module Data.Git.Storage
( Git
, gitRepoPath
, openRepo
, closeRepo
, withRepo
, withCurrentRepo
, findRepo
, isRepo
, initRepo
, iterateIndexes
, findReference
, findReferencesWithPrefix
, getObjectRaw
, getObjectRawAt
, getObject
, getObjectAt
, getObjectType
, setObject
) where
import System.Directory
import System.FilePath
import System.Environment
import Control.Applicative ((<$>))
import Control.Exception
import qualified Control.Exception as E
import Control.Monad
import Data.List ((\\), isPrefixOf)
import Data.IORef
import Data.Word
import Data.Git.Delta
import Data.Git.Storage.FileReader
import Data.Git.Storage.PackIndex
import Data.Git.Storage.Object
import Data.Git.Storage.Pack
import Data.Git.Storage.Loose
import Data.Git.Ref
data PackIndexReader = PackIndexReader PackIndexHeader FileReader
data Git = Git
{ gitRepoPath :: FilePath
, indexReaders :: IORef [(Ref, PackIndexReader)]
, packReaders :: IORef [(Ref, FileReader)]
}
openRepo :: FilePath -> IO Git
openRepo path = liftM2 (Git path) (newIORef []) (newIORef [])
closeRepo :: Git -> IO ()
closeRepo (Git { indexReaders = ireaders, packReaders = preaders }) = do
mapM_ (closeIndexReader . snd) =<< readIORef ireaders
mapM_ (fileReaderClose . snd) =<< readIORef preaders
where closeIndexReader (PackIndexReader _ fr) = fileReaderClose fr
findRepo :: IO FilePath
findRepo = do
menvDir <- E.catch (Just <$> getEnv "GIT_DIR") (\(_:: SomeException) -> return Nothing)
case menvDir of
Nothing -> checkDir 0
Just envDir -> do
e <- isRepo envDir
when (not e) $ error "environment GIT_DIR is not a git repository"
return envDir
where
checkDir 128 = error "not a git repository"
checkDir n = do
let filepath = concat (replicate n ("../") ++ [".git"])
e <- isRepo filepath
if e then return filepath else checkDir (n+1)
withRepo path f = bracket (openRepo path) closeRepo f
withCurrentRepo :: (Git -> IO a) -> IO a
withCurrentRepo f = findRepo >>= \path -> withRepo path f
isRepo :: FilePath -> IO Bool
isRepo path = do
dir <- doesDirectoryExist path
subDirs <- mapM (doesDirectoryExist . (path </>))
["branches","hooks","info"
,"logs","objects","refs"
,"refs"</>"heads","refs"</>"tags"]
return $ and ([dir] ++ subDirs)
initRepo :: FilePath -> IO ()
initRepo path = do
exists <- doesDirectoryExist path
when exists $ error "destination directory already exists"
createDirectory path
mapM_ (createDirectory . (path </>))
["branches","hooks","info"
,"logs","objects","refs"
,"refs"</>"heads","refs"</>"tags"]
iterateIndexes git f initAcc = do
allIndexes <- packIndexEnumerate (gitRepoPath git)
readers <- readIORef (indexReaders git)
(a,terminate) <- loop initAcc readers
if terminate
then return a
else readRemainingIndexes a (allIndexes \\ map fst readers)
where
loop acc [] = return (acc, False)
loop acc (r:rs) = do
(nacc, terminate) <- f acc r
if terminate
then return (nacc,True)
else loop nacc rs
readRemainingIndexes acc [] = return acc
readRemainingIndexes acc (idxref:idxs) = do
fr <- packIndexOpen (gitRepoPath git) idxref
idx <- packIndexReadHeader fr
let idxreader = PackIndexReader idx fr
let r = (idxref, idxreader)
modifyIORef (indexReaders git) (\l -> r : l)
(nacc, terminate) <- f acc r
if terminate
then return nacc
else readRemainingIndexes nacc idxs
findReference :: Git -> Ref -> IO ObjectLocation
findReference git ref = maybe NotFound id <$> (findLoose `mplusIO` findInIndexes)
where
findLoose :: IO (Maybe ObjectLocation)
findLoose = do
isLoose <- looseExists (gitRepoPath git) ref
if isLoose then return (Just $ Loose ref) else return Nothing
findInIndexes :: IO (Maybe ObjectLocation)
findInIndexes = iterateIndexes git isinIndex Nothing
isinIndex acc (idxref, (PackIndexReader idxhdr indexreader)) = do
mloc <- packIndexGetReferenceLocation idxhdr indexreader ref
case mloc of
Nothing -> return (acc, False)
Just loc -> return (Just $ Packed idxref loc, True)
mplusIO :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)
mplusIO f g = f >>= \vopt -> case vopt of
Nothing -> g
Just v -> return $ Just v
findReferencesWithPrefix :: Git -> String -> IO [Ref]
findReferencesWithPrefix git pre
| invalidLength = error "not a valid prefix"
| not (isHexString pre) = error "reference prefix contains non hexchar"
| otherwise = do
looseRefs <- looseEnumerateWithPrefixFilter (gitRepoPath git) (take 2 pre) matchRef
packedRefs <- concat <$> iterateIndexes git idxPrefixMatch []
return (looseRefs ++ packedRefs)
where
matchRef ref = pre `isPrefixOf` toHexString ref
invalidLength = length pre < 2 || length pre > 39
idxPrefixMatch acc (_, (PackIndexReader idxhdr indexreader)) = do
refs <- packIndexGetReferencesWithPrefix idxhdr indexreader pre
return (refs:acc,False)
readRawFromPack :: Git -> Ref -> Word64 -> IO (FileReader, PackedObjectRaw)
readRawFromPack git pref offset = do
readers <- readIORef (packReaders git)
reader <- maybe getDefault return $ lookup pref readers
po <- packReadRawAtOffset reader offset
return (reader, po)
where getDefault = do p <- packOpen (gitRepoPath git) pref
modifyIORef (packReaders git) ((pref, p):)
return p
readFromPack :: Git -> Ref -> Word64 -> Bool -> IO (Maybe ObjectInfo)
readFromPack git pref o resolveDelta = do
(reader, x) <- readRawFromPack git pref o
if resolveDelta then resolve reader o x else return $ Just $ generifyHeader x
where
generifyHeader :: PackedObjectRaw -> ObjectInfo
generifyHeader (po, objData) = ObjectInfo { oiHeader = hdr, oiData = objData, oiChains = [] }
where hdr = (poiType po, poiActualSize po, poiExtra po)
resolve :: FileReader -> Word64 -> PackedObjectRaw -> IO (Maybe ObjectInfo)
resolve reader offset (po, objData) = do
case (poiType po, poiExtra po) of
(TypeDeltaOff, Just ptr@(PtrOfs doff)) -> do
let delta = deltaRead objData
let noffset = offset doff
base <- resolve reader noffset =<< packReadRawAtOffset reader noffset
return $ addToChain ptr $ applyDelta delta base
(TypeDeltaRef, Just ptr@(PtrRef bref)) -> do
let delta = deltaRead objData
base <- getObjectRaw git bref True
return $ addToChain ptr $ applyDelta delta base
_ -> return $ Just $ generifyHeader (po, objData)
addToChain ptr (Just oi) = Just (oi { oiChains = ptr : oiChains oi })
addToChain _ Nothing = Nothing
applyDelta :: Maybe Delta -> Maybe ObjectInfo -> Maybe ObjectInfo
applyDelta (Just delta@(Delta _ rSize _)) (Just objInfo) = Just $ objInfo
{ oiHeader = (\(a,_,c) -> (a,rSize,c)) $ oiHeader objInfo
, oiData = deltaApply (oiData objInfo) delta
}
applyDelta _ _ = Nothing
getObjectRawAt :: Git -> ObjectLocation -> Bool -> IO (Maybe ObjectInfo)
getObjectRawAt _ NotFound _ = return Nothing
getObjectRawAt git (Loose ref) _ = Just . (\(h,d)-> ObjectInfo h d[]) <$> looseReadRaw (gitRepoPath git) ref
getObjectRawAt git (Packed pref o) resolveDelta = readFromPack git pref o resolveDelta
getObjectRaw :: Git -> Ref -> Bool -> IO (Maybe ObjectInfo)
getObjectRaw git ref resolveDelta = do
loc <- findReference git ref
getObjectRawAt git loc resolveDelta
getObjectType :: Git -> Ref -> IO (Maybe ObjectType)
getObjectType git ref = findReference git ref >>= getObjectTypeAt
where
getObjectTypeAt NotFound = return Nothing
getObjectTypeAt (Loose _) = Just . (\(t,_,_) -> t) <$> looseReadHeader (gitRepoPath git) ref
getObjectTypeAt (Packed pref o) =
fmap ((\(ty,_,_) -> ty) . oiHeader) <$> readFromPack git pref o True
getObjectAt :: Git -> ObjectLocation -> Bool -> IO (Maybe Object)
getObjectAt git loc resolveDelta = maybe Nothing toObject <$> getObjectRawAt git loc resolveDelta
where
toObject (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)
getObject :: Git
-> Ref
-> Bool
-> IO (Maybe Object)
getObject git ref resolveDelta = maybe Nothing toObject <$> getObjectRaw git ref resolveDelta
where
toObject (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)
setObject :: Git
-> Object
-> IO Ref
setObject git obj = looseWrite (gitRepoPath git) obj