@@ -2,6 +2,8 @@
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE RankNTypes #-}
6+
57module Servant.Common.Req where
68
79#if !MIN_VERSION_base(4,8,0)
@@ -65,60 +67,60 @@ data Req = Req
6567defReq :: Req
6668defReq = Req "" [] Nothing [] []
6769
68−appendToPath :: String -> Req -> Req
69−appendToPath p req =
70− req { reqPath = reqPath req ++ "/" ++ p }
71−
72−appendToQueryString :: Text -- ^ param name
73− -> Maybe Text -- ^ param value
74− -> Req
75− -> Req
76−appendToQueryString pname pvalue req =
77− req { qs = qs req ++ [(pname, pvalue)]
78− }
79−
80−addHeader :: ToHttpApiData a => String -> a -> Req -> Req
81−addHeader name val req = req { headers = headers req
82− ++ [(name, decodeUtf8 (toHeader val))]
83− }
84−
85−setRQBody :: ByteString -> MediaType -> Req -> Req
86−setRQBody b t req = req { reqBody = Just (b, t) }
87−
88−reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
89−reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
90− setheaders . setAccept . setrqb . setQS <$> parseUrl url
91−
92− where url = show $ nullURI { uriScheme = case reqScheme of
93− Http -> "http:"
94− Https -> "https:"
95− , uriAuthority = Just $
96− URIAuth { uriUserInfo = ""
97− , uriRegName = reqHost
98− , uriPort = ":" ++ show reqPort
99− }
100− , uriPath = path ++ reqPath req
101− }
102−
103− setrqb r = case reqBody req of
104− Nothing -> r
105− Just (b,t) -> r { requestBody = RequestBodyLBS b
106− , requestHeaders = requestHeaders r
107− ++ [(hContentType, cs . show $ t)] }
108− setQS = setQueryString $ queryTextToQuery (qs req)
109− setheaders r = r { requestHeaders = requestHeaders r
110− <> fmap toProperHeader (headers req) }
111− setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
112− <> [("Accept", renderHeader $ reqAccept req)
113− | not . null . reqAccept $ req] }
114− toProperHeader (name, val) =
115− (fromString name, encodeUtf8 val)
116−
117−
118−-- * performing requests
119−
120−displayHttpRequest :: Method -> String
121−displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
70+-- appendToPath :: String -> Req -> Req
71+-- appendToPath p req =
72+-- req { reqPath = reqPath req ++ "/" ++ p }
73+
74+-- appendToQueryString :: Text -- ^ param name
75+-- -> Maybe Text -- ^ param value
76+-- -> Req
77+-- -> Req
78+-- appendToQueryString pname pvalue req =
79+-- req { qs = qs req ++ [(pname, pvalue)]
80+-- }
81+
82+-- addHeader :: ToHttpApiData a => String -> a -> Req -> Req
83+-- addHeader name val req = req { headers = headers req
84+-- ++ [(name, decodeUtf8 (toHeader val))]
85+-- }
86+
87+-- setRQBody :: ByteString -> MediaType -> Req -> Req
88+-- setRQBody b t req = req { reqBody = Just (b, t) }
89+
90+-- reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
91+-- reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
92+-- setheaders . setAccept . setrqb . setQS <$> parseUrl url
93+
94+-- where url = show $ nullURI { uriScheme = case reqScheme of
95+-- Http -> "http:"
96+-- Https -> "https:"
97+-- , uriAuthority = Just $
98+-- URIAuth { uriUserInfo = ""
99+-- , uriRegName = reqHost
100+-- , uriPort = ":" ++ show reqPort
101+-- }
102+-- , uriPath = path ++ reqPath req
103+-- }
104+
105+-- setrqb r = case reqBody req of
106+-- Nothing -> r
107+-- Just (b,t) -> r { requestBody = RequestBodyLBS b
108+-- , requestHeaders = requestHeaders r
109+-- ++ [(hContentType, cs . show $ t)] }
110+-- setQS = setQueryString $ queryTextToQuery (qs req)
111+-- setheaders r = r { requestHeaders = requestHeaders r
112+-- <> fmap toProperHeader (headers req) }
113+-- setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
114+-- <> [("Accept", renderHeader $ reqAccept req)
115+-- | not . null . reqAccept $ req] }
116+-- toProperHeader (name, val) =
117+-- (fromString name, encodeUtf8 val)
118+
119+
120+-- -- * performing requests
121+
122+-- displayHttpRequest :: Method -> String
123+-- displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
122124
123125performRequest = undefined
124126performRequestCT = undefined
@@ -129,16 +131,16 @@ performRequestNoBody = undefined
129131-- , [HTTP.Header], Response ByteString)
130132-- performRequest reqMethod req reqHost manager = do
131133-- partialRequest <- liftIO $ reqToRequest req reqHost
132−--
134+
133135-- let request = partialRequest { Client.method = reqMethod
134136-- , checkStatus = \ _status _headers _cookies -> Nothing
135137-- }
136−--
138+
137139-- eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
138140-- case eResponse of
139141-- Left err ->
140142-- throwE . ConnectionError $ SomeException err
141−--
143+
142144-- Right response -> do
143145-- let status = Client.responseStatus response
144146-- body = Client.responseBody response
@@ -152,7 +154,7 @@ performRequestNoBody = undefined
152154-- unless (status_code >= 200 && status_code < 300) $
153155-- throwE $ FailureResponse status ct body
154156-- return (status_code, body, ct, hrds, response)
155−--
157+
156158--
157159-- performRequestCT :: MimeUnrender ct result =>
158160-- Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)