Body.hs

{-# 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]