f44ab3d · typeable/servant

git.iko.soy/typeable/servant

Cleanup

commitf44ab3d083c66828b73ed837f830fedc268e4008 authorJulian K. Arni <jkarni@gmail.com> dateThu 7 Sep 2017, 16:11 (9 years ago) parent05db359

2 files changed+8−90

compare with master

unifiedsplit

servant-client-core/src/Servant/Client/Core/Internal/Request.hs−50 servant-client/src/Servant/Client/HttpClient.hs+8−40

servant-client-core/src/Servant/Client/Core/Internal/Request.hs−50

@@ -107,53 +107,3 @@ setRequestBodyLBS b t req

107107--

108108setRequestBody :: RequestBody -> MediaType -> Request -> Request

109109setRequestBody b t req = req { requestBody = Just (b, t) }

110−

111−{-reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request-}

112−{-reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =-}

113− {-setheaders . setAccept . setrqb . setQS <$> parseRequest url-}

114−

115− {-where url = show $ nullURI { uriScheme = case reqScheme of-}

116− {-Http -> "http:"-}

117− {-Https -> "https:"-}

118− {-, uriAuthority = Just $-}

119− {-URIAuth { uriUserInfo = ""-}

120− {-, uriRegName = reqHost-}

121− {-, uriPort = ":" ++ show reqPort-}

122− {-}-}

123− {-, uriPath = fullPath-}

124− {-}-}

125− {-fullPath = path ++ cs (Builder.toLazyByteString (reqPath req))-}

126−

127− {-setrqb r = case reqBody req of-}

128− {-Nothing -> r-}

129− {-Just (b,t) -> r { requestBody = b-}

130− {-, requestHeaders = requestHeaders r-}

131− {-++ [(hContentType, cs . show $ t)] }-}

132− {-setQS = setQueryString $ queryTextToQuery (qs req)-}

133− {-setheaders r = r { requestHeaders = requestHeaders r-}

134− {-<> fmap toProperHeader (headers req) }-}

135− {-setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)-}

136− {-<> [("Accept", renderHeader $ reqAccept req)-}

137− {-| not . null . reqAccept $ req] }-}

138− {-toProperHeader (name, val) =-}

139− {-(fromString name, encodeUtf8 val)-}

140−

141−

142− {- #if !MIN_VERSION_http_client(0,4,30)-}

143− {--- 'parseRequest' is introduced in http-client-0.4.30-}

144− {--- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses-}

145− {----}

146− {--- See for implementations:-}

147− {--- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest-}

148− {--- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest-}

149− {-parseRequest :: MonadThrow m => String -> m Request-}

150− {-parseRequest url = liftM disableStatusCheck (parseUrl url)-}

151− {-where-}

152− {-disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }-}

153− {- #endif-}

154−

155−

156− {--- * performing requests-}

157−

158− {-displayHttpRequest :: Method -> String-}

159− {-displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"-}

servant-client/src/Servant/Client/HttpClient.hs+8−40

@@ -20,33 +20,24 @@ import Control.Monad

2020import Control.Monad.Base (MonadBase (..))

2121import Control.Monad.Catch (MonadCatch, MonadThrow)

2222import Control.Monad.Error.Class (MonadError (..))

23+import Control.Monad.Reader

24+import Control.Monad.Trans.Control (MonadBaseControl (..))

25+import Control.Monad.Trans.Except

2326import Data.ByteString.Builder (toLazyByteString)

2427import qualified Data.ByteString.Lazy as BSL

28+import Data.Foldable (toList)

29+import Data.Functor.Alt (Alt (..))

2530import Data.Monoid ((<>))

2631import Data.String (fromString)

2732import qualified Data.Text as T

2833import GHC.Exts (fromList)

29−{-import Control.Monad.IO.Class ()-}

30−import Control.Monad.Reader

31−import Control.Monad.Trans.Control (MonadBaseControl (..))

32−import Control.Monad.Trans.Except

33−{-import Data.ByteString.Lazy hiding (any, elem, filter, map,-}

34− {-null, pack)-}

35−import Data.Foldable (toList)

36−import Data.Functor.Alt (Alt (..))

37−import Data.Proxy

38−{-import Data.String.Conversions (cs)-}

3934import GHC.Generics

40−import Network.HTTP.Media (parseAccept, renderHeader, (//))

35+import Network.HTTP.Media (renderHeader)

4136import Network.HTTP.Types (hContentType, renderQuery,

4237 statusCode)

43−{-import Servant.API.ContentTypes-}

4438import Servant.Client.Core

45−{-import Servant.Common.BaseUrl-}

46−{-import Servant.Common.Req-}

4739

4840import qualified Network.HTTP.Client as Client

49−{-import qualified Network.HTTP.Types.Header as HTTP-}

5041

5142data ClientEnv

5243 = ClientEnv

@@ -97,15 +88,8 @@ performRequest req = do

9788 Left err -> throwError $ err

9889 Right response -> do

9990 let status = Client.responseStatus response

100− body = Client.responseBody response

101− hdrs = Client.responseHeaders response

10291 status_code = statusCode status

10392 ourResponse = clientResponseToReponse response

104− ct <- case lookup "Content-Type" $ Client.responseHeaders response of

105− Nothing -> pure $ "application"//"octet-stream"

106− Just t -> case parseAccept t of

107− Nothing -> throwError $ InvalidContentTypeHeader ourResponse

108− Just t' -> pure t'

10993 unless (status_code >= 200 && status_code < 300) $

11094 throwError $ FailureResponse ourResponse

11195 return ourResponse

@@ -135,24 +119,8 @@ requestToClientRequest burl r = Client.defaultRequest

135119 where

136120 (body, contentTypeHdr) = case requestBody r of

137121 Nothing -> (Client.RequestBodyLBS "", Nothing)

138− Just (RequestBodyLBS body, typ)

139− -> (Client.RequestBodyLBS body, Just (hContentType, renderHeader typ))

140−

141−{-performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req-}

142− {--> ClientM ([HTTP.Header], result)-}

143−{-performRequestCT ct reqMethod req = do-}

144− {-let acceptCTS = contentTypes ct-}

145− {-(_status, respBody, respCT, hdrs, _response) <--}

146− {-performRequest reqMethod (req { reqAccept = toList acceptCTS })-}

147− {-unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody-}

148− {-case mimeUnrender ct respBody of-}

149− {-Left err -> throwError $ DecodeFailure err respCT respBody-}

150− {-Right val -> return (hdrs, val)-}

151−

152−{-performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]-}

153−{-performRequestNoBody reqMethod req = do-}

154− {-(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req-}

155− {-return hdrs-}

122+ Just (RequestBodyLBS body', typ)

123+ -> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))

156124

157125catchConnectionError :: IO a -> IO (Either ServantError a)

158126catchConnectionError action =