eeva
/
servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge f9994cf0b7 into 8f081bd9ad

This commit is contained in:
Gaël Deest 2022-11-23 11:37:57 +03:00 committed by GitHub
parent 8f081bd9ad f9994cf0b7
commit 9907028dfe
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
1 changed files with 31 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
servant-server/src/Servant/Server/Internal.hs
View File

@ -297,26 +297,42 @@ noContentRouter method status action = leafRouter route'
env request respond $ \ _output ->
Route $ responseLBS status [] ""
instance {-# OVERLAPPABLE #-}
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
newtype Naked a = Naked a
type family Wrap a where
Wrap (Headers x a) = Headers x a
Wrap a = Naked a
class ExtractHeadersResponse orig wrapped where
type HandlerResponse orig wrapped :: *
type ExtractedValue orig wrapped :: *
extractHeadersResponse :: HandlerResponse orig wrapped -> (([(HeaderName, B.ByteString)]), ExtractedValue orig wrapped)
instance ExtractHeadersResponse a (Naked a) where
type HandlerResponse a (Naked a) = a
type ExtractedValue a (Naked a) = a
extractHeadersResponse :: a -> (([(HeaderName, B.ByteString)]), a)
extractHeadersResponse x = ([], x)
instance GetHeaders (Headers x a) => ExtractHeadersResponse (Headers x a) (Headers x a) where
type HandlerResponse (Headers x a) (Headers x a) = Headers x a
type ExtractedValue (Headers x a) (Headers x a) = a
extractHeadersResponse :: Headers x a -> ([(HeaderName, B.ByteString)], a)
extractHeadersResponse x = (getHeaders x, getResponse x)
instance ( AllCTRender ctypes (ExtractedValue a (Wrap a))
, ReflectMethod method, KnownNat status
, ExtractHeadersResponse a (Wrap a)
, a ~ HandlerResponse a (Wrap a)
) => HasServer (Verb method status ctypes a) context where
type ServerT (Verb method status ctypes a) m = m a
hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status)
instance {-# OVERLAPPING #-}
( AllCTRender ctypes a, ReflectMethod method, KnownNat status
, GetHeaders (Headers h a)
) => HasServer (Verb method status ctypes (Headers h a)) context where
type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
hoistServerWithContext _ _ nt s = nt s
route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
route Proxy _ = methodRouter (extractHeadersResponse @a @(Wrap a)) method (Proxy :: Proxy ctypes) status
where method = reflectMethod (Proxy :: Proxy method)
status = statusFromNat (Proxy :: Proxy status)