module Futhark.Pkg.Info
(
PkgInfo (..),
lookupPkgRev,
pkgInfo,
PkgRevInfo (..),
GetManifest (getManifest),
GetFiles (getFiles),
CacheDir (..),
PkgRegistry,
MonadPkgRegistry (..),
lookupPackage,
lookupPackageRev,
lookupNewestRev,
)
where
import Control.Monad (unless, void)
import Control.Monad.IO.Class
import Data.ByteString qualified as BS
import Data.IORef
import Data.List (foldl', intersperse)
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
import Data.Time (UTCTime, defaultTimeLocale, formatTime)
import Data.Time.Format.ISO8601 (iso8601ParseM)
import Data.Time.LocalTime (zonedTimeToUTC)
import Futhark.Pkg.Types
import Futhark.Util (directoryContents, showText, zEncodeText)
import Futhark.Util.Log
import System.Directory (doesDirectoryExist)
import System.Exit
import System.FilePath (makeRelative, (</>))
import System.Process.ByteString (readProcessWithExitCode)
newtype GetManifest m = GetManifest {forall (m :: * -> *). GetManifest m -> m PkgManifest
getManifest :: m PkgManifest}
instance Show (GetManifest m) where
show :: GetManifest m -> String
show GetManifest m
_ = String
"#<GetManifest>"
instance Eq (GetManifest m) where
GetManifest m
_ == :: GetManifest m -> GetManifest m -> Bool
== GetManifest m
_ = Bool
True
newtype GetFiles m = GetFiles {forall (m :: * -> *). GetFiles m -> m (String, [String])
getFiles :: m (FilePath, [FilePath])}
instance Show (GetFiles m) where
show :: GetFiles m -> String
show GetFiles m
_ = String
"#<GetFiles>"
instance Eq (GetFiles m) where
GetFiles m
_ == :: GetFiles m -> GetFiles m -> Bool
== GetFiles m
_ = Bool
True
data PkgRevInfo m = PkgRevInfo
{ forall (m :: * -> *). PkgRevInfo m -> GetFiles m
pkgGetFiles :: GetFiles m,
forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevCommit :: T.Text,
forall (m :: * -> *). PkgRevInfo m -> GetManifest m
pkgRevGetManifest :: GetManifest m,
forall (m :: * -> *). PkgRevInfo m -> UTCTime
pkgRevTime :: UTCTime
}
deriving (PkgRevInfo m -> PkgRevInfo m -> Bool
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 -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *). Int -> PkgRevInfo m -> ShowS
forall (m :: * -> *). [PkgRevInfo m] -> ShowS
forall (m :: * -> *). PkgRevInfo m -> String
showList :: [PkgRevInfo m] -> ShowS
$cshowList :: forall (m :: * -> *). [PkgRevInfo m] -> ShowS
show :: PkgRevInfo m -> String
$cshow :: forall (m :: * -> *). PkgRevInfo m -> String
showsPrec :: Int -> PkgRevInfo m -> ShowS
$cshowsPrec :: forall (m :: * -> *). Int -> PkgRevInfo m -> ShowS
Show)
memoiseGetManifest :: MonadIO m => GetManifest m -> m (GetManifest m)
memoiseGetManifest :: forall (m :: * -> *).
MonadIO m =>
GetManifest m -> m (GetManifest m)
memoiseGetManifest (GetManifest m PkgManifest
m) = do
IORef (Maybe PkgManifest)
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). m PkgManifest -> GetManifest m
GetManifest forall a b. (a -> b) -> a -> b
$ do
Maybe PkgManifest
v <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Maybe PkgManifest)
ref
case Maybe PkgManifest
v of
Just PkgManifest
v' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PkgManifest
v'
Maybe PkgManifest
Nothing -> do
PkgManifest
v' <- m PkgManifest
m
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe PkgManifest)
ref forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just PkgManifest
v'
forall (f :: * -> *) a. Applicative f => a -> f a
pure PkgManifest
v'
data PkgInfo m = PkgInfo
{ forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions :: M.Map SemVer (PkgRevInfo m),
forall (m :: * -> *). PkgInfo m -> Maybe Text -> m (PkgRevInfo m)
pkgLookupCommit :: Maybe T.Text -> m (PkgRevInfo m)
}
lookupPkgRev :: SemVer -> PkgInfo m -> Maybe (PkgRevInfo m)
lookupPkgRev :: forall (m :: * -> *). SemVer -> PkgInfo m -> Maybe (PkgRevInfo m)
lookupPkgRev SemVer
v = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SemVer
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions
majorRevOfPkg :: PkgPath -> (T.Text, [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
"")] <- forall a. Read a => ReadS a
reads forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
v -> (Text
p', [Word
v'])
[Text]
_ -> (Text
p, [Word
0, Word
1])
gitCmd :: (MonadIO m, MonadLogger m, MonadFail m) => [String] -> m BS.ByteString
gitCmd :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m ByteString
gitCmd [String]
opts = do
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$ Text
"Running command: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (Text
"git" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack [String]
opts)
(ExitCode
code, ByteString
out, ByteString
err) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
readProcessWithExitCode String
"git" [String]
opts forall a. Monoid a => a
mempty
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
err forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
err
case ExitCode
code of
ExitFailure Int
127 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"'" forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords (String
"git" forall a. a -> [a] -> [a]
: [String]
opts) forall a. Semigroup a => a -> a -> a
<> String
"' failed (program not found?)."
ExitFailure Int
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"'" forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords (String
"git" forall a. a -> [a] -> [a]
: [String]
opts) forall a. Semigroup a => a -> a -> a
<> String
"' failed."
ExitCode
ExitSuccess -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
out
gitCmd_ :: (MonadIO m, MonadLogger m, MonadFail m) => [String] -> m ()
gitCmd_ :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m ()
gitCmd_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m ByteString
gitCmd
gitCmdLines :: (MonadIO m, MonadLogger m, MonadFail m) => [String] -> m [T.Text]
gitCmdLines :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m [Text]
gitCmdLines = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m ByteString
gitCmd
newtype CacheDir = CacheDir FilePath
ensureGit ::
(MonadIO m, MonadLogger m, MonadFail m) =>
CacheDir ->
T.Text ->
m FilePath
ensureGit :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
CacheDir -> Text -> m String
ensureGit (CacheDir String
cachedir) Text
url = do
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
gitdir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m ()
gitCmd_ [String
"-C", String
cachedir, String
"clone", String
"https://" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
url, String
url']
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
gitdir
where
url' :: String
url' = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text
zEncodeText Text
url
gitdir :: String
gitdir = String
cachedir String -> ShowS
</> String
url'
type Ref = String
versionRef :: SemVer -> Ref
versionRef :: SemVer -> String
versionRef SemVer
v = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
"v" forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v
revInfo ::
(MonadIO m, MonadLogger m, MonadFail m) =>
FilePath ->
PkgPath ->
Ref ->
m (PkgRevInfo m)
revInfo :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
String -> Text -> String -> m (PkgRevInfo m)
revInfo String
gitdir Text
path String
ref = do
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m ()
gitCmd_ [String
"-C", String
gitdir, String
"rev-parse", String
ref, String
"--"]
[Text
sha] <- forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m [Text]
gitCmdLines [String
"-C", String
gitdir, String
"rev-list", String
"-n1", String
ref]
[Text
time] <- forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m [Text]
gitCmdLines [String
"-C", String
gitdir, String
"show", String
"-s", String
"--format=%cI", String
ref]
UTCTime
utc <- ZonedTime -> UTCTime
zonedTimeToUTC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) t. (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM (Text -> String
T.unpack Text
time)
GetManifest m
gm <- forall (m :: * -> *).
MonadIO m =>
GetManifest m -> m (GetManifest m)
memoiseGetManifest GetManifest m
getManifest'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
PkgRevInfo
{ pkgGetFiles :: GetFiles m
pkgGetFiles = GetManifest m -> GetFiles m
getFiles GetManifest m
gm,
pkgRevCommit :: Text
pkgRevCommit = Text
sha,
pkgRevGetManifest :: GetManifest m
pkgRevGetManifest = GetManifest m
gm,
pkgRevTime :: UTCTime
pkgRevTime = UTCTime
utc
}
where
noPkgDir :: String -> m a
noPkgDir String
pdir =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
Text -> String
T.unpack Text
path
forall a. Semigroup a => a -> a -> a
<> String
"-"
forall a. Semigroup a => a -> a -> a
<> String
ref
forall a. Semigroup a => a -> a -> a
<> String
" does not contain a directory "
forall a. Semigroup a => a -> a -> a
<> String
pdir
noPkgPath :: m a
noPkgPath =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"futhark.pkg for "
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
path
forall a. Semigroup a => a -> a -> a
<> String
"-"
forall a. Semigroup a => a -> a -> a
<> String
ref
forall a. Semigroup a => a -> a -> a
<> String
" does not define a package path."
getFiles :: GetManifest m -> GetFiles m
getFiles GetManifest m
gm = forall (m :: * -> *). m (String, [String]) -> GetFiles m
GetFiles forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m ()
gitCmd_ [String
"-C", String
gitdir, String
"checkout", String
ref, String
"--"]
String
pdir <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. m a
noPkgPath forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgManifest -> Maybe String
pkgDir forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). GetManifest m -> m PkgManifest
getManifest GetManifest m
gm
let pdir_abs :: String
pdir_abs = String
gitdir String -> ShowS
</> String
pdir
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
pdir_abs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}. MonadFail m => String -> m a
noPkgDir String
pdir
[String]
fs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO [String]
directoryContents String
pdir_abs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
pdir_abs, forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
makeRelative String
pdir_abs) [String]
fs)
getManifest' :: GetManifest m
getManifest' = forall (m :: * -> *). m PkgManifest -> GetManifest m
GetManifest forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m ()
gitCmd_ [String
"-C", String
gitdir, String
"checkout", String
ref, String
"--"]
let f :: String
f = String
gitdir String -> ShowS
</> String
futharkPkg
Text
s <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Text
T.readFile String
f
let msg :: String
msg =
String
"When reading package manifest for "
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
path
forall a. Semigroup a => a -> a -> a
<> String
" "
forall a. Semigroup a => a -> a -> a
<> String
ref
forall a. Semigroup a => a -> a -> a
<> String
":\n"
case String -> Text -> Either (ParseErrorBundle Text Void) PkgManifest
parsePkgManifest String
f Text
s of
Left ParseErrorBundle Text Void
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
msg forall a. Semigroup a => a -> a -> a
<> forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
e
Right PkgManifest
pm -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PkgManifest
pm
pkgInfo ::
(MonadIO m, MonadLogger m, MonadFail m) =>
CacheDir ->
PkgPath ->
m (PkgInfo m)
pkgInfo :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
CacheDir -> Text -> m (PkgInfo m)
pkgInfo CacheDir
cachedir Text
path = do
String
gitdir <- forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
CacheDir -> Text -> m String
ensureGit CacheDir
cachedir Text
url
[SemVer]
versions <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe SemVer
isVersionRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
[String] -> m [Text]
gitCmdLines [String
"-C", String
gitdir, String
"tag"]
Map SemVer (PkgRevInfo m)
versions' <-
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [SemVer]
versions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
String -> Text -> String -> m (PkgRevInfo m)
revInfo String
gitdir Text
path forall b c a. (b -> c) -> (a -> b) -> a -> c
. SemVer -> String
versionRef) [SemVer]
versions
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Map SemVer (PkgRevInfo m)
-> (Maybe Text -> m (PkgRevInfo m)) -> PkgInfo m
PkgInfo Map SemVer (PkgRevInfo m)
versions' forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
(MonadIO m, MonadLogger m, MonadFail m) =>
String -> Maybe Text -> m (PkgRevInfo m)
lookupCommit String
gitdir
where
(Text
url, [Word]
path_versions) = Text -> (Text, [Word])
majorRevOfPkg Text
path
isVersionRef :: Text -> Maybe SemVer
isVersionRef Text
l
| Text
"v" Text -> Text -> Bool
`T.isPrefixOf` Text
l,
Right SemVer
v <- Text -> Either (ParseErrorBundle Text Void) SemVer
parseVersion forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
l,
SemVer -> Word
_svMajor SemVer
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word]
path_versions =
forall a. a -> Maybe a
Just SemVer
v
| Bool
otherwise = forall a. Maybe a
Nothing
lookupCommit :: String -> Maybe Text -> m (PkgRevInfo m)
lookupCommit String
gitdir = forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
String -> Text -> String -> m (PkgRevInfo m)
revInfo String
gitdir Text
path forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"HEAD" Text -> String
T.unpack
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 = forall (m :: * -> *). Map Text (PkgInfo m) -> PkgRegistry m
PkgRegistry forall a b. (a -> b) -> a -> b
$ Map Text (PkgInfo m)
x forall a. Semigroup a => a -> a -> a
<> Map Text (PkgInfo m)
y
instance Monoid (PkgRegistry m) where
mempty :: PkgRegistry m
mempty = forall (m :: * -> *). Map Text (PkgInfo m) -> PkgRegistry m
PkgRegistry forall a. Monoid a => a
mempty
lookupKnownPackage :: PkgPath -> PkgRegistry m -> Maybe (PkgInfo m)
lookupKnownPackage :: forall (m :: * -> *). Text -> PkgRegistry m -> Maybe (PkgInfo m)
lookupKnownPackage Text
p (PkgRegistry Map Text (PkgInfo m)
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 = forall (m :: * -> *). MonadPkgRegistry m => PkgRegistry m -> m ()
putPkgRegistry forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgRegistry m -> PkgRegistry m
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadPkgRegistry m => m (PkgRegistry m)
getPkgRegistry
lookupPackage ::
MonadPkgRegistry m =>
CacheDir ->
PkgPath ->
m (PkgInfo m)
lookupPackage :: forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> m (PkgInfo m)
lookupPackage CacheDir
cachedir Text
p = do
r :: PkgRegistry m
r@(PkgRegistry Map Text (PkgInfo m)
m) <- forall (m :: * -> *). MonadPkgRegistry m => m (PkgRegistry m)
getPkgRegistry
case forall (m :: * -> *). Text -> PkgRegistry m -> Maybe (PkgInfo m)
lookupKnownPackage Text
p PkgRegistry m
r of
Just PkgInfo m
info ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure PkgInfo m
info
Maybe (PkgInfo m)
Nothing -> do
PkgInfo m
pinfo <- forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
CacheDir -> Text -> m (PkgInfo m)
pkgInfo CacheDir
cachedir Text
p
forall (m :: * -> *). MonadPkgRegistry m => PkgRegistry m -> m ()
putPkgRegistry forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Map Text (PkgInfo m) -> PkgRegistry m
PkgRegistry forall a b. (a -> b) -> a -> b
$ 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure PkgInfo m
pinfo
lookupPackageCommit ::
MonadPkgRegistry m =>
CacheDir ->
PkgPath ->
Maybe T.Text ->
m (SemVer, PkgRevInfo m)
lookupPackageCommit :: forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit CacheDir
cachedir Text
p Maybe Text
ref = do
PkgInfo m
pinfo <- forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> m (PkgInfo m)
lookupPackage CacheDir
cachedir Text
p
PkgRevInfo m
rev_info <- forall (m :: * -> *). PkgInfo m -> Maybe Text -> m (PkgRevInfo m)
pkgLookupCommit PkgInfo m
pinfo Maybe Text
ref
let timestamp :: Text
timestamp =
String -> Text
T.pack forall a b. (a -> b) -> a -> b
$
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y%m%d%H%M%S" forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). PkgRevInfo m -> UTCTime
pkgRevTime PkgRevInfo m
rev_info
v :: SemVer
v = Text -> Text -> SemVer
commitVersion Text
timestamp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevCommit PkgRevInfo m
rev_info
pinfo' :: PkgInfo m
pinfo' = PkgInfo m
pinfo {pkgVersions :: Map SemVer (PkgRevInfo m)
pkgVersions = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert SemVer
v PkgRevInfo m
rev_info forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions PkgInfo m
pinfo}
forall (m :: * -> *).
MonadPkgRegistry m =>
(PkgRegistry m -> PkgRegistry m) -> m ()
modifyPkgRegistry forall a b. (a -> b) -> a -> b
$ \(PkgRegistry Map Text (PkgInfo m)
m) ->
forall (m :: * -> *). Map Text (PkgInfo m) -> PkgRegistry m
PkgRegistry forall a b. (a -> b) -> a -> b
$ 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SemVer
v, PkgRevInfo m
rev_info)
lookupPackageRev ::
MonadPkgRegistry m =>
CacheDir ->
PkgPath ->
SemVer ->
m (PkgRevInfo m)
lookupPackageRev :: forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev CacheDir
cachedir Text
p SemVer
v
| Just Text
commit <- SemVer -> Maybe Text
isCommitVersion SemVer
v =
forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit CacheDir
cachedir Text
p (forall a. a -> Maybe a
Just Text
commit)
| Bool
otherwise = do
PkgInfo m
pinfo <- forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> m (PkgInfo m)
lookupPackage CacheDir
cachedir Text
p
case forall (m :: * -> *). SemVer -> PkgInfo m -> Maybe (PkgRevInfo m)
lookupPkgRev SemVer
v PkgInfo m
pinfo of
Maybe (PkgRevInfo m)
Nothing ->
let versions :: Text
versions = case forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions PkgInfo m
pinfo of
[] -> Text
"Package " forall a. Semigroup a => a -> a -> a
<> Text
p forall a. Semigroup a => a -> a -> a
<> Text
" has no versions. Invalid package path?"
[SemVer]
ks ->
Text
"Known versions: "
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (forall a. a -> [a] -> [a]
intersperse Text
", " forall a b. (a -> b) -> a -> b
$ 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Word]
vs =
Text
"\nFor major version "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText (SemVer -> Word
_svMajor SemVer
v)
forall a. Semigroup a => a -> a -> a
<> Text
", use package path "
forall a. Semigroup a => a -> a -> a
<> Text
p
forall a. Semigroup a => a -> a -> a
<> Text
"@"
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showText (SemVer -> Word
_svMajor SemVer
v)
| Bool
otherwise = forall a. Monoid a => a
mempty
in forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$
Text
"package "
forall a. Semigroup a => a -> a -> a
<> Text
p
forall a. Semigroup a => a -> a -> a
<> Text
" does not have a version "
forall a. Semigroup a => a -> a -> a
<> SemVer -> Text
prettySemVer SemVer
v
forall a. Semigroup a => a -> a -> a
<> Text
".\n"
forall a. Semigroup a => a -> a -> a
<> Text
versions
forall a. Semigroup a => a -> a -> a
<> Text
major
Just PkgRevInfo m
v' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PkgRevInfo m
v'
lookupNewestRev ::
MonadPkgRegistry m =>
CacheDir ->
PkgPath ->
m SemVer
lookupNewestRev :: forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> m SemVer
lookupNewestRev CacheDir
cachedir Text
p = do
PkgInfo m
pinfo <- forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> m (PkgInfo m)
lookupPackage CacheDir
cachedir Text
p
case forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PkgInfo m -> Map SemVer (PkgRevInfo m)
pkgVersions PkgInfo m
pinfo of
[] -> do
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$ Text
"Package " forall a. Semigroup a => a -> a -> a
<> Text
p forall a. Semigroup a => a -> a -> a
<> Text
" has no released versions. Using HEAD."
forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadPkgRegistry m =>
CacheDir -> Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit CacheDir
cachedir Text
p forall a. Maybe a
Nothing
SemVer
v : [SemVer]
vs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Ord a => a -> a -> a
max SemVer
v [SemVer]
vs