Skip to content

Commit

Permalink
TOSQUASH
Browse files Browse the repository at this point in the history
  • Loading branch information
@jorisdral
jorisdral committed Apr 29, 2024
1 parent 4b954e8 commit 640e4fe
Show file tree
Hide file tree
Showing 3 changed files with 72 additions and 38 deletions.
38 changes: 21 additions & 17 deletions src-extras/Database/LSMTree/Extras/Orphans.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,10 +20,10 @@ import qualified Data.Primitive as P
import qualified Data.Vector.Primitive as PV
import Data.WideWord.Word128 (Word128 (..), byteSwapWord128)
import Data.WideWord.Word256 (Word256 (..))
import Database.LSMTree.Internal.Primitive (indexWord8ArrayAsWord64)
import qualified Database.LSMTree.Internal.RawBytes as RB
import Database.LSMTree.Internal.Serialise.Class
import Database.LSMTree.Internal.Vector
import GHC.Exts
import GHC.Generics
import GHC.Word
import qualified System.FS.API as FS
Expand All @@ -45,8 +45,9 @@ instance SerialiseKey Word256 where
P.writeByteArray ba 0 $ byteSwapWord256 w256
return ba
deserialiseKey (RawBytes (PV.Vector off len ba))
| len >= 32 = byteSwapWord256 $ indexWord8ArrayAsWord256 ba off
| otherwise = error "deserialiseKey: not enough bytes for Word256"
| len >= expected = byteSwapWord256 $ indexWord8ArrayAsWord256 ba off
| otherwise = error $ deserialiseKeyInputBytesNotPrecise "Word256" len expected
where expected = 32

instance SerialiseValue Word256 where
serialiseValue w256 =
Expand All @@ -55,8 +56,9 @@ instance SerialiseValue Word256 where
P.writeByteArray ba 0 w256
return ba
deserialiseValue (RawBytes (PV.Vector off len ba))
| len >= 32 = indexWord8ArrayAsWord256 ba off
| otherwise = error "deserialiseValue: not enough bytes for Word256"
| len >= expected = indexWord8ArrayAsWord256 ba off
| otherwise = error $ deserialiseValueInputBytesNotPrecise "Word256" len expected
where expected = 32
deserialiseValueN = deserialiseValue . mconcat -- TODO: optimise

instance Arbitrary Word256 where
Expand All @@ -76,11 +78,11 @@ byteSwapWord256 (Word256 a3 a2 a1 a0) =

{-# INLINE indexWord8ArrayAsWord256 #-}
indexWord8ArrayAsWord256 :: P.ByteArray -> Int -> Word256
indexWord8ArrayAsWord256 (P.ByteArray ba#) (I# off#) =
Word256 (W64# (indexWord8ArrayAsWord64# ba# (off# +# 24#)))
(W64# (indexWord8ArrayAsWord64# ba# (off# +# 16#)))
(W64# (indexWord8ArrayAsWord64# ba# (off# +# 8#)))
(W64# (indexWord8ArrayAsWord64# ba# off#))
indexWord8ArrayAsWord256 !ba !off =
Word256 (indexWord8ArrayAsWord64 ba (off + 24))
(indexWord8ArrayAsWord64 ba (off + 16))
(indexWord8ArrayAsWord64 ba (off + 8))
(indexWord8ArrayAsWord64 ba off)

{-------------------------------------------------------------------------------
Word128
Expand All @@ -95,8 +97,9 @@ instance SerialiseKey Word128 where
P.writeByteArray ba 0 $ byteSwapWord128 w128
return ba
deserialiseKey (RawBytes (PV.Vector off len ba))
| len >= 16 = byteSwapWord128 $ indexWord8ArrayAsWord128 ba off
| otherwise = error "deserialiseKey: not enough bytes for Word128"
| len >= expected = byteSwapWord128 $ indexWord8ArrayAsWord128 ba off
| otherwise = error $ deserialiseKeyInputBytesNotPrecise "Word128" len expected
where expected = 16

instance SerialiseValue Word128 where
serialiseValue w128 =
Expand All @@ -105,8 +108,9 @@ instance SerialiseValue Word128 where
P.writeByteArray ba 0 w128
return ba
deserialiseValue (RawBytes (PV.Vector off len ba))
| len >= 16 = indexWord8ArrayAsWord128 ba off
| otherwise = error "deserialiseValue: not enough bytes for Word128"
| len >= expected = indexWord8ArrayAsWord128 ba off
| otherwise = error $ deserialiseValueInputBytesNotPrecise "Word128" len expected
where expected = 16
deserialiseValueN = deserialiseValue . mconcat -- TODO: optimise

instance Arbitrary Word128 where
Expand All @@ -121,9 +125,9 @@ instance Arbitrary Word128 where

{-# INLINE indexWord8ArrayAsWord128 #-}
indexWord8ArrayAsWord128 :: P.ByteArray -> Int -> Word128
indexWord8ArrayAsWord128 (P.ByteArray ba#) (I# off#) =
Word128 (W64# (indexWord8ArrayAsWord64# ba# (off# +# 8#)))
(W64# (indexWord8ArrayAsWord64# ba# off#))
indexWord8ArrayAsWord128 !ba !off =
Word128 (indexWord8ArrayAsWord64 ba (off + 8))
(indexWord8ArrayAsWord64 ba off)

{-------------------------------------------------------------------------------
NFData
Expand Down
33 changes: 17 additions & 16 deletions src-extras/Database/LSMTree/Extras/UTxO.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -48,15 +48,16 @@ instance SerialiseKey UTxOKey where
P.writeByteArray ba 16 $ byteSwap16 txIx
return ba
deserialiseKey (RawBytes (PV.Vector off len ba))
| len >= 34 = UTxOKey (byteSwapWord256 $ indexWord8ArrayAsWord256 ba off)
(byteSwap16 $ indexWord8ArrayAsWord16 ba (off + 32))
| otherwise = error "deserialiseKey: not enough bytes for UTxOKey"
| len == expected
= UTxOKey (byteSwapWord256 $ indexWord8ArrayAsWord256 ba off)
(byteSwap16 $ indexWord8ArrayAsWord16 ba (off + 32))
| otherwise
= error $ deserialiseKeyInputBytesNotPrecise "UTxOKey" len expected
where expected = 34

instance Arbitrary UTxOKey where
arbitrary = UTxOKey <$> arbitrary <*> arbitrary
shrink UTxOKey{txId, txIx} =
(UTxOKey <$> shrink txId <*> pure txIx)
<> (UTxOKey <$> pure txId <*> shrink txIx)
shrink (UTxOKey a b) = [ UTxOKey a' b' | (a', b') <- shrink (a, b) ]

{-------------------------------------------------------------------------------
UTxO values
Expand All @@ -82,20 +83,20 @@ instance SerialiseValue UTxOValue where
P.writeByteArray ba 14 utxoValue32
return ba
deserialiseValue (RawBytes (PV.Vector off len ba))
| len >= 60 = UTxOValue (indexWord8ArrayAsWord256 ba off)
(indexWord8ArrayAsWord128 ba (off + 32))
(indexWord8ArrayAsWord64 ba (off + 48))
(indexWord8ArrayAsWord32 ba (off + 56))
| otherwise = error "deserialiseValue: not enough bytes for UTxOValue"
| len >= expected
= UTxOValue (indexWord8ArrayAsWord256 ba off)
(indexWord8ArrayAsWord128 ba (off + 32))
(indexWord8ArrayAsWord64 ba (off + 48))
(indexWord8ArrayAsWord32 ba (off + 56))
| otherwise
= error $ deserialiseValueInputBytesNotPrecise "UTxOValue" len expected
where expected = 60
deserialiseValueN = deserialiseValue . mconcat -- TODO: optimise

instance Arbitrary UTxOValue where
arbitrary = UTxOValue <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
shrink (UTxOValue a b c d) =
(UTxOValue <$> shrink a <*> pure b <*> pure c <*> pure d)
<> (UTxOValue <$> pure a <*> shrink b <*> pure c <*> pure d)
<> (UTxOValue <$> pure a <*> pure b <*> shrink c <*> pure d)
<> (UTxOValue <$> pure a <*> pure b <*> pure c <*> shrink d)
shrink (UTxOValue a b c d) = [ UTxOValue a' b' c' d'
| (a', b', c', d') <- shrink (a, b, c, d) ]

{-------------------------------------------------------------------------------
UTxO blobs
Expand Down
39 changes: 34 additions & 5 deletions src/Database/LSMTree/Internal/Serialise/Class.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,9 @@ module Database.LSMTree.Internal.Serialise.Class (
, serialiseValueConcatDistributes
, RawBytes (..)
, packSlice
-- * Error messages
, deserialiseKeyInputBytesNotPrecise
, deserialiseValueInputBytesNotPrecise
) where

import qualified Data.ByteString as BS
Expand All @@ -32,7 +35,9 @@ import Database.LSMTree.Internal.RawBytes (RawBytes (..))
import qualified Database.LSMTree.Internal.RawBytes as RB
import Database.LSMTree.Internal.Vector
import GHC.Exts (Int (..), indexWord8ArrayAsWord64#)
import GHC.Show (showSpace)
import GHC.Word (Word64 (..))
import Numeric (showInt)

-- | Serialisation of keys.
--
Expand Down Expand Up @@ -121,6 +126,29 @@ packSlice :: RawBytes -> RawBytes -> RawBytes -> RawBytes
packSlice prefix x suffix =
RB.take (RB.size x) (RB.drop (RB.size prefix) (prefix <> x <> suffix))

{-------------------------------------------------------------------------------
Error messages
-------------------------------------------------------------------------------}

inputBytesNotPrecisely :: String -> String -> Int -> Int -> String
inputBytesNotPrecisely funcName tyName actual expected =
showString funcName
. showSpace
. showParen True (showString tyName)
. showString ": expected "
. showInt actual
. showString " bytes, but got "
. showInt expected
$ ""

-- | @'serialiseKeyInputBytesNotPrecise' tyName actual expected@
deserialiseKeyInputBytesNotPrecise :: String -> Int -> Int -> String
deserialiseKeyInputBytesNotPrecise = inputBytesNotPrecisely "deserialiseKey"

-- | @'serialiseValueInputBytesNotPrecise' tyName actual expected@
deserialiseValueInputBytesNotPrecise :: String -> Int -> Int -> String
deserialiseValueInputBytesNotPrecise = inputBytesNotPrecisely "deserialiseValue"

{-------------------------------------------------------------------------------
Word64
-------------------------------------------------------------------------------}
Expand All @@ -133,8 +161,9 @@ instance SerialiseKey Word64 where
return ba

deserialiseKey (RawBytes (PV.Vector (I# off#) len (P.ByteArray ba#)))
| len >= 8 = byteSwap64 (W64# (indexWord8ArrayAsWord64# ba# off# ))
| otherwise = error "deserialiseKey: not enough bytes for Word64"
| len >= expected = byteSwap64 (W64# (indexWord8ArrayAsWord64# ba# off# ))
| otherwise = error $ deserialiseKeyInputBytesNotPrecise "Word64" len expected
where expected = 8

instance SerialiseValue Word64 where
serialiseValue x =
Expand All @@ -144,9 +173,9 @@ instance SerialiseValue Word64 where
return ba

deserialiseValue (RawBytes (PV.Vector off len ba))
| len >= 8 = indexWord8ArrayAsWord64 ba off
| otherwise = error "deserialiseValue: not enough bytes for Word64"

| len >= expected = indexWord8ArrayAsWord64 ba off
| otherwise = error $ deserialiseValueInputBytesNotPrecise "Word64" len expected
where expected = 8
deserialiseValueN = deserialiseValue . mconcat

{-------------------------------------------------------------------------------
Expand Down

0 comments on commit 640e4fe

Please sign in to comment.