diff --git a/Git/CmdLine.hs b/Git/CmdLine.hs --- a/Git/CmdLine.hs +++ b/Git/CmdLine.hs @@ -45,7 +45,6 @@ import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F import qualified Git -import qualified Git.Commit.Push as Git import qualified Git.Tree.Builder.Pure as Pure import Prelude hiding (FilePath) import Shelly hiding (trace) @@ -112,8 +111,7 @@ lookupTag = error "Not defined CmdLineRepository.cliLookupTag" lookupObject = error "Not defined CmdLineRepository.cliLookupObject" existsObject = cliExistsObject - pushCommit = \name _ rrefname -> Git.genericPushCommit name rrefname - listObjects = cliListObjects + sourceObjects = cliSourceObjects newTreeBuilder = Pure.newPureTreeBuilder cliReadTree cliWriteTree treeEntry = cliTreeEntry listTreeEntries = cliListTreeEntries @@ -122,7 +120,9 @@ createBlob = cliCreateBlob createCommit = cliCreateCommit createTag = cliCreateTag - remoteFetch = error "Not defined: CmdLineRepository.remoteFetch" + + -- remoteFetch = error "Not defined: CmdLineRepository.remoteFetch" + deleteRepository = cliGet >>= liftIO . F.removeTree . Git.repoPath . repoOptions @@ -153,7 +153,7 @@ -> CmdLineRepository m a doRunGit f args act = do repo <- cliGet - shellyNoDir $ silently $ do + shellyNoDir $ verbosely $ do act f "git" $ ["--git-dir", repoPath repo] <> args @@ -186,7 +186,7 @@ -> CmdLineRepository m (CommitOid m) cliPushCommit cname remoteNameOrURI remoteRefName msshCmd = do repo <- cliGet - merr <- shellyNoDir $ silently $ errExit False $ do + merr <- shellyNoDir $ verbosely $ errExit False $ do case msshCmd of Nothing -> return () Just sshCmd -> setenv "GIT_SSH" . toTextIgnore @@ -234,7 +234,7 @@ repo <- cliGet leftHead <- cliResolveRef "HEAD" - eres <- shellyNoDir $ silently $ errExit False $ do + eres <- shellyNoDir $ verbosely $ errExit False $ do case msshCmd of Nothing -> return () Just sshCmd -> setenv "GIT_SSH" . toTextIgnore @@ -272,7 +272,7 @@ -- create a detached commit and return its id. recordMerge repo leftHead = do rightHead <- getOid "MERGE_HEAD" - xs <- shellyNoDir $ silently $ errExit False $ do + xs <- shellyNoDir $ verbosely $ errExit False $ do xs <- returnConflict . TL.init <$> git [ "--git-dir", repoPath repo , "status", "-z", "--porcelain" ] @@ -376,16 +376,16 @@ => Git.SHA -> CmdLineRepository m Bool cliExistsObject (Git.shaToText -> sha) = do repo <- cliGet - shellyNoDir $ silently $ errExit False $ do + shellyNoDir $ verbosely $ errExit False $ do git_ [ "--git-dir", repoPath repo, "cat-file", "-e", fromStrict sha ] ec <- lastExitCode return (ec == 0) -cliListObjects :: Git.MonadGit m - => Maybe (CommitOid m) -> CommitOid m -> Bool - -> CmdLineRepository m [ObjectOid m] -cliListObjects mhave need alsoTrees = do - shas <- doRunGit run +cliSourceObjects :: Git.MonadGit m + => Maybe (CommitOid m) -> CommitOid m -> Bool + -> Source (CmdLineRepository m) (ObjectOid m) +cliSourceObjects mhave need alsoTrees = do + shas <- lift $ doRunGit run ([ "--no-pager", "log", "--format=%H %T" ] <> (case mhave of Nothing -> [ fromStrict (Git.renderObjOid need) ] @@ -394,12 +394,15 @@ , TL.append "^" (fromStrict (Git.renderObjOid need)) ])) $ return () - concat <$> mapM (go . T.words . toStrict) (TL.lines shas) + mapM_ (go . T.words . toStrict) (TL.lines shas) where go [csha,tsha] = do - coid <- Git.parseObjOid csha - toid <- Git.parseObjOid tsha - return $ [Git.CommitObjOid coid] <> [Git.TreeObjOid toid | alsoTrees] + coid <- lift $ Git.parseObjOid csha + yield $ Git.CommitObjOid coid + when alsoTrees $ do + toid <- lift $ Git.parseObjOid tsha + yield $ Git.TreeObjOid toid + go x = failure (Git.BackendError $ "Unexpected output from git-log: " <> T.pack (show x)) @@ -460,7 +463,7 @@ cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m) cliLookupTree oid@(Git.renderObjOid -> sha) = do repo <- cliGet - ec <- shellyNoDir $ silently $ errExit False $ do + ec <- shellyNoDir $ verbosely $ errExit False $ do git_ $ [ "--git-dir", repoPath repo, "cat-file", "-t", fromStrict sha ] lastExitCode if ec == 0 @@ -471,7 +474,7 @@ -> CmdLineRepository m (Maybe (TreeEntry m)) cliTreeEntry tree fp = do repo <- cliGet - mentryLines <- shellyNoDir $ silently $ errExit False $ do + mentryLines <- shellyNoDir $ verbosely $ errExit False $ do contents <- git $ [ "--git-dir", repoPath repo , "ls-tree", "-z" , fromStrict (Git.renderObjOid (Git.treeOid tree)) @@ -589,7 +592,7 @@ => Maybe Text -> CmdLineRepository m (Maybe [(TL.Text,TL.Text)]) cliShowRef mrefName = do repo <- cliGet - shellyNoDir $ silently $ errExit False $ do + shellyNoDir $ verbosely $ errExit False $ do rev <- git $ [ "--git-dir", repoPath repo, "show-ref" ] <> [ fromStrict (fromJust mrefName) | isJust mrefName ] ec <- lastExitCode @@ -602,7 +605,7 @@ => Text -> CmdLineRepository m (Maybe (RefTarget m)) cliLookupRef refName = do repo <- cliGet - (ec,rev) <- shellyNoDir $ silently $ errExit False $ do + (ec,rev) <- shellyNoDir $ verbosely $ errExit False $ do rev <- git $ [ "--git-dir", repoPath repo , "symbolic-ref", fromStrict refName ] ec <- lastExitCode @@ -635,7 +638,7 @@ => Text -> CmdLineRepository m (Maybe (CommitOid m)) cliResolveRef refName = do repo <- cliGet - (rev, ec) <- shellyNoDir $ silently $ errExit False $ do + (rev, ec) <- shellyNoDir $ verbosely $ errExit False $ do rev <- git [ "--git-dir", repoPath repo , "rev-parse", "--quiet", "--verify" , fromStrict refName ] @@ -741,7 +744,7 @@ Right p -> do when (not exists && Git.repoAutoCreate opts) $ do liftIO $ F.createTree (fromText (fromStrict p)) - shellyNoDir $ silently $ + shellyNoDir $ verbosely $ git_ $ ["--git-dir", fromStrict p] <> ["--bare" | Git.repoIsBare opts] <> ["init"] diff --git a/gitlib-cmdline.cabal b/gitlib-cmdline.cabal --- a/gitlib-cmdline.cabal +++ b/gitlib-cmdline.cabal @@ -1,5 +1,5 @@ Name: gitlib-cmdline -Version: 2.0.0.0 +Version: 2.0.1.0 Synopsis: Gitlib repository backend that uses the git command-line tool. Description: Gitlib repository backend that uses the git command-line tool. License-file: LICENSE @@ -20,7 +20,7 @@ ghc-options: -Wall build-depends: base >= 3 && < 5 - , gitlib >= 2.0.0.0 + , gitlib >= 2.0.1.0 , bytestring >= 0.9.2.1 , conduit >= 0.5.5 , containers >= 0.4.2.1 @@ -49,9 +49,9 @@ hs-source-dirs: test build-depends: base >=3 - , gitlib >= 2.0.0.0 + , gitlib >= 2.0.1.0 , gitlib-test >= 2.0.0.0 - , gitlib-cmdline >= 2.0.0.0 + , gitlib-cmdline >= 2.0.1.0 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3