This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE MultiParamTypeClasses #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE UndecidableInstances #-} | |
{-# LANGUAGE ViewPatterns #-} | |
module Body where | |
import ClassyPrelude | |
import Control.Monad.Trans (liftIO) | |
import qualified Data.ByteString.Lazy as BL | |
import Data.Proxy (Proxy (..)) | |
import Data.String.Conversions (cs) | |
import Network.HTTP.Types.Header | |
import Network.Wai (lazyRequestBody, requestHeaders) | |
import Servant.API.ContentTypes | |
import Servant.API.Modifiers | |
import Data.Aeson | |
import Servant.API | |
import Servant.Server | |
import Servant.Server.Internal | |
type Body = Body' '[Required, Strict] | |
data Body' (mods :: [*]) (contentTypes :: [*]) (a :: *) | |
deriving (Typeable) | |
instance ( FromJSON a, AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods) | |
) => HasServer (Body' mods list a :> api) context where | |
type ServerT (Body' mods list a :> api) m = | |
If (FoldLenient mods) (Either String a) a -> ServerT api m | |
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s | |
route Proxy context subserver = | |
route (Proxy :: Proxy api) context (addBodyCheck subserver ctCheck bodyCheck) | |
where | |
ctCheck = withRequest $ \ request -> do | |
let contentTypeH = fromMaybe "application/octet-stream" | |
$ lookup hContentType $ requestHeaders request | |
case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of | |
Nothing -> delayedFail err415 | |
Just f -> return f | |
bodyCheck f = withRequest $ \ request -> do | |
mrqbody <- f <$> liftIO (lazyRequestBody request) | |
case sbool :: SBool (FoldLenient mods) of | |
STrue -> return mrqbody | |
SFalse -> case mrqbody of | |
Left (BodyError -> e) -> delayedFailFatal err400 { errBody = encode e } | |
Right v -> return v | |
newtype BodyError = BodyError String | |
instance ToJSON BodyError where | |
toJSON (BodyError b) = object ["error" .= b] |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment