@@ -1,24 +1,23 @@
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
@@ -36,19 +35,19 @@ module Servant.Server.Internal
36import Control.Monad
35import Control.Monad
37 (join, when)
36 (join, when)
38import Control.Monad.Trans
37import Control.Monad.Trans
39− (liftIO, lift)
38+ (liftIO)
40import Control.Monad.Trans.Resource
39import Control.Monad.Trans.Resource
41− (runResourceT, ReleaseKey)
40+ (runResourceT)
43import qualified Data.ByteString as B
41import qualified Data.ByteString as B
44import qualified Data.ByteString.Builder as BB
42import qualified Data.ByteString.Builder as BB
45import qualified Data.ByteString.Char8 as BC8
43import qualified Data.ByteString.Char8 as BC8
46import qualified Data.ByteString.Lazy as BL
44import qualified Data.ByteString.Lazy as BL
47−import Data.Constraint (Constraint, Dict(..))
48import Data.Either
45import Data.Either
49 (partitionEithers)
46 (partitionEithers)
50import Data.Maybe
47import Data.Maybe
51 (fromMaybe, isNothing, mapMaybe, maybeToList)
48 (fromMaybe, isNothing, mapMaybe, maybeToList)
52import Data.String
51import Data.String
53 (IsString (..))
52 (IsString (..))
54import Data.String.Conversions
53import Data.String.Conversions
@@ -57,48 +56,41 @@ import Data.Tagged
57 (Tagged (..), retag, untag)
56 (Tagged (..), retag, untag)
58import qualified Data.Text as T
57import qualified Data.Text as T
59import Data.Typeable
58import Data.Typeable
61import GHC.TypeLits
59import GHC.TypeLits
62− (KnownNat, KnownSymbol, TypeError, symbolVal)
60+ (KnownNat, KnownSymbol, natVal, symbolVal)
63import qualified Network.HTTP.Media as NHM
61import qualified Network.HTTP.Media as NHM
64import Network.HTTP.Types hiding
62import Network.HTTP.Types hiding
65 (Header, ResponseHeaders)
63 (Header, ResponseHeaders)
66import Network.Socket
64import Network.Socket
67 (SockAddr)
65 (SockAddr)
68import Network.Wai
66import Network.Wai
69− (Application, Request, Response, ResponseReceived, httpVersion, isSecure, lazyRequestBody,
67+ (Application, Request, httpVersion, isSecure, lazyRequestBody,
70− queryString, remoteHost, getRequestBodyChunk, requestHeaders,
68+ queryString, remoteHost, requestBody, requestHeaders,
71 requestMethod, responseLBS, responseStream, vault)
69 requestMethod, responseLBS, responseStream, vault)
72import Prelude ()
70import Prelude ()
73import Prelude.Compat
71import Prelude.Compat
74import Servant.API
72import Servant.API
75 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
73 ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture',
76− CaptureAll, Description, EmptyAPI, Fragment,
74+ CaptureAll, Description, EmptyAPI, FramingRender (..),
77− FramingRender (..), FramingUnrender (..), FromSourceIO (..),
75+ FramingUnrender (..), FromSourceIO (..), Header', If,
78− Header', If, IsSecure (..), NoContentVerb, QueryFlag,
76+ IsSecure (..), QueryFlag, QueryParam', QueryParams, Raw,
79− QueryParam', QueryParams, Raw, RawM, ReflectMethod (reflectMethod),
77+ ReflectMethod (reflectMethod), RemoteHost, ReqBody',
80− RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO,
78+ SBool (..), SBoolI (..), SourceIO, Stream, StreamBody',
81− Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb,
79+ Summary, ToSourceIO (..), Vault, Verb, NoContentVerb,
82− WithNamedContext, WithResource, NamedRoutes)
80+ WithNamedContext)
83−import Servant.API.Generic (GenericMode(..), ToServant, ToServantApi, GServantProduct, toServant, fromServant)
84import Servant.API.ContentTypes
81import Servant.API.ContentTypes
85 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
82 (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
86− AllMime, MimeRender (..), MimeUnrender (..), NoContent,
83+ AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
87− canHandleAcceptH)
84+ NoContent)
88import Servant.API.Modifiers
85import Servant.API.Modifiers
89 (FoldLenient, FoldRequired, RequestArgument,
86 (FoldLenient, FoldRequired, RequestArgument,
90 unfoldRequestArgument)
87 unfoldRequestArgument)
91import Servant.API.ResponseHeaders
88import Servant.API.ResponseHeaders
92 (GetHeaders, Headers, getHeaders, getResponse)
89 (GetHeaders, Headers, getHeaders, getResponse)
93−import Servant.API.Status
95import qualified Servant.Types.SourceT as S
90import qualified Servant.Types.SourceT as S
96−import Servant.API.TypeErrors
97import Web.HttpApiData
91import Web.HttpApiData
98− (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece,
92+ (FromHttpApiData, parseHeader, parseQueryParam,
99− parseUrlPieces)
93+ parseUrlPieces, parseUrlPiece)
103import Servant.Server.Internal.BasicAuth
95import Servant.Server.Internal.BasicAuth
104import Servant.Server.Internal.Context
96import Servant.Server.Internal.Context
@@ -111,16 +103,12 @@ import Servant.Server.Internal.RouteResult
111import Servant.Server.Internal.RoutingApplication
103import Servant.Server.Internal.RoutingApplication
112import Servant.Server.Internal.ServerError
104import Servant.Server.Internal.ServerError
106+#ifdef HAS_TYPE_ERROR
114import GHC.TypeLits
107import GHC.TypeLits
115 (ErrorMessage (..), TypeError)
108 (ErrorMessage (..), TypeError)
116−import Servant.API.TypeLevel
109+#endif
117− (AtLeastOneFragment, FragmentUnique)
119class HasServer api context where
111class 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 :: * -> *) :: *
112 type ServerT api (m :: * -> *) :: *
@@ -182,7 +170,7 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
182-- > server = getBook
170-- > server = getBook
183-- > where getBook :: Text -> Handler Book
171-- > where getBook :: Text -> Handler Book
184-- > getBook isbn = ...
172-- > getBook isbn = ...
185−instance (KnownSymbol capture, FromHttpApiData a, Typeable a
173+instance (KnownSymbol capture, FromHttpApiData a
186 , HasServer api context, SBoolI (FoldLenient mods)
174 , HasServer api context, SBoolI (FoldLenient mods)
187 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
175 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
@@ -194,7 +182,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
194 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
182 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
196 route Proxy context d =
184 route Proxy context d =
197− CaptureRouter [hint] $
185+ CaptureRouter $
198 route (Proxy :: Proxy api)
186 route (Proxy :: Proxy api)
200 (addCapture d $ \ txt -> withRequest $ \ request ->
188 (addCapture d $ \ txt -> withRequest $ \ request ->
@@ -206,7 +194,6 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
207 rep = typeRep (Proxy :: Proxy Capture')
195 rep = typeRep (Proxy :: Proxy Capture')
208 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
196 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,
198-- | If you use 'CaptureAll' in one of the endpoints for your API,
212-- this automatically requires your server-side handler to be a
199-- this automatically requires your server-side handler to be a
@@ -225,7 +212,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
225-- > server = getSourceFile
212-- > server = getSourceFile
226-- > where getSourceFile :: [Text] -> Handler Book
213-- > where getSourceFile :: [Text] -> Handler Book
227-- > getSourceFile pathSegments = ...
214-- > getSourceFile pathSegments = ...
228−instance (KnownSymbol capture, FromHttpApiData a, Typeable a
215+instance (KnownSymbol capture, FromHttpApiData a
229 , HasServer api context
216 , HasServer api context
230 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
217 , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
@@ -237,7 +224,7 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
237 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
224 hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
239 route Proxy context d =
226 route Proxy context d =
240− CaptureAllRouter [hint] $
227+ CaptureAllRouter $
241 route (Proxy :: Proxy api)
228 route (Proxy :: Proxy api)
243 (addCapture d $ \ txts -> withRequest $ \ request ->
230 (addCapture d $ \ txts -> withRequest $ \ request ->
@@ -248,43 +235,6 @@ instance (KnownSymbol capture, FromHttpApiData a, Typeable a
249 rep = typeRep (Proxy :: Proxy CaptureAll)
236 rep = typeRep (Proxy :: Proxy CaptureAll)
250 formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
237 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
239allowedMethodHead :: Method -> Request -> Bool
290allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
240allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -348,7 +298,7 @@ instance {-# OVERLAPPABLE #-}
349 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
299 route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
350 where method = reflectMethod (Proxy :: Proxy method)
300 where method = reflectMethod (Proxy :: Proxy method)
351− status = statusFromNat (Proxy :: Proxy status)
301+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
353instance {-# OVERLAPPING #-}
303instance {-# OVERLAPPING #-}
354 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
304 ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
@@ -360,7 +310,7 @@ instance {-# OVERLAPPING #-}
361 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
311 route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
362 where method = reflectMethod (Proxy :: Proxy method)
312 where method = reflectMethod (Proxy :: Proxy method)
363− status = statusFromNat (Proxy :: Proxy status)
313+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
365instance (ReflectMethod method) =>
315instance (ReflectMethod method) =>
366 HasServer (NoContentVerb method) context where
316 HasServer (NoContentVerb method) context where
@@ -381,7 +331,7 @@ instance {-# OVERLAPPABLE #-}
382 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
332 route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
383 where method = reflectMethod (Proxy :: Proxy method)
333 where method = reflectMethod (Proxy :: Proxy method)
384− status = statusFromNat (Proxy :: Proxy status)
334+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
387instance {-# OVERLAPPING #-}
337instance {-# OVERLAPPING #-}
@@ -395,7 +345,7 @@ instance {-# OVERLAPPING #-}
396 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
346 route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
397 where method = reflectMethod (Proxy :: Proxy method)
347 where method = reflectMethod (Proxy :: Proxy method)
398− status = statusFromNat (Proxy :: Proxy status)
348+ status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
401streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
351streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a) =>
@@ -653,35 +603,6 @@ instance HasServer Raw context where
653 Fail a -> respond $ Fail a
603 Fail a -> respond $ Fail a
654 FailFatal e -> respond $ FailFatal e
604 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,
606-- | If you use 'ReqBody' in one of the endpoints for your API,
686-- this automatically requires your server-side handler to be a function
607-- this automatically requires your server-side handler to be a function
687-- that takes an argument of the type specified by 'ReqBody'.
608-- that takes an argument of the type specified by 'ReqBody'.
@@ -760,7 +681,7 @@ instance
760 bodyCheck fromRS = withRequest $ \req -> do
681 bodyCheck fromRS = withRequest $ \req -> do
761 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
682 let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
762 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
683 let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk
763− let body = getRequestBodyChunk req
684+ let body = requestBody req
764 let rs = S.fromAction B.null body
685 let rs = S.fromAction B.null body
765 let rs' = fromRS $ framingUnrender' rs
686 let rs' = fromRS $ framingUnrender' rs
766 return rs'
687 return rs'
@@ -829,12 +750,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
829emptyServer :: ServerT EmptyAPI m
750emptyServer :: ServerT EmptyAPI m
830emptyServer = Tagged EmptyServer
751emptyServer = Tagged EmptyServer
832−-- | The server for an `EmptyAPI` is `emptyServer`.
753+-- | The server for an `EmptyAPI` is `emptyAPIServer`.
834-- > type MyApi = "nothing" :> EmptyApi
755-- > type MyApi = "nothing" :> EmptyApi
836-- > server :: Server MyApi
757-- > server :: Server MyApi
837−-- > server = emptyServer
758+-- > server = emptyAPIServer
838instance HasServer EmptyAPI context where
759instance HasServer EmptyAPI context where
839 type ServerT EmptyAPI m = Tagged m EmptyServer
760 type ServerT EmptyAPI m = Tagged m EmptyServer
@@ -863,7 +784,7 @@ instance ( KnownSymbol realm
863-- * helpers
784-- * helpers
865ct_wildcard :: B.ByteString
786ct_wildcard :: B.ByteString
866−ct_wildcard = "*" <> "/" <> "*"
787+ct_wildcard = "*" <> "/" <> "*" -- Because CPP
868getAcceptHeader :: Request -> AcceptHeader
789getAcceptHeader :: Request -> AcceptHeader
869getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
790getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
@@ -891,19 +812,39 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
891 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
812 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
893-------------------------------------------------------------------------------
814-------------------------------------------------------------------------------
894−-- Custom type errors
815+-- TypeError helpers
895-------------------------------------------------------------------------------
816-------------------------------------------------------------------------------
897−-- Erroring instance for 'HasServer' when a combinator is not fully applied
818+#ifdef HAS_TYPE_ERROR
898−instance TypeError (PartialApplication
819+-- | This instance catches mistakes when there are non-saturated
899−#if __GLASGOW_HASKELL__ >= 904
820+-- type applications on LHS of ':>'.
900− @(Type -> [Type] -> Constraint)
821+--
901−#endif
822+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
824+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
825+-- ...Maybe you haven't applied enough arguments to
826+-- ...Capture' '[] "foo"
829+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
831+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
832+-- ...Maybe you haven't applied enough arguments to
833+-- ...Capture' '[] "foo"
902− HasServer arr) => HasServer ((arr :: a -> b) :> sub) context
836+instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
904− type ServerT (arr :> sub) _ = TypeError (PartialApplication (HasServer :: * -> [*] -> Constraint) arr)
838+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
905− route = error "unreachable"
839+ -- it doesn't really matter what sub route we peak
840+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
906− hoistServerWithContext _ _ _ _ = error "unreachable"
841+ hoistServerWithContext _ _ _ = id
843+-- Cannot have TypeError here, otherwise use of this symbol will error :)
844+type HasServerArrowKindError arr =
845+ 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
846+ ':$$: 'Text "Maybe you haven't applied enough arguments to"
908-- | This instance prevents from accidentally using '->' instead of ':>'
849-- | This instance prevents from accidentally using '->' instead of ':>'
@@ -937,107 +878,7 @@ type HasServerArrowTypeError a b =
937 ':$$: 'ShowType a
878 ':$$: 'ShowType a
938 ':$$: 'Text "and"
879 ':$$: 'Text "and"
939 ':$$: 'ShowType b
880 ':$$: '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
884-- >>> 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