@@ -292,26 +292,42 @@ noContentRouter method status action = leafRouter route'
292 env request respond $ \ _output ->
292 env request respond $ \ _output ->
293 Route $ responseLBS status [] ""
293 Route $ responseLBS status [] ""
295−instance {-# OVERLAPPABLE #-}
295+newtype Naked a = Naked a
296− ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
297− ) => HasServer (Verb method status ctypes a) context where
299− type ServerT (Verb method status ctypes a) m = m a
297+type family Wrap a where
300− hoistServerWithContext _ _ nt s = nt s
298+ Wrap (Headers x a) = Headers x a
302− route Proxy _ = methodRouter ([],) method (Proxy :: Proxy ctypes) status
301+class ExtractHeadersResponse orig wrapped where
303− where method = reflectMethod (Proxy :: Proxy method)
302+ type HandlerResponse orig wrapped :: *
304− status = statusFromNat (Proxy :: Proxy status)
303+ type ExtractedValue orig wrapped :: *
306−instance {-# OVERLAPPING #-}
305+ extractHeadersResponse :: HandlerResponse orig wrapped -> (([(HeaderName, B.ByteString)]), ExtractedValue orig wrapped)
307− ( AllCTRender ctypes a, ReflectMethod method, KnownNat status
308− , GetHeaders (Headers h a)
309− ) => HasServer (Verb method status ctypes (Headers h a)) context where
307+instance ExtractHeadersResponse a (Naked a) where
308+ type HandlerResponse a (Naked a) = a
309+ type ExtractedValue a (Naked a) = a
311+ extractHeadersResponse :: a -> (([(HeaderName, B.ByteString)]), a)
312+ extractHeadersResponse x = ([], x)
314+instance GetHeaders (Headers x a) => ExtractHeadersResponse (Headers x a) (Headers x a) where
315+ type HandlerResponse (Headers x a) (Headers x a) = Headers x a
316+ type ExtractedValue (Headers x a) (Headers x a) = a
318+ extractHeadersResponse :: Headers x a -> ([(HeaderName, B.ByteString)], a)
319+ extractHeadersResponse x = (getHeaders x, getResponse x)
321+instance ( AllCTRender ctypes (ExtractedValue a (Wrap a))
322+ , ReflectMethod method, KnownNat status
323+ , ExtractHeadersResponse a (Wrap a)
324+ , a ~ HandlerResponse a (Wrap a)
325+ ) => HasServer (Verb method status ctypes a) context where
311− type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a)
327+ type ServerT (Verb method status ctypes a) m = m a
312 hoistServerWithContext _ _ nt s = nt s
328 hoistServerWithContext _ _ nt s = nt s
314− route Proxy _ = methodRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy ctypes) status
330+ route Proxy _ = methodRouter (extractHeadersResponse @a @(Wrap a)) method (Proxy :: Proxy ctypes) status
315 where method = reflectMethod (Proxy :: Proxy method)
331 where method = reflectMethod (Proxy :: Proxy method)
316 status = statusFromNat (Proxy :: Proxy status)
332 status = statusFromNat (Proxy :: Proxy status)