{-# 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 qualified Codec.Archive.Zip as Zip
import Control.Monad.IO.Class
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.IORef
import Data.List (foldl', intersperse)
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Futhark.Pkg.Types
import Futhark.Util (maybeHead)
import Futhark.Util.Log
import System.Exit
import qualified System.FilePath.Posix as Posix
import System.IO
import System.Process.ByteString (readProcessWithExitCode)

-- | 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,
    -- | The directory inside the zipball
    -- containing the @lib@ directory, in
    -- which the package files themselves
    -- are stored (Based on the package
    -- path).
    PkgRevInfo m -> String
pkgRevZipballDir :: FilePath,
    -- | The commit ID can be used for
    -- verification ("freezing"), by
    -- storing what it was at the time this
    -- version was last selected.
    PkgRevInfo m -> Text
pkgRevCommit :: T.Text,
    PkgRevInfo m -> GetManifest m
pkgRevGetManifest :: GetManifest m,
    -- | Timestamp for when the revision
    -- was made (rarely used).
    PkgRevInfo m -> UTCTime
pkgRevTime :: UTCTime
  }
  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'

-- | Download the zip archive corresponding to a specific package
-- version.
downloadZipball ::
  (MonadLogger m, MonadIO m, MonadFail m) =>
  PkgRevInfo m ->
  m Zip.Archive
downloadZipball :: PkgRevInfo m -> m Archive
downloadZipball PkgRevInfo m
info = do
  let url :: Text
url = PkgRevInfo m -> Text
forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevZipballUrl PkgRevInfo m
info
  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),
    -- | Look up information about a specific
    -- commit, or HEAD in case of Nothing.
    PkgInfo m -> Maybe Text -> m (PkgRevInfo m)
pkgLookupCommit :: Maybe T.Text -> m (PkgRevInfo m)
  }

-- | Lookup information about a given version of a package.
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.
(VisualStream s, TraversableStream 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
parseVersion (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
parseVersion 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

-- | Given a package path, look up information about that package.
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