@@ -22,95 +22,95 @@ module Servant.Server.UVerb
2222 )
2323where
2424
25−import qualified Data.ByteString as B
26−import Data.Proxy (Proxy (Proxy))
27−import Data.SOP (I (I))
28−import Data.SOP.Constraint (All, And)
29−import Data.String.Conversions (LBS, cs)
30−import Network.HTTP.Types (Status, HeaderName, hContentType)
31−import Network.Wai (responseLBS, Request)
32−import Servant.API (ReflectMethod, reflectMethod)
33−import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
34−import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
35−import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
36−import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)
25+-- import qualified Data.ByteString as B
26+-- import Data.Proxy (Proxy (Proxy))
27+-- import Data.SOP (I (I))
28+-- import Data.SOP.Constraint (All, And)
29+-- import Data.String.Conversions (LBS, cs)
30+-- import Network.HTTP.Types (Status, HeaderName, hContentType)
31+-- import Network.Wai (responseLBS, Request)
32+-- import Servant.API (ReflectMethod, reflectMethod)
33+-- import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
34+-- import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))
35+-- import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf)
36+import Servant.Server.Internal (respond, IsServerResource)
3737
3838
39−-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
40−-- and will construct a union value in an 'Applicative' (eg. 'Server').
41−respond ::
42− forall (x :: *) (xs :: [*]) (f :: * -> *).
43− (Applicative f, HasStatus x, IsMember x xs) =>
44− x ->
45− f (Union xs)
46−respond = pure . inject . I
39+-- -- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union,
40+-- -- and will construct a union value in an 'Applicative' (eg. 'Server').
41+-- respond ::
42+-- forall (x :: *) (xs :: [*]) (f :: * -> *).
43+-- (Applicative f, HasStatus x, IsMember x xs) =>
44+-- x ->
45+-- f (Union xs)
46+-- respond = pure . inject . I
4747
48−class IsServerResource (cts :: [*]) a where
49− resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
50− resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
48+-- class IsServerResource (cts :: [*]) a where
49+-- resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)
50+-- resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)]
5151
52−instance {-# OVERLAPPABLE #-} AllCTRender cts a
53− => IsServerResource cts a where
54− resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
55− resourceHeaders _ _ = []
52+-- instance {-# OVERLAPPABLE #-} AllCTRender cts a
53+-- => IsServerResource cts a where
54+-- resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res
55+-- resourceHeaders _ _ = []
5656
57−instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
58− => IsServerResource cts (Headers h a) where
59− resourceResponse request p res = resourceResponse request p (getResponse res)
60− resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
57+-- instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))
58+-- => IsServerResource cts (Headers h a) where
59+-- resourceResponse request p res = resourceResponse request p (getResponse res)
60+-- resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)
6161
62−instance {-# OVERLAPPING #-} IsServerResource cts a
63− => IsServerResource cts (WithStatus n a) where
64− resourceResponse request p (WithStatus x) = resourceResponse request p x
65− resourceHeaders cts (WithStatus x) = resourceHeaders cts x
62+-- instance {-# OVERLAPPING #-} IsServerResource cts a
63+-- => IsServerResource cts (WithStatus n a) where
64+-- resourceResponse request p (WithStatus x) = resourceResponse request p x
65+-- resourceHeaders cts (WithStatus x) = resourceHeaders cts x
6666
67−encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
68− => Request -> Proxy cts -> a
69− -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
70−encodeResource request cts res = (statusOf (Proxy @a),
71− resourceResponse request cts res,
72− resourceHeaders cts res)
67+-- encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)
68+-- => Request -> Proxy cts -> a
69+-- -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
70+-- encodeResource request cts res = (statusOf (Proxy @a),
71+-- resourceResponse request cts res,
72+-- resourceHeaders cts res)
7373
74−type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
74+-- type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus
7575
76−instance
77− ( ReflectMethod method,
78− AllMime contentTypes,
79− All (IsServerResourceWithStatus contentTypes) as,
80− Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
81− -- without; client is a bit of a corner case, because it dispatches
82− -- the parser based on the status code. with this uniqueness
83− -- constraint it won't have to run more than one parser in weird
84− -- corner cases.
85− ) =>
86− HasServer (UVerb method contentTypes as) context
87− where
88− type ServerT (UVerb method contentTypes as) m = m (Union as)
76+-- instance
77+-- ( ReflectMethod method,
78+-- AllMime contentTypes,
79+-- All (IsServerResourceWithStatus contentTypes) as,
80+-- Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
81+-- -- without; client is a bit of a corner case, because it dispatches
82+-- -- the parser based on the status code. with this uniqueness
83+-- -- constraint it won't have to run more than one parser in weird
84+-- -- corner cases.
85+-- ) =>
86+-- HasServer (UVerb method contentTypes as) context
87+-- where
88+-- type ServerT (UVerb method contentTypes as) m = m (Union as)
8989
90− hoistServerWithContext _ _ nt s = nt s
90+-- hoistServerWithContext _ _ nt s = nt s
9191
92− route ::
93− forall env.
94− Proxy (UVerb method contentTypes as) ->
95− Context context ->
96− Delayed env (Server (UVerb method contentTypes as)) ->
97− Router env
98− route _proxy _ctx action = leafRouter route'
99− where
100− method = reflectMethod (Proxy @method)
101− route' env request cont = do
102− let action' :: Delayed env (Handler (Union as))
103− action' =
104− action
105− `addMethodCheck` methodCheck method request
106− `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
92+-- route ::
93+-- forall env.
94+-- Proxy (UVerb method contentTypes as) ->
95+-- Context context ->
96+-- Delayed env (Server (UVerb method contentTypes as)) ->
97+-- Router env
98+-- route _proxy _ctx action = leafRouter route'
99+-- where
100+-- method = reflectMethod (Proxy @method)
101+-- route' env request cont = do
102+-- let action' :: Delayed env (Handler (Union as))
103+-- action' =
104+-- action
105+-- `addMethodCheck` methodCheck method request
106+-- `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
107107
108− runAction action' env request cont $ \(output :: Union as) -> do
109− let cts = Proxy @contentTypes
110− pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
111− pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
112− case pickResource output of
113− (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
114− (status, Just (contentT, body), headers) ->
115− let bdy = if allowedMethodHead method request then "" else body
116− in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
108+-- runAction action' env request cont $ \(output :: Union as) -> do
109+-- let cts = Proxy @contentTypes
110+-- pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])
111+-- pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts)
112+-- case pickResource output of
113+-- (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
114+-- (status, Just (contentT, body), headers) ->
115+-- let bdy = if allowedMethodHead method request then "" else body
116+-- in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy