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

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

import 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)

-- | Download URL via shelling out to @curl@.
curl :: String -> IO (Either String BS.ByteString)
curl :: String -> IO (Either String ByteString)
curl String
url = do
  (ExitCode
code, ByteString
out, ByteString
err) <-
    -- The -L option follows HTTP redirects.
    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

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

-- | Information about a version of a single package.  The version
-- number is stored separately.
data PkgRevInfo m = PkgRevInfo
  { forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevZipballUrl :: T.Text,
    -- | The directory inside the zipball
    -- containing the @lib@ directory, in
    -- which the package files themselves
    -- are stored (Based on the package
    -- path).
    forall (m :: * -> *). PkgRevInfo m -> String
pkgRevZipballDir :: FilePath,
    -- | The commit ID can be used for
    -- verification ("freezing"), by
    -- storing what it was at the time this
    -- version was last selected.
    forall (m :: * -> *). PkgRevInfo m -> Text
pkgRevCommit :: T.Text,
    forall (m :: * -> *). PkgRevInfo m -> GetManifest m
pkgRevGetManifest :: GetManifest m,
    -- | Timestamp for when the revision
    -- was made (rarely used).
    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)

-- | Create memoisation around a 'GetManifest' action to ensure that
-- multiple inspections of the same revisions will not result in
-- potentially expensive network round trips.
memoiseGetManifest :: MonadIO m => GetManifest m -> m (GetManifest m)
memoiseGetManifest :: 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'

-- | Download the zip archive corresponding to a specific package
-- version.
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

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

-- | Lookup information about a given version of a package.
lookupPkgRev :: SemVer -> PkgInfo m -> Maybe (PkgRevInfo m)
lookupPkgRev :: 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])

-- | Retrieve information about a package based on its package path.
-- This uses Semantic Import Versioning when interacting with
-- repositories.  For example, a package @github.com/user/repo@ will
-- match version 0.* or 1.* tags only, a package
-- @github.com/user/repo/v2@ will match 2.* tags, and so forth..
pkgInfo ::
  (MonadIO m, MonadLogger m, MonadFail m) =>
  PkgPath ->
  m (Either T.Text (PkgInfo m))
pkgInfo :: 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
"'"

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

gitCmd :: (MonadIO m, MonadFail m) => [String] -> m BS.ByteString
gitCmd :: 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

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

ghglRevGetManifest ::
  (MonadIO m, MonadLogger m, MonadFail m) =>
  T.Text ->
  T.Text ->
  T.Text ->
  T.Text ->
  GetManifest m
ghglRevGetManifest :: 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 -- FIXME
  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

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

instance Semigroup (PkgRegistry m) where
  PkgRegistry Map Text (PkgInfo m)
x <> :: PkgRegistry m -> PkgRegistry m -> PkgRegistry m
<> PkgRegistry Map Text (PkgInfo m)
y = 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

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

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

-- | Look up information about a specific version of a package.
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'

-- | Find the newest version of a package.
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