@@ -1,49 +1,54 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DataKinds #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE InstanceSigs #-}
9+{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE PolyKinds #-}
13+{-# LANGUAGE QuantifiedConstraints #-}
10{-# LANGUAGE RankNTypes #-}
14{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TupleSections #-}
17+{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE UndecidableInstances #-}
20{-# LANGUAGE UndecidableInstances #-}
17−#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18−#define HAS_TYPE_ERROR
21module Servant.Server.Internal
22module Servant.Server.Internal
22 ( module Servant.Server.Internal
23 ( module Servant.Server.Internal
23 , module Servant.Server.Internal.BasicAuth
24 , module Servant.Server.Internal.BasicAuth
24 , module Servant.Server.Internal.Context
25 , module Servant.Server.Internal.Context
26+ , module Servant.Server.Internal.Delayed
27+ , module Servant.Server.Internal.DelayedIO
28+ , module Servant.Server.Internal.ErrorFormatter
25 , module Servant.Server.Internal.Handler
29 , module Servant.Server.Internal.Handler
26 , module Servant.Server.Internal.Router
30 , module Servant.Server.Internal.Router
31+ , module Servant.Server.Internal.RouteResult
27 , module Servant.Server.Internal.RoutingApplication
32 , module Servant.Server.Internal.RoutingApplication
28− , module Servant.Server.Internal.ServantErr
33+ , module Servant.Server.Internal.ServerError
31import Control.Monad
36import Control.Monad
32 (join, when)
37 (join, when)
33import Control.Monad.Trans
38import Control.Monad.Trans
34− (liftIO)
39+ (liftIO, lift)
35import Control.Monad.Trans.Resource
40import Control.Monad.Trans.Resource
36− (runResourceT)
41+ (runResourceT, ReleaseKey)
37import qualified Data.ByteString as B
43import qualified Data.ByteString as B
38import qualified Data.ByteString.Builder as BB
44import qualified Data.ByteString.Builder as BB
39import qualified Data.ByteString.Char8 as BC8
45import qualified Data.ByteString.Char8 as BC8
40import qualified Data.ByteString.Lazy as BL
46import qualified Data.ByteString.Lazy as BL
47+import Data.Constraint (Constraint, Dict(..))
41import Data.Either
48import Data.Either
42 (partitionEithers)
49 (partitionEithers)
43import Data.Maybe
50import Data.Maybe
44 (fromMaybe, isNothing, mapMaybe, maybeToList)
51 (fromMaybe, isNothing, mapMaybe, maybeToList)
47import Data.String
52import Data.String
48 (IsString (..))
53 (IsString (..))
49import Data.String.Conversions
54import Data.String.Conversions
@@ -52,53 +57,70 @@ import Data.Tagged
52 (Tagged (..), retag, untag)
57 (Tagged (..), retag, untag)
53import qualified Data.Text as T
58import qualified Data.Text as T
54import Data.Typeable
59import Data.Typeable
55import GHC.TypeLits
61import GHC.TypeLits
56− (KnownNat, KnownSymbol, natVal, symbolVal)
62+ (KnownNat, KnownSymbol, TypeError, symbolVal)
57import qualified Network.HTTP.Media as NHM
63import qualified Network.HTTP.Media as NHM
58import Network.HTTP.Types hiding
64import Network.HTTP.Types hiding
59 (Header, ResponseHeaders)
65 (Header, ResponseHeaders)
60import Network.Socket
66import Network.Socket
61 (SockAddr)
67 (SockAddr)
62import Network.Wai
68import Network.Wai
63− (Application, Request, httpVersion, isSecure, lazyRequestBody,
69+ (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
64− rawQueryString, remoteHost, requestBody, requestHeaders,
70+ queryString, remoteHost, getRequestBodyChunk, requestHeaders,
65 requestMethod, responseLBS, responseStream, vault)
71 requestMethod, responseLBS, responseStream, vault)
66import Prelude ()
72import Prelude ()
67import Prelude.Compat
73import Prelude.Compat
68import Servant.API
74import Servant.API
69 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
75 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
70− CaptureAll, Description, EmptyAPI, FramingRender (..),
76+ CaptureAll, Description, EmptyAPI, Fragment,
71− FramingUnrender (..), FromSourceIO (..), Header', If,
77+ FramingRender (..), FramingUnrender (..), FromSourceIO (..),
72− IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
78+ Header', If, IsSecure (..), NoContentVerb, QueryFlag,
73− ReflectMethod (reflectMethod), RemoteHost, ReqBody',
79+ QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
74− SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
80+ RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
75− Summary, ToSourceIO (..), Vault, Verb, WithNamedContext)
81+ Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
82+ WithNamedContext, WithResource, NamedRoutes)
83+import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
76import Servant.API.ContentTypes
84import Servant.API.ContentTypes
77 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
85 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
78− AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH)
86+ AllMime, MimeRender (..), MimeUnrender (..), NoContent,
79import Servant.API.Modifiers
88import Servant.API.Modifiers
80 (FoldLenient, FoldRequired, RequestArgument,
89 (FoldLenient, FoldRequired, RequestArgument,
81 unfoldRequestArgument)
90 unfoldRequestArgument)
82import Servant.API.ResponseHeaders
91import Servant.API.ResponseHeaders
83 (GetHeaders, Headers, getHeaders, getResponse)
92 (GetHeaders, Headers, getHeaders, getResponse)
93+import Servant.API.Status
84import qualified Servant.Types.SourceT as S
95import qualified Servant.Types.SourceT as S
96+import Servant.API.TypeErrors
85import Web.HttpApiData
97import Web.HttpApiData
86− (FromHttpApiData, parseHeader, parseQueryParam,
98+ (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
87− parseUrlPieceMaybe, parseUrlPieces)
99+ parseUrlPieces)
89import Servant.Server.Internal.BasicAuth
103import Servant.Server.Internal.BasicAuth
90import Servant.Server.Internal.Context
104import Servant.Server.Internal.Context
105+import Servant.Server.Internal.Delayed
106+import Servant.Server.Internal.DelayedIO
107+import Servant.Server.Internal.ErrorFormatter
91import Servant.Server.Internal.Handler
108import Servant.Server.Internal.Handler
92import Servant.Server.Internal.Router
109import Servant.Server.Internal.Router
110+import Servant.Server.Internal.RouteResult
93import Servant.Server.Internal.RoutingApplication
111import Servant.Server.Internal.RoutingApplication
94−import Servant.Server.Internal.ServantErr
112+import Servant.Server.Internal.ServerError
97import GHC.TypeLits
114import GHC.TypeLits
98 (ErrorMessage (..), TypeError)
115 (ErrorMessage (..), TypeError)
99−#endif
116+import Servant.API.TypeLevel
117+ (AtLeastOneFragment, FragmentUnique)
101class HasServer api context where
119class HasServer api context where
120+ -- | The type of a server for this API, given a monad to run effects in.
122+ -- Note that the result kind is @*@, so it is /not/ a monad transformer, unlike
123+ -- what the @T@ in the name might suggest.
102 type ServerT api (m :: * -> *) :: *
124 type ServerT api (m :: * -> *) :: *
@@ -160,22 +182,31 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
160-- > server = getBook
182-- > server = getBook
161-- > where getBook :: Text -> Handler Book
183-- > where getBook :: Text -> Handler Book
162-- > getBook isbn = ...
184-- > getBook isbn = ...
163−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
185+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
186+ , HasServer api context, SBoolI (FoldLenient mods)
187+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
164 => HasServer (Capture' mods capture a :> api) context where
189 => HasServer (Capture' mods capture a :> api) context where
166 type ServerT (Capture' mods capture a :> api) m =
191 type ServerT (Capture' mods capture a :> api) m =
167− a -> ServerT api m
192+ If (FoldLenient mods) (Either String a) a -> ServerT api m
169 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
194 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
171 route Proxy context d =
196 route Proxy context d =
172− CaptureRouter $
197+ CaptureRouter [hint] $
173 route (Proxy :: Proxy api)
198 route (Proxy :: Proxy api)
175− (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
200+ (addCapture d $ \ txt -> withRequest $ \ request ->
176− Nothing -> delayedFail err400
201+ case ( sbool :: SBool (FoldLenient mods)
202+ , parseUrlPiece txt :: Either T.Text a) of
203+ (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
177− Just v -> return v
204+ (SFalse, Right v) -> return v
178− )
205+ (STrue, piece) -> return $ (either (Left . cs) Right) piece)
207+ rep = typeRep (Proxy :: Proxy Capture')
208+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
209+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
180-- | If you use 'CaptureAll' in one of the endpoints for your API,
211-- | If you use 'CaptureAll' in one of the endpoints for your API,
181-- this automatically requires your server-side handler to be a
212-- this automatically requires your server-side handler to be a
@@ -194,7 +225,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
194-- > server = getSourceFile
225-- > server = getSourceFile
195-- > where getSourceFile :: [Text] -> Handler Book
226-- > where getSourceFile :: [Text] -> Handler Book
196-- > getSourceFile pathSegments = ...
227-- > getSourceFile pathSegments = ...
197−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
228+instance (KnownSymbol capture, FromHttpApiData a, Typeable a
229+ , HasServer api context
230+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
198 => HasServer (CaptureAll capture a :> api) context where
232 => HasServer (CaptureAll capture a :> api) context where
200 type ServerT (CaptureAll capture a :> api) m =
234 type ServerT (CaptureAll capture a :> api) m =
@@ -203,13 +237,53 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
203 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
237 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
205 route Proxy context d =
239 route Proxy context d =
206− CaptureAllRouter $
240+ CaptureAllRouter [hint] $
207 route (Proxy :: Proxy api)
241 route (Proxy :: Proxy api)
243+ (addCapture d $ \ txts -> withRequest $ \ request ->
209− (addCapture d $ \ txts -> case parseUrlPieces txts of
244+ case parseUrlPieces txts of
210− Left _ -> delayedFail err400
245+ Left e -> delayedFail $ formatError rep request $ cs e
211− Right v -> return v
246+ Right v -> return v
249+ rep = typeRep (Proxy :: Proxy CaptureAll)
250+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
251+ hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy [a]))
253+-- | If you use 'WithResource' in one of the endpoints for your API Servant
254+-- will provide the handler for this endpoint an argument of the specified type.
255+-- The lifespan of this resource will be automatically managed by Servant. This
256+-- resource will be created before the handler starts and it will be destoyed
257+-- after it ends. A new resource is created for each request to the endpoint.
259+-- The creation and destruction are done using a 'Data.Acquire.Acquire'
260+-- provided via server 'Context'.
264+-- > type MyApi = WithResource Handle :> "writeToFile" :> Post '[JSON] NoContent
266+-- > server :: Server MyApi
267+-- > server = writeToFile
268+-- > where writeToFile :: (ReleaseKey, Handle) -> Handler NoContent
269+-- > writeToFile (_, h) = hPutStrLn h "message"
271+-- In addition to the resource, the handler will also receive a 'ReleaseKey'
272+-- which can be used to deallocate the resource before the end of the request
275+instance (HasServer api ctx, HasContextEntry ctx (Acquire a))
276+ => HasServer (WithResource a :> api) ctx where
278+ type ServerT (WithResource a :> api) m = (ReleaseKey, a) -> ServerT api m
280+ hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy @api) pc nt . s
282+ route Proxy context d = route (Proxy @api) context (d `addParameterCheck` allocateResource)
284+ allocateResource :: DelayedIO (ReleaseKey, a)
285+ allocateResource = DelayedIO $ lift $ allocateAcquire (getContextEntry context)
215allowedMethodHead :: Method -> Request -> Bool
289allowedMethodHead :: Method -> Request -> Bool
@@ -230,10 +304,10 @@ methodCheck method request
230-- body check is no longer an option. However, we now run the accept
304-- body check is no longer an option. However, we now run the accept
231-- check before the body check and can therefore afford to make it
305-- check before the body check and can therefore afford to make it
232-- recoverable.
306-- recoverable.
233−acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
307+acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
234acceptCheck proxy accH
308acceptCheck proxy accH
235− | canHandleAcceptH proxy (AcceptHeader accH) = return ()
309+ | canHandleAcceptH proxy accH = return ()
236− | otherwise = delayedFail err406
310+ | otherwise = delayedFail err406
238methodRouter :: (AllCTRender ctypes a)
312methodRouter :: (AllCTRender ctypes a)
239 => (b -> ([(HeaderName, B.ByteString)], a))
313 => (b -> ([(HeaderName, B.ByteString)], a))
@@ -243,17 +317,28 @@ methodRouter :: (AllCTRender ctypes a)
243methodRouter splitHeaders method proxy status action = leafRouter route'
317methodRouter splitHeaders method proxy status action = leafRouter route'
245 route' env request respond =
319 route' env request respond =
246− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
320+ let accH = getAcceptHeader request
247 in runAction (action `addMethodCheck` methodCheck method request
321 in runAction (action `addMethodCheck` methodCheck method request
248 `addAcceptCheck` acceptCheck proxy accH
322 `addAcceptCheck` acceptCheck proxy accH
249 ) env request respond $ \ output -> do
323 ) env request respond $ \ output -> do
250 let (headers, b) = splitHeaders output
324 let (headers, b) = splitHeaders output
251− case handleAcceptH proxy (AcceptHeader accH) b of
325+ case handleAcceptH proxy accH b of
252 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
326 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
253 Just (contentT, body) ->
327 Just (contentT, body) ->
254 let bdy = if allowedMethodHead method request then "" else body
328 let bdy = if allowedMethodHead method request then "" else body
255 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
329 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
331+noContentRouter :: Method
333+ -> Delayed env (Handler b)
335+noContentRouter method status action = leafRouter route'
337+ route' env request respond =
338+ runAction (action `addMethodCheck` methodCheck method request)
339+ env request respond $ \ _output ->
340+ Route $ responseLBS status [] ""
257instance {-# OVERLAPPABLE #-}
342instance {-# OVERLAPPABLE #-}
258 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
343 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
259 ) => HasServer (Verb method status ctypes a) context where
344 ) => HasServer (Verb method status ctypes a) context where
@@ -263,7 +348,7 @@ instance {-# OVERLAPPABLE #-}
264 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
349 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
265 where method = reflectMethod (Proxy :: Proxy method)
350 where method = reflectMethod (Proxy :: Proxy method)
266− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
351+ status = statusFromNat (Proxy :: Proxy status)
268instance {-# OVERLAPPING #-}
353instance {-# OVERLAPPING #-}
269 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
354 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -275,8 +360,16 @@ instance {-# OVERLAPPING #-}
276 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
361 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
277 where method = reflectMethod (Proxy :: Proxy method)
362 where method = reflectMethod (Proxy :: Proxy method)
278− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
363+ status = statusFromNat (Proxy :: Proxy status)
365+instance (ReflectMethod method) =>
366+ HasServer (NoContentVerb method) context where
368+ type ServerT (NoContentVerb method) m = m NoContent
369+ hoistServerWithContext _ _ nt s = nt s
371+ route Proxy _ = noContentRouter method status204
372+ where method = reflectMethod (Proxy :: Proxy method)
281instance {-# OVERLAPPABLE #-}
374instance {-# OVERLAPPABLE #-}
282 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
375 ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
@@ -288,7 +381,7 @@ instance {-# OVERLAPPABLE #-}
289 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
382 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
290 where method = reflectMethod (Proxy :: Proxy method)
383 where method = reflectMethod (Proxy :: Proxy method)
291− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
384+ status = statusFromNat (Proxy :: Proxy status)
294instance {-# OVERLAPPING #-}
387instance {-# OVERLAPPING #-}
@@ -302,7 +395,7 @@ instance {-# OVERLAPPING #-}
303 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
396 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
304 where method = reflectMethod (Proxy :: Proxy method)
397 where method = reflectMethod (Proxy :: Proxy method)
305− status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
398+ status = statusFromNat (Proxy :: Proxy status)
308streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
401streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@@ -314,7 +407,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra
314 -> Delayed env (Handler c)
407 -> Delayed env (Handler c)
315 -> Router env
408 -> Router env
316streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
409streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
317− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
410+ let AcceptHeader accH = getAcceptHeader request
318 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
411 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
319 accCheck = when (isNothing cmediatype) $ delayedFail err406
412 accCheck = when (isNothing cmediatype) $ delayedFail err406
320 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
413 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
@@ -359,6 +452,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
360 (KnownSymbol sym, FromHttpApiData a, HasServer api context
453 (KnownSymbol sym, FromHttpApiData a, HasServer api context
361 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
454 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
455+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
363 => HasServer (Header' mods sym a :> api) context where
457 => HasServer (Header' mods sym a :> api) context where
@@ -370,6 +464,9 @@ instance
370 route Proxy context subserver = route (Proxy :: Proxy api) context $
464 route Proxy context subserver = route (Proxy :: Proxy api) context $
371 subserver `addHeaderCheck` withRequest headerCheck
465 subserver `addHeaderCheck` withRequest headerCheck
467+ rep = typeRep (Proxy :: Proxy Header')
468+ formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
373 headerName :: IsString n => n
470 headerName :: IsString n => n
374 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
471 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
@@ -380,15 +477,13 @@ instance
380 mev :: Maybe (Either T.Text a)
477 mev :: Maybe (Either T.Text a)
381 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
478 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
383− errReq = delayedFailFatal err400
480+ errReq = delayedFailFatal $ formatError rep req
384− { errBody = "Header " <> headerName <> " is required"
481+ $ "Header " <> headerName <> " is required"
387− errSt e = delayedFailFatal err400
483+ errSt e = delayedFailFatal $ formatError rep req
388− { errBody = cs $ "Error parsing header "
484+ $ cs $ "Error parsing header "
389− <> headerName
485+ <> headerName
390− <> " failed: " <> e
486+ <> " failed: " <> e
393-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
488-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
394-- this automatically requires your server-side handler to be a function
489-- this automatically requires your server-side handler to be a function
@@ -414,6 +509,7 @@ instance
415 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
510 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
416 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
511 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
512+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
418 => HasServer (QueryParam' mods sym a :> api) context where
514 => HasServer (QueryParam' mods sym a :> api) context where
@@ -423,9 +519,12 @@ instance
423 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
519 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
425 route Proxy context subserver =
521 route Proxy context subserver =
426− let querytext req = parseQueryText $ rawQueryString req
522+ let querytext = queryToQueryText . queryString
427 paramname = cs $ symbolVal (Proxy :: Proxy sym)
523 paramname = cs $ symbolVal (Proxy :: Proxy sym)
525+ rep = typeRep (Proxy :: Proxy QueryParam')
526+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
429 parseParam :: Request -> DelayedIO (RequestArgument mods a)
528 parseParam :: Request -> DelayedIO (RequestArgument mods a)
430 parseParam req =
529 parseParam req =
431 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
530 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
@@ -433,14 +532,12 @@ instance
433 mev :: Maybe (Either T.Text a)
532 mev :: Maybe (Either T.Text a)
434 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
533 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
436− errReq = delayedFailFatal err400
535+ errReq = delayedFailFatal $ formatError rep req
437− { errBody = cs $ "Query parameter " <> paramname <> " is required"
536+ $ cs $ "Query parameter " <> paramname <> " is required"
440− errSt e = delayedFailFatal err400
538+ errSt e = delayedFailFatal $ formatError rep req
441− { errBody = cs $ "Error parsing query parameter "
539+ $ cs $ "Error parsing query parameter "
442− <> paramname <> " failed: " <> e
540+ <> paramname <> " failed: " <> e
445 delayed = addParameterCheck subserver . withRequest $ \req ->
542 delayed = addParameterCheck subserver . withRequest $ \req ->
446 parseParam req
543 parseParam req
@@ -466,7 +563,8 @@ instance
466-- > server = getBooksBy
563-- > server = getBooksBy
467-- > where getBooksBy :: [Text] -> Handler [Book]
564-- > where getBooksBy :: [Text] -> Handler [Book]
468-- > getBooksBy authors = ...return all books by these authors...
565-- > getBooksBy authors = ...return all books by these authors...
469−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
566+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
567+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
470 => HasServer (QueryParams sym a :> api) context where
568 => HasServer (QueryParams sym a :> api) context where
472 type ServerT (QueryParams sym a :> api) m =
570 type ServerT (QueryParams sym a :> api) m =
@@ -477,21 +575,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
477 route Proxy context subserver = route (Proxy :: Proxy api) context $
575 route Proxy context subserver = route (Proxy :: Proxy api) context $
478 subserver `addParameterCheck` withRequest paramsCheck
576 subserver `addParameterCheck` withRequest paramsCheck
578+ rep = typeRep (Proxy :: Proxy QueryParams)
579+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
480 paramname = cs $ symbolVal (Proxy :: Proxy sym)
581 paramname = cs $ symbolVal (Proxy :: Proxy sym)
481 paramsCheck req =
582 paramsCheck req =
482 case partitionEithers $ fmap parseQueryParam params of
583 case partitionEithers $ fmap parseQueryParam params of
483 ([], parsed) -> return parsed
584 ([], parsed) -> return parsed
484− (errs, _) -> delayedFailFatal err400
585+ (errs, _) -> delayedFailFatal $ formatError rep req
485− { errBody = cs $ "Error parsing query parameter(s) "
586+ $ cs $ "Error parsing query parameter(s) "
486− <> paramname <> " failed: "
587+ <> paramname <> " failed: "
487− <> T.intercalate ", " errs
588+ <> T.intercalate ", " errs
490 params :: [T.Text]
590 params :: [T.Text]
491 params = mapMaybe snd
591 params = mapMaybe snd
492 . filter (looksLikeParam . fst)
592 . filter (looksLikeParam . fst)
493− . parseQueryText
593+ . queryToQueryText
494− . rawQueryString
594+ . queryString
497 looksLikeParam name = name == paramname || name == (paramname <> "[]")
597 looksLikeParam name = name == paramname || name == (paramname <> "[]")
@@ -517,7 +617,7 @@ instance (KnownSymbol sym, HasServer api context)
517 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
617 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
519 route Proxy context subserver =
619 route Proxy context subserver =
520− let querytext r = parseQueryText $ rawQueryString r
620+ let querytext = queryToQueryText . queryString
521 param r = case lookup paramname (querytext r) of
621 param r = case lookup paramname (querytext r) of
522 Just Nothing -> True -- param is there, with no value
622 Just Nothing -> True -- param is there, with no value
523 Just (Just v) -> examine v -- param with a value
623 Just (Just v) -> examine v -- param with a value
@@ -553,13 +653,42 @@ instance HasServer Raw context where
553 Fail a -> respond $ Fail a
653 Fail a -> respond $ Fail a
554 FailFatal e -> respond $ FailFatal e
654 FailFatal e -> respond $ FailFatal e
656+-- | Just pass the request to the underlying application and serve its response.
660+-- > type MyApi = "images" :> Raw
662+-- > server :: Server MyApi
663+-- > server = serveDirectory "/var/www/images"
664+instance HasServer RawM context where
665+ type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
670+ -> Delayed env (Request -> (Response -> IO ResponseReceived) -> Handler ResponseReceived) -> Router env
671+ route _ _ handleDelayed = RawRouter $ \env request respond -> runResourceT $ do
672+ routeResult <- runDelayed handleDelayed env request
673+ let respond' = liftIO . respond
674+ liftIO $ case routeResult of
675+ Route handler -> runHandler (handler request (respond . Route)) >>=
677+ Left e -> respond' $ FailFatal e
679+ Fail e -> respond' $ Fail e
680+ FailFatal e -> respond' $ FailFatal e
682+ hoistServerWithContext _ _ f srvM = \req respond -> f (srvM req respond)
556-- | If you use 'ReqBody' in one of the endpoints for your API,
685-- | If you use 'ReqBody' in one of the endpoints for your API,
557-- this automatically requires your server-side handler to be a function
686-- this automatically requires your server-side handler to be a function
558-- that takes an argument of the type specified by 'ReqBody'.
687-- that takes an argument of the type specified by 'ReqBody'.
559-- The @Content-Type@ header is inspected, and the list provided is used to
688-- The @Content-Type@ header is inspected, and the list provided is used to
560-- attempt deserialization. If the request does not have a @Content-Type@
689-- attempt deserialization. If the request does not have a @Content-Type@
561-- header, it is treated as @application/octet-stream@ (as specified in
690-- header, it is treated as @application/octet-stream@ (as specified in
562−-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
691+-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
563-- This lets servant worry about extracting it from the request and turning
692-- This lets servant worry about extracting it from the request and turning
564-- it into a value of the type you specify.
693-- it into a value of the type you specify.
@@ -575,6 +704,7 @@ instance HasServer Raw context where
575-- > where postBook :: Book -> Handler Book
704-- > where postBook :: Book -> Handler Book
576-- > postBook book = ...insert into your db...
705-- > postBook book = ...insert into your db...
577instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
706instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
707+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
578 ) => HasServer (ReqBody' mods list a :> api) context where
708 ) => HasServer (ReqBody' mods list a :> api) context where
580 type ServerT (ReqBody' mods list a :> api) m =
710 type ServerT (ReqBody' mods list a :> api) m =
@@ -586,6 +716,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
586 = route (Proxy :: Proxy api) context $
716 = route (Proxy :: Proxy api) context $
587 addBodyCheck subserver ctCheck bodyCheck
717 addBodyCheck subserver ctCheck bodyCheck
719+ rep = typeRep (Proxy :: Proxy ReqBody')
720+ formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
589 -- Content-Type check, we only lookup we can try to parse the request body
722 -- Content-Type check, we only lookup we can try to parse the request body
590 ctCheck = withRequest $ \ request -> do
723 ctCheck = withRequest $ \ request -> do
591 -- See HTTP RFC 2616, section 7.2.1
724 -- See HTTP RFC 2616, section 7.2.1
@@ -604,7 +737,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
604 case sbool :: SBool (FoldLenient mods) of
737 case sbool :: SBool (FoldLenient mods) of
605 STrue -> return mrqbody
738 STrue -> return mrqbody
606 SFalse -> case mrqbody of
739 SFalse -> case mrqbody of
607− Left e -> delayedFailFatal err400 { errBody = cs e }
740+ Left e -> delayedFailFatal $ formatError rep request e
608 Right v -> return v
741 Right v -> return v
@@ -627,7 +760,7 @@ instance
627 bodyCheck fromRS = withRequest $ \req -> do
760 bodyCheck fromRS = withRequest $ \req -> do
628 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
761 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
629 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
762 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
630− let body = requestBody req
763+ let body = getRequestBodyChunk req
631 let rs = S.fromAction B.null body
764 let rs = S.fromAction B.null body
632 let rs' = fromRS $ framingUnrender' rs
765 let rs' = fromRS $ framingUnrender' rs
633 return rs'
766 return rs'
@@ -696,12 +829,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
696emptyServer :: ServerT EmptyAPI m
829emptyServer :: ServerT EmptyAPI m
697emptyServer = Tagged EmptyServer
830emptyServer = Tagged EmptyServer
699−-- | The server for an `EmptyAPI` is `emptyAPIServer`.
832+-- | The server for an `EmptyAPI` is `emptyServer`.
701-- > type MyApi = "nothing" :> EmptyApi
834-- > type MyApi = "nothing" :> EmptyApi
703-- > server :: Server MyApi
836-- > server :: Server MyApi
704−-- > server = emptyAPIServer
837+-- > server = emptyServer
705instance HasServer EmptyAPI context where
838instance HasServer EmptyAPI context where
706 type ServerT EmptyAPI m = Tagged m EmptyServer
839 type ServerT EmptyAPI m = Tagged m EmptyServer
@@ -730,7 +863,10 @@ instance ( KnownSymbol realm
730-- * helpers
863-- * helpers
732ct_wildcard :: B.ByteString
865ct_wildcard :: B.ByteString
733−ct_wildcard = "*" <> "/" <> "*" -- Because CPP
866+ct_wildcard = "*" <> "/" <> "*"
868+getAcceptHeader :: Request -> AcceptHeader
869+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
735-- * General Authentication
871-- * General Authentication
@@ -755,39 +891,19 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
755 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
891 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
757-------------------------------------------------------------------------------
893-------------------------------------------------------------------------------
758−-- TypeError helpers
894+-- Custom type errors
759-------------------------------------------------------------------------------
895-------------------------------------------------------------------------------
761−#ifdef HAS_TYPE_ERROR
897+-- Erroring instance for 'HasServer' when a combinator is not fully applied
762−-- | This instance catches mistakes when there are non-saturated
898+instance TypeError (PartialApplication
763−-- type applications on LHS of ':>'.
899+#if __GLASGOW_HASKELL__ >= 904
764−--
900+ @(Type -> [Type] -> Constraint)
765−-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
901+#endif
767−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
768−-- ...Maybe you haven't applied enough arguments to
769−-- ...Capture' '[] "foo"
772−-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
774−-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
775−-- ...Maybe you haven't applied enough arguments to
776−-- ...Capture' '[] "foo"
779−instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
902+ HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
781− type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
904+ type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
782− -- it doens't really matter what sub route we peak
905+ route = error "unreachable"
783− route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
784− hoistServerWithContext _ _ _ = id
906+ hoistServerWithContext _ _ _ _ = error "unreachable"
786−-- Cannot have TypeError here, otherwise use of this symbol will error :)
787−type HasServerArrowKindError arr =
788− 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
789− ':$$: 'Text "Maybe you haven't applied enough arguments to"
792-- | This instance prevents from accidentally using '->' instead of ':>'
908-- | This instance prevents from accidentally using '->' instead of ':>'
@@ -821,7 +937,107 @@ type HasServerArrowTypeError a b =
821 ':$$: 'ShowType a
937 ':$$: 'ShowType a
822 ':$$: 'Text "and"
938 ':$$: 'Text "and"
823 ':$$: 'ShowType b
939 ':$$: 'ShowType b
941+-- Erroring instances for 'HasServer' for unknown API combinators
943+-- XXX: This omits the @context@ parameter, e.g.:
945+-- "There is no instance for HasServer (Bool :> …)". Do we care ?
946+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceForSub
947+#if __GLASGOW_HASKELL__ >= 904
948+ @(Type -> [Type] -> Constraint)
950+ HasServer ty) => HasServer (ty :> sub) context
952+instance {-# OVERLAPPABLE #-} TypeError (NoInstanceFor (HasServer api context)) => HasServer api context
954+-- | Ignore @'Fragment'@ in server handlers.
955+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
959+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
961+-- > server :: Server MyApi
962+-- > server = getBooks
963+-- > where getBooks :: Handler [Book]
964+-- > getBooks = ...return all books...
965+instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context)
966+ => HasServer (Fragment a1 :> api) context where
967+ type ServerT (Fragment a1 :> api) m = ServerT api m
969+ route _ = route (Proxy :: Proxy api)
971+ hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api)
827-- >>> import Servant
974-- >>> import Servant
976+-- | A type that specifies that an API record contains a server implementation.
977+data AsServerT (m :: * -> *)
978+instance GenericMode (AsServerT m) where
979+ type AsServerT m :- api = ServerT api m
981+type AsServer = AsServerT Handler
984+-- | Set of constraints required to convert to / from vanilla server types.
985+type GServerConstraints api m =
986+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
987+ , GServantProduct (Rep (api (AsServerT m)))
990+-- | This class is a necessary evil: in the implementation of 'HasServer' for
991+-- @'NamedRoutes' api@, we essentially need the quantified constraint @forall
992+-- m. 'GServerConstraints' m@ to hold.
994+-- We cannot require do that directly as the definition of 'GServerConstraints'
995+-- contains type family applications ('Rep' and 'ServerT'). The trick is to hide
996+-- those type family applications behind a typeclass providing evidence for
997+-- @'GServerConstraints' api m@ in the form of a dictionary, and require that
998+-- @forall m. 'GServer' api m@ instead.
1000+-- Users shouldn't have to worry about this class, as the only possible instance
1001+-- is provided in this module for all record APIs.
1003+class GServer (api :: * -> *) (m :: * -> *) where
1004+ gServerProof :: Dict (GServerConstraints api m)
1007+ ( ToServant api (AsServerT m) ~ ServerT (ToServantApi api) m
1008+ , GServantProduct (Rep (api (AsServerT m)))
1009+ ) => GServer api m where
1010+ gServerProof = Dict
1013+ ( HasServer (ToServantApi api) context
1014+ , forall m. Generic (api (AsServerT m))
1015+ , forall m. GServer api m
1016+ ) => HasServer (NamedRoutes api) context where
1018+ type ServerT (NamedRoutes api) m = api (AsServerT m)
1021+ :: Proxy (NamedRoutes api)
1023+ -> Delayed env (api (AsServerT Handler))
1025+ route _ ctx delayed =
1026+ case gServerProof @api @Handler of
1027+ Dict -> route (Proxy @(ToServantApi api)) ctx (toServant <$> delayed)
1029+ hoistServerWithContext
1030+ :: forall m n. Proxy (NamedRoutes api)
1032+ -> (forall x. m x -> n x)
1033+ -> api (AsServerT m)
1034+ -> api (AsServerT n)
1035+ hoistServerWithContext _ pctx nat server =
1036+ case (gServerProof @api @m, gServerProof @api @n) of
1038+ fromServant servantSrvN
1040+ servantSrvM :: ServerT (ToServantApi api) m =
1042+ servantSrvN :: ServerT (ToServantApi api) n =
1043+ hoistServerWithContext (Proxy @(ToServantApi api)) pctx nat servantSrvM