-- | Errors in servant.
module Servant.Util.Error
    ( SimpleJSON
    ) where

import Universum

import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode)
import Data.Reflection (Reifies (..), reflect)
import Servant (JSON)
import Servant.API.ContentTypes (Accept (..), MimeRender (..), MimeUnrender (..))

-- | Custom json marker which sends no human-unreadable decoding errors
-- but a given fixed one.
data SimpleJSON err

instance Accept (SimpleJSON err) where
    contentTypes :: Proxy (SimpleJSON err) -> NonEmpty MediaType
contentTypes Proxy (SimpleJSON err)
_ = Proxy JSON -> NonEmpty MediaType
forall k (ctype :: k).
Accept ctype =>
Proxy ctype -> NonEmpty MediaType
contentTypes (Proxy JSON
forall k (t :: k). Proxy t
Proxy @JSON)
instance ToJSON a => MimeRender (SimpleJSON err) a where
    mimeRender :: Proxy (SimpleJSON err) -> a -> ByteString
mimeRender Proxy (SimpleJSON err)
_ = a -> ByteString
forall a. ToJSON a => a -> ByteString
encode
instance (FromJSON a, Reifies err String) => MimeUnrender (SimpleJSON err) a where
    mimeUnrender :: Proxy (SimpleJSON err) -> ByteString -> Either String a
mimeUnrender Proxy (SimpleJSON err)
_ =
        let errMsg :: String
errMsg = Proxy err -> String
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect (Proxy err
forall k (t :: k). Proxy t
Proxy @err)
        in (String -> String) -> Either String a -> Either String a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\String
_ -> String
errMsg) (Either String a -> Either String a)
-> (ByteString -> Either String a) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode