@@ -1,31 +1,29 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
4{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveDataTypeable #-}
6{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
7{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE InstanceSigs #-}
9−{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
12{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
13−{-# LANGUAGE QuantifiedConstraints #-}
14{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RankNTypes #-}
15{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE TupleSections #-}
12{-# LANGUAGE TupleSections #-}
17−{-# LANGUAGE TypeApplications #-}
18{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
19{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
20{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
17+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18+#define HAS_TYPE_ERROR
22module Servant.Server.Internal
21module Servant.Server.Internal
23 ( module Servant.Server.Internal
22 ( module Servant.Server.Internal
24 , module Servant.Server.Internal.BasicAuth
23 , module Servant.Server.Internal.BasicAuth
25 , module Servant.Server.Internal.Context
24 , module Servant.Server.Internal.Context
26 , module Servant.Server.Internal.Delayed
25 , module Servant.Server.Internal.Delayed
27 , module Servant.Server.Internal.DelayedIO
26 , module Servant.Server.Internal.DelayedIO
28− , module Servant.Server.Internal.ErrorFormatter
29 , module Servant.Server.Internal.Handler
27 , module Servant.Server.Internal.Handler
30 , module Servant.Server.Internal.Router
28 , module Servant.Server.Internal.Router
31 , module Servant.Server.Internal.RouteResult
29 , module Servant.Server.Internal.RouteResult
@@ -36,19 +34,19 @@ module Servant.Server.Internal
36import Control.Monad
34import Control.Monad
37 (join, when)
35 (join, when)
38import Control.Monad.Trans
36import Control.Monad.Trans
39− (liftIO, lift)
37+ (liftIO)
40import Control.Monad.Trans.Resource
38import Control.Monad.Trans.Resource
41− (runResourceT, ReleaseKey)
39+ (runResourceT)
43import qualified Data.ByteString as B
40import qualified Data.ByteString as B
44import qualified Data.ByteString.Builder as BB
41import qualified Data.ByteString.Builder as BB
45import qualified Data.ByteString.Char8 as BC8
42import qualified Data.ByteString.Char8 as BC8
46import qualified Data.ByteString.Lazy as BL
43import qualified Data.ByteString.Lazy as BL
47−import Data.Constraint (Constraint, Dict(..))
48import Data.Either
44import Data.Either
49 (partitionEithers)
45 (partitionEithers)
50import Data.Maybe
46import Data.Maybe
51 (fromMaybe, isNothing, mapMaybe, maybeToList)
47 (fromMaybe, isNothing, mapMaybe, maybeToList)
52import Data.String
50import Data.String
53 (IsString (..))
51 (IsString (..))
54import Data.String.Conversions
52import Data.String.Conversions
@@ -57,70 +55,58 @@ import Data.Tagged
57 (Tagged (..), retag, untag)
55 (Tagged (..), retag, untag)
58import qualified Data.Text as T
56import qualified Data.Text as T
59import Data.Typeable
57import Data.Typeable
61import GHC.TypeLits
58import GHC.TypeLits
62− (KnownNat, KnownSymbol, TypeError, symbolVal)
59+ (KnownNat, KnownSymbol, natVal, symbolVal)
63import qualified Network.HTTP.Media as NHM
60import qualified Network.HTTP.Media as NHM
64import Network.HTTP.Types hiding
61import Network.HTTP.Types hiding
65 (Header, ResponseHeaders)
62 (Header, ResponseHeaders)
66import Network.Socket
63import Network.Socket
67 (SockAddr)
64 (SockAddr)
68import Network.Wai
65import Network.Wai
69− (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
66+ (Application, Request, httpVersion, isSecure, lazyRequestBody,
70− queryString, remoteHost, getRequestBodyChunk, requestHeaders,
67+ queryString, remoteHost, requestBody, requestHeaders,
71 requestMethod, responseLBS, responseStream, vault)
68 requestMethod, responseLBS, responseStream, vault)
72import Prelude ()
69import Prelude ()
73import Prelude.Compat
70import Prelude.Compat
74import Servant.API
71import Servant.API
75 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
72 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
76− CaptureAll, Description, EmptyAPI, Fragment,
73+ CaptureAll, Description, EmptyAPI, FramingRender (..),
77− FramingRender (..), FramingUnrender (..), FromSourceIO (..),
74+ FramingUnrender (..), FromSourceIO (..), Header', If,
78− Header', If, IsSecure (..), NoContentVerb, QueryFlag,
75+ IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
79− QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
76+ ReflectMethod (reflectMethod), RemoteHost, ReqBody',
80− RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
77+ SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
81− Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
78+ Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
82− WithNamedContext, WithResource, NamedRoutes)
79+ WithNamedContext)
83−import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
84import Servant.API.ContentTypes
80import Servant.API.ContentTypes
85 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
81 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
86− AllMime, MimeRender (..), MimeUnrender (..), NoContent,
82+ AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
87− canHandleAcceptH)
83+ NoContent)
88import Servant.API.Modifiers
84import Servant.API.Modifiers
89 (FoldLenient, FoldRequired, RequestArgument,
85 (FoldLenient, FoldRequired, RequestArgument,
90 unfoldRequestArgument)
86 unfoldRequestArgument)
91import Servant.API.ResponseHeaders
87import Servant.API.ResponseHeaders
92 (GetHeaders, Headers, getHeaders, getResponse)
88 (GetHeaders, Headers, getHeaders, getResponse)
93−import Servant.API.Status
95import qualified Servant.Types.SourceT as S
89import qualified Servant.Types.SourceT as S
96−import Servant.API.TypeErrors
97import Web.HttpApiData
90import Web.HttpApiData
98− (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
91+ (FromHttpApiData, parseHeader, parseQueryParam,
99− parseUrlPieces)
92+ parseUrlPieces, parseUrlPiece)
103import Servant.Server.Internal.BasicAuth
94import Servant.Server.Internal.BasicAuth
104import Servant.Server.Internal.Context
95import Servant.Server.Internal.Context
105import Servant.Server.Internal.Delayed
96import Servant.Server.Internal.Delayed
106import Servant.Server.Internal.DelayedIO
97import Servant.Server.Internal.DelayedIO
107−import Servant.Server.Internal.ErrorFormatter
108import Servant.Server.Internal.Handler
98import Servant.Server.Internal.Handler
109import Servant.Server.Internal.Router
99import Servant.Server.Internal.Router
110import Servant.Server.Internal.RouteResult
100import Servant.Server.Internal.RouteResult
111import Servant.Server.Internal.RoutingApplication
101import Servant.Server.Internal.RoutingApplication
112import Servant.Server.Internal.ServerError
102import Servant.Server.Internal.ServerError
104+#ifdef HAS_TYPE_ERROR
114import GHC.TypeLits
105import GHC.TypeLits
115 (ErrorMessage (..), TypeError)
106 (ErrorMessage (..), TypeError)
116−import Servant.API.TypeLevel
107+#endif
117− (AtLeastOneFragment, FragmentUnique)
119class HasServer api context where
109class 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.
124 type ServerT api (m :: * -> *) :: *
110 type ServerT api (m :: * -> *) :: *
@@ -182,10 +168,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
182-- > server = getBook
168-- > server = getBook
183-- > where getBook :: Text -> Handler Book
169-- > where getBook :: Text -> Handler Book
184-- > getBook isbn = ...
170-- > getBook isbn = ...
185−instance (KnownSymbol capture, FromHttpApiData a, Typeable a
186− , HasServer api context, SBoolI (FoldLenient mods)
171+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods))
187− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
189 => HasServer (Capture' mods capture a :> api) context where
172 => HasServer (Capture' mods capture a :> api) context where
191 type ServerT (Capture' mods capture a :> api) m =
174 type ServerT (Capture' mods capture a :> api) m =
@@ -194,19 +177,15 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
194 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
177 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
196 route Proxy context d =
179 route Proxy context d =
197− CaptureRouter [hint] $
180+ CaptureRouter $
198 route (Proxy :: Proxy api)
181 route (Proxy :: Proxy api)
200− (addCapture d $ \ txt -> withRequest $ \ request ->
201− case ( sbool :: SBool (FoldLenient mods)
183+ (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods)
202− , parseUrlPiece txt :: Either T.Text a) of
184+ , parseUrlPiece txt :: Either T.Text a) of
203− (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
185+ (SFalse, Left e) -> delayedFail err400 { errBody = cs e }
204− (SFalse, Right v) -> return v
186+ (SFalse, Right v) -> return v
205− (STrue, piece) -> return $ (either (Left . cs) Right) piece)
187+ (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))
211-- | If you use 'CaptureAll' in one of the endpoints for your API,
190-- | If you use 'CaptureAll' in one of the endpoints for your API,
212-- this automatically requires your server-side handler to be a
191-- this automatically requires your server-side handler to be a
@@ -225,10 +204,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
225-- > server = getSourceFile
204-- > server = getSourceFile
226-- > where getSourceFile :: [Text] -> Handler Book
205-- > where getSourceFile :: [Text] -> Handler Book
227-- > getSourceFile pathSegments = ...
206-- > getSourceFile pathSegments = ...
228−instance (KnownSymbol capture, FromHttpApiData a, Typeable a
207+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
229− , HasServer api context
230− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
232 => HasServer (CaptureAll capture a :> api) context where
208 => HasServer (CaptureAll capture a :> api) context where
234 type ServerT (CaptureAll capture a :> api) m =
210 type ServerT (CaptureAll capture a :> api) m =
@@ -237,53 +213,13 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
237 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
213 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
239 route Proxy context d =
215 route Proxy context d =
240− CaptureAllRouter [hint] $
216+ CaptureAllRouter $
241 route (Proxy :: Proxy api)
217 route (Proxy :: Proxy api)
243− (addCapture d $ \ txts -> withRequest $ \ request ->
244− case parseUrlPieces txts of
219+ (addCapture d $ \ txts -> case parseUrlPieces txts of
245− Left e -> delayedFail $ formatError rep request $ cs e
220+ Left _ -> delayedFail err400
246− Right v -> return v
221+ 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)
289allowedMethodHead :: Method -> Request -> Bool
225allowedMethodHead :: Method -> Request -> Bool
@@ -304,10 +240,10 @@ methodCheck method request
304-- body check is no longer an option. However, we now run the accept
240-- body check is no longer an option. However, we now run the accept
305-- check before the body check and can therefore afford to make it
241-- check before the body check and can therefore afford to make it
306-- recoverable.
242-- recoverable.
307−acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
243+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
308acceptCheck proxy accH
244acceptCheck proxy accH
309− | canHandleAcceptH proxy accH = return ()
245+ | canHandleAcceptH proxy (AcceptHeader accH) = return ()
310− | otherwise = delayedFail err406
246+ | otherwise = delayedFail err406
312methodRouter :: (AllCTRender ctypes a)
248methodRouter :: (AllCTRender ctypes a)
313 => (b -> ([(HeaderName, B.ByteString)], a))
249 => (b -> ([(HeaderName, B.ByteString)], a))
@@ -317,12 +253,12 @@ methodRouter :: (AllCTRender ctypes a)
317methodRouter splitHeaders method proxy status action = leafRouter route'
253methodRouter splitHeaders method proxy status action = leafRouter route'
319 route' env request respond =
255 route' env request respond =
320− let accH = getAcceptHeader request
256+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
321 in runAction (action `addMethodCheck` methodCheck method request
257 in runAction (action `addMethodCheck` methodCheck method request
322 `addAcceptCheck` acceptCheck proxy accH
258 `addAcceptCheck` acceptCheck proxy accH
323 ) env request respond $ \ output -> do
259 ) env request respond $ \ output -> do
324 let (headers, b) = splitHeaders output
260 let (headers, b) = splitHeaders output
325− case handleAcceptH proxy accH b of
261+ case handleAcceptH proxy (AcceptHeader accH) b of
326 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
262 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
327 Just (contentT, body) ->
263 Just (contentT, body) ->
328 let bdy = if allowedMethodHead method request then "" else body
264 let bdy = if allowedMethodHead method request then "" else body
@@ -348,7 +284,7 @@ instance {-# OVERLAPPABLE #-}
349 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
285 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
350 where method = reflectMethod (Proxy :: Proxy method)
286 where method = reflectMethod (Proxy :: Proxy method)
351− status = statusFromNat (Proxy :: Proxy status)
287+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
353instance {-# OVERLAPPING #-}
289instance {-# OVERLAPPING #-}
354 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
290 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -360,7 +296,7 @@ instance {-# OVERLAPPING #-}
361 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
297 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
362 where method = reflectMethod (Proxy :: Proxy method)
298 where method = reflectMethod (Proxy :: Proxy method)
363− status = statusFromNat (Proxy :: Proxy status)
299+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
365instance (ReflectMethod method) =>
301instance (ReflectMethod method) =>
366 HasServer (NoContentVerb method) context where
302 HasServer (NoContentVerb method) context where
@@ -381,7 +317,7 @@ instance {-# OVERLAPPABLE #-}
382 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
318 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
383 where method = reflectMethod (Proxy :: Proxy method)
319 where method = reflectMethod (Proxy :: Proxy method)
384− status = statusFromNat (Proxy :: Proxy status)
320+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
387instance {-# OVERLAPPING #-}
323instance {-# OVERLAPPING #-}
@@ -395,7 +331,7 @@ instance {-# OVERLAPPING #-}
396 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
332 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
397 where method = reflectMethod (Proxy :: Proxy method)
333 where method = reflectMethod (Proxy :: Proxy method)
398− status = statusFromNat (Proxy :: Proxy status)
334+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
401streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
337streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@@ -407,7 +343,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra
407 -> Delayed env (Handler c)
343 -> Delayed env (Handler c)
408 -> Router env
344 -> Router env
409streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
345streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
410− let AcceptHeader accH = getAcceptHeader request
346+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
411 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
347 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
412 accCheck = when (isNothing cmediatype) $ delayedFail err406
348 accCheck = when (isNothing cmediatype) $ delayedFail err406
413 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
349 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
@@ -452,7 +388,6 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
453 (KnownSymbol sym, FromHttpApiData a, HasServer api context
389 (KnownSymbol sym, FromHttpApiData a, HasServer api context
454 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
390 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
455− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
457 => HasServer (Header' mods sym a :> api) context where
392 => HasServer (Header' mods sym a :> api) context where
@@ -464,9 +399,6 @@ instance
464 route Proxy context subserver = route (Proxy :: Proxy api) context $
399 route Proxy context subserver = route (Proxy :: Proxy api) context $
465 subserver `addHeaderCheck` withRequest headerCheck
400 subserver `addHeaderCheck` withRequest headerCheck
467− rep = typeRep (Proxy :: Proxy Header')
468− formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
470 headerName :: IsString n => n
402 headerName :: IsString n => n
471 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
403 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
@@ -477,13 +409,15 @@ instance
477 mev :: Maybe (Either T.Text a)
409 mev :: Maybe (Either T.Text a)
478 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
410 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
480− errReq = delayedFailFatal $ formatError rep req
412+ errReq = delayedFailFatal err400
481− $ "Header " <> headerName <> " is required"
413+ { errBody = "Header " <> headerName <> " is required"
483− errSt e = delayedFailFatal $ formatError rep req
416+ errSt e = delayedFailFatal err400
484− $ cs $ "Error parsing header "
417+ { errBody = cs $ "Error parsing header "
485− <> headerName
418+ <> headerName
486− <> " failed: " <> e
419+ <> " failed: " <> e
488-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
422-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
489-- this automatically requires your server-side handler to be a function
423-- this automatically requires your server-side handler to be a function
@@ -509,7 +443,6 @@ instance
510 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
444 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
511 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
445 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
512− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
514 => HasServer (QueryParam' mods sym a :> api) context where
447 => HasServer (QueryParam' mods sym a :> api) context where
@@ -522,9 +455,6 @@ instance
522 let querytext = queryToQueryText . queryString
455 let querytext = queryToQueryText . queryString
523 paramname = cs $ symbolVal (Proxy :: Proxy sym)
456 paramname = cs $ symbolVal (Proxy :: Proxy sym)
525− rep = typeRep (Proxy :: Proxy QueryParam')
526− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
528 parseParam :: Request -> DelayedIO (RequestArgument mods a)
458 parseParam :: Request -> DelayedIO (RequestArgument mods a)
529 parseParam req =
459 parseParam req =
530 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
460 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
@@ -532,12 +462,14 @@ instance
532 mev :: Maybe (Either T.Text a)
462 mev :: Maybe (Either T.Text a)
533 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
463 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
535− errReq = delayedFailFatal $ formatError rep req
465+ errReq = delayedFailFatal err400
536− $ cs $ "Query parameter " <> paramname <> " is required"
466+ { errBody = cs $ "Query parameter " <> paramname <> " is required"
538− errSt e = delayedFailFatal $ formatError rep req
469+ errSt e = delayedFailFatal err400
539− $ cs $ "Error parsing query parameter "
470+ { errBody = cs $ "Error parsing query parameter "
540− <> paramname <> " failed: " <> e
471+ <> paramname <> " failed: " <> e
542 delayed = addParameterCheck subserver . withRequest $ \req ->
474 delayed = addParameterCheck subserver . withRequest $ \req ->
543 parseParam req
475 parseParam req
@@ -563,8 +495,7 @@ instance
563-- > server = getBooksBy
495-- > server = getBooksBy
564-- > where getBooksBy :: [Text] -> Handler [Book]
496-- > where getBooksBy :: [Text] -> Handler [Book]
565-- > getBooksBy authors = ...return all books by these authors...
497-- > getBooksBy authors = ...return all books by these authors...
566−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
498+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
567− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
568 => HasServer (QueryParams sym a :> api) context where
499 => HasServer (QueryParams sym a :> api) context where
570 type ServerT (QueryParams sym a :> api) m =
501 type ServerT (QueryParams sym a :> api) m =
@@ -575,23 +506,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
575 route Proxy context subserver = route (Proxy :: Proxy api) context $
506 route Proxy context subserver = route (Proxy :: Proxy api) context $
576 subserver `addParameterCheck` withRequest paramsCheck
507 subserver `addParameterCheck` withRequest paramsCheck
578− rep = typeRep (Proxy :: Proxy QueryParams)
579− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
581 paramname = cs $ symbolVal (Proxy :: Proxy sym)
509 paramname = cs $ symbolVal (Proxy :: Proxy sym)
582 paramsCheck req =
510 paramsCheck req =
583 case partitionEithers $ fmap parseQueryParam params of
511 case partitionEithers $ fmap parseQueryParam params of
584 ([], parsed) -> return parsed
512 ([], parsed) -> return parsed
585− (errs, _) -> delayedFailFatal $ formatError rep req
513+ (errs, _) -> delayedFailFatal err400
586− $ cs $ "Error parsing query parameter(s) "
514+ { errBody = cs $ "Error parsing query parameter(s) "
587− <> paramname <> " failed: "
515+ <> paramname <> " failed: "
588− <> T.intercalate ", " errs
516+ <> T.intercalate ", " errs
590 params :: [T.Text]
519 params :: [T.Text]
591 params = mapMaybe snd
520 params = mapMaybe snd
592 . filter (looksLikeParam . fst)
521 . filter (looksLikeParam . fst)
593− . queryToQueryText
522+ . queryToQueryText
594− . queryString
523+ . queryString
597 looksLikeParam name = name == paramname || name == (paramname <> "[]")
526 looksLikeParam name = name == paramname || name == (paramname <> "[]")
@@ -653,42 +582,13 @@ instance HasServer Raw context where
653 Fail a -> respond $ Fail a
582 Fail a -> respond $ Fail a
654 FailFatal e -> respond $ FailFatal e
583 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)
685-- | If you use 'ReqBody' in one of the endpoints for your API,
585-- | If you use 'ReqBody' in one of the endpoints for your API,
686-- this automatically requires your server-side handler to be a function
586-- this automatically requires your server-side handler to be a function
687-- that takes an argument of the type specified by 'ReqBody'.
587-- that takes an argument of the type specified by 'ReqBody'.
688-- The @Content-Type@ header is inspected, and the list provided is used to
588-- The @Content-Type@ header is inspected, and the list provided is used to
689-- attempt deserialization. If the request does not have a @Content-Type@
589-- attempt deserialization. If the request does not have a @Content-Type@
690-- header, it is treated as @application/octet-stream@ (as specified in
590-- header, it is treated as @application/octet-stream@ (as specified in
691−-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
591+-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
692-- This lets servant worry about extracting it from the request and turning
592-- This lets servant worry about extracting it from the request and turning
693-- it into a value of the type you specify.
593-- it into a value of the type you specify.
@@ -704,7 +604,6 @@ instance HasServer RawM context where
704-- > where postBook :: Book -> Handler Book
604-- > where postBook :: Book -> Handler Book
705-- > postBook book = ...insert into your db...
605-- > postBook book = ...insert into your db...
706instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
606instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
707− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
708 ) => HasServer (ReqBody' mods list a :> api) context where
607 ) => HasServer (ReqBody' mods list a :> api) context where
710 type ServerT (ReqBody' mods list a :> api) m =
609 type ServerT (ReqBody' mods list a :> api) m =
@@ -716,9 +615,6 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
716 = route (Proxy :: Proxy api) context $
615 = route (Proxy :: Proxy api) context $
717 addBodyCheck subserver ctCheck bodyCheck
616 addBodyCheck subserver ctCheck bodyCheck
719− rep = typeRep (Proxy :: Proxy ReqBody')
720− formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
722 -- Content-Type check, we only lookup we can try to parse the request body
618 -- Content-Type check, we only lookup we can try to parse the request body
723 ctCheck = withRequest $ \ request -> do
619 ctCheck = withRequest $ \ request -> do
724 -- See HTTP RFC 2616, section 7.2.1
620 -- See HTTP RFC 2616, section 7.2.1
@@ -737,7 +633,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
737 case sbool :: SBool (FoldLenient mods) of
633 case sbool :: SBool (FoldLenient mods) of
738 STrue -> return mrqbody
634 STrue -> return mrqbody
739 SFalse -> case mrqbody of
635 SFalse -> case mrqbody of
740− Left e -> delayedFailFatal $ formatError rep request e
636+ Left e -> delayedFailFatal err400 { errBody = cs e }
741 Right v -> return v
637 Right v -> return v
@@ -760,7 +656,7 @@ instance
760 bodyCheck fromRS = withRequest $ \req -> do
656 bodyCheck fromRS = withRequest $ \req -> do
761 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
657 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
762 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
658 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
763− let body = getRequestBodyChunk req
659+ let body = requestBody req
764 let rs = S.fromAction B.null body
660 let rs = S.fromAction B.null body
765 let rs' = fromRS $ framingUnrender' rs
661 let rs' = fromRS $ framingUnrender' rs
766 return rs'
662 return rs'
@@ -829,12 +725,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
829emptyServer :: ServerT EmptyAPI m
725emptyServer :: ServerT EmptyAPI m
830emptyServer = Tagged EmptyServer
726emptyServer = Tagged EmptyServer
832−-- | The server for an `EmptyAPI` is `emptyServer`.
728+-- | The server for an `EmptyAPI` is `emptyAPIServer`.
834-- > type MyApi = "nothing" :> EmptyApi
730-- > type MyApi = "nothing" :> EmptyApi
836-- > server :: Server MyApi
732-- > server :: Server MyApi
837−-- > server = emptyServer
733+-- > server = emptyAPIServer
838instance HasServer EmptyAPI context where
734instance HasServer EmptyAPI context where
839 type ServerT EmptyAPI m = Tagged m EmptyServer
735 type ServerT EmptyAPI m = Tagged m EmptyServer
@@ -863,10 +759,7 @@ instance ( KnownSymbol realm
863-- * helpers
759-- * helpers
865ct_wildcard :: B.ByteString
761ct_wildcard :: B.ByteString
866−ct_wildcard = "*" <> "/" <> "*"
762+ct_wildcard = "*" <> "/" <> "*" -- Because CPP
868−getAcceptHeader :: Request -> AcceptHeader
869−getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
871-- * General Authentication
764-- * General Authentication
@@ -891,19 +784,39 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
891 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
784 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
893-------------------------------------------------------------------------------
786-------------------------------------------------------------------------------
894−-- Custom type errors
787+-- TypeError helpers
895-------------------------------------------------------------------------------
788-------------------------------------------------------------------------------
897−-- Erroring instance for 'HasServer' when a combinator is not fully applied
790+#ifdef HAS_TYPE_ERROR
898−instance TypeError (PartialApplication
791+-- | This instance catches mistakes when there are non-saturated
899−#if __GLASGOW_HASKELL__ >= 904
792+-- type applications on LHS of ':>'.
900− @(Type -> [Type] -> Constraint)
793+--
901−#endif
794+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
796+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
797+-- ...Maybe you haven't applied enough arguments to
798+-- ...Capture' '[] "foo"
801+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
803+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
804+-- ...Maybe you haven't applied enough arguments to
805+-- ...Capture' '[] "foo"
902− HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
808+instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
904− type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
810+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
905− route = error "unreachable"
811+ -- it doens't really matter what sub route we peak
812+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
906− hoistServerWithContext _ _ _ _ = error "unreachable"
813+ hoistServerWithContext _ _ _ = id
815+-- Cannot have TypeError here, otherwise use of this symbol will error :)
816+type HasServerArrowKindError arr =
817+ 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
818+ ':$$: 'Text "Maybe you haven't applied enough arguments to"
908-- | This instance prevents from accidentally using '->' instead of ':>'
821-- | This instance prevents from accidentally using '->' instead of ':>'
@@ -937,107 +850,7 @@ type HasServerArrowTypeError a b =
937 ':$$: 'ShowType a
850 ':$$: 'ShowType a
938 ':$$: 'Text "and"
851 ':$$: 'Text "and"
939 ':$$: 'ShowType b
852 ':$$: '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)
974-- >>> import Servant
856-- >>> 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