gitlib-cmdline (empty) → 1.0.1
raw patch · 5 files changed
+975/−0 lines, 5 filesdep +HUnitdep +basedep +bytestringsetup-changed
Dependencies added: HUnit, base, bytestring, conduit, containers, failure, gitlib, gitlib-cmdline, gitlib-test, gitlib-utils, hspec, hspec-expectations, monad-control, old-locale, parsec, process-extras, shelly, system-fileio, system-filepath, tagged, text, time, transformers, transformers-base, unordered-containers
Files
- Git/CmdLine.hs +874/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- gitlib-cmdline.cabal +63/−0
- test/Smoke.hs +16/−0
+ Git/CmdLine.hs view
@@ -0,0 +1,874 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Git.CmdLine where++import Control.Applicative hiding (many)+import Control.Exception hiding (try)+import Control.Failure+import Control.Monad+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Reader+import qualified Data.ByteString as B+import Data.Conduit hiding (MonadBaseControl)+import Data.Function+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.IORef+import Data.List as L+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.Tagged+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import Data.Time+import Data.Tuple+import qualified Filesystem as F+import qualified Filesystem.Path.CurrentOS as F+import qualified Git+import qualified Git.Utils as Git+import Prelude hiding (FilePath)+import Shelly hiding (trace)+import System.Exit+import System.IO.Unsafe+import System.Locale (defaultTimeLocale)+import System.Process.ByteString+import Text.Parsec.Char+import Text.Parsec.Combinator+import Text.Parsec.Language (haskellDef)+import Text.Parsec.Prim+import Text.Parsec.Token++type Oid m = Git.Oid (CmdLineRepository m)++type BlobOid m = Git.BlobOid (CmdLineRepository m)+type TreeOid m = Git.TreeOid (CmdLineRepository m)+type CommitOid m = Git.CommitOid (CmdLineRepository m)+type TagOid m = Git.TagOid (CmdLineRepository m)++type Blob m = Git.Blob (CmdLineRepository m)+type Tree m = Git.Tree (CmdLineRepository m)+type TreeEntry m = Git.TreeEntry (CmdLineRepository m)+type Commit m = Git.Commit (CmdLineRepository m)+type Tag m = Git.Tag (CmdLineRepository m)++type TreeRef m = Git.TreeRef (CmdLineRepository m)+type CommitRef m = Git.CommitRef (CmdLineRepository m)+type CommitName m = Git.CommitName (CmdLineRepository m)++type Reference m = Git.Reference (CmdLineRepository m) (Commit m)+type Object m = Git.Object (CmdLineRepository m)++instance Git.MonadGit m => Git.Repository (CmdLineRepository m) where+ data Oid (CmdLineRepository m) = Oid { getOid :: TL.Text }++ data TreeData (CmdLineRepository m) = TreeData+ { cliTreeOid :: IORef (Maybe (TreeOid m))+ , cliTreeContents :: IORef (HashMap Text (TreeEntry m))+ }++ data Options (CmdLineRepository m) = Options++ facts = return Git.RepositoryFacts+ { Git.hasSymbolicReferences = True }++ parseOid = return . Oid . TL.fromStrict+ renderOid (Oid x) = TL.toStrict x++ lookupRef = cliLookupRef+ createRef = cliUpdateRef+ updateRef = cliUpdateRef+ deleteRef = cliDeleteRef+ resolveRef = cliResolveRef+ allRefs = cliAllRefs+ lookupCommit = cliLookupCommit+ lookupTree = cliLookupTree+ lookupBlob = cliLookupBlob+ lookupTag = error "Not defined CmdLineRepository.cliLookupTag"+ lookupObject = error "Not defined CmdLineRepository.cliLookupObject"+ existsObject = cliExistsObject+ pushCommit = \name _ rrefname -> Git.genericPushCommit name rrefname+ traverseCommits = cliTraverseCommits+ missingObjects = cliMissingObjects+ traverseObjects = error "Not defined: CmdLineRepository.traverseObjects"+ newTree = cliNewTree+ hashContents = cliHashContents+ createBlob = cliCreateBlob+ createCommit = cliCreateCommit+ createTag = cliCreateTag++ remoteFetch = error "Not defined: CmdLineRepository.remoteFetch"++ deleteRepository =+ cliGet >>= liftIO . F.removeTree . Git.repoPath . repoOptions++instance Show (Git.Oid (CmdLineRepository m)) where+ show (Oid x) = show x++instance Ord (Git.Oid (CmdLineRepository m)) where+ compare (Oid l) (Oid r) = compare l r++instance Eq (Git.Oid (CmdLineRepository m)) where+ Oid l == Oid r = l == r++git :: [TL.Text] -> Sh TL.Text+git args = do+ -- liftIO $ putStrLn $ "CmdLine: git " ++ show args+ run "git" args++git_ :: [TL.Text] -> Sh ()+git_ args = do+ -- liftIO $ putStrLn $ "CmdLine: git " ++ show args+ run_ "git" args++doRunGit :: Git.MonadGit m+ => (FilePath -> [TL.Text] -> Sh a) -> [TL.Text] -> Sh ()+ -> CmdLineRepository m a+doRunGit f args act = do+ repo <- cliGet+ shellyNoDir $ silently $ do+ act+ -- liftIO $ putStrLn $ "CmdLine: git "+ -- ++ show (["--git-dir", repoPath repo] <> args)+ f "git" $ ["--git-dir", repoPath repo] <> args++runGit :: Git.MonadGit m+ => [TL.Text] -> CmdLineRepository m TL.Text+runGit = flip (doRunGit run) (return ())++runGit_ :: Git.MonadGit m+ => [TL.Text] -> CmdLineRepository m ()+runGit_ = flip (doRunGit run_) (return ())++cliRepoDoesExist :: Text -> Sh (Either Git.GitException ())+cliRepoDoesExist remoteURI = do+ setenv "SSH_ASKPASS" "echo"+ setenv "GIT_ASKPASS" "echo"+ git_ [ "ls-remote", TL.fromStrict remoteURI ]+ ec <- lastExitCode+ return $ if ec == 0+ then Right ()+ else Left $ Git.RepositoryCannotAccess remoteURI++cliFilePathToURI :: Git.MonadGit m => FilePath -> m Text+cliFilePathToURI =+ fmap (T.append "file://localhost" . TL.toStrict . toTextIgnore)+ . liftIO+ . F.canonicalizePath++cliPushCommitDirectly :: Git.MonadGit m+ => CommitName m -> Text -> Text -> Maybe FilePath+ -> CmdLineRepository m (CommitRef m)+cliPushCommitDirectly cname remoteNameOrURI remoteRefName msshCmd = do+ repo <- cliGet+ merr <- shellyNoDir $ silently $ errExit False $ do+ case msshCmd of+ Nothing -> return ()+ Just sshCmd -> setenv "GIT_SSH" . toTextIgnore+ =<< liftIO (F.canonicalizePath sshCmd)++ eres <- cliRepoDoesExist remoteNameOrURI+ case eres of+ Left e -> return (Just e)+ Right () -> do+ git_ $ [ "--git-dir", repoPath repo ]+ <> [ "push", TL.fromStrict remoteNameOrURI+ , TL.concat [ TL.fromStrict (Git.renderCommitName cname)+ , ":", TL.fromStrict remoteRefName ] ]+ r <- lastExitCode+ if r == 0+ then return Nothing+ else Just+ . (\x -> if "non-fast-forward" `T.isInfixOf` x ||+ "Note about fast-forwards" `T.isInfixOf` x+ then Git.PushNotFastForward x+ else (Git.BackendError $+ "git push failed:\n" <> x))+ . TL.toStrict <$> lastStderr+ case merr of+ Nothing -> do+ mcref <- Git.resolveRef remoteRefName+ case mcref of+ Nothing -> failure (Git.BackendError $ "git push failed")+ Just cref -> return cref+ Just err -> failure err++cliResetHard :: Git.MonadGit m => Text -> CmdLineRepository m ()+cliResetHard refname =+ doRunGit run_ [ "reset", "--hard", TL.fromStrict refname ] $ return ()++cliPullCommitDirectly :: Git.MonadGit m+ => Text+ -> Text+ -> Text+ -> Text+ -> Maybe FilePath+ -> CmdLineRepository m+ (Git.MergeResult (CmdLineRepository m))+cliPullCommitDirectly remoteNameOrURI remoteRefName user email msshCmd = do+ repo <- cliGet+ leftHead <- Git.resolveRef "HEAD"++ eres <- shellyNoDir $ silently $ errExit False $ do+ case msshCmd of+ Nothing -> return ()+ Just sshCmd -> setenv "GIT_SSH" . toTextIgnore+ =<< liftIO (F.canonicalizePath sshCmd)++ eres <- cliRepoDoesExist remoteNameOrURI+ case eres of+ Left e -> return (Left e)+ Right () -> do+ git_ $ [ "--git-dir", repoPath repo+ , "config", "user.name", TL.fromStrict user+ ]+ git_ $ [ "--git-dir", repoPath repo+ , "config", "user.email", TL.fromStrict email+ ]+ git_ $ [ "--git-dir", repoPath repo+ , "-c", "merge.conflictstyle=merge"+ ]+ <> [ "pull", "--quiet"+ , TL.fromStrict remoteNameOrURI+ , TL.fromStrict remoteRefName ]+ Right <$> lastExitCode+ case eres of+ Left err -> failure err+ Right r ->+ if r == 0+ then Git.MergeSuccess <$> getOid "HEAD"+ else case leftHead of+ Nothing ->+ failure (Git.BackendError+ "Reference missing: HEAD (left)")+ Just lh -> recordMerge repo (Git.commitRefOid lh)+ where+ -- jww (2013-05-15): This function should not overwrite head, but simply+ -- create a detached commit and return its id.+ recordMerge repo leftHead = do+ rightHead <- getOid "MERGE_HEAD"+ xs <- shellyNoDir $ silently $ errExit False $ do+ xs <- returnConflict . TL.init+ <$> git [ "--git-dir", repoPath repo+ , "status", "-z", "--porcelain" ]+ forM_ (Map.assocs xs) $ uncurry (handleFile repo)+ git_ [ "--git-dir", repoPath repo+ , "commit", "-F", ".git/MERGE_MSG" ]+ return xs+ Git.MergeConflicted+ <$> getOid "HEAD"+ <*> pure leftHead+ <*> pure rightHead+ <*> pure (Map.fromList . filter (isConflict . snd)+ . Map.toList $ xs)++ isConflict (Git.Deleted, Git.Deleted) = False+ isConflict (_, Git.Unchanged) = False+ isConflict (Git.Unchanged, _) = False+ isConflict _ = True++ handleFile repo fp (Git.Deleted, Git.Deleted) =+ git_ [ "--git-dir", repoPath repo, "rm", "--cached", toTextIgnore fp ]+ handleFile repo fp (Git.Unchanged, Git.Deleted) =+ git_ [ "--git-dir", repoPath repo, "rm", "--cached", toTextIgnore fp ]+ handleFile repo fp (_, _) =+ git_ [ "--git-dir", repoPath repo, "add", toTextIgnore fp ]++ getOid name = do+ mref <- Git.resolveRef name+ case mref of+ Nothing -> failure (Git.BackendError $+ T.append "Reference missing: " name)+ Just ref -> return (Git.commitRefOid ref)++ charToModKind 'M' = Just Git.Modified+ charToModKind 'U' = Just Git.Unchanged+ charToModKind 'A' = Just Git.Added+ charToModKind 'D' = Just Git.Deleted+ charToModKind _ = Nothing++ returnConflict xs =+ Map.fromList+ . map (\(f, (l, r)) -> (f, getModKinds l r))+ . filter (\(_, (l, r)) -> ((&&) `on` isJust) l r)+ . map (\l -> (fromText $ TL.drop 3 l,+ (charToModKind (TL.index l 0),+ charToModKind (TL.index l 1))))+ . init+ . TL.splitOn "\NUL" $ xs++ getModKinds l r = case (l, r) of+ (Nothing, Just x) -> (Git.Unchanged, x)+ (Just x, Nothing) -> (x, Git.Unchanged)+ -- 'U' really means unmerged, but it can mean both modified and+ -- unmodified as a result. Example: UU means both sides have modified+ -- a file, but AU means that the left side added the file and the+ -- right side knows nothing about the file.+ (Just Git.Unchanged,+ Just Git.Unchanged) -> (Git.Modified, Git.Modified)+ (Just x, Just y) -> (x, y)+ (Nothing, Nothing) -> error "Both merge items cannot be Unchanged"++cliLookupBlob :: Git.MonadGit m+ => BlobOid m -> CmdLineRepository m (Blob m)+cliLookupBlob oid@(Tagged (Oid sha)) = do+ repo <- cliGet+ (r,out,_) <-+ liftIO $ readProcessWithExitCode "git"+ [ "--git-dir", TL.unpack (repoPath repo)+ , "cat-file", "-p", TL.unpack sha ]+ B.empty+ if r == ExitSuccess+ then return (Git.Blob oid (Git.BlobString out))+ else failure Git.BlobLookupFailed++cliDoCreateBlob :: Git.MonadGit m+ => Git.BlobContents (CmdLineRepository m) -> Bool+ -> CmdLineRepository m (BlobOid m)+cliDoCreateBlob b persist = do+ repo <- cliGet+ bs <- Git.blobContentsToByteString b+ (r,out,_) <-+ liftIO $ readProcessWithExitCode "git"+ ([ "--git-dir", TL.unpack (repoPath repo), "hash-object" ]+ <> ["-w" | persist] <> ["--stdin"])+ bs+ if r == ExitSuccess+ then return . Tagged . Oid . TL.fromStrict . T.init . T.decodeUtf8 $ out+ else failure Git.BlobCreateFailed++cliHashContents :: Git.MonadGit m+ => Git.BlobContents (CmdLineRepository m)+ -> CmdLineRepository m (BlobOid m)+cliHashContents b = cliDoCreateBlob b False++cliCreateBlob :: Git.MonadGit m+ => Git.BlobContents (CmdLineRepository m)+ -> CmdLineRepository m (BlobOid m)+cliCreateBlob b = cliDoCreateBlob b True++cliExistsObject :: Git.MonadGit m => Oid m -> CmdLineRepository m Bool+cliExistsObject (Oid sha) = do+ repo <- cliGet+ shellyNoDir $ silently $ errExit False $ do+ git_ [ "--git-dir", repoPath repo, "cat-file", "-e", sha ]+ ec <- lastExitCode+ return (ec == 0)++cliTraverseCommits :: Git.MonadGit m+ => (CommitRef m -> CmdLineRepository m a)+ -> CommitName m+ -> CmdLineRepository m [a]+cliTraverseCommits f name = do+ shas <- doRunGit run [ "--no-pager", "log", "--format=%H"+ , TL.fromStrict (Git.renderCommitName name) ]+ $ return ()+ mapM (\sha -> f =<< (Git.ByOid . Tagged <$> Git.parseOid (TL.toStrict sha)))+ (TL.lines shas)++cliMissingObjects :: Git.MonadGit m+ => Maybe (CommitName m) -> CommitName m+ -> CmdLineRepository m [Object m]+cliMissingObjects mhave need = do+ shas <- doRunGit run+ ([ "--no-pager", "log", "--format=%H %T", "-z"]+ <> (case mhave of+ Nothing -> [ TL.fromStrict (Git.renderCommitName need) ]+ Just have ->+ [ TL.fromStrict (Git.renderCommitName have)+ , TL.append "^"+ (TL.fromStrict (Git.renderCommitName need)) ]))+ $ return ()+ concat <$> mapM (go . T.words . TL.toStrict) (TL.lines shas)+ where+ go [csha,tsha] = do+ coid <- Git.parseOid csha+ toid <- Git.parseOid tsha+ return [ Git.CommitObj (Git.ByOid (Tagged coid))+ , Git.TreeObj (Git.ByOid (Tagged toid))+ ]+ go x = failure (Git.BackendError $+ "Unexpected output from git-log: " <> T.pack (show x))++cliMakeTree :: Git.MonadGit m+ => IORef (Maybe (TreeOid m))+ -> IORef (HashMap Text (TreeEntry m))+ -> Tree m+cliMakeTree oid contents =+ Git.mkTree cliModifyTree cliWriteTree cliTraverseEntries $+ TreeData oid contents++cliNewTree :: Git.MonadGit m => CmdLineRepository m (Tree m)+cliNewTree = cliMakeTree <$> liftIO (newIORef Nothing)+ <*> liftIO (newIORef HashMap.empty)++cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m)+cliLookupTree oid@(Tagged (Oid sha)) = do+ contents <- runGit ["ls-tree", "-z", sha]+ oidRef <- liftIO $ newIORef (Just oid)+ -- Even though the tree entries are separated by \NUL, for whatever reason+ -- @git ls-tree@ also outputs a newline at the end.+ contentsRef <- liftIO $ newIORef $ HashMap.fromList $+ map parseLine (L.init (TL.splitOn "\NUL" contents))+ return $ cliMakeTree oidRef contentsRef+ where+ parseLine line =+ let [prefix,path] = TL.splitOn "\t" line+ [mode,kind,sha] = TL.words prefix+ in (TL.toStrict path,+ case kind of+ "blob" -> Git.BlobEntry (Tagged (Oid sha)) $+ case mode of+ "100644" -> Git.PlainBlob+ "100755" -> Git.ExecutableBlob+ "120000" -> Git.SymlinkBlob+ _ -> Git.UnknownBlob+ "commit" -> Git.CommitEntry (Tagged (Oid sha))+ "tree" -> Git.TreeEntry (Git.ByOid (Tagged (Oid sha)))+ _ -> error "This cannot happen")++doLookupTreeEntry :: Git.MonadGit m => Tree m -> [Text]+ -> CmdLineRepository m (Maybe (TreeEntry m))+doLookupTreeEntry t [] = return (Just (Git.treeEntry t))+doLookupTreeEntry t (name:names) = do+ -- Lookup the current name in this tree. If it doesn't exist, and there are+ -- more names in the path and 'createIfNotExist' is True, create a new Tree+ -- and descend into it. Otherwise, if it exists we'll have @Just (TreeEntry+ -- {})@, and if not we'll have Nothing.++ y <- liftIO $ HashMap.lookup name+ <$> readIORef (cliTreeContents (Git.getTreeData t))+ if null names+ then return y+ else case y of+ Just (Git.BlobEntry {}) ->+ failure Git.TreeCannotTraverseBlob+ Just (Git.CommitEntry {}) ->+ failure Git.TreeCannotTraverseCommit+ Just (Git.TreeEntry t') -> do+ t'' <- Git.resolveTreeRef t'+ doLookupTreeEntry t'' names+ _ -> return Nothing++doModifyTree :: Git.MonadGit m+ => Tree m+ -> [Text]+ -> Bool+ -> (Maybe (TreeEntry m)+ -> CmdLineRepository m+ (Git.ModifyTreeResult (CmdLineRepository m)))+ -> CmdLineRepository m (Git.ModifyTreeResult (CmdLineRepository m))+doModifyTree t [] _ _ =+ return . Git.TreeEntryPersistent . Git.TreeEntry . Git.Known $ t+doModifyTree t (name:names) createIfNotExist f = do+ -- Lookup the current name in this tree. If it doesn't exist, and there+ -- are more names in the path and 'createIfNotExist' is True, create a new+ -- Tree and descend into it. Otherwise, if it exists we'll have @Just+ -- (TreeEntry {})@, and if not we'll have Nothing.+ y' <- doLookupTreeEntry t [name]+ y <- if isNothing y' && createIfNotExist && not (null names)+ then Just . Git.TreeEntry . Git.Known <$> Git.newTree+ else return y'++ if null names+ then do+ -- If there are no further names in the path, call the transformer+ -- function, f. It receives a @Maybe TreeEntry@ to indicate if there+ -- was a previous entry at this path. It should return a 'Left' value+ -- to propagate out a user-defined error, or a @Maybe TreeEntry@ to+ -- indicate whether the entry at this path should be deleted or+ -- replaced with something new.+ --+ -- NOTE: There is no provision for leaving the entry unchanged! It is+ -- assumed to always be changed, as we have no reliable method of+ -- testing object equality that is not O(n).+ ze <- f y+ liftIO $ modifyIORef (cliTreeContents (Git.getTreeData t)) $+ case ze of+ Git.TreeEntryNotFound -> id+ Git.TreeEntryPersistent _ -> id+ Git.TreeEntryDeleted -> HashMap.delete name+ Git.TreeEntryMutated z' -> HashMap.insert name z'+ return ze++ else+ -- If there are further names in the path, descend them now. If+ -- 'createIfNotExist' was False and there is no 'Tree' under the+ -- current name, or if we encountered a 'Blob' when a 'Tree' was+ -- required, throw an exception to avoid colliding with user-defined+ -- 'Left' values.+ case y of+ Nothing -> return Git.TreeEntryNotFound+ Just (Git.BlobEntry {}) -> failure Git.TreeCannotTraverseBlob+ Just (Git.CommitEntry {}) -> failure Git.TreeCannotTraverseCommit+ Just (Git.TreeEntry st') -> do+ st <- Git.resolveTreeRef st'+ ze <- doModifyTree st names createIfNotExist f+ case ze of+ Git.TreeEntryNotFound -> return ()+ Git.TreeEntryPersistent _ -> return ()+ Git.TreeEntryDeleted -> postUpdate st+ Git.TreeEntryMutated _ -> postUpdate st+ return ze+ where+ postUpdate st = liftIO $ do+ modifyIORef (cliTreeOid (Git.getTreeData t)) (const Nothing)+ stc <- readIORef (cliTreeContents (Git.getTreeData st))+ modifyIORef (cliTreeContents (Git.getTreeData t)) $+ if HashMap.null stc+ then HashMap.delete name+ else HashMap.insert name (Git.treeEntry st)++cliModifyTree :: Git.MonadGit m+ => Tree m -> FilePath -> Bool+ -> (Maybe (TreeEntry m)+ -> CmdLineRepository m+ (Git.ModifyTreeResult (CmdLineRepository m)))+ -> CmdLineRepository m (Maybe (TreeEntry m))+cliModifyTree t path createIfNotExist f =+ Git.fromModifyTreeResult <$>+ doModifyTree t (splitPath path) createIfNotExist f++splitPath :: FilePath -> [Text]+splitPath path = T.splitOn "/" text+ where text = case F.toText path of+ Left x -> error $ "Invalid path: " ++ T.unpack x+ Right y -> y++cliWriteTree :: Git.MonadGit m+ => Tree m -> CmdLineRepository m (TreeOid m)+cliWriteTree tree = do+ contents <- liftIO $ readIORef (cliTreeContents (Git.getTreeData tree))+ rendered <- mapM renderLine (HashMap.toList contents)+ oid <- doRunGit run ["mktree", "-z", "--missing"]+ $ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL"+ return (Tagged (Oid (TL.init oid)))+ where+ renderLine (path, Git.BlobEntry (Tagged (Oid sha)) kind) =+ return $ TL.concat [ case kind of+ Git.PlainBlob -> "100644"+ Git.ExecutableBlob -> "100755"+ Git.SymlinkBlob -> "120000"+ Git.UnknownBlob -> "100000"+ , " blob ", sha, "\t", TL.fromStrict path ]+ renderLine (path, Git.CommitEntry coid) = do+ return $ TL.concat [ "160000 commit "+ , TL.fromStrict (Git.renderObjOid coid), "\t"+ , TL.fromStrict path ]+ renderLine (path, Git.TreeEntry tref) = do+ treeOid <- Git.treeRefOid tref+ return $ TL.concat+ [ "040000 tree "+ , TL.fromStrict (Git.renderObjOid treeOid), "\t"+ , TL.fromStrict path ]++cliTraverseEntries :: Git.MonadGit m+ => Tree m+ -> (FilePath -> TreeEntry m -> CmdLineRepository m b)+ -> CmdLineRepository m [b]+cliTraverseEntries tree f = do+ Tagged (Oid sha) <- Git.writeTree tree+ contents <- runGit ["ls-tree", "-t", "-r", "-z", sha]+ -- Even though the tree entries are separated by \NUL, for whatever reason+ -- @git ls-tree@ also outputs a newline at the end.+ mapM (uncurry f) $ map parseLine (L.init (TL.splitOn "\NUL" contents))+ where+ parseLine line =+ let [prefix,path] = TL.splitOn "\t" line+ [mode,kind,sha] = TL.words prefix+ in (fromText path,+ case kind of+ "blob" -> Git.BlobEntry (Tagged (Oid sha)) $+ case mode of+ "100644" -> Git.PlainBlob+ "100755" -> Git.ExecutableBlob+ "120000" -> Git.SymlinkBlob+ _ -> Git.UnknownBlob+ "commit" -> Git.CommitEntry (Tagged (Oid sha))+ "tree" -> Git.TreeEntry (Git.ByOid (Tagged (Oid sha)))+ _ -> error "This cannot happen")++parseCliTime :: String -> ZonedTime+parseCliTime = fromJust . parseTime defaultTimeLocale "%s %z"++formatCliTime :: ZonedTime -> Text+formatCliTime = T.pack . formatTime defaultTimeLocale "%s %z"++lexer :: TokenParser u+lexer = makeTokenParser haskellDef++cliLookupCommit :: Git.MonadGit m+ => CommitOid m -> CmdLineRepository m (Commit m)+cliLookupCommit (Tagged (Oid sha)) = do+ output <- doRunGit run ["cat-file", "--batch"]+ $ setStdin (TL.append sha "\n")+ case parse parseOutput "" (TL.unpack output) of+ Left e -> failure $ Git.CommitLookupFailed (T.pack (show e))+ Right c -> return c+ where+ parseOutput = do+ coid <- Tagged . Oid . TL.pack+ <$> manyTill alphaNum space+ _ <- string "commit " *> manyTill digit newline+ treeOid <- string "tree " *>+ (Tagged . Oid . TL.pack+ <$> manyTill anyChar newline)+ parentOids <- many (string "parent " *>+ (Tagged . Oid . TL.pack+ <$> manyTill anyChar newline))+ author <- parseSignature "author"+ committer <- parseSignature "committer"+ message <- newline *> many anyChar+ return Git.Commit+ { Git.commitOid = coid+ , Git.commitAuthor = author+ , Git.commitCommitter = committer+ , Git.commitLog = T.pack (init message)+ , Git.commitTree = Git.ByOid treeOid+ , Git.commitParents = map Git.ByOid parentOids+ , Git.commitEncoding = "utf-8"+ }++ parseSignature txt =+ Git.Signature+ <$> (string (T.unpack txt ++ " ")+ *> (T.pack <$> manyTill anyChar (try (string " <"))))+ <*> (T.pack <$> manyTill anyChar (try (string "> ")))+ <*> (parseCliTime <$> manyTill anyChar newline)++cliCreateCommit :: Git.MonadGit m+ => [CommitRef m] -> TreeRef m+ -> Git.Signature -> Git.Signature -> Text -> Maybe Text+ -> CmdLineRepository m (Commit m)+cliCreateCommit parents tree author committer message ref = do+ treeOid <- Git.treeRefOid tree+ let parentOids = map Git.commitRefOid parents+ oid <- doRunGit run+ (["commit-tree"]+ <> [TL.fromStrict (Git.renderObjOid treeOid)]+ <> L.concat [["-p", TL.fromStrict (Git.renderObjOid poid)] |+ poid <- parentOids])+ $ do mapM_ (\(var,f,val) -> setenv var (TL.fromStrict (f val)))+ [ ("GIT_AUTHOR_NAME", Git.signatureName, author)+ , ("GIT_AUTHOR_EMAIL", Git.signatureEmail, author)+ , ("GIT_AUTHOR_DATE",+ formatCliTime . Git.signatureWhen, author)+ , ("GIT_COMMITTER_NAME", Git.signatureName, committer)+ , ("GIT_COMMITTER_EMAIL", Git.signatureEmail, committer)+ , ("GIT_COMMITTER_DATE",+ formatCliTime . Git.signatureWhen, committer)+ ]+ setStdin (TL.fromStrict message)++ let commit = Git.Commit+ { Git.commitOid = Tagged (Oid (TL.init oid))+ , Git.commitAuthor = author+ , Git.commitCommitter = committer+ , Git.commitLog = message+ , Git.commitTree = Git.ByOid treeOid+ , Git.commitParents = map Git.ByOid parentOids+ , Git.commitEncoding = "utf-8"+ }+ when (isJust ref) $+ void $ cliUpdateRef (fromJust ref) (Git.RefObj (Git.Known commit))++ return commit++data CliObjectRef = CliObjectRef+ { objectRefType :: Text+ , objectRefSha :: Text } deriving Show++data CliReference = CliReference+ { referenceRef :: Text+ , referenceObject :: CliObjectRef } deriving Show++cliShowRef :: Git.MonadGit m+ => Maybe Text -> CmdLineRepository m (Maybe [(TL.Text,TL.Text)])+cliShowRef mrefName = do+ repo <- cliGet+ shellyNoDir $ silently $ errExit False $ do+ rev <- git $ [ "--git-dir", repoPath repo, "show-ref" ]+ <> [ TL.fromStrict (fromJust mrefName) | isJust mrefName ]+ ec <- lastExitCode+ return $ if ec == 0+ then Just $ map ((\(x:y:[]) -> (y,x)) . TL.words)+ $ TL.lines rev+ else Nothing++nameAndShaToRef :: TL.Text -> TL.Text -> Reference m+nameAndShaToRef name sha =+ Git.Reference (TL.toStrict name)+ (Git.RefObj (Git.ByOid (Tagged (Oid sha))))++cliLookupRef :: Git.MonadGit m+ => Text -> CmdLineRepository m (Maybe (Reference m))+cliLookupRef refName = do+ xs <- cliShowRef (Just refName)+ let name = TL.fromStrict refName+ ref = maybe Nothing (lookup name) xs+ return $ maybe Nothing (Just . uncurry nameAndShaToRef .+ \sha -> (name,sha)) ref++cliUpdateRef :: Git.MonadGit m+ => Text -> Git.RefTarget (CmdLineRepository m) (Commit m)+ -> CmdLineRepository m (Reference m)+cliUpdateRef refName refObj@(Git.RefObj commitRef) = do+ let Tagged (Oid sha) = Git.commitRefOid commitRef+ runGit_ ["update-ref", TL.fromStrict refName, sha]+ return (Git.Reference refName refObj)++cliUpdateRef refName refObj@(Git.RefSymbolic targetName) = do+ runGit_ ["symbolic-ref", TL.fromStrict refName, TL.fromStrict targetName]+ return (Git.Reference refName refObj)++cliDeleteRef :: Git.MonadGit m => Text -> CmdLineRepository m ()+cliDeleteRef refName = runGit_ ["update-ref", "-d", TL.fromStrict refName]++cliAllRefs :: Git.MonadGit m+ => CmdLineRepository m [Reference m]+cliAllRefs = do+ mxs <- cliShowRef Nothing+ return $ case mxs of+ Nothing -> []+ Just xs -> map (uncurry nameAndShaToRef) xs++cliResolveRef :: Git.MonadGit m+ => Text -> CmdLineRepository m (Maybe (CommitRef m))+cliResolveRef refName = do+ repo <- cliGet+ shellyNoDir $ silently $ errExit False $ do+ rev <- git [ "--git-dir", repoPath repo+ , "rev-parse", "--quiet", "--verify"+ , TL.fromStrict refName ]+ ec <- lastExitCode+ return $ if ec == 0+ then Just (Git.ByOid (Tagged (Oid (TL.init rev))))+ else Nothing++-- cliLookupTag :: TagOid -> CmdLineRepository Tag+-- cliLookupTag oid = undefined++cliCreateTag :: Git.MonadGit m+ => CommitOid m -> Git.Signature -> Text -> Text+ -> CmdLineRepository m (Tag m)+cliCreateTag oid@(Tagged (Oid sha)) tagger msg name = do+ tsha <- doRunGit run ["mktag"] $ setStdin $ TL.unlines $+ [ "object " <> sha+ , "type commit"+ , "tag " <> TL.fromStrict name+ , "tagger " <> TL.fromStrict (Git.signatureName tagger)+ <> " <" <> TL.fromStrict (Git.signatureEmail tagger) <> "> "+ <> TL.pack (formatTime defaultTimeLocale "%s %z"+ (Git.signatureWhen tagger))+ , ""] <> TL.lines (TL.fromStrict msg)+ return $ Git.Tag (Tagged (Oid (TL.init tsha))) (Git.ByOid oid)++data Repository = Repository+ { repoOptions :: Git.RepositoryOptions+ }++repoPath :: Repository -> TL.Text+repoPath = toTextIgnore . Git.repoPath . repoOptions++newtype CmdLineRepository m a = CmdLineRepository+ { cmdLineRepositoryReaderT :: ReaderT Repository m a }++instance Functor m => Functor (CmdLineRepository m) where+ fmap f (CmdLineRepository x) = CmdLineRepository (fmap f x)++instance Applicative m => Applicative (CmdLineRepository m) where+ pure = CmdLineRepository . pure+ CmdLineRepository f <*> CmdLineRepository x = CmdLineRepository (f <*> x)++instance Monad m => Monad (CmdLineRepository m) where+ return = CmdLineRepository . return+ CmdLineRepository m >>= f =+ CmdLineRepository (m >>= cmdLineRepositoryReaderT . f)++instance MonadIO m => MonadIO (CmdLineRepository m) where+ liftIO m = CmdLineRepository (liftIO m)++instance (Monad m, MonadIO m, Applicative m)+ => MonadBase IO (CmdLineRepository m) where+ liftBase = liftIO++instance Monad m => MonadUnsafeIO (CmdLineRepository m) where+ unsafeLiftIO = return . unsafePerformIO++instance Monad m => MonadThrow (CmdLineRepository m) where+ monadThrow = throw++instance MonadTrans CmdLineRepository where+ lift = CmdLineRepository . ReaderT . const++instance MonadTransControl CmdLineRepository where+ newtype StT CmdLineRepository a = StCmdLineRepository+ { unCmdLineRepository :: StT (ReaderT Repository) a+ }+ liftWith = defaultLiftWith CmdLineRepository+ cmdLineRepositoryReaderT StCmdLineRepository+ restoreT = defaultRestoreT CmdLineRepository unCmdLineRepository++instance (MonadIO m, MonadBaseControl IO m)+ => MonadBaseControl IO (CmdLineRepository m) where+ newtype StM (CmdLineRepository m) a = StMT+ { unStMT :: ComposeSt CmdLineRepository m a+ }+ liftBaseWith = defaultLiftBaseWith StMT+ restoreM = defaultRestoreM unStMT++cliGet :: Monad m => CmdLineRepository m Repository+cliGet = CmdLineRepository ask++cliFactory :: Git.MonadGit m+ => Git.RepositoryFactory CmdLineRepository m Repository+cliFactory = Git.RepositoryFactory+ { Git.openRepository = openCliRepository+ , Git.runRepository = runCliRepository+ , Git.closeRepository = closeCliRepository+ , Git.getRepository = cliGet+ , Git.defaultOptions = defaultCliOptions+ , Git.startupBackend = return ()+ , Git.shutdownBackend = return ()+ }++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) $+ shellyNoDir $ silently $+ git_ $ ["--git-dir", TL.fromStrict p]+ <> ["--bare" | Git.repoIsBare opts]+ <> ["init"]+ return Repository { repoOptions = opts }++runCliRepository :: Git.MonadGit m => Repository -> CmdLineRepository m a -> m a+runCliRepository repo action =+ runReaderT (cmdLineRepositoryReaderT action) repo++closeCliRepository :: Git.MonadGit m => Repository -> m ()+closeCliRepository = const (return ())++defaultCliOptions :: Git.RepositoryOptions+defaultCliOptions = Git.RepositoryOptions "" False False++-- Cli.hs
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2012 John Wiegley+Copyright (c) 2011 Sakari Jokinen, Jacob Stanley++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gitlib-cmdline.cabal view
@@ -0,0 +1,63 @@+Name: gitlib-cmdline+Version: 1.0.1+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+License: MIT+Author: John Wiegley+Maintainer: johnw@fpcomplete.com+Build-Type: Simple+Cabal-Version: >=1.10+Category: Git++Source-repository head+ type: git+ location: git://github.com/fpco/gitlib.git++Library+ hs-source-dirs: .+ default-language: Haskell98+ ghc-options: -Wall+ build-depends:+ base >= 3 && < 5+ , gitlib+ , gitlib-utils+ , bytestring >= 0.9.2.1+ , conduit >= 0.5.5+ , containers >= 0.4.2.1+ , failure >= 0.2.0.1+ , monad-control >= 0.3.2+ , old-locale >= 1.0.0.4+ , parsec >= 3.1.3+ , process-extras >= 0.2.0+ , shelly >= 0.14+ , system-fileio >= 0.3.11+ , system-filepath >= 0.4.7+ , tagged >= 0.4.4+ , time >= 1.4+ , text >= 0.11.2+ , transformers >= 0.2.2+ , transformers-base >= 0.4.1+ , unordered-containers >= 0.2.3.0+ exposed-modules:+ Git.CmdLine++Test-suite smoke+ default-language: Haskell98+ type: exitcode-stdio-1.0+ main-is: Smoke.hs+ ghc-options: -Wall+ hs-source-dirs: test+ build-depends:+ base >=3+ , gitlib+ , gitlib-utils+ , gitlib-test+ , gitlib-cmdline+ , HUnit >= 1.2.5+ , hspec >= 1.4.4+ , hspec-expectations >= 0.3+ , system-filepath >= 0.4.7+ , tagged >= 0.2.3.1+ , text >= 0.11.2+ , transformers >= 0.2.2
+ test/Smoke.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+{-# OPTIONS_GHC -fno-warn-wrong-do-bind #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Main where++import qualified Git.CmdLine as Cli+import qualified Git.Smoke as Git+import Test.Hspec.HUnit ()+import Test.Hspec.Runner++main :: IO ()+main = hspec $ Git.smokeTestSpec Cli.cliFactory Cli.cliFactory++-- Smoke.hs ends here