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.Ref
data HTreeEnt = TreeDir Ref HTree | TreeFile Ref
type HTree = [(Int,ByteString,HTreeEnt)]
mapJustM f (Just o) = f o
mapJustM _ Nothing = return Nothing
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
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
resolveRevision :: Git -> Revision -> IO (Maybe Ref)
resolveRevision git (Revision prefix modifiers) = resolvePrefix >>= modf modifiers
where
resolvePrefix :: IO Ref
resolvePrefix = resolveNamedPrefix fs >>= maybe resolvePrePrefix (return . Just) >>= maybe (return $ fromHexString prefix) return
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"
fs = [ (specialExists, specialRead), (tagExists, tagRead), (headExists, headRead) ]
resolveNamedPrefix [] = return Nothing
resolveNamedPrefix (x:xs) = do
exists <- (fst x) (gitRepoPath git) prefix
if exists
then Just <$> (snd x) (gitRepoPath git) prefix
else resolveNamedPrefix xs
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 (n1):xs) (head parentRefs)
modf (_:_) _ = error "unimplemented revision modifier"
getParentRefs ref = do
obj <- getCommit git ref
case obj of
Just (Commit _ parents _ _ _) -> return parents
Nothing -> error "reference in commit chain doesn't exists"
resolveTreeish :: Git -> Ref -> IO (Maybe Tree)
resolveTreeish git ref = getObject git ref True >>= mapJustM recToTree where
recToTree (objectToCommit -> Just (Commit tree _ _ _ _)) = resolveTreeish git tree
recToTree (objectToTag -> Just (Tag tref _ _ _ _)) = resolveTreeish git tref
recToTree (objectToTree -> Just t@(Tree _)) = return $ Just t
recToTree _ = return Nothing
rewrite :: Git
-> (Commit -> IO Commit)
-> Revision
-> Int
-> IO 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 (n1) parentRef)
_ -> return [(ref,commit)]
process [] = error "nothing to rewrite"
process ((_,commit):next) =
mapCommit commit >>= looseWrite (gitRepoPath git) . objectWrap >>= flip rewriteOne next
rewriteOne prevRef [] = return prevRef
rewriteOne prevRef ((_,commit):next) = do
newCommit <- mapCommit $ commit { commitParents = [prevRef] }
ref <- looseWrite (gitRepoPath git) (objectWrap newCommit)
rewriteOne ref next
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"
resolvePath :: Git
-> Ref
-> [ByteString]
-> IO (Maybe Ref)
resolvePath git commitRef paths = do
commit <- getCommit git commitRef
case commit of
Just (Commit 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