diff --git a/src/Niv/Git/Cmd.hs b/src/Niv/Git/Cmd.hs index a58be11..0a3ec75 100644 --- a/src/Niv/Git/Cmd.hs +++ b/src/Niv/Git/Cmd.hs @@ -1,8 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE QuasiQuotes #-} -module Niv.Git.Cmd (gitCmd) where +module Niv.Git.Cmd {- (gitCmd) -} where +import Control.Arrow +import Data.String.QQ (s) +import Data.Text.Extended as T import Niv.Cmd +import Niv.Sources +import Niv.Update +import System.Exit (ExitCode(ExitSuccess)) +import System.Process (readProcessWithExitCode) +import qualified Data.HashMap.Strict as HMS +import qualified Data.Text as T import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts @@ -10,11 +22,14 @@ gitCmd :: Cmd gitCmd = Cmd { description = describeGit , parseCmdShortcut = pure Nothing - , parsePackageSpec = pure mempty - , updateCmd = error "git update is not implemented yet" + , parsePackageSpec = parseGitPackageSpec + , updateCmd = gitUpdate , name = "git" } +parseGitPackageSpec :: Opts.Parser PackageSpec +parseGitPackageSpec = pure $ PackageSpec $ HMS.singleton "repo" "git@github.com:nmattia/niv" + describeGit :: Opts.InfoMod a describeGit = mconcat [ Opts.fullDesc @@ -27,13 +42,91 @@ describeGit = mconcat " niv add https://github.com/stedolan/jq.git" ] --- for git: --- default branch: --- ~/niv$ git ls-remote --symref git@github.com:NixOS/nixpkgs HEAD --- ref: refs/heads/master HEAD --- 3dd8e8e7faa87fc45c2492f88643bb363572180e HEAD --- 0a46a71a6ec41764b118a24e4cbf1b4bc4be906e refs/remotes/origin/HEAD --- --- lastest rev: --- ~/niv$ git ls-remote git@github.com:NixOS/nixpkgs refs/heads/master --- 3dd8e8e7faa87fc45c2492f88643bb363572180e refs/heads/master +gitUpdate :: Update () () +gitUpdate = proc () -> do + useOrSet "type" -< ("git" :: Box T.Text) + repository <- load "repo" -< () + refAndRev <- (discoverRev <+> discoverRefAndRev) -< repository + update "ref" -< fst <$> refAndRev + update "rev" -< snd <$> refAndRev + returnA -< () + where + discoverRefAndRev = proc repository -> do + run defaultRefAndHEAD -< repository + discoverRev = proc repository -> do + ref <- load "ref" -< () + rev <- run (\(r1,r2) -> latestRev r1 r2)-< (,) <$> repository <*> ref + returnA -< (,) <$> ref <*> rev + +latestRev + :: T.Text -- ^ the repository + -> T.Text -- ^ the ref/branch + -> IO T.Text +latestRev repo ref = do + let gitArgs = [ "ls-remote", repo, "refs/heads/" <> ref ] + sout <- runGit gitArgs + case sout of + ls@(_:_:_) -> abortTooMuchOutput ls + (l1:[]) -> parseRev l1 + [] -> abortNoOutput + where + parseRev l = maybe (abortNoRev l) pure $ do + checkRev $ T.takeWhile (/= '\t') l + checkRev t = if isRev t then Just t else Nothing + abortNoOutput = abort "foo" -- TODO: args + abortBugIn + +defaultRefAndHEAD + :: T.Text -- ^ the repository + -> IO (T.Text, T.Text) +defaultRefAndHEAD repo = do + sout <- runGit [ "ls-remote", "--symref", repo, "HEAD" ] + case sout of + (l1:l2:_) -> (,) <$> parseRef l1 <*> parseRev l2 + _ -> abortNoRefAndRev + where + parseRef l = maybe (abortNoRef l) pure $ do + -- ref: refs/head/master\tHEAD -> master\tHEAD + refAndSym <- T.stripPrefix "ref: refs/heads/" l + let ref = T.takeWhile (/= '\t') refAndSym + if T.null ref then Nothing else Just ref + parseRev l = maybe (abortNoRev l) pure $ do + checkRev $ T.takeWhile (/= '\t') l + checkRev t = if isRev t then Just t else Nothing + +-- | Run the "git" executable +runGit :: [T.Text] -> IO [T.Text] +runGit args = do + (exitCode, sout, serr) <- readProcessWithExitCode "git" (T.unpack <$> args) "" + case (exitCode, lines sout) of + (ExitSuccess, ls) -> pure $ T.pack <$> ls + _ -> abortGitFailure args (T.pack sout) (T.pack serr) + +isRev :: T.Text -> Bool +isRev t = + -- commit hashes a comprised of abcdef0123456789 + T.all (\c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9')) t && + -- commit _should_ be 40 chars long, but to be sure we pick 7 + T.length t >= 7 + +abortTooMuchOutput :: [T.Text] -> IO a +abortTooMuchOutput = abort . T.unwords + +abortNoRef :: T.Text -> IO a +abortNoRef = abort -- TODO + +abortNoRev :: T.Text -> IO a +abortNoRev = abort -- TODO + +abortNoRefAndRev :: IO a +abortNoRefAndRev = error "foo" + +-- TODO: mention error code +abortGitFailure :: [T.Text] -> T.Text -> T.Text -> IO a +abortGitFailure args sout serr = abort $ [s| +Could not read the output of 'git'. This is a bug. Please create a +ticket: + + https://github.com/nmattia/niv/issues/new + +Thanks! I'll buy you a beer. +|] <> T.unlines ["command: ", T.unwords args, "stdout: ", sout, "stderr: ", serr] diff --git a/src/Niv/GitHub/Cmd.hs b/src/Niv/GitHub/Cmd.hs index dba412b..c5b9fbf 100644 --- a/src/Niv/GitHub/Cmd.hs +++ b/src/Niv/GitHub/Cmd.hs @@ -132,7 +132,6 @@ parseAddShortcutGitHub str = githubUpdate' :: Update () () githubUpdate' = githubUpdate nixPrefetchURL githubLatestRev githubRepo --- TODO: dedup nixPrefetchURL :: Bool -> T.Text -> IO T.Text nixPrefetchURL unpack (T.unpack -> url) = do (exitCode, sout, serr) <- runNixPrefetch