{-# LANGUAGE OverloadedStrings #-}
module Futhark.Pkg.Info
(
PkgInfo(..)
, lookupPkgRev
, pkgInfo
, PkgRevInfo (..)
, GetManifest (getManifest)
, downloadZipball
, 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)
curl :: String -> IO (Either String BS.ByteString)
curl :: String -> IO (Either String ByteString)
curl String
url = do
(ExitCode
code, ByteString
out, ByteString
err) <-
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
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
data PkgRevInfo m = PkgRevInfo { PkgRevInfo m -> Text
pkgRevZipballUrl :: T.Text
, PkgRevInfo m -> String
pkgRevZipballDir :: FilePath
, PkgRevInfo m -> Text
pkgRevCommit :: T.Text
, PkgRevInfo m -> GetManifest m
pkgRevGetManifest :: GetManifest m
, 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)
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) =>
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
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)
}
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])
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
"'"
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
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
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
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
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)
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'
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