@@ -12,6 +12,7 @@
1212{-# LANGUAGE TupleSections #-}
1313{-# LANGUAGE TypeFamilies #-}
1414{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
1516
1617#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
1718#define HAS_TYPE_ERROR
@@ -33,7 +34,7 @@ module Servant.Server.Internal
3334 , module Servant.Server.Internal.ServantErr
3435 ) where
3536
36−import Control.Monad (when)
37+import Control.Monad (join, when)
3738import Control.Monad.Trans (liftIO)
3839import Control.Monad.Trans.Resource (runResourceT)
3940import qualified Data.ByteString as B
@@ -43,7 +44,7 @@ import qualified Data.ByteString.Lazy as BL
4344import Data.Maybe (fromMaybe, mapMaybe,
4445 isNothing, maybeToList)
4546import Data.Either (partitionEithers)
46−import Data.String (fromString)
47+import Data.String (IsString (..))
4748import Data.String.Conversions (cs, (<>))
4849import Data.Tagged (Tagged(..), retag, untag)
4950import qualified Data.Text as T
@@ -69,15 +70,17 @@ import Web.HttpApiData (FromHttpApiData, parseHeader,
6970import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
7071 CaptureAll, Verb, EmptyAPI,
7172 ReflectMethod(reflectMethod),
72− IsSecure(..), Header, QueryFlag,
73− QueryParam, QueryParams, Raw,
74− RemoteHost, ReqBody, Vault,
73+ IsSecure(..), Header', QueryFlag,
74+ QueryParam', QueryParams, Raw,
75+ RemoteHost, ReqBody', Vault,
7576 WithNamedContext,
7677 Description, Summary,
7778 Accept(..),
7879 FramingRender(..), Stream,
7980 StreamGenerator(..), ToStreamGenerator(..),
80− BoundaryStrategy(..))
81+ BoundaryStrategy(..),
82+ If, SBool (..), SBoolI (..))
83+import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient)
8184import Servant.API.ContentTypes (AcceptHeader (..),
8285 AllCTRender (..),
8386 AllCTUnrender (..),
@@ -361,29 +364,39 @@ streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \
361364-- > server = viewReferer
362365-- > where viewReferer :: Referer -> Handler referer
363366-- > viewReferer referer = return referer
364−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
365− => HasServer (Header sym a :> api) context where
366−
367− type ServerT (Header sym a :> api) m =
368− Maybe a -> ServerT api m
367+instance
368+ (KnownSymbol sym, FromHttpApiData a, HasServer api context
369+ , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
370+ )
371+ => HasServer (Header' mods sym a :> api) context where
372+------
373+ type ServerT (Header' mods sym a :> api) m =
374+ RequestArgument mods a -> ServerT api m
369375
370376 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
371377
372378 route Proxy context subserver = route (Proxy :: Proxy api) context $
373379 subserver `addHeaderCheck` withRequest headerCheck
374380 where
375− headerName = symbolVal (Proxy :: Proxy sym)
381+ headerName :: IsString n => n
382+ headerName = fromString $ symbolVal (Proxy :: Proxy sym)
383+
384+ headerCheck :: Request -> DelayedIO (RequestArgument mods a)
376385 headerCheck req =
377− case lookup (fromString headerName) (requestHeaders req) of
378− Nothing -> return Nothing
379− Just txt ->
380− case parseHeader txt of
381− Left e -> delayedFailFatal err400
382− { errBody = cs $ "Error parsing header "
383− <> fromString headerName
384− <> " failed: " <> e
385− }
386− Right hdr -> return $ Just hdr
386+ unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
387+ where
388+ mev :: Maybe (Either T.Text a)
389+ mev = fmap parseHeader $ lookup headerName (requestHeaders req)
390+
391+ errReq = delayedFailFatal err400
392+ { errBody = "Header " <> headerName <> " is required"
393+ }
394+
395+ errSt e = delayedFailFatal err400
396+ { errBody = cs $ "Error parsing header "
397+ <> headerName
398+ <> " failed: " <> e
399+ }
387400
388401-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
389402-- this automatically requires your server-side handler to be a function
@@ -406,33 +419,41 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
406419-- > where getBooksBy :: Maybe Text -> Handler [Book]
407420-- > getBooksBy Nothing = ...return all books...
408421-- > getBooksBy (Just author) = ...return books by the given author...
409−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
410− => HasServer (QueryParam sym a :> api) context where
411−
412− type ServerT (QueryParam sym a :> api) m =
413− Maybe a -> ServerT api m
422+instance
423+ ( KnownSymbol sym, FromHttpApiData a, HasServer api context
424+ , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
425+ )
426+ => HasServer (QueryParam' mods sym a :> api) context where
427+------
428+ type ServerT (QueryParam' mods sym a :> api) m =
429+ RequestArgument mods a -> ServerT api m
414430
415431 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
416432
417433 route Proxy context subserver =
418434 let querytext req = parseQueryText $ rawQueryString req
435+ paramname = cs $ symbolVal (Proxy :: Proxy sym)
436+
437+ parseParam :: Request -> DelayedIO (RequestArgument mods a)
419438 parseParam req =
420− case lookup paramname (querytext req) of
421− Nothing -> return Nothing -- param absent from the query string
422− Just Nothing -> return Nothing -- param present with no value -> Nothing
423− Just (Just v) ->
424− case parseQueryParam v of
425− Left e -> delayedFailFatal err400
426− { errBody = cs $ "Error parsing query parameter "
427− <> paramname <> " failed: " <> e
428− }
429−
430− Right param -> return $ Just param
439+ unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
440+ where
441+ mev :: Maybe (Either T.Text a)
442+ mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
443+
444+ errReq = delayedFailFatal err400
445+ { errBody = cs $ "Query parameter " <> paramname <> " is required"
446+ }
447+
448+ errSt e = delayedFailFatal err400
449+ { errBody = cs $ "Error parsing query parameter "
450+ <> paramname <> " failed: " <> e
451+ }
452+
431453 delayed = addParameterCheck subserver . withRequest $ \req ->
432454 parseParam req
433455
434456 in route (Proxy :: Proxy api) context delayed
435− where paramname = cs $ symbolVal (Proxy :: Proxy sym)
436457
437458-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
438459-- this automatically requires your server-side handler to be a function
@@ -561,11 +582,11 @@ instance HasServer Raw context where
561582-- > server = postBook
562583-- > where postBook :: Book -> Handler Book
563584-- > postBook book = ...insert into your db...
564−instance ( AllCTUnrender list a, HasServer api context
565− ) => HasServer (ReqBody list a :> api) context where
585+instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
586+ ) => HasServer (ReqBody' mods list a :> api) context where
566587
567− type ServerT (ReqBody list a :> api) m =
568− a -> ServerT api m
588+ type ServerT (ReqBody' mods list a :> api) m =
589+ If (FoldLenient mods) (Either String a) a -> ServerT api m
569590
570591 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
571592
@@ -588,9 +609,11 @@ instance ( AllCTUnrender list a, HasServer api context
588609 -- Body check, we get a body parsing functions as the first argument.
589610 bodyCheck f = withRequest $ \ request -> do
590611 mrqbody <- f <$> liftIO (lazyRequestBody request)
591− case mrqbody of
592− Left e -> delayedFailFatal err400 { errBody = cs e }
593− Right v -> return v
612+ case sbool :: SBool (FoldLenient mods) of
613+ STrue -> return mrqbody
614+ SFalse -> case mrqbody of
615+ Left e -> delayedFailFatal err400 { errBody = cs e }
616+ Right v -> return v
594617
595618-- | Make sure the incoming request starts with @"/path"@, strip it and
596619-- pass the rest of the request path to @api@.