{- This file is part of hit-network.

 -

 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.

 -

 - ♡ Copying is an act of love. Please copy, reuse and share.

 -

 - The author(s) have dedicated all copyright and related and neighboring

 - rights to this software to the public domain worldwide. This software is

 - distributed without any warranty.

 -

 - You should have received a copy of the CC0 Public Domain Dedication along

 - with this software. If not, see

 - <http://creativecommons.org/publicdomain/zero/1.0/>.

 -}

module Network.Git.Transport.HTTP.Fetch.Packfile

    (

    )

where

putPackHeader :: Int -> Put

putPackHeader numOfObjects = do

    putByteString "PACK"    -- Signature

    putWord32be 2           -- Version number

    putInt32be numOfObjects -- Number of objects contained in the pack

type ObjIdSet = HashSet ObjId

-- | Take a minimal list of commits we must send, and build a set of object IDs

-- of these commits and all the trees and blobs they refer to recursively.

collectObjIds :: Git -> [(ObjId, Commit)] -> IO ObjIdSet

collectObjIds git pairs = do

    let (commitIds, commits) = unzip pairs

        treeIds = map (commitTreeish git) commits

        resolve tid = do

            mtree <- resolveTreeish git $ unObjId tid

            return $ fromMaybe (error "invalid commit treeish ref") mtree

        visit s oid _ _ _ = S.insert oid s

        collect = traverseTree git visit

    trees <- traverse resolve treeIds

    let initial = S.toList commitsIds `S.union` S.toList treeIds

    foldlM (flip collect) initial trees

data CompressedObject = CompressedObject

    { zoType :: ObjectType

    , zoSize :: Word64

    , zoData :: BL.ByteString

    }

objectTypeCode :: Num a => ObjectType -> a

objectTypeCode TypeCommit   = 1

objectTypeCode TypeTree     = 2

objectTypeCode TypeBlob     = 3

objectTypeCode TypeTag      = 4

objectTypeCode TypeDeltaOff = 6

objectTypeCode TypeDeltaRef = 7

-- | This is an encoder for a specific encoding of arbitrary-length numbers

-- used by Git. The purpose is to support objects of arbitrary size, not

-- limiting their size representation to 32 or 64 bits.

--

-- The encoding work as follows. The number is split into sequences of 7 bits,

-- in little endian order (i.e. least significant bits come first). For each

-- sequence, a byte is constructed. The sequence serve as the low 7 bits of it,

-- and the highest bit determines whether there is another sequence after it.

-- In other words, the last byte has that bit set to 0, and all other bytes

-- have it set to 1.

--

-- The encoding contains at least one byte. If the word value is 127 or less,

-- i.e. can be expressed in 7 bits, the encoding contains a single byte.

-- Otherwise, it's more than one byte, as needed.

putExtensibleWord :: Bits a => a -> Put

putExtensibleWord

-- | Like 'putExtensibleWord'', but lets you manually pass the first 7 bits

-- separately from the rest of the bits.

--

-- If the rest of the bits are all zeros, te encoding will contain a single

-- byte (the first 7 bits passed, and a zero high bit). Otherwise, it will

-- contain at least 2 bytes: 1 byte for the first 7 bits, and at least 1 byte

-- for the rest of the bits.

putExtensibleWord'

    :: Bits a

    => Word8  -- ^ The low 7 bits of the word

    -> a      -- ^ The rest of the bits

    -> Put

putExtensibleWord' first rest =

    let setHigh = (.|. 0x80)

        clearHigh = (.&. 0x7f)

        continues = setHigh

        stops = clearHigh

    if rest == zeroBits

        then putWord8 $ stops first

        else do

            putWord8 $ continues first

            let mnextF = fromIntegralSized $ rest .&. 0x7f

                msg =

                    "toIntegralSized failed to convert small Bits a (0-127) \

                    \to Word8"

                nextF = fromMaybe (error msg) mnextF

                nextR = unsafeShiftR rest 7

            putExtensibleWord' nextF nextR

putObjectHeader :: ObjectType -> Word64 -> Put

putObjectHeader otype size =

    let typeBits = objectTypeCode otype

        msizeLowBits = toIntegralSized $ size .&. 0x0f

        sizeLowBits = case msizeLowBits of

            Nothing ->

                error

                    "toIntegralSized failed to convert small (0-15) Word64 to \

                    \Word8 in putObjectHeader"

            Just n  -> n

        first7bits = unsafeShiftL typeBits 4 .|. sizeLowBits

    in  putExtensibleWord' first7bits (unsafeShiftR size 4)

putCompressedObject :: CompressedObject -> Put

putCompressedObject zo = do

    putObjectHeader (zoType zo) (zoSize zo)

    putLazyByteString $ zoData zo

compressObject :: ObjectInfo -> CompressedObject

compressObect (ObjectInfo (t, s, _mp) odata _ochains) = CompressedObject

    { zoType = t

    , zoSize = s

    , zoData = compress odata

    }

putObject :: ObjectInfo -> Put

putObject = putCompressedObject . compressObject

mkPutObject :: Git -> ObjId -> IO Put

mkPutObject git oid = do

    minfo <- getObjectRaw git (unObjId oid) True

    case minfo of

        Nothing   -> error "failed to load raw object from oid"

        Just info -> return $ putObject info

writeHashed :: Put -> HashT SHA1 IO Put

writeHashed put = do

    let lbs = runPut put

    updateHashMulti $ toChunks lbs

    return $ putLazyByteString lbs

writePack :: Git -> ObjIdSet -> IO Put

writePack git oidset = do

    (put, digest) <- runHashT $ do

        header <- writeHashed $ putPackHeader $ S.size oidset

        let writeObj oid = liftIO (mkPutObject git oid) >>= writeHashed

        foldlM (\ put oid -> (put >>) <$> writeObj oid) header oidset

    return $ put >> putByteString (convert digest)