Loose.hs

-- |
-- Module      : Data.Git.Storage.Loose
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unix
--
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}
module Data.Git.Storage.Loose
        (
          Zipped(..)
        -- * marshall from and to lazy bytestring
        , looseUnmarshall
        , looseUnmarshallRaw
        , looseUnmarshallZipped
        , looseUnmarshallZippedRaw
        , looseMarshall
        -- * read and check object existence
        , looseRead
        , looseReadHeader
        , looseReadRaw
        , looseExists
        -- * write objects
        , looseWriteBlobFromFile
        , looseWrite
        -- * enumeration of loose objects
        , looseEnumeratePrefixes
        , looseEnumerateWithPrefixFilter
        , looseEnumerateWithPrefix
        ) where

import Codec.Compression.Zlib
import Data.Git.Ref
import Data.Git.Path
import Data.Git.Internal
import Data.Git.OS
import Data.Git.Imports
import Data.Git.Storage.FileWriter
import Data.Git.Storage.Object
import qualified Data.Git.Parser as P

import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as B

import Control.Exception (onException, SomeException)
import qualified Control.Exception as E

import Data.String
import Data.Char (isHexDigit)

newtype Zipped = Zipped { getZippedData :: L.ByteString }
    deriving (Show,Eq)

readZippedFile :: LocalPath -> IO Zipped
readZippedFile fp = Zipped <$> readBinaryFileLazy fp

dezip :: Zipped -> L.ByteString
dezip = decompress . getZippedData

isObjectPrefix :: [Char] -> Bool
isObjectPrefix [a,b] = isHexDigit a && isHexDigit b
isObjectPrefix _     = False

-- loose object parsing
parseHeader :: P.Parser ObjectHeader
parseHeader = do
        h <- P.takeWhile1 ((/=) 0x20)
        _ <- P.byte 0x20
        sz <- P.decimal :: P.Parser Int
        return (objectTypeUnmarshall h, fromIntegral sz, Nothing)

data HeaderType = HeaderTree | HeaderTag | HeaderCommit | HeaderBlob

parseTreeHeader, parseTagHeader, parseCommitHeader, parseBlobHeader :: P.Parser HeaderType
parseTreeHeader   = P.string "tree " >> parseLength >> P.byte 0 >> return HeaderTree
parseTagHeader    = P.string "tag " >> parseLength >> P.byte 0 >> return HeaderTag
parseCommitHeader = P.string "commit " >> parseLength >> P.byte 0 >> return HeaderCommit
parseBlobHeader   = P.string "blob " >> parseLength >> P.byte 0 >> return HeaderBlob

parseLength :: P.Parser Int
parseLength = P.decimal

parseObject :: L.ByteString -> Object
parseObject = parseSuccess getOne
  where
    parseSuccess p = either (error . ("parseObject: " ++)) id . P.eitherParseChunks p . L.toChunks
    getOne = do
        hdrType <- parseTreeHeader <|> parseBlobHeader <|> parseCommitHeader <|> parseTagHeader
        case hdrType of
            HeaderTree   -> objectParseTree
            HeaderTag    -> objectParseTag
            HeaderCommit -> objectParseCommit
            HeaderBlob   -> objectParseBlob


-- | unmarshall an object (with header) from a bytestring.
looseUnmarshall :: L.ByteString -> Object
looseUnmarshall = parseObject

-- | unmarshall an object (with header) from a zipped stream.
looseUnmarshallZipped :: Zipped -> Object
looseUnmarshallZipped = parseObject . dezip

-- | unmarshall an object as (header, data) tuple from a bytestring
looseUnmarshallRaw :: L.ByteString -> (ObjectHeader, ObjectData)
looseUnmarshallRaw stream =
        case L.findIndex ((==) 0) stream of
                Nothing  -> error "object not right format. missing 0"
                Just idx ->
                        let (h, r) = L.splitAt (idx+1) stream in
                        case P.maybeParseChunks parseHeader (L.toChunks h) of
                                Nothing  -> error "cannot open object"
                                Just hdr -> (hdr, r)

-- | unmarshall an object as (header, data) tuple from a zipped stream
looseUnmarshallZippedRaw :: Zipped -> (ObjectHeader, ObjectData)
looseUnmarshallZippedRaw = looseUnmarshallRaw . dezip

-- | read a specific ref from a loose object and returns an header and data.
looseReadRaw :: LocalPath -> Ref -> IO (ObjectHeader, ObjectData)
looseReadRaw repoPath ref = looseUnmarshallZippedRaw <$> readZippedFile (objectPathOfRef repoPath ref)

-- | read only the header of a loose object.
looseReadHeader :: LocalPath -> Ref -> IO ObjectHeader
looseReadHeader repoPath ref = toHeader <$> readZippedFile (objectPathOfRef repoPath ref)
  where
    toHeader = either (error . ("parseHeader: " ++)) id . P.eitherParseChunks parseHeader . L.toChunks . dezip

-- | read a specific ref from a loose object and returns an object
looseRead :: LocalPath -> Ref -> IO Object
looseRead repoPath ref = looseUnmarshallZipped <$> readZippedFile (objectPathOfRef repoPath ref)

-- | check if a specific ref exists as loose object
looseExists :: LocalPath -> Ref -> IO Bool
looseExists repoPath ref = isFile (objectPathOfRef repoPath ref)

-- | enumarate all prefixes available in the object store.
looseEnumeratePrefixes :: LocalPath -> IO [[Char]]
looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath </> fromString "objects")

-- | enumerate all references available with a specific prefix.
looseEnumerateWithPrefixFilter :: LocalPath -> String -> (Ref -> Bool) -> IO [Ref]
looseEnumerateWithPrefixFilter repoPath prefix filterF =
        filter filterF . map (fromHexString . (prefix ++)) . filter isRef <$> getDir (repoPath </> fromString "objects" </> fromString prefix)
        where
                getDir p = E.catch (getDirectoryContents p) (\(_::SomeException) -> return [])
                isRef l = length l == 38

looseEnumerateWithPrefix :: LocalPath -> String -> IO [Ref]
looseEnumerateWithPrefix repoPath prefix =
        looseEnumerateWithPrefixFilter repoPath prefix (const True)

-- | marshall as lazy bytestring an object except deltas.
looseMarshall :: Object -> L.ByteString
looseMarshall obj
        | objectIsDelta obj = error "cannot write delta object loose"
        | otherwise         = L.concat [ L.fromChunks [hdrB], objData ]
        where
                objData = objectWrite obj
                hdrB    = objectWriteHeader (objectToType obj) (fromIntegral $ L.length objData)

-- | create a new blob on a temporary location and on success move it to
-- the object store with its digest name.
looseWriteBlobFromFile :: LocalPath -> LocalPath -> IO Ref
looseWriteBlobFromFile repoPath file = do
        fsz <- getSize file
        let hdr = objectWriteHeader TypeBlob (fromIntegral fsz)
        tmpPath <- objectTemporaryPath repoPath
        flip onException (removeFile tmpPath) $ do
                (ref, npath) <- withFileWriter tmpPath $ \fw -> do
                        fileWriterOutput fw hdr
                        withFile file ReadMode $ \h -> loop h fw
                        digest <- fileWriterGetDigest fw
                        return (digest, objectPathOfRef repoPath digest)
                exists <- isFile npath
                when exists $ error "destination already exists"
                rename tmpPath npath
                return ref
    where loop h fw = do
                r <- B.hGet h (32*1024)
                if B.null r
                    then return ()
                    else fileWriterOutput fw r >> loop h fw

-- | write an object to disk as a loose reference.
-- use looseWriteBlobFromFile for efficiently writing blobs when being commited from a file.
looseWrite :: LocalPath -> Object -> IO Ref
looseWrite repoPath obj = createParentDirectory path
                       >> isFile path
                       >>= \exists -> unless exists (writeFileLazy path $ compress content)
                       >> return ref
        where
                path    = objectPathOfRef repoPath ref
                content = looseMarshall obj
                ref     = hashLBS content
                writeFileLazy p bs = withFile p WriteMode (\h -> L.hPut h bs)

getDirectoryContents :: LocalPath -> IO [String]
getDirectoryContents p = listDirectoryFilename p