{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Versioning.Servant
( VersionedJSON
, VersionedJSONFrom
)
where
import Data.Aeson (FromJSON, ToJSON, encode,
parseJSON)
import Data.Aeson.Parser (value)
import Data.Aeson.Types (parseEither)
import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,
skipSpace, (<?>))
import qualified Data.ByteString.Lazy as LazyBS
import Data.Kind (Type)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Typeable (Typeable)
import qualified Network.HTTP.Media as Media
import Servant.API (Accept (..), MimeRender (..),
MimeUnrender (..))
import Versioning.Base
import Versioning.Internal.Decoding
import Versioning.JSON
type VersionedJSON = VersionedJSONFrom V0
data VersionedJSONFrom (v :: V) deriving Typeable
instance Accept (VersionedJSONFrom from) where
contentTypes _ =
"application" Media.// "json" Media./: ("charset", "utf-8") NonEmpty.:|
[ "application" Media.// "json" ]
instance {-# OVERLAPPABLE #-} (JsonDecodableToFrom from v a, ToJSON (a v))
=> MimeRender (VersionedJSONFrom from) (a v) where
mimeRender _ = encode
instance JsonDecodableToFrom from v a => MimeUnrender (VersionedJSONFrom from) (a v) where
mimeUnrender _ = fromJsonAnyVersionLenientFrom @from
fromJsonAnyVersionLenientFrom
:: forall from v a
. JsonDecodableToFrom from v a
=> LazyBS.ByteString
-> Either String (a v)
fromJsonAnyVersionLenientFrom = decodeAnyVersionFrom @from jsonDecodeLenient
jsonDecodeLenient
:: Decoder FromJSON LazyBS.ByteString (Either String) (a :: V -> Type)
jsonDecodeLenient = Decoder eitherDecodeLenient
eitherDecodeLenient :: FromJSON a => LazyBS.ByteString -> Either String a
eitherDecodeLenient input = parseOnly parser (LazyBS.toStrict input)
>>= parseEither parseJSON
where
parser =
skipSpace
*> value
<* skipSpace
<* (endOfInput <?> "trailing junk after valid JSON")