gitlib-utils (empty) → 1.0.1
raw patch · 4 files changed
+400/−0 lines, 4 filesdep +basedep +bytestringdep +conduitsetup-changed
Dependencies added: base, bytestring, conduit, data-default, failure, gitlib, lifted-base, system-fileio, system-filepath, tagged, text, transformers, unordered-containers
Files
- Git/Utils.hs +330/−0
- LICENSE +19/−0
- Setup.hs +2/−0
- gitlib-utils.cabal +49/−0
+ Git/Utils.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Git.Utils where++import Control.Applicative+import qualified Control.Exception.Lifted as Exc+import Control.Failure+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Conduit+import qualified Data.Conduit.List as CList+import Data.Function+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import Data.List+import Data.Monoid+import Data.Tagged+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Traversable hiding (mapM, forM, sequence)+import Filesystem (removeTree, isDirectory)+import Filesystem.Path.CurrentOS hiding (null, concat)+import Git+import Prelude hiding (FilePath)++treeOid :: Repository m => Tree m -> m Text+treeOid t = renderObjOid <$> writeTree t++createBlobUtf8 :: Repository m => Text -> m (BlobOid m)+createBlobUtf8 = createBlob . BlobString . T.encodeUtf8++catBlob :: Repository m => Text -> m ByteString+catBlob str =+ if len == 40+ then do+ oid <- parseOid str+ lookupBlob (Tagged oid) >>= blobToByteString++ else do+ obj <- lookupObject str+ case obj of+ BlobObj (ByOid oid) -> lookupBlob oid >>= blobToByteString+ BlobObj (Known x) -> blobToByteString x+ _ -> failure (ObjectLookupFailed str len)+ where+ len = T.length str++catBlobUtf8 :: Repository m => Text -> m Text+catBlobUtf8 = catBlob >=> return . T.decodeUtf8++blobContentsToByteString :: Repository m => BlobContents m -> m ByteString+blobContentsToByteString (BlobString bs) = return bs+blobContentsToByteString (BlobStream bs) = do+ strs <- bs $$ CList.consume+ return (B.concat strs)+blobContentsToByteString (BlobSizedStream bs _) = do+ strs <- bs $$ CList.consume+ return (B.concat strs)++blobToByteString :: Repository m => Blob m -> m ByteString+blobToByteString (Blob _ contents) = blobContentsToByteString contents++treeBlobEntries :: Repository m => Tree m -> m [(FilePath,TreeEntry m)]+treeBlobEntries tree =+ mconcat <$> traverseEntries tree go+ where+ go fp e@(BlobEntry _ PlainBlob) = return [(fp,e)]+ go fp e@(BlobEntry _ ExecutableBlob) = return [(fp,e)]+ go _ _ = return []++commitTreeEntry :: Repository m+ => Commit m+ -> FilePath+ -> m (Maybe (TreeEntry m))+commitTreeEntry c path =+ flip lookupEntry path =<< resolveTreeRef (commitTree c)++copyOid :: (Repository m, Repository (t m), MonadTrans t)+ => Oid m -> t m (Oid (t m))+copyOid = parseOid . renderOid++copyBlob :: (Repository m, Repository (t m), MonadTrans t)+ => BlobRef m+ -> HashSet Text+ -> t m (BlobOid (t m), HashSet Text)+copyBlob blobr needed = do+ let oid = unTagged (blobRefOid blobr)+ sha = renderOid oid+ oid2 <- parseOid (renderOid oid)+ if HashSet.member sha needed+ then do+ bs <- lift $ blobToByteString+ =<< resolveBlobRef (ByOid (Tagged oid))+ boid <- createBlob (BlobString bs)++ let x = HashSet.delete sha needed+ return $ boid `seq` x `seq` (boid, x)++ else return (Tagged oid2, needed)++copyTreeEntry :: (Repository m, Repository (t m), MonadTrans t)+ => TreeEntry m+ -> HashSet Text+ -> t m (TreeEntry (t m), HashSet Text)+copyTreeEntry (BlobEntry oid kind) needed = do+ (b,needed') <- copyBlob (ByOid oid) needed+ return (BlobEntry b kind, needed')+copyTreeEntry (CommitEntry oid) needed = do+ coid <- parseOid (renderObjOid oid)+ return (CommitEntry (Tagged coid), needed)+copyTreeEntry (TreeEntry _) _ = error "This should never be called"++copyTree :: (Repository m, Repository (t m), MonadTrans t)+ => TreeRef m+ -> HashSet Text+ -> t m (TreeRef (t m), HashSet Text)+copyTree tr needed = do+ oid <- unTagged <$> lift (treeRefOid tr)+ let sha = renderOid oid+ oid2 <- parseOid (renderOid oid)+ if HashSet.member sha needed+ then do+ tree <- lift $ resolveTreeRef tr+ entries <- lift $ traverseEntries tree (curry return)+ tree2 <- newTree+ needed' <- foldM (doCopyTreeEntry tree2) needed entries+ toid <- writeTree tree2++ let tref = ByOid toid+ x = HashSet.delete sha needed'+ return $ tref `seq` x `seq` (tref, x)++ else return (ByOid (Tagged oid2), needed)+ where+ doCopyTreeEntry _ needed' (_,TreeEntry {}) = return needed'+ doCopyTreeEntry tree2 needed' (fp,ent) = do+ (ent2,needed'') <- copyTreeEntry ent needed'+ putTreeEntry tree2 fp ent2+ return needed''++copyCommit :: (Repository m, Repository (t m), MonadTrans t)+ => CommitRef m+ -> Maybe Text+ -> HashSet Text+ -> t m (CommitRef (t m), HashSet Text)+copyCommit cr mref needed = do+ let oid = unTagged (commitRefOid cr)+ sha = renderOid oid+ commit <- lift $ resolveCommitRef cr+ oid2 <- parseOid sha+ if HashSet.member sha needed+ then do+ let parents = commitParents commit+ (parentRefs,needed') <- foldM copyParent ([],needed) parents+ (tr,needed'') <- copyTree (commitTree commit) needed'++ commit <- createCommit (reverse parentRefs) tr+ (commitAuthor commit)+ (commitCommitter commit)+ (commitLog commit)+ mref++ let cref = commitRef $! commit+ x = HashSet.delete sha needed''+ return $ cref `seq` x `seq` (cref, x)++ else return (ByOid (Tagged oid2), needed)+ where+ copyParent (prefs,needed') cref = do+ (cref2,needed'') <- copyCommit cref Nothing needed'+ let x = cref2 `seq` (cref2:prefs)+ return $ x `seq` needed'' `seq` (x,needed'')++-- | Given a list of objects (commit and top-level trees) return by+-- 'missingObjects', expand it to include all subtrees and blobs as well.+-- Ordering is preserved.+allMissingObjects :: Repository m => [Object m] -> m [Object m]+allMissingObjects objs =+ fmap concat . forM objs $ \obj -> case obj of+ TreeObj ref -> do+ tr <- resolveTreeRef ref+ subobjss <- traverseEntries tr $ \_ ent ->+ return $ case ent of+ Git.BlobEntry oid _ -> [Git.BlobObj (Git.ByOid oid)]+ Git.TreeEntry tr' -> [Git.TreeObj tr']+ _ -> []+ return (obj:concat subobjss)+ _ -> return [obj]++-- | Fast-forward push a reference between repositories using a recursive+-- copy. This can be extremely slow, but always works.+genericPushCommit :: (Repository m, Repository (t m),+ MonadTrans t, MonadIO (t m))+ => CommitName m -> Text -> t m (CommitRef (t m))+genericPushCommit cname remoteRefName = do+ mrref <- lookupRef remoteRefName+ commits1 <- lift $ traverseCommits crefToSha cname+ fastForward <- case mrref of+ Just rref -> do+ mrsha <- referenceSha rref+ case mrsha of+ Nothing -> failure (Git.PushNotFastForward $+ "Could not find SHA for " <> remoteRefName)+ Just rsha+ | rsha `elem` commits1 -> do+ roid <- lift $ parseOid rsha+ return $ Just (Just (CommitObjectId (Tagged roid)))+ | otherwise -> do+ mapM_ (liftIO . putStrLn . T.unpack) commits1+ failure (Git.PushNotFastForward $+ "SHA " <> rsha+ <> " not found in remote")+ Nothing -> return (Just Nothing)+ case fastForward of+ Nothing -> failure (Git.PushNotFastForward "unexpected")+ Just liftedMrref -> do+ objs <- lift $ allMissingObjects+ =<< missingObjects liftedMrref cname+ shas <- mapM (\obj -> renderOid <$> lift (objectOid obj)) objs+ mref <- lift $ commitNameToRef cname+ case mref of+ Nothing -> failure (ReferenceLookupFailed (T.pack (show cname)))+ Just ref -> do+ (cref,_) <- copyCommit ref Nothing (HashSet.fromList shas)+ -- jww (2013-04-18): This is something the user must+ -- decide to do+ -- updateRef_ remoteRefName (RefObj cref)+ return cref+ where+ referenceSha ref = do+ r <- referenceToRef Nothing (Just ref)+ return $ renderObjOid . commitRefOid <$> r++ crefToSha cref = return (renderObjOid (commitRefOid cref))++commitHistoryFirstParent :: Repository m => Commit m -> m [Commit m]+commitHistoryFirstParent c =+ case commitParents c of+ [] -> return [c]+ (p:_) -> do ps <- commitHistoryFirstParent =<< resolveCommitRef p+ return (c:ps)++data PinnedEntry m = PinnedEntry+ { pinnedOid :: Oid m+ , pinnedCommit :: Commit m+ , pinnedEntry :: TreeEntry m+ }++identifyEntry :: Repository m => Commit m -> TreeEntry m -> m (PinnedEntry m)+identifyEntry co x = do+ oid <- case x of+ BlobEntry oid _ -> return (unTagged oid)+ TreeEntry ref -> unTagged <$> treeRefOid ref+ CommitEntry oid -> return (unTagged oid)+ return (PinnedEntry oid co x)++commitEntryHistory :: Repository m => Commit m -> FilePath -> m [PinnedEntry m]+commitEntryHistory c path =+ map head . filter (not . null) . groupBy ((==) `on` pinnedOid) <$> go c+ where+ go co = do+ entry <- getEntry co+ rest <- case commitParents co of+ [] -> return []+ (p:_) -> go =<< resolveCommitRef p+ return $ maybe rest (:rest) entry++ getEntry co = do+ ce <- commitTreeEntry co path+ case ce of+ Nothing -> return Nothing+ Just ce' -> Just <$> identifyEntry co ce'++getCommitParents :: Repository m => Commit m -> m [Commit m]+getCommitParents = traverse resolveCommitRef . commitParents++resolveRefTree :: Repository m => Text -> m (Tree m)+resolveRefTree refName = do+ c <- resolveRef refName+ case c of+ Nothing -> newTree+ Just c' -> resolveCommitRef c' >>= resolveTreeRef . commitTree++withNewRepository :: (Repository (t m), MonadGit (t m),+ MonadBaseControl IO m, MonadIO m, MonadTrans t)+ => RepositoryFactory t m c+ -> FilePath -> t m a -> m a+withNewRepository factory path action = do+ liftIO $ do+ exists <- isDirectory path+ when exists $ removeTree path++ -- we want exceptions to leave the repo behind+ a <- withRepository' factory (defaultOptions factory)+ { repoPath = path+ , repoIsBare = True+ , repoAutoCreate = True+ } action++ liftIO $ do+ exists <- isDirectory path+ when exists $ removeTree path++ return a++withNewRepository' :: (Repository (t m), MonadGit (t m),+ MonadBaseControl IO m, MonadIO m, MonadTrans t)+ => RepositoryFactory t m c -> FilePath -> t m a -> m a+withNewRepository' factory path action =+ Exc.bracket_ recover recover $+ withRepository' factory (defaultOptions factory)+ { repoPath = path+ , repoIsBare = True+ , repoAutoCreate = True+ } action+ where+ recover = liftIO $ do+ exists <- isDirectory path+ when exists $ removeTree path+++-- Utils.hs ends here
+ LICENSE view
@@ -0,0 +1,19 @@+opyright (c) 2012 John Wiegley++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-utils.cabal view
@@ -0,0 +1,49 @@+Name: gitlib-utils+Version: 1.0.1+Synopsis: Generic utility functions for working with Git repositories+License-file: LICENSE+License: MIT+Author: John Wiegley+Maintainer: johnw@fpcomplete.com+Build-Type: Simple+Cabal-Version: >=1.10+Category: FFI+Description:+ @gitlib@ is a high-level, lazy and conduit-aware set of abstractions for+ programming with Git types.++Source-repository head+ type: git+ location: git://github.com/fpco/gitlib.git++-- Test-suite doctests+-- Default-language: Haskell98+-- Type: exitcode-stdio-1.0+-- Main-is: Doctest.hs+-- Hs-source-dirs: test+-- Build-depends:+-- base+-- , directory >= 1.0+-- , doctest >= 0.8+-- , doctest-prop >= 0.1+-- , filepath >= 1.3++Library+ default-language: Haskell98+ ghc-options: -Wall+ build-depends:+ base >= 3 && < 5+ , gitlib+ , bytestring >= 0.9.2.1+ , conduit >= 0.5.5+ , data-default >= 0.5.1+ , failure >= 0.2.0.1+ , lifted-base >= 0.2.0.2+ , system-fileio >= 0.3.11+ , system-filepath >= 0.4.7+ , tagged >= 0.2.3.1+ , text >= 0.11.2+ , transformers >= 0.3.0.0+ , unordered-containers >= 0.2.3.0+ exposed-modules:+ Git.Utils