diff --git a/Git/CmdLine.hs b/Git/CmdLine.hs --- a/Git/CmdLine.hs +++ b/Git/CmdLine.hs @@ -25,6 +25,7 @@ import Control.Monad.Trans.Reader import qualified Data.ByteString as B import Data.Conduit hiding (MonadBaseControl) +import Data.Foldable (for_) import Data.Function import qualified Data.HashMap.Strict as HashMap import Data.List as L @@ -41,13 +42,11 @@ import qualified Data.Text.Lazy as TL #endif import Data.Time -import Data.Tuple -import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F import qualified Git import qualified Git.Tree.Builder.Pure as Pure -import Prelude hiding (FilePath) -import Shelly hiding (trace) +import Shelly hiding (FilePath, trace) +import System.Directory import System.Exit import System.IO.Unsafe import System.Locale (defaultTimeLocale) @@ -124,7 +123,8 @@ -- remoteFetch = error "Not defined: CmdLineRepository.remoteFetch" deleteRepository = - cliGet >>= liftIO . F.removeTree . Git.repoPath . repoOptions + cliGet >>= liftIO + . removeDirectoryRecursive . Git.repoPath . repoOptions mkOid :: Git.MonadGit m => forall o. TL.Text -> CmdLineRepository m (Tagged o Git.SHA) @@ -149,11 +149,11 @@ git_ = run_ "git" doRunGit :: Git.MonadGit m - => (FilePath -> [TL.Text] -> Sh a) -> [TL.Text] -> Sh () + => (F.FilePath -> [TL.Text] -> Sh a) -> [TL.Text] -> Sh () -> CmdLineRepository m a doRunGit f args act = do repo <- cliGet - shellyNoDir $ verbosely $ do + shellyNoDir $ silently $ do act f "git" $ ["--git-dir", repoPath repo] <> args @@ -175,26 +175,21 @@ then Right () else Left $ Git.RepositoryCannotAccess remoteURI -cliFilePathToURI :: Git.MonadGit m => FilePath -> m Text -cliFilePathToURI = - fmap (T.append "file://localhost" . toStrict . toTextIgnore) - . liftIO - . F.canonicalizePath +cliFilePathToURI :: Git.MonadGit m => FilePath -> m FilePath +cliFilePathToURI = fmap ("file://localhost" <>) . liftIO . canonicalizePath cliPushCommit :: Git.MonadGit m => CommitOid m -> Text -> Text -> Maybe FilePath -> CmdLineRepository m (CommitOid m) cliPushCommit cname remoteNameOrURI remoteRefName msshCmd = do repo <- cliGet - merr <- shellyNoDir $ verbosely $ errExit False $ do - case msshCmd of - Nothing -> return () - Just sshCmd -> setenv "GIT_SSH" . toTextIgnore - =<< liftIO (F.canonicalizePath sshCmd) + merr <- shellyNoDir $ silently $ errExit False $ do + for_ msshCmd $ \sshCmd -> + setenv "GIT_SSH" . TL.pack =<< liftIO (canonicalizePath sshCmd) eres <- cliRepoDoesExist remoteNameOrURI case eres of - Left e -> return (Just e) + Left e -> return $ Just e Right () -> do git_ $ [ "--git-dir", repoPath repo ] <> [ "push", fromStrict remoteNameOrURI @@ -234,11 +229,9 @@ repo <- cliGet leftHead <- cliResolveRef "HEAD" - eres <- shellyNoDir $ verbosely $ errExit False $ do - case msshCmd of - Nothing -> return () - Just sshCmd -> setenv "GIT_SSH" . toTextIgnore - =<< liftIO (F.canonicalizePath sshCmd) + eres <- shellyNoDir $ silently $ errExit False $ do + for_ msshCmd $ \sshCmd -> + setenv "GIT_SSH" . TL.pack =<< liftIO (canonicalizePath sshCmd) eres <- cliRepoDoesExist remoteNameOrURI case eres of @@ -272,7 +265,7 @@ -- create a detached commit and return its id. recordMerge repo leftHead = do rightHead <- getOid "MERGE_HEAD" - xs <- shellyNoDir $ verbosely $ errExit False $ do + xs <- shellyNoDir $ silently $ errExit False $ do xs <- returnConflict . TL.init <$> git [ "--git-dir", repoPath repo , "status", "-z", "--porcelain" ] @@ -284,8 +277,7 @@ <$> getOid "HEAD" <*> pure leftHead <*> pure rightHead - <*> pure (Map.fromList . filter (isConflict . snd) - . Map.toList $ xs) + <*> pure (Map.filter isConflict xs) isConflict (Git.Deleted, Git.Deleted) = False isConflict (_, Git.Unchanged) = False @@ -293,17 +285,23 @@ isConflict _ = True handleFile repo fp (Git.Deleted, Git.Deleted) = - git_ [ "--git-dir", repoPath repo, "rm", "--cached", fromStrict fp ] + git_ [ "--git-dir", repoPath repo, "rm", "--cached" + , fromStrict . T.decodeUtf8 $ fp + ] handleFile repo fp (Git.Unchanged, Git.Deleted) = - git_ [ "--git-dir", repoPath repo, "rm", "--cached", fromStrict fp ] + git_ [ "--git-dir", repoPath repo, "rm", "--cached" + , fromStrict . T.decodeUtf8 $ fp + ] handleFile repo fp (_, _) = - git_ [ "--git-dir", repoPath repo, "add", fromStrict fp ] + git_ [ "--git-dir", repoPath repo, "add" + , fromStrict . T.decodeUtf8 $ fp + ] getOid name = do mref <- cliResolveRef name case mref of - Nothing -> failure (Git.BackendError $ - T.append "Reference missing: " name) + Nothing -> failure $ Git.BackendError + $ T.append "Reference missing: " name Just ref -> return ref charToModKind 'M' = Just Git.Modified @@ -316,7 +314,9 @@ Map.fromList . map (\(f, (l, r)) -> (f, getModKinds l r)) . filter (\(_, (l, r)) -> ((&&) `on` isJust) l r) - . map (\l -> (toStrict $ TL.drop 3 l, + -- jww (2013-08-25): What is the correct way to interpret the + -- output from "git status"? + . map (\l -> (T.encodeUtf8 . toStrict . TL.drop 3 $ l, (charToModKind (TL.index l 0), charToModKind (TL.index l 1)))) . init @@ -376,7 +376,7 @@ => Git.SHA -> CmdLineRepository m Bool cliExistsObject (Git.shaToText -> sha) = do repo <- cliGet - shellyNoDir $ verbosely $ errExit False $ do + shellyNoDir $ silently $ errExit False $ do git_ [ "--git-dir", repoPath repo, "cat-file", "-e", fromStrict sha ] ec <- lastExitCode return (ec == 0) @@ -417,11 +417,11 @@ <$> mapM cliParseLsTree (L.init (TL.splitOn "\NUL" contents)) cliParseLsTree :: Git.MonadGit m - => TL.Text -> CmdLineRepository m (Text, TreeEntry m) + => TL.Text -> CmdLineRepository m (Git.TreeFilePath, TreeEntry m) cliParseLsTree line = let [prefix,path] = TL.splitOn "\t" line [mode,kind,sha] = TL.words prefix - in liftM2 (,) (return (toStrict path)) $ case kind of + in liftM2 (,) (return (T.encodeUtf8 . toStrict $ path)) $ case kind of "blob" -> do oid <- mkOid sha return $ Git.BlobEntry oid $ case mode of @@ -431,7 +431,7 @@ _ -> Git.UnknownBlob "commit" -> Git.CommitEntry <$> mkOid sha "tree" -> Git.TreeEntry <$> mkOid sha - _ -> failure (Git.BackendError "This cannot happen") + _ -> failure $ Git.BackendError "This cannot happen" cliWriteTree :: Git.MonadGit m => Pure.EntryHashMap (CmdLineRepository m) @@ -443,42 +443,51 @@ $ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL" mkOid (TL.init oid) where - renderLine (path, Git.BlobEntry (Git.renderObjOid -> sha) kind) = - return $ TL.concat [ case kind of - Git.PlainBlob -> "100644" - Git.ExecutableBlob -> "100755" - Git.SymlinkBlob -> "120000" - Git.UnknownBlob -> "100000" - , " blob ", fromStrict sha, "\t", fromStrict path ] - renderLine (path, Git.CommitEntry coid) = do - return $ TL.concat [ "160000 commit " - , fromStrict (Git.renderObjOid coid), "\t" - , fromStrict path ] - renderLine (path, Git.TreeEntry toid) = do + renderLine (fromStrict . T.decodeUtf8 -> path, + Git.BlobEntry (Git.renderObjOid -> sha) kind) = return $ TL.concat + [ case kind of + Git.PlainBlob -> "100644" + Git.ExecutableBlob -> "100755" + Git.SymlinkBlob -> "120000" + Git.UnknownBlob -> "100000" + , " blob ", fromStrict sha, "\t", path + ] + renderLine (fromStrict . T.decodeUtf8 -> path, Git.CommitEntry coid) = do + return $ TL.concat + [ "160000 commit " + , fromStrict (Git.renderObjOid coid), "\t" + , path + ] + renderLine (fromStrict . T.decodeUtf8 -> path, Git.TreeEntry toid) = do + return $ TL.concat [ "040000 tree " , fromStrict (Git.renderObjOid toid), "\t" - , fromStrict path ] + , path + ] cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m) cliLookupTree oid@(Git.renderObjOid -> sha) = do repo <- cliGet - ec <- shellyNoDir $ verbosely $ errExit False $ do + ec <- shellyNoDir $ silently $ errExit False $ do git_ $ [ "--git-dir", repoPath repo, "cat-file", "-t", fromStrict sha ] lastExitCode if ec == 0 then return $ CmdLineTree oid else failure (Git.ObjectLookupFailed sha 40) -cliTreeEntry :: Git.MonadGit m => Tree m -> Text +cliTreeEntry :: Git.MonadGit m + => Tree m + -> Git.TreeFilePath -> CmdLineRepository m (Maybe (TreeEntry m)) cliTreeEntry tree fp = do repo <- cliGet - mentryLines <- shellyNoDir $ verbosely $ errExit False $ do + mentryLines <- shellyNoDir $ silently $ errExit False $ do contents <- git $ [ "--git-dir", repoPath repo , "ls-tree", "-z" , fromStrict (Git.renderObjOid (Git.treeOid tree)) - , "--", fromStrict fp ] + , "--", fromStrict . T.decodeUtf8 $ fp + ] ec <- lastExitCode return $ if ec == 0 then Just $ L.init (TL.splitOn "\NUL" contents) @@ -493,7 +502,7 @@ cliListTreeEntries :: Git.MonadGit m => Tree m - -> CmdLineRepository m [(Text, TreeEntry m)] + -> CmdLineRepository m [(Git.TreeFilePath, TreeEntry m)] cliListTreeEntries tree = do contents <- runGit [ "ls-tree", "-t", "-r", "-z" , fromStrict (Git.renderObjOid (Git.treeOid tree)) ] @@ -592,7 +601,7 @@ => Maybe Text -> CmdLineRepository m (Maybe [(TL.Text,TL.Text)]) cliShowRef mrefName = do repo <- cliGet - shellyNoDir $ verbosely $ errExit False $ do + shellyNoDir $ silently $ errExit False $ do rev <- git $ [ "--git-dir", repoPath repo, "show-ref" ] <> [ fromStrict (fromJust mrefName) | isJust mrefName ] ec <- lastExitCode @@ -605,7 +614,7 @@ => Text -> CmdLineRepository m (Maybe (RefTarget m)) cliLookupRef refName = do repo <- cliGet - (ec,rev) <- shellyNoDir $ verbosely $ errExit False $ do + (ec,rev) <- shellyNoDir $ silently $ errExit False $ do rev <- git $ [ "--git-dir", repoPath repo , "symbolic-ref", fromStrict refName ] ec <- lastExitCode @@ -638,7 +647,7 @@ => Text -> CmdLineRepository m (Maybe (CommitOid m)) cliResolveRef refName = do repo <- cliGet - (rev, ec) <- shellyNoDir $ verbosely $ errExit False $ do + (rev, ec) <- shellyNoDir $ silently $ errExit False $ do rev <- git [ "--git-dir", repoPath repo , "rev-parse", "--quiet", "--verify" , fromStrict refName ] @@ -671,7 +680,7 @@ } repoPath :: Repository -> TL.Text -repoPath = toTextIgnore . Git.repoPath . repoOptions +repoPath = TL.pack . Git.repoPath . repoOptions newtype CmdLineRepository m a = CmdLineRepository { cmdLineRepositoryReaderT :: ReaderT Repository m a } @@ -738,17 +747,14 @@ openCliRepository :: Git.MonadGit m => Git.RepositoryOptions -> m Repository openCliRepository opts = do let path = Git.repoPath opts - exists <- liftIO $ F.isDirectory path - case F.toText path of - Left e -> failure (Git.BackendError e) - Right p -> do - when (not exists && Git.repoAutoCreate opts) $ do - liftIO $ F.createTree (fromText (fromStrict p)) - shellyNoDir $ verbosely $ - git_ $ ["--git-dir", fromStrict p] - <> ["--bare" | Git.repoIsBare opts] - <> ["init"] - return Repository { repoOptions = opts } + exists <- liftIO $ doesDirectoryExist path + when (not exists && Git.repoAutoCreate opts) $ do + liftIO $ createDirectoryIfMissing True path + shellyNoDir $ silently $ + git_ $ ["--git-dir", TL.pack path] + <> ["--bare" | Git.repoIsBare opts] + <> ["init"] + return Repository { repoOptions = opts } runCliRepository :: Git.MonadGit m => Repository -> CmdLineRepository m a -> m a runCliRepository repo action = 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.1.0 +Version: 2.1.0.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,10 +20,11 @@ ghc-options: -Wall build-depends: base >= 3 && < 5 - , gitlib >= 2.0.1.0 + , gitlib >= 2.1.0.0 , bytestring >= 0.9.2.1 , conduit >= 0.5.5 , containers >= 0.4.2.1 + , directory >= 1.1.0.2 , failure >= 0.2.0.1 , monad-control >= 0.3.2 , old-locale >= 1.0.0.4 @@ -49,9 +50,9 @@ hs-source-dirs: test build-depends: base >=3 - , gitlib >= 2.0.1.0 - , gitlib-test >= 2.0.0.0 - , gitlib-cmdline >= 2.0.1.0 + , gitlib >= 2.1.0.0 + , gitlib-test >= 2.1.0.0 + , gitlib-cmdline >= 2.1.0.0 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3