@@ -8,6 +8,7 @@
88{-# LANGUAGE MultiParamTypeClasses #-}
99{-# LANGUAGE OverloadedStrings #-}
1010{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE RankNTypes #-}
1112{-# LANGUAGE ScopedTypeVariables #-}
1213{-# LANGUAGE TypeFamilies #-}
1314{-# LANGUAGE TypeOperators #-}
@@ -33,7 +34,7 @@ import Data.Maybe (fromMaybe, mapMaybe)
3334import Data.Either (partitionEithers)
3435import Data.String (fromString)
3536import Data.String.Conversions (cs, (<>))
36−import Data.Tagged (Tagged(..), untag)
37+import Data.Tagged (Tagged(..), retag, untag)
3738import qualified Data.Text as T
3839import Data.Typeable
3940import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
@@ -85,6 +86,13 @@ class HasServer api context where
8586 -> Delayed env (Server api)
8687 -> Router env
8788
89+ hoistServer
90+ :: Proxy api
91+ -> Proxy context
92+ -> (forall x. m x -> n x)
93+ -> ServerT api m
94+ -> ServerT api n
95+
8896type Server api = ServerT api Handler
8997
9098-- * Instances
@@ -109,6 +117,11 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
109117 where pa = Proxy :: Proxy a
110118 pb = Proxy :: Proxy b
111119
120+ -- | This is better than 'enter', as it's taylor made for 'HasServer'.
121+ hoistServer _ pc nt (a :<|> b) =
122+ hoistServer (Proxy :: Proxy a) pc nt a :<|>
123+ hoistServer (Proxy :: Proxy b) pc nt b
124+
112125-- | If you use 'Capture' in one of the endpoints for your API,
113126-- this automatically requires your server-side handler to be a function
114127-- that takes an argument of the type specified by the 'Capture'.
@@ -132,6 +145,8 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
132145 type ServerT (Capture capture a :> api) m =
133146 a -> ServerT api m
134147
148+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
149+
135150 route Proxy context d =
136151 CaptureRouter $
137152 route (Proxy :: Proxy api)
@@ -158,15 +173,17 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
158173-- > server = getSourceFile
159174-- > where getSourceFile :: [Text] -> Handler Book
160175-- > getSourceFile pathSegments = ...
161−instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context)
162− => HasServer (CaptureAll capture a :> sublayout) context where
176+instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
177+ => HasServer (CaptureAll capture a :> api) context where
163178
164− type ServerT (CaptureAll capture a :> sublayout) m =
165− [a] -> ServerT sublayout m
179+ type ServerT (CaptureAll capture a :> api) m =
180+ [a] -> ServerT api m
181+
182+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
166183
167184 route Proxy context d =
168185 CaptureAllRouter $
169− route (Proxy :: Proxy sublayout)
186+ route (Proxy :: Proxy api)
170187 context
171188 (addCapture d $ \ txts -> case parseUrlPieces txts of
172189 Left _ -> delayedFail err400
@@ -241,6 +258,7 @@ instance OVERLAPPABLE_
241258 ) => HasServer (Verb method status ctypes a) context where
242259
243260 type ServerT (Verb method status ctypes a) m = m a
261+ hoistServer _ _ nt s = nt s
244262
245263 route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status
246264 where method = reflectMethod (Proxy :: Proxy method)
@@ -252,6 +270,7 @@ instance OVERLAPPING_
252270 ) => HasServer (Verb method status ctypes (Headers h a)) context where
253271
254272 type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
273+ hoistServer _ _ nt s = nt s
255274
256275 route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status
257276 where method = reflectMethod (Proxy :: Proxy method)
@@ -283,6 +302,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
283302 type ServerT (Header sym a :> api) m =
284303 Maybe a -> ServerT api m
285304
305+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
306+
286307 route Proxy context subserver = route (Proxy :: Proxy api) context $
287308 subserver `addHeaderCheck` withRequest headerCheck
288309 where
@@ -326,6 +347,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
326347 type ServerT (QueryParam sym a :> api) m =
327348 Maybe a -> ServerT api m
328349
350+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
351+
329352 route Proxy context subserver =
330353 let querytext req = parseQueryText $ rawQueryString req
331354 parseParam req =
@@ -371,6 +394,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
371394 type ServerT (QueryParams sym a :> api) m =
372395 [a] -> ServerT api m
373396
397+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
398+
374399 route Proxy context subserver = route (Proxy :: Proxy api) context $
375400 subserver `addParameterCheck` withRequest paramsCheck
376401 where
@@ -411,6 +436,8 @@ instance (KnownSymbol sym, HasServer api context)
411436 type ServerT (QueryFlag sym :> api) m =
412437 Bool -> ServerT api m
413438
439+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
440+
414441 route Proxy context subserver =
415442 let querytext r = parseQueryText $ rawQueryString r
416443 param r = case lookup paramname (querytext r) of
@@ -434,6 +461,8 @@ instance HasServer Raw context where
434461
435462 type ServerT Raw m = Tagged m Application
436463
464+ hoistServer _ _ _ = retag
465+
437466 route Proxy _ rawApplication = RawRouter $ \ env request respond -> runResourceT $ do
438467 -- note: a Raw application doesn't register any cleanup
439468 -- but for the sake of consistency, we nonetheless run
@@ -473,6 +502,8 @@ instance ( AllCTUnrender list a, HasServer api context
473502 type ServerT (ReqBody list a :> api) m =
474503 a -> ServerT api m
475504
505+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
506+
476507 route Proxy context subserver
477508 = route (Proxy :: Proxy api) context $
478509 addBodyCheck subserver ctCheck bodyCheck
@@ -507,44 +538,51 @@ instance (KnownSymbol path, HasServer api context) => HasServer (path :> api) co
507538 (cs (symbolVal proxyPath))
508539 (route (Proxy :: Proxy api) context subserver)
509540 where proxyPath = Proxy :: Proxy path
541+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt s
510542
511543instance HasServer api context => HasServer (RemoteHost :> api) context where
512544 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
513545
514546 route Proxy context subserver =
515547 route (Proxy :: Proxy api) context (passToServer subserver remoteHost)
548+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
516549
517550instance HasServer api context => HasServer (IsSecure :> api) context where
518551 type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
519552
520553 route Proxy context subserver =
521554 route (Proxy :: Proxy api) context (passToServer subserver secure)
522−
523555 where secure req = if isSecure req then Secure else NotSecure
524556
557+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
558+
525559instance HasServer api context => HasServer (Vault :> api) context where
526560 type ServerT (Vault :> api) m = Vault -> ServerT api m
527561
528562 route Proxy context subserver =
529563 route (Proxy :: Proxy api) context (passToServer subserver vault)
564+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
530565
531566instance HasServer api context => HasServer (HttpVersion :> api) context where
532567 type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
533568
534569 route Proxy context subserver =
535570 route (Proxy :: Proxy api) context (passToServer subserver httpVersion)
571+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
536572
537573-- | Ignore @'Summary'@ in server handlers.
538574instance HasServer api ctx => HasServer (Summary desc :> api) ctx where
539575 type ServerT (Summary desc :> api) m = ServerT api m
540576
541577 route _ = route (Proxy :: Proxy api)
578+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt s
542579
543580-- | Ignore @'Description'@ in server handlers.
544581instance HasServer api ctx => HasServer (Description desc :> api) ctx where
545582 type ServerT (Description desc :> api) m = ServerT api m
546583
547584 route _ = route (Proxy :: Proxy api)
585+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt s
548586
549587-- | Singleton type representing a server that serves an empty API.
550588data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum)
@@ -564,6 +602,8 @@ instance HasServer EmptyAPI context where
564602
565603 route Proxy _ _ = StaticRouter mempty mempty
566604
605+ hoistServer _ _ _ = retag
606+
567607-- | Basic Authentication
568608instance ( KnownSymbol realm
569609 , HasServer api context
@@ -580,6 +620,8 @@ instance ( KnownSymbol realm
580620 basicAuthContext = getContextEntry context
581621 authCheck = withRequest $ \ req -> runBasicAuth req realm basicAuthContext
582622
623+ hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
624+
583625-- * helpers
584626
585627ct_wildcard :: B.ByteString
@@ -604,3 +646,5 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
604646
605647 subContext :: Context subContext
606648 subContext = descendIntoNamedContext (Proxy :: Proxy name) context
649+
650+ hoistServer _ _ nt s = hoistServer (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s