-- | Servant configuration for the CBOR media type
--
-- Adapted from https://hackage.haskell.org/package/servant-serialization-0.3/docs/Servant-API-ContentTypes-SerialiseCBOR.html via MIT license
module Unison.Util.Servant.CBOR
  ( CBOR,
    UnknownCBORBytes,
    CBORBytes (..),
    CBORStream (..),
    deserialiseOrFailCBORBytes,
    serialiseCBORBytes,
    decodeCBORBytes,
    decodeUnknownCBORBytes,
    serialiseUnknownCBORBytes,
  )
where

import Codec.CBOR.Read (DeserialiseFailure (..))
import Codec.Serialise (Serialise, deserialiseOrFail, serialise)
import Codec.Serialise qualified as CBOR
import Codec.Serialise.Decoding qualified as CBOR
import Data.ByteString.Lazy qualified as BL
import Data.List.NonEmpty qualified as NonEmpty
import Network.HTTP.Media.MediaType qualified as MediaType
import Servant

-- | Content-type for encoding and decoding objects as their CBOR representations
data CBOR

-- | Mime-type for CBOR and additional ones using the word "hackage" and the
-- name of the package "serialise".
instance Accept CBOR where
  contentTypes :: Proxy CBOR -> NonEmpty MediaType
contentTypes Proxy CBOR
Proxy =
    MediaType -> NonEmpty MediaType
forall a. a -> NonEmpty a
NonEmpty.singleton (ByteString
"application" ByteString -> ByteString -> MediaType
MediaType.// ByteString
"cbor")

-- |
--
-- >>> mimeRender (Proxy :: Proxy CBOR) ("Hello" :: String)
-- "eHello"
instance (Serialise a) => MimeRender CBOR a where
  mimeRender :: Proxy CBOR -> a -> ByteString
mimeRender Proxy CBOR
Proxy = a -> ByteString
forall a. Serialise a => a -> ByteString
serialise

-- |
--
-- >>> let bsl = mimeRender (Proxy :: Proxy CBOR) (3.14 :: Float)
-- >>> mimeUnrender (Proxy :: Proxy CBOR) bsl :: Either String Float
-- Right 3.14
--
-- >>> mimeUnrender (Proxy :: Proxy CBOR) (bsl <> "trailing garbage") :: Either String Float
-- Right 3.14
--
-- >>> mimeUnrender (Proxy :: Proxy CBOR) ("preceding garbage" <> bsl) :: Either String Float
-- Left "Codec.Serialise.deserialiseOrFail: expected float at byte-offset 0"
instance (Serialise a) => MimeUnrender CBOR a where
  mimeUnrender :: Proxy CBOR -> ByteString -> Either String a
mimeUnrender Proxy CBOR
Proxy = (DeserialiseFailure -> String)
-> Either DeserialiseFailure a -> Either String a
forall {a} {b} {b}. (a -> b) -> Either a b -> Either b b
mapLeft DeserialiseFailure -> String
prettyErr (Either DeserialiseFailure a -> Either String a)
-> (ByteString -> Either DeserialiseFailure a)
-> ByteString
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either DeserialiseFailure a
forall a. Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFail
    where
      mapLeft :: (a -> b) -> Either a b -> Either b b
mapLeft a -> b
f = (a -> Either b b) -> (b -> Either b b) -> Either a b -> Either b b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (b -> Either b b
forall a b. a -> Either a b
Left (b -> Either b b) -> (a -> b) -> a -> Either b b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) b -> Either b b
forall a b. b -> Either a b
Right
      prettyErr :: DeserialiseFailure -> String
prettyErr (DeserialiseFailure ByteOffset
offset String
err) =
        String
"Codec.Serialise.deserialiseOrFail: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" at byte-offset " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteOffset -> String
forall a. Show a => a -> String
show ByteOffset
offset

-- | Wrapper for CBOR data that has already been serialized.
-- In our case, we use this because we may load pre-serialized CBOR directly from the database,
-- but it's also useful in allowing us to more quickly seek through a CBOR stream, since we only need to decode the CBOR when/if we actually need to use it, and can skip past it using a byte offset otherwise.
--
-- The 't' phantom type is the type of the data encoded in the bytestring.
newtype CBORBytes t = CBORBytes BL.ByteString
  deriving ([CBORBytes t] -> Encoding
CBORBytes t -> Encoding
(CBORBytes t -> Encoding)
-> (forall s. Decoder s (CBORBytes t))
-> ([CBORBytes t] -> Encoding)
-> (forall s. Decoder s [CBORBytes t])
-> Serialise (CBORBytes t)
forall s. Decoder s [CBORBytes t]
forall s. Decoder s (CBORBytes t)
forall t. [CBORBytes t] -> Encoding
forall t. CBORBytes t -> Encoding
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
forall t s. Decoder s [CBORBytes t]
forall t s. Decoder s (CBORBytes t)
$cencode :: forall t. CBORBytes t -> Encoding
encode :: CBORBytes t -> Encoding
$cdecode :: forall t s. Decoder s (CBORBytes t)
decode :: forall s. Decoder s (CBORBytes t)
$cencodeList :: forall t. [CBORBytes t] -> Encoding
encodeList :: [CBORBytes t] -> Encoding
$cdecodeList :: forall t s. Decoder s [CBORBytes t]
decodeList :: forall s. Decoder s [CBORBytes t]
Serialise) via (BL.ByteString)
  deriving (CBORBytes t -> CBORBytes t -> Bool
(CBORBytes t -> CBORBytes t -> Bool)
-> (CBORBytes t -> CBORBytes t -> Bool) -> Eq (CBORBytes t)
forall t. CBORBytes t -> CBORBytes t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall t. CBORBytes t -> CBORBytes t -> Bool
== :: CBORBytes t -> CBORBytes t -> Bool
$c/= :: forall t. CBORBytes t -> CBORBytes t -> Bool
/= :: CBORBytes t -> CBORBytes t -> Bool
Eq, Int -> CBORBytes t -> String -> String
[CBORBytes t] -> String -> String
CBORBytes t -> String
(Int -> CBORBytes t -> String -> String)
-> (CBORBytes t -> String)
-> ([CBORBytes t] -> String -> String)
-> Show (CBORBytes t)
forall t. Int -> CBORBytes t -> String -> String
forall t. [CBORBytes t] -> String -> String
forall t. CBORBytes t -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall t. Int -> CBORBytes t -> String -> String
showsPrec :: Int -> CBORBytes t -> String -> String
$cshow :: forall t. CBORBytes t -> String
show :: CBORBytes t -> String
$cshowList :: forall t. [CBORBytes t] -> String -> String
showList :: [CBORBytes t] -> String -> String
Show, Eq (CBORBytes t)
Eq (CBORBytes t) =>
(CBORBytes t -> CBORBytes t -> Ordering)
-> (CBORBytes t -> CBORBytes t -> Bool)
-> (CBORBytes t -> CBORBytes t -> Bool)
-> (CBORBytes t -> CBORBytes t -> Bool)
-> (CBORBytes t -> CBORBytes t -> Bool)
-> (CBORBytes t -> CBORBytes t -> CBORBytes t)
-> (CBORBytes t -> CBORBytes t -> CBORBytes t)
-> Ord (CBORBytes t)
CBORBytes t -> CBORBytes t -> Bool
CBORBytes t -> CBORBytes t -> Ordering
CBORBytes t -> CBORBytes t -> CBORBytes t
forall t. Eq (CBORBytes t)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall t. CBORBytes t -> CBORBytes t -> Bool
forall t. CBORBytes t -> CBORBytes t -> Ordering
forall t. CBORBytes t -> CBORBytes t -> CBORBytes t
$ccompare :: forall t. CBORBytes t -> CBORBytes t -> Ordering
compare :: CBORBytes t -> CBORBytes t -> Ordering
$c< :: forall t. CBORBytes t -> CBORBytes t -> Bool
< :: CBORBytes t -> CBORBytes t -> Bool
$c<= :: forall t. CBORBytes t -> CBORBytes t -> Bool
<= :: CBORBytes t -> CBORBytes t -> Bool
$c> :: forall t. CBORBytes t -> CBORBytes t -> Bool
> :: CBORBytes t -> CBORBytes t -> Bool
$c>= :: forall t. CBORBytes t -> CBORBytes t -> Bool
>= :: CBORBytes t -> CBORBytes t -> Bool
$cmax :: forall t. CBORBytes t -> CBORBytes t -> CBORBytes t
max :: CBORBytes t -> CBORBytes t -> CBORBytes t
$cmin :: forall t. CBORBytes t -> CBORBytes t -> CBORBytes t
min :: CBORBytes t -> CBORBytes t -> CBORBytes t
Ord)

-- | Deserialize a 'CBORBytes' value into its tagged type, throwing an error if the deserialization fails.
deserialiseOrFailCBORBytes :: (Serialise t) => CBORBytes t -> Either CBOR.DeserialiseFailure t
deserialiseOrFailCBORBytes :: forall t. Serialise t => CBORBytes t -> Either DeserialiseFailure t
deserialiseOrFailCBORBytes (CBORBytes ByteString
bs) = ByteString -> Either DeserialiseFailure t
forall a. Serialise a => ByteString -> Either DeserialiseFailure a
CBOR.deserialiseOrFail ByteString
bs

decodeCBORBytes :: (Serialise t) => CBORBytes t -> CBOR.Decoder s t
decodeCBORBytes :: forall t s. Serialise t => CBORBytes t -> Decoder s t
decodeCBORBytes (CBORBytes ByteString
bs) = UnknownCBORBytes -> Decoder s t
forall t s. Serialise t => UnknownCBORBytes -> Decoder s t
decodeUnknownCBORBytes (ByteString -> UnknownCBORBytes
forall t. ByteString -> CBORBytes t
CBORBytes ByteString
bs)

decodeUnknownCBORBytes :: (Serialise t) => UnknownCBORBytes -> CBOR.Decoder s t
decodeUnknownCBORBytes :: forall t s. Serialise t => UnknownCBORBytes -> Decoder s t
decodeUnknownCBORBytes (CBORBytes ByteString
bs) = case CBORBytes t -> Either DeserialiseFailure t
forall t. Serialise t => CBORBytes t -> Either DeserialiseFailure t
deserialiseOrFailCBORBytes (ByteString -> CBORBytes t
forall t. ByteString -> CBORBytes t
CBORBytes ByteString
bs) of
  Left DeserialiseFailure
err -> String -> Decoder s t
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (DeserialiseFailure -> String
forall a. Show a => a -> String
show DeserialiseFailure
err)
  Right t
t -> t -> Decoder s t
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t

serialiseCBORBytes :: (Serialise t) => t -> CBORBytes t
serialiseCBORBytes :: forall t. Serialise t => t -> CBORBytes t
serialiseCBORBytes = ByteString -> CBORBytes t
forall t. ByteString -> CBORBytes t
CBORBytes (ByteString -> CBORBytes t)
-> (t -> ByteString) -> t -> CBORBytes t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ByteString
forall a. Serialise a => a -> ByteString
CBOR.serialise

serialiseUnknownCBORBytes :: (Serialise t) => t -> UnknownCBORBytes
serialiseUnknownCBORBytes :: forall t. Serialise t => t -> UnknownCBORBytes
serialiseUnknownCBORBytes = ByteString -> UnknownCBORBytes
forall t. ByteString -> CBORBytes t
CBORBytes (ByteString -> UnknownCBORBytes)
-> (t -> ByteString) -> t -> UnknownCBORBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ByteString
forall a. Serialise a => a -> ByteString
CBOR.serialise

data Unknown

type UnknownCBORBytes = CBORBytes Unknown

-- | Wrapper for a stream of CBOR data. Each chunk may not be a complete CBOR value, but the concatenation of all the chunks is a valid CBOR stream.
newtype CBORStream a = CBORStream BL.ByteString
  deriving ([CBORStream a] -> Encoding
CBORStream a -> Encoding
(CBORStream a -> Encoding)
-> (forall s. Decoder s (CBORStream a))
-> ([CBORStream a] -> Encoding)
-> (forall s. Decoder s [CBORStream a])
-> Serialise (CBORStream a)
forall s. Decoder s [CBORStream a]
forall s. Decoder s (CBORStream a)
forall a. [CBORStream a] -> Encoding
forall a. CBORStream a -> Encoding
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
forall a s. Decoder s [CBORStream a]
forall a s. Decoder s (CBORStream a)
$cencode :: forall a. CBORStream a -> Encoding
encode :: CBORStream a -> Encoding
$cdecode :: forall a s. Decoder s (CBORStream a)
decode :: forall s. Decoder s (CBORStream a)
$cencodeList :: forall a. [CBORStream a] -> Encoding
encodeList :: [CBORStream a] -> Encoding
$cdecodeList :: forall a s. Decoder s [CBORStream a]
decodeList :: forall s. Decoder s [CBORStream a]
Serialise) via (BL.ByteString)
  deriving (CBORStream a -> CBORStream a -> Bool
(CBORStream a -> CBORStream a -> Bool)
-> (CBORStream a -> CBORStream a -> Bool) -> Eq (CBORStream a)
forall a. CBORStream a -> CBORStream a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. CBORStream a -> CBORStream a -> Bool
== :: CBORStream a -> CBORStream a -> Bool
$c/= :: forall a. CBORStream a -> CBORStream a -> Bool
/= :: CBORStream a -> CBORStream a -> Bool
Eq, Int -> CBORStream a -> String -> String
[CBORStream a] -> String -> String
CBORStream a -> String
(Int -> CBORStream a -> String -> String)
-> (CBORStream a -> String)
-> ([CBORStream a] -> String -> String)
-> Show (CBORStream a)
forall a. Int -> CBORStream a -> String -> String
forall a. [CBORStream a] -> String -> String
forall a. CBORStream a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Int -> CBORStream a -> String -> String
showsPrec :: Int -> CBORStream a -> String -> String
$cshow :: forall a. CBORStream a -> String
show :: CBORStream a -> String
$cshowList :: forall a. [CBORStream a] -> String -> String
showList :: [CBORStream a] -> String -> String
Show, Eq (CBORStream a)
Eq (CBORStream a) =>
(CBORStream a -> CBORStream a -> Ordering)
-> (CBORStream a -> CBORStream a -> Bool)
-> (CBORStream a -> CBORStream a -> Bool)
-> (CBORStream a -> CBORStream a -> Bool)
-> (CBORStream a -> CBORStream a -> Bool)
-> (CBORStream a -> CBORStream a -> CBORStream a)
-> (CBORStream a -> CBORStream a -> CBORStream a)
-> Ord (CBORStream a)
CBORStream a -> CBORStream a -> Bool
CBORStream a -> CBORStream a -> Ordering
CBORStream a -> CBORStream a -> CBORStream a
forall a. Eq (CBORStream a)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. CBORStream a -> CBORStream a -> Bool
forall a. CBORStream a -> CBORStream a -> Ordering
forall a. CBORStream a -> CBORStream a -> CBORStream a
$ccompare :: forall a. CBORStream a -> CBORStream a -> Ordering
compare :: CBORStream a -> CBORStream a -> Ordering
$c< :: forall a. CBORStream a -> CBORStream a -> Bool
< :: CBORStream a -> CBORStream a -> Bool
$c<= :: forall a. CBORStream a -> CBORStream a -> Bool
<= :: CBORStream a -> CBORStream a -> Bool
$c> :: forall a. CBORStream a -> CBORStream a -> Bool
> :: CBORStream a -> CBORStream a -> Bool
$c>= :: forall a. CBORStream a -> CBORStream a -> Bool
>= :: CBORStream a -> CBORStream a -> Bool
$cmax :: forall a. CBORStream a -> CBORStream a -> CBORStream a
max :: CBORStream a -> CBORStream a -> CBORStream a
$cmin :: forall a. CBORStream a -> CBORStream a -> CBORStream a
min :: CBORStream a -> CBORStream a -> CBORStream a
Ord)

instance MimeRender OctetStream (CBORStream a) where
  mimeRender :: Proxy OctetStream -> CBORStream a -> ByteString
mimeRender Proxy OctetStream
Proxy (CBORStream ByteString
bs) = ByteString
bs

instance MimeUnrender OctetStream (CBORStream a) where
  mimeUnrender :: Proxy OctetStream -> ByteString -> Either String (CBORStream a)
mimeUnrender Proxy OctetStream
Proxy ByteString
bs = CBORStream a -> Either String (CBORStream a)
forall a b. b -> Either a b
Right (ByteString -> CBORStream a
forall a. ByteString -> CBORStream a
CBORStream ByteString
bs)