{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

-- | Copyright: (c) 2021-2022 berberman
-- SPDX-License-Identifier: MIT
-- Maintainer: berberman <[email protected]>
-- Stability: experimental
-- Portability: portable
--
-- This module provides function to calculate @[email protected] used in @[email protected]
module NvFetcher.FetchRustGitDeps
  ( -- * Types
    FetchRustGitDepsQ (..),

    -- * Rules
    fetchRustGitDepsRule,
    fetchRustGitDeps,
  )
where

import Control.Monad (void)
import Data.Binary.Instances ()
import Data.Coerce (coerce)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HMap
import Data.List.Extra (nubOrdOn)
import Data.Maybe (maybeToList)
import Data.Text (Text)
import qualified Data.Text as T
import Development.Shake
import NvFetcher.ExtractSrc
import NvFetcher.NixFetcher
import NvFetcher.Types
import Prettyprinter (pretty, (<+>))
import Text.Parsec
import Text.Parsec.Text
import Toml (TomlCodec, (.=))
import qualified Toml

-- | Rules of fetch rust git dependencies
fetchRustGitDepsRule :: Rules ()
fetchRustGitDepsRule :: Rules ()
fetchRustGitDepsRule = Rules (FetchRustGitDepsQ -> Action (HashMap Text Checksum))
-> Rules ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Rules (FetchRustGitDepsQ -> Action (HashMap Text Checksum))
 -> Rules ())
-> Rules (FetchRustGitDepsQ -> Action (HashMap Text Checksum))
-> Rules ()
forall a b. (a -> b) -> a -> b
$
  (FetchRustGitDepsQ -> Action (HashMap Text Checksum))
-> Rules (FetchRustGitDepsQ -> Action (HashMap Text Checksum))
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a, Partial) =>
(q -> Action a) -> Rules (q -> Action a)
addOracleCache ((FetchRustGitDepsQ -> Action (HashMap Text Checksum))
 -> Rules (FetchRustGitDepsQ -> Action (HashMap Text Checksum)))
-> (FetchRustGitDepsQ -> Action (HashMap Text Checksum))
-> Rules (FetchRustGitDepsQ -> Action (HashMap Text Checksum))
forall a b. (a -> b) -> a -> b
$ \key :: FetchRustGitDepsQ
key@(FetchRustGitDepsQ NixFetcher 'Fetched
fetcher String
lockPath) -> do
    String -> Action ()
putInfo (String -> Action ())
-> (Doc Any -> String) -> Doc Any -> Action ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> Action ()) -> Doc Any -> Action ()
forall a b. (a -> b) -> a -> b
$ Doc Any
"#" Doc Any -> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FetchRustGitDepsQ -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty FetchRustGitDepsQ
key
    Text
cargoLock <- [Text] -> Text
forall a. [a] -> a
head ([Text] -> Text)
-> (HashMap String Text -> [Text]) -> HashMap String Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap String Text -> [Text]
forall k v. HashMap k v -> [v]
HMap.elems (HashMap String Text -> Text)
-> Action (HashMap String Text) -> Action Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NixFetcher 'Fetched -> String -> Action (HashMap String Text)
extractSrc NixFetcher 'Fetched
fetcher String
lockPath
    [RustDep]
deps <- case TomlCodec [RustDep] -> Text -> Either [TomlDecodeError] [RustDep]
forall a. TomlCodec a -> Text -> Either [TomlDecodeError] a
Toml.decode (TomlCodec RustDep -> Key -> TomlCodec [RustDep]
forall a. TomlCodec a -> Key -> TomlCodec [a]
Toml.list TomlCodec RustDep
rustDepCodec Key
"package") Text
cargoLock of
      Right [RustDep]
r -> [RustDep] -> Action [RustDep]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([RustDep] -> Action [RustDep]) -> [RustDep] -> Action [RustDep]
forall a b. (a -> b) -> a -> b
$ (RustDep -> Maybe Text) -> [RustDep] -> [RustDep]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn RustDep -> Maybe Text
rrawSrc [RustDep]
r
      Left [TomlDecodeError]
err -> String -> Action [RustDep]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Action [RustDep]) -> String -> Action [RustDep]
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse Cargo.lock: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack ([TomlDecodeError] -> Text
Toml.prettyTomlDecodeErrors [TomlDecodeError]
err)
    [(Text, Checksum)]
r <-
      [Action (Text, Checksum)] -> Action [(Text, Checksum)]
forall a. [Action a] -> Action [a]
parallel
        [ case Parsec Text () ParsedGitSrc
-> String -> Text -> Either ParseError ParsedGitSrc
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec Text () ParsedGitSrc
gitSrcParser (Text -> String
T.unpack Text
rname) Text
src of
            Right ParsedGitSrc {Text
Version
pgsha :: ParsedGitSrc -> Version
pgurl :: ParsedGitSrc -> Text
pgsha :: Version
pgurl :: Text
..} -> do
              (NixFetcher 'Fetched -> FetchResult 'Fetched
forall (k :: FetchStatus). NixFetcher k -> FetchResult k
_sha256 -> FetchResult 'Fetched
sha256) <- NixFetcher 'Fresh -> Action (NixFetcher 'Fetched)
prefetch (NixFetcher 'Fresh -> Action (NixFetcher 'Fetched))
-> NixFetcher 'Fresh -> Action (NixFetcher 'Fetched)
forall a b. (a -> b) -> a -> b
$ Text -> PackageFetcher
gitFetcher Text
pgurl Version
pgsha
              -- @${name}-${version}@ -> sha256
              (Text, Checksum) -> Action (Text, Checksum)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
rname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
coerce Version
rversion, FetchResult 'Fetched
Checksum
sha256)
            Left ParseError
err -> String -> Action (Text, Checksum)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Action (Text, Checksum))
-> String -> Action (Text, Checksum)
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse git source in Cargo.lock: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseError -> String
forall a. Show a => a -> String
show ParseError
err
          | RustDep {Maybe Text
Text
Version
rversion :: RustDep -> Version
rname :: RustDep -> Text
rrawSrc :: Maybe Text
rversion :: Version
rname :: Text
rrawSrc :: RustDep -> Maybe Text
..} <- [RustDep]
deps,
            -- it's a dependency
            Text
src <- Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList Maybe Text
rrawSrc,
            -- it's a git dependency
            Text
"git+" Text -> Text -> Bool
`T.isPrefixOf` Text
src
        ]
    HashMap Text Checksum -> Action (HashMap Text Checksum)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text Checksum -> Action (HashMap Text Checksum))
-> HashMap Text Checksum -> Action (HashMap Text Checksum)
forall a b. (a -> b) -> a -> b
$ [(Text, Checksum)] -> HashMap Text Checksum
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HMap.fromList [(Text, Checksum)]
r

-- | Run fetch rust git dependencies
fetchRustGitDeps ::
  -- | prefetched source
  NixFetcher Fetched ->
  -- | relative file path of @[email protected]
  FilePath ->
  Action (HashMap Text Checksum)
fetchRustGitDeps :: NixFetcher 'Fetched -> String -> Action (HashMap Text Checksum)
fetchRustGitDeps NixFetcher 'Fetched
fetcher String
lockPath = FetchRustGitDepsQ -> Action (HashMap Text Checksum)
forall q a.
(RuleResult q ~ a, ShakeValue q, ShakeValue a) =>
q -> Action a
askOracle (FetchRustGitDepsQ -> Action (HashMap Text Checksum))
-> FetchRustGitDepsQ -> Action (HashMap Text Checksum)
forall a b. (a -> b) -> a -> b
$ NixFetcher 'Fetched -> String -> FetchRustGitDepsQ
FetchRustGitDepsQ NixFetcher 'Fetched
fetcher String
lockPath

data ParsedGitSrc = ParsedGitSrc
  { -- | git url
    ParsedGitSrc -> Text
pgurl :: Text,
    ParsedGitSrc -> Version
pgsha :: Version
  }
  deriving (Int -> ParsedGitSrc -> String -> String
[ParsedGitSrc] -> String -> String
ParsedGitSrc -> String
(Int -> ParsedGitSrc -> String -> String)
-> (ParsedGitSrc -> String)
-> ([ParsedGitSrc] -> String -> String)
-> Show ParsedGitSrc
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ParsedGitSrc] -> String -> String
$cshowList :: [ParsedGitSrc] -> String -> String
show :: ParsedGitSrc -> String
$cshow :: ParsedGitSrc -> String
showsPrec :: Int -> ParsedGitSrc -> String -> String
$cshowsPrec :: Int -> ParsedGitSrc -> String -> String
Show, ParsedGitSrc -> ParsedGitSrc -> Bool
(ParsedGitSrc -> ParsedGitSrc -> Bool)
-> (ParsedGitSrc -> ParsedGitSrc -> Bool) -> Eq ParsedGitSrc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParsedGitSrc -> ParsedGitSrc -> Bool
$c/= :: ParsedGitSrc -> ParsedGitSrc -> Bool
== :: ParsedGitSrc -> ParsedGitSrc -> Bool
$c== :: ParsedGitSrc -> ParsedGitSrc -> Bool
Eq, Eq ParsedGitSrc
Eq ParsedGitSrc
-> (ParsedGitSrc -> ParsedGitSrc -> Ordering)
-> (ParsedGitSrc -> ParsedGitSrc -> Bool)
-> (ParsedGitSrc -> ParsedGitSrc -> Bool)
-> (ParsedGitSrc -> ParsedGitSrc -> Bool)
-> (ParsedGitSrc -> ParsedGitSrc -> Bool)
-> (ParsedGitSrc -> ParsedGitSrc -> ParsedGitSrc)
-> (ParsedGitSrc -> ParsedGitSrc -> ParsedGitSrc)
-> Ord ParsedGitSrc
ParsedGitSrc -> ParsedGitSrc -> Bool
ParsedGitSrc -> ParsedGitSrc -> Ordering
ParsedGitSrc -> ParsedGitSrc -> ParsedGitSrc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ParsedGitSrc -> ParsedGitSrc -> ParsedGitSrc
$cmin :: ParsedGitSrc -> ParsedGitSrc -> ParsedGitSrc
max :: ParsedGitSrc -> ParsedGitSrc -> ParsedGitSrc
$cmax :: ParsedGitSrc -> ParsedGitSrc -> ParsedGitSrc
>= :: ParsedGitSrc -> ParsedGitSrc -> Bool
$c>= :: ParsedGitSrc -> ParsedGitSrc -> Bool
> :: ParsedGitSrc -> ParsedGitSrc -> Bool
$c> :: ParsedGitSrc -> ParsedGitSrc -> Bool
<= :: ParsedGitSrc -> ParsedGitSrc -> Bool
$c<= :: ParsedGitSrc -> ParsedGitSrc -> Bool
< :: ParsedGitSrc -> ParsedGitSrc -> Bool
$c< :: ParsedGitSrc -> ParsedGitSrc -> Bool
compare :: ParsedGitSrc -> ParsedGitSrc -> Ordering
$ccompare :: ParsedGitSrc -> ParsedGitSrc -> Ordering
Ord)

-- | Parse git src in cargo lock file
-- >>> parse gitSrcParser "test" "git+https://github.com/rust-random/rand.git?rev=0.8.3#6ecbe2626b2cc6110a25c97b1702b347574febc7"
-- Right (ParsedGitSrc {pgurl = "https://github.com/rust-random/rand.git", pgsha = "6ecbe2626b2cc6110a25c97b1702b347574febc7"})
--
-- >>> parse gitSrcParser "test" "git+https://github.com/rust-random/rand.git#f0e01ee0a7257753cc51b291f62666f4765923ef"
-- Right (ParsedGitSrc {pgurl = "https://github.com/rust-random/rand.git", pgsha = "f0e01ee0a7257753cc51b291f62666f4765923ef"})
--
-- >>> parse gitSrcParser "test" "git+https://github.com/rust-lang/cargo?branch=rust-1.53.0#4369396ce7d270972955d876eaa4954bea56bcd9"
-- Right (ParsedGitSrc {pgurl = "https://github.com/rust-lang/cargo", pgsha = "4369396ce7d270972955d876eaa4954bea56bcd9"})
gitSrcParser :: Parser ParsedGitSrc
gitSrcParser :: Parsec Text () ParsedGitSrc
gitSrcParser = do
  String
_ <- String -> ParsecT Text () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"git+"
  String
pgurl <- ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT Text () Identity Char -> ParsecT Text () Identity String)
-> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
'?', Char
'#']
  -- skip things like ?rev and ?branch
  ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (String -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
'#'])
  Char
_ <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'#'
  String
pgsha <- ParsecT Text () Identity Char
-> ParsecT Text () Identity () -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
  ParsedGitSrc -> Parsec Text () ParsedGitSrc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParsedGitSrc -> Parsec Text () ParsedGitSrc)
-> ParsedGitSrc -> Parsec Text () ParsedGitSrc
forall a b. (a -> b) -> a -> b
$ Text -> Version -> ParsedGitSrc
ParsedGitSrc (String -> Text
T.pack String
pgurl) (Text -> Version
coerce (Text -> Version) -> Text -> Version
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
pgsha)

data RustDep = RustDep
  { RustDep -> Text
rname :: PackageName,
    RustDep -> Version
rversion :: Version,
    RustDep -> Maybe Text
rrawSrc :: Maybe Text
  }
  deriving (Int -> RustDep -> String -> String
[RustDep] -> String -> String
RustDep -> String
(Int -> RustDep -> String -> String)
-> (RustDep -> String)
-> ([RustDep] -> String -> String)
-> Show RustDep
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RustDep] -> String -> String
$cshowList :: [RustDep] -> String -> String
show :: RustDep -> String
$cshow :: RustDep -> String
showsPrec :: Int -> RustDep -> String -> String
$cshowsPrec :: Int -> RustDep -> String -> String
Show, RustDep -> RustDep -> Bool
(RustDep -> RustDep -> Bool)
-> (RustDep -> RustDep -> Bool) -> Eq RustDep
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RustDep -> RustDep -> Bool
$c/= :: RustDep -> RustDep -> Bool
== :: RustDep -> RustDep -> Bool
$c== :: RustDep -> RustDep -> Bool
Eq, Eq RustDep
Eq RustDep
-> (RustDep -> RustDep -> Ordering)
-> (RustDep -> RustDep -> Bool)
-> (RustDep -> RustDep -> Bool)
-> (RustDep -> RustDep -> Bool)
-> (RustDep -> RustDep -> Bool)
-> (RustDep -> RustDep -> RustDep)
-> (RustDep -> RustDep -> RustDep)
-> Ord RustDep
RustDep -> RustDep -> Bool
RustDep -> RustDep -> Ordering
RustDep -> RustDep -> RustDep
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RustDep -> RustDep -> RustDep
$cmin :: RustDep -> RustDep -> RustDep
max :: RustDep -> RustDep -> RustDep
$cmax :: RustDep -> RustDep -> RustDep
>= :: RustDep -> RustDep -> Bool
$c>= :: RustDep -> RustDep -> Bool
> :: RustDep -> RustDep -> Bool
$c> :: RustDep -> RustDep -> Bool
<= :: RustDep -> RustDep -> Bool
$c<= :: RustDep -> RustDep -> Bool
< :: RustDep -> RustDep -> Bool
$c< :: RustDep -> RustDep -> Bool
compare :: RustDep -> RustDep -> Ordering
$ccompare :: RustDep -> RustDep -> Ordering
Ord)

rustDepCodec :: TomlCodec RustDep
rustDepCodec :: TomlCodec RustDep
rustDepCodec =
  Text -> Version -> Maybe Text -> RustDep
RustDep
    (Text -> Version -> Maybe Text -> RustDep)
-> Codec RustDep Text
-> Codec RustDep (Version -> Maybe Text -> RustDep)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> TomlCodec Text
Toml.text Key
"name" TomlCodec Text -> (RustDep -> Text) -> Codec RustDep Text
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= RustDep -> Text
rname
    Codec RustDep (Version -> Maybe Text -> RustDep)
-> Codec RustDep Version -> Codec RustDep (Maybe Text -> RustDep)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TomlCodec Text -> TomlCodec Version
forall b a. Coercible a b => TomlCodec a -> TomlCodec b
Toml.diwrap (Key -> TomlCodec Text
Toml.text Key
"version") TomlCodec Version -> (RustDep -> Version) -> Codec RustDep Version
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= RustDep -> Version
rversion
    Codec RustDep (Maybe Text -> RustDep)
-> Codec RustDep (Maybe Text) -> TomlCodec RustDep
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TomlCodec Text -> TomlCodec (Maybe Text)
forall a. TomlCodec a -> TomlCodec (Maybe a)
Toml.dioptional (Key -> TomlCodec Text
Toml.text Key
"source") TomlCodec (Maybe Text)
-> (RustDep -> Maybe Text) -> Codec RustDep (Maybe Text)
forall field a object.
Codec field a -> (object -> field) -> Codec object a
.= RustDep -> Maybe Text
rrawSrc