From f11dd6b071739e2c975d1a3e2d96ff069ad3fefc Mon Sep 17 00:00:00 2001 From: buckie Date: Mon, 11 May 2015 23:24:47 -0400 Subject: [PATCH 1/2] Added 'withHeader' versions for the convinience functions... sometimes we are stuck in enterprise land and need wierd headers Signed-off-by: buckie --- lib/Network/Http/Inconvenience.hs | 125 ++++++++++++++++++++++++++---- 1 file changed, 112 insertions(+), 13 deletions(-) diff --git a/lib/Network/Http/Inconvenience.hs b/lib/Network/Http/Inconvenience.hs index e908769..ea00243 100644 --- a/lib/Network/Http/Inconvenience.hs +++ b/lib/Network/Http/Inconvenience.hs @@ -21,10 +21,14 @@ module Network.Http.Inconvenience ( modifyContextSSL, establishConnection, get, + getWithHeader, post, + postWithHeader, postForm, + postFormWithHeader, encodedFormBody, put, + putWithHeader, baselineContextSSL, concatHandler', jsonHandler, @@ -301,9 +305,43 @@ get :: URL -> (Response -> InputStream ByteString -> IO β) -- ^ Handler function to receive the response from the server. -> IO β -get r' handler = getN 0 r' handler +get r' handler = getN 0 r' [] handler -getN n r' handler = do +-- +-- | The same as 'get' but with the ability to add on generic additional +-- headers. Be aware that these extras are set after the "known" header +-- args are and will override those already specified should they overlap. +-- +-- By default, 'setAccept' @*/*@ will be first specified. Only after will +-- the rest of the name=value Header pairs be specified via 'setHeader'. +-- Should any names collide, the last one specified will be one used +-- in the Header of the request. +-- +-- For example, the following are wholly equivilent: +-- +-- > get "foo.com/bar" +-- > getWithHeader "foo.com/bar" [] +-- > getWithHeader "foo.com/bar" [("Accept", "*/*")] +-- +-- In this example, "Accept" could be overwriten (intentionally or +-- unintentionally) via: +-- +-- > getWithHeader "foo.com/bar" [("Accept", "text/json")] +-- +-- Though appropriate for protoypes a more typesafe system is provided +-- via 'buildRequest1' or 'buildRequest' and is thus recommended. See +-- the aforementioned as well as 'setHeader' for more details. +-- +getWithHeader :: URL + -- ^ Resource to GET from. + -> [(ByteString, ByteString)] + -- ^ List of Header key=value pairs each applied via 'setHeader' + -> (Response -> InputStream ByteString -> IO β) + -- ^ Handler function to receive the response from the server. + -> IO β +getWithHeader r' h handler = getN 0 r' h handler + +getN n r' h handler = do bracket (establish u) (teardown) @@ -317,12 +355,12 @@ getN n r' handler = do q = buildRequest1 $ do http GET (path u) setAccept "*/*" + mapM (uncurry setHeader) h process c = do sendRequest c q emptyBody - receiveResponse c (wrapRedirect u n handler) - + receiveResponse c (wrapRedirect u header n handler) {- This is fairly simple-minded. Improvements could include reusing @@ -334,15 +372,16 @@ getN n r' handler = do wrapRedirect :: URI + -> [(ByteString, ByteString)] -> Int -> (Response -> InputStream ByteString -> IO β) -> Response -> InputStream ByteString -> IO β -wrapRedirect u n handler p i = do +wrapRedirect u h n handler p i = do if (s == 301 || s == 302 || s == 303 || s == 307) then case lm of - Just l -> getN n' (splitURI u l) handler + Just l -> getN n' (splitURI u l) h handler Nothing -> handler p i else handler p i where @@ -352,7 +391,6 @@ wrapRedirect u n handler p i = do then n + 1 else throw $! TooManyRedirects n - splitURI :: URI -> URL -> URL splitURI old new' = let @@ -393,7 +431,26 @@ post :: URL -> (Response -> InputStream ByteString -> IO β) -- ^ Handler function to receive the response from the server. -> IO β -post r' t body handler = do +post r' t body handler = postWithHeader r' t [] body handler + +-- +-- | The same as 'post' but with the ability to add on generic additional +-- headers. By default, 'postWithHeader' specifies 'setAccept' @*/*@ and 'setContentType' first. +-- +-- Beware of Header name collisions. Please refer to 'getWithHeader' for more information. +-- +postWithHeader :: URL + -- ^ Resource to POST to. + -> ContentType + -- ^ MIME type of the request body being sent. + -> [(ByteString, ByteString)] + -- ^ List of Header name=value pairs each applied via 'setHeader' + -> (OutputStream Builder -> IO α) + -- ^ Handler function to write content to server. + -> (Response -> InputStream ByteString -> IO β) + -- ^ Handler function to receive the response from the server. + -> IO β +postWithHeader r' t h body handler = do bracket (establish u) (teardown) @@ -407,6 +464,7 @@ post r' t body handler = do http POST (path u) setAccept "*/*" setContentType t + mapM_ (uncurry setHeader) h process c = do _ <- sendRequest c q body @@ -414,7 +472,6 @@ post r' t body handler = do x <- receiveResponse c handler return x - -- -- | Send form data to a server via an HTTP POST request. This is the -- usual use case; most services expect the body to be MIME type @@ -430,7 +487,27 @@ postForm -> (Response -> InputStream ByteString -> IO β) -- ^ Handler function to receive the response from the server. -> IO β -postForm r' nvs handler = do +postForm r' nvs handler = postFormWithHeader r' [] nvs handler + +-- +-- | The same as 'postForm' but with the ability to add on generic additional +-- headers. By default, 'postFormWithHeader' specifies 'setAccept' @*/*@ and +-- 'setContentType' @"application/x-www-form-urlencoded"@. +-- +-- Beware of Header name collisions. Please refer to 'getWithHeader' for more +-- information. +-- +postFormWithHeader + :: URL + -- ^ Resource to POST to. + -> [(ByteString, ByteString)] + -- ^ List of form body name=value pairs. Will be sent URL-encoded. + -> [(ByteString, ByteString)] + -- ^ List of additional Header name=value pairs each applied via 'setHeader' + -> (Response -> InputStream ByteString -> IO β) + -- ^ Handler function to receive the response from the server. + -> IO β +postFormWithHeader r' nvs h handler = do bracket (establish u) (teardown) @@ -444,6 +521,7 @@ postForm r' nvs handler = do http POST (path u) setAccept "*/*" setContentType "application/x-www-form-urlencoded" + mapM_ (uncurry setHeader) h process c = do _ <- sendRequest c q (encodedFormBody nvs) @@ -451,7 +529,6 @@ postForm r' nvs handler = do x <- receiveResponse c handler return x - -- -- | Specify name/value pairs to be sent to the server in the manner -- used by web browsers when submitting a form via a POST request. @@ -500,7 +577,28 @@ put :: URL -> (Response -> InputStream ByteString -> IO β) -- ^ Handler function to receive the response from the server. -> IO β -put r' t body handler = do +put r' t body handler = putWithHeader r' t [] body handler + +-- +-- | The same as 'put' but with the ability to add on generic additional +-- headers. By default, 'postWithHeader' specifies 'setAccept' @*/*@ and +-- 'setContentType' first. +-- +-- Beware of Header name collisions. Please refer to 'getWithHeader' for +-- more information. +-- +putWithHeader :: URL + -- ^ Resource to PUT to. + -> ContentType + -- ^ MIME type of the request body being sent. + -> [(ByteString, ByteString)] + -- ^ List of additional Header name=value pairs each applied via 'setHeader' + -> (OutputStream Builder -> IO α) + -- ^ Handler function to write content to server. + -> (Response -> InputStream ByteString -> IO β) + -- ^ Handler function to receive the response from the server. + -> IO β +putWithHeader r' t h body handler = do bracket (establish u) (teardown) @@ -513,7 +611,8 @@ put r' t body handler = do q = buildRequest1 $ do http PUT (path u) setAccept "*/*" - setHeader "Content-Type" t + setContentType t + mapM_ (uncurry setHeader) h process c = do _ <- sendRequest c q body From dd080e3e48a5bac2d6c00ad468e1fb884627656f Mon Sep 17 00:00:00 2001 From: buckie Date: Tue, 12 May 2015 19:07:36 -0400 Subject: [PATCH 2/2] fixed the comments so this would build Signed-off-by: buckie --- lib/Network/Http/Client.hs | 4 ++++ lib/Network/Http/Inconvenience.hs | 14 +++++++------- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/lib/Network/Http/Client.hs b/lib/Network/Http/Client.hs index 22ec799..9e0b418 100644 --- a/lib/Network/Http/Client.hs +++ b/lib/Network/Http/Client.hs @@ -160,10 +160,14 @@ module Network.Http.Client ( -- URL, get, + getWithHeader, TooManyRedirects, post, + postWithHeader, postForm, + postFormWithHeader, put, + putWithHeader, -- * Secure connections openConnectionSSL, diff --git a/lib/Network/Http/Inconvenience.hs b/lib/Network/Http/Inconvenience.hs index ea00243..26d2e61 100644 --- a/lib/Network/Http/Inconvenience.hs +++ b/lib/Network/Http/Inconvenience.hs @@ -312,7 +312,7 @@ get r' handler = getN 0 r' [] handler -- headers. Be aware that these extras are set after the "known" header -- args are and will override those already specified should they overlap. -- --- By default, 'setAccept' @*/*@ will be first specified. Only after will +-- By default, 'setAccept' @"*/*"@ will be first specified. Only after will -- the rest of the name=value Header pairs be specified via 'setHeader'. -- Should any names collide, the last one specified will be one used -- in the Header of the request. @@ -355,12 +355,12 @@ getN n r' h handler = do q = buildRequest1 $ do http GET (path u) setAccept "*/*" - mapM (uncurry setHeader) h + mapM_ (uncurry setHeader) h process c = do sendRequest c q emptyBody - receiveResponse c (wrapRedirect u header n handler) + receiveResponse c (wrapRedirect u h n handler) {- This is fairly simple-minded. Improvements could include reusing @@ -435,7 +435,7 @@ post r' t body handler = postWithHeader r' t [] body handler -- -- | The same as 'post' but with the ability to add on generic additional --- headers. By default, 'postWithHeader' specifies 'setAccept' @*/*@ and 'setContentType' first. +-- headers. By default, 'postWithHeader' specifies 'setAccept' @"*/*"@ and 'setContentType' first. -- -- Beware of Header name collisions. Please refer to 'getWithHeader' for more information. -- @@ -487,11 +487,11 @@ postForm -> (Response -> InputStream ByteString -> IO β) -- ^ Handler function to receive the response from the server. -> IO β -postForm r' nvs handler = postFormWithHeader r' [] nvs handler +postForm r' nvs handler = postFormWithHeader r' nvs [] handler -- -- | The same as 'postForm' but with the ability to add on generic additional --- headers. By default, 'postFormWithHeader' specifies 'setAccept' @*/*@ and +-- headers. By default, 'postFormWithHeader' specifies 'setAccept' and -- 'setContentType' @"application/x-www-form-urlencoded"@. -- -- Beware of Header name collisions. Please refer to 'getWithHeader' for more @@ -581,7 +581,7 @@ put r' t body handler = putWithHeader r' t [] body handler -- -- | The same as 'put' but with the ability to add on generic additional --- headers. By default, 'postWithHeader' specifies 'setAccept' @*/*@ and +-- headers. By default, 'postWithHeader' specifies 'setAccept' @"*/*"@ and -- 'setContentType' first. -- -- Beware of Header name collisions. Please refer to 'getWithHeader' for