module Futhark.Pkg.Info
(
PkgInfo (..),
lookupPkgRev,
pkgInfo,
PkgRevInfo (..),
GetManifest (getManifest),
downloadZipball,
PkgRegistry,
MonadPkgRegistry (..),
lookupPackage,
lookupPackageRev,
lookupNewestRev,
)
where
import Codec.Archive.Zip qualified as Zip
import Control.Monad.IO.Class
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
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.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import Futhark.Pkg.Types
import Futhark.Util (maybeHead)
import Futhark.Util.Log
import System.Exit
import System.FilePath.Posix qualified as Posix
import System.IO
import System.Process.ByteString (readProcessWithExitCode)
curl :: String -> IO (Either String BS.ByteString)
curl :: String -> IO (Either String ByteString)
curl String
url = do
(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
"curl" [String
"-L", String
url] forall a. Monoid a => a
mempty
case ExitCode
code of
ExitFailure Int
127 ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
String
"'" forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String
"curl", String
"-L", String
url] forall a. Semigroup a => a -> a -> a
<> String
"' failed (program not found?)."
ExitFailure Int
_ -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPutStr Handle
stderr ByteString
err
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"'" forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String
"curl", String
"-L", String
url] forall a. Semigroup a => a -> a -> a
<> String
"' failed."
ExitCode
ExitSuccess ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ByteString
out
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
"#<revdeps>"
instance Eq (GetManifest m) where
GetManifest m
_ == :: GetManifest m -> GetManifest m -> Bool
== GetManifest m
_ = Bool
True
data PkgRevInfo m = PkgRevInfo
{ forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevZipballUrl :: T.Text,
forall (m :: * -> *). PkgRevInfo m -> String
pkgRevZipballDir :: FilePath,
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'
downloadZipball ::
(MonadLogger m, MonadIO m, MonadFail m) =>
PkgRevInfo m ->
m Zip.Archive
downloadZipball :: forall (m :: * -> *).
(MonadLogger m, MonadIO m, MonadFail m) =>
PkgRevInfo m -> m Archive
downloadZipball PkgRevInfo m
info = do
let url :: Text
url = forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevZipballUrl PkgRevInfo m
info
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$ String
"Downloading " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
url
let bad :: String -> m a
bad = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String
"When downloading " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
url forall a. Semigroup a => a -> a -> a
<> String
": ") <>)
Either String ByteString
http <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Either String ByteString)
curl forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url
case Either String ByteString
http of
Left String
e -> forall {a}. String -> m a
bad String
e
Right ByteString
r ->
case ByteString -> Either String Archive
Zip.toArchiveOrFail forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
r of
Left String
e -> forall {a}. String -> m a
bad forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
e
Right Archive
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Archive
a
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 -> (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
"")] <- 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])
pkgInfo ::
(MonadIO m, MonadLogger m, MonadFail m) =>
PkgPath ->
m (Either T.Text (PkgInfo m))
pkgInfo :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
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 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 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
Text -> [Text] -> Text
T.intercalate
Text
"\n"
[Text
nope, Text
"Do you perhaps mean 'github.com/" forall a. Semigroup a => a -> a -> a
<> Text
owner forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
repo 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 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 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
Text -> [Text] -> Text
T.intercalate
Text
"\n"
[Text
nope, Text
"Do you perhaps mean 'gitlab.com/" forall a. Semigroup a => a -> a -> a
<> Text
owner forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
repo forall a. Semigroup a => a -> a -> a
<> Text
"'?"]
| Bool
otherwise =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
nope
where
nope :: Text
nope = Text
"Unable to handle package paths of the form '" forall a. Semigroup a => a -> a -> a
<> Text
path forall a. Semigroup a => a -> a -> a
<> Text
"'"
gitCmd :: (MonadIO m, MonadFail m) => [String] -> m BS.ByteString
gitCmd :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
[String] -> m ByteString
gitCmd [String]
opts = do
(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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
BS.hPutStr Handle
stderr 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
ghglRevGetManifest ::
(MonadIO m, MonadLogger m, MonadFail m) =>
T.Text ->
T.Text ->
T.Text ->
T.Text ->
GetManifest m
ghglRevGetManifest :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text -> Text -> Text -> Text -> GetManifest m
ghglRevGetManifest Text
url Text
owner Text
repo Text
tag = forall (m :: * -> *). m PkgManifest -> GetManifest m
GetManifest forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$ Text
"Downloading package manifest from " forall a. Semigroup a => a -> a -> a
<> Text
url
let path :: String
path =
Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$
Text
owner
forall a. Semigroup a => a -> a -> a
<> Text
"/"
forall a. Semigroup a => a -> a -> a
<> Text
repo
forall a. Semigroup a => a -> a -> a
<> Text
"@"
forall a. Semigroup a => a -> a -> a
<> Text
tag
forall a. Semigroup a => a -> a -> a
<> Text
"/"
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
futharkPkg
msg :: ShowS
msg = ((String
"When reading " forall a. Semigroup a => a -> a -> a
<> String
path forall a. Semigroup a => a -> a -> a
<> String
": ") <>)
Either String ByteString
http <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Either String ByteString)
curl forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
url
case Either String ByteString
http of
Left String
e -> 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ ShowS
msg forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ ShowS
msg forall a b. (a -> b) -> a -> b
$ 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
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 :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
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 <- forall (m :: * -> *).
MonadIO m =>
GetManifest m -> m (GetManifest m)
memoiseGetManifest forall a b. (a -> b) -> a -> b
$ 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 = ShowS
Posix.addTrailingPathSeparator forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text
mk_zip_dir Text
d
UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: 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 = do
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$ Text
"Retrieving list of tags from " forall a. Semigroup a => a -> a -> a
<> Text
repo_url
[Text]
remote_lines <- Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
[String] -> m ByteString
gitCmd [String
"ls-remote", Text -> String
T.unpack Text
repo_url]
Text
head_ref <-
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Cannot find HEAD ref for " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
repo_url) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a. [a] -> Maybe a
maybeHead forall a b. (a -> b) -> a -> b
$
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Text
isHeadRef [Text]
remote_lines
let def :: Maybe Text -> Text
def = forall a. a -> Maybe a -> a
fromMaybe Text
head_ref
Map SemVer (PkgRevInfo m)
rev_info <- forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes 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) =>
Text -> m (Maybe (SemVer, PkgRevInfo m))
revInfo [Text]
remote_lines
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a b. b -> Either a b
Right 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)
rev_info forall a b. (a -> b) -> a -> b
$ \Maybe Text
r ->
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 = forall a. a -> Maybe a
Just Text
hash
| Bool
otherwise = 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 forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
t,
SemVer -> Word
_svMajor SemVer
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word]
versions = do
PkgRevInfo m
pinfo <-
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (SemVer
v, PkgRevInfo m
pinfo)
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
ghPkgInfo ::
(MonadIO m, MonadLogger m, MonadFail m) =>
T.Text ->
T.Text ->
[Word] ->
m (Either T.Text (PkgInfo m))
ghPkgInfo :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text -> Text -> [Word] -> m (Either Text (PkgInfo m))
ghPkgInfo Text
owner Text
repo [Word]
versions =
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/" forall a. Semigroup a => a -> a -> a
<> Text
owner forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
repo
mk_archive_url :: Text -> Text
mk_archive_url Text
r = Text
repo_url forall a. Semigroup a => a -> a -> a
<> Text
"/archive/" forall a. Semigroup a => a -> a -> a
<> Text
r forall a. Semigroup a => a -> a -> a
<> Text
".zip"
mk_manifest_url :: Text -> Text
mk_manifest_url Text
r =
Text
"https://raw.githubusercontent.com/"
forall a. Semigroup a => a -> a -> a
<> Text
owner
forall a. Semigroup a => a -> a -> a
<> Text
"/"
forall a. Semigroup a => a -> a -> a
<> Text
repo
forall a. Semigroup a => a -> a -> a
<> Text
"/"
forall a. Semigroup a => a -> a -> a
<> Text
r
forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> 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 :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadFail m) =>
Text -> Text -> [Word] -> m (Either Text (PkgInfo m))
glPkgInfo Text
owner Text
repo [Word]
versions =
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/" forall a. Semigroup a => a -> a -> a
<> Text
owner forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
repo
repo_url :: Text
repo_url = Text
base_url forall a. Semigroup a => a -> a -> a
<> Text
".git"
mk_archive_url :: Text -> Text
mk_archive_url Text
r =
Text
base_url
forall a. Semigroup a => a -> a -> a
<> Text
"/-/archive/"
forall a. Semigroup a => a -> a -> a
<> Text
r
forall a. Semigroup a => a -> a -> a
<> Text
"/"
forall a. Semigroup a => a -> a -> a
<> Text
repo
forall a. Semigroup a => a -> a -> a
<> Text
"-"
forall a. Semigroup a => a -> a -> a
<> Text
r
forall a. Semigroup a => a -> a -> a
<> Text
".zip"
mk_manifest_url :: Text -> Text
mk_manifest_url Text
r =
Text
base_url
forall a. Semigroup a => a -> a -> a
<> Text
"/raw/"
forall a. Semigroup a => a -> a -> a
<> Text
r
forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> Text
"-v" forall a. Semigroup a => a -> a -> a
<> Text
r
| Bool
otherwise = Text
repo forall a. Semigroup a => a -> a -> a
<> 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 = 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 =>
PkgPath ->
m (PkgInfo m)
lookupPackage :: forall (m :: * -> *). MonadPkgRegistry m => Text -> m (PkgInfo m)
lookupPackage 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
Either Text (PkgInfo m)
e <- 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' -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
e'
Right PkgInfo m
pinfo -> do
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 =>
PkgPath ->
Maybe T.Text ->
m (SemVer, PkgRevInfo m)
lookupPackageCommit :: forall (m :: * -> *).
MonadPkgRegistry m =>
Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit Text
p Maybe Text
ref = do
PkgInfo m
pinfo <- forall (m :: * -> *). MonadPkgRegistry m => Text -> m (PkgInfo m)
lookupPackage 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 =>
PkgPath ->
SemVer ->
m (PkgRevInfo m)
lookupPackageRev :: forall (m :: * -> *).
MonadPkgRegistry m =>
Text -> SemVer -> m (PkgRevInfo m)
lookupPackageRev 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 =>
Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit Text
p (forall a. a -> Maybe a
Just Text
commit)
| Bool
otherwise = do
PkgInfo m
pinfo <- forall (m :: * -> *). MonadPkgRegistry m => Text -> m (PkgInfo m)
lookupPackage 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
<> String -> Text
T.pack (forall a. Show a => a -> String
show (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
<> String -> Text
T.pack (forall a. Show a => a -> String
show (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 =>
PkgPath ->
m SemVer
lookupNewestRev :: forall (m :: * -> *). MonadPkgRegistry m => Text -> m SemVer
lookupNewestRev Text
p = do
PkgInfo m
pinfo <- forall (m :: * -> *). MonadPkgRegistry m => Text -> m (PkgInfo m)
lookupPackage 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 =>
Text -> Maybe Text -> m (SemVer, PkgRevInfo m)
lookupPackageCommit 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