@@ -1,29 +1,29 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE InstanceSigs #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE QuantifiedConstraints #-}
10{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE TupleSections #-}
15+{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18−#define HAS_TYPE_ERROR
21module Servant.Server.Internal
20module Servant.Server.Internal
22 ( module Servant.Server.Internal
21 ( module Servant.Server.Internal
23 , module Servant.Server.Internal.BasicAuth
22 , module Servant.Server.Internal.BasicAuth
24 , module Servant.Server.Internal.Context
23 , module Servant.Server.Internal.Context
25 , module Servant.Server.Internal.Delayed
24 , module Servant.Server.Internal.Delayed
26 , module Servant.Server.Internal.DelayedIO
25 , module Servant.Server.Internal.DelayedIO
26+ , module Servant.Server.Internal.ErrorFormatter
27 , module Servant.Server.Internal.Handler
27 , module Servant.Server.Internal.Handler
28 , module Servant.Server.Internal.Router
28 , module Servant.Server.Internal.Router
29 , module Servant.Server.Internal.RouteResult
29 , module Servant.Server.Internal.RouteResult
@@ -41,12 +41,11 @@ import qualified Data.ByteString as B
41import qualified Data.ByteString.Builder as BB
41import qualified Data.ByteString.Builder as BB
42import qualified Data.ByteString.Char8 as BC8
42import qualified Data.ByteString.Char8 as BC8
43import qualified Data.ByteString.Lazy as BL
43import qualified Data.ByteString.Lazy as BL
44+import Data.Constraint (Constraint, Dict(..))
44import Data.Either
45import Data.Either
45 (partitionEithers)
46 (partitionEithers)
46import Data.Maybe
47import Data.Maybe
47 (fromMaybe, isNothing, mapMaybe, maybeToList)
48 (fromMaybe, isNothing, mapMaybe, maybeToList)
50import Data.String
49import Data.String
51 (IsString (..))
50 (IsString (..))
52import Data.String.Conversions
51import Data.String.Conversions
@@ -55,8 +54,9 @@ import Data.Tagged
55 (Tagged (..), retag, untag)
54 (Tagged (..), retag, untag)
56import qualified Data.Text as T
55import qualified Data.Text as T
57import Data.Typeable
56import Data.Typeable
58import GHC.TypeLits
58import GHC.TypeLits
59− (KnownNat, KnownSymbol, natVal, symbolVal)
59+ (KnownNat, KnownSymbol, TypeError, symbolVal)
60import qualified Network.HTTP.Media as NHM
60import qualified Network.HTTP.Media as NHM
61import Network.HTTP.Types hiding
61import Network.HTTP.Types hiding
62 (Header, ResponseHeaders)
62 (Header, ResponseHeaders)
@@ -64,45 +64,52 @@ import Network.Socket
64 (SockAddr)
64 (SockAddr)
65import Network.Wai
65import Network.Wai
66 (Application, Request, httpVersion, isSecure, lazyRequestBody,
66 (Application, Request, httpVersion, isSecure, lazyRequestBody,
67− rawQueryString, remoteHost, requestBody, requestHeaders,
67+ queryString, remoteHost, getRequestBodyChunk, requestHeaders,
68 requestMethod, responseLBS, responseStream, vault)
68 requestMethod, responseLBS, responseStream, vault)
69import Prelude ()
69import Prelude ()
70import Prelude.Compat
70import Prelude.Compat
71import Servant.API
71import Servant.API
72 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
72 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
73− CaptureAll, Description, EmptyAPI, FramingRender (..),
73+ CaptureAll, Description, EmptyAPI, Fragment,
74− FramingUnrender (..), FromSourceIO (..), Header', If,
74+ FramingRender (..), FramingUnrender (..), FromSourceIO (..),
75− IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
75+ Header', If, IsSecure (..), NoContentVerb, QueryFlag,
76− ReflectMethod (reflectMethod), RemoteHost, ReqBody',
76+ QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
77− SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
77+ RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
78− Summary, ToSourceIO (..), Vault, Verb, WithNamedContext)
78+ Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
79+ WithNamedContext, NamedRoutes)
80+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
79import Servant.API.ContentTypes
81import Servant.API.ContentTypes
80 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
81− AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH)
83+ AllMime, MimeRender (..), MimeUnrender (..), NoContent,
82import Servant.API.Modifiers
85import Servant.API.Modifiers
83 (FoldLenient, FoldRequired, RequestArgument,
86 (FoldLenient, FoldRequired, RequestArgument,
84 unfoldRequestArgument)
87 unfoldRequestArgument)
85import Servant.API.ResponseHeaders
88import Servant.API.ResponseHeaders
86 (GetHeaders, Headers, getHeaders, getResponse)
89 (GetHeaders, Headers, getHeaders, getResponse)
90+import Servant.API.Status
87import qualified Servant.Types.SourceT as S
92import qualified Servant.Types.SourceT as S
93+import Servant.API.TypeErrors
88import Web.HttpApiData
94import Web.HttpApiData
89− (FromHttpApiData, parseHeader, parseQueryParam,
95+ (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
90− parseUrlPieceMaybe, parseUrlPieces, parseUrlPiece)
96+ parseUrlPieces)
92import Servant.Server.Internal.BasicAuth
98import Servant.Server.Internal.BasicAuth
93import Servant.Server.Internal.Context
99import Servant.Server.Internal.Context
94import Servant.Server.Internal.Delayed
100import Servant.Server.Internal.Delayed
95import Servant.Server.Internal.DelayedIO
101import Servant.Server.Internal.DelayedIO
102+import Servant.Server.Internal.ErrorFormatter
96import Servant.Server.Internal.Handler
103import Servant.Server.Internal.Handler
97import Servant.Server.Internal.Router
104import Servant.Server.Internal.Router
98import Servant.Server.Internal.RouteResult
105import Servant.Server.Internal.RouteResult
99import Servant.Server.Internal.RoutingApplication
106import Servant.Server.Internal.RoutingApplication
100import Servant.Server.Internal.ServerError
107import Servant.Server.Internal.ServerError
102−#ifdef HAS_TYPE_ERROR
103import GHC.TypeLits
109import GHC.TypeLits
104 (ErrorMessage (..), TypeError)
110 (ErrorMessage (..), TypeError)
105−#endif
111+import Servant.API.TypeLevel
112+ (AtLeastOneFragment, FragmentUnique)
107class HasServer api context where
114class HasServer api context where
108 type ServerT api (m :: * -> *) :: *
115 type ServerT api (m :: * -> *) :: *
@@ -166,7 +173,10 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
166-- > server = getBook
173-- > server = getBook
167-- > where getBook :: Text -> Handler Book
174-- > where getBook :: Text -> Handler Book
168-- > getBook isbn = ...
175-- > getBook isbn = ...
176+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
169−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods))
177+ , HasServer api context, SBoolI (FoldLenient mods)
178+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
170 => HasServer (Capture' mods capture a :> api) context where
180 => HasServer (Capture' mods capture a :> api) context where
172 type ServerT (Capture' mods capture a :> api) m =
182 type ServerT (Capture' mods capture a :> api) m =
@@ -175,15 +185,19 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI
175 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
185 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
177 route Proxy context d =
187 route Proxy context d =
178− CaptureRouter $
188+ CaptureRouter [hint] $
179 route (Proxy :: Proxy api)
189 route (Proxy :: Proxy api)
191+ (addCapture d $ \ txt -> withRequest $ \ request ->
181− (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods)
192+ case ( sbool :: SBool (FoldLenient mods)
182− , parseUrlPiece txt :: Either T.Text a) of
193+ , parseUrlPiece txt :: Either T.Text a) of
183− (SFalse, Left e) -> delayedFail err400 { errBody = cs e }
194+ (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
184− (SFalse, Right v) -> return v
195+ (SFalse, Right v) -> return v
185− (STrue, piece) -> return $ (either (Left . cs) Right) piece
196+ (STrue, piece) -> return $ (either (Left . cs) Right) piece)
198+ rep = typeRep (Proxy :: Proxy Capture')
199+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
200+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
188-- | If you use 'CaptureAll' in one of the endpoints for your API,
202-- | If you use 'CaptureAll' in one of the endpoints for your API,
189-- this automatically requires your server-side handler to be a
203-- this automatically requires your server-side handler to be a
@@ -202,7 +216,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI
202-- > server = getSourceFile
216-- > server = getSourceFile
203-- > where getSourceFile :: [Text] -> Handler Book
217-- > where getSourceFile :: [Text] -> Handler Book
204-- > getSourceFile pathSegments = ...
218-- > getSourceFile pathSegments = ...
205−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
219+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
220+ , HasServer api context
221+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
206 => HasServer (CaptureAll capture a :> api) context where
223 => HasServer (CaptureAll capture a :> api) context where
208 type ServerT (CaptureAll capture a :> api) m =
225 type ServerT (CaptureAll capture a :> api) m =
@@ -211,14 +228,18 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
211 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
228 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
213 route Proxy context d =
230 route Proxy context d =
214− CaptureAllRouter $
231+ CaptureAllRouter [hint] $
215 route (Proxy :: Proxy api)
232 route (Proxy :: Proxy api)
234+ (addCapture d $ \ txts -> withRequest $ \ request ->
217− (addCapture d $ \ txts -> case parseUrlPieces txts of
235+ case parseUrlPieces txts of
218− Left _ -> delayedFail err400
236+ Left e -> delayedFail $ formatError rep request $ cs e
219− Right v -> return v
237+ Right v -> return v
240+ rep = typeRep (Proxy :: Proxy CaptureAll)
241+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
242+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
223allowedMethodHead :: Method -> Request -> Bool
244allowedMethodHead :: Method -> Request -> Bool
224allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
245allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -238,10 +259,10 @@ methodCheck method request
238-- body check is no longer an option. However, we now run the accept
259-- body check is no longer an option. However, we now run the accept
239-- check before the body check and can therefore afford to make it
260-- check before the body check and can therefore afford to make it
240-- recoverable.
261-- recoverable.
241−acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
262+acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
242acceptCheck proxy accH
263acceptCheck proxy accH
243− | canHandleAcceptH proxy (AcceptHeader accH) = return ()
264+ | canHandleAcceptH proxy accH = return ()
244− | otherwise = delayedFail err406
265+ | otherwise = delayedFail err406
246methodRouter :: (AllCTRender ctypes a)
267methodRouter :: (AllCTRender ctypes a)
247 => (b -> ([(HeaderName, B.ByteString)], a))
268 => (b -> ([(HeaderName, B.ByteString)], a))
@@ -251,17 +272,28 @@ methodRouter :: (AllCTRender ctypes a)
251methodRouter splitHeaders method proxy status action = leafRouter route'
272methodRouter splitHeaders method proxy status action = leafRouter route'
253 route' env request respond =
274 route' env request respond =
254− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
275+ let accH = getAcceptHeader request
255 in runAction (action `addMethodCheck` methodCheck method request
276 in runAction (action `addMethodCheck` methodCheck method request
256 `addAcceptCheck` acceptCheck proxy accH
277 `addAcceptCheck` acceptCheck proxy accH
257 ) env request respond $ \ output -> do
278 ) env request respond $ \ output -> do
258 let (headers, b) = splitHeaders output
279 let (headers, b) = splitHeaders output
259− case handleAcceptH proxy (AcceptHeader accH) b of
280+ case handleAcceptH proxy accH b of
260 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
281 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
261 Just (contentT, body) ->
282 Just (contentT, body) ->
262 let bdy = if allowedMethodHead method request then "" else body
283 let bdy = if allowedMethodHead method request then "" else body
263 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
284 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
286+noContentRouter :: Method
288+ -> Delayed env (Handler b)
290+noContentRouter method status action = leafRouter route'
292+ route' env request respond =
293+ runAction (action `addMethodCheck` methodCheck method request)
294+ env request respond $ \ _output ->
295+ Route $ responseLBS status [] ""
265instance {-# OVERLAPPABLE #-}
297instance {-# OVERLAPPABLE #-}
266 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
298 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
267 ) => HasServer (Verb method status ctypes a) context where
299 ) => HasServer (Verb method status ctypes a) context where
@@ -271,7 +303,7 @@ instance {-# OVERLAPPABLE #-}
272 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
304 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
273 where method = reflectMethod (Proxy :: Proxy method)
305 where method = reflectMethod (Proxy :: Proxy method)
274− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
306+ status = statusFromNat (Proxy :: Proxy status)
276instance {-# OVERLAPPING #-}
308instance {-# OVERLAPPING #-}
277 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
309 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -283,8 +315,16 @@ instance {-# OVERLAPPING #-}
284 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
316 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
285 where method = reflectMethod (Proxy :: Proxy method)
317 where method = reflectMethod (Proxy :: Proxy method)
286− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
318+ status = statusFromNat (Proxy :: Proxy status)
320+instance (ReflectMethod method) =>
321+ HasServer (NoContentVerb method) context where
323+ type ServerT (NoContentVerb method) m = m NoContent
324+ hoistServerWithContext _ _ nt s = nt s
326+ route Proxy _ = noContentRouter method status204
327+ where method = reflectMethod (Proxy :: Proxy method)
289instance {-# OVERLAPPABLE #-}
329instance {-# OVERLAPPABLE #-}
290 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
330 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
@@ -296,7 +336,7 @@ instance {-# OVERLAPPABLE #-}
297 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
337 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
298 where method = reflectMethod (Proxy :: Proxy method)
338 where method = reflectMethod (Proxy :: Proxy method)
299− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
339+ status = statusFromNat (Proxy :: Proxy status)
302instance {-# OVERLAPPING #-}
342instance {-# OVERLAPPING #-}
@@ -310,7 +350,7 @@ instance {-# OVERLAPPING #-}
311 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
351 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
312 where method = reflectMethod (Proxy :: Proxy method)
352 where method = reflectMethod (Proxy :: Proxy method)
313− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
353+ status = statusFromNat (Proxy :: Proxy status)
316streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
356streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@@ -322,7 +362,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra
322 -> Delayed env (Handler c)
362 -> Delayed env (Handler c)
323 -> Router env
363 -> Router env
324streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
364streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
325− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
365+ let AcceptHeader accH = getAcceptHeader request
326 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
366 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
327 accCheck = when (isNothing cmediatype) $ delayedFail err406
367 accCheck = when (isNothing cmediatype) $ delayedFail err406
328 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
368 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
@@ -367,6 +407,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
368 (KnownSymbol sym, FromHttpApiData a, HasServer api context
408 (KnownSymbol sym, FromHttpApiData a, HasServer api context
369 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
409 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
410+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
371 => HasServer (Header' mods sym a :> api) context where
412 => HasServer (Header' mods sym a :> api) context where
@@ -378,6 +419,9 @@ instance
378 route Proxy context subserver = route (Proxy :: Proxy api) context $
419 route Proxy context subserver = route (Proxy :: Proxy api) context $
379 subserver `addHeaderCheck` withRequest headerCheck
420 subserver `addHeaderCheck` withRequest headerCheck
422+ rep = typeRep (Proxy :: Proxy Header')
423+ formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
381 headerName :: IsString n => n
425 headerName :: IsString n => n
382 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
426 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
@@ -388,15 +432,13 @@ instance
388 mev :: Maybe (Either T.Text a)
432 mev :: Maybe (Either T.Text a)
389 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
433 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
391− errReq = delayedFailFatal err400
435+ errReq = delayedFailFatal $ formatError rep req
392− { errBody = "Header " <> headerName <> " is required"
436+ $ "Header " <> headerName <> " is required"
395− errSt e = delayedFailFatal err400
438+ errSt e = delayedFailFatal $ formatError rep req
396− { errBody = cs $ "Error parsing header "
439+ $ cs $ "Error parsing header "
397− <> headerName
440+ <> headerName
398− <> " failed: " <> e
441+ <> " failed: " <> e
401-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
443-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
402-- this automatically requires your server-side handler to be a function
444-- this automatically requires your server-side handler to be a function
@@ -422,6 +464,7 @@ instance
423 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
465 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
424 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
466 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
467+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
426 => HasServer (QueryParam' mods sym a :> api) context where
469 => HasServer (QueryParam' mods sym a :> api) context where
@@ -431,9 +474,12 @@ instance
431 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
474 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
433 route Proxy context subserver =
476 route Proxy context subserver =
434− let querytext req = parseQueryText $ rawQueryString req
477+ let querytext = queryToQueryText . queryString
435 paramname = cs $ symbolVal (Proxy :: Proxy sym)
478 paramname = cs $ symbolVal (Proxy :: Proxy sym)
480+ rep = typeRep (Proxy :: Proxy QueryParam')
481+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
437 parseParam :: Request -> DelayedIO (RequestArgument mods a)
483 parseParam :: Request -> DelayedIO (RequestArgument mods a)
438 parseParam req =
484 parseParam req =
439 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
485 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
@@ -441,14 +487,12 @@ instance
441 mev :: Maybe (Either T.Text a)
487 mev :: Maybe (Either T.Text a)
442 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
488 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
444− errReq = delayedFailFatal err400
490+ errReq = delayedFailFatal $ formatError rep req
445− { errBody = cs $ "Query parameter " <> paramname <> " is required"
491+ $ cs $ "Query parameter " <> paramname <> " is required"
448− errSt e = delayedFailFatal err400
493+ errSt e = delayedFailFatal $ formatError rep req
449− { errBody = cs $ "Error parsing query parameter "
494+ $ cs $ "Error parsing query parameter "
450− <> paramname <> " failed: " <> e
495+ <> paramname <> " failed: " <> e
453 delayed = addParameterCheck subserver . withRequest $ \req ->
497 delayed = addParameterCheck subserver . withRequest $ \req ->
454 parseParam req
498 parseParam req
@@ -474,7 +518,8 @@ instance
474-- > server = getBooksBy
518-- > server = getBooksBy
475-- > where getBooksBy :: [Text] -> Handler [Book]
519-- > where getBooksBy :: [Text] -> Handler [Book]
476-- > getBooksBy authors = ...return all books by these authors...
520-- > getBooksBy authors = ...return all books by these authors...
477−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
521+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
522+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
478 => HasServer (QueryParams sym a :> api) context where
523 => HasServer (QueryParams sym a :> api) context where
480 type ServerT (QueryParams sym a :> api) m =
525 type ServerT (QueryParams sym a :> api) m =
@@ -485,21 +530,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
485 route Proxy context subserver = route (Proxy :: Proxy api) context $
530 route Proxy context subserver = route (Proxy :: Proxy api) context $
486 subserver `addParameterCheck` withRequest paramsCheck
531 subserver `addParameterCheck` withRequest paramsCheck
533+ rep = typeRep (Proxy :: Proxy QueryParams)
534+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
488 paramname = cs $ symbolVal (Proxy :: Proxy sym)
536 paramname = cs $ symbolVal (Proxy :: Proxy sym)
489 paramsCheck req =
537 paramsCheck req =
490 case partitionEithers $ fmap parseQueryParam params of
538 case partitionEithers $ fmap parseQueryParam params of
491 ([], parsed) -> return parsed
539 ([], parsed) -> return parsed
492− (errs, _) -> delayedFailFatal err400
540+ (errs, _) -> delayedFailFatal $ formatError rep req
493− { errBody = cs $ "Error parsing query parameter(s) "
541+ $ cs $ "Error parsing query parameter(s) "
494− <> paramname <> " failed: "
542+ <> paramname <> " failed: "
495− <> T.intercalate ", " errs
543+ <> T.intercalate ", " errs
498 params :: [T.Text]
545 params :: [T.Text]
499 params = mapMaybe snd
546 params = mapMaybe snd
500 . filter (looksLikeParam . fst)
547 . filter (looksLikeParam . fst)
501− . parseQueryText
548+ . queryToQueryText
502− . rawQueryString
549+ . queryString
505 looksLikeParam name = name == paramname || name == (paramname <> "[]")
552 looksLikeParam name = name == paramname || name == (paramname <> "[]")
@@ -525,7 +572,7 @@ instance (KnownSymbol sym, HasServer api context)
525 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
572 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
527 route Proxy context subserver =
574 route Proxy context subserver =
528− let querytext r = parseQueryText $ rawQueryString r
575+ let querytext = queryToQueryText . queryString
529 param r = case lookup paramname (querytext r) of
576 param r = case lookup paramname (querytext r) of
530 Just Nothing -> True -- param is there, with no value
577 Just Nothing -> True -- param is there, with no value
531 Just (Just v) -> examine v -- param with a value
578 Just (Just v) -> examine v -- param with a value
@@ -567,7 +614,7 @@ instance HasServer Raw context where
567-- The @Content-Type@ header is inspected, and the list provided is used to
614-- The @Content-Type@ header is inspected, and the list provided is used to
568-- attempt deserialization. If the request does not have a @Content-Type@
615-- attempt deserialization. If the request does not have a @Content-Type@
569-- header, it is treated as @application/octet-stream@ (as specified in
616-- header, it is treated as @application/octet-stream@ (as specified in
570−-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
617+-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
571-- This lets servant worry about extracting it from the request and turning
618-- This lets servant worry about extracting it from the request and turning
572-- it into a value of the type you specify.
619-- it into a value of the type you specify.
@@ -583,6 +630,7 @@ instance HasServer Raw context where
583-- > where postBook :: Book -> Handler Book
630-- > where postBook :: Book -> Handler Book
584-- > postBook book = ...insert into your db...
631-- > postBook book = ...insert into your db...
585instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
632instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
633+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
586 ) => HasServer (ReqBody' mods list a :> api) context where
634 ) => HasServer (ReqBody' mods list a :> api) context where
588 type ServerT (ReqBody' mods list a :> api) m =
636 type ServerT (ReqBody' mods list a :> api) m =
@@ -594,6 +642,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
594 = route (Proxy :: Proxy api) context $
642 = route (Proxy :: Proxy api) context $
595 addBodyCheck subserver ctCheck bodyCheck
643 addBodyCheck subserver ctCheck bodyCheck
645+ rep = typeRep (Proxy :: Proxy ReqBody')
646+ formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
597 -- Content-Type check, we only lookup we can try to parse the request body
648 -- Content-Type check, we only lookup we can try to parse the request body
598 ctCheck = withRequest $ \ request -> do
649 ctCheck = withRequest $ \ request -> do
599 -- See HTTP RFC 2616, section 7.2.1
650 -- See HTTP RFC 2616, section 7.2.1
@@ -612,7 +663,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
612 case sbool :: SBool (FoldLenient mods) of
663 case sbool :: SBool (FoldLenient mods) of
613 STrue -> return mrqbody
664 STrue -> return mrqbody
614 SFalse -> case mrqbody of
665 SFalse -> case mrqbody of
615− Left e -> delayedFailFatal err400 { errBody = cs e }
666+ Left e -> delayedFailFatal $ formatError rep request e
616 Right v -> return v
667 Right v -> return v
@@ -635,7 +686,7 @@ instance
635 bodyCheck fromRS = withRequest $ \req -> do
686 bodyCheck fromRS = withRequest $ \req -> do
636 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
687 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
637 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
688 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
638− let body = requestBody req
689+ let body = getRequestBodyChunk req
639 let rs = S.fromAction B.null body
690 let rs = S.fromAction B.null body
640 let rs' = fromRS $ framingUnrender' rs
691 let rs' = fromRS $ framingUnrender' rs
641 return rs'
692 return rs'
@@ -704,12 +755,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
704emptyServer :: ServerT EmptyAPI m
755emptyServer :: ServerT EmptyAPI m
705emptyServer = Tagged EmptyServer
756emptyServer = Tagged EmptyServer
707−-- | The server for an `EmptyAPI` is `emptyAPIServer`.
758+-- | The server for an `EmptyAPI` is `emptyServer`.
709-- > type MyApi = "nothing" :> EmptyApi
760-- > type MyApi = "nothing" :> EmptyApi
711-- > server :: Server MyApi
762-- > server :: Server MyApi
712−-- > server = emptyAPIServer
763+-- > server = emptyServer
713instance HasServer EmptyAPI context where
764instance HasServer EmptyAPI context where
714 type ServerT EmptyAPI m = Tagged m EmptyServer
765 type ServerT EmptyAPI m = Tagged m EmptyServer
@@ -738,7 +789,10 @@ instance ( KnownSymbol realm
738-- * helpers
789-- * helpers
740ct_wildcard :: B.ByteString
791ct_wildcard :: B.ByteString
741−ct_wildcard = "*" <> "/" <> "*" -- Because CPP
792+ct_wildcard = "*" <> "/" <> "*"
794+getAcceptHeader :: Request -> AcceptHeader
795+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
743-- * General Authentication
797-- * General Authentication
@@ -763,39 +817,15 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
763 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
817 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
765-------------------------------------------------------------------------------
819-------------------------------------------------------------------------------
766−-- TypeError helpers
820+-- Custom type errors
767-------------------------------------------------------------------------------
821-------------------------------------------------------------------------------
769−#ifdef HAS_TYPE_ERROR
823+-- Erroring instance for 'HasServer' when a combinator is not fully applied
770−-- | This instance catches mistakes when there are non-saturated
771−-- type applications on LHS of ':>'.
773−-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
775−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
776−-- ...Maybe you haven't applied enough arguments to
777−-- ...Capture' '[] "foo"
780−-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
782−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
783−-- ...Maybe you haven't applied enough arguments to
784−-- ...Capture' '[] "foo"
787−instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
824+instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
789− type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
826+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
790− -- it doens't really matter what sub route we peak
827+ route = error "unreachable"
791− route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
792− hoistServerWithContext _ _ _ = id
828+ hoistServerWithContext _ _ _ _ = error "unreachable"
794−-- Cannot have TypeError here, otherwise use of this symbol will error :)
795−type HasServerArrowKindError arr =
796− 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
797− ':$$: 'Text "Maybe you haven't applied enough arguments to"
800-- | This instance prevents from accidentally using '->' instead of ':>'
830-- | This instance prevents from accidentally using '->' instead of ':>'
@@ -829,7 +859,103 @@ type HasServerArrowTypeError a b =
829 ':$$: 'ShowType a
859 ':$$: 'ShowType a
830 ':$$: 'Text "and"
860 ':$$: 'Text "and"
831 ':$$: 'ShowType b
861 ':$$: 'ShowType b
863+-- Erroring instances for 'HasServer' for unknown API combinators
865+-- XXX: This omits the @context@ parameter, e.g.:
867+-- "There is no instance for HasServer (Bool :> …)". Do we care ?
868+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub HasServer ty) => HasServer (ty :> sub) context
870+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
872+-- | Ignore @'Fragment'@ in server handlers.
873+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
877+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
879+-- > server :: Server MyApi
880+-- > server = getBooks
881+-- > where getBooks :: Handler [Book]
882+-- > getBooks = ...return all books...
883+instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
884+ => HasServer (Fragment a1 :> api) context where
885+ type ServerT (Fragment a1 :> api) m = ServerT api m
887+ route _ = route (Proxy :: Proxy api)
889+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
835-- >>> import Servant
892-- >>> import Servant
894+-- | A type that specifies that an API record contains a server implementation.
895+data AsServerT (m :: * -> *)
896+instance GenericMode (AsServerT m) where
897+ type AsServerT m :- api = ServerT api m
899+type AsServer = AsServerT Handler
902+-- | Set of constraints required to convert to / from vanilla server types.
903+type GServerConstraints api m =
904+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
905+ , GServantProduct (Rep (api (AsServerT m)))
908+-- | This class is a necessary evil: in the implementation of 'HasServer' for
909+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
910+-- m. 'GServerConstraints' m@ to hold.
912+-- We cannot require do that directly as the definition of 'GServerConstraints'
913+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
914+-- those type family applications behind a typeclass providing evidence for
915+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
916+-- @forall m. 'GServer' api m@ instead.
918+-- Users shouldn't have to worry about this class, as the only possible instance
919+-- is provided in this module for all record APIs.
921+class GServer (api :: * -> *) (m :: * -> *) where
922+ gServerProof :: Dict (GServerConstraints api m)
925+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
926+ , GServantProduct (Rep (api (AsServerT m)))
927+ ) => GServer api m where
931+ ( HasServer (ToServantApi api) context
932+ , forall m. Generic (api (AsServerT m))
933+ , forall m. GServer api m
934+ ) => HasServer (NamedRoutes api) context where
936+ type ServerT (NamedRoutes api) m = api (AsServerT m)
939+ :: Proxy (NamedRoutes api)
941+ -> Delayed env (api (AsServerT Handler))
943+ route _ ctx delayed =
944+ case gServerProof @api @Handler of
945+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
947+ hoistServerWithContext
948+ :: forall m n. Proxy (NamedRoutes api)
950+ -> (forall x. m x -> n x)
951+ -> api (AsServerT m)
952+ -> api (AsServerT n)
953+ hoistServerWithContext _ pctx nat server =
954+ case (gServerProof @api @m, gServerProof @api @n) of
956+ fromServant servantSrvN
958+ servantSrvM :: ServerT (ToServantApi api) m =
960+ servantSrvN :: ServerT (ToServantApi api) n =
961+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM