content: {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE StrictData #-}
  
  module Duffer.Pack.Entries (module Duffer.Pack.Entries) where
  
  import qualified Data.ByteString    as B
  import qualified Data.IntMap.Strict as IntMap
  
  import Codec.Compression.Zlib (CompressionLevel, compressLevel, bestSpeed
                                ,compressWith, defaultCompressParams
                                ,defaultCompression)
  import Data.Byteable          (Byteable(..))
  import Data.ByteString.Base16 (decode)
  import Data.ByteString.Lazy   (fromStrict, toStrict)
  import Data.Bits              (Bits(..))
  import Data.Bool              (bool)
  import Data.Digest.CRC32      (crc32)
  import Data.List              (foldl')
  import Data.Map.Strict        (Map, insert, empty, foldrWithKey)
  import Data.Word              (Word8, Word32)
  import Numeric.Natural        (Natural)
  
  import Duffer.Loose.Objects (Ref)
  import Duffer.Pack.Bits
  
  data PackIndexEntry = PackIndexEntry
      { pieOffset :: Int
      , pieRef    :: Ref
      , pieCRC    :: Word32
      } deriving (Show, Eq)
  
  data FullObjectType = CommitType | TreeType | BlobType | TagType
      deriving (Eq, Show)
  
  data DeltaObjectType = OfsDeltaType | RefDeltaType
      deriving (Eq, Show)
  
  data PackObjectType = FullType FullObjectType | DeltaType DeltaObjectType
      deriving (Eq, Show)
  
  data PackDelta = OfsDelta Natural (WCL Delta) | RefDelta Ref (WCL Delta)
      deriving (Show, Eq)
  
  data PackedObject = PackedObject FullObjectType Ref (WCL B.ByteString)
      deriving (Show, Eq)
  
  data PackEntry = Resolved PackedObject | UnResolved PackDelta
      deriving (Show, Eq)
  
  {- Packfile entries generated by `git` use one of two different compression
   - levels: default compression or best speed. To perfectly reconstruct a
   - packfile, we need to store the compression level of each section of
   - compressed content. For generating our own packfiles, this is not as
   - important.
   -}
  data WCL a = WCL
      { wclLevel   :: CompressionLevel
      , wclContent :: a
      } deriving (Show, Eq, Functor)
  
  data DeltaInstruction
      = CopyInstruction   Natural Natural
      | InsertInstruction B.ByteString
      deriving (Show, Eq)
  
  data Delta = Delta Natural Natural [DeltaInstruction] deriving (Show, Eq)
  
  data CombinedMap = CombinedMap
      { getOffsetMap :: OffsetMap
      , getRefIndex  :: RefIndex
      } deriving (Show)
  
  data ObjectMap = ObjectMap
      { getObjectMap   :: IntMap.IntMap PackedObject
      , getObjectIndex :: RefIndex
      }
  
  type OffsetMap = IntMap.IntMap PackEntry
  type RefIndex  = Map Ref Int
  
  instance Enum PackObjectType where
      fromEnum (FullType  CommitType)   = 1
      fromEnum (FullType  TreeType)     = 2
      fromEnum (FullType  BlobType)     = 3
      fromEnum (FullType  TagType)      = 4
      fromEnum (DeltaType OfsDeltaType) = 6
      fromEnum (DeltaType RefDeltaType) = 7
  
      toEnum 1 = FullType  CommitType
      toEnum 2 = FullType  TreeType
      toEnum 3 = FullType  BlobType
      toEnum 4 = FullType  TagType
      toEnum 6 = DeltaType OfsDeltaType
      toEnum 7 = DeltaType RefDeltaType
      toEnum _ = error "invalid"
  
  instance Byteable FullObjectType where
      toBytes ty = case ty of
          CommitType -> "commit"
          TagType    -> "tag"
          TreeType   -> "tree"
          BlobType   -> "blob"
  
  instance Byteable PackEntry where
      toBytes (Resolved  packedObject) = toBytes packedObject
      toBytes (UnResolved ofsD@(OfsDelta _ WCL{..})) = let
          header = encodeTypeLen (DeltaType OfsDeltaType) . fromIntegral
              $ B.length (toBytes wclContent)
          in header `B.append` toBytes ofsD
      toBytes (UnResolved refD@(RefDelta _ WCL{..})) = let
          header = encodeTypeLen (DeltaType RefDeltaType) . fromIntegral
              $ B.length (toBytes wclContent)
          in header `B.append` toBytes refD
  
  instance Byteable PackedObject where
      toBytes (PackedObject t _ packed) = let
          header = encodeTypeLen (FullType t) . fromIntegral . B.length
              $ wclContent packed
          in header `B.append` toBytes packed
  
  instance (Byteable a) => Byteable (WCL a) where
      toBytes WCL{..} = compressToLevel wclLevel $ toBytes wclContent
  
  isResolved :: PackEntry -> Bool
  isResolved Resolved{}   = True
  isResolved UnResolved{} = False
  
  compressToLevel :: CompressionLevel -> B.ByteString -> B.ByteString
  compressToLevel level content = toStrict .
      compressWith defaultCompressParams {compressLevel = level}
          $ fromStrict content
  
  getCompressionLevel :: Word8 -> CompressionLevel
  getCompressionLevel levelByte = case levelByte of
          1   -> bestSpeed
          156 -> defaultCompression
          _   -> error "I can't make sense of this compression level"
  
  encodeTypeLen :: PackObjectType -> Natural -> B.ByteString
  encodeTypeLen packObjType len = let
      (last4, rest) = packEntryLenList len
      firstByte     = fromEnum packObjType `shiftL` 4 .|. fromIntegral last4
      firstByte'    = bool firstByte (setMSB firstByte) (rest /= B.empty)
      in B.cons (fromIntegral firstByte') rest
  
  instance Byteable PackDelta where
      toBytes packDelta = uncurry B.append $ case packDelta of
          RefDelta ref delta -> (fst $ decode ref, toBytes delta)
          OfsDelta off delta -> (encodeOffset off, toBytes delta)
  
  instance Byteable Delta where
      toBytes (Delta source destination instructions) = B.concat
          [ toLittleEndian $ to7BitList source
          , toLittleEndian $ to7BitList destination
          , B.concat (map toBytes instructions)
          ]
  
  instance Byteable DeltaInstruction where
      toBytes (InsertInstruction content) =
          B.singleton (fromIntegral $ B.length content) `B.append` content
      toBytes (CopyInstruction offset 0x10000) =
          toBytes $ CopyInstruction offset 0
      toBytes (CopyInstruction offset size) = let
          offsetBytes = toByteList offset
          sizeBytes   = toByteList size
          offsetBits  = map (>0) offsetBytes
          sizeBits    = map (>0) sizeBytes
          bools       = True:padFalse sizeBits 3 ++ padFalse offsetBits 4
          firstByte   = fromIntegral $ boolsToByte bools
          encodedOff  = encode offsetBytes
          encodedSize = encode sizeBytes
          in B.concat [B.singleton firstByte, encodedOff, encodedSize]
          where encode = B.pack . map fromIntegral . reverse . filter (>0)
                padFalse bits len = let pad = len - length bits
                  in bool bits (replicate pad False ++ bits) (pad > 0)
                boolsToByte = foldl' (\acc b -> shiftL acc 1 + fromEnum b) 0
  
  packObjectType :: (Bits t, Integral t) => t -> PackObjectType
  packObjectType header = toEnum . fromIntegral $ (header `shiftR` 4) .&. 7
  
  toAssoc :: PackIndexEntry -> (Int, Ref)
  toAssoc (PackIndexEntry o r _) = (o, r)
  
  emptyObjectMap :: ObjectMap
  emptyObjectMap = ObjectMap IntMap.empty empty
  
  insertObject :: Int -> PackedObject -> ObjectMap -> ObjectMap
  insertObject offset object@(PackedObject _ r _) ObjectMap {..} = ObjectMap
      (IntMap.insert offset object getObjectMap)
      (insert r      offset getObjectIndex)
  
  packIndexEntries :: CombinedMap -> [PackIndexEntry]
  packIndexEntries CombinedMap {..} = let
      crc32s = crc32 . toBytes <$> getOffsetMap
      op r o = (:) (PackIndexEntry o r (crc32s IntMap.! o))
      in foldrWithKey op [] getRefIndex
  