Cleanup
This commit is contained in:
Julian K. Arni
parent
05db359296
commit
f44ab3d083
2 changed files with 8 additions and 90 deletions
|
|
@ -107,53 +107,3 @@ setRequestBodyLBS b t req
|
|||
--
|
||||
setRequestBody :: RequestBody -> MediaType -> Request -> Request
|
||||
setRequestBody b t req = req { requestBody = Just (b, t) }
|
||||
|
||||
{-reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request-}
|
||||
{-reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =-}
|
||||
{-setheaders . setAccept . setrqb . setQS <$> parseRequest url-}
|
||||
|
||||
{-where url = show $ nullURI { uriScheme = case reqScheme of-}
|
||||
{-Http -> "http:"-}
|
||||
{-Https -> "https:"-}
|
||||
{-, uriAuthority = Just $-}
|
||||
{-URIAuth { uriUserInfo = ""-}
|
||||
{-, uriRegName = reqHost-}
|
||||
{-, uriPort = ":" ++ show reqPort-}
|
||||
{-}-}
|
||||
{-, uriPath = fullPath-}
|
||||
{-}-}
|
||||
{-fullPath = path ++ cs (Builder.toLazyByteString (reqPath req))-}
|
||||
|
||||
{-setrqb r = case reqBody req of-}
|
||||
{-Nothing -> r-}
|
||||
{-Just (b,t) -> r { requestBody = b-}
|
||||
{-, requestHeaders = requestHeaders r-}
|
||||
{-++ [(hContentType, cs . show $ t)] }-}
|
||||
{-setQS = setQueryString $ queryTextToQuery (qs req)-}
|
||||
{-setheaders r = r { requestHeaders = requestHeaders r-}
|
||||
{-<> fmap toProperHeader (headers req) }-}
|
||||
{-setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)-}
|
||||
{-<> [("Accept", renderHeader $ reqAccept req)-}
|
||||
{-| not . null . reqAccept $ req] }-}
|
||||
{-toProperHeader (name, val) =-}
|
||||
{-(fromString name, encodeUtf8 val)-}
|
||||
|
||||
|
||||
{- #if !MIN_VERSION_http_client(0,4,30)-}
|
||||
{--- 'parseRequest' is introduced in http-client-0.4.30-}
|
||||
{--- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses-}
|
||||
{----}
|
||||
{--- See for implementations:-}
|
||||
{--- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest-}
|
||||
{--- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest-}
|
||||
{-parseRequest :: MonadThrow m => String -> m Request-}
|
||||
{-parseRequest url = liftM disableStatusCheck (parseUrl url)-}
|
||||
{-where-}
|
||||
{-disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }-}
|
||||
{- #endif-}
|
||||
|
||||
|
||||
{--- * performing requests-}
|
||||
|
||||
{-displayHttpRequest :: Method -> String-}
|
||||
{-displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"-}
|
||||
|
|
|
|||
|
|
@ -20,33 +20,24 @@ import Control.Monad
|
|||
import Control.Monad.Base (MonadBase (..))
|
||||
import Control.Monad.Catch (MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class (MonadError (..))
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.Foldable (toList)
|
||||
import Data.Functor.Alt (Alt (..))
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String (fromString)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Exts (fromList)
|
||||
{-import Control.Monad.IO.Class ()-}
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Except
|
||||
{-import Data.ByteString.Lazy hiding (any, elem, filter, map,-}
|
||||
{-null, pack)-}
|
||||
import Data.Foldable (toList)
|
||||
import Data.Functor.Alt (Alt (..))
|
||||
import Data.Proxy
|
||||
{-import Data.String.Conversions (cs)-}
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Media (parseAccept, renderHeader, (//))
|
||||
import Network.HTTP.Media (renderHeader)
|
||||
import Network.HTTP.Types (hContentType, renderQuery,
|
||||
statusCode)
|
||||
{-import Servant.API.ContentTypes-}
|
||||
import Servant.Client.Core
|
||||
{-import Servant.Common.BaseUrl-}
|
||||
{-import Servant.Common.Req-}
|
||||
|
||||
import qualified Network.HTTP.Client as Client
|
||||
{-import qualified Network.HTTP.Types.Header as HTTP-}
|
||||
|
||||
data ClientEnv
|
||||
= ClientEnv
|
||||
|
|
@ -97,15 +88,8 @@ performRequest req = do
|
|||
Left err -> throwError $ err
|
||||
Right response -> do
|
||||
let status = Client.responseStatus response
|
||||
body = Client.responseBody response
|
||||
hdrs = Client.responseHeaders response
|
||||
status_code = statusCode status
|
||||
ourResponse = clientResponseToReponse response
|
||||
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
|
||||
Nothing -> pure $ "application"//"octet-stream"
|
||||
Just t -> case parseAccept t of
|
||||
Nothing -> throwError $ InvalidContentTypeHeader ourResponse
|
||||
Just t' -> pure t'
|
||||
unless (status_code >= 200 && status_code < 300) $
|
||||
throwError $ FailureResponse ourResponse
|
||||
return ourResponse
|
||||
|
|
@ -135,24 +119,8 @@ requestToClientRequest burl r = Client.defaultRequest
|
|||
where
|
||||
(body, contentTypeHdr) = case requestBody r of
|
||||
Nothing -> (Client.RequestBodyLBS "", Nothing)
|
||||
Just (RequestBodyLBS body, typ)
|
||||
-> (Client.RequestBodyLBS body, Just (hContentType, renderHeader typ))
|
||||
|
||||
{-performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req-}
|
||||
{--> ClientM ([HTTP.Header], result)-}
|
||||
{-performRequestCT ct reqMethod req = do-}
|
||||
{-let acceptCTS = contentTypes ct-}
|
||||
{-(_status, respBody, respCT, hdrs, _response) <--}
|
||||
{-performRequest reqMethod (req { reqAccept = toList acceptCTS })-}
|
||||
{-unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody-}
|
||||
{-case mimeUnrender ct respBody of-}
|
||||
{-Left err -> throwError $ DecodeFailure err respCT respBody-}
|
||||
{-Right val -> return (hdrs, val)-}
|
||||
|
||||
{-performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]-}
|
||||
{-performRequestNoBody reqMethod req = do-}
|
||||
{-(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req-}
|
||||
{-return hdrs-}
|
||||
Just (RequestBodyLBS body', typ)
|
||||
-> (Client.RequestBodyLBS body', Just (hContentType, renderHeader typ))
|
||||
|
||||
catchConnectionError :: IO a -> IO (Either ServantError a)
|
||||
catchConnectionError action =
|
||||
|
|
|
|||
Loading…
Reference in a new issue