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 extraArgs :: [Text]
extraArgs prefetchURL :: Text
prefetchURL = do
  (exitCode :: ExitCode
exitCode, nsStdout :: String
nsStdout, nsStderr :: 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
    "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])
    ""
  case ExitCode
exitCode of
    ExitFailure e :: Int
e -> Warning -> M ()
forall a. Warning -> M a
refute1 (Int -> Text -> Warning
NixPrefetchGitFailed Int
e (String -> Text
pack String
nsStderr))
    ExitSuccess   -> () -> M ()
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 --unpack
nixPrefetchUrl
  :: [Text] -- ^ Extra arguments for nix-prefetch-url
  -> Text   -- ^ The URL to prefetch
  -> M Text -- The sha256 output
nixPrefetchUrl :: [Text] -> Text -> M Text
nixPrefetchUrl extraArgs :: [Text]
extraArgs prefetchURL :: Text
prefetchURL = do
  (exitCode :: ExitCode
exitCode, nsStdout :: String
nsStdout, nsStderr :: 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
    "nix-prefetch-url"
    ("--unpack" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (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])
    ""
  case ExitCode
exitCode of
    ExitFailure e :: Int
e -> Warning -> M ()
forall a. Warning -> M a
refute1 (Int -> Text -> Warning
NixPrefetchUrlFailed Int
e (String -> Text
pack String
nsStderr))
    ExitSuccess   -> () -> M ()
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 repo :: Text
repo revision :: 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 (_hash :: Text
_hash, name :: Text
name) -> Text -> M Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name
    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 repo :: Text
repo revision :: 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 (hash :: Text
hash, name :: Text
name) | Just tag :: Text
tag <- Text -> Text -> Maybe Text
stripPrefix "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
    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 repo :: Text
repo revision :: Revision
revision = do
  let headsTags :: [String]
headsTags = if Text -> Text -> Bool
T.isPrefixOf "refs/" (Revision -> Text
unRevision Revision
revision)
        then []
        else ["--heads", "--tags"]
  (exitCode :: ExitCode
exitCode, nsStdout :: String
nsStdout, nsStderr :: 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
    "git"
    (  [ "ls-remote"
       , "--sort=-v:refname"
       , Text -> String
T.unpack Text
repo
       , Text -> String
T.unpack (Revision -> Text
unRevision Revision
revision)
       ]
    [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
headsTags
    )
    ""
  case ExitCode
exitCode of
    ExitFailure e :: Int
e -> Warning -> M ()
forall a. Warning -> M a
refute1 (Int -> Text -> Warning
NixPrefetchGitFailed Int
e (String -> Text
pack String
nsStderr))
    ExitSuccess   -> () -> M ()
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
    [hash :: Text
hash, name :: Text
name] : _ -> 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)
    _                -> 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 owner :: Text
owner repo :: Text
repo revision :: 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     = "/repos/:owner/:repo/commits/:ref"
      , endpointVals :: EndpointVals
endpointVals = [ "owner" Text -> Text -> KeyValue
forall v. (Show v, ToJSON v) => Text -> v -> KeyValue
:= Text
owner
                       , "repo" Text -> Text -> KeyValue
forall v. (Show v, ToJSON v) => Text -> v -> KeyValue
:= Text
repo
                       , "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
.: "commit" Value -> Text -> Value
forall a. FromJSON a => Value -> Text -> a
.: "committer" Value -> Text -> Text
forall a. FromJSON a => Value -> Text -> a
.: "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  = "expipiplus1/update-nix-fetchgit"
                      , $sel:apiVersion:GitHubState :: ByteString
apiVersion = "v3"
                      }

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

parseSHA256 :: Text -> Maybe Text
parseSHA256 :: Text -> Maybe Text
parseSHA256 t :: 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    = "0123456789abcdfghijklmnpqrsvwxyz" :: String
  sha256HashSize :: Int
sha256HashSize = 32
  base32Length :: Int
base32Length   = (Int
sha256HashSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` 5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1

stripPrefix :: Text -> Text -> Maybe Text
stripPrefix :: Text -> Text -> Maybe Text
stripPrefix p :: Text
p t :: 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