@@ -1,34 +1,31 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE CPP #-}
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 #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
10{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE QuantifiedConstraints #-}
12{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE TupleSections #-}
12{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE TypeApplications #-}
16{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
17+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18+#define HAS_TYPE_ERROR
20module Servant.Server.Internal
21module Servant.Server.Internal
21 ( module Servant.Server.Internal
22 ( module Servant.Server.Internal
22 , module Servant.Server.Internal.BasicAuth
23 , module Servant.Server.Internal.BasicAuth
23 , module Servant.Server.Internal.Context
24 , module Servant.Server.Internal.Context
24− , module Servant.Server.Internal.Delayed
25− , module Servant.Server.Internal.DelayedIO
26− , module Servant.Server.Internal.ErrorFormatter
27 , module Servant.Server.Internal.Handler
25 , module Servant.Server.Internal.Handler
28 , module Servant.Server.Internal.Router
26 , module Servant.Server.Internal.Router
29− , module Servant.Server.Internal.RouteResult
30 , module Servant.Server.Internal.RoutingApplication
27 , module Servant.Server.Internal.RoutingApplication
31− , module Servant.Server.Internal.ServerError
28+ , module Servant.Server.Internal.ServantErr
34import Control.Monad
31import Control.Monad
@@ -41,11 +38,12 @@ import qualified Data.ByteString as B
41import qualified Data.ByteString.Builder as BB
38import qualified Data.ByteString.Builder as BB
42import qualified Data.ByteString.Char8 as BC8
39import qualified Data.ByteString.Char8 as BC8
43import qualified Data.ByteString.Lazy as BL
40import qualified Data.ByteString.Lazy as BL
44−import Data.Constraint (Constraint, Dict(..))
45import Data.Either
41import Data.Either
46 (partitionEithers)
42 (partitionEithers)
47import Data.Maybe
43import Data.Maybe
48 (fromMaybe, isNothing, mapMaybe, maybeToList)
44 (fromMaybe, isNothing, mapMaybe, maybeToList)
49import Data.String
47import Data.String
50 (IsString (..))
48 (IsString (..))
51import Data.String.Conversions
49import Data.String.Conversions
@@ -54,9 +52,8 @@ import Data.Tagged
54 (Tagged (..), retag, untag)
52 (Tagged (..), retag, untag)
55import qualified Data.Text as T
53import qualified Data.Text as T
56import Data.Typeable
54import Data.Typeable
58import GHC.TypeLits
55import GHC.TypeLits
59− (KnownNat, KnownSymbol, TypeError, symbolVal)
56+ (KnownNat, KnownSymbol, natVal, symbolVal)
60import qualified Network.HTTP.Media as NHM
57import qualified Network.HTTP.Media as NHM
61import Network.HTTP.Types hiding
58import Network.HTTP.Types hiding
62 (Header, ResponseHeaders)
59 (Header, ResponseHeaders)
@@ -64,52 +61,42 @@ import Network.Socket
64 (SockAddr)
61 (SockAddr)
65import Network.Wai
62import Network.Wai
66 (Application, Request, httpVersion, isSecure, lazyRequestBody,
63 (Application, Request, httpVersion, isSecure, lazyRequestBody,
67− queryString, remoteHost, getRequestBodyChunk, requestHeaders,
64+ rawQueryString, remoteHost, requestHeaders, requestMethod,
68− requestMethod, responseLBS, responseStream, vault)
65+ responseLBS, responseStream, vault)
69import Prelude ()
66import Prelude ()
70import Prelude.Compat
67import Prelude.Compat
71import Servant.API
68import Servant.API
72− ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
69+ ((:<|>) (..), (:>), Accept (..), BasicAuth,
73− CaptureAll, Description, EmptyAPI, Fragment,
70+ BoundaryStrategy (..), Capture', CaptureAll, Description,
74− FramingRender (..), FramingUnrender (..), FromSourceIO (..),
75− Header', If, IsSecure (..), NoContentVerb, QueryFlag,
71+ EmptyAPI, FramingRender (..), Header', If, IsSecure (..),
76− QueryParam', QueryParams, Raw, ReflectMethod (reflectMethod),
72+ QueryFlag, QueryParam', QueryParams, Raw,
77− RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
73+ ReflectMethod (reflectMethod), RemoteHost, ReqBody',
74+ SBool (..), SBoolI (..), Stream, StreamGenerator (..),
78− Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
75+ Summary, ToStreamGenerator (..), Vault, Verb,
79− WithNamedContext, NamedRoutes)
76+ WithNamedContext)
80−import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
81import Servant.API.ContentTypes
77import Servant.API.ContentTypes
82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
78 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
83− AllMime, MimeRender (..), MimeUnrender (..), NoContent,
84− canHandleAcceptH)
79+ AllMime, MimeRender (..), canHandleAcceptH)
85import Servant.API.Modifiers
80import Servant.API.Modifiers
86 (FoldLenient, FoldRequired, RequestArgument,
81 (FoldLenient, FoldRequired, RequestArgument,
87 unfoldRequestArgument)
82 unfoldRequestArgument)
88import Servant.API.ResponseHeaders
83import Servant.API.ResponseHeaders
89 (GetHeaders, Headers, getHeaders, getResponse)
84 (GetHeaders, Headers, getHeaders, getResponse)
90−import Servant.API.Status
92−import qualified Servant.Types.SourceT as S
93−import Servant.API.TypeErrors
94import Web.HttpApiData
85import Web.HttpApiData
95− (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
86+ (FromHttpApiData, parseHeader, parseQueryParam,
96− parseUrlPieces)
87+ parseUrlPieceMaybe, parseUrlPieces)
98import Servant.Server.Internal.BasicAuth
89import Servant.Server.Internal.BasicAuth
99import Servant.Server.Internal.Context
90import Servant.Server.Internal.Context
100−import Servant.Server.Internal.Delayed
101−import Servant.Server.Internal.DelayedIO
102−import Servant.Server.Internal.ErrorFormatter
103import Servant.Server.Internal.Handler
91import Servant.Server.Internal.Handler
104import Servant.Server.Internal.Router
92import Servant.Server.Internal.Router
105−import Servant.Server.Internal.RouteResult
106import Servant.Server.Internal.RoutingApplication
93import Servant.Server.Internal.RoutingApplication
107−import Servant.Server.Internal.ServerError
94+import Servant.Server.Internal.ServantErr
109import GHC.TypeLits
97import GHC.TypeLits
110 (ErrorMessage (..), TypeError)
98 (ErrorMessage (..), TypeError)
111−import Servant.API.TypeLevel
99+#endif
112− (AtLeastOneFragment, FragmentUnique)
114class HasServer api context where
101class HasServer api context where
115 type ServerT api (m :: * -> *) :: *
102 type ServerT api (m :: * -> *) :: *
@@ -173,31 +160,22 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
173-- > server = getBook
160-- > server = getBook
174-- > where getBook :: Text -> Handler Book
161-- > where getBook :: Text -> Handler Book
175-- > getBook isbn = ...
162-- > getBook isbn = ...
176−instance (KnownSymbol capture, FromHttpApiData a, Typeable a
163+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
177− , HasServer api context, SBoolI (FoldLenient mods)
178− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
180 => HasServer (Capture' mods capture a :> api) context where
164 => HasServer (Capture' mods capture a :> api) context where
182 type ServerT (Capture' mods capture a :> api) m =
166 type ServerT (Capture' mods capture a :> api) m =
183− If (FoldLenient mods) (Either String a) a -> ServerT api m
167+ a -> ServerT api m
185 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
169 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
187 route Proxy context d =
171 route Proxy context d =
188− CaptureRouter [hint] $
172+ CaptureRouter $
189 route (Proxy :: Proxy api)
173 route (Proxy :: Proxy api)
191− (addCapture d $ \ txt -> withRequest $ \ request ->
175+ (addCapture d $ \ txt -> case parseUrlPieceMaybe txt of
192− case ( sbool :: SBool (FoldLenient mods)
176+ Nothing -> delayedFail err400
193− , parseUrlPiece txt :: Either T.Text a) of
194− (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
195− (SFalse, Right v) -> return v
177+ Just v -> return v
196− (STrue, piece) -> return $ (either (Left . cs) Right) piece)
178+ )
198− rep = typeRep (Proxy :: Proxy Capture')
199− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
200− hint = CaptureHint (T.pack $ symbolVal $ Proxy @capture) (typeRep (Proxy :: Proxy a))
202-- | If you use 'CaptureAll' in one of the endpoints for your API,
180-- | If you use 'CaptureAll' in one of the endpoints for your API,
203-- this automatically requires your server-side handler to be a
181-- this automatically requires your server-side handler to be a
@@ -216,10 +194,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
216-- > server = getSourceFile
194-- > server = getSourceFile
217-- > where getSourceFile :: [Text] -> Handler Book
195-- > where getSourceFile :: [Text] -> Handler Book
218-- > getSourceFile pathSegments = ...
196-- > getSourceFile pathSegments = ...
219−instance (KnownSymbol capture, FromHttpApiData a, Typeable a
197+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
220− , HasServer api context
221− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
223 => HasServer (CaptureAll capture a :> api) context where
198 => HasServer (CaptureAll capture a :> api) context where
225 type ServerT (CaptureAll capture a :> api) m =
200 type ServerT (CaptureAll capture a :> api) m =
@@ -228,18 +203,14 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
228 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
203 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
230 route Proxy context d =
205 route Proxy context d =
231− CaptureAllRouter [hint] $
206+ CaptureAllRouter $
232 route (Proxy :: Proxy api)
207 route (Proxy :: Proxy api)
234− (addCapture d $ \ txts -> withRequest $ \ request ->
235− case parseUrlPieces txts of
209+ (addCapture d $ \ txts -> case parseUrlPieces txts of
236− Left e -> delayedFail $ formatError rep request $ cs e
210+ Left _ -> delayedFail err400
237− Right v -> return v
211+ 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]))
244allowedMethodHead :: Method -> Request -> Bool
215allowedMethodHead :: Method -> Request -> Bool
245allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
216allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -259,10 +230,10 @@ methodCheck method request
259-- body check is no longer an option. However, we now run the accept
230-- body check is no longer an option. However, we now run the accept
260-- check before the body check and can therefore afford to make it
231-- check before the body check and can therefore afford to make it
261-- recoverable.
232-- recoverable.
262−acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
233+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
263acceptCheck proxy accH
234acceptCheck proxy accH
264− | canHandleAcceptH proxy accH = return ()
235+ | canHandleAcceptH proxy (AcceptHeader accH) = return ()
265− | otherwise = delayedFail err406
236+ | otherwise = delayedFail err406
267methodRouter :: (AllCTRender ctypes a)
238methodRouter :: (AllCTRender ctypes a)
268 => (b -> ([(HeaderName, B.ByteString)], a))
239 => (b -> ([(HeaderName, B.ByteString)], a))
@@ -272,28 +243,17 @@ methodRouter :: (AllCTRender ctypes a)
272methodRouter splitHeaders method proxy status action = leafRouter route'
243methodRouter splitHeaders method proxy status action = leafRouter route'
274 route' env request respond =
245 route' env request respond =
275− let accH = getAcceptHeader request
246+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
276 in runAction (action `addMethodCheck` methodCheck method request
247 in runAction (action `addMethodCheck` methodCheck method request
277 `addAcceptCheck` acceptCheck proxy accH
248 `addAcceptCheck` acceptCheck proxy accH
278 ) env request respond $ \ output -> do
249 ) env request respond $ \ output -> do
279 let (headers, b) = splitHeaders output
250 let (headers, b) = splitHeaders output
280− case handleAcceptH proxy accH b of
251+ case handleAcceptH proxy (AcceptHeader accH) b of
281 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
252 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
282 Just (contentT, body) ->
253 Just (contentT, body) ->
283 let bdy = if allowedMethodHead method request then "" else body
254 let bdy = if allowedMethodHead method request then "" else body
284 in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
255 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 [] ""
297instance {-# OVERLAPPABLE #-}
257instance {-# OVERLAPPABLE #-}
298 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
258 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
299 ) => HasServer (Verb method status ctypes a) context where
259 ) => HasServer (Verb method status ctypes a) context where
@@ -303,7 +263,7 @@ instance {-# OVERLAPPABLE #-}
304 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
264 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
305 where method = reflectMethod (Proxy :: Proxy method)
265 where method = reflectMethod (Proxy :: Proxy method)
306− status = statusFromNat (Proxy :: Proxy status)
266+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
308instance {-# OVERLAPPING #-}
268instance {-# OVERLAPPING #-}
309 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
269 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -315,46 +275,37 @@ instance {-# OVERLAPPING #-}
316 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
276 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
317 where method = reflectMethod (Proxy :: Proxy method)
277 where method = reflectMethod (Proxy :: Proxy method)
318− status = statusFromNat (Proxy :: Proxy status)
278+ status = toEnum . fromInteger $ natVal (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)
329instance {-# OVERLAPPABLE #-}
281instance {-# OVERLAPPABLE #-}
330− ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
282+ ( MimeRender ctype a, ReflectMethod method, KnownNat status,
331− FramingRender framing, ToSourceIO chunk a
283+ FramingRender framing ctype, ToStreamGenerator b a
332− ) => HasServer (Stream method status framing ctype a) context where
284+ ) => HasServer (Stream method status framing ctype b) context where
334− type ServerT (Stream method status framing ctype a) m = m a
286+ type ServerT (Stream method status framing ctype b) m = m b
335 hoistServerWithContext _ _ nt s = nt s
287 hoistServerWithContext _ _ nt s = nt s
337 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
289 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
338 where method = reflectMethod (Proxy :: Proxy method)
290 where method = reflectMethod (Proxy :: Proxy method)
339− status = statusFromNat (Proxy :: Proxy status)
291+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
342instance {-# OVERLAPPING #-}
293instance {-# OVERLAPPING #-}
343− ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,
294+ ( MimeRender ctype a, ReflectMethod method, KnownNat status,
344− FramingRender framing, ToSourceIO chunk a,
295+ FramingRender framing ctype, ToStreamGenerator b a,
345− GetHeaders (Headers h a)
296+ GetHeaders (Headers h b)
346− ) => HasServer (Stream method status framing ctype (Headers h a)) context where
297+ ) => HasServer (Stream method status framing ctype (Headers h b)) context where
348− type ServerT (Stream method status framing ctype (Headers h a)) m = m (Headers h a)
299+ type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b)
349 hoistServerWithContext _ _ nt s = nt s
300 hoistServerWithContext _ _ nt s = nt s
351 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
302 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
352 where method = reflectMethod (Proxy :: Proxy method)
303 where method = reflectMethod (Proxy :: Proxy method)
353− status = statusFromNat (Proxy :: Proxy status)
304+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
356−streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
307+streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) =>
357− (c -> ([(HeaderName, B.ByteString)], a))
308+ (c -> ([(HeaderName, B.ByteString)], b))
358 -> Method
309 -> Method
359 -> Status
310 -> Status
360 -> Proxy framing
311 -> Proxy framing
@@ -362,7 +313,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra
362 -> Delayed env (Handler c)
313 -> Delayed env (Handler c)
363 -> Router env
314 -> Router env
364streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
315streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
365− let AcceptHeader accH = getAcceptHeader request
316+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
366 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
317 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
367 accCheck = when (isNothing cmediatype) $ delayedFail err406
318 accCheck = when (isNothing cmediatype) $ delayedFail err406
368 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
319 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
@@ -370,19 +321,28 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
370 `addAcceptCheck` accCheck
321 `addAcceptCheck` accCheck
371 ) env request respond $ \ output ->
322 ) env request respond $ \ output ->
372 let (headers, fa) = splitHeaders output
323 let (headers, fa) = splitHeaders output
373− sourceT = toSourceIO fa
324+ k = getStreamGenerator . toStreamGenerator $ fa in
374− S.SourceT kStepLBS = framingRender framingproxy (mimeRender ctypeproxy :: chunk -> BL.ByteString) sourceT
375− in Route $ responseStream status (contentHeader : headers) $ \write flush -> do
325+ Route $ responseStream status (contentHeader : headers) $ \write flush -> do
376− let loop S.Stop = flush
326+ write . BB.lazyByteString $ header framingproxy ctypeproxy
377− loop (S.Error err) = fail err -- TODO: throw better error
327+ case boundary framingproxy ctypeproxy of
378− loop (S.Skip s) = loop s
328+ BoundaryStrategyBracket f ->
379− loop (S.Effect ms) = ms >>= loop
329+ let go x = let bs = mimeRender ctypeproxy x
380− loop (S.Yield lbs s) = do
330+ (before, after) = f bs
331+ in write ( BB.lazyByteString before
332+ <> BB.lazyByteString bs
333+ <> BB.lazyByteString after) >> flush
335+ BoundaryStrategyIntersperse sep -> k
337+ write . BB.lazyByteString . mimeRender ctypeproxy $ x
381− write (BB.lazyByteString lbs)
340+ write . (BB.lazyByteString sep <>) . BB.lazyByteString . mimeRender ctypeproxy $ x
383− loop s
342+ BoundaryStrategyGeneral f ->
384−
343+ let go = (>> flush) . write . BB.lazyByteString . f . mimeRender ctypeproxy
385− kStepLBS loop
344+ in k go go
345+ write . BB.lazyByteString $ trailer framingproxy ctypeproxy
387-- | If you use 'Header' in one of the endpoints for your API,
347-- | If you use 'Header' in one of the endpoints for your API,
388-- this automatically requires your server-side handler to be a function
348-- this automatically requires your server-side handler to be a function
@@ -407,7 +367,6 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
408 (KnownSymbol sym, FromHttpApiData a, HasServer api context
368 (KnownSymbol sym, FromHttpApiData a, HasServer api context
409 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
369 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
410− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
412 => HasServer (Header' mods sym a :> api) context where
371 => HasServer (Header' mods sym a :> api) context where
@@ -419,9 +378,6 @@ instance
419 route Proxy context subserver = route (Proxy :: Proxy api) context $
378 route Proxy context subserver = route (Proxy :: Proxy api) context $
420 subserver `addHeaderCheck` withRequest headerCheck
379 subserver `addHeaderCheck` withRequest headerCheck
422− rep = typeRep (Proxy :: Proxy Header')
423− formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
425 headerName :: IsString n => n
381 headerName :: IsString n => n
426 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
382 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
@@ -432,13 +388,15 @@ instance
432 mev :: Maybe (Either T.Text a)
388 mev :: Maybe (Either T.Text a)
433 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
389 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
435− errReq = delayedFailFatal $ formatError rep req
391+ errReq = delayedFailFatal err400
436− $ "Header " <> headerName <> " is required"
392+ { errBody = "Header " <> headerName <> " is required"
438− errSt e = delayedFailFatal $ formatError rep req
395+ errSt e = delayedFailFatal err400
439− $ cs $ "Error parsing header "
396+ { errBody = cs $ "Error parsing header "
440− <> headerName
397+ <> headerName
441− <> " failed: " <> e
398+ <> " failed: " <> e
443-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
401-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
444-- this automatically requires your server-side handler to be a function
402-- this automatically requires your server-side handler to be a function
@@ -464,7 +422,6 @@ instance
465 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
423 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
466 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
424 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
467− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
469 => HasServer (QueryParam' mods sym a :> api) context where
426 => HasServer (QueryParam' mods sym a :> api) context where
@@ -474,12 +431,9 @@ instance
474 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
431 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
476 route Proxy context subserver =
433 route Proxy context subserver =
477− let querytext = queryToQueryText . queryString
434+ let querytext req = parseQueryText $ rawQueryString req
478 paramname = cs $ symbolVal (Proxy :: Proxy sym)
435 paramname = cs $ symbolVal (Proxy :: Proxy sym)
480− rep = typeRep (Proxy :: Proxy QueryParam')
481− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
483 parseParam :: Request -> DelayedIO (RequestArgument mods a)
437 parseParam :: Request -> DelayedIO (RequestArgument mods a)
484 parseParam req =
438 parseParam req =
485 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
439 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
@@ -487,12 +441,14 @@ instance
487 mev :: Maybe (Either T.Text a)
441 mev :: Maybe (Either T.Text a)
488 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
442 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
490− errReq = delayedFailFatal $ formatError rep req
444+ errReq = delayedFailFatal err400
491− $ cs $ "Query parameter " <> paramname <> " is required"
445+ { errBody = cs $ "Query parameter " <> paramname <> " is required"
493− errSt e = delayedFailFatal $ formatError rep req
448+ errSt e = delayedFailFatal err400
494− $ cs $ "Error parsing query parameter "
449+ { errBody = cs $ "Error parsing query parameter "
495− <> paramname <> " failed: " <> e
450+ <> paramname <> " failed: " <> e
497 delayed = addParameterCheck subserver . withRequest $ \req ->
453 delayed = addParameterCheck subserver . withRequest $ \req ->
498 parseParam req
454 parseParam req
@@ -518,8 +474,7 @@ instance
518-- > server = getBooksBy
474-- > server = getBooksBy
519-- > where getBooksBy :: [Text] -> Handler [Book]
475-- > where getBooksBy :: [Text] -> Handler [Book]
520-- > getBooksBy authors = ...return all books by these authors...
476-- > getBooksBy authors = ...return all books by these authors...
521−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
477+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
522− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
523 => HasServer (QueryParams sym a :> api) context where
478 => HasServer (QueryParams sym a :> api) context where
525 type ServerT (QueryParams sym a :> api) m =
480 type ServerT (QueryParams sym a :> api) m =
@@ -530,23 +485,21 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
530 route Proxy context subserver = route (Proxy :: Proxy api) context $
485 route Proxy context subserver = route (Proxy :: Proxy api) context $
531 subserver `addParameterCheck` withRequest paramsCheck
486 subserver `addParameterCheck` withRequest paramsCheck
533− rep = typeRep (Proxy :: Proxy QueryParams)
534− formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
536 paramname = cs $ symbolVal (Proxy :: Proxy sym)
488 paramname = cs $ symbolVal (Proxy :: Proxy sym)
537 paramsCheck req =
489 paramsCheck req =
538 case partitionEithers $ fmap parseQueryParam params of
490 case partitionEithers $ fmap parseQueryParam params of
539 ([], parsed) -> return parsed
491 ([], parsed) -> return parsed
540− (errs, _) -> delayedFailFatal $ formatError rep req
492+ (errs, _) -> delayedFailFatal err400
541− $ cs $ "Error parsing query parameter(s) "
493+ { errBody = cs $ "Error parsing query parameter(s) "
542− <> paramname <> " failed: "
494+ <> paramname <> " failed: "
543− <> T.intercalate ", " errs
495+ <> T.intercalate ", " errs
545 params :: [T.Text]
498 params :: [T.Text]
546 params = mapMaybe snd
499 params = mapMaybe snd
547 . filter (looksLikeParam . fst)
500 . filter (looksLikeParam . fst)
548− . queryToQueryText
501+ . parseQueryText
549− . queryString
502+ . rawQueryString
552 looksLikeParam name = name == paramname || name == (paramname <> "[]")
505 looksLikeParam name = name == paramname || name == (paramname <> "[]")
@@ -572,7 +525,7 @@ instance (KnownSymbol sym, HasServer api context)
572 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
525 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
574 route Proxy context subserver =
527 route Proxy context subserver =
575− let querytext = queryToQueryText . queryString
528+ let querytext r = parseQueryText $ rawQueryString r
576 param r = case lookup paramname (querytext r) of
529 param r = case lookup paramname (querytext r) of
577 Just Nothing -> True -- param is there, with no value
530 Just Nothing -> True -- param is there, with no value
578 Just (Just v) -> examine v -- param with a value
531 Just (Just v) -> examine v -- param with a value
@@ -614,7 +567,7 @@ instance HasServer Raw context where
614-- The @Content-Type@ header is inspected, and the list provided is used to
567-- The @Content-Type@ header is inspected, and the list provided is used to
615-- attempt deserialization. If the request does not have a @Content-Type@
568-- attempt deserialization. If the request does not have a @Content-Type@
616-- header, it is treated as @application/octet-stream@ (as specified in
569-- header, it is treated as @application/octet-stream@ (as specified in
617−-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
570+-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
618-- This lets servant worry about extracting it from the request and turning
571-- This lets servant worry about extracting it from the request and turning
619-- it into a value of the type you specify.
572-- it into a value of the type you specify.
@@ -630,7 +583,6 @@ instance HasServer Raw context where
630-- > where postBook :: Book -> Handler Book
583-- > where postBook :: Book -> Handler Book
631-- > postBook book = ...insert into your db...
584-- > postBook book = ...insert into your db...
632instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
585instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
633− , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
634 ) => HasServer (ReqBody' mods list a :> api) context where
586 ) => HasServer (ReqBody' mods list a :> api) context where
636 type ServerT (ReqBody' mods list a :> api) m =
588 type ServerT (ReqBody' mods list a :> api) m =
@@ -642,9 +594,6 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
642 = route (Proxy :: Proxy api) context $
594 = route (Proxy :: Proxy api) context $
643 addBodyCheck subserver ctCheck bodyCheck
595 addBodyCheck subserver ctCheck bodyCheck
645− rep = typeRep (Proxy :: Proxy ReqBody')
646− formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
648 -- Content-Type check, we only lookup we can try to parse the request body
597 -- Content-Type check, we only lookup we can try to parse the request body
649 ctCheck = withRequest $ \ request -> do
598 ctCheck = withRequest $ \ request -> do
650 -- See HTTP RFC 2616, section 7.2.1
599 -- See HTTP RFC 2616, section 7.2.1
@@ -663,34 +612,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
663 case sbool :: SBool (FoldLenient mods) of
612 case sbool :: SBool (FoldLenient mods) of
664 STrue -> return mrqbody
613 STrue -> return mrqbody
665 SFalse -> case mrqbody of
614 SFalse -> case mrqbody of
666− Left e -> delayedFailFatal $ formatError rep request e
615+ Left e -> delayedFailFatal err400 { errBody = cs e }
667 Right v -> return v
616 Right v -> return v
670− ( FramingUnrender framing, FromSourceIO chunk a, MimeUnrender ctype chunk
671− , HasServer api context
672− ) => HasServer (StreamBody' mods framing ctype a :> api) context
674− type ServerT (StreamBody' mods framing ctype a :> api) m = a -> ServerT api m
676− hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
678− route Proxy context subserver = route (Proxy :: Proxy api) context $
679− addBodyCheck subserver ctCheck bodyCheck
681− ctCheck :: DelayedIO (SourceIO chunk -> a)
682− -- TODO: do content-type check
683− ctCheck = return fromSourceIO
685− bodyCheck :: (SourceIO chunk -> a) -> DelayedIO a
686− bodyCheck fromRS = withRequest $ \req -> do
687− let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
688− let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
689− let body = getRequestBodyChunk req
690− let rs = S.fromAction B.null body
691− let rs' = fromRS $ framingUnrender' rs
694-- | Make sure the incoming request starts with @"/path"@, strip it and
618-- | Make sure the incoming request starts with @"/path"@, strip it and
695-- pass the rest of the request path to @api@.
619-- pass the rest of the request path to @api@.
696instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where
620instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) context where
@@ -755,12 +679,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
755emptyServer :: ServerT EmptyAPI m
679emptyServer :: ServerT EmptyAPI m
756emptyServer = Tagged EmptyServer
680emptyServer = Tagged EmptyServer
758−-- | The server for an `EmptyAPI` is `emptyServer`.
682+-- | The server for an `EmptyAPI` is `emptyAPIServer`.
760-- > type MyApi = "nothing" :> EmptyApi
684-- > type MyApi = "nothing" :> EmptyApi
762-- > server :: Server MyApi
686-- > server :: Server MyApi
763−-- > server = emptyServer
687+-- > server = emptyAPIServer
764instance HasServer EmptyAPI context where
688instance HasServer EmptyAPI context where
765 type ServerT EmptyAPI m = Tagged m EmptyServer
689 type ServerT EmptyAPI m = Tagged m EmptyServer
@@ -789,10 +713,7 @@ instance ( KnownSymbol realm
789-- * helpers
713-- * helpers
791ct_wildcard :: B.ByteString
715ct_wildcard :: B.ByteString
792−ct_wildcard = "*" <> "/" <> "*"
716+ct_wildcard = "*" <> "/" <> "*" -- Because CPP
794−getAcceptHeader :: Request -> AcceptHeader
795−getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
797-- * General Authentication
718-- * General Authentication
@@ -817,15 +738,39 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
817 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
738 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
819-------------------------------------------------------------------------------
740-------------------------------------------------------------------------------
820−-- Custom type errors
741+-- TypeError helpers
821-------------------------------------------------------------------------------
742-------------------------------------------------------------------------------
823−-- Erroring instance for 'HasServer' when a combinator is not fully applied
744+#ifdef HAS_TYPE_ERROR
745+-- | This instance catches mistakes when there are non-saturated
746+-- type applications on LHS of ':>'.
748+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
750+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
751+-- ...Maybe you haven't applied enough arguments to
752+-- ...Capture' '[] "foo"
755+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
757+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
758+-- ...Maybe you haven't applied enough arguments to
759+-- ...Capture' '[] "foo"
824−instance TypeError (PartialApplication HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
762+instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
826− type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
764+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
827− route = error "unreachable"
765+ -- it doens't really matter what sub route we peak
766+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
828− hoistServerWithContext _ _ _ _ = error "unreachable"
767+ hoistServerWithContext _ _ _ = id
769+-- Cannot have TypeError here, otherwise use of this symbol will error :)
770+type HasServerArrowKindError arr =
771+ 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
772+ ':$$: 'Text "Maybe you haven't applied enough arguments to"
830-- | This instance prevents from accidentally using '->' instead of ':>'
775-- | This instance prevents from accidentally using '->' instead of ':>'
@@ -859,103 +804,7 @@ type HasServerArrowTypeError a b =
859 ':$$: 'ShowType a
804 ':$$: 'ShowType a
860 ':$$: 'Text "and"
805 ':$$: 'Text "and"
861 ':$$: 'ShowType b
806 ':$$: '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)
892-- >>> import Servant
810-- >>> 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