{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Niv.Git.Cmd where

import Control.Applicative
import Control.Arrow
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Char8 as B8
import qualified Data.HashMap.Strict as HMS
import Data.Maybe
import qualified Data.Text as T
import Data.Text.Extended as T
import Niv.Cmd
import Niv.Logger
import Niv.Sources
import Niv.Update
import qualified Options.Applicative as Opts
import qualified Options.Applicative.Help.Pretty as Opts
import System.Exit (ExitCode (ExitSuccess))
import System.Process (readProcessWithExitCode)

gitCmd :: Cmd
gitCmd :: Cmd
gitCmd =
  Cmd :: (forall a. InfoMod a)
-> (Text -> Maybe (PackageName, Object))
-> Parser PackageSpec
-> Update () ()
-> Text
-> (Attrs -> [Text])
-> Cmd
Cmd
    { description :: forall a. InfoMod a
description = forall a. InfoMod a
describeGit,
      parseCmdShortcut :: Text -> Maybe (PackageName, Object)
parseCmdShortcut = Text -> Maybe (PackageName, Object)
parseGitShortcut,
      parsePackageSpec :: Parser PackageSpec
parsePackageSpec = Parser PackageSpec
parseGitPackageSpec,
      updateCmd :: Update () ()
updateCmd = Update () ()
gitUpdate',
      name :: Text
name = Text
"git",
      extraLogs :: Attrs -> [Text]
extraLogs = Attrs -> [Text]
gitExtraLogs
    }

gitExtraLogs :: Attrs -> [T.Text]
gitExtraLogs :: Attrs -> [Text]
gitExtraLogs Attrs
attrs = [Text]
noteRef [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
warnRefBranch [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
warnRefTag
  where
    noteRef :: [Text]
noteRef =
      Bool -> Text -> [Text]
forall a. Bool -> a -> [a]
textIf (Text -> Attrs -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HMS.member Text
"ref" Attrs
attrs) (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
        Text -> Text
mkNote
          Text
"Your source contains a `ref` attribute. Make sure your sources.nix is up-to-date and consider using a `branch` or `tag` attribute."
    warnRefBranch :: [Text]
warnRefBranch =
      Bool -> Text -> [Text]
forall a. Bool -> a -> [a]
textIf (Text -> Bool
member Text
"ref" Bool -> Bool -> Bool
&& Text -> Bool
member Text
"branch") (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
        Text -> Text
mkWarn
          Text
"Your source contains both a `ref` and a `branch`. Niv will update the `branch` but the `ref` will be used by Nix to fetch the repo."
    warnRefTag :: [Text]
warnRefTag =
      Bool -> Text -> [Text]
forall a. Bool -> a -> [a]
textIf (Text -> Bool
member Text
"ref" Bool -> Bool -> Bool
&& Text -> Bool
member Text
"tag") (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
        Text -> Text
mkWarn
          Text
"Your source contains both a `ref` and a `tag`. The `ref` will be used by Nix to fetch the repo."
    member :: Text -> Bool
member Text
x = Text -> Attrs -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HMS.member Text
x Attrs
attrs
    textIf :: Bool -> a -> [a]
textIf Bool
cond a
txt = if Bool
cond then [a
txt] else []

parseGitShortcut :: T.Text -> Maybe (PackageName, Aeson.Object)
parseGitShortcut :: Text -> Maybe (PackageName, Object)
parseGitShortcut txt' :: Text
txt'@((Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') -> Text
txt) =
  -- basic heuristics for figuring out if something is a git repo
  if Bool
isGitURL
    then case Text -> Text -> [Text]
T.splitOn Text
"/" Text
txt of
      [] -> Maybe (PackageName, Object)
forall a. Maybe a
Nothing
      ([Text] -> Text
forall a. [a] -> a
last -> Text
w) -> case Text -> Text -> Maybe Text
T.stripSuffix Text
".git" Text
w of
        Maybe Text
Nothing -> (PackageName, Object) -> Maybe (PackageName, Object)
forall a. a -> Maybe a
Just (Text -> PackageName
PackageName Text
w, Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KM.singleton Key
"repo" (Text -> Value
Aeson.String Text
txt'))
        Just Text
w' -> (PackageName, Object) -> Maybe (PackageName, Object)
forall a. a -> Maybe a
Just (Text -> PackageName
PackageName Text
w', Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KM.singleton Key
"repo" (Text -> Value
Aeson.String Text
txt'))
    else Maybe (PackageName, Object)
forall a. Maybe a
Nothing
  where
    isGitURL :: Bool
isGitURL =
      Text
".git" Text -> Text -> Bool
`T.isSuffixOf` Text
txt
        Bool -> Bool -> Bool
|| Text
"git@" Text -> Text -> Bool
`T.isPrefixOf` Text
txt
        Bool -> Bool -> Bool
|| Text
"ssh://" Text -> Text -> Bool
`T.isPrefixOf` Text
txt

parseGitPackageSpec :: Opts.Parser PackageSpec
parseGitPackageSpec :: Parser PackageSpec
parseGitPackageSpec =
  (Object -> PackageSpec
PackageSpec (Object -> PackageSpec)
-> ([(Key, Value)] -> Object) -> [(Key, Value)] -> PackageSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList)
    ([(Key, Value)] -> PackageSpec)
-> Parser [(Key, Value)] -> Parser PackageSpec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Key, Value) -> Parser [(Key, Value)]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser (Key, Value)
parseRepo Parser (Key, Value) -> Parser (Key, Value) -> Parser (Key, Value)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Key, Value)
parseBranch Parser (Key, Value) -> Parser (Key, Value) -> Parser (Key, Value)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Key, Value)
parseRev Parser (Key, Value) -> Parser (Key, Value) -> Parser (Key, Value)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Key, Value)
parseAttr Parser (Key, Value) -> Parser (Key, Value) -> Parser (Key, Value)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Key, Value)
parseSAttr)
  where
    parseRepo :: Parser (Key, Value)
parseRepo =
      (Key
"repo",) (Value -> (Key, Value)) -> (Text -> Value) -> Text -> (Key, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Aeson.String
        (Text -> (Key, Value)) -> Parser Text -> Parser (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
Opts.strOption
          ( String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"repo"
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"URL"
          )
    parseRev :: Parser (Key, Value)
parseRev =
      (Key
"rev",) (Value -> (Key, Value)) -> (Text -> Value) -> Text -> (Key, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Aeson.String
        (Text -> (Key, Value)) -> Parser Text -> Parser (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
Opts.strOption
          ( String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"rev"
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"SHA"
          )
    parseBranch :: Parser (Key, Value)
parseBranch =
      (Key
"branch",) (Value -> (Key, Value)) -> (Text -> Value) -> Text -> (Key, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Aeson.String
        (Text -> (Key, Value)) -> Parser Text -> Parser (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields Text -> Parser Text
forall s. IsString s => Mod OptionFields s -> Parser s
Opts.strOption
          ( String -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"branch"
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Text
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
'b'
              Mod OptionFields Text
-> Mod OptionFields Text -> Mod OptionFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"BRANCH"
          )
    parseAttr :: Parser (Key, Value)
parseAttr =
      ReadM (Key, Value)
-> Mod OptionFields (Key, Value) -> Parser (Key, Value)
forall a. ReadM a -> Mod OptionFields a -> Parser a
Opts.option
        ((String -> Maybe (Key, Value)) -> ReadM (Key, Value)
forall a. (String -> Maybe a) -> ReadM a
Opts.maybeReader String -> Maybe (Key, Value)
parseKeyValJSON)
        ( String -> Mod OptionFields (Key, Value)
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"attribute"
            Mod OptionFields (Key, Value)
-> Mod OptionFields (Key, Value) -> Mod OptionFields (Key, Value)
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields (Key, Value)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
'a'
            Mod OptionFields (Key, Value)
-> Mod OptionFields (Key, Value) -> Mod OptionFields (Key, Value)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Key, Value)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"KEY=VAL"
            Mod OptionFields (Key, Value)
-> Mod OptionFields (Key, Value) -> Mod OptionFields (Key, Value)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Key, Value)
forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."
        )
    parseSAttr :: Parser (Key, Value)
parseSAttr =
      ReadM (Key, Value)
-> Mod OptionFields (Key, Value) -> Parser (Key, Value)
forall a. ReadM a -> Mod OptionFields a -> Parser a
Opts.option
        ((String -> Maybe (Key, Value)) -> ReadM (Key, Value)
forall a. (String -> Maybe a) -> ReadM a
Opts.maybeReader ((String -> Value) -> String -> Maybe (Key, Value)
parseKeyVal String -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON))
        ( String -> Mod OptionFields (Key, Value)
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opts.long String
"string-attribute"
            Mod OptionFields (Key, Value)
-> Mod OptionFields (Key, Value) -> Mod OptionFields (Key, Value)
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields (Key, Value)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
Opts.short Char
's'
            Mod OptionFields (Key, Value)
-> Mod OptionFields (Key, Value) -> Mod OptionFields (Key, Value)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Key, Value)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Opts.metavar String
"KEY=VAL"
            Mod OptionFields (Key, Value)
-> Mod OptionFields (Key, Value) -> Mod OptionFields (Key, Value)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (Key, Value)
forall (f :: * -> *) a. String -> Mod f a
Opts.help String
"Set the package spec attribute <KEY> to <VAL>."
        )
    parseKeyValJSON :: String -> Maybe (Key, Value)
parseKeyValJSON = (String -> Value) -> String -> Maybe (Key, Value)
parseKeyVal ((String -> Value) -> String -> Maybe (Key, Value))
-> (String -> Value) -> String -> Maybe (Key, Value)
forall a b. (a -> b) -> a -> b
$ \String
x ->
      Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (String -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON String
x) (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict (String -> ByteString
B8.pack String
x))
    -- Parse "key=val" into ("key", val)
    parseKeyVal ::
      -- | how to convert to JSON
      (String -> Aeson.Value) ->
      String ->
      Maybe (K.Key, Aeson.Value)
    parseKeyVal :: (String -> Value) -> String -> Maybe (Key, Value)
parseKeyVal String -> Value
toJSON String
str = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') String
str of
      (String
key, Char
'=' : String
val) -> (Key, Value) -> Maybe (Key, Value)
forall a. a -> Maybe a
Just (String -> Key
K.fromString String
key, String -> Value
toJSON String
val)
      (String, String)
_ -> Maybe (Key, Value)
forall a. Maybe a
Nothing

describeGit :: Opts.InfoMod a
describeGit :: InfoMod a
describeGit =
  [InfoMod a] -> InfoMod a
forall a. Monoid a => [a] -> a
mconcat
    [ InfoMod a
forall a. InfoMod a
Opts.fullDesc,
      String -> InfoMod a
forall a. String -> InfoMod a
Opts.progDesc String
"Add a git dependency. Experimental.",
      Maybe Doc -> InfoMod a
forall a. Maybe Doc -> InfoMod a
Opts.headerDoc (Maybe Doc -> InfoMod a) -> Maybe Doc -> InfoMod a
forall a b. (a -> b) -> a -> b
$
        Doc -> Maybe Doc
forall a. a -> Maybe a
Just (Doc -> Maybe Doc) -> Doc -> Maybe Doc
forall a b. (a -> b) -> a -> b
$
          Doc
"Examples:"
            Doc -> Doc -> Doc
Opts.<$$> Doc
""
            Doc -> Doc -> Doc
Opts.<$$> Doc
"  niv add git git@github.com:stedolan/jq"
            Doc -> Doc -> Doc
Opts.<$$> Doc
"  niv add git ssh://git@github.com/stedolan/jq --rev deadb33f"
            Doc -> Doc -> Doc
Opts.<$$> Doc
"  niv add git https://github.com/stedolan/jq.git"
            Doc -> Doc -> Doc
Opts.<$$> Doc
"  niv add git --repo /my/custom/repo --name custom --branch development"
    ]

gitUpdate ::
  -- | latest rev
  (T.Text -> T.Text -> IO T.Text) ->
  -- | latest rev and default ref
  (T.Text -> IO (T.Text, T.Text)) ->
  Update () ()
gitUpdate :: (Text -> Text -> IO Text)
-> (Text -> IO (Text, Text)) -> Update () ()
gitUpdate Text -> Text -> IO Text
latestRev' Text -> IO (Text, Text)
defaultBranchAndRev' = proc () -> do
  Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
useOrSet Text
"type" -< (Box Text
"git" :: Box T.Text)
  Box Text
repository <- Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"repo" -< ()
  Update (Box Text) ()
discoverRev Update (Box Text) ()
-> Update (Box Text) () -> Update (Box Text) ()
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> Update (Box Text) ()
discoverRefAndRev -< Box Text
repository
  where
    discoverRefAndRev :: Update (Box Text) ()
discoverRefAndRev = proc Box Text
repository -> do
      Box (Text, Text)
branchAndRev <- (Text -> IO (Text, Text)) -> Update (Box Text) (Box (Text, Text))
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run Text -> IO (Text, Text)
defaultBranchAndRev' -< Box Text
repository
      Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"branch" -< (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> Box (Text, Text) -> Box Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box (Text, Text)
branchAndRev
      Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"rev" -< (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> Box (Text, Text) -> Box Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box (Text, Text)
branchAndRev
      Update () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
    discoverRev :: Update (Box Text) ()
discoverRev = proc Box Text
repository -> do
      Box Text
branch <- Text -> Update () (Box Text)
forall a. FromJSON a => Text -> Update () (Box a)
load Text
"branch" -< ()
      Box Text
rev <- ((Text, Text) -> IO Text) -> Update (Box (Text, Text)) (Box Text)
forall a b. (a -> IO b) -> Update (Box a) (Box b)
run' ((Text -> Text -> IO Text) -> (Text, Text) -> IO Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> IO Text
latestRev') -< (,) (Text -> Text -> (Text, Text))
-> Box Text -> Box (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Box Text
repository Box (Text -> (Text, Text)) -> Box Text -> Box (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Box Text
branch
      Text -> Update (Box Text) (Box Text)
forall a. JSON a => Text -> Update (Box a) (Box a)
update Text
"rev" -< Box Text
rev
      Update () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()

-- | The "real" (IO) update
gitUpdate' :: Update () ()
gitUpdate' :: Update () ()
gitUpdate' = (Text -> Text -> IO Text)
-> (Text -> IO (Text, Text)) -> Update () ()
gitUpdate Text -> Text -> IO Text
latestRev Text -> IO (Text, Text)
defaultBranchAndRev

latestRev ::
  -- | the repository
  T.Text ->
  -- | the branch
  T.Text ->
  IO T.Text
latestRev :: Text -> Text -> IO Text
latestRev Text
repo Text
branch = do
  let gitArgs :: [Text]
gitArgs = [Text
"ls-remote", Text
repo, Text
"refs/heads/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch]
  [Text]
sout <- [Text] -> IO [Text]
runGit [Text]
gitArgs
  case [Text]
sout of
    ls :: [Text]
ls@(Text
_ : Text
_ : [Text]
_) -> [Text] -> [Text] -> IO Text
forall a. [Text] -> [Text] -> IO a
abortTooMuchOutput [Text]
gitArgs [Text]
ls
    (Text
l1 : []) -> [Text] -> Text -> IO Text
parseRev [Text]
gitArgs Text
l1
    [] -> [Text] -> IO Text
forall a. [Text] -> IO a
abortNoOutput [Text]
gitArgs
  where
    parseRev :: [Text] -> Text -> IO Text
parseRev [Text]
args Text
l = IO Text -> (Text -> IO Text) -> Maybe Text -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> Text -> IO Text
forall a. [Text] -> Text -> IO a
abortNoRev [Text]
args Text
l) Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO Text) -> Maybe Text -> IO Text
forall a b. (a -> b) -> a -> b
$ do
      Text -> Maybe Text
checkRev (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t') Text
l
    checkRev :: Text -> Maybe Text
checkRev Text
t = if Text -> Bool
isRev Text
t then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t else Maybe Text
forall a. Maybe a
Nothing
    abortNoOutput :: [Text] -> IO a
abortNoOutput [Text]
args =
      [Text] -> Text -> IO a
forall a. [Text] -> Text -> IO a
abortGitFailure
        [Text]
args
        (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$ Text
"Git didn't produce any output. Does the branch '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' exist?"
    abortTooMuchOutput :: [Text] -> [Text] -> IO a
abortTooMuchOutput [Text]
args [Text]
ls =
      [Text] -> Text -> IO a
forall a. [Text] -> Text -> IO a
abortGitBug [Text]
args (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
          [Text
"Git produced too much output:"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
ls

defaultBranchAndRev ::
  -- | the repository
  T.Text ->
  IO (T.Text, T.Text)
defaultBranchAndRev :: Text -> IO (Text, Text)
defaultBranchAndRev Text
repo = do
  [Text]
sout <- [Text] -> IO [Text]
runGit [Text]
args
  case [Text]
sout of
    (Text
l1 : Text
l2 : [Text]
_) -> (,) (Text -> Text -> (Text, Text))
-> IO Text -> IO (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> IO Text
parseBranch Text
l1 IO (Text -> (Text, Text)) -> IO Text -> IO (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> IO Text
parseRev Text
l2
    [Text]
_ ->
      [Text] -> Text -> IO (Text, Text)
forall a. [Text] -> Text -> IO a
abortGitBug [Text]
args (Text -> IO (Text, Text)) -> Text -> IO (Text, Text)
forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
          [ Text
"Could not read reference and revision from stdout:"
          ]
            [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
sout
  where
    args :: [Text]
args = [Text
"ls-remote", Text
"--symref", Text
repo, Text
"HEAD"]
    parseBranch :: Text -> IO Text
parseBranch Text
l = IO Text -> (Text -> IO Text) -> Maybe Text -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> Text -> IO Text
forall a. [Text] -> Text -> IO a
abortNoRef [Text]
args Text
l) Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO Text) -> Maybe Text -> IO Text
forall a b. (a -> b) -> a -> b
$ do
      -- ref: refs/head/master\tHEAD -> master\tHEAD
      Text
refAndSym <- Text -> Text -> Maybe Text
T.stripPrefix Text
"ref: refs/heads/" Text
l
      let branch :: Text
branch = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t') Text
refAndSym
      if Text -> Bool
T.null Text
branch then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
branch
    parseRev :: Text -> IO Text
parseRev Text
l = IO Text -> (Text -> IO Text) -> Maybe Text -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> Text -> IO Text
forall a. [Text] -> Text -> IO a
abortNoRev [Text]
args Text
l) Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO Text) -> Maybe Text -> IO Text
forall a b. (a -> b) -> a -> b
$ do
      Text -> Maybe Text
checkRev (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t') Text
l
    checkRev :: Text -> Maybe Text
checkRev Text
t = if Text -> Bool
isRev Text
t then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t else Maybe Text
forall a. Maybe a
Nothing

abortNoRev :: [T.Text] -> T.Text -> IO a
abortNoRev :: [Text] -> Text -> IO a
abortNoRev [Text]
args Text
l = [Text] -> Text -> IO a
forall a. [Text] -> Text -> IO a
abortGitBug [Text]
args (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$ Text
"Could not read revision from: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l

abortNoRef :: [T.Text] -> T.Text -> IO a
abortNoRef :: [Text] -> Text -> IO a
abortNoRef [Text]
args Text
l = [Text] -> Text -> IO a
forall a. [Text] -> Text -> IO a
abortGitBug [Text]
args (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$ Text
"Could not read reference from: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
l

-- | Run the "git" executable
runGit :: [T.Text] -> IO [T.Text]
runGit :: [Text] -> IO [Text]
runGit [Text]
args = do
  (ExitCode
exitCode, String
sout, String
serr) <- 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, String -> [String]
lines String
sout) of
    (ExitCode
ExitSuccess, [String]
ls) -> [Text] -> IO [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
ls
    (ExitCode, [String])
_ ->
      [Text] -> Text -> IO [Text]
forall a. [Text] -> Text -> IO a
abortGitBug [Text]
args (Text -> IO [Text]) -> Text -> IO [Text]
forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
T.unlines
          [ [Text] -> Text
T.unwords [Text
"stdout:", String -> Text
T.pack String
sout],
            [Text] -> Text
T.unwords [Text
"stderr:", String -> Text
T.pack String
serr]
          ]

isRev :: T.Text -> Bool
isRev :: Text -> Bool
isRev Text
t =
  -- commit hashes are comprised of abcdef0123456789
  (Char -> Bool) -> Text -> Bool
T.all (\Char
c -> (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f') Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')) Text
t
    Bool -> Bool -> Bool
&&
    -- commit _should_ be 40 chars long, but to be sure we pick 7
    Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
7

abortGitFailure :: [T.Text] -> T.Text -> IO a
abortGitFailure :: [Text] -> Text -> IO a
abortGitFailure [Text]
args Text
msg =
  Text -> IO a
forall (io :: * -> *) a. MonadIO io => Text -> io a
abort (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
T.unlines
      [ Text
"Could not read the output of 'git'.",
        [Text] -> Text
T.unwords (Text
"command:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"git" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
args),
        Text
msg
      ]

abortGitBug :: [T.Text] -> T.Text -> IO a
abortGitBug :: [Text] -> Text -> IO a
abortGitBug [Text]
args Text
msg =
  Text -> IO a
forall (io :: * -> *) a. MonadIO io => Text -> io a
abort (Text -> IO a) -> Text -> IO a
forall a b. (a -> b) -> a -> b
$
    Text -> Text
bug (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
T.unlines
        [ Text
"Could not read the output of 'git'.",
          [Text] -> Text
T.unwords (Text
"command:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"git" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
args),
          Text
msg
        ]