{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Git.Repository -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unix -- module Data.Git.Repository ( Git , HTree , HTreeEnt(..) , getCommit , getTree , rewrite , buildHTree , resolvePath , resolveTreeish , resolveRevision , initRepo , isRepo ) where import Control.Applicative ((<$>)) import Control.Monad import Data.Maybe (fromMaybe) import Data.List (find) import Data.ByteString (ByteString) import Data.Git.Named import Data.Git.Types import Data.Git.Storage.Object import Data.Git.Storage import Data.Git.Revision import Data.Git.Storage.Loose import Data.Git.Storage.CacheFile import Data.Git.Ref import qualified Data.Map as M -- | hierarchy tree, either a reference to a blob (file) or a tree (directory). data HTreeEnt = TreeDir Ref HTree | TreeFile Ref type HTree = [(Int,ByteString,HTreeEnt)] -- should be a standard function that do that... mapJustM f (Just o) = f o mapJustM _ Nothing = return Nothing -- | get a specified commit getCommit :: Git -> Ref -> IO (Maybe Commit) getCommit git ref = getObject git ref True >>= mapJustM unwrap where unwrap (objectToCommit -> Just c@(Commit {})) = return $ Just c unwrap _ = return Nothing -- | get a specified tree getTree :: Git -> Ref -> IO (Maybe Tree) getTree git ref = getObject git ref True >>= mapJustM unwrap where unwrap (objectToTree -> Just c@(Tree {})) = return $ Just c unwrap _ = return Nothing -- | try to resolve a string to a specific commit ref -- for example: HEAD, HEAD^, master~3, shortRef resolveRevision :: Git -> Revision -> IO (Maybe Ref) resolveRevision git (Revision prefix modifiers) = getCacheVal (packedNamed git) >>= \c -> resolvePrefix c >>= modf modifiers where resolvePrefix lookupCache = tryResolvers [resolveNamedPrefix lookupCache namedResolvers ,resolvePrePrefix ] resolveNamedPrefix _ [] = return Nothing resolveNamedPrefix lookupCache (x:xs) = followToRef (resolveNamedPrefix lookupCache xs) x where followToRef onFailure refty = do exists <- existsRefFile (gitRepoPath git) refty if exists then do refcont <- readRefFile (gitRepoPath git) refty case refcont of RefDirect ref -> return $ Just ref RefLink refspecty -> followToRef onFailure refspecty _ -> error "cannot handle reference content" else case M.lookup refty lookupCache of Nothing -> onFailure y -> return y namedResolvers = case prefix of "HEAD" -> [ RefHead ] "ORIG_HEAD" -> [ RefOrigHead ] "FETCH_HEAD" -> [ RefFetchHead ] _ -> [ RefTag prefix, RefBranch prefix, RefRemote prefix ] tryResolvers :: [IO (Maybe Ref)] -> IO Ref tryResolvers [] = return $ fromHexString prefix tryResolvers (resolver:xs) = resolver >>= isResolved where isResolved (Just r) = return r isResolved Nothing = tryResolvers xs resolvePrePrefix :: IO (Maybe Ref) resolvePrePrefix = do refs <- findReferencesWithPrefix git prefix case refs of [] -> return Nothing [r] -> return (Just r) _ -> error "multiple references with this prefix" modf [] ref = return (Just ref) modf (RevModParent i:xs) ref = do parentRefs <- getParentRefs ref case i of 0 -> error "revision modifier ^0 is not implemented" _ -> case drop (i - 1) parentRefs of [] -> error "no such parent" (p:_) -> modf xs p modf (RevModParentFirstN 1:xs) ref = modf (RevModParent 1:xs) ref modf (RevModParentFirstN n:xs) ref = do parentRefs <- getParentRefs ref modf (RevModParentFirstN (n-1):xs) (head parentRefs) modf (_:_) _ = error "unimplemented revision modifier" getParentRefs ref = do obj <- getCommit git ref case obj of Just (Commit { commitParents = parents }) -> return parents Nothing -> error "reference in commit chain doesn't exists" -- | returns a tree from a ref that might be either a commit, a tree or a tag. resolveTreeish :: Git -> Ref -> IO (Maybe Tree) resolveTreeish git ref = getObject git ref True >>= mapJustM recToTree where recToTree (objectToCommit -> Just (Commit { commitTreeish = tree })) = resolveTreeish git tree recToTree (objectToTag -> Just (Tag tref _ _ _ _)) = resolveTreeish git tref recToTree (objectToTree -> Just t@(Tree _)) = return $ Just t recToTree _ = return Nothing -- | Rewrite a set of commits from a revision and returns the new ref. -- -- If during revision traversal (diving) there's a commit with zero or multiple -- parents then the traversal will stop regardless of the amount of parent requested. -- -- calling "rewrite f 2 (revisionOf d)" on the following tree: -- -- a <-- b <-- c <-- d -- -- result in the following tree after mapping with f: -- -- a <-- f(b) <-- f(c) <-- f(d) -- rewrite :: Git -- ^ Repository -> (Commit -> IO Commit) -- ^ Mapping function -> Revision -- ^ revision to start from -> Int -- ^ the number of parents to map -> IO Ref -- ^ return the new head REF rewrite git mapCommit revision nbParent = do ref <- fromMaybe (error "revision cannot be found") <$> resolveRevision git revision resolveParents nbParent ref >>= process . reverse where resolveParents :: Int -> Ref -> IO [ (Ref, Commit) ] resolveParents 0 ref = (:[]) . (,) ref . fromMaybe (error "commit cannot be found") <$> getCommit git ref resolveParents n ref = do commit <- fromMaybe (error "commit cannot be found") <$> getCommit git ref case commitParents commit of [parentRef] -> liftM ((ref,commit) :) (resolveParents (n-1) parentRef) _ -> return [(ref,commit)] process [] = error "nothing to rewrite" process ((_,commit):next) = mapCommit commit >>= looseWrite (gitRepoPath git) . toObject >>= flip rewriteOne next rewriteOne prevRef [] = return prevRef rewriteOne prevRef ((_,commit):next) = do newCommit <- mapCommit $ commit { commitParents = [prevRef] } ref <- looseWrite (gitRepoPath git) (toObject newCommit) rewriteOne ref next -- | build a hierarchy tree from a tree object buildHTree :: Git -> Tree -> IO HTree buildHTree git (Tree ents) = mapM resolveTree ents where resolveTree (perm, ent, ref) = do obj <- getObjectType git ref case obj of Just TypeBlob -> return (perm, ent, TreeFile ref) Just TypeTree -> do ctree <- getTree git ref case ctree of Nothing -> error "unknown reference in tree object: no such child" Just t -> do dir <- buildHTree git t return (perm, ent, TreeDir ref dir) Just _ -> error "wrong type embedded in tree object" Nothing -> error "unknown reference in tree object" -- | resolve the ref (tree or blob) related to a path at a specific commit ref resolvePath :: Git -- ^ repository -> Ref -- ^ commit reference -> [ByteString] -- ^ paths -> IO (Maybe Ref) resolvePath git commitRef paths = do commit <- getCommit git commitRef case commit of Just (Commit { commitTreeish = tree }) -> resolve tree paths Nothing -> error ("not a valid commit ref: " ++ show commitRef) where resolve :: Ref -> [ByteString] -> IO (Maybe Ref) resolve treeRef [] = return $ Just treeRef resolve treeRef (x:xs) = do tree <- getTree git treeRef case tree of Just (Tree ents) -> do let cEnt = treeEntRef <$> findEnt x ents if xs == [] then return cEnt else maybe (return Nothing) (\z -> resolve z xs) cEnt Nothing -> error ("not a valid tree ref: " ++ show treeRef) findEnt x = find (\(_, b, _) -> b == x) treeEntRef (_,_,r) = r