module Data.Git.Repository
( Git
, configRead
, Cfg.Config(..)
, Cfg.Section(..)
, HTree
, HTreeEnt(..)
, RefName(..)
, getCommitMaybe
, getCommit
, getTreeMaybe
, getTree
, rewrite
, buildHTree
, resolvePath
, resolveTreeish
, resolveRevision
, initRepo
, isRepo
, branchWrite
, branchList
, tagWrite
, tagList
, headSet
, headGet
) where
import Control.Applicative ((<$>))
import Control.Monad
import Control.Exception (Exception, throw)
import Data.Maybe (fromMaybe)
import Data.List (find)
import Data.Data
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.Git.Config as Cfg
import Data.Set (Set)
import qualified Data.Map as M
import qualified Data.Set as Set
data HTreeEnt = TreeDir Ref HTree | TreeFile Ref
type HTree = [(ModePerm,ByteString,HTreeEnt)]
data InvalidType = InvalidType Ref ObjectType
deriving (Show,Eq,Data,Typeable)
instance Exception InvalidType
mapJustM f (Just o) = f o
mapJustM _ Nothing = return Nothing
getCommitMaybe :: Git -> Ref -> IO (Maybe Commit)
getCommitMaybe git ref = maybe Nothing objectToCommit <$> getObject git ref True
getCommit :: Git -> Ref -> IO Commit
getCommit git ref = maybe err id . objectToCommit <$> getObject_ git ref True
where err = throw $ InvalidType ref TypeCommit
getTreeMaybe :: Git -> Ref -> IO (Maybe Tree)
getTreeMaybe git ref = maybe Nothing objectToTree <$> getObject git ref True
getTree :: Git -> Ref -> IO Tree
getTree git ref = maybe err id . objectToTree <$> getObject_ git ref True
where err = throw $ InvalidType ref TypeTree
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 refty of
RefTag name -> mapLookup name $ packedTags lookupCache
RefBranch name -> mapLookup name $ packedBranchs lookupCache
RefRemote name -> mapLookup name $ packedRemotes lookupCache
_ -> return Nothing
where mapLookup name m = maybe onFailure (return . Just) $ M.lookup name m
namedResolvers = case prefix of
"HEAD" -> [ RefHead ]
"ORIG_HEAD" -> [ RefOrigHead ]
"FETCH_HEAD" -> [ RefFetchHead ]
_ -> map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote]
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 (n1):xs) (head parentRefs)
modf (_:_) _ = error "unimplemented revision modifier"
getParentRefs ref = commitParents <$> getCommit git ref
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 :: 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 <$> getCommit git ref
resolveParents n ref = do commit <- 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) . 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
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
dir <- buildHTree git ctree
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 =
getCommit git commitRef >>= \commit -> resolve (commitTreeish commit) paths
where resolve :: Ref -> [ByteString] -> IO (Maybe Ref)
resolve treeRef [] = return $ Just treeRef
resolve treeRef (x:xs) = do
(Tree ents) <- getTree git treeRef
let cEnt = treeEntRef <$> findEnt x ents
if xs == []
then return cEnt
else maybe (return Nothing) (\z -> resolve z xs) cEnt
findEnt x = find (\(_, b, _) -> b == x)
treeEntRef (_,_,r) = r
branchWrite :: Git
-> RefName
-> Ref
-> IO ()
branchWrite git branchName ref =
writeRefFile (gitRepoPath git) (RefBranch branchName) (RefDirect ref)
branchList :: Git -> IO (Set RefName)
branchList git = do
ps <- Set.fromList . M.keys . packedBranchs <$> getCacheVal (packedNamed git)
ls <- Set.fromList <$> looseHeadsList (gitRepoPath git)
return $ Set.union ps ls
tagWrite :: Git
-> RefName
-> Ref
-> IO ()
tagWrite git tagname ref =
writeRefFile (gitRepoPath git) (RefTag tagname) (RefDirect ref)
tagList :: Git -> IO (Set RefName)
tagList git = do
ps <- Set.fromList . M.keys . packedTags <$> getCacheVal (packedNamed git)
ls <- Set.fromList <$> looseTagsList (gitRepoPath git)
return $ Set.union ps ls
headSet :: Git
-> Either Ref RefName
-> IO ()
headSet git (Left ref) =
writeRefFile (gitRepoPath git) RefHead (RefDirect ref)
headSet git (Right refname) =
writeRefFile (gitRepoPath git) RefHead (RefLink $ RefBranch refname)
headGet :: Git
-> IO (Either Ref RefName)
headGet git = do
content <- readRefFile (gitRepoPath git) RefHead
case content of
RefLink (RefBranch b) -> return $ Right b
RefLink spec -> error ("unknown content link in HEAD: " ++ show spec)
RefDirect r -> return $ Left r
RefContentUnknown bs -> error ("unknown content in HEAD: " ++ show bs)
configRead :: Git -> IO Cfg.Config
configRead git = Cfg.readConfig (gitRepoPath git)