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
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
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
FilePath -> Put
Put.putStringUtf8 FilePath
"🌋📦"
Word8 -> Put
Put.putWord8 Word8
VER_BREAKS
Word8 -> Put
Put.putWord8 Word8
VER_TWEAKS
Word16 -> Put
Put.putWord16le forall a. Bounded a => a
maxBound
Word32 -> Put
Put.putWord32le forall a. Bounded a => a
maxBound
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
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
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
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
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
Word32 -> Put
Put.putWord32le forall a. Bounded a => a
maxBound
Word32 -> Put
Put.putWord32le forall a. Bounded a => a
maxBound
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
ByteString -> Put
Put.putByteString ByteString
posCompressed
ByteString -> Put
Put.putByteString ByteString
indCompressed
ByteString -> Put
Put.putByteString ByteString
attCompressed
ByteString -> Put
Put.putByteString ByteString
nodCompressed
ByteString -> Put
Put.putByteString ByteString
metCompressed
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
!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)
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
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
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
]
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
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
]