@@ -8,42 +8,27 @@
88{-# LANGUAGE TupleSections #-}
99module Servant.Common.Req where
1010
11−import Control.Applicative (liftA2, liftA3)
11+-------------------------------------------------------------------------------
12+import Control.Applicative (liftA2, liftA3)
1213import qualified Data.ByteString.Lazy.Char8 as BL
14+import qualified Data.Map as Map
1315import Data.Maybe
1416import Data.Monoid
15−import qualified Data.Text.Encoding as TE
16−import qualified Data.Text.Lazy.Encoding as LTE
17−-- import qualified Data.Foldable as F
17+import Data.Proxy (Proxy(..))
1818import Data.Text (Text)
1919import qualified Data.Text as T
20+import qualified Data.Text.Encoding as TE
21+import qualified Data.Text.Lazy.Encoding as LTE
2022import qualified Data.Text.Lazy as LT
21−import Data.Proxy
22−import qualified Data.Text as T
23−import qualified Data.Map as Map
24−-- import Data.Monoid
25−-- import Data.String
26−-- import Data.String.Conversions
27−-- import Data.Proxy
28−-- import Data.Text (Text)
29−-- import Data.Text.Encoding
30−-- import Data.Typeable
31−-- import Network.HTTP.Client hiding (Proxy, path)
32−-- import Network.HTTP.Media
33−-- import Network.HTTP.Types
34−-- import qualified Network.HTTP.Types.Header as HTTP
35−-- import Network.URI hiding (path)
36−-- import Servant.API.ContentTypes
37−import Servant.Common.BaseUrl
38−import Servant.API.ContentTypes
39−import Reflex
40−import Reflex.Dom
41−
42−import Servant.API.BasicAuth
43−
44−-- import qualified Network.HTTP.Client as Client
45−
46−import Web.HttpApiData
23+import Reflex
24+import Reflex.Dom
25+import Servant.Common.BaseUrl
26+import Servant.API.ContentTypes
27+import Web.HttpApiData
28+-------------------------------------------------------------------------------
29+import Servant.API.BasicAuth
30+
31+
4732
4833data ReqResult a = ResponseSuccess a XhrResponse
4934 | ResponseFailure Text XhrResponse
@@ -80,8 +65,7 @@ data Req t = Req
8065 , reqPathParts :: [Dynamic t (Either Text Text)]
8166 , qParams :: [(Text, QueryPart t)]
8267 , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
83− -- , reqAccept :: [MediaType] -- TODO ?
84− , headers :: [(Text, Dynamic t Text)]
68+ , headers :: [(Text, Dynamic t (Either Text Text))]
8569 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
8670 }
8771
@@ -93,10 +77,8 @@ prependToPathParts p req =
9377 req { reqPathParts = p : reqPathParts req }
9478
9579addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
96−addHeader name val req = req { headers = headers req
97− <> [(name, fmap (TE.decodeUtf8 . toHeader) val)]
98−-- <> [(name, (fmap . fmap) (decodeUtf8 . toHeader) val)]
99− }
80+addHeader name val req = req { headers = (name, (fmap . fmap) (unpack . toHeader) val) : headers req }
81+
10082
10183-- * performing requests
10284
@@ -114,7 +96,6 @@ performRequest :: forall t m.MonadWidget t m
11496 -- , [HTTP.Header], Response ByteString)
11597performRequest reqMeth req reqHost trigger = do
11698
117− -- Ridiculous functor-juggling! How to clean this up?
11899 let t :: Dynamic t [Either Text Text]
119100 t = sequence $ reverse $ reqPathParts req
120101
@@ -154,21 +135,29 @@ performRequest reqMeth req reqHost trigger = do
154135 x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
155136 | otherwise = x <> "/" <> y
156137
157− xhrHeaders :: Dynamic t [(Text, Text)]
158− xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal
159138
160− mkConfigBody :: [(Text,Text)] -> (Either Text (BL.ByteString, Text)) -> Either Text (XhrRequestConfig LT.Text)
161− mkConfigBody _ rb = case rb of
162− Left e -> Left e
163− (Right (bBytes, bCT)) ->
164− Right $ def { _xhrRequestConfig_sendData = LTE.decodeUtf8 bBytes
139+ xhrHeaders :: Dynamic t (Either Text [(Text, Text)])
140+ xhrHeaders = (fmap sequence . sequence . fmap f . headers) req
141+ where
142+ f = \(headerName, dynam) ->
143+ fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
144+
145+ mkConfigBody :: Either Text [(Text,Text)]
146+ -> (Either Text (BL.ByteString, Text))
147+ -> Either Text XhrRequestConfig
148+ mkConfigBody ehs rb = case (ehs, rb) of
149+ (_, Left e) -> Left e
150+ (Left e, _) -> Left e
151+ (Right hs, Right (bBytes, bCT)) ->
152+ Right $ def { _xhrRequestConfig_sendData = Just (BL.unpack bBytes)
165153 , _xhrRequestConfig_headers =
166− Map.insert "Content-Type" bCT (_xhrRequestConfig_headers def)}
154+ Map.insert "Content-Type" bCT (Map.fromList hs)}
167155
168156 xhrOpts :: Dynamic t (Either Text (XhrRequestConfig LT.Text))
169157 xhrOpts = case reqBody req of
170− Nothing -> fmap (\h -> Right $ XhrRequestConfig
171− (Map.fromList h) Nothing Nothing Nothing "") xhrHeaders
158+ Nothing -> ffor xhrHeaders $ \case
159+ Left e -> Left e
160+ Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs }
172161 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
173162
174163 mkAuth :: Maybe BasicAuthData -> Either Text (XhrRequestConfig x) -> Either Text (XhrRequestConfig x)
@@ -178,7 +167,8 @@ performRequest reqMeth req reqHost trigger = do
178167 { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
179168 , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
180169
181− addAuth :: Dynamic t (Either Text (XhrRequestConfig x)) -> Dynamic t (Either Text (XhrRequestConfig x))
170+ addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
171+ -> Dynamic t (Either Text (XhrRequestConfig x))
182172 addAuth xhr = case authData req of
183173 Nothing -> xhr
184174 Just auth -> liftA2 mkAuth auth xhr
@@ -197,21 +187,6 @@ performRequest reqMeth req reqHost trigger = do
197187
198188 return (resps, badReqs)
199189
200− -- let oneNamedPair :: String -> [QueryPart] -> String
201− -- oneNamedPair pName ps =
202− -- T.intercalate "&" $ ffor ps $ \case
203− -- QueryPartParam pval -> pName <> "=" <> pval
204− -- QueryPartFlag True -> pName
205− -- QueryPartFlag False -> error "Impossible case"
206−
207− -- t' :: [Behavior t String]
208− -- t' = map (\(pName, pVals) -> fmap (oneNamedPair pName) pVals)
209− -- (qParams req)
210−
211− -- queryString :: Behavior t String
212− -- queryString = fmap (T.intercalate "&") (sequence t')
213−
214− -- xhrUrl = (liftA2 . liftA2) (\u q -> u <> '?' : q) urlPath (fmap Just queryString)
215190
216191-- TODO implement
217192-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]
@@ -240,83 +215,3 @@ performRequestCT ct reqMeth req reqHost trigger = do
240215
241216note :: e -> Maybe a -> Either e a
242217note e = maybe (Left e) Right
243−
244−
245− -- partialRequest <- liftIO $ reqToRequest req reqHost
246−
247− -- let request = partialRequest { Client.method = reqMethod
248− -- , checkStatus = \ _status _headers _cookies -> Nothing
249− -- , qs :: QueryText
250− -- , qs :: QueryText
251− -- }
252−
253− -- eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
254− -- case eResponse of
255− -- Left err ->
256− -- throwE . ConnectionError $ SomeException err
257−
258− -- Right response -> do
259− -- let status = Client.responseStatus response
260− -- body = Client.responseBody response
261− -- hdrs = Client.responseHeaders response
262− -- status_code = statusCode status
263− -- ct <- case lookup "Content-Type" $ Client.responseHeaders response of
264− -- Nothing -> pure $ "application/octet-stream"
265− -- Just t -> case parseAccept t of
266− -- Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
267− -- Just t' -> pure t'
268− -- unless (status_code >= 200 && status_code < 300) $
269− -- throwE $ FailureResponse status ct body
270− -- return (status_code, body, ct, hdrs, response)
271−
272−
273−-- TODO implement
274−-- performRequestCT :: (MimeUnrender ct result, Reflex t) =>
275−-- Proxy ct -> String -> Req t -> BaseUrl -> Event t ()
276−-- -> m (Event t (Maybe result, XhrResponse)) -- ExceptT ServantError IO ([HTTP.Header], result)
277−-- performRequestCT ct reqMethod req reqHost = do
278−-- let acceptCT = contentType ct
279−-- (_status, respBody, respCT, hdrs, _response) <-
280−-- performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
281−-- unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
282−-- case mimeUnrender ct respBody of
283−-- Left err -> throwE $ DecodeFailure err respCT respBody
284−-- Right val -> return (hdrs, val)
285−
286−-- catchConnectionError :: IO a -> IO (Either ServantError a)
287−-- catchConnectionError action =
288−-- catch (Right <$> action) $ \e ->
289−-- pure . Left . ConnectionError $ SomeException (e :: HttpException)
290−
291−-- setRQBody :: ByteString -> String -> Req -> Req
292−-- setRQBody b t req = req { reqBody = Just (b, t) }
293−
294−-- TODO: Helpful soon!
295−-- reqToRequest :: (Reflex t, Functor m, MonadThrow m) => Req t -> BaseUrl -> m Request
296−-- reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
297−-- setheaders . setAccept . setrqb . setQS <$> parseUrl url
298−
299−-- where url = show $ nullURI { uriScheme = case reqScheme of
300−-- Http -> "http:"
301−-- Https -> "https:"
302−-- , uriAuthority = Just $
303−-- URIAuth { uriUserInfo = ""
304−-- , uriRegName = reqHost
305−-- , uriPort = ":" <> show reqPort
306−-- }
307−-- , uriPath = path <> reqPath req
308−-- }
309−
310−-- setrqb r = case reqBody req of
311−-- Nothing -> r
312−-- Just (b,t) -> r { requestBody = RequestBodyLBS b
313−-- , requestHeaders = requestHeaders r
314−-- <> [(hContentType, cs . show $ t)] }
315−-- setQS = setQueryString $ queryTextToQuery (qs req)
316−-- setheaders r = r { requestHeaders = requestHeaders r
317−-- <> fmap toProperHeader (headers req) }
318−-- setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
319−-- <> [("Accept", renderHeader $ reqAccept req)
320−-- | not . null . reqAccept $ req] }
321−-- toProperHeader (name, val) =
322−-- (fromString name, encodeUtf8 val)