{-# OPTIONS_HADDOCK not-home #-}

-- | Public API for serialisation of keys, blobs and values
--
module Database.LSMTree.Internal.Serialise.Class (
    SerialiseKey (..)
  , serialiseKeyIdentity
  , serialiseKeyIdentityUpToSlicing
  , serialiseKeyPreservesOrdering
  , serialiseKeyMinimalSize
  , SerialiseValue (..)
  , serialiseValueIdentity
  , serialiseValueIdentityUpToSlicing
  , RawBytes (..)
  , packSlice
    -- * Errors
  , requireBytesExactly
  ) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Short.Internal as SBS
import           Data.Monoid (Sum (..))
import qualified Data.Primitive as P
import qualified Data.Vector.Primitive as VP
import           Data.Void (Void, absurd)
import           Data.Word
import           Database.LSMTree.Internal.ByteString (byteArrayToSBS)
import           Database.LSMTree.Internal.Primitive (indexWord8ArrayAsWord64)
import           Database.LSMTree.Internal.RawBytes (RawBytes (..))
import qualified Database.LSMTree.Internal.RawBytes as RB
import           Database.LSMTree.Internal.Vector
import           Numeric (showInt)

-- | Serialisation of keys.
--
-- Instances should satisfy the following:
--
-- [Identity] @'deserialiseKey' ('serialiseKey' x) == x@
-- [Identity up to slicing] @'deserialiseKey' ('packSlice' prefix ('serialiseKey' x) suffix) == x@
--
-- Instances /may/ satisfy the following:
--
-- [Ordering-preserving] @x \`'compare'\` y == 'serialiseKey' x \`'compare'\` 'serialiseKey' y@
--
-- Raw bytes are lexicographically ordered, so in particular this means that
-- values should be serialised into big-endian formats. This constraint mainly
-- exists for range queries, where the range is specified in terms of
-- unserialised values, but the internal implementation works on the serialised
-- representation.
class SerialiseKey k where
  serialiseKey :: k -> RawBytes
  -- TODO: 'deserialiseKey' is only strictly necessary for range queries.
  -- It might make sense to move it to a separate class, which could also
  -- require total deserialisation (potentially using 'Either').
  deserialiseKey :: RawBytes -> k

-- | Test the __Identity__ law for the 'SerialiseKey' class
serialiseKeyIdentity :: (Eq k, SerialiseKey k) => k -> Bool
serialiseKeyIdentity :: forall k. (Eq k, SerialiseKey k) => k -> Bool
serialiseKeyIdentity k
x = RawBytes -> k
forall k. SerialiseKey k => RawBytes -> k
deserialiseKey (k -> RawBytes
forall k. SerialiseKey k => k -> RawBytes
serialiseKey k
x) k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
x

-- | Test the __Identity up to slicing__ law for the 'SerialiseKey' class
serialiseKeyIdentityUpToSlicing ::
     (Eq k, SerialiseKey k)
  => RawBytes -> k -> RawBytes -> Bool
serialiseKeyIdentityUpToSlicing :: forall k.
(Eq k, SerialiseKey k) =>
RawBytes -> k -> RawBytes -> Bool
serialiseKeyIdentityUpToSlicing RawBytes
prefix k
x RawBytes
suffix =
    RawBytes -> k
forall k. SerialiseKey k => RawBytes -> k
deserialiseKey (RawBytes -> RawBytes -> RawBytes -> RawBytes
packSlice RawBytes
prefix (k -> RawBytes
forall k. SerialiseKey k => k -> RawBytes
serialiseKey k
x) RawBytes
suffix) k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
x

-- | Test the __Ordering-preserving__ law for the 'SerialiseKey' class
serialiseKeyPreservesOrdering :: (Ord k, SerialiseKey k) => k -> k -> Bool
serialiseKeyPreservesOrdering :: forall k. (Ord k, SerialiseKey k) => k -> k -> Bool
serialiseKeyPreservesOrdering k
x k
y = k
x k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` k
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== k -> RawBytes
forall k. SerialiseKey k => k -> RawBytes
serialiseKey k
x RawBytes -> RawBytes -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` k -> RawBytes
forall k. SerialiseKey k => k -> RawBytes
serialiseKey k
y

-- | Test the __Minimal size__ law for the 'SerialiseKey' class.
serialiseKeyMinimalSize :: SerialiseKey k => k -> Bool
serialiseKeyMinimalSize :: forall k. SerialiseKey k => k -> Bool
serialiseKeyMinimalSize k
x = RawBytes -> Int
RB.size (k -> RawBytes
forall k. SerialiseKey k => k -> RawBytes
serialiseKey k
x) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
8

-- | Serialisation of values and blobs.
--
-- Instances should satisfy the following:
--
-- [Identity] @'deserialiseValue' ('serialiseValue' x) == x@
-- [Identity up to slicing] @'deserialiseValue' ('packSlice' prefix ('serialiseValue' x) suffix) == x@
class SerialiseValue v where
  serialiseValue :: v -> RawBytes
  deserialiseValue :: RawBytes -> v


-- | An instance for 'Sum' which is transparent to the serialisation of @a@.
--
-- Note: If you want to serialize @Sum a@ differently than @a@, then you should
-- create another @newtype@ over 'Sum' and define your alternative serialization.
instance SerialiseValue a => SerialiseValue (Sum a) where
  serialiseValue :: Sum a -> RawBytes
serialiseValue (Sum a
v) = a -> RawBytes
forall v. SerialiseValue v => v -> RawBytes
serialiseValue a
v

  deserialiseValue :: RawBytes -> Sum a
deserialiseValue = a -> Sum a
forall a. a -> Sum a
Sum (a -> Sum a) -> (RawBytes -> a) -> RawBytes -> Sum a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBytes -> a
forall v. SerialiseValue v => RawBytes -> v
deserialiseValue

-- | Test the __Identity__ law for the 'SerialiseValue' class
serialiseValueIdentity :: (Eq v, SerialiseValue v) => v -> Bool
serialiseValueIdentity :: forall v. (Eq v, SerialiseValue v) => v -> Bool
serialiseValueIdentity v
x = RawBytes -> v
forall v. SerialiseValue v => RawBytes -> v
deserialiseValue (v -> RawBytes
forall v. SerialiseValue v => v -> RawBytes
serialiseValue v
x) v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
x

-- | Test the __Identity up to slicing__ law for the 'SerialiseValue' class
serialiseValueIdentityUpToSlicing ::
     (Eq v, SerialiseValue v)
  => RawBytes -> v -> RawBytes -> Bool
serialiseValueIdentityUpToSlicing :: forall v.
(Eq v, SerialiseValue v) =>
RawBytes -> v -> RawBytes -> Bool
serialiseValueIdentityUpToSlicing RawBytes
prefix v
x RawBytes
suffix =
    RawBytes -> v
forall v. SerialiseValue v => RawBytes -> v
deserialiseValue (RawBytes -> RawBytes -> RawBytes -> RawBytes
packSlice RawBytes
prefix (v -> RawBytes
forall v. SerialiseValue v => v -> RawBytes
serialiseValue v
x) RawBytes
suffix) v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
x

{-------------------------------------------------------------------------------
  RawBytes
-------------------------------------------------------------------------------}

-- | @'packSlice' prefix x suffix@ makes @x@ into a slice with @prefix@ bytes on
-- the left and @suffix@ bytes on the right.
packSlice :: RawBytes -> RawBytes -> RawBytes -> RawBytes
packSlice :: RawBytes -> RawBytes -> RawBytes -> RawBytes
packSlice RawBytes
prefix RawBytes
x RawBytes
suffix =
    Int -> RawBytes -> RawBytes
RB.take (RawBytes -> Int
RB.size RawBytes
x) (Int -> RawBytes -> RawBytes
RB.drop (RawBytes -> Int
RB.size RawBytes
prefix) (RawBytes
prefix RawBytes -> RawBytes -> RawBytes
forall a. Semigroup a => a -> a -> a
<> RawBytes
x RawBytes -> RawBytes -> RawBytes
forall a. Semigroup a => a -> a -> a
<> RawBytes
suffix))

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

-- | @'requireBytesExactly' tyName expected actual x@
requireBytesExactly :: String -> Int -> Int -> a -> a
requireBytesExactly :: forall a. String -> Int -> Int -> a -> a
requireBytesExactly String
tyName Int
expected Int
actual a
x
  | Int
expected Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
actual = a
x
  | Bool
otherwise          =
        String -> a
forall a. HasCallStack => String -> a
error
      (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"deserialise "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
tyName
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": expected "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Integral a => a -> ShowS
showInt Int
expected
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" bytes, but got "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Integral a => a -> ShowS
showInt Int
actual
      ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
""

{-------------------------------------------------------------------------------
  Word64
-------------------------------------------------------------------------------}

instance SerialiseKey Word64 where
  serialiseKey :: Word64 -> RawBytes
serialiseKey Word64
x = Vector Word8 -> RawBytes
RB.RawBytes (Vector Word8 -> RawBytes) -> Vector Word8 -> RawBytes
forall a b. (a -> b) -> a -> b
$ Word64 -> Vector Word8
forall a. Prim a => a -> Vector Word8
byteVectorFromPrim (Word64 -> Vector Word8) -> Word64 -> Vector Word8
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
byteSwap64 Word64
x

  deserialiseKey :: RawBytes -> Word64
deserialiseKey (RawBytes (VP.Vector Int
off Int
len ByteArray
ba)) =
    String -> Int -> Int -> Word64 -> Word64
forall a. String -> Int -> Int -> a -> a
requireBytesExactly String
"Word64" Int
8 Int
len (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
byteSwap64 (ByteArray -> Int -> Word64
indexWord8ArrayAsWord64 ByteArray
ba Int
off)

instance SerialiseValue Word64 where
  serialiseValue :: Word64 -> RawBytes
serialiseValue Word64
x = Vector Word8 -> RawBytes
RB.RawBytes (Vector Word8 -> RawBytes) -> Vector Word8 -> RawBytes
forall a b. (a -> b) -> a -> b
$ Word64 -> Vector Word8
forall a. Prim a => a -> Vector Word8
byteVectorFromPrim (Word64 -> Vector Word8) -> Word64 -> Vector Word8
forall a b. (a -> b) -> a -> b
$ Word64
x

  deserialiseValue :: RawBytes -> Word64
deserialiseValue (RawBytes (VP.Vector Int
off Int
len ByteArray
ba)) =
    String -> Int -> Int -> Word64 -> Word64
forall a. String -> Int -> Int -> a -> a
requireBytesExactly String
"Word64" Int
8 Int
len (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ ByteArray -> Int -> Word64
indexWord8ArrayAsWord64 ByteArray
ba Int
off

{-------------------------------------------------------------------------------
  ByteString
-------------------------------------------------------------------------------}

-- | Placeholder instance, not optimised
instance SerialiseKey LBS.ByteString where
  serialiseKey :: ByteString -> RawBytes
serialiseKey = ByteString -> RawBytes
forall k. SerialiseKey k => k -> RawBytes
serialiseKey (ByteString -> RawBytes)
-> (ByteString -> ByteString) -> ByteString -> RawBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict
  deserialiseKey :: RawBytes -> ByteString
deserialiseKey = Builder -> ByteString
B.toLazyByteString (Builder -> ByteString)
-> (RawBytes -> Builder) -> RawBytes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBytes -> Builder
RB.builder

-- | Placeholder instance, not optimised
instance SerialiseKey BS.ByteString where
  serialiseKey :: ByteString -> RawBytes
serialiseKey = ShortByteString -> RawBytes
RB.fromShortByteString (ShortByteString -> RawBytes)
-> (ByteString -> ShortByteString) -> ByteString -> RawBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
SBS.toShort
  deserialiseKey :: RawBytes -> ByteString
deserialiseKey = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (RawBytes -> ByteString) -> RawBytes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBytes -> ByteString
forall k. SerialiseKey k => RawBytes -> k
deserialiseKey

-- | Placeholder instance, not optimised
instance SerialiseValue LBS.ByteString where
  serialiseValue :: ByteString -> RawBytes
serialiseValue = ByteString -> RawBytes
forall v. SerialiseValue v => v -> RawBytes
serialiseValue (ByteString -> RawBytes)
-> (ByteString -> ByteString) -> ByteString -> RawBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict
  deserialiseValue :: RawBytes -> ByteString
deserialiseValue = Builder -> ByteString
B.toLazyByteString (Builder -> ByteString)
-> (RawBytes -> Builder) -> RawBytes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBytes -> Builder
RB.builder

-- | Placeholder instance, not optimised
instance SerialiseValue BS.ByteString where
  serialiseValue :: ByteString -> RawBytes
serialiseValue = ShortByteString -> RawBytes
RB.fromShortByteString (ShortByteString -> RawBytes)
-> (ByteString -> ShortByteString) -> ByteString -> RawBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
SBS.toShort
  deserialiseValue :: RawBytes -> ByteString
deserialiseValue = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (RawBytes -> ByteString) -> RawBytes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBytes -> ByteString
forall v. SerialiseValue v => RawBytes -> v
deserialiseValue

{-------------------------------------------------------------------------------
 ShortByteString
-------------------------------------------------------------------------------}

instance SerialiseKey SBS.ShortByteString where
  serialiseKey :: ShortByteString -> RawBytes
serialiseKey = ShortByteString -> RawBytes
RB.fromShortByteString
  deserialiseKey :: RawBytes -> ShortByteString
deserialiseKey = ByteArray -> ShortByteString
byteArrayToSBS (ByteArray -> ShortByteString)
-> (RawBytes -> ByteArray) -> RawBytes -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBytes -> ByteArray
RB.force

instance SerialiseValue SBS.ShortByteString where
  serialiseValue :: ShortByteString -> RawBytes
serialiseValue = ShortByteString -> RawBytes
RB.fromShortByteString
  deserialiseValue :: RawBytes -> ShortByteString
deserialiseValue = ByteArray -> ShortByteString
byteArrayToSBS (ByteArray -> ShortByteString)
-> (RawBytes -> ByteArray) -> RawBytes -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawBytes -> ByteArray
RB.force

{-------------------------------------------------------------------------------
 ByteArray
-------------------------------------------------------------------------------}

-- | The 'Ord' instance of 'ByteArray' is not lexicographic, so there cannot be
-- an order-preserving instance of 'SerialiseKey'.
-- Use 'ShortByteString' instead.
instance SerialiseValue P.ByteArray where
  serialiseValue :: ByteArray -> RawBytes
serialiseValue ByteArray
ba = Int -> Int -> ByteArray -> RawBytes
RB.fromByteArray Int
0 (ByteArray -> Int
P.sizeofByteArray ByteArray
ba) ByteArray
ba
  deserialiseValue :: RawBytes -> ByteArray
deserialiseValue = RawBytes -> ByteArray
RB.force

{-------------------------------------------------------------------------------
Void
-------------------------------------------------------------------------------}

-- | The 'deserialiseValue' of this instance throws. (as does e.g. 'Word64' instance on invalid input.)
--
-- This instance is useful for tables without blobs.
instance SerialiseValue Void where
  serialiseValue :: Void -> RawBytes
serialiseValue = Void -> RawBytes
forall a. Void -> a
absurd
  deserialiseValue :: RawBytes -> Void
deserialiseValue = String -> RawBytes -> Void
forall a. HasCallStack => String -> a
error String
"panic"