@@ -1,183 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE TypeFamilies #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−
10−module Servant.Common.Req where
11−
12−import Prelude ()
13−import Prelude.Compat
14−
15−import Control.Exception
16−import Control.Monad.Catch (MonadThrow)
17−import Data.Semigroup ((<>))
18−
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)
22−import Data.String
23−import Data.String.Conversions (cs)
24−import Data.Text (Text)
25−import Data.Text.Encoding
26−import Data.Typeable
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
32−
33−import Web.HttpApiData
34−
35−data ServantError
36− = FailureResponse
37− { failingRequest :: UrlReq
38− , responseStatus :: Status
39− , responseContentType :: MediaType
40− , responseBody :: ByteString
41− }
42− | DecodeFailure
43− { decodeError :: String
44− , responseContentType :: MediaType
45− , responseBody :: ByteString
46− }
47− | UnsupportedContentType
48− { responseContentType :: MediaType
49− , responseBody :: ByteString
50− }
51− | InvalidContentTypeHeader
52− { responseContentTypeHeader :: ByteString
53− , responseBody :: ByteString
54− }
55− | ConnectionError
56− { connectionError :: SomeException
57− }
58− deriving (Show, Typeable)
59−
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 =
66− (a, b) == (x, y)
67− InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
68− (a, b) == (x, y)
69− ConnectionError a == ConnectionError x =
70− show a == show x
71− _ == _ = False
72−
73−instance Exception ServantError
74−
75−data UrlReq = UrlReq BaseUrl Req
76−
77−instance Show UrlReq where
78− show (UrlReq url req) = showBaseUrl url ++ path ++ "?" ++ show (qs req)
79− where
80− path = cs (BS.toLazyByteString (reqPath req))
81−
82−data Req = Req
83− { reqPath :: BS.Builder
84− , qs :: QueryText
85− , reqBody :: Maybe (RequestBody, MediaType)
86− , reqAccept :: [MediaType]
87− , headers :: [(String, Text)]
88− }
89−
90−defReq :: Req
91−defReq = Req "" [] Nothing [] []
92−
93−appendToPath :: String -> Req -> Req
94−appendToPath p req =
95− req { reqPath = reqPath req <> "/" <> toEncodedUrlPiece p }
96−
97−appendToQueryString :: Text -- ^ param name
98− -> Maybe Text -- ^ param value
99− -> Req
100− -> Req
101−appendToQueryString pname pvalue req =
102− req { qs = qs req ++ [(pname, pvalue)]
103− }
104−
105−addHeader :: ToHttpApiData a => String -> a -> Req -> Req
106−addHeader name val req = req { headers = headers req
107− ++ [(name, decodeUtf8 (toHeader val))]
108− }
109−
110−-- | Set body and media type of the request being constructed.
111−--
112−-- The body is set to the given bytestring using the 'RequestBodyLBS'
113−-- constructor.
114−--
115−{-# DEPRECATED setRQBody "Use setReqBodyLBS instead" #-}
116−setRQBody :: ByteString -> MediaType -> Req -> Req
117−setRQBody = setReqBodyLBS
118−
119−-- | Set body and media type of the request being constructed.
120−--
121−-- The body is set to the given bytestring using the 'RequestBodyLBS'
122−-- constructor.
123−--
124−-- @since 0.9.2.0
125−--
126−setReqBodyLBS :: ByteString -> MediaType -> Req -> Req
127−setReqBodyLBS b t req = req { reqBody = Just (RequestBodyLBS b, t) }
128−
129−-- | Set body and media type of the request being constructed.
130−--
131−-- @since 0.9.2.0
132−--
133−setReqBody :: RequestBody -> MediaType -> Req -> Req
134−setReqBody b t req = req { reqBody = Just (b, t) }
135−
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
139−
140− where url = show $ nullURI { uriScheme = case reqScheme of
141− Http -> "http:"
142− Https -> "https:"
143− , uriAuthority = Just $
144− URIAuth { uriUserInfo = ""
145− , uriRegName = reqHost
146− , uriPort = ":" ++ show reqPort
147− }
148− , uriPath = fullPath
149− }
150− fullPath = path ++ cs (BS.toLazyByteString (reqPath req))
151−
152− setrqb r = case reqBody req of
153− Nothing -> r
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)
165−
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
169−--
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)
175− where
176− disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
177−#endif
178−
179−
180−-- * performing requests
181−
182−displayHttpRequest :: Method -> String
183−displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"