{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TahoeLAFS.Internal.ServantUtil (
CBOR,
) where
import Network.HTTP.Media (
(//),
)
import Data.ByteString (
ByteString,
)
import qualified "base64-bytestring" Data.ByteString.Base64 as Base64
import Data.Text.Encoding (
decodeLatin1,
encodeUtf8,
)
import Servant (
Accept (..),
MimeRender (..),
MimeUnrender (..),
)
import qualified Codec.Serialise as S
import Data.Aeson (
FromJSON (parseJSON),
ToJSON (toJSON),
withText,
)
import Data.Aeson.Types (
Value (String),
)
data CBOR
instance Accept CBOR where
contentType :: Proxy CBOR -> MediaType
contentType Proxy CBOR
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"cbor"
instance S.Serialise a => MimeRender CBOR a where
mimeRender :: Proxy CBOR -> a -> ByteString
mimeRender Proxy CBOR
_ = a -> ByteString
forall a. Serialise a => a -> ByteString
S.serialise
instance S.Serialise a => MimeUnrender CBOR a where
mimeUnrender :: Proxy CBOR -> ByteString -> Either String a
mimeUnrender Proxy CBOR
_ ByteString
bytes = a -> Either String a
forall a b. b -> Either a b
Right (a -> Either String a) -> a -> Either String a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall a. Serialise a => ByteString -> a
S.deserialise ByteString
bytes
instance ToJSON ByteString where
toJSON :: ByteString -> Value
toJSON = Text -> Value
String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode
instance FromJSON ByteString where
parseJSON :: Value -> Parser ByteString
parseJSON =
String -> (Text -> Parser ByteString) -> Value -> Parser ByteString
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText
String
"String"
( \Text
bs ->
case ByteString -> Either String ByteString
Base64.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
bs of
Left String
err -> String -> Parser ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Base64 decoding failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err)
Right ByteString
bytes -> ByteString -> Parser ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bytes
)