gitlib-cmdline 2.0.1.0 → 2.1.0.0

raw patch · 2 files changed

+81/−74 lines, 2 filesdep +directorydep ~gitlibdep ~gitlib-cmdlinedep ~gitlib-testPVP ok

version bump matches the API change (PVP)

Dependencies added: directory

Dependency ranges changed: gitlib, gitlib-cmdline, gitlib-test

API changes (from Hackage documentation)

Files

• Git/CmdLine.hs +75/−69
• gitlib-cmdline.cabal +6/−5

@@ -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 =

@@ -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