{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-- |
-- Module      : Data.Git.Storage.Object
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unix
--
module Data.Git.Storage.Object
        ( ObjectLocation(..)
        , ObjectType(..)
        , ObjectHeader
        , ObjectData
        , ObjectPtr(..)
        , Object(..)
        , ObjectInfo(..)
        , Objectable(..)
        , objectToType
        , objectTypeMarshall
        , objectTypeUnmarshall
        , objectTypeIsDelta
        , objectIsDelta
        , objectToTree
        , objectToCommit
        , objectToTag
        , objectToBlob
        -- * parsing function
        , treeParse
        , commitParse
        , tagParse
        , blobParse
        , objectParseTree
        , objectParseCommit
        , objectParseTag
        , objectParseBlob
        -- * writing function
        , objectWriteHeader
        , objectWrite
        , objectHash
        ) where

import Data.Git.Ref
import Data.Git.Types
import Data.Git.Imports
import qualified Data.Git.Parser as P

import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as L

import Data.List (intersperse)
import Data.Word
import Text.Printf

#if MIN_VERSION_bytestring(0,10,0)
import Data.ByteString.Lazy.Builder hiding (word8)
#else
import qualified Data.ByteString.Lazy.Char8 as LC

-- tiny builder interface like for bytestring < 0.10 that
-- use normal lazy bytestring concat.
string7 :: String -> L.ByteString
string7 = LC.pack

byteString :: ByteString -> L.ByteString
byteString = LC.fromChunks . (:[])

toLazyByteString = id
#endif

-- | location of an object in the database
data ObjectLocation hash = NotFound | Loose (Ref hash) | Packed (Ref hash) Word64
        deriving (Show,Eq)

-- | Delta objects points to some others objects in the database
-- either as offset in the pack or as a direct reference.
data ObjectPtr hash = PtrRef (Ref hash) | PtrOfs Word64 deriving (Show,Eq)

type ObjectHeader hash = (ObjectType, Word64, Maybe (ObjectPtr hash))

type ObjectData = L.ByteString

-- | Raw objects infos have an header (type, size, ptr),
-- the data and a pointers chains to parents for resolved objects.
data ObjectInfo hash = ObjectInfo
        { oiHeader :: ObjectHeader hash
        , oiData   :: ObjectData
        , oiChains :: [ObjectPtr hash]
        } deriving (Show,Eq)

-- | describe a git object, that could of 6 differents types:
-- tree, blob, commit, tag and deltas (offset or ref).
-- the deltas one are only available in packs.
data Object hash =
      ObjCommit   (Commit hash)
    | ObjTag      (Tag hash)
    | ObjBlob     (Blob hash)
    | ObjTree     (Tree hash)
    | ObjDeltaOfs (DeltaOfs hash)
    | ObjDeltaRef (DeltaRef hash)
    deriving (Show,Eq)

class Objectable a where
        getType  :: a hash -> ObjectType
        getRaw   :: a hash -> L.ByteString
        isDelta  :: a hash -> Bool
        toObject :: a hash -> Object hash

objectToType :: Object hash -> ObjectType
objectToType (ObjTree _)     = TypeTree
objectToType (ObjBlob _)     = TypeBlob
objectToType (ObjCommit _)   = TypeCommit
objectToType (ObjTag _)      = TypeTag
objectToType (ObjDeltaOfs _) = TypeDeltaOff
objectToType (ObjDeltaRef _) = TypeDeltaRef

objectTypeMarshall :: ObjectType -> String
objectTypeMarshall TypeTree   = "tree"
objectTypeMarshall TypeBlob   = "blob"
objectTypeMarshall TypeCommit = "commit"
objectTypeMarshall TypeTag    = "tag"
objectTypeMarshall _          = error "deltas cannot be marshalled"

objectTypeUnmarshall :: ByteString -> ObjectType
objectTypeUnmarshall "tree"   = TypeTree
objectTypeUnmarshall "blob"   = TypeBlob
objectTypeUnmarshall "commit" = TypeCommit
objectTypeUnmarshall "tag"    = TypeTag
objectTypeUnmarshall _        = error "unknown object type"

objectTypeIsDelta :: ObjectType -> Bool
objectTypeIsDelta TypeDeltaOff = True
objectTypeIsDelta TypeDeltaRef = True
objectTypeIsDelta _            = False

objectIsDelta :: Object hash -> Bool
objectIsDelta (ObjDeltaOfs _) = True
objectIsDelta (ObjDeltaRef _) = True
objectIsDelta _               = False

objectToTree :: Object hash -> Maybe (Tree hash)
objectToTree (ObjTree tree) = Just tree
objectToTree _              = Nothing

objectToCommit :: Object hash -> Maybe (Commit hash)
objectToCommit (ObjCommit commit) = Just commit
objectToCommit _                  = Nothing

objectToTag :: Object hash -> Maybe (Tag hash)
objectToTag (ObjTag tag) = Just tag
objectToTag _            = Nothing

objectToBlob :: Object hash -> Maybe (Blob hash)
objectToBlob (ObjBlob blob) = Just blob
objectToBlob _              = Nothing

octal :: P.Parser Int
octal = B.foldl' step 0 `fmap` P.takeWhile1 isOct
  where isOct w = w >= 0x30 && w <= 0x37
        step a w = a * 8 + fromIntegral (w - 0x30)

modeperm :: P.Parser ModePerm
modeperm = ModePerm . fromIntegral <$> octal

-- | parse a tree content
treeParse :: HashAlgorithm hash => P.Parser (Tree hash)
treeParse = Tree <$> parseEnts
    where parseEnts = P.hasMore >>= \b -> if b then liftM2 (:) parseEnt parseEnts else return []
          parseEnt = liftM3 (,,) modeperm parseEntName (P.byte 0 >> P.referenceBin)
          parseEntName = entName <$> (P.skipASCII ' ' >> P.takeWhile (/= 0))

-- | parse a blob content
blobParse :: P.Parser (Blob hash)
blobParse = (Blob . L.fromChunks . (:[]) <$> P.takeAll)

-- | parse a commit content
commitParse :: HashAlgorithm hash => P.Parser (Commit hash)
commitParse = do
        tree <- P.string "tree " >> P.referenceHex
        P.skipEOL
        parents   <- many parseParentRef
        author    <- P.string "author " >> parsePerson
        committer <- P.string "committer " >> parsePerson
        encoding  <- optional (P.string "encoding " >> P.tillEOL)
        extras    <- many parseExtra
        P.skipEOL
        message <- P.takeAll
        return $ Commit tree parents author committer encoding extras message
        where
                parseParentRef = do
                        tree <- P.string "parent " >> P.referenceHex
                        P.skipEOL
                        return tree
                parseExtra = do
                        b <- P.anyByte
                        if b == 0xa
                            then fail "no extra"
                            else do
                                r <- P.tillEOL
                                P.skipEOL
                                v <- concatLines <$> many (P.string " " *> P.tillEOL <* P.skipEOL)
                                return $ CommitExtra (b `B.cons` r) v
                concatLines = B.concat . intersperse (B.pack [0xa])

-- | parse a tag content
tagParse :: HashAlgorithm hash => P.Parser (Tag hash)
tagParse = do
        object <- P.string "object " >> P.referenceHex
        P.skipEOL
        type_ <- objectTypeUnmarshall <$> (P.string "type " >> P.tillEOL)
        P.skipEOL
        tag   <- P.string "tag " >> P.tillEOL -- PC.takeTill ((==) 0x0a)
        P.skipEOL
        tagger <- P.string "tagger " >> parsePerson
        P.skipEOL
        signature <- P.takeAll
        return $ Tag object type_ tag tagger signature

parsePerson :: P.Parser Person
parsePerson = do
        name <- B.init <$> P.takeUntilASCII '<'
        P.skipASCII '<'
        email <- P.takeUntilASCII '>'
        _ <- P.string "> "
        time <- P.decimal :: P.Parser Integer
        _ <- P.string " "
        timezoneSign <- maybe 1 id <$> optional ((const 1 <$> ascii '+') <|> (const (-1) <$> ascii '-'))
        timezoneFmt  <- P.decimal
        let (h,m)    = timezoneFmt `divMod` 100
            timezone = timezoneSign * (h * 60 + m)
        P.skipEOL
        return $ Person name email (gitTime time timezone)

ascii :: Char -> P.Parser ()
ascii c = P.byte (asciiChar c)

asciiChar :: Char -> Word8
asciiChar c
    | cp < 0x80 = fromIntegral cp
    | otherwise = error ("char " <> show c <> " not valid ASCII")
  where cp = fromEnum c

objectParseTree, objectParseCommit, objectParseTag, objectParseBlob :: HashAlgorithm hash => P.Parser (Object hash)
objectParseTree   = ObjTree <$> treeParse
objectParseCommit = ObjCommit <$> commitParse
objectParseTag    = ObjTag <$> tagParse
objectParseBlob   = ObjBlob <$> blobParse

-- header of loose objects, but also useful for any object to determine object's hash
objectWriteHeader :: ObjectType -> Word64 -> ByteString
objectWriteHeader ty sz = BC.pack (objectTypeMarshall ty ++ " " ++ show sz ++ [ '\0' ])

objectWrite :: Object hash -> L.ByteString
objectWrite (ObjCommit commit) = commitWrite commit
objectWrite (ObjTag tag)       = tagWrite tag
objectWrite (ObjBlob blob)     = blobWrite blob
objectWrite (ObjTree tree)     = treeWrite tree
objectWrite _                  = error "delta cannot be marshalled"

treeWrite :: Tree hash -> L.ByteString
treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents
    where writeTreeEnt (ModePerm perm,name,ref) =
                [ string7 (printf "%o" perm)
                , string7 " "
                , byteString $ getEntNameBytes name
                , string7 "\0"
                , byteString $ toBinary ref
                ]

commitWrite :: Commit hash -> L.ByteString
commitWrite (Commit tree parents author committer encoding extra msg) =
    toLazyByteString $ mconcat els
    where
          toNamedRef s r = mconcat [string7 s, byteString (toHex r),eol]
          toParent       = toNamedRef "parent "
          toCommitExtra (CommitExtra k v) = [byteString k, eol] ++
                                            (concatMap (\l -> [byteString " ", byteString l, eol]) $ linesLast v)

          linesLast b
            | B.length b > 0 && B.last b == 0xa = BC.lines b ++ [ "" ]
            | otherwise                         = BC.lines b
          els = [toNamedRef "tree " tree ]
             ++ map toParent parents
             ++ [byteString $ writeName "author" author, eol
                ,byteString $ writeName "committer" committer, eol
                ,maybe (byteString B.empty) (byteString) encoding -- FIXME need eol
                ]
             ++ concatMap toCommitExtra extra
             ++ [eol
                ,byteString msg
                ]

tagWrite :: Tag hash -> L.ByteString
tagWrite (Tag ref ty tag tagger signature) =
    toLazyByteString $ mconcat els
    where els = [ string7 "object ", byteString (toHex ref), eol
                , string7 "type ", string7 (objectTypeMarshall ty), eol
                , string7 "tag ", byteString tag, eol
                , byteString $ writeName "tagger" tagger, eol
                , eol
                , byteString signature
                ]

eol :: Builder
eol = string7 "\n"

blobWrite :: Blob hash -> L.ByteString
blobWrite (Blob bData) = bData

instance Objectable Blob where
        getType _ = TypeBlob
        getRaw    = blobWrite
        toObject  = ObjBlob
        isDelta   = const False

instance Objectable Commit where
        getType _ = TypeCommit
        getRaw    = commitWrite
        toObject  = ObjCommit
        isDelta   = const False

instance Objectable Tag where
        getType _ = TypeTag
        getRaw    = tagWrite
        toObject  = ObjTag
        isDelta   = const False

instance Objectable Tree where
        getType _ = TypeTree
        getRaw    = treeWrite
        toObject  = ObjTree
        isDelta   = const False

instance Objectable DeltaOfs where
        getType _ = TypeDeltaOff
        getRaw    = error "delta offset cannot be marshalled"
        toObject  = ObjDeltaOfs
        isDelta   = const True

instance Objectable DeltaRef where
        getType _ = TypeDeltaRef
        getRaw    = error "delta ref cannot be marshalled"
        toObject  = ObjDeltaRef
        isDelta   = const True

objectHash :: HashAlgorithm hash => ObjectType -> Word64 -> L.ByteString -> Ref hash
objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunks lbs)

-- used for objectWrite for commit and tag
writeName :: ByteString -> Person -> ByteString
writeName label (Person name email locTime) =
        B.concat [label, " ", name, " <", email, "> ", BC.pack timeStr]
  where timeStr = show locTime