{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Provides instances from server-related types to jordan API combinators.
--
-- Sadly, this does mean that this module has a bunch of orphan instances.
-- Please, *please* use these instead of any others.
-- Please.
module Jordan.Servant.Server where
import Control.Monad.IO.Class
import Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import Data.List.NonEmpty (toList)
import Data.Maybe (fromMaybe)
import Data.Proxy
import qualified Data.Text as T
import GHC.TypeLits
import Jordan
import Jordan.Servant
import Jordan.Servant.Query
import Jordan.Servant.Query.Parse
import Jordan.Types.JSONError
import Network.HTTP.Media (matchContent)
import Network.HTTP.Types.Header (hContentType)
import Network.Wai (Request (..), lazyRequestBody, queryString)
import Servant.API
import Servant.API.Modifiers
import Servant.Server
import Servant.Server.Internal
import Servant.Server.Internal.ServerError
import Servant.Server.UVerb
-- | Parse a request body.
-- On parse errors where a valid but wrong-for-the-type JSON is given, we return back an error report.
instance forall a rest context. (HasServer rest context, FromJSON a) => HasServer (ReportingRequestBody a :> rest) context where
type ServerT (ReportingRequestBody a :> rest) m = a -> ServerT rest m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy rest) pc nt . s
route (Proxy :: Proxy (ReportingRequestBody a :> rest)) context subserver =
route (Proxy :: Proxy rest) context $ addBodyCheck subserver checkContent checkBody
where
checkContent = withRequest $ \request -> do
let contentType = fromMaybe "application/octect-stream" $ lookup hContentType $ requestHeaders request
case matchContent (toList $ contentTypes (Proxy :: Proxy JordanJSON)) contentType of
Nothing -> delayedFail err415
Just _ -> pure (parseOrReport @a)
checkBody parser = withRequest $ \request -> do
body <- liftIO $ lazyRequestBody request
case parser (LBS.toStrict body) of
Left je ->
delayedFailFatal $
ServerError
{ errHTTPCode = 400,
errReasonPhrase = "Bad Request",
errBody = toJSONViaBuilder je,
errHeaders = [("Content-Type", "application/json+haskell-servant-body-error")]
}
Right a -> pure a
-- | If the query was required, no maybe.
-- Otherwise, wrap the query in a maybe.
type QueryArgument mods a = If (FoldRequired mods) a (Maybe a)
instance
forall a rest context baseKey mods.
( HasServer rest context,
FromJSON a,
KnownSymbol baseKey,
SBoolI (FoldRequired mods)
) =>
HasServer (JordanQuery' baseKey mods a :> rest) context
where
type ServerT (JordanQuery' baseKey mods a :> rest) m = QueryArgument mods a -> ServerT rest m
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy rest) pc nt . s
route (Proxy :: Proxy (JordanQuery' baseKey mods a :> rest)) context subserver =
route (Proxy :: Proxy rest) context $ subserver `addParameterCheck` withRequest paramsCheck
where
keyName = T.pack $ symbolVal (Proxy :: Proxy baseKey)
parseQ :: Request -> Either String a
parseQ = parseQueryAtKey keyName . queryString
hasQuery = hasQueryAtKey keyName . queryString
failWithError s =
delayedFailFatal $
err400
{ errBody = toJSONViaBuilder s,
errHeaders = [("Content-Type", "application/json+haskell-jordan-query-error")]
}
paramsCheck req =
let parsed = parseQ req
hasKeys = hasQuery req
in case sbool @(FoldRequired mods) of
STrue -> either failWithError pure parsed
SFalse
| not hasKeys -> pure Nothing
| otherwise -> either failWithError (pure . Just) parsed