module Data.Git.Storage
( Git
, packedNamed
, gitRepoPath
, openRepo
, closeRepo
, withRepo
, withCurrentRepo
, findRepoMaybe
, findRepo
, isRepo
, initRepo
, iterateIndexes
, findReference
, findReferencesWithPrefix
, getObjectRaw
, getObjectRawAt
, getObject
, getObjectAt
, getObjectType
, setObject
) where
import Filesystem
import Filesystem.Path hiding (concat)
import Filesystem.Path.Rules
import System.Environment
import Control.Applicative ((<$>))
import Control.Exception
import qualified Control.Exception as E
import Control.Monad
import Data.String
import Data.List ((\\), isPrefixOf)
import Data.IORef
import Data.Word
import Data.Git.Named
import Data.Git.Path (packedRefsPath)
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.Storage.CacheFile
import Data.Git.Ref
import qualified Data.Map as M
import Prelude hiding (FilePath)
data PackIndexReader = PackIndexReader PackIndexHeader FileReader
type PackedRef = CacheFile (M.Map RefSpecTy Ref)
data Git = Git
{ gitRepoPath :: FilePath
, indexReaders :: IORef [(Ref, PackIndexReader)]
, packReaders :: IORef [(Ref, FileReader)]
, packedNamed :: PackedRef
}
openRepo :: FilePath -> IO Git
openRepo path = liftM3 (Git path) (newIORef []) (newIORef []) packedRef
where packedRef = newCacheVal (packedRefsPath path) (M.fromList <$> readPackedRefs path) M.empty
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
findRepoMaybe :: IO (Maybe FilePath)
findRepoMaybe = do
menvDir <- E.catch (Just . decodeString posix_ghc704 <$> getEnv "GIT_DIR") (\(_:: SomeException) -> return Nothing)
case menvDir of
Nothing -> getWorkingDirectory >>= checkDir 0
Just envDir -> isRepo envDir >>= \e -> return (if e then Just envDir else Nothing)
where checkDir :: Int -> FilePath -> IO (Maybe FilePath)
checkDir 128 _ = return Nothing
checkDir n wd = do
let filepath = wd </> ".git"
e <- isRepo filepath
if e then return (Just filepath) else checkDir (n+1) (if absolute wd then parent wd else wd </> "..")
findRepo :: IO FilePath
findRepo = do
menvDir <- E.catch (Just . decodeString posix_ghc704 <$> getEnv "GIT_DIR") (\(_:: SomeException) -> return Nothing)
case menvDir of
Nothing -> getWorkingDirectory >>= checkDir 0
Just envDir -> do
e <- isRepo envDir
when (not e) $ error "environment GIT_DIR is not a git repository"
return envDir
where
checkDir :: Int -> FilePath -> IO FilePath
checkDir 128 _ = error "not a git repository"
checkDir n wd = do
let filepath = wd </> ".git"
e <- isRepo filepath
if e then return filepath else checkDir (n+1) (if absolute wd then parent wd else wd </> "..")
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 <- isDirectory path
subDirs <- mapM (isDirectory . (path </>))
[ "branches", "hooks", "info"
, "logs", "objects", "refs"
, "refs"</> "heads", "refs"</> "tags"]
return $ and ([dir] ++ subDirs)
initRepo :: FilePath -> IO ()
initRepo path = do
exists <- isDirectory path
when exists $ error "destination directory already exists"
createDirectory True path
mapM_ (createDirectory False . (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: " ++ show pre)
| not (isHexString pre) = error ("reference prefix contains non hexchar: " ++ show pre)
| 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 toObj <$> getObjectRawAt git loc resolveDelta
where
toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)
getObject :: Git
-> Ref
-> Bool
-> IO (Maybe Object)
getObject git ref resolveDelta = maybe Nothing toObj <$> getObjectRaw git ref resolveDelta
where
toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)
setObject :: Git
-> Object
-> IO Ref
setObject git obj = looseWrite (gitRepoPath git) obj