{-# 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