module Update.Nix.FetchGit.Prefetch
( NixPrefetchGitOutput(..)
, nixPrefetchGit
, nixPrefetchUrl
, getGitFullName
, getGitRevision
, getGitHubRevisionDate
, Revision(..)
) where
import Control.Monad ( guard )
import Control.Monad.IO.Class ( MonadIO(liftIO) )
import Data.Aeson ( FromJSON
, decode
)
import Data.ByteString.Lazy.UTF8 ( fromString )
import Data.Text ( Text
, pack
, unpack
)
import qualified Data.Text as T
import Data.Time ( Day )
import GHC.Generics
import GitHub.REST
import System.Exit ( ExitCode(..) )
import System.Process ( readProcessWithExitCode )
import Update.Nix.FetchGit.Types
import Update.Nix.FetchGit.Utils
import Update.Nix.FetchGit.Warning
data NixPrefetchGitOutput = NixPrefetchGitOutput
{ NixPrefetchGitOutput -> Text
url :: Text
, NixPrefetchGitOutput -> Text
rev :: Text
, NixPrefetchGitOutput -> Text
sha256 :: Text
, NixPrefetchGitOutput -> Text
date :: Text
}
deriving (Int -> NixPrefetchGitOutput -> ShowS
[NixPrefetchGitOutput] -> ShowS
NixPrefetchGitOutput -> String
(Int -> NixPrefetchGitOutput -> ShowS)
-> (NixPrefetchGitOutput -> String)
-> ([NixPrefetchGitOutput] -> ShowS)
-> Show NixPrefetchGitOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NixPrefetchGitOutput] -> ShowS
$cshowList :: [NixPrefetchGitOutput] -> ShowS
show :: NixPrefetchGitOutput -> String
$cshow :: NixPrefetchGitOutput -> String
showsPrec :: Int -> NixPrefetchGitOutput -> ShowS
$cshowsPrec :: Int -> NixPrefetchGitOutput -> ShowS
Show, (forall x. NixPrefetchGitOutput -> Rep NixPrefetchGitOutput x)
-> (forall x. Rep NixPrefetchGitOutput x -> NixPrefetchGitOutput)
-> Generic NixPrefetchGitOutput
forall x. Rep NixPrefetchGitOutput x -> NixPrefetchGitOutput
forall x. NixPrefetchGitOutput -> Rep NixPrefetchGitOutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NixPrefetchGitOutput x -> NixPrefetchGitOutput
$cfrom :: forall x. NixPrefetchGitOutput -> Rep NixPrefetchGitOutput x
Generic, Value -> Parser [NixPrefetchGitOutput]
Value -> Parser NixPrefetchGitOutput
(Value -> Parser NixPrefetchGitOutput)
-> (Value -> Parser [NixPrefetchGitOutput])
-> FromJSON NixPrefetchGitOutput
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [NixPrefetchGitOutput]
$cparseJSONList :: Value -> Parser [NixPrefetchGitOutput]
parseJSON :: Value -> Parser NixPrefetchGitOutput
$cparseJSON :: Value -> Parser NixPrefetchGitOutput
FromJSON)
nixPrefetchGit
:: [Text]
-> Text
-> M NixPrefetchGitOutput
nixPrefetchGit :: [Text] -> Text -> M NixPrefetchGitOutput
nixPrefetchGit [Text]
extraArgs Text
prefetchURL = do
(ExitCode
exitCode, String
nsStdout, String
nsStderr) <- IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode
String
"nix-prefetch-git"
((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack [Text]
extraArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Text -> String
unpack Text
prefetchURL])
String
""
case ExitCode
exitCode of
ExitFailure Int
e -> Warning -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
forall a. Warning -> M a
refute1 (Int -> Text -> Warning
NixPrefetchGitFailed Int
e (String -> Text
pack String
nsStderr))
ExitCode
ExitSuccess -> () -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Warning -> Maybe NixPrefetchGitOutput -> M NixPrefetchGitOutput
forall a. Warning -> Maybe a -> M a
note (Text -> Warning
InvalidPrefetchGitOutput (String -> Text
pack String
nsStdout)) (ByteString -> Maybe NixPrefetchGitOutput
forall a. FromJSON a => ByteString -> Maybe a
decode (String -> ByteString
fromString String
nsStdout))
nixPrefetchUrl
:: [Text]
-> Text
-> M Text
nixPrefetchUrl :: [Text] -> Text -> M Text
nixPrefetchUrl [Text]
extraArgs Text
prefetchURL = do
(ExitCode
exitCode, String
nsStdout, String
nsStderr) <- IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode
String
"nix-prefetch-url"
((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
unpack [Text]
extraArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Text -> String
unpack Text
prefetchURL])
String
""
case ExitCode
exitCode of
ExitFailure Int
e -> Warning -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
forall a. Warning -> M a
refute1 (Int -> Text -> Warning
NixPrefetchUrlFailed Int
e (String -> Text
pack String
nsStderr))
ExitCode
ExitSuccess -> () -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Warning -> Maybe Text -> M Text
forall a. Warning -> Maybe a -> M a
note (Text -> Warning
InvalidPrefetchUrlOutput (String -> Text
pack String
nsStdout))
(Text -> Maybe Text
parseSHA256 (Text -> Text
T.strip (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
nsStdout))
newtype Revision = Revision { Revision -> Text
unRevision :: Text }
getGitFullName
:: Text
-> Revision
-> M Text
getGitFullName :: Text -> Revision -> M Text
getGitFullName Text
repo Revision
revision = do
Text -> Revision -> M (Maybe (Text, Text))
gitLsRemotes Text
repo Revision
revision M (Maybe (Text, Text)) -> (Maybe (Text, Text) -> M Text) -> M Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (Text
_hash, Text
name) -> Text -> M Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name
Maybe (Text, Text)
Nothing -> Warning -> M Text
forall a. Warning -> M a
refute1 (Warning -> M Text) -> Warning -> M Text
forall a b. (a -> b) -> a -> b
$ Text -> Warning
NoSuchRef (Revision -> Text
unRevision Revision
revision)
getGitRevision
:: Text
-> Revision
-> M Text
getGitRevision :: Text -> Revision -> M Text
getGitRevision Text
repo Revision
revision = do
Text -> Revision -> M (Maybe (Text, Text))
gitLsRemotes Text
repo Revision
revision M (Maybe (Text, Text)) -> (Maybe (Text, Text) -> M Text) -> M Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (Text
hash, Text
name) | Just Text
tag <- Text -> Text -> Maybe Text
stripPrefix Text
"refs/tags/" Text
name -> Text -> M Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
tag
| Bool
otherwise -> Text -> M Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
hash
Maybe (Text, Text)
Nothing -> Warning -> M Text
forall a. Warning -> M a
refute1 (Warning -> M Text) -> Warning -> M Text
forall a b. (a -> b) -> a -> b
$ Text -> Warning
NoSuchRef (Revision -> Text
unRevision Revision
revision)
gitLsRemotes :: Text -> Revision -> M (Maybe (Text, Text))
gitLsRemotes :: Text -> Revision -> M (Maybe (Text, Text))
gitLsRemotes Text
repo Revision
revision = do
let headsTags :: [Text]
headsTags = if Text -> Text -> Bool
T.isPrefixOf Text
"refs/" (Revision -> Text
unRevision Revision
revision)
then []
else [Text
"--heads", Text
"--tags"]
args :: [Text]
args =
[Text
"ls-remote", Text
"--sort=-v:refname", Text
repo, Revision -> Text
unRevision Revision
revision]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
headsTags :: [Text]
Text -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
logVerbose (Text -> ReaderT Env (ValidateT (Dual [Warning]) IO) ())
-> Text -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
forall a b. (a -> b) -> a -> b
$ Text
"Calling: git " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords [Text]
args
(ExitCode
exitCode, String
nsStdout, String
nsStderr) <- IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
(IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> ReaderT
Env (ValidateT (Dual [Warning]) IO) (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"git" (Text -> String
T.unpack (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
args) String
""
case ExitCode
exitCode of
ExitFailure Int
e -> Warning -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
forall a. Warning -> M a
refute1 (Int -> Text -> Warning
NixPrefetchGitFailed Int
e (String -> Text
pack String
nsStderr))
ExitCode
ExitSuccess -> () -> ReaderT Env (ValidateT (Dual [Warning]) IO) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let stdoutText :: Text
stdoutText = String -> Text
T.pack String
nsStdout
case (Text -> [Text]) -> [Text] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Text]
T.words ([Text] -> [[Text]]) -> (Text -> [Text]) -> Text -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> [[Text]]) -> Text -> [[Text]]
forall a b. (a -> b) -> a -> b
$ Text
stdoutText of
[] -> Maybe (Text, Text) -> M (Maybe (Text, Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, Text)
forall a. Maybe a
Nothing
[Text
hash, Text
name] : [[Text]]
_ -> Maybe (Text, Text) -> M (Maybe (Text, Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> M (Maybe (Text, Text)))
-> Maybe (Text, Text) -> M (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
hash, Text
name)
[[Text]]
_ -> Warning -> M (Maybe (Text, Text))
forall a. Warning -> M a
refute1 (Text -> Warning
InvalidGitLsRemoteOutput Text
stdoutText)
getGitHubRevisionDate :: Text -> Text -> Revision -> M Day
getGitHubRevisionDate :: Text -> Text -> Revision -> M Day
getGitHubRevisionDate Text
owner Text
repo Revision
revision = do
Text
dateString <- GitHubState
-> GitHubT (ReaderT Env (ValidateT (Dual [Warning]) IO)) Text
-> M Text
forall (m :: * -> *) a.
MonadIO m =>
GitHubState -> GitHubT m a -> m a
runGitHubT GitHubState
ghState (GitHubT (ReaderT Env (ValidateT (Dual [Warning]) IO)) Text
-> M Text)
-> GitHubT (ReaderT Env (ValidateT (Dual [Warning]) IO)) Text
-> M Text
forall a b. (a -> b) -> a -> b
$ do
Value
ref <- GHEndpoint
-> GitHubT (ReaderT Env (ValidateT (Dual [Warning]) IO)) Value
forall (m :: * -> *) a.
(MonadGitHubREST m, FromJSON a) =>
GHEndpoint -> m a
queryGitHub GHEndpoint :: StdMethod -> Text -> EndpointVals -> EndpointVals -> GHEndpoint
GHEndpoint
{ method :: StdMethod
method = StdMethod
GET
, endpoint :: Text
endpoint = Text
"/repos/:owner/:repo/commits/:ref"
, endpointVals :: EndpointVals
endpointVals = [ Text
"owner" Text -> Text -> KeyValue
forall v. (Show v, ToJSON v) => Text -> v -> KeyValue
:= Text
owner
, Text
"repo" Text -> Text -> KeyValue
forall v. (Show v, ToJSON v) => Text -> v -> KeyValue
:= Text
repo
, Text
"ref" Text -> Text -> KeyValue
forall v. (Show v, ToJSON v) => Text -> v -> KeyValue
:= Revision -> Text
unRevision Revision
revision
]
, ghData :: EndpointVals
ghData = []
}
Text -> GitHubT (ReaderT Env (ValidateT (Dual [Warning]) IO)) Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
-> GitHubT (ReaderT Env (ValidateT (Dual [Warning]) IO)) Text)
-> Text
-> GitHubT (ReaderT Env (ValidateT (Dual [Warning]) IO)) Text
forall a b. (a -> b) -> a -> b
$ Value
ref Value -> Text -> Value
forall a. FromJSON a => Value -> Text -> a
.: Text
"commit" Value -> Text -> Value
forall a. FromJSON a => Value -> Text -> a
.: Text
"committer" Value -> Text -> Text
forall a. FromJSON a => Value -> Text -> a
.: Text
"date"
Either Warning Day -> M Day
forall a. Either Warning a -> M a
fromEither (Either Warning Day -> M Day) -> Either Warning Day -> M Day
forall a b. (a -> b) -> a -> b
$ Text -> Either Warning Day
parseISO8601DateToDay Text
dateString
ghState :: GitHubState
ghState :: GitHubState
ghState = GitHubState :: Maybe Token -> ByteString -> ByteString -> GitHubState
GitHubState { $sel:token:GitHubState :: Maybe Token
token = Maybe Token
forall a. Maybe a
Nothing
, $sel:userAgent:GitHubState :: ByteString
userAgent = ByteString
"expipiplus1/update-nix-fetchgit"
, $sel:apiVersion:GitHubState :: ByteString
apiVersion = ByteString
"v3"
}
parseSHA256 :: Text -> Maybe Text
parseSHA256 :: Text -> Maybe Text
parseSHA256 Text
t = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
base32Length Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Int
T.length Text
t)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((Char -> Bool) -> Text -> Bool
T.all (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
base32Chars) Text
t)
Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
where
base32Chars :: String
base32Chars = String
"0123456789abcdfghijklmnpqrsvwxyz" :: String
sha256HashSize :: Int
sha256HashSize = Int
32
base32Length :: Int
base32Length = (Int
sha256HashSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
stripPrefix :: Text -> Text -> Maybe Text
stripPrefix :: Text -> Text -> Maybe Text
stripPrefix Text
p Text
t =
if Text
p Text -> Text -> Bool
`T.isPrefixOf` Text
t then Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop (Text -> Int
T.length Text
p) Text
t else Maybe Text
forall a. Maybe a
Nothing