Storage.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module      : Data.Git.Storage
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unix
--

module Data.Git.Storage
    ( Git
    , packedNamed
    , gitRepoPath
    , configs
    -- * opening repositories
    , openRepo
    , closeRepo
    , withRepo
    , withCurrentRepo
    , findRepoMaybe
    , findRepo
    , isRepo
    -- * creating repositories
    , initRepo
    -- * repository accessors
    , getDescription
    , setDescription
    -- * iterators
    , iterateIndexes
    , findReference
    , findReferencesWithPrefix
    -- * getting objects
    , getObjectRaw
    , getObjectRawAt
    , getObject
    , getObject_
    , getObjectAt
    , getObjectType
    -- * setting objects
    , setObject
    ) where

import Control.Exception
import qualified Control.Exception as E
import Control.Monad

import Data.List ((\\), isPrefixOf)
import Data.Either (partitionEithers)
import Data.IORef
import Data.Word
import Data.Typeable

import Data.Git.Named
import Data.Git.Imports
import Data.Git.OS
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 Data.Git.Config
import qualified Data.ByteString.Lazy as L

import qualified Data.Map as M

data PackIndexReader = PackIndexReader PackIndexHeader FileReader

-- | this is a cache representation of the packed-ref file
type CachedPackedRef hash = CacheFile (PackedRefs (M.Map RefName (Ref hash)))

-- | represent a git repo, with possibly already opened filereaders
-- for indexes and packs
data Git hash = Git
    { gitRepoPath  :: LocalPath
    , indexReaders :: IORef [(Ref hash, PackIndexReader)]
    , packReaders  :: IORef [(Ref hash, FileReader)]
    , packedNamed  :: CachedPackedRef hash
    , configs      :: IORef [Config]
    }

-- | open a new git repository context
openRepo :: LocalPath -> IO (Git SHA1)
openRepo path = Git path <$> newIORef []
                         <*> newIORef []
                         <*> packedRef
                         <*> (readConfigs >>= newIORef)
  where packedRef = newCacheVal (packedRefsPath path)
                                (readPackedRefs path M.fromList)
                                (PackedRefs M.empty M.empty M.empty)
        readConfigs = do
            global <- E.try readGlobalConfig :: IO (Either IOException Config)
            local  <- E.try (readConfig path)
            return $ snd $ partitionEithers [local,global]

-- | close a git repository context, closing all remaining fileReaders.
closeRepo :: Git hash -> IO ()
closeRepo (Git { indexReaders = ireaders, packReaders = preaders }) = do
    mapM_ (closeIndexReader . snd) =<< readIORef ireaders
    mapM_ (fileReaderClose . snd) =<< readIORef preaders
  where closeIndexReader (PackIndexReader _ fr) = fileReaderClose fr

-- | Find the git repository from the current directory.
--
-- If the environment variable GIT_DIR is set then it's used,
-- otherwise iterate from current directory, up to 128 parents for a .git directory
findRepoMaybe :: IO (Maybe LocalPath)
findRepoMaybe = do
    menvDir <- E.catch (Just <$> getEnvAsPath "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 -> LocalPath -> IO (Maybe LocalPath)
        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 </> "..")

-- | Find the git repository from the current directory.
--
-- If the environment variable GIT_DIR is set then it's used,
-- otherwise iterate from current directory, up to 128 parents for a .git directory
findRepo :: IO LocalPath
findRepo = do
    menvDir <- E.catch (Just <$> getEnvAsPath "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 -> LocalPath -> IO LocalPath
        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 </> "..")

-- | execute a function f with a git context.
withRepo :: LocalPath -> (Git SHA1 -> IO c) -> IO c
withRepo path f = bracket (openRepo path) closeRepo f

-- | execute a function on the current repository.
--
-- check findRepo to see how the git repository is found.
withCurrentRepo :: (Git SHA1 -> IO a) -> IO a
withCurrentRepo f = findRepo >>= \path -> withRepo path f

-- | basic checks to see if a specific path looks like a git repo.
isRepo :: LocalPath -> IO Bool
isRepo path = do
    dir     <- isDirectory path
    subDirs <- mapM (isDirectory . (path </>))
                    [ "hooks", "info"
                    , "objects", "refs"
                    , "refs"</> "heads", "refs"</> "tags"]
    return $ and ([dir] ++ subDirs)

-- | initialize a new repository at a specific location.
initRepo :: LocalPath -> IO ()
initRepo path = do
    exists <- isDirectory path
    when exists $ error "destination directory already exists"
    createParentDirectory path
    createDirectory False path
    mapM_ (createDirectory False . (path </>))
        [ "branches", "hooks", "info"
        , "logs", "objects", "refs"
        , "refs"</> "heads", "refs"</> "tags"]

-- | read the repository's description
getDescription :: Git hash -> IO (Maybe String)
getDescription git = do
    isdescription <- isFile descriptionPath
    if (isdescription)
        then do
                content <- readTextFile descriptionPath
                return $ Just content
        else return Nothing
  where descriptionPath = (gitRepoPath git) </> "description"

-- | set the repository's description
setDescription :: Git hash -> String -> IO ()
setDescription git desc = do
    writeTextFile descriptionPath desc
  where descriptionPath = (gitRepoPath git) </> "description"

iterateIndexes :: HashAlgorithm hash
               => Git hash
               -> (b -> (Ref hash, PackIndexReader) -> IO (b, Bool))
               -> b -> IO b
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

-- | Get the object location of a specific reference
findReference :: HashAlgorithm hash => Git hash -> Ref hash -> IO (ObjectLocation hash)
findReference git ref = maybe NotFound id <$> (findLoose `mplusIO` findInIndexes)
  where --findLoose :: HashAlgorithm hash => IO (Maybe (ObjectLocation hash))
        findLoose = do
            isLoose <- looseExists (gitRepoPath git) ref
            if isLoose then return (Just $ Loose ref) else return Nothing

        --findInIndexes :: HashAlgorithm hash => IO (Maybe (ObjectLocation hash))
        findInIndexes = iterateIndexes git isinIndex Nothing --f -> (a -> IndexReader -> IO (a,Bool)) -> a -> IO a

        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

-- | get all the references that start by a specific prefix
findReferencesWithPrefix :: HashAlgorithm hash => Git hash -> String -> IO [Ref hash]
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 -- not very efficient way to do that... will do for now.
        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 :: HashAlgorithm hash => Git hash -> Ref hash -> Word64 -> IO (FileReader, (PackedObjectRaw hash))
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 :: HashAlgorithm hash => Git hash -> Ref hash -> Word64 -> Bool -> IO (Maybe (ObjectInfo hash))
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 hash -> ObjectInfo hash
        generifyHeader (po, objData) = ObjectInfo { oiHeader = hdr, oiData = objData, oiChains = [] }
          where hdr = (poiType po, poiActualSize po, poiExtra po)

        --resolve :: FileReader -> Word64 -> PackedObjectRaw hash -> IO (Maybe (ObjectInfo hash))
        resolve reader offset (po, objData) = do
            case (poiType po, poiExtra po) of
                (TypeDeltaOff, Just ptr@(PtrOfs doff)) -> do
                    let delta = deltaRead (L.toChunks 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 (L.toChunks 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 hash) -> Maybe (ObjectInfo hash)
        applyDelta (Just delta@(Delta _ rSize _)) (Just objInfo) = Just $ objInfo
            { oiHeader = (\(a,_,c) -> (a,rSize,c)) $ oiHeader objInfo
            , oiData   = deltaApply (oiData objInfo) delta
            }
        applyDelta _ _                                      = Nothing

-- | get an object from repository
getObjectRawAt :: HashAlgorithm hash => Git hash -> ObjectLocation hash -> Bool -> IO (Maybe (ObjectInfo hash))
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

-- | get an object from repository
getObjectRaw :: HashAlgorithm hash => Git hash -> Ref hash -> Bool -> IO (Maybe (ObjectInfo hash))
getObjectRaw git ref resolveDelta = do
    loc <- findReference git ref
    getObjectRawAt git loc resolveDelta

-- | get an object type from repository
getObjectType :: HashAlgorithm hash => Git hash -> Ref hash -> 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

-- | get an object from repository using a location to reference it.
getObjectAt :: HashAlgorithm hash => Git hash -> ObjectLocation hash -> Bool -> IO (Maybe (Object hash))
getObjectAt git loc resolveDelta = maybe Nothing toObj <$> getObjectRawAt git loc resolveDelta
  where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)

-- | get an object from repository using a ref.
getObject :: HashAlgorithm hash
          => Git hash          -- ^ repository
          -> Ref hash          -- ^ the object's reference to
          -> Bool              -- ^ whether to resolve deltas if found
          -> IO (Maybe (Object hash)) -- ^ returned object if found
getObject git ref resolveDelta = maybe Nothing toObj <$> getObjectRaw git ref resolveDelta
  where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)

-- | Just like 'getObject' but will raise a RefNotFound exception if the
-- reference cannot be found.
getObject_ :: (Typeable hash, HashAlgorithm hash)
           => Git hash  -- ^ repository
           -> Ref hash  -- ^ the object's reference to
           -> Bool      -- ^ whether to resolve deltas if found
           -> IO (Object hash) -- ^ returned object if found
getObject_ git ref resolveDelta = maybe (throwIO $ RefNotFound ref) return
                              =<< getObject git ref resolveDelta

-- | set an object in the store and returns the new ref
-- this is always going to create a loose object.
setObject :: HashAlgorithm hash
          => Git hash
          -> Object hash
          -> IO (Ref hash)
setObject git obj = looseWrite (gitRepoPath git) obj