module Resource.Mesh.Codec where

import RIO

import Codec.Compression.Zstd qualified as Zstd
import Codec.Serialise qualified as CBOR
import Crypto.Hash.MD5 qualified as MD5
import Data.Binary.Get (runGet)
import Data.Binary.Get qualified as Get
import Data.Binary.Put (runPut)
import Data.Binary.Put qualified as Put
import Data.ByteString.Internal qualified as BSI
import Data.ByteString.Unsafe (unsafePackCStringLen)
import Data.Typeable (typeRep, typeRepTyCon)
import Data.Vector qualified as Vector
import Data.Vector.Generic qualified as Generic
import Data.Vector.Storable qualified as Storable
import Foreign qualified
import Geomancy.Vec3 qualified as Vec3
import RIO.ByteString qualified as ByteString
import RIO.ByteString.Lazy qualified as BSL
import System.IO.Unsafe (unsafePerformIO)
import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk

import Engine.Vulkan.Types (MonadVulkan, Queues)
import Resource.Buffer qualified as Buffer
import Resource.Model qualified as Model
import Resource.Region qualified as Region

-- * Format meta

pattern VER_BREAKS :: Word8
pattern $bVER_BREAKS :: Word8
$mVER_BREAKS :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
VER_BREAKS = 3

pattern VER_TWEAKS :: Word8
pattern $bVER_TWEAKS :: Word8
$mVER_TWEAKS :: forall {r}. Word8 -> ((# #) -> r) -> ((# #) -> r) -> r
VER_TWEAKS = 0

-- * Encoding

encodeFile
  :: forall vp vi va vn attrs nodes meta env
  .  ( Generic.Vector vp Vec3.Packed
     , Generic.Vector vi Word32
     , Generic.Vector va attrs
     , Generic.Vector vn nodes
     , Storable attrs
     , Storable nodes
     , CBOR.Serialise meta
     , HasLogFunc env
     )
  => FilePath
  -> vp Vec3.Packed
  -> vi Word32
  -> va attrs
  -> vn nodes
  -> meta
  -> RIO env ()
encodeFile :: forall (vp :: * -> *) (vi :: * -> *) (va :: * -> *) (vn :: * -> *)
       attrs nodes meta env.
(Vector vp Packed, Vector vi Word32, Vector va attrs,
 Vector vn nodes, Storable attrs, Storable nodes, Serialise meta,
 HasLogFunc env) =>
FilePath
-> vp Packed
-> vi Word32
-> va attrs
-> vn nodes
-> meta
-> RIO env ()
encodeFile FilePath
fp vp Packed
positions vi Word32
indices va attrs
attrs vn nodes
nodes meta
meta = do
  (ByteString
posDigest, ByteString
posCompressed) <- forall a (v :: * -> *) (m :: * -> *).
(Storable a, Vector v a, MonadIO m) =>
v a -> m (ByteString, ByteString)
encodeItems vp Packed
positions
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Position digest: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow ByteString
posDigest

  (ByteString
indDigest, ByteString
indCompressed) <- forall a (v :: * -> *) (m :: * -> *).
(Storable a, Vector v a, MonadIO m) =>
v a -> m (ByteString, ByteString)
encodeItems vi Word32
indices
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Index digest: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow ByteString
indDigest

  (ByteString
attDigest, ByteString
attCompressed) <- forall a (v :: * -> *) (m :: * -> *).
(Storable a, Vector v a, MonadIO m) =>
v a -> m (ByteString, ByteString)
encodeItems va attrs
attrs
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Attribute digest: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow ByteString
attDigest

  (ByteString
nodDigest, ByteString
nodCompressed) <- forall a (v :: * -> *) (m :: * -> *).
(Storable a, Vector v a, MonadIO m) =>
v a -> m (ByteString, ByteString)
encodeItems vn nodes
nodes
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Node digest: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow ByteString
nodDigest

  let (Int
metSize, ByteString
metDigest, ByteString
metCompressed) = forall a. Serialise a => a -> (Int, ByteString, ByteString)
encodeCBOR meta
meta
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Meta digest: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow ByteString
metDigest

  forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withFile FilePath
fp IOMode
WriteMode \Handle
out -> do
    forall (m :: * -> *). MonadIO m => Handle -> LByteString -> m ()
BSL.hPut Handle
out forall a b. (a -> b) -> a -> b
$ Put -> LByteString
runPut do
      -- 0x00 + 4 + 4
      FilePath -> Put
Put.putStringUtf8 FilePath
"🌋📦"

      -- 0x08 + 1 + 1
      Word8 -> Put
Put.putWord8 Word8
VER_BREAKS
      Word8 -> Put
Put.putWord8 Word8
VER_TWEAKS

      -- 0x0A + 2 + 4
      -- XXX: reserved
      Word16 -> Put
Put.putWord16le forall a. Bounded a => a
maxBound
      Word32 -> Put
Put.putWord32le forall a. Bounded a => a
maxBound

      -- 0x10 + 4 + 4
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) a. Vector v a => v a -> Int
Generic.length vp Packed
positions
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
posCompressed

      -- 0x18 + 4 + 4
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) a. Vector v a => v a -> Int
Generic.length vi Word32
indices
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
indCompressed

      -- 0x20 + 4 + 4
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
Foreign.sizeOf (forall a. HasCallStack => FilePath -> a
error FilePath
"sizeOf" :: attrs)
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
attCompressed

      -- 0x28 + 4 + 4
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
Foreign.sizeOf (forall a. HasCallStack => FilePath -> a
error FilePath
"sizeOf" :: nodes)
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
nodCompressed

      -- 0x30 + 4 + 4
      Word32 -> Put
Put.putWord32le forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
metSize
      Word32 -> Put
Put.putWord32le forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
metCompressed

      -- 0x38 + 4 + 4
      -- XXX: reserved
      Word32 -> Put
Put.putWord32le forall a. Bounded a => a
maxBound
      Word32 -> Put
Put.putWord32le forall a. Bounded a => a
maxBound

      -- 0x40 + 16 + 16 + 16 + 16 + 16
      ByteString -> Put
Put.putByteString ByteString
posDigest
      ByteString -> Put
Put.putByteString ByteString
indDigest
      ByteString -> Put
Put.putByteString ByteString
attDigest
      ByteString -> Put
Put.putByteString ByteString
nodDigest
      ByteString -> Put
Put.putByteString ByteString
metDigest

      -- 0x90 + posCompressed
      ByteString -> Put
Put.putByteString ByteString
posCompressed

      -- 0x90 + posCompressed + indCompressed
      ByteString -> Put
Put.putByteString ByteString
indCompressed

      -- 0x90 + posCompressed + indCompressed + attCompressed
      ByteString -> Put
Put.putByteString ByteString
attCompressed

      -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed
      ByteString -> Put
Put.putByteString ByteString
nodCompressed

      -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed + metCompressed
      ByteString -> Put
Put.putByteString ByteString
metCompressed

      -- 0x90 + posCompressed + indCompressed + attCompressed + nodCompressed + metCompressed + 4 + 4
      FilePath -> Put
Put.putStringUtf8 FilePath
"📦🌋"

encodeItems
  :: ( Storable a
     , Generic.Vector v a
     , MonadIO m
     )
  => v a
  -> m (ByteString, ByteString)
encodeItems :: forall a (v :: * -> *) (m :: * -> *).
(Storable a, Vector v a, MonadIO m) =>
v a -> m (ByteString, ByteString)
encodeItems v a
items = do
  let bytes :: Vector Word8
bytes = forall a b. (Storable a, Storable b) => Vector a -> Vector b
Storable.unsafeCast @_ @Word8 forall a b. (a -> b) -> a -> b
$ forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
Vector.convert v a
items
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
Storable.unsafeWith Vector Word8
bytes \Ptr Word8
ptr -> do
    ByteString
buf <- CStringLen -> IO ByteString
unsafePackCStringLen
      ( forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr Word8
ptr
      , forall a. Storable a => Vector a -> Int
Storable.length Vector Word8
bytes
      )
    let
      -- XXX: Process buffer before bytes/ptr go out of scope!
      !bufHash :: ByteString
bufHash = ByteString -> ByteString
MD5.hash ByteString
buf
      !zBuf :: ByteString
zBuf = Int -> ByteString -> ByteString
Zstd.compress Int
Zstd.maxCLevel ByteString
buf
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
bufHash, ByteString
zBuf)

encodeCBOR :: CBOR.Serialise a => a -> (Int, ByteString, ByteString)
encodeCBOR :: forall a. Serialise a => a -> (Int, ByteString, ByteString)
encodeCBOR a
stuff =
  ( ByteString -> Int
ByteString.length ByteString
buf
  , ByteString -> ByteString
MD5.hash ByteString
buf
  , Int -> ByteString -> ByteString
Zstd.compress Int
Zstd.maxCLevel ByteString
buf
  )
  where
    buf :: ByteString
buf = LByteString -> ByteString
BSL.toStrict (forall a. Serialise a => a -> LByteString
CBOR.serialise a
stuff)

-- * Decoding

loadIndexed
  :: ( Storable attrs
     , Storable nodes
     , CBOR.Serialise meta
     , Show meta
     , Typeable nodes
     , HasLogFunc env
     , MonadResource m
     , MonadVulkan env m
     )
  => Queues Vk.CommandPool
  -> FilePath
  -> m
    ( Resource.ReleaseKey
    , ( meta
      , Storable.Vector nodes
      , Model.Indexed 'Buffer.Staged Vec3.Packed attrs
      )
    )
loadIndexed :: forall attrs nodes meta env (m :: * -> *).
(Storable attrs, Storable nodes, Serialise meta, Show meta,
 Typeable nodes, HasLogFunc env, MonadResource m,
 MonadVulkan env m) =>
Queues CommandPool
-> FilePath
-> m (ReleaseKey,
      (meta, Vector nodes, Indexed 'Staged Packed attrs))
loadIndexed Queues CommandPool
pools FilePath
fp = do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loading " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
fp
  (meta
meta, Vector nodes
nodes, (Vector Packed
positions, Vector Word32
indices, Vector attrs
attrs)) <- forall attrs env nodes meta (m :: * -> *).
(Storable attrs, Serialise meta, Storable nodes, Typeable nodes,
 HasLogFunc env, MonadReader env m, MonadIO m) =>
FilePath
-> m (meta, Vector nodes,
      (Vector Packed, Vector Word32, Vector attrs))
loadBlobs FilePath
fp
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow meta
meta

  forall (m :: * -> *) a.
MonadResource m =>
ResourceT m a -> m (ReleaseKey, a)
Region.run do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Staging " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => FilePath -> a
fromString FilePath
fp
    Indexed 'Staged Packed attrs
indexed <- forall env (m :: * -> *) pos attrs.
(MonadVulkan env m, Storable pos, Storable attrs) =>
Maybe Text
-> Queues CommandPool
-> Vector pos
-> Vector attrs
-> Vector Word32
-> m (Indexed 'Staged pos attrs)
Model.createStaged (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsString a => FilePath -> a
fromString FilePath
fp) Queues CommandPool
pools Vector Packed
positions Vector attrs
attrs Vector Word32
indices
    forall env (m :: * -> *) (storage :: Store) pos attrs.
(MonadVulkan env m, MonadResource m) =>
Indexed storage pos attrs -> m ()
Model.registerIndexed_ Indexed 'Staged Packed attrs
indexed
    pure (meta
meta, Vector nodes
nodes, Indexed 'Staged Packed attrs
indexed)

loadBlobs
  :: forall attrs env nodes meta m
  .  ( Storable attrs
     , CBOR.Serialise meta
     , Storable nodes
     , Typeable nodes
     , HasLogFunc env
     , MonadReader env m
     , MonadIO m
     )
  => FilePath
  -> m
    ( meta
    , Storable.Vector nodes
    , ( Storable.Vector Vec3.Packed
      , Storable.Vector Word32
      , Storable.Vector attrs
      )
    )
loadBlobs :: forall attrs env nodes meta (m :: * -> *).
(Storable attrs, Serialise meta, Storable nodes, Typeable nodes,
 HasLogFunc env, MonadReader env m, MonadIO m) =>
FilePath
-> m (meta, Vector nodes,
      (Vector Packed, Vector Word32, Vector attrs))
loadBlobs FilePath
fp = do
  LByteString
blob <- forall (m :: * -> *). MonadIO m => FilePath -> m LByteString
BSL.readFile FilePath
fp
  let
    getter :: Get
  (Word8, meta, Vector nodes,
   (Vector Packed, Vector Word32, Vector attrs))
getter = do
      ByteString
magicStart <- Int -> Get ByteString
Get.getByteString (Int
4forall a. Num a => a -> a -> a
+Int
4)

      Word8
verBreaks <- Get Word8
Get.getWord8
      Word8
verTweaks <- Get Word8
Get.getWord8
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq FilePath
"Codec version" Word8
VER_BREAKS Word8
verBreaks

      Word16
_reserved16 <- Get Word16
Get.getWord16le
      Word32
_reserved32 <- Get Word32
Get.getWord32le

      Int
numPositions <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le
      Int
lenPositions <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le

      Int
numIndices <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le
      Int
lenIndices <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le

      Int
sizeOfAttr <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le
      Int
lenAttrs   <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq FilePath
"Attribute size" (forall a. Storable a => a -> Int
Foreign.sizeOf (forall a. HasCallStack => FilePath -> a
error FilePath
"sizeOfAttr" :: attrs)) Int
sizeOfAttr

      Int
sizeOfNode <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le
      Int
lenNodes   <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq
        (FilePath
"Node size for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show (TypeRep -> TyCon
typeRepTyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @nodes))
        (forall a. Storable a => a -> Int
Foreign.sizeOf (forall a. HasCallStack => FilePath -> a
error FilePath
"sizeOfNode" :: nodes))
        Int
sizeOfNode

      Int
sizeOfMeta <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le
      Int
lenMeta    <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word32
Get.getWord32le
      -- guardEq "Meta size" (Foreign.sizeOf (error "sizeOf" :: meta)) sizeOfMeta

      Word32
_reserved32 <- Get Word32
Get.getWord32le
      Word32
_reserved32 <- Get Word32
Get.getWord32le

      ByteString
posDigest <- Int -> Get ByteString
Get.getByteString Int
16
      ByteString
indDigest <- Int -> Get ByteString
Get.getByteString Int
16
      ByteString
attDigest <- Int -> Get ByteString
Get.getByteString Int
16
      ByteString
nodDigest <- Int -> Get ByteString
Get.getByteString Int
16
      ByteString
metDigest <- Int -> Get ByteString
Get.getByteString Int
16

      -- XXX: end for static part for VER_BREAKS
      Int64
staticDone <- Get Int64
Get.bytesRead
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq (FilePath
"End of static part for v" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Word8
VER_BREAKS) Int64
0x90 Int64
staticDone

      let payloadSize :: Int64
payloadSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
lenPositions forall a. Num a => a -> a -> a
+ Int
lenIndices forall a. Num a => a -> a -> a
+ Int
lenAttrs forall a. Num a => a -> a -> a
+ Int
lenNodes forall a. Num a => a -> a -> a
+ Int
lenMeta)
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq FilePath
"Blob size" (LByteString -> Int64
BSL.length LByteString
blob) forall a b. (a -> b) -> a -> b
$
        Int64
staticDone forall a. Num a => a -> a -> a
+ Int64
payloadSize forall a. Num a => a -> a -> a
+ Int64
4 forall a. Num a => a -> a -> a
+ Int64
4

      ByteString
zPositions <- Int -> Get ByteString
Get.getByteString Int
lenPositions
      ByteString
zIndices   <- Int -> Get ByteString
Get.getByteString Int
lenIndices
      ByteString
zAttrs     <- Int -> Get ByteString
Get.getByteString Int
lenAttrs
      ByteString
zNodes     <- Int -> Get ByteString
Get.getByteString Int
lenNodes
      ByteString
zMetas     <- Int -> Get ByteString
Get.getByteString Int
lenMeta

      ByteString
magicFinish <- Int -> Get ByteString
Get.getByteString (Int
4forall a. Num a => a -> a -> a
+Int
4)

      let magicReverse :: ByteString
magicReverse = Int -> ByteString -> ByteString
ByteString.drop Int
4 ByteString
magicFinish forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
ByteString.take Int
4 ByteString
magicFinish
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq FilePath
"Magic final" ByteString
magicStart ByteString
magicReverse

      Vector Packed
positions <- forall item (m :: * -> *).
(Storable item, MonadFail m) =>
FilePath
-> ByteString -> Maybe Int -> ByteString -> m (Vector item)
decodeItems FilePath
"Positions"  ByteString
posDigest (forall a. a -> Maybe a
Just Int
numPositions) ByteString
zPositions
      Vector Word32
indices   <- forall item (m :: * -> *).
(Storable item, MonadFail m) =>
FilePath
-> ByteString -> Maybe Int -> ByteString -> m (Vector item)
decodeItems FilePath
"Indices"    ByteString
indDigest (forall a. a -> Maybe a
Just Int
numIndices)   ByteString
zIndices
      Vector attrs
attrs     <- forall item (m :: * -> *).
(Storable item, MonadFail m) =>
FilePath
-> ByteString -> Maybe Int -> ByteString -> m (Vector item)
decodeItems FilePath
"Attributes" ByteString
attDigest (forall a. a -> Maybe a
Just Int
numPositions) ByteString
zAttrs
      Vector nodes
nodes     <- forall item (m :: * -> *).
(Storable item, MonadFail m) =>
FilePath
-> ByteString -> Maybe Int -> ByteString -> m (Vector item)
decodeItems FilePath
"Nodes"      ByteString
nodDigest forall a. Maybe a
Nothing             ByteString
zNodes

      meta
meta      <- forall a (m :: * -> *).
(Serialise a, MonadFail m) =>
FilePath -> ByteString -> Int -> ByteString -> m a
decodeCBOR  FilePath
"Metadata"   ByteString
metDigest Int
sizeOfMeta          ByteString
zMetas

      pure (Word8
verTweaks, meta
meta, Vector nodes
nodes, (Vector Packed
positions, Vector Word32
indices, Vector attrs
attrs))

  let (Word8
verTweaks, meta
meta, Vector nodes
nodes, (Vector Packed, Vector Word32, Vector attrs)
blobs) = forall a. Get a -> LByteString -> a
runGet Get
  (Word8, meta, Vector nodes,
   (Vector Packed, Vector Word32, Vector attrs))
getter LByteString
blob

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
verTweaks forall a. Eq a => a -> a -> Bool
/= Word8
VER_TWEAKS) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ Utf8Builder
"Format tweak version mismatch: "
      , forall a. Display a => a -> Utf8Builder
display Word8
verTweaks
      , Utf8Builder
" /= "
      , forall a. Display a => a -> Utf8Builder
display Word8
VER_TWEAKS
      ]

  pure (meta
meta, Vector nodes
nodes, (Vector Packed, Vector Word32, Vector attrs)
blobs)

decodeItems
  :: forall item m
  . (Storable item, MonadFail m)
  => String
  -> ByteString
  -> Maybe Int
  -> ByteString
  -> m (Storable.Vector item)
decodeItems :: forall item (m :: * -> *).
(Storable item, MonadFail m) =>
FilePath
-> ByteString -> Maybe Int -> ByteString -> m (Vector item)
decodeItems FilePath
label ByteString
digest Maybe Int
expectedSize ByteString
zBytes =
  case ByteString -> Decompress
Zstd.decompress ByteString
zBytes of
    Zstd.Error FilePath
err ->
      forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
err
    Decompress
Zstd.Skip -> do
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq (FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" size") Int
0 Int
itemSize
      case Maybe Int
expectedSize of
        Just Int
size ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Int -> a -> Vector a
Storable.replicate Int
size forall a b. (a -> b) -> a -> b
$
            forall a. IO a -> a
unsafePerformIO (forall a. Storable a => Ptr a -> IO a
Foreign.peek forall a. Ptr a
Foreign.nullPtr)
        Maybe Int
Nothing ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Storable a => Vector a
Storable.empty
    Zstd.Decompress ByteString
bytes -> do
      let (ForeignPtr Word8
buf, Int
bufOff, Int
bufLen) = ByteString -> (ForeignPtr Word8, Int, Int)
BSI.toForeignPtr ByteString
bytes
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq (FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" buffer offset") Int
0 Int
bufOff
      case Maybe Int
expectedSize of
        Maybe Int
Nothing ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Int
size ->
          forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq (FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" buffer size") (Int
itemSize forall a. Num a => a -> a -> a
* Int
size) Int
bufLen
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq (FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" hash") ByteString
digest (ByteString -> ByteString
MD5.hash ByteString
bytes)
      let
        !items :: Vector item
items =
          forall a b. (Storable a, Storable b) => Vector a -> Vector b
Storable.unsafeCast @Word8 @item forall a b. (a -> b) -> a -> b
$
            forall a. Storable a => ForeignPtr a -> Int -> Vector a
Storable.unsafeFromForeignPtr0 ForeignPtr Word8
buf Int
bufLen
      case Maybe Int
expectedSize of
        Maybe Int
Nothing ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Int
size ->
          forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq (FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" size") Int
size (forall a. Storable a => Vector a -> Int
Storable.length Vector item
items)
      pure Vector item
items
  where
    itemSize :: Int
itemSize = forall a. Storable a => a -> Int
Foreign.sizeOf @item forall a. HasCallStack => a
undefined

decodeCBOR
  :: ( CBOR.Serialise a
     , MonadFail m
     )
  => String
  -> ByteString
  -> Int
  -> ByteString
  -> m a
decodeCBOR :: forall a (m :: * -> *).
(Serialise a, MonadFail m) =>
FilePath -> ByteString -> Int -> ByteString -> m a
decodeCBOR FilePath
label ByteString
digest Int
expectedSize ByteString
zBytes =
  case ByteString -> Decompress
Zstd.decompress ByteString
zBytes of
    Zstd.Error FilePath
err ->
      forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
": zstd error (" forall a. Semigroup a => a -> a -> a
<> FilePath
err forall a. Semigroup a => a -> a -> a
<> FilePath
")"
    Decompress
Zstd.Skip ->
      forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
": empty zstd"
    Zstd.Decompress ByteString
bytes -> do
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq (FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" size") Int
expectedSize (ByteString -> Int
ByteString.length ByteString
bytes)
      forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq (FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" hash") ByteString
digest (ByteString -> ByteString
MD5.hash ByteString
bytes)
      case forall a. Serialise a => LByteString -> Either DeserialiseFailure a
CBOR.deserialiseOrFail (ByteString -> LByteString
BSL.fromStrict ByteString
bytes) of
        Right a
value ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure a
value
        Left (CBOR.DeserialiseFailure Int64
_off FilePath
err) ->
          forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
            [ FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" deserialise failure:"
            , FilePath
err
            ]

-- * Utils

guardEq :: (MonadFail m, Show a, Eq a) => String -> a -> a -> m ()
guardEq :: forall (m :: * -> *) a.
(MonadFail m, Show a, Eq a) =>
FilePath -> a -> a -> m ()
guardEq FilePath
label a
expected a
got = do
  if a
expected forall a. Eq a => a -> a -> Bool
== a
got then
    -- traceM . fromString $ label <> " match: " <> show got
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else
    forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
      [ FilePath
label forall a. Semigroup a => a -> a -> a
<> FilePath
" mismatch"
      , FilePath
"\tExpected: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show a
expected
      , FilePath
"\tGot     : " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show a
got
      ]