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


-- | The type of nix-prefetch-git's output
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)

-- | Run nix-prefetch-git
nixPrefetchGit
  :: [Text] -- ^ Extra arguments for nix-prefetch-git
  -> Text   -- ^ The URL to prefetch
  -> 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))

-- | Run nix-prefetch-url
nixPrefetchUrl
  :: [Text] -- ^ Extra arguments for nix-prefetch-url
  -> Text   -- ^ The URL to prefetch
  -> M Text -- The sha256 output
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 }

-- | Discover if this ref is a branch or a tag
--
-- >>> runM _ $ getGitFullName "https://github.com/expipiplus1/update-nix-fetchgit" (Revision "0.1.0.0")
-- Right "refs/tags/0.1.0.0"
--
-- >>> runM _ $ getGitFullName "https://github.com/expipiplus1/update-nix-fetchgit" (Revision "joe-fetchTarball")
-- Right "refs/heads/joe-fetchTarball"
getGitFullName
  :: Text
  -- ^ git repo location
  -> Revision
  -- ^ branch or tag name
  -> M Text
  -- ^ Full name, i.e. with refs/heads/ or refs/tags/
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)

-- | Return a tag or a hash
getGitRevision
  :: Text
  -- ^ git repo location
  -> Revision
  -- ^ branch or tag name
  -> 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)

-- | Run git ls-remote --heads --tags --sort=-v:refname and return the first
-- match if any. Use '--heads --tags' if the revision doesn't start with
-- 'refs/' to avoid getting 'remote' refs.
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"
                      }

----------------------------------------------------------------
-- Utils
----------------------------------------------------------------

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