@@ -1,183 +0,0 @@
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
10−module Servant.Common.Req where
15−import Control.Exception
16−import Control.Monad.Catch (MonadThrow)
17−import Data.Semigroup ((<>))
19−import Control.Monad.IO.Class ()
20−import qualified Data.ByteString.Builder as BS
21−import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
23−import Data.String.Conversions (cs)
24−import Data.Text (Text)
25−import Data.Text.Encoding
27−import Network.HTTP.Media
28−import Network.HTTP.Types
29−import Network.HTTP.Client hiding (Proxy, path)
30−import Network.URI hiding (path)
31−import Servant.Common.BaseUrl
33−import Web.HttpApiData
37− { failingRequest :: UrlReq
38− , responseStatus :: Status
39− , responseContentType :: MediaType
40− , responseBody :: ByteString
43− { decodeError :: String
44− , responseContentType :: MediaType
45− , responseBody :: ByteString
47− | UnsupportedContentType
48− { responseContentType :: MediaType
49− , responseBody :: ByteString
51− | InvalidContentTypeHeader
52− { responseContentTypeHeader :: ByteString
53− , responseBody :: ByteString
56− { connectionError :: SomeException
58− deriving (Show, Typeable)
60−instance Eq ServantError where
61− FailureResponse _ a b c == FailureResponse _ x y z =
62− (a, b, c) == (x, y, z)
63− DecodeFailure a b c == DecodeFailure x y z =
64− (a, b, c) == (x, y, z)
65− UnsupportedContentType a b == UnsupportedContentType x y =
67− InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
69− ConnectionError a == ConnectionError x =
73−instance Exception ServantError
75−data UrlReq = UrlReq BaseUrl Req
77−instance Show UrlReq where
78− show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req)
80− path = cs (BS.toLazyByteString (reqPath req))
83− { reqPath :: BS.Builder
85− , reqBody :: Maybe (RequestBody, MediaType)
86− , reqAccept :: [MediaType]
87− , headers :: [(String, Text)]
91−defReq = Req "" [] Nothing [] []
93−appendToPath :: String -> Req -> Req
95− req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p }
97−appendToQueryString :: Text -- ^ param name
98− -> Maybe Text -- ^ param value
101−appendToQueryString pname pvalue req =
102− req { qs = qs req ++ [(pname, pvalue)]
105−addHeader :: ToHttpApiData a => String -> a -> Req -> Req
106−addHeader name val req = req { headers = headers req
107− ++ [(name, decodeUtf8 (toHeader val))]
110−-- | Set body and media type of the request being constructed.
112−-- The body is set to the given bytestring using the 'RequestBodyLBS'
115−{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-}
116−setRQBody :: ByteString -> MediaType -> Req -> Req
117−setRQBody = setReqBodyLBS
119−-- | Set body and media type of the request being constructed.
121−-- The body is set to the given bytestring using the 'RequestBodyLBS'
126−setReqBodyLBS :: ByteString -> MediaType -> Req -> Req
127−setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) }
129−-- | Set body and media type of the request being constructed.
133−setReqBody :: RequestBody -> MediaType -> Req -> Req
134−setReqBody b t req = req { reqBody = Just (b, t) }
136−reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
137−reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
138− setheaders . setAccept . setrqb . setQS <$> parseRequest url
140− where url = show $ nullURI { uriScheme = case reqScheme of
143− , uriAuthority = Just $
144− URIAuth { uriUserInfo = ""
145− , uriRegName = reqHost
146− , uriPort = ":" ++ show reqPort
148− , uriPath = fullPath
150− fullPath = path ++ cs (BS.toLazyByteString (reqPath req))
152− setrqb r = case reqBody req of
154− Just (b,t) -> r { requestBody = b
155− , requestHeaders = requestHeaders r
156− ++ [(hContentType, cs . show $ t)] }
157− setQS = setQueryString $ queryTextToQuery (qs req)
158− setheaders r = r { requestHeaders = requestHeaders r
159− <> fmap toProperHeader (headers req) }
160− setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
161− <> [("Accept", renderHeader $ reqAccept req)
162− | not . null . reqAccept $ req] }
163− toProperHeader (name, val) =
164− (fromString name, encodeUtf8 val)
166−#if !MIN_VERSION_http_client(0,4,30)
167−-- 'parseRequest' is introduced in http-client-0.4.30
168−-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses
170−-- See for implementations:
171−-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest
172−-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest
173−parseRequest :: MonadThrow m => String -> m Request
174−parseRequest url = liftM disableStatusCheck (parseUrl url)
176− disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
180−-- * performing requests
182−displayHttpRequest :: Method -> String
183−displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"