{-# 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
    -- https://tools.ietf.org/html/rfc7049#section-7.3
    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
            )