{-# LANGUAGE OverloadedStrings #-}
-- | Obtaining information about packages over THE INTERNET!
module Futhark.Pkg.Info
  ( -- * Package info
    PkgInfo(..)
  , lookupPkgRev
  , pkgInfo
  , PkgRevInfo (..)
  , GetManifest (getManifest)
  , downloadZipball

    -- * Package registry
  , PkgRegistry
  , MonadPkgRegistry(..)
  , lookupPackage
  , lookupPackageRev
  , lookupNewestRev
  )
  where

import Control.Monad.IO.Class
import Data.Maybe
import Data.IORef
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Encoding as T
import Data.List (foldl', intersperse)
import qualified System.FilePath.Posix as Posix
import System.Exit
import System.IO

import qualified Codec.Archive.Zip as Zip
import Data.Time (UTCTime, UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import System.Process.ByteString (readProcessWithExitCode)

import Futhark.Pkg.Types
import Futhark.Util.Log
import Futhark.Util (maybeHead)

-- | Download URL via shelling out to @curl@.
curl :: String -> IO (Either String BS.ByteString)
curl :: String -> IO (Either String ByteString)
curl String
url = do
  (ExitCode
code, ByteString
out, ByteString
err) <-
    -- The -L option follows HTTP redirects.
    IO (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
 -> IO (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
"curl" [String
"-L", String
url] ByteString
forall a. Monoid a => a
mempty
  case ExitCode
code of
    ExitFailure Int
127 ->
      Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ByteString -> IO (Either String ByteString))
-> Either String ByteString -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$
      String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String
"curl", String
"-L", String
url] String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' failed (program not found?)."
    ExitFailure Int
_ -> do
      IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPutStr Handle
stderr ByteString
err
      Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ByteString -> IO (Either String ByteString))
-> Either String ByteString -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String
"curl", String
"-L", String
url] String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' failed."
    ExitCode
ExitSuccess ->
      Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ByteString -> IO (Either String ByteString))
-> Either String ByteString -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
out

-- | The manifest is stored as a monadic action, because we want to
-- fetch them on-demand.  It would be a waste to fetch it information
-- for every version of every package if we only actually need a small
-- subset of them.
newtype GetManifest m = GetManifest { GetManifest m -> m PkgManifest
getManifest :: m PkgManifest }

instance Show (GetManifest m) where
  show :: GetManifest m -> String
show GetManifest m
_ = String
"#<revdeps>"

instance Eq (GetManifest m) where
  GetManifest m
_ == :: GetManifest m -> GetManifest m -> Bool
== GetManifest m
_ = Bool
True

-- | Information about a version of a single package.  The version
-- number is stored separately.
data PkgRevInfo m = PkgRevInfo { PkgRevInfo m -> Text
pkgRevZipballUrl :: T.Text
                               , PkgRevInfo m -> String
pkgRevZipballDir :: FilePath
                                 -- ^ The directory inside the zipball
                                 -- containing the 'lib' directory, in
                                 -- which the package files themselves
                                 -- are stored (Based on the package
                                 -- path).
                               , PkgRevInfo m -> Text
pkgRevCommit :: T.Text
                                 -- ^ The commit ID can be used for
                                 -- verification ("freezing"), by
                                 -- storing what it was at the time this
                                 -- version was last selected.
                               , PkgRevInfo m -> GetManifest m
pkgRevGetManifest :: GetManifest m
                               , PkgRevInfo m -> UTCTime
pkgRevTime :: UTCTime
                                 -- ^ Timestamp for when the revision
                                 -- was made (rarely used).
                               }
                  deriving (PkgRevInfo m -> PkgRevInfo m -> Bool
(PkgRevInfo m -> PkgRevInfo m -> Bool)
-> (PkgRevInfo m -> PkgRevInfo m -> Bool) -> Eq (PkgRevInfo m)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (m :: * -> *). PkgRevInfo m -> PkgRevInfo m -> Bool
/= :: PkgRevInfo m -> PkgRevInfo m -> Bool
$c/= :: forall (m :: * -> *). PkgRevInfo m -> PkgRevInfo m -> Bool
== :: PkgRevInfo m -> PkgRevInfo m -> Bool
$c== :: forall (m :: * -> *). PkgRevInfo m -> PkgRevInfo m -> Bool
Eq, Int -> PkgRevInfo m -> String -> String
[PkgRevInfo m] -> String -> String
PkgRevInfo m -> String
(Int -> PkgRevInfo m -> String -> String)
-> (PkgRevInfo m -> String)
-> ([PkgRevInfo m] -> String -> String)
-> Show (PkgRevInfo m)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall (m :: * -> *). Int -> PkgRevInfo m -> String -> String
forall (m :: * -> *). [PkgRevInfo m] -> String -> String
forall (m :: * -> *). PkgRevInfo m -> String
showList :: [PkgRevInfo m] -> String -> String
$cshowList :: forall (m :: * -> *). [PkgRevInfo m] -> String -> String
show :: PkgRevInfo m -> String
$cshow :: forall (m :: * -> *). PkgRevInfo m -> String
showsPrec :: Int -> PkgRevInfo m -> String -> String
$cshowsPrec :: forall (m :: * -> *). Int -> PkgRevInfo m -> String -> String
Show)

-- | Create memoisation around a 'GetManifest' action to ensure that
-- multiple inspections of the same revisions will not result in
-- potentially expensive network round trips.
memoiseGetManifest :: MonadIO m => GetManifest m -> m (GetManifest m)
memoiseGetManifest :: GetManifest m -> m (GetManifest m)
memoiseGetManifest (GetManifest m PkgManifest
m) = do
  IORef (Maybe PkgManifest)
ref <- IO (IORef (Maybe PkgManifest)) -> m (IORef (Maybe PkgManifest))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe PkgManifest)) -> m (IORef (Maybe PkgManifest)))
-> IO (IORef (Maybe PkgManifest)) -> m (IORef (Maybe PkgManifest))
forall a b. (a -> b) -> a -> b
$ Maybe PkgManifest -> IO (IORef (Maybe PkgManifest))
forall a. a -> IO (IORef a)
newIORef Maybe PkgManifest
forall a. Maybe a
Nothing
  GetManifest m -> m (GetManifest m)
forall (m :: * -> *) a. Monad m => a -> m a
return (GetManifest m -> m (GetManifest m))
-> GetManifest m -> m (GetManifest m)
forall a b. (a -> b) -> a -> b
$ m PkgManifest -> GetManifest m
forall (m :: * -> *). m PkgManifest -> GetManifest m
GetManifest (m PkgManifest -> GetManifest m) -> m PkgManifest -> GetManifest m
forall a b. (a -> b) -> a -> b
$ do
    Maybe PkgManifest
v <- IO (Maybe PkgManifest) -> m (Maybe PkgManifest)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe PkgManifest) -> m (Maybe PkgManifest))
-> IO (Maybe PkgManifest) -> m (Maybe PkgManifest)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe PkgManifest) -> IO (Maybe PkgManifest)
forall a. IORef a -> IO a
readIORef IORef (Maybe PkgManifest)
ref
    case Maybe PkgManifest
v of Just PkgManifest
v' -> PkgManifest -> m PkgManifest
forall (m :: * -> *) a. Monad m => a -> m a
return PkgManifest
v'
              Maybe PkgManifest
Nothing -> do
                PkgManifest
v' <- m PkgManifest
m
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe PkgManifest) -> Maybe PkgManifest -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe PkgManifest)
ref (Maybe PkgManifest -> IO ()) -> Maybe PkgManifest -> IO ()
forall a b. (a -> b) -> a -> b
$ PkgManifest -> Maybe PkgManifest
forall a. a -> Maybe a
Just PkgManifest
v'
                PkgManifest -> m PkgManifest
forall (m :: * -> *) a. Monad m => a -> m a
return PkgManifest
v'

downloadZipball :: (MonadLogger m, MonadIO m, MonadFail m) =>
                   T.Text -> m Zip.Archive
downloadZipball :: Text -> m Archive
downloadZipball Text
url = do
  String -> m ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Downloading " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
url

  let bad :: String -> m a
bad = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> (String -> String) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"When downloading " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
url String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ")String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)
  Either String ByteString
http <- IO (Either String ByteString) -> m (Either String ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String ByteString) -> m (Either String ByteString))
-> IO (Either String ByteString) -> m (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either String ByteString)
curl (String -> IO (Either String ByteString))
-> String -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url
  case Either String ByteString
http of
    Left String
e -> String -> m Archive
forall a. String -> m a
bad String
e
    Right ByteString
r ->
      case ByteString -> Either String Archive
Zip.toArchiveOrFail (ByteString -> Either String Archive)
-> ByteString -> Either String Archive
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
r of
        Left String
e -> String -> m Archive
forall a. String -> m a
bad (String -> m Archive) -> String -> m Archive
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
e
        Right Archive
a -> Archive -> m Archive
forall (m :: * -> *) a. Monad m => a -> m a
return Archive
a

-- | Information about a package.  The name of the package is stored
-- separately.
data PkgInfo m = PkgInfo { PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions :: M.Map SemVer (PkgRevInfo m)
                         , PkgInfo m -> Maybe Text -> m (PkgRevInfo m)
pkgLookupCommit :: Maybe T.Text -> m (PkgRevInfo m)
                           -- ^ Look up information about a specific
                           -- commit, or HEAD in case of Nothing.
                         }

lookupPkgRev :: SemVer -> PkgInfo m -> Maybe (PkgRevInfo m)
lookupPkgRev :: SemVer -> PkgInfo m -> Maybe (PkgRevInfo m)
lookupPkgRev SemVer
v = SemVer -> Map SemVer (PkgRevInfo m) -> Maybe (PkgRevInfo m)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SemVer
v (Map SemVer (PkgRevInfo m) -> Maybe (PkgRevInfo m))
-> (PkgInfo m -> Map SemVer (PkgRevInfo m))
-> PkgInfo m
-> Maybe (PkgRevInfo m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgInfo m -> Map SemVer (PkgRevInfo m)
forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions

majorRevOfPkg :: PkgPath -> (PkgPath, [Word])
majorRevOfPkg :: Text -> (Text, [Word])
majorRevOfPkg Text
p =
  case Text -> Text -> [Text]
T.splitOn Text
"@" Text
p of
    [Text
p', Text
v] | [(Word
v', String
"")] <- ReadS Word
forall a. Read a => ReadS a
reads ReadS Word -> ReadS Word
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
v -> (Text
p', [Word
v'])
    [Text]
_                                          -> (Text
p, [Word
0, Word
1])

-- | Retrieve information about a package based on its package path.
-- This uses Semantic Import Versioning when interacting with
-- repositories.  For example, a package @github.com/user/repo@ will
-- match version 0.* or 1.* tags only, a package
-- @github.com/user/repo/v2@ will match 2.* tags, and so forth..
pkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) =>
           PkgPath -> m (Either T.Text (PkgInfo m))
pkgInfo :: Text -> m (Either Text (PkgInfo m))
pkgInfo Text
path
  | [Text
"github.com", Text
owner, Text
repo] <- Text -> Text -> [Text]
T.splitOn Text
"/" Text
path =
      let (Text
repo', [Word]
vs) = Text -> (Text, [Word])
majorRevOfPkg Text
repo
      in Text -> Text -> [Word] -> m (Either Text (PkgInfo m))
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text -> Text -> [Word] -> m (Either Text (PkgInfo m))
ghPkgInfo Text
owner Text
repo' [Word]
vs
  | Text
"github.com": Text
owner : Text
repo : [Text]
_ <- Text -> Text -> [Text]
T.splitOn Text
"/" Text
path =
      Either Text (PkgInfo m) -> m (Either Text (PkgInfo m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (PkgInfo m) -> m (Either Text (PkgInfo m)))
-> Either Text (PkgInfo m) -> m (Either Text (PkgInfo m))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (PkgInfo m)
forall a b. a -> Either a b
Left (Text -> Either Text (PkgInfo m))
-> Text -> Either Text (PkgInfo m)
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n"
      [Text
nope, Text
"Do you perhaps mean 'github.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'?"]
  | [Text
"gitlab.com", Text
owner, Text
repo] <- Text -> Text -> [Text]
T.splitOn Text
"/" Text
path =
      let (Text
repo', [Word]
vs) = Text -> (Text, [Word])
majorRevOfPkg Text
repo
      in Text -> Text -> [Word] -> m (Either Text (PkgInfo m))
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text -> Text -> [Word] -> m (Either Text (PkgInfo m))
glPkgInfo Text
owner Text
repo' [Word]
vs
  | Text
"gitlab.com": Text
owner : Text
repo : [Text]
_ <- Text -> Text -> [Text]
T.splitOn Text
"/" Text
path =
      Either Text (PkgInfo m) -> m (Either Text (PkgInfo m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (PkgInfo m) -> m (Either Text (PkgInfo m)))
-> Either Text (PkgInfo m) -> m (Either Text (PkgInfo m))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (PkgInfo m)
forall a b. a -> Either a b
Left (Text -> Either Text (PkgInfo m))
-> Text -> Either Text (PkgInfo m)
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n"
      [Text
nope, Text
"Do you perhaps mean 'gitlab.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'?"]
  | Bool
otherwise =
      Either Text (PkgInfo m) -> m (Either Text (PkgInfo m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (PkgInfo m) -> m (Either Text (PkgInfo m)))
-> Either Text (PkgInfo m) -> m (Either Text (PkgInfo m))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (PkgInfo m)
forall a b. a -> Either a b
Left Text
nope
  where nope :: Text
nope = Text
"Unable to handle package paths of the form '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"

-- For GitHub, we unfortunately cannot use the (otherwise very nice)
-- GitHub web API, because it is rate-limited to 60 requests per hour
-- for non-authenticated users.  Instead we fall back to a combination
-- of calling 'git' directly and retrieving things from the GitHub
-- webserver, which is not rate-limited.  This approach is also used
-- by other systems (Go most notably), so we should not be stepping on
-- any toes.

gitCmd :: (MonadIO m, MonadFail m) => [String] -> m BS.ByteString
gitCmd :: [String] -> m ByteString
gitCmd [String]
opts = do
  (ExitCode
code, ByteString
out, ByteString
err) <- IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, ByteString, ByteString)
 -> m (ExitCode, ByteString, ByteString))
-> IO (ExitCode, ByteString, ByteString)
-> m (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
"git" [String]
opts ByteString
forall a. Monoid a => a
mempty
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPutStr Handle
stderr ByteString
err
  case ExitCode
code of
    ExitFailure Int
127 -> String -> m ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords (String
"git" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
opts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' failed (program not found?)."
    ExitFailure Int
_ -> String -> m ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords (String
"git" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
opts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' failed."
    ExitCode
ExitSuccess -> ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
out

-- The GitLab and GitHub interactions are very similar, so we define a
-- couple of generic functions that are used to implement support for
-- both.

ghglRevGetManifest :: (MonadIO m, MonadLogger m, MonadFail m) =>
                      T.Text -> T.Text -> T.Text -> T.Text -> GetManifest m
ghglRevGetManifest :: Text -> Text -> Text -> Text -> GetManifest m
ghglRevGetManifest Text
url Text
owner Text
repo Text
tag = m PkgManifest -> GetManifest m
forall (m :: * -> *). m PkgManifest -> GetManifest m
GetManifest (m PkgManifest -> GetManifest m) -> m PkgManifest -> GetManifest m
forall a b. (a -> b) -> a -> b
$ do
  Text -> m ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Downloading package manifest from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
url

  let path :: String
path = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
             Text
tag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
futharkPkg
      msg :: String -> String
msg = ((String
"When reading " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ")String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)
  Either String ByteString
http <- IO (Either String ByteString) -> m (Either String ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String ByteString) -> m (Either String ByteString))
-> IO (Either String ByteString) -> m (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either String ByteString)
curl (String -> IO (Either String ByteString))
-> String -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url
  case Either String ByteString
http of
    Left String
e -> String -> m PkgManifest
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
    Right ByteString
r' ->
      case ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
r' of
        Left UnicodeException
e -> String -> m PkgManifest
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m PkgManifest) -> String -> m PkgManifest
forall a b. (a -> b) -> a -> b
$ String -> String
msg (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
e
        Right Text
s ->
          case String -> Text -> Either (ParseErrorBundle Text Void) PkgManifest
parsePkgManifest String
path Text
s of
            Left ParseErrorBundle Text Void
e -> String -> m PkgManifest
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m PkgManifest) -> String -> m PkgManifest
forall a b. (a -> b) -> a -> b
$ String -> String
msg (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void -> String
forall s e.
(Stream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
e
            Right PkgManifest
pm -> PkgManifest -> m PkgManifest
forall (m :: * -> *) a. Monad m => a -> m a
return PkgManifest
pm

ghglLookupCommit :: (MonadIO m, MonadLogger m, MonadFail m) =>
                    T.Text -> T.Text -> (T.Text -> T.Text)
                 -> T.Text -> T.Text -> T.Text -> T.Text -> T.Text -> m (PkgRevInfo m)
ghglLookupCommit :: Text
-> Text
-> (Text -> Text)
-> Text
-> Text
-> Text
-> Text
-> Text
-> m (PkgRevInfo m)
ghglLookupCommit Text
archive_url Text
manifest_url Text -> Text
mk_zip_dir Text
owner Text
repo Text
d Text
ref Text
hash = do
  GetManifest m
gd <- GetManifest m -> m (GetManifest m)
forall (m :: * -> *).
MonadIO m =>
GetManifest m -> m (GetManifest m)
memoiseGetManifest (GetManifest m -> m (GetManifest m))
-> GetManifest m -> m (GetManifest m)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text -> GetManifest m
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text -> Text -> Text -> Text -> GetManifest m
ghglRevGetManifest Text
manifest_url Text
owner Text
repo Text
ref
  let dir :: String
dir = String -> String
Posix.addTrailingPathSeparator (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
mk_zip_dir Text
d
  UTCTime
time <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime -- FIXME
  PkgRevInfo m -> m (PkgRevInfo m)
forall (m :: * -> *) a. Monad m => a -> m a
return (PkgRevInfo m -> m (PkgRevInfo m))
-> PkgRevInfo m -> m (PkgRevInfo m)
forall a b. (a -> b) -> a -> b
$ Text -> String -> Text -> GetManifest m -> UTCTime -> PkgRevInfo m
forall (m :: * -> *).
Text -> String -> Text -> GetManifest m -> UTCTime -> PkgRevInfo m
PkgRevInfo Text
archive_url String
dir Text
hash GetManifest m
gd UTCTime
time

ghglPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) =>
               T.Text
            -> (T.Text -> T.Text) -> (T.Text -> T.Text)  -> (T.Text -> T.Text)
            -> T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m))
ghglPkgInfo :: Text
-> (Text -> Text)
-> (Text -> Text)
-> (Text -> Text)
-> Text
-> Text
-> [Word]
-> m (Either Text (PkgInfo m))
ghglPkgInfo Text
repo_url Text -> Text
mk_archive_url Text -> Text
mk_manifest_url Text -> Text
mk_zip_dir Text
owner Text
repo [Word]
versions = do
  Text -> m ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Retrieving list of tags from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo_url
  [Text]
remote_lines <- Text -> [Text]
T.lines (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> [Text]) -> m ByteString -> m [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> m ByteString
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
[String] -> m ByteString
gitCmd [String
"ls-remote", Text -> String
T.unpack Text
repo_url]

  Text
head_ref <- m Text -> (Text -> m Text) -> Maybe Text -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Text) -> String -> m Text
forall a b. (a -> b) -> a -> b
$ String
"Cannot find HEAD ref for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
repo_url) Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> m Text) -> Maybe Text -> m Text
forall a b. (a -> b) -> a -> b
$
              [Text] -> Maybe Text
forall a. [a] -> Maybe a
maybeHead ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe Text) -> [Text] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Text
isHeadRef [Text]
remote_lines
  let def :: Maybe Text -> Text
def = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
head_ref

  Map SemVer (PkgRevInfo m)
rev_info <- [(SemVer, PkgRevInfo m)] -> Map SemVer (PkgRevInfo m)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(SemVer, PkgRevInfo m)] -> Map SemVer (PkgRevInfo m))
-> ([Maybe (SemVer, PkgRevInfo m)] -> [(SemVer, PkgRevInfo m)])
-> [Maybe (SemVer, PkgRevInfo m)]
-> Map SemVer (PkgRevInfo m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (SemVer, PkgRevInfo m)] -> [(SemVer, PkgRevInfo m)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (SemVer, PkgRevInfo m)] -> Map SemVer (PkgRevInfo m))
-> m [Maybe (SemVer, PkgRevInfo m)]
-> m (Map SemVer (PkgRevInfo m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> m (Maybe (SemVer, PkgRevInfo m)))
-> [Text] -> m [Maybe (SemVer, PkgRevInfo m)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> m (Maybe (SemVer, PkgRevInfo m))
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text -> m (Maybe (SemVer, PkgRevInfo m))
revInfo [Text]
remote_lines

  Either Text (PkgInfo m) -> m (Either Text (PkgInfo m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (PkgInfo m) -> m (Either Text (PkgInfo m)))
-> Either Text (PkgInfo m) -> m (Either Text (PkgInfo m))
forall a b. (a -> b) -> a -> b
$ PkgInfo m -> Either Text (PkgInfo m)
forall a b. b -> Either a b
Right (PkgInfo m -> Either Text (PkgInfo m))
-> PkgInfo m -> Either Text (PkgInfo m)
forall a b. (a -> b) -> a -> b
$ Map SemVer (PkgRevInfo m)
-> (Maybe Text -> m (PkgRevInfo m)) -> PkgInfo m
forall (m :: * -> *).
Map SemVer (PkgRevInfo m)
-> (Maybe Text -> m (PkgRevInfo m)) -> PkgInfo m
PkgInfo Map SemVer (PkgRevInfo m)
rev_info ((Maybe Text -> m (PkgRevInfo m)) -> PkgInfo m)
-> (Maybe Text -> m (PkgRevInfo m)) -> PkgInfo m
forall a b. (a -> b) -> a -> b
$ \Maybe Text
r ->
    Text
-> Text
-> (Text -> Text)
-> Text
-> Text
-> Text
-> Text
-> Text
-> m (PkgRevInfo m)
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text
-> Text
-> (Text -> Text)
-> Text
-> Text
-> Text
-> Text
-> Text
-> m (PkgRevInfo m)
ghglLookupCommit
    (Text -> Text
mk_archive_url (Maybe Text -> Text
def Maybe Text
r)) (Text -> Text
mk_manifest_url (Maybe Text -> Text
def Maybe Text
r)) Text -> Text
mk_zip_dir
    Text
owner Text
repo (Maybe Text -> Text
def Maybe Text
r) (Maybe Text -> Text
def Maybe Text
r) (Maybe Text -> Text
def Maybe Text
r)
  where isHeadRef :: Text -> Maybe Text
isHeadRef Text
l
          | [Text
hash, Text
"HEAD"] <- Text -> [Text]
T.words Text
l = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
hash
          | Bool
otherwise                   = Maybe Text
forall a. Maybe a
Nothing

        revInfo :: Text -> m (Maybe (SemVer, PkgRevInfo m))
revInfo Text
l
          | [Text
hash, Text
ref] <- Text -> [Text]
T.words Text
l,
            [Text
"refs", Text
"tags", Text
t] <- Text -> Text -> [Text]
T.splitOn Text
"/" Text
ref,
            Text
"v" Text -> Text -> Bool
`T.isPrefixOf` Text
t,
            Right SemVer
v <- Text -> Either (ParseErrorBundle Text Void) SemVer
semver (Text -> Either (ParseErrorBundle Text Void) SemVer)
-> Text -> Either (ParseErrorBundle Text Void) SemVer
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
t,
            SemVer -> Word
_svMajor SemVer
v Word -> [Word] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word]
versions = do
              PkgRevInfo m
pinfo <- Text
-> Text
-> (Text -> Text)
-> Text
-> Text
-> Text
-> Text
-> Text
-> m (PkgRevInfo m)
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text
-> Text
-> (Text -> Text)
-> Text
-> Text
-> Text
-> Text
-> Text
-> m (PkgRevInfo m)
ghglLookupCommit
                       (Text -> Text
mk_archive_url Text
t) (Text -> Text
mk_manifest_url Text
t) Text -> Text
mk_zip_dir
                       Text
owner Text
repo (SemVer -> Text
prettySemVer SemVer
v) Text
t Text
hash
              Maybe (SemVer, PkgRevInfo m) -> m (Maybe (SemVer, PkgRevInfo m))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SemVer, PkgRevInfo m) -> m (Maybe (SemVer, PkgRevInfo m)))
-> Maybe (SemVer, PkgRevInfo m) -> m (Maybe (SemVer, PkgRevInfo m))
forall a b. (a -> b) -> a -> b
$ (SemVer, PkgRevInfo m) -> Maybe (SemVer, PkgRevInfo m)
forall a. a -> Maybe a
Just (SemVer
v, PkgRevInfo m
pinfo)
          | Bool
otherwise = Maybe (SemVer, PkgRevInfo m) -> m (Maybe (SemVer, PkgRevInfo m))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (SemVer, PkgRevInfo m)
forall a. Maybe a
Nothing

ghPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) =>
             T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m))
ghPkgInfo :: Text -> Text -> [Word] -> m (Either Text (PkgInfo m))
ghPkgInfo Text
owner Text
repo [Word]
versions =
  Text
-> (Text -> Text)
-> (Text -> Text)
-> (Text -> Text)
-> Text
-> Text
-> [Word]
-> m (Either Text (PkgInfo m))
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text
-> (Text -> Text)
-> (Text -> Text)
-> (Text -> Text)
-> Text
-> Text
-> [Word]
-> m (Either Text (PkgInfo m))
ghglPkgInfo Text
repo_url Text -> Text
mk_archive_url Text -> Text
mk_manifest_url Text -> Text
mk_zip_dir
  Text
owner Text
repo [Word]
versions
  where repo_url :: Text
repo_url = Text
"https://github.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo
        mk_archive_url :: Text -> Text
mk_archive_url Text
r = Text
repo_url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/archive/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".zip"
        mk_manifest_url :: Text -> Text
mk_manifest_url Text
r = Text
"https://raw.githubusercontent.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Text
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
futharkPkg
        mk_zip_dir :: Text -> Text
mk_zip_dir Text
r = Text
repo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r

glPkgInfo :: (MonadIO m, MonadLogger m, MonadFail m) =>
             T.Text -> T.Text -> [Word] -> m (Either T.Text (PkgInfo m))
glPkgInfo :: Text -> Text -> [Word] -> m (Either Text (PkgInfo m))
glPkgInfo Text
owner Text
repo [Word]
versions =
  Text
-> (Text -> Text)
-> (Text -> Text)
-> (Text -> Text)
-> Text
-> Text
-> [Word]
-> m (Either Text (PkgInfo m))
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text
-> (Text -> Text)
-> (Text -> Text)
-> (Text -> Text)
-> Text
-> Text
-> [Word]
-> m (Either Text (PkgInfo m))
ghglPkgInfo Text
repo_url Text -> Text
mk_archive_url Text -> Text
mk_manifest_url Text -> Text
mk_zip_dir
  Text
owner Text
repo [Word]
versions
  where base_url :: Text
base_url = Text
"https://gitlab.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo
        repo_url :: Text
repo_url = Text
base_url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".git"
        mk_archive_url :: Text -> Text
mk_archive_url Text
r = Text
base_url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/-/archive/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                           Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".zip"
        mk_manifest_url :: Text -> Text
mk_manifest_url Text
r = Text
base_url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/raw/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Text
r Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
futharkPkg
        mk_zip_dir :: Text -> Text
mk_zip_dir Text
r
          | Right SemVer
_ <- Text -> Either (ParseErrorBundle Text Void) SemVer
semver Text
r = Text
repo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-v" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r
          | Bool
otherwise = Text
repo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r

-- | A package registry is a mapping from package paths to information
-- about the package.  It is unlikely that any given registry is
-- global; rather small registries are constructed on-demand based on
-- the package paths referenced by the user, and may also be combined
-- monoidically.  In essence, the PkgRegistry is just a cache.
newtype PkgRegistry m = PkgRegistry (M.Map PkgPath (PkgInfo m))

instance Semigroup (PkgRegistry m) where
  PkgRegistry Map Text (PkgInfo m)
x <> :: PkgRegistry m -> PkgRegistry m -> PkgRegistry m
<> PkgRegistry Map Text (PkgInfo m)
y = Map Text (PkgInfo m) -> PkgRegistry m
forall (m :: * -> *). Map Text (PkgInfo m) -> PkgRegistry m
PkgRegistry (Map Text (PkgInfo m) -> PkgRegistry m)
-> Map Text (PkgInfo m) -> PkgRegistry m
forall a b. (a -> b) -> a -> b
$ Map Text (PkgInfo m)
x Map Text (PkgInfo m)
-> Map Text (PkgInfo m) -> Map Text (PkgInfo m)
forall a. Semigroup a => a -> a -> a
<> Map Text (PkgInfo m)
y

instance Monoid (PkgRegistry m) where
  mempty :: PkgRegistry m
mempty = Map Text (PkgInfo m) -> PkgRegistry m
forall (m :: * -> *). Map Text (PkgInfo m) -> PkgRegistry m
PkgRegistry Map Text (PkgInfo m)
forall a. Monoid a => a
mempty

lookupKnownPackage :: PkgPath -> PkgRegistry m -> Maybe (PkgInfo m)
lookupKnownPackage :: Text -> PkgRegistry m -> Maybe (PkgInfo m)
lookupKnownPackage Text
p (PkgRegistry Map Text (PkgInfo m)
m) = Text -> Map Text (PkgInfo m) -> Maybe (PkgInfo m)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
p Map Text (PkgInfo m)
m

-- | Monads that support a stateful package registry.  These are also
-- required to be instances of 'MonadIO' because most package registry
-- operations involve network operations.
class (MonadIO m, MonadLogger m, MonadFail m) => MonadPkgRegistry m where
  getPkgRegistry :: m (PkgRegistry m)
  putPkgRegistry :: PkgRegistry m -> m ()
  modifyPkgRegistry :: (PkgRegistry m -> PkgRegistry m) -> m ()
  modifyPkgRegistry PkgRegistry m -> PkgRegistry m
f = PkgRegistry m -> m ()
forall (m :: * -> *). MonadPkgRegistry m => PkgRegistry m -> m ()
putPkgRegistry (PkgRegistry m -> m ())
-> (PkgRegistry m -> PkgRegistry m) -> PkgRegistry m -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgRegistry m -> PkgRegistry m
f (PkgRegistry m -> m ()) -> m (PkgRegistry m) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (PkgRegistry m)
forall (m :: * -> *). MonadPkgRegistry m => m (PkgRegistry m)
getPkgRegistry

lookupPackage :: MonadPkgRegistry m =>
                 PkgPath -> m (PkgInfo m)
lookupPackage :: Text -> m (PkgInfo m)
lookupPackage Text
p = do
  r :: PkgRegistry m
r@(PkgRegistry Map Text (PkgInfo m)
m) <- m (PkgRegistry m)
forall (m :: * -> *). MonadPkgRegistry m => m (PkgRegistry m)
getPkgRegistry
  case Text -> PkgRegistry m -> Maybe (PkgInfo m)
forall (m :: * -> *). Text -> PkgRegistry m -> Maybe (PkgInfo m)
lookupKnownPackage Text
p PkgRegistry m
r of
    Just PkgInfo m
info ->
      PkgInfo m -> m (PkgInfo m)
forall (m :: * -> *) a. Monad m => a -> m a
return PkgInfo m
info
    Maybe (PkgInfo m)
Nothing -> do
      Either Text (PkgInfo m)
e <- Text -> m (Either Text (PkgInfo m))
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text -> m (Either Text (PkgInfo m))
pkgInfo Text
p
      case Either Text (PkgInfo m)
e of
        Left Text
e' -> String -> m (PkgInfo m)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (PkgInfo m)) -> String -> m (PkgInfo m)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
e'
        Right PkgInfo m
pinfo -> do
          PkgRegistry m -> m ()
forall (m :: * -> *). MonadPkgRegistry m => PkgRegistry m -> m ()
putPkgRegistry (PkgRegistry m -> m ()) -> PkgRegistry m -> m ()
forall a b. (a -> b) -> a -> b
$ Map Text (PkgInfo m) -> PkgRegistry m
forall (m :: * -> *). Map Text (PkgInfo m) -> PkgRegistry m
PkgRegistry (Map Text (PkgInfo m) -> PkgRegistry m)
-> Map Text (PkgInfo m) -> PkgRegistry m
forall a b. (a -> b) -> a -> b
$ Text -> PkgInfo m -> Map Text (PkgInfo m) -> Map Text (PkgInfo m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
p PkgInfo m
pinfo Map Text (PkgInfo m)
m
          PkgInfo m -> m (PkgInfo m)
forall (m :: * -> *) a. Monad m => a -> m a
return PkgInfo m
pinfo

lookupPackageCommit :: MonadPkgRegistry m =>
                       PkgPath -> Maybe T.Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit :: Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit Text
p Maybe Text
ref = do
  PkgInfo m
pinfo <- Text -> m (PkgInfo m)
forall (m :: * -> *). MonadPkgRegistry m => Text -> m (PkgInfo m)
lookupPackage Text
p
  PkgRevInfo m
rev_info <- PkgInfo m -> Maybe Text -> m (PkgRevInfo m)
forall (m :: * -> *). PkgInfo m -> Maybe Text -> m (PkgRevInfo m)
pkgLookupCommit PkgInfo m
pinfo Maybe Text
ref
  let timestamp :: Text
timestamp = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%d%H%M%S" (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$
                  PkgRevInfo m -> UTCTime
forall (m :: * -> *). PkgRevInfo m -> UTCTime
pkgRevTime PkgRevInfo m
rev_info
      v :: SemVer
v = Text -> Text -> SemVer
commitVersion Text
timestamp (Text -> SemVer) -> Text -> SemVer
forall a b. (a -> b) -> a -> b
$ PkgRevInfo m -> Text
forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevCommit PkgRevInfo m
rev_info
      pinfo' :: PkgInfo m
pinfo' = PkgInfo m
pinfo { pkgVersions :: Map SemVer (PkgRevInfo m)
pkgVersions = SemVer
-> PkgRevInfo m
-> Map SemVer (PkgRevInfo m)
-> Map SemVer (PkgRevInfo m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SemVer
v PkgRevInfo m
rev_info (Map SemVer (PkgRevInfo m) -> Map SemVer (PkgRevInfo m))
-> Map SemVer (PkgRevInfo m) -> Map SemVer (PkgRevInfo m)
forall a b. (a -> b) -> a -> b
$ PkgInfo m -> Map SemVer (PkgRevInfo m)
forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions PkgInfo m
pinfo }
  (PkgRegistry m -> PkgRegistry m) -> m ()
forall (m :: * -> *).
MonadPkgRegistry m =>
(PkgRegistry m -> PkgRegistry m) -> m ()
modifyPkgRegistry ((PkgRegistry m -> PkgRegistry m) -> m ())
-> (PkgRegistry m -> PkgRegistry m) -> m ()
forall a b. (a -> b) -> a -> b
$ \(PkgRegistry Map Text (PkgInfo m)
m) ->
    Map Text (PkgInfo m) -> PkgRegistry m
forall (m :: * -> *). Map Text (PkgInfo m) -> PkgRegistry m
PkgRegistry (Map Text (PkgInfo m) -> PkgRegistry m)
-> Map Text (PkgInfo m) -> PkgRegistry m
forall a b. (a -> b) -> a -> b
$ Text -> PkgInfo m -> Map Text (PkgInfo m) -> Map Text (PkgInfo m)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
p PkgInfo m
pinfo' Map Text (PkgInfo m)
m
  (SemVer, PkgRevInfo m) -> m (SemVer, PkgRevInfo m)
forall (m :: * -> *) a. Monad m => a -> m a
return (SemVer
v, PkgRevInfo m
rev_info)

-- | Look up information about a specific version of a package.
lookupPackageRev :: MonadPkgRegistry m =>
                    PkgPath -> SemVer -> m (PkgRevInfo m)
lookupPackageRev :: Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev Text
p SemVer
v
  | Just Text
commit <- SemVer -> Maybe Text
isCommitVersion SemVer
v =
      (SemVer, PkgRevInfo m) -> PkgRevInfo m
forall a b. (a, b) -> b
snd ((SemVer, PkgRevInfo m) -> PkgRevInfo m)
-> m (SemVer, PkgRevInfo m) -> m (PkgRevInfo m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
forall (m :: * -> *).
MonadPkgRegistry m =>
Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit Text
p (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
commit)
  | Bool
otherwise = do
  PkgInfo m
pinfo <- Text -> m (PkgInfo m)
forall (m :: * -> *). MonadPkgRegistry m => Text -> m (PkgInfo m)
lookupPackage Text
p
  case SemVer -> PkgInfo m -> Maybe (PkgRevInfo m)
forall (m :: * -> *). SemVer -> PkgInfo m -> Maybe (PkgRevInfo m)
lookupPkgRev SemVer
v PkgInfo m
pinfo of
    Maybe (PkgRevInfo m)
Nothing ->
      let versions :: Text
versions = case Map SemVer (PkgRevInfo m) -> [SemVer]
forall k a. Map k a -> [k]
M.keys (Map SemVer (PkgRevInfo m) -> [SemVer])
-> Map SemVer (PkgRevInfo m) -> [SemVer]
forall a b. (a -> b) -> a -> b
$ PkgInfo m -> Map SemVer (PkgRevInfo m)
forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions PkgInfo m
pinfo of
                       [] -> Text
"Package " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no versions.  Invalid package path?"
                       [SemVer]
ks -> Text
"Known versions: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                             [Text] -> Text
T.concat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", " ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (SemVer -> Text) -> [SemVer] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map SemVer -> Text
prettySemVer [SemVer]
ks)
          major :: Text
major | (Text
_, [Word]
vs) <- Text -> (Text, [Word])
majorRevOfPkg Text
p,
                  SemVer -> Word
_svMajor SemVer
v Word -> [Word] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Word]
vs =
                    Text
"\nFor major version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word -> String
forall a. Show a => a -> String
show (SemVer -> Word
_svMajor SemVer
v)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    Text
", use package path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Word -> String
forall a. Show a => a -> String
show (SemVer -> Word
_svMajor SemVer
v))
                | Bool
otherwise = Text
forall a. Monoid a => a
mempty
      in String -> m (PkgRevInfo m)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (PkgRevInfo m)) -> String -> m (PkgRevInfo m)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
         Text
"package " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not have a version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
         Text
versions Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
major
    Just PkgRevInfo m
v' -> PkgRevInfo m -> m (PkgRevInfo m)
forall (m :: * -> *) a. Monad m => a -> m a
return PkgRevInfo m
v'

-- | Find the newest version of a package.
lookupNewestRev :: MonadPkgRegistry m =>
                   PkgPath -> m SemVer
lookupNewestRev :: Text -> m SemVer
lookupNewestRev Text
p = do
  PkgInfo m
pinfo <- Text -> m (PkgInfo m)
forall (m :: * -> *). MonadPkgRegistry m => Text -> m (PkgInfo m)
lookupPackage Text
p
  case Map SemVer (PkgRevInfo m) -> [SemVer]
forall k a. Map k a -> [k]
M.keys (Map SemVer (PkgRevInfo m) -> [SemVer])
-> Map SemVer (PkgRevInfo m) -> [SemVer]
forall a b. (a -> b) -> a -> b
$ PkgInfo m -> Map SemVer (PkgRevInfo m)
forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions PkgInfo m
pinfo of
    [] -> do
      Text -> m ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Package " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no released versions.  Using HEAD."
      (SemVer, PkgRevInfo m) -> SemVer
forall a b. (a, b) -> a
fst ((SemVer, PkgRevInfo m) -> SemVer)
-> m (SemVer, PkgRevInfo m) -> m SemVer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
forall (m :: * -> *).
MonadPkgRegistry m =>
Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit Text
p Maybe Text
forall a. Maybe a
Nothing
    SemVer
v:[SemVer]
vs -> SemVer -> m SemVer
forall (m :: * -> *) a. Monad m => a -> m a
return (SemVer -> m SemVer) -> SemVer -> m SemVer
forall a b. (a -> b) -> a -> b
$ (SemVer -> SemVer -> SemVer) -> SemVer -> [SemVer] -> SemVer
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SemVer -> SemVer -> SemVer
forall a. Ord a => a -> a -> a
max SemVer
v [SemVer]
vs