http-streams 0.8.8.1 → 0.8.9.4
raw patch · 10 files changed
+1385/−1203 lines, 10 filesdep +filepathdep +randomdep ~http-commonPVP ok
version bump matches the API change (PVP)
Dependencies added: filepath, random
Dependency ranges changed: http-common
API changes (from Hackage documentation)
+ Network.Http.Client: data Boundary
+ Network.Http.Client: data Part
+ Network.Http.Client: filePart :: FieldName -> Maybe ContentType -> FilePath -> Part
+ Network.Http.Client: inputStreamPart :: FieldName -> Maybe ContentType -> Maybe FilePath -> InputStream ByteString -> Part
+ Network.Http.Client: multipartFormBody :: Boundary -> [Part] -> OutputStream Builder -> IO ()
+ Network.Http.Client: packBoundary :: String -> Boundary
+ Network.Http.Client: randomBoundary :: IO Boundary
+ Network.Http.Client: setContentMultipart :: Boundary -> RequestBuilder ()
+ Network.Http.Client: simpleHandler :: Response -> InputStream ByteString -> IO ByteString
+ Network.Http.Client: simpleHandler' :: Response -> InputStream ByteString -> IO ByteString
+ Network.Http.Client: simplePart :: FieldName -> Maybe ContentType -> ByteString -> Part
+ Network.Http.Client: type FieldName = ByteString
Files
- README.md +1/−11
- http-streams.cabal +5/−2
- lib/Network/Http/Client.hs +15/−3
- lib/Network/Http/Connection.hs +401/−397
- lib/Network/Http/Inconvenience.hs +405/−300
- lib/Network/Http/ResponseParser.hs +52/−60
- lib/Network/Http/Utilities.hs +108/−111
- tests/MockServer.hs +34/−52
- tests/TestSuite.hs +352/−267
- tests/multipart.bin +12/−0
README.md view
@@ -54,14 +54,4 @@ See the documentation in [Network.Http.Client](https://hackage.haskell.org/package/http-streams/docs/Network-Http-Client.html)-for further examples and details of usage of the API. There's also a [blog-post](http://blogs.operationaldynamics.com/andrew/software/haskell/http-streams-introduction)-introducing the library with a discussion of the design and usage.--Change Log-------------Now included in separate file [CHANGELOG](CHANGELOG.md).--AfC-+for further examples and details of usage of the API.
http-streams.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.24 name: http-streams-version: 0.8.8.1+version: 0.8.9.4 synopsis: An HTTP client using io-streams description: An HTTP client, using the Snap Framework's 'io-streams' library to@@ -28,6 +28,7 @@ tests/data-us-gdp.json tests/data-jp-gdp.json tests/statler.jpg+ tests/multipart.bin tests/example1.txt tests/example2.txt tests/example3.txt@@ -52,6 +53,7 @@ blaze-builder >= 0.4, bytestring, case-insensitive,+ filepath, io-streams >= 1.3 && < 1.6, HsOpenSSL >= 0.11.2, openssl-streams >= 1.1 && < 1.4,@@ -60,7 +62,7 @@ text, unordered-containers, aeson,- http-common >= 0.8.2+ http-common >= 0.8.3.4 if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else@@ -112,6 +114,7 @@ network >= 2.6, network-uri >= 2.6, openssl-streams >= 1.1 && < 1.4,+ random, snap-core >= 1.0 && < 1.2, snap-server >= 1.1 && < 1.2, system-fileio >= 0.3.10 && < 0.4,
lib/Network/Http/Client.hs view
@@ -1,7 +1,7 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- Copyright © 2012-2021 Athae Eredh Siniath and Others -- -- The code in this file, and the program it is a part of, is -- made available to you by its authors as open source software:@@ -116,6 +116,10 @@ ContentType, setContentType, setContentLength,+ FieldName,+ Boundary,+ randomBoundary,+ setContentMultipart, setExpectContinue, setTransferEncoding, setHeader,@@ -130,6 +134,11 @@ fileBody, inputStreamBody, encodedFormBody,+ multipartFormBody,+ Part,+ simplePart,+ filePart,+ inputStreamPart, jsonBody, -- * Processing HTTP response@@ -142,8 +151,8 @@ getStatusMessage, getHeader, debugHandler,- concatHandler,- concatHandler',+ simpleHandler,+ simpleHandler', HttpClientError(..), jsonHandler, @@ -179,8 +188,11 @@ Headers, getHeaders, getHeadersFull,+ packBoundary, -- * Deprecated+ concatHandler,+ concatHandler', getRequestHeaders ) where
lib/Network/Http/Connection.hs view
@@ -1,23 +1,22 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd+-- Copyright © 2012-2021 Athae Eredh Siniath and Others -- -- The code in this file, and the program it is a part of, is -- made available to you by its authors as open source software: -- you can redistribute it and/or modify it under the terms of -- the BSD licence. ----{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide, not-home #-} module Network.Http.Connection (- Connection(..),- -- constructors only for testing+ Connection (..),+ -- constructors only for testing makeConnection, withConnection, openConnection,@@ -37,12 +36,16 @@ fileBody, inputStreamBody, debugHandler,- concatHandler+ simpleHandler,+ concatHandler, ) where import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (flush, fromByteString,- toByteString)+import qualified Blaze.ByteString.Builder as Builder (+ flush,+ fromByteString,+ toByteString,+ ) import qualified Blaze.ByteString.Builder.HTTP as Builder (chunkedTransferEncoding, chunkedTransferTerminator) import Control.Exception (bracket) import Data.ByteString (ByteString)@@ -62,114 +65,112 @@ import Network.Http.Internal import Network.Http.ResponseParser ------ | A connection to a web server.----data Connection- = Connection {- cHost :: ByteString,- -- ^ will be used as the Host: header in the HTTP request.- cClose :: IO (),- -- ^ called when the connection should be closed.- cOut :: OutputStream Builder,- cIn :: InputStream ByteString+{- |+A connection to a web server.+-}+data Connection = Connection+ { -- | will be used as the Host: header in the HTTP request.+ cHost :: ByteString+ , -- | called when the connection should be closed.+ cClose :: IO ()+ , cOut :: OutputStream Builder+ , cIn :: InputStream ByteString } instance Show Connection where- show c = {-# SCC "Connection.show" #-}+ show c =+ {-# SCC "Connection.show" #-} concat- ["Host: ",- S.unpack $ cHost c,- "\n"]+ [ "Host: "+ , S.unpack $ cHost c+ , "\n"+ ] +{- |+Create a raw Connection object from the given parts. This is+primarily of use when teseting, for example: ------ | Create a raw Connection object from the given parts. This is--- primarily of use when teseting, for example:------ > fakeConnection :: IO Connection--- > fakeConnection = do--- > o <- Streams.nullOutput--- > i <- Streams.nullInput--- > c <- makeConnection "www.example.com" (return()) o i--- > return c------ is an idiom we use frequently in testing and benchmarking, usually--- replacing the InputStream with something like:------ > x' <- S.readFile "properly-formatted-response.txt"--- > i <- Streams.fromByteString x'------ If you're going to do that, keep in mind that you /must/ have CR-LF--- pairs after each header line and between the header and body to--- be compliant with the HTTP protocol; otherwise, parsers will--- reject your message.----makeConnection- :: ByteString- -- ^ will be used as the @Host:@ header in the HTTP request.- -> IO ()- -- ^ an action to be called when the connection is terminated.- -> OutputStream ByteString- -- ^ write end of the HTTP client-server connection.- -> InputStream ByteString- -- ^ read end of the HTTP client-server connection.- -> IO Connection+> fakeConnection :: IO Connection+> fakeConnection = do+> o <- Streams.nullOutput+> i <- Streams.nullInput+> c <- makeConnection "www.example.com" (return()) o i+> return c++is an idiom we use frequently in testing and benchmarking, usually+replacing the InputStream with something like:++> x' <- S.readFile "properly-formatted-response.txt"+> i <- Streams.fromByteString x'++If you're going to do that, keep in mind that you /must/ have CR-LF+pairs after each header line and between the header and body to+be compliant with the HTTP protocol; otherwise, parsers will+reject your message.+-}+makeConnection ::+ -- | will be used as the @Host:@ header in the HTTP request.+ ByteString ->+ -- | an action to be called when the connection is terminated.+ IO () ->+ -- | write end of the HTTP client-server connection.+ OutputStream ByteString ->+ -- | read end of the HTTP client-server connection.+ InputStream ByteString ->+ IO Connection makeConnection h c o1 i = do o2 <- Streams.builderStream o1 return $! Connection h c o2 i +{- |+Given an @IO@ action producing a 'Connection', and a computation+that needs one, runs the computation, cleaning up the+@Connection@ afterwards. ------ | Given an @IO@ action producing a 'Connection', and a computation--- that needs one, runs the computation, cleaning up the--- @Connection@ afterwards.------ > x <- withConnection (openConnection "s3.example.com" 80) $ (\c -> do--- > let q = buildRequest1 $ do--- > http GET "/bucket42/object/149"--- > sendRequest c q emptyBody--- > ...--- > return "blah")------ which can make the code making an HTTP request a lot more--- straight-forward.------ Wraps @Control.Exception@'s 'Control.Exception.bracket'.---+> x <- withConnection (openConnection "s3.example.com" 80) $ (\c -> do+> let q = buildRequest1 $ do+> http GET "/bucket42/object/149"+> sendRequest c q emptyBody+> ...+> return "blah")++which can make the code making an HTTP request a lot more+straight-forward.++Wraps @Control.Exception@'s 'Control.Exception.bracket'.+-} withConnection :: IO Connection -> (Connection -> IO γ) -> IO γ withConnection mkC = bracket mkC closeConnection +{- |+In order to make a request you first establish the TCP+connection to the server over which to send it. ------ | In order to make a request you first establish the TCP--- connection to the server over which to send it.------ Ordinarily you would supply the host part of the URL here and it will--- be used as the value of the HTTP 1.1 @Host:@ field. However, you can--- specify any server name or IP addresss and set the @Host:@ value--- later with 'Network.Http.Client.setHostname' when building the--- request.------ Usage is as follows:------ > c <- openConnection "localhost" 80--- > ...--- > closeConnection c------ More likely, you'll use 'withConnection' to wrap the call in order--- to ensure finalization.------ HTTP pipelining is supported; you can reuse the connection to a--- web server, but it's up to you to ensure you match the number of--- requests sent to the number of responses read, and to process those--- responses in order. This is all assuming that the /server/ supports--- pipelining; be warned that not all do. Web browsers go to--- extraordinary lengths to probe this; you probably only want to do--- pipelining under controlled conditions. Otherwise just open a new--- connection for subsequent requests.---+Ordinarily you would supply the host part of the URL here and it will+be used as the value of the HTTP 1.1 @Host:@ field. However, you can+specify any server name or IP addresss and set the @Host:@ value+later with 'Network.Http.Client.setHostname' when building the+request.++Usage is as follows:++> c <- openConnection "localhost" 80+> ...+> closeConnection c++More likely, you'll use 'withConnection' to wrap the call in order+to ensure finalization.++HTTP pipelining is supported; you can reuse the connection to a+web server, but it's up to you to ensure you match the number of+requests sent to the number of responses read, and to process those+responses in order. This is all assuming that the /server/ supports+pipelining; be warned that not all do. Web browsers go to+extraordinary lengths to probe this; you probably only want to do+pipelining under controlled conditions. Otherwise just open a new+connection for subsequent requests.+-} openConnection :: Hostname -> Port -> IO Connection openConnection h1' p = do is <- getAddrInfo (Just hints) (Just h1) (Just $ show p)@@ -178,56 +179,59 @@ s <- socket (addrFamily addr) Stream defaultProtocol connect s a- (i,o1) <- Streams.socketToStreams s+ (i, o1) <- Streams.socketToStreams s o2 <- Streams.builderStream o1 - return Connection {- cHost = h2',- cClose = close s,- cOut = o2,- cIn = i- }+ return+ Connection+ { cHost = h2'+ , cClose = close s+ , cOut = o2+ , cIn = i+ } where- hints = defaultHints {- addrFlags = [AI_NUMERICSERV],- addrSocketType = Stream- }- h2' = if p == 80- then h1'- else S.concat [ h1', ":", S.pack $ show p ]- h1 = S.unpack h1'+ hints =+ defaultHints+ { addrFlags = [AI_NUMERICSERV]+ , addrSocketType = Stream+ }+ h2' =+ if p == 80+ then h1'+ else S.concat [h1', ":", S.pack $ show p]+ h1 = S.unpack h1' ------ | Open a secure connection to a web server.------ > import OpenSSL (withOpenSSL)--- >--- > main :: IO ()--- > main = do--- > ctx <- baselineContextSSL--- > c <- openConnectionSSL ctx "api.github.com" 443--- > ...--- > closeConnection c------ If you want to tune the parameters used in making SSL connections,--- manually specify certificates, etc, then setup your own context:------ > import OpenSSL.Session (SSLContext)--- > import qualified OpenSSL.Session as SSL--- >--- > ...--- > ctx <- SSL.context--- > ...------ See "OpenSSL.Session".------ Crypto is as provided by the system @openssl@ library, as wrapped--- by the @HsOpenSSL@ package and @openssl-streams@.------ /There is no longer a need to call @withOpenSSL@ explicitly; the--- initialization is invoked once per process for you/---+{- |+Open a secure connection to a web server.++> import OpenSSL (withOpenSSL)+>+> main :: IO ()+> main = do+> ctx <- baselineContextSSL+> c <- openConnectionSSL ctx "api.github.com" 443+> ...+> closeConnection c++If you want to tune the parameters used in making SSL connections,+manually specify certificates, etc, then setup your own context:++> import OpenSSL.Session (SSLContext)+> import qualified OpenSSL.Session as SSL+>+> ...+> ctx <- SSL.context+> ...++See "OpenSSL.Session".++Crypto is as provided by the system @openssl@ library, as wrapped+by the @HsOpenSSL@ package and @openssl-streams@.++/There is no longer a need to call @withOpenSSL@ explicitly; the+initialization is invoked once per process for you/+-} openConnectionSSL :: SSLContext -> Hostname -> Port -> IO Connection openConnectionSSL ctx h1' p = withOpenSSL $ do is <- getAddrInfo Nothing (Just h1) (Just $ show p)@@ -242,72 +246,76 @@ SSL.setTlsextHostName ssl h1 SSL.connect ssl - (i,o1) <- Streams.sslToStreams ssl+ (i, o1) <- Streams.sslToStreams ssl o2 <- Streams.builderStream o1 - return Connection {- cHost = h2',- cClose = closeSSL s ssl,- cOut = o2,- cIn = i- }+ return+ Connection+ { cHost = h2'+ , cClose = closeSSL s ssl+ , cOut = o2+ , cIn = i+ } where h2' :: ByteString- h2' = if p == 443- then h1'- else S.concat [ h1', ":", S.pack $ show p ]- h1 = S.unpack h1'+ h2' =+ if p == 443+ then h1'+ else S.concat [h1', ":", S.pack $ show p]+ h1 = S.unpack h1' closeSSL :: Socket -> SSL -> IO () closeSSL s ssl = do SSL.shutdown ssl SSL.Unidirectional close s ------ | Open a connection to a Unix domain socket.------ > main :: IO ()--- > main = do--- > c <- openConnectionUnix "/var/run/docker.sock"--- > ...--- > closeConnection c---+{- |+Open a connection to a Unix domain socket.++> main :: IO ()+> main = do+> c <- openConnectionUnix "/var/run/docker.sock"+> ...+> closeConnection c+-} openConnectionUnix :: FilePath -> IO Connection openConnectionUnix path = do let a = SockAddrUnix path s <- socket AF_UNIX Stream defaultProtocol connect s a- (i,o1) <- Streams.socketToStreams s+ (i, o1) <- Streams.socketToStreams s o2 <- Streams.builderStream o1 - return Connection {- cHost = path',- cClose = close s,- cOut = o2,- cIn = i- }+ return+ Connection+ { cHost = path'+ , cClose = close s+ , cOut = o2+ , cIn = i+ } where- path' = S.pack path+ path' = S.pack path ------ | Having composed a 'Request' object with the headers and metadata for--- this connection, you can now send the request to the server, along--- with the entity body, if there is one. For the rather common case of--- HTTP requests like 'GET' that don't send data, use 'emptyBody' as the--- output stream:------ > sendRequest c q emptyBody------ For 'PUT' and 'POST' requests, you can use 'fileBody' or--- 'inputStreamBody' to send content to the server, or you can work with--- the @io-streams@ API directly:------ > sendRequest c q (\o ->--- > Streams.write (Just (Builder.fromString "Hello World\n")) o)---+{- |+Having composed a 'Request' object with the headers and metadata for+this connection, you can now send the request to the server, along+with the entity body, if there is one. For the rather common case of+HTTP requests like 'GET' that don't send data, use 'emptyBody' as the+output stream:++> sendRequest c q emptyBody++For 'PUT' and 'POST' requests, you can use 'fileBody' or+'inputStreamBody' to send content to the server, or you can work with+the @io-streams@ API directly:++> sendRequest c q (\o ->+> Streams.write (Just (Builder.fromString "Hello World\n")) o)+-}+ {- I would like to enforce the constraints on the Empty and Static cases shown here, but those functions take OutputStream ByteString,@@ -324,20 +332,19 @@ e2 <- case t of Normal -> do return e- Continue -> do Streams.write (Just Builder.flush) o2 - p <- readResponseHeader i+ p <- readResponseHeader i case getStatusCode p of 100 -> do- -- ok to send- return e- _ -> do- -- put the response back- Streams.unRead (rsp p) i- return Empty+ -- ok to send+ return e+ _ -> do+ -- put the response back+ Streams.unRead (rsp p) i+ return Empty -- write the body, if there is one @@ -346,25 +353,21 @@ o3 <- Streams.nullOutput y <- handler o3 return y-- Chunking -> do+ Chunking -> do o3 <- Streams.contramap Builder.chunkedTransferEncoding o2- y <- handler o3+ y <- handler o3 Streams.write (Just Builder.chunkedTransferTerminator) o2 return y- (Static _) -> do--- o3 <- Streams.giveBytes (fromIntegral n :: Int64) o2- y <- handler o2+ -- o3 <- Streams.giveBytes (fromIntegral n :: Int64) o2+ y <- handler o2 return y - -- push the stream out by flushing the output buffers Streams.write (Just Builder.flush) o2 return x- where o2 = cOut c e = qBody q@@ -374,20 +377,18 @@ i = cIn c rsp p = Builder.toByteString $ composeResponseBytes p ------- | Get the virtual hostname that will be used as the @Host:@ header in--- the HTTP 1.1 request. Per RFC 2616 § 14.23, this will be of the form--- @hostname:port@ if the port number is other than the default, ie 80--- for HTTP.---+{- |+Get the virtual hostname that will be used as the @Host:@ header in+the HTTP 1.1 request. Per RFC 2616 § 14.23, this will be of the form+@hostname:port@ if the port number is other than the default, ie 80+for HTTP.+-} getHostname :: Connection -> Request -> ByteString getHostname c q = case qHost q of Just h' -> h' Nothing -> cHost c - {-# DEPRECATED getRequestHeaders "use retrieveHeaders . getHeadersFull instead" #-} getRequestHeaders :: Connection -> Request -> [(ByteString, ByteString)] getRequestHeaders c q =@@ -396,54 +397,55 @@ h = qHeaders q kvs = retrieveHeaders h ------ | Get the headers that will be sent with this request. You likely won't--- need this but there are some corner cases where people need to make--- calculations based on all the headers before they go out over the wire.------ If you'd like the request headers as an association list, import the header--- functions:------ > import Network.Http.Types------ then use 'Network.Http.Types.retreiveHeaders' as follows:------ >>> let kvs = retreiveHeaders $ getHeadersFull c q--- >>> :t kvs--- :: [(ByteString, ByteString)]---+{- |+Get the headers that will be sent with this request. You likely won't+need this but there are some corner cases where people need to make+calculations based on all the headers before they go out over the wire.++If you'd like the request headers as an association list, import the header+functions:++> import Network.Http.Types++then use 'Network.Http.Types.retreiveHeaders' as follows:++>>> let kvs = retreiveHeaders $ getHeadersFull c q+>>> :t kvs+:: [(ByteString, ByteString)]+-} getHeadersFull :: Connection -> Request -> Headers getHeadersFull c q = h' where- h = qHeaders q+ h = qHeaders q h' = updateHeader h "Host" (getHostname c q) ------ | Handle the response coming back from the server. This function--- hands control to a handler function you supply, passing you the--- 'Response' object with the response headers and an 'InputStream'--- containing the entity body.------ For example, if you just wanted to print the first chunk of the--- content from the server:------ > receiveResponse c (\p i -> do--- > m <- Streams.read i--- > case m of--- > Just bytes -> putStr bytes--- > Nothing -> return ())------ Obviously, you can do more sophisticated things with the--- 'InputStream', which is the whole point of having an @io-streams@--- based HTTP client library.------ The final value from the handler function is the return value of--- @receiveResponse@, if you need it.------ Throws 'UnexpectedCompression' if it doesn't know how to handle the--- compression format used in the response.---+{- |+Handle the response coming back from the server. This function+hands control to a handler function you supply, passing you the+'Response' object with the response headers and an 'InputStream'+containing the entity body.++For example, if you just wanted to print the first chunk of the+content from the server:++> receiveResponse c (\p i -> do+> m <- Streams.read i+> case m of+> Just bytes -> putStr bytes+> Nothing -> return ())++Obviously, you can do more sophisticated things with the+'InputStream', which is the whole point of having an @io-streams@+based HTTP client library.++The final value from the handler function is the return value of+@receiveResponse@, if you need it.++Throws 'UnexpectedCompression' if it doesn't know how to handle the+compression format used in the response.+-}+ {- The reponse body coming from the server MUST be fully read, even if (especially if) the users's handler doesn't consume it all.@@ -455,10 +457,10 @@ -} receiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β receiveResponse c handler = do- p <- readResponseHeader i+ p <- readResponseHeader i i' <- readResponseBody p i - x <- handler p i'+ x <- handler p i' Streams.skipToEof i' @@ -466,25 +468,27 @@ where i = cIn c ------ | This is a specialized variant of 'receiveResponse' that /explicitly/ does--- not handle the content encoding of the response body stream (it will not--- decompress anything). Unless you really want the raw gzipped content coming--- down from the server, use @receiveResponse@.---+{- |+This is a specialized variant of 'receiveResponse' that /explicitly/ does+not handle the content encoding of the response body stream (it will not+decompress anything). Unless you really want the raw gzipped content coming+down from the server, use @receiveResponse@.+-}+ {- See notes at receiveResponse. -} receiveResponseRaw :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β receiveResponseRaw c handler = do- p <- readResponseHeader i- let p' = p {- pContentEncoding = Identity- }+ p <- readResponseHeader i+ let p' =+ p+ { pContentEncoding = Identity+ } i' <- readResponseBody p' i - x <- handler p i'+ x <- handler p i' Streams.skipToEof i' @@ -492,30 +496,30 @@ where i = cIn c ------ | Handle the response coming back from the server. This function--- is the same as receiveResponse, but it does not consume the body for--- you after the handler is done. This means that it can only be safely used--- if the handler will fully consume the body, there is no body, or when--- the connection is not being reused (no pipelining).---+{- |+Handle the response coming back from the server. This function+is the same as receiveResponse, but it does not consume the body for+you after the handler is done. This means that it can only be safely used+if the handler will fully consume the body, there is no body, or when+the connection is not being reused (no pipelining).+-} unsafeReceiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β unsafeReceiveResponse c handler = do- p <- readResponseHeader i+ p <- readResponseHeader i i' <- readResponseBody p i handler p i' where i = cIn c ------ | Use this for the common case of the HTTP methods that only send--- headers and which have no entity body, i.e. 'GET' requests.---+{- |+Use this for the common case of the HTTP methods that only send+headers and which have no entity body, i.e. 'GET' requests.+-} emptyBody :: OutputStream Builder -> IO () emptyBody _ = return () -{-|+{- | Sometimes you just want to send some bytes to the server as a the body of your request. This is easy to use, but if you're doing anything massive use 'inputStreamBody'; if you're sending a file use 'fileBody'; if you have an@@ -526,20 +530,21 @@ let b = Builder.fromByteString x' Streams.write (Just b) o ------ | Specify a local file to be sent to the server as the body of the--- request.------ You use this partially applied:------ > sendRequest c q (fileBody "/etc/passwd")------ Note that the type of @(fileBody \"\/path\/to\/file\")@ is just what--- you need for the third argument to 'sendRequest', namely------ >>> :t filePath "hello.txt"--- :: OutputStream Builder -> IO ()---+{- |+Specify a local file to be sent to the server as the body of the+request.++You use this partially applied:++> sendRequest c q (fileBody "/etc/passwd")++Note that the type of @(fileBody \"\/path\/to\/file\")@ is just what+you need for the third argument to 'sendRequest', namely++>>> :t filePath "hello.txt"+:: OutputStream Builder -> IO ()+-}+ {- Relies on Streams.withFileAsInput generating (very) large chunks [which it does]. A more efficient way to do this would be interesting.@@ -548,20 +553,21 @@ fileBody p o = do Streams.withFileAsInput p (\i -> inputStreamBody i o) ------ | Read from a pre-existing 'InputStream' and pipe that through to the--- connection to the server. This is useful in the general case where--- something else has handed you stream to read from and you want to use--- it as the entity body for the request.------ You use this partially applied:------ > i <- getStreamFromVault -- magic, clearly--- > sendRequest c q (inputStreamBody i)------ This function maps "Builder.fromByteString" over the input, which will--- be efficient if the ByteString chunks are large.---+{- |+Read from a pre-existing 'InputStream' and pipe that through to the+connection to the server. This is useful in the general case where+something else has handed you stream to read from and you want to use+it as the entity body for the request.++You use this partially applied:++> i <- getStreamFromVault -- magic, clearly+> sendRequest c q (inputStreamBody i)++This function maps "Builder.fromByteString" over the input, which will+be efficient if the ByteString chunks are large.+-}+ {- Note that this has to be 'supply' and not 'connect' as we do not want the end of stream to prematurely terminate the chunked encoding@@ -572,104 +578,102 @@ i2 <- Streams.map Builder.fromByteString i1 Streams.supply i2 o +{- |+Print the response headers and response body to @stdout@. You can+use this with 'receiveResponse' or one of the convenience functions+when testing. For example, doing: ------ | Print the response headers and response body to @stdout@. You can--- use this with 'receiveResponse' or one of the convenience functions--- when testing. For example, doing:------ > c <- openConnection "kernel.operationaldynamics.com" 58080--- >--- > let q = buildRequest1 $ do--- > http GET "/time"--- >--- > sendRequest c q emptyBody--- >--- > receiveResponse c debugHandler------ would print out:------ > HTTP/1.1 200 OK--- > Transfer-Encoding: chunked--- > Content-Type: text/plain--- > Vary: Accept-Encoding--- > Server: Snap/0.9.2.4--- > Content-Encoding: gzip--- > Date: Mon, 21 Jan 2013 06:13:37 GMT--- >--- > Mon 21 Jan 13, 06:13:37.303Z------ or thereabouts.---+> c <- openConnection "kernel.operationaldynamics.com" 58080+>+> let q = buildRequest1 $ do+> http GET "/time"+>+> sendRequest c q emptyBody+>+> receiveResponse c debugHandler++would print out:++> HTTP/1.1 200 OK+> Transfer-Encoding: chunked+> Content-Type: text/plain+> Vary: Accept-Encoding+> Server: Snap/0.9.2.4+> Content-Encoding: gzip+> Date: Mon, 21 Jan 2013 06:13:37 GMT+>+> Mon 21 Jan 13, 06:13:37.303Z++or thereabouts.+-} debugHandler :: Response -> InputStream ByteString -> IO () debugHandler p i = do S.putStr $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p Streams.connect i stdout +{- |+Sometimes you just want the entire response body as a single blob.+This function concatonates all the bytes from the response into a+ByteString. If using the main @http-streams@ API, you would use it+as follows: ------ | Sometimes you just want the entire response body as a single blob.--- This function concatonates all the bytes from the response into a--- ByteString. If using the main @http-streams@ API, you would use it--- as follows:------ > ...--- > x' <- receiveResponse c concatHandler--- > ...------ The methods in the convenience API all take a function to handle the--- response; this function is passed directly to the 'receiveResponse'--- call underlying the request. Thus this utility function can be used--- for 'get' as well:------ > x' <- get "http://www.example.com/document.txt" concatHandler------ Either way, the usual caveats about allocating a--- single object from streaming I/O apply: do not use this if you are--- not absolutely certain that the response body will fit in a--- reasonable amount of memory.------ Note that this function makes no discrimination based on the--- response's HTTP status code. You're almost certainly better off--- writing your own handler function.----{-- I'd welcome a better name for this function.+> ...+> x' <- receiveResponse c simpleHandler+> ...++The methods in the convenience API all take a function to handle the+response; this function is passed directly to the 'receiveResponse'+call underlying the request. Thus this utility function can be used+for 'get' as well:++> x' <- get "http://www.example.com/document.txt" simpleHandler++Either way, the usual caveats about allocating a+single object from streaming I/O apply: do not use this if you are+not absolutely certain that the response body will fit in a+reasonable amount of memory.++Note that this function makes no discrimination based on the+response's HTTP status code. You're almost certainly better off+writing your own handler function. -}-concatHandler :: Response -> InputStream ByteString -> IO ByteString-concatHandler _ i1 = do+simpleHandler :: Response -> InputStream ByteString -> IO ByteString+simpleHandler _ i1 = do i2 <- Streams.map Builder.fromByteString i1 x <- Streams.fold mappend mempty i2 return $ Builder.toByteString x +concatHandler :: Response -> InputStream ByteString -> IO ByteString+concatHandler = simpleHandler+{-# DEPRECATED concatHandler "Use simpleHandler instead" #-} ------ | Shutdown the connection. You need to call this release the--- underlying socket file descriptor and related network resources. To--- do so reliably, use this in conjunction with 'openConnection' in a--- call to 'Control.Exception.bracket':------ > ----- > -- Make connection, cleaning up afterward--- > ----- >--- > foo :: IO ByteString--- > foo = bracket--- > (openConnection "localhost" 80)--- > (closeConnection)--- > (doStuff)--- >--- > ----- > -- Actually use Connection to send Request and receive Response--- > ----- >--- > doStuff :: Connection -> IO ByteString------ or, just use 'withConnection'.------ While returning a ByteString is probably the most common use case,--- you could conceivably do more processing of the response in 'doStuff'--- and have it and 'foo' return a different type.---+{- |+Shutdown the connection. You need to call this release the+underlying socket file descriptor and related network resources. To+do so reliably, use this in conjunction with 'openConnection' in a+call to 'Control.Exception.bracket':++> --+> -- Make connection, cleaning up afterward+> --+>+> foo :: IO ByteString+> foo = bracket+> (openConnection "localhost" 80)+> (closeConnection)+> (doStuff)+>+> --+> -- Actually use Connection to send Request and receive Response+> --+>+> doStuff :: Connection -> IO ByteString++or, just use 'withConnection'.++While returning a ByteString is probably the most common use case,+you could conceivably do more processing of the response in 'doStuff'+and have it and 'foo' return a different type.+-} closeConnection :: Connection -> IO () closeConnection c = cClose c
lib/Network/Http/Inconvenience.hs view
@@ -1,19 +1,18 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd+-- Copyright © 2012-2021 Athae Eredh Siniath and Others -- -- The code in this file, and the program it is a part of, is -- made available to you by its authors as open source software: -- you can redistribute it and/or modify it under the terms of -- the BSD licence. ----{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide, not-home #-} @@ -25,25 +24,34 @@ post, postForm, encodedFormBody,+ multipartFormBody,+ Part,+ simplePart,+ filePart,+ inputStreamPart, put, baselineContextSSL,+ simpleHandler', concatHandler', jsonBody, jsonHandler,- TooManyRedirects(..),- HttpClientError(..),-- -- for testing+ TooManyRedirects (..),+ HttpClientError (..),+ -- for testing splitURI,- parseURL+ parseURL, ) where import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (fromByteString, fromLazyByteString,- fromWord8, toByteString)+import qualified Blaze.ByteString.Builder as Builder (+ fromByteString,+ fromLazyByteString,+ fromWord8,+ toByteString,+ ) import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString) import Control.Exception (Exception, bracket, throw)-import Data.Aeson (FromJSON, ToJSON, Result (..), fromJSON, json', encode)+import Data.Aeson (FromJSON, Result (..), ToJSON, encode, fromJSON, json') import Data.Bits (Bits (..)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S@@ -59,12 +67,20 @@ import Data.Word (Word16) import GHC.Exts import GHC.Word (Word8 (..))-import Network.URI (URI (..), URIAuth (..), isAbsoluteURI,- parseRelativeReference,- parseURI, escapeURIString, isAllowedInURI, uriToString)+import Network.URI (+ URI (..),+ URIAuth (..),+ escapeURIString,+ isAbsoluteURI,+ isAllowedInURI,+ parseRelativeReference,+ parseURI,+ uriToString,+ ) import OpenSSL (withOpenSSL) import OpenSSL.Session (SSLContext) import qualified OpenSSL.Session as SSL+import System.FilePath.Posix (takeFileName) import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams import qualified System.IO.Streams.Attoparsec as Streams@@ -75,8 +91,8 @@ #endif import Network.Http.Connection+import Network.Http.Internal import Network.Http.RequestBuilder-import Network.Http.Types -- (see also http://downloads.haskell.org/~ghc/8.4.2/docs/html/users_guide/phases.html#standard-cpp-macros -- for a list of predefined CPP macros provided by GHC and/or Cabal; see also the cabal user's guide)@@ -88,52 +104,52 @@ ------------------------------------------------------------------------------ ------ | URL-escapes a string (see--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>)---+{- |+URL-escapes a string (see+<http://tools.ietf.org/html/rfc2396.html#section-2.4>)+-} urlEncode :: ByteString -> URL urlEncode = Builder.toByteString . urlEncodeBuilder {-# INLINE urlEncode #-} ------- | URL-escapes a string (see--- <http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.---+{- |+URL-escapes a string (see+<http://tools.ietf.org/html/rfc2396.html#section-2.4>) into a 'Builder'.+-} urlEncodeBuilder :: ByteString -> Builder urlEncodeBuilder = go mempty where go !b !s = maybe b' esc (S.uncons y) where- (x,y) = S.span (flip HashSet.member urlEncodeTable) s- b' = b `mappend` Builder.fromByteString x- esc (c,r) = let b'' = if c == ' '- then b' `mappend` Builder.fromWord8 (c2w '+')- else b' `mappend` hexd c- in go b'' r-+ (x, y) = S.span (flip HashSet.member urlEncodeTable) s+ b' = b `mappend` Builder.fromByteString x+ esc (c, r) =+ let b'' =+ if c == ' '+ then b' `mappend` Builder.fromWord8 (c2w '+')+ else b' `mappend` hexd c+ in go b'' r hexd :: Char -> Builder-hexd c0 = Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi- `mappend` Builder.fromWord8 low+hexd c0 =+ Builder.fromWord8 (c2w '%') `mappend` Builder.fromWord8 hi+ `mappend` Builder.fromWord8 low where- !c = c2w c0- toDigit = c2w . intToDigit- !low = toDigit $ fromEnum $ c .&. 0xf- !hi = toDigit $ (c .&. 0xf0) `shiftr` 4+ !c = c2w c0+ toDigit = c2w . intToDigit+ !low = toDigit $ fromEnum $ c .&. 0xf+ !hi = toDigit $ (c .&. 0xf0) `shiftr` 4 shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#)) - urlEncodeTable :: HashSet Char-urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0..255]+urlEncodeTable = HashSet.fromList $! filter f $! map w2c [0 .. 255] where- f c | c >= 'A' && c <= 'Z' = True+ f c+ | c >= 'A' && c <= 'Z' = True | c >= 'a' && c <= 'z' = True | c >= '0' && c <= '9' = True- f c = c `elem` ("$-_.!~*'(),"::String)-+ f c = c `elem` ("$-_.!~*'()," :: String) ------------------------------------------------------------------------------ @@ -152,35 +168,35 @@ newIORef ctx {-# NOINLINE global #-} ------ | Modify the context being used to configure the SSL tunnel used by--- the convenience API functions to make @https://@ connections. The--- default is that setup by 'baselineContextSSL'.---+{- |+Modify the context being used to configure the SSL tunnel used by+the convenience API functions to make @https://@ connections. The+default is that setup by 'baselineContextSSL'.+-} modifyContextSSL :: (SSLContext -> IO SSLContext) -> IO () modifyContextSSL f = do ctx <- readIORef global ctx' <- f ctx writeIORef global ctx' ------ | Given a URL, work out whether it is normal, secure, or unix domain,--- and then open the connection to the webserver including setting the--- appropriate default port if one was not specified in the URL. This--- is what powers the convenience API, but you may find it useful in--- composing your own similar functions.------ For example (on the assumption that your server behaves when given--- an absolute URI as the request path), this will open a connection--- to server @www.example.com@ port @443@ and request @/photo.jpg@:------ > let url = "https://www.example.com/photo.jpg"--- >--- > c <- establishConnection url--- > let q = buildRequest1 $ do--- > http GET url--- > ...---+{- |+Given a URL, work out whether it is normal, secure, or unix domain,+and then open the connection to the webserver including setting the+appropriate default port if one was not specified in the URL. This+is what powers the convenience API, but you may find it useful in+composing your own similar functions.++For example (on the assumption that your server behaves when given+an absolute URI as the request path), this will open a connection+to server @www.example.com@ port @443@ and request @/photo.jpg@:++> let url = "https://www.example.com/photo.jpg"+>+> c <- establishConnection url+> let q = buildRequest1 $ do+> http GET url+> ...+-} establishConnection :: URL -> IO (Connection) establishConnection r' = do establish u@@ -191,45 +207,45 @@ establish :: URI -> IO (Connection) establish u = case scheme of- "http:" -> do- openConnection host port+ "http:" -> do+ openConnection host port "https:" -> do- ctx <- readIORef global- openConnectionSSL ctx host ports- "unix:" -> do- openConnectionUnix $ uriPath u- _ -> error ("Unknown URI scheme " ++ scheme)+ ctx <- readIORef global+ openConnectionSSL ctx host ports+ "unix:" -> do+ openConnectionUnix $ uriPath u+ _ -> error ("Unknown URI scheme " ++ scheme) where scheme = uriScheme u auth = case uriAuthority u of- Just x -> x+ Just x -> x Nothing -> URIAuth "" "localhost" "" host = S.pack (uriRegName auth) port = case uriPort auth of- "" -> 80- _ -> read $ tail $ uriPort auth :: Word16+ "" -> 80+ _ -> read $ tail $ uriPort auth :: Word16 ports = case uriPort auth of- "" -> 443- _ -> read $ tail $ uriPort auth :: Word16+ "" -> 443+ _ -> read $ tail $ uriPort auth :: Word16 +{- |+Creates a basic SSL context. This is the SSL context used if you make an+@\"https:\/\/\"@ request using one of the convenience functions. It+configures OpenSSL to use the default set of ciphers. ------ | Creates a basic SSL context. This is the SSL context used if you make an--- @\"https:\/\/\"@ request using one of the convenience functions. It--- configures OpenSSL to use the default set of ciphers.------ On Linux, OpenBSD and FreeBSD systems, this function also configures--- OpenSSL to verify certificates using the system/distribution supplied--- certificate authorities' certificates------ On other systems, /no certificate validation is performed/ by the--- generated 'SSLContext' because there is no canonical place to find--- the set of system certificates. When using this library on such system,--- you are encouraged to install the system--- certificates somewhere and create your own 'SSLContext'.---+On Linux, OpenBSD and FreeBSD systems, this function also configures+OpenSSL to verify certificates using the system/distribution supplied+certificate authorities' certificates++On other systems, /no certificate validation is performed/ by the+generated 'SSLContext' because there is no canonical place to find+the set of system certificates. When using this library on such system,+you are encouraged to install the system+certificates somewhere and create your own 'SSLContext'.+-}+ {- We would like to turn certificate verification on for everyone, but this has proved contingent on leveraging platform specific mechanisms@@ -261,11 +277,10 @@ #endif return ctx - parseURL :: URL -> URI parseURL r' = case parseURI r of- Just u -> u+ Just u -> u Nothing -> error ("Can't parse URI " ++ r) where r = escapeURIString isAllowedInURI $ T.unpack $ T.decodeUtf8 r'@@ -277,43 +292,44 @@ path element, resulting in an illegal HTTP request line. -} -path :: URI -> ByteString-path u = case url of- "" -> "/"- _ -> url+pathFrom :: URI -> ByteString+pathFrom u = case url of+ "" -> "/"+ _ -> url where- url = T.encodeUtf8 $! T.pack- $! concat [uriPath u, uriQuery u, uriFragment u]-+ url =+ T.encodeUtf8 $! T.pack+ $! concat [uriPath u, uriQuery u, uriFragment u] ------------------------------------------------------------------------------ ------ | Issue an HTTP GET request and pass the resultant response to the--- supplied handler function. This code will silently follow redirects,--- to a maximum depth of 5 hops.------ The handler function is as for 'receiveResponse', so you can use one--- of the supplied convenience handlers if you're in a hurry:------ > x' <- get "http://www.bbc.co.uk/news/" concatHandler------ But as ever the disadvantage of doing this is that you're not doing--- anything intelligent with the HTTP response status code. If you want--- an exception raised in the event of a non @2xx@ response, you can use:------ > x' <- get "http://www.bbc.co.uk/news/" concatHandler'------ but for anything more refined you'll find it easy to simply write--- your own handler function.------ Throws 'TooManyRedirects' if more than 5 redirects are thrown.----get :: URL- -- ^ Resource to GET from.- -> (Response -> InputStream ByteString -> IO β)- -- ^ Handler function to receive the response from the server.- -> IO β+{- |+Issue an HTTP GET request and pass the resultant response to the+supplied handler function. This code will silently follow redirects,+to a maximum depth of 5 hops.++The handler function is as for 'receiveResponse', so you can use one+of the supplied convenience handlers if you're in a hurry:++> x' <- get "http://www.bbc.co.uk/news/" concatHandler++But as ever the disadvantage of doing this is that you're not doing+anything intelligent with the HTTP response status code. If you want+an exception raised in the event of a non @2xx@ response, you can use:++> x' <- get "http://www.bbc.co.uk/news/" concatHandler'++but for anything more refined you'll find it easy to simply write+your own handler function.++Throws 'TooManyRedirects' if more than 5 redirects are thrown.+-}+get ::+ -- | Resource to GET from.+ URL ->+ -- | Handler function to receive the response from the server.+ (Response -> InputStream ByteString -> IO β) ->+ IO β get r' handler = getN 0 r' handler getN n r' handler = do@@ -321,22 +337,20 @@ (establish u) (teardown) (process)- where teardown = closeConnection u = parseURL r' q = buildRequest1 $ do- http GET (path u)- setAccept "*/*"+ http GET (pathFrom u)+ setAccept "*/*" process c = do sendRequest c q emptyBody receiveResponse c (wrapRedirect u n handler) - {- This is fairly simple-minded. Improvements could include reusing the Connection if the redirect is to the same host, and closing@@ -345,67 +359,66 @@ it for now. -} -wrapRedirect- :: URI- -> Int- -> (Response -> InputStream ByteString -> IO β)- -> Response- -> InputStream ByteString- -> IO β+wrapRedirect ::+ URI ->+ Int ->+ (Response -> InputStream ByteString -> IO β) ->+ Response ->+ InputStream ByteString ->+ IO β wrapRedirect u 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- Nothing -> handler p i+ Just l -> getN n' (splitURI u l) handler+ Nothing -> handler p i else handler p i where- s = getStatusCode p+ s = getStatusCode p lm = getHeader p "Location"- !n' = if n < 5+ !n' =+ if n < 5 then n + 1 else throw $! TooManyRedirects n - splitURI :: URI -> URL -> URL splitURI old new' =- let- new = S.unpack new'- in- if isAbsoluteURI new- then- new'- else- let- rel = parseRelativeReference new- in- case rel of- Nothing -> new'- Just x -> S.pack $ uriToString id old {- uriPath = uriPath x,- uriQuery = uriQuery x,- uriFragment = uriFragment x- } ""-+ let new = S.unpack new'+ in if isAbsoluteURI new+ then new'+ else+ let rel = parseRelativeReference new+ in case rel of+ Nothing -> new'+ Just x ->+ S.pack $+ uriToString+ id+ old+ { uriPath = uriPath x+ , uriQuery = uriQuery x+ , uriFragment = uriFragment x+ }+ "" data TooManyRedirects = TooManyRedirects Int- deriving (Typeable, Show, Eq)+ deriving (Typeable, Show, Eq) instance Exception TooManyRedirects ------- | Send content to a server via an HTTP POST request. Use this--- function if you have an 'OutputStream' with the body content.----post :: URL- -- ^ Resource to POST to.- -> ContentType- -- ^ MIME type of the request body being sent.- -> (OutputStream Builder -> IO α)- -- ^ Handler function to write content to server.- -> (Response -> InputStream ByteString -> IO β)- -- ^ Handler function to receive the response from the server.- -> IO β+{- |+Send content to a server via an HTTP POST request. Use this+function if you have an 'OutputStream' with the body content.+-}+post ::+ -- | Resource to POST to.+ URL ->+ -- | MIME type of the request body being sent.+ ContentType ->+ -- | Handler function to write content to server.+ (OutputStream Builder -> IO α) ->+ -- | Handler function to receive the response from the server.+ (Response -> InputStream ByteString -> IO β) ->+ IO β post r' t body handler = do bracket (establish u)@@ -417,9 +430,9 @@ u = parseURL r' q = buildRequest1 $ do- http POST (path u)- setAccept "*/*"- setContentType t+ http POST (pathFrom u)+ setAccept "*/*"+ setContentType t process c = do _ <- sendRequest c q body@@ -427,22 +440,21 @@ 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--- @application/x-www-form-urlencoded@ as this is what conventional--- web browsers send on form submission. If you want to POST to a URL--- with an arbitrary Content-Type, use 'post'.----postForm- :: URL- -- ^ Resource to POST to.- -> [(ByteString, ByteString)]- -- ^ List of name=value pairs. Will be sent URL-encoded.- -> (Response -> InputStream ByteString -> IO β)- -- ^ Handler function to receive the response from the server.- -> IO β+{- |+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+@application/x-www-form-urlencoded@ as this is what conventional+web browsers send on form submission. If you want to POST to a URL+with an arbitrary Content-Type, use 'post'.+-}+postForm ::+ -- | Resource to POST to.+ URL ->+ -- | List of name=value pairs. Will be sent URL-encoded.+ [(ByteString, ByteString)] ->+ -- | Handler function to receive the response from the server.+ (Response -> InputStream ByteString -> IO β) ->+ IO β postForm r' nvs handler = do bracket (establish u)@@ -454,9 +466,9 @@ u = parseURL r' q = buildRequest1 $ do- http POST (path u)- setAccept "*/*"- setContentType "application/x-www-form-urlencoded"+ http POST (pathFrom u)+ setAccept "*/*"+ setContentType "application/x-www-form-urlencoded" process c = do _ <- sendRequest c q (encodedFormBody nvs)@@ -464,55 +476,147 @@ 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.+Parameters will be URL encoded per RFC 2396 and combined into a+single string which will be sent as the body of your request. ------ | 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.--- Parameters will be URL encoded per RFC 2396 and combined into a--- single string which will be sent as the body of your request.------ You use this partially applied:------ > let nvs = [("name","Kermit"),--- > ("type","frog")]--- > ("role","stagehand")]--- >--- > sendRequest c q (encodedFormBody nvs)------ Note that it's going to be up to you to call 'setContentType' with--- a value of @\"application/x-www-form-urlencoded\"@ when building the--- Request object; the 'postForm' convenience (which uses this--- @encodedFormBody@ function) takes care of this for you, obviously.----encodedFormBody :: [(ByteString,ByteString)] -> OutputStream Builder -> IO ()+You use this partially applied:++> let nvs = [("name","Kermit"),+> ("type","frog")]+> ("role","stagehand")]+>+> sendRequest c q (encodedFormBody nvs)++Note that it's going to be up to you to call 'setContentType' with+a value of @\"application/x-www-form-urlencoded\"@ when building the+Request object; the 'postForm' convenience (which uses this+@encodedFormBody@ function) takes care of this for you, obviously.+-}+encodedFormBody :: [(ByteString, ByteString)] -> OutputStream Builder -> IO () encodedFormBody nvs o = do Streams.write (Just b) o where b = mconcat $ intersperse (Builder.fromString "&") $ map combine nvs - combine :: (ByteString,ByteString) -> Builder- combine (n',v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", urlEncodeBuilder v']+ combine :: (ByteString, ByteString) -> Builder+ combine (n', v') = mconcat [urlEncodeBuilder n', Builder.fromString "=", urlEncodeBuilder v'] +{- |+Build a list of parts into an upload body. ------ | Place content on the server at the given URL via an HTTP PUT--- request, specifying the content type and a function to write the--- content to the supplied 'OutputStream'. You might see:------ > put "http://s3.example.com/bucket42/object149" "text/plain"--- > (fileBody "hello.txt") (\p i -> do--- > putStr $ show p--- > Streams.connect i stdout)----put :: URL- -- ^ Resource to PUT to.- -> ContentType- -- ^ MIME type of the request body being sent.- -> (OutputStream Builder -> IO α)- -- ^ Handler function to write content to server.- -> (Response -> InputStream ByteString -> IO β)- -- ^ Handler function to receive the response from the server.- -> IO β+You use this partially applied:++> boundary <- randomBoundary+>+> let q = buildRequest1 $ do+> http POST "/api/v1/upload"+> setContentMultipart boundary+>+> let parts =+> [ simplePart "metadata" Nothing metadata+> , filePart "submission" (Just "audio/wav") filepath+> ]+>+> sendRequest c q (multipartFormBody boundary parts)++You /must/ have called 'setContentMultipart' when forming the request or the+request body you are sending will be invalid and (obviously) you must pass in+that same 'Boundary' value when calling this function.+-}+multipartFormBody :: Boundary -> [Part] -> OutputStream Builder -> IO ()+multipartFormBody boundary parts o = do+ mapM_ handlePart parts+ handleEnding+ where+ handlePart :: Part -> IO ()+ handlePart (Part field possibleContentType possibleFilename action) = do+ let h' = composeMultipartBytes boundary field possibleFilename possibleContentType+ Streams.write (Just h') o+ action o++ handleEnding :: IO ()+ handleEnding = do+ Streams.write (Just (composeMultipartEnding boundary)) o++{- |+Information about each of the parts of a @multipart/form-data@ form upload.+Build these with 'simplePart', 'filePart', or 'inputStreamPart'.+-}+data Part = Part+ { partFieldName :: FieldName+ , partContentType :: Maybe ContentType+ , partFilename :: Maybe FilePath+ , partDataHandler :: OutputStream Builder -> IO ()+ }++{- |+Given a simple static set of bytes, send them as a part in a multipart form+upload. You need to specify the name of the field for the form, and optionally+can supply a MIME content-type.+-}+simplePart :: FieldName -> Maybe ContentType -> ByteString -> Part+simplePart name possibleContentType x' =+ let action o = do+ i1 <- Streams.fromByteString x'+ i2 <- Streams.map Builder.fromByteString i1+ Streams.supply i2 o+ in Part name possibleContentType Nothing action++{- |+The most common case in using multipart form data is to upload a file. Specify+the name of the field, optionally a MIME content-type, and then the path to+the file to be transmitted. The filename (without directory) will be used to+name the file to the server.+-}+filePart :: FieldName -> Maybe ContentType -> FilePath -> Part+filePart name possibleContentType path =+ let action o = do+ Streams.withFileAsInput+ path+ ( \i1 -> do+ i2 <- Streams.map Builder.fromByteString i1+ Streams.supply i2 o+ )++ filename = takeFileName path+ in Part name possibleContentType (Just filename) action++{- |+Build a piece of a multipart submission from an 'InputStream'. You need to+specify a field name for this piece of the submission, and can optionally+indicate the MIME type and a filename (if what you are sending is going to be+interpreted as a file).+-}+inputStreamPart :: FieldName -> Maybe ContentType -> Maybe FilePath -> InputStream ByteString -> Part+inputStreamPart name possibleContentType possilbeFilename i1 =+ let action o = do+ i2 <- Streams.map Builder.fromByteString i1+ Streams.supply i2 o+ in Part name possibleContentType possilbeFilename action++{- |+Place content on the server at the given URL via an HTTP PUT+request, specifying the content type and a function to write the+content to the supplied 'OutputStream'. You might see:++> put "http://s3.example.com/bucket42/object149" "text/plain"+> (fileBody "hello.txt") (\p i -> do+> putStr $ show p+> Streams.connect i stdout)+-}+put ::+ -- | Resource to PUT to.+ URL ->+ -- | MIME type of the request body being sent.+ ContentType ->+ -- | Handler function to write content to server.+ (OutputStream Builder -> IO α) ->+ -- | Handler function to receive the response from the server.+ (Response -> InputStream ByteString -> IO β) ->+ IO β put r' t body handler = do bracket (establish u)@@ -524,9 +628,9 @@ u = parseURL r' q = buildRequest1 $ do- http PUT (path u)- setAccept "*/*"- setHeader "Content-Type" t+ http PUT (pathFrom u)+ setAccept "*/*"+ setHeader "Content-Type" t process c = do _ <- sendRequest c q body@@ -534,23 +638,25 @@ x <- receiveResponse c handler return x ------- | A special case of 'concatHandler', this function will return the--- entire response body as a single ByteString, but will throw--- 'HttpClientError' if the response status code was other than @2xx@.----concatHandler' :: Response -> InputStream ByteString -> IO ByteString-concatHandler' p i =+{- |+A special case of 'concatHandler', this function will return the+entire response body as a single ByteString, but will throw+'HttpClientError' if the response status code was other than @2xx@.+-}+simpleHandler' :: Response -> InputStream ByteString -> IO ByteString+simpleHandler' p i = if s >= 300 then throw (HttpClientError s m)- else concatHandler p i+ else simpleHandler p i where s = getStatusCode p m = getStatusMessage p +concatHandler' :: Response -> InputStream ByteString -> IO ByteString+concatHandler' = simpleHandler'+ data HttpClientError = HttpClientError Int ByteString- deriving (Typeable)+ deriving (Typeable) instance Exception HttpClientError @@ -564,54 +670,53 @@ not like we'd want anything different in their Show instances. -} --{-|+{- | If you've got an object of a type with a 'ToJSON' instance and you need to send that object as JSON up to a web service API, this can help. You use this partially applied: > sendRequest c q (jsonBody thing)- -} jsonBody :: ToJSON a => a -> OutputStream Builder -> IO () jsonBody thing o = do let b = Builder.fromLazyByteString (encode thing) Streams.write (Just b) o ------ | If you're working with a data stream that is in @application/json@,--- then chances are you're using @aeson@ to handle the JSON to Haskell--- decoding. If so, then this helper function might be of use.------ > v <- get "http://api.example.com/v1/" jsonHandler------ This function feeds the input body to the 'Data.Aeson.Parser.json''--- @attoparsec@ Parser in order to get the aeson Value type. This is then--- marshalled to your type represeting the source data, via the FromJSON--- typeclass.------ The above example was actually insufficient; when working with--- @aeson@ you need to fix the type so it knows what FromJSON instance--- to use. Let's say you're getting Person objects, then it would be------ > v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person------ assuming your Person type had a FromJSON instance, of course.------ /Note/------ This function parses a single top level JSON object or array, which--- is all you're supposed to get if it's a valid document. People do--- all kinds of crazy things though, so beware. Also, this function (like the--- "concatHander" convenience) loads the entire response into memory; it's--- not /streaming/; if you're receiving a document which is (say) a very--- long array of objects then you may want to implement your own--- handler function, perhaps using "Streams.parserToInputStream" and--- the 'Data.Aeson.Parser' combinators directly — with a result type of--- InputStream Value, perhaps — by which you could then iterate over--- the Values one at a time in constant space.---+{- |+If you're working with a data stream that is in @application/json@,+then chances are you're using @aeson@ to handle the JSON to Haskell+decoding. If so, then this helper function might be of use.++> v <- get "http://api.example.com/v1/" jsonHandler++This function feeds the input body to the 'Data.Aeson.Parser.json''+@attoparsec@ Parser in order to get the aeson Value type. This is then+marshalled to your type represeting the source data, via the FromJSON+typeclass.++The above example was actually insufficient; when working with+@aeson@ you need to fix the type so it knows what FromJSON instance+to use. Let's say you're getting Person objects, then it would be++> v <- get "http://api.example.com/v1/person/461" jsonHandler :: IO Person++assuming your Person type had a FromJSON instance, of course.++/Note/++This function parses a single top level JSON object or array, which+is all you're supposed to get if it's a valid document. People do+all kinds of crazy things though, so beware. Also, this function (like the+"concatHander" convenience) loads the entire response into memory; it's+not /streaming/; if you're receiving a document which is (say) a very+long array of objects then you may want to implement your own+handler function, perhaps using "Streams.parserToInputStream" and+the 'Data.Aeson.Parser' combinators directly — with a result type of+InputStream Value, perhaps — by which you could then iterate over+the Values one at a time in constant space.+-}+ {- This looks simple. It wasn't. The types involved are rediculous to disentangle. The biggest problem is that the Parser type used in@@ -629,14 +734,14 @@ Result α). Then finally, pull the result out of it. Why in Bog's name this wasn't just Either I'll never know. -}-jsonHandler- :: (FromJSON α)- => Response- -> InputStream ByteString- -> IO α+jsonHandler ::+ (FromJSON α) =>+ Response ->+ InputStream ByteString ->+ IO α jsonHandler _ i = do- v <- Streams.parseFromStream json' i -- Value- let r = fromJSON v -- Result+ v <- Streams.parseFromStream json' i -- Value+ let r = fromJSON v -- Result case r of- (Success a) -> return a- (Error str) -> error str+ (Success a) -> return a+ (Error str) -> error str
lib/Network/Http/ResponseParser.hs view
@@ -1,7 +1,7 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd+-- Copyright © 2012-2021 Athae Eredh Siniath and Others -- -- The code in this file, and the program it is a part of, is -- made available to you by its authors as open source software:@@ -14,20 +14,18 @@ -- src/Snap/Internal/Http/Parser.hs, and various utility functions -- have been cloned from there. ----{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide, not-home #-} module Network.Http.ResponseParser ( readResponseHeader, readResponseBody,- UnexpectedCompression(..),-- -- for testing- readDecimal+ UnexpectedCompression (..),+ -- for testing+ readDecimal, ) where import Prelude hiding (take, takeWhile)@@ -64,61 +62,60 @@ __BITE_SIZE__ :: Int __BITE_SIZE__ = 32 * 1024 - {- Process the reply from the server up to the end of the headers as deliniated by a blank line. -} readResponseHeader :: InputStream ByteString -> IO Response readResponseHeader i = do- (sc,sm) <- Streams.parseFromStream parseStatusLine i+ (sc, sm) <- Streams.parseFromStream parseStatusLine i hs <- readHeaderFields i - let h = buildHeaders hs+ let h = buildHeaders hs let te = case lookupHeader h "Transfer-Encoding" of- Just x' -> if mk x' == "chunked"- then Chunked- else None+ Just x' ->+ if mk x' == "chunked"+ then Chunked+ else None Nothing -> None let ce = case lookupHeader h "Content-Encoding" of- Just x' -> if mk x' == "gzip"- then Gzip- else Identity+ Just x' ->+ if mk x' == "gzip"+ then Gzip+ else Identity Nothing -> Identity let nm = case lookupHeader h "Content-Length" of Just x' -> Just (readDecimal x' :: Int64) Nothing -> case sc of- 204 -> Just 0- 304 -> Just 0- 100 -> Just 0- _ -> Nothing-- return Response {- pStatusCode = sc,- pStatusMsg = sm,- pTransferEncoding = te,- pContentEncoding = ce,- pContentLength = nm,- pHeaders = h- }+ 204 -> Just 0+ 304 -> Just 0+ 100 -> Just 0+ _ -> Nothing + return+ Response+ { pStatusCode = sc+ , pStatusMsg = sm+ , pTransferEncoding = te+ , pContentEncoding = ce+ , pContentLength = nm+ , pHeaders = h+ } -parseStatusLine :: Parser (Int,ByteString)+parseStatusLine :: Parser (Int, ByteString) parseStatusLine = do sc <- string "HTTP/1." *> satisfy version *> char ' ' *> decimal <* char ' ' sm <- takeTill (== '\r') <* crlf- return (sc,sm)+ return (sc, sm) where version c = c == '1' || c == '0' - crlf :: Parser ByteString crlf = string "\r\n" - --------------------------------------------------------------------- {-@@ -127,17 +124,16 @@ -} readResponseBody :: Response -> InputStream ByteString -> IO (InputStream ByteString) readResponseBody p i1 = do- i2 <- case t of- None -> case l of- Just n -> readFixedLengthBody i1 n- Nothing -> readUnlimitedBody i1- Chunked -> readChunkedBody i1+ None -> case l of+ Just n -> readFixedLengthBody i1 n+ Nothing -> readUnlimitedBody i1+ Chunked -> readChunkedBody i1 i3 <- case c of- Identity -> return i2- Gzip -> readCompressedBody i2- Deflate -> throwIO (UnexpectedCompression $ show c)+ Identity -> return i2+ Gzip -> readCompressedBody i2+ Deflate -> throwIO (UnexpectedCompression $ show c) return i3 where@@ -145,7 +141,6 @@ c = pContentEncoding p l = pContentLength p - readDecimal :: (Enum α, Num α, Bits α) => ByteString -> α readDecimal str' = S.foldl' f 0 x'@@ -156,16 +151,16 @@ {-# INLINE digitToInt #-} digitToInt :: (Enum α, Num α, Bits α) => Char -> α- digitToInt c | c >= '0' && c <= '9' = toEnum $! ord c - ord '0'- | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit"+ digitToInt c+ | c >= '0' && c <= '9' = toEnum $! ord c - ord '0'+ | otherwise = error $ "'" ++ [c] ++ "' is not an ascii digit" {-# INLINE readDecimal #-} data UnexpectedCompression = UnexpectedCompression String- deriving (Typeable, Show)+ deriving (Typeable, Show) instance Exception UnexpectedCompression - --------------------------------------------------------------------- {-@@ -177,7 +172,6 @@ i2 <- Streams.fromGenerator (consumeChunks i1) return i2 - {- For a response body in chunked transfer encoding, iterate over the individual chunks, reading the size parameter, then@@ -197,11 +191,10 @@ else do -- skip "trailers" and consume final CRLF skipEnd- where go 0 = return () go !n = do- (!x',!r) <- liftIO $ readN n i1+ (!x', !r) <- liftIO $ readN n i1 Streams.yield x' go r @@ -231,17 +224,18 @@ where !d = n - size - !p = if d > 0- then size- else n+ !p =+ if d > 0+ then size+ else n - !r = if d > 0- then d- else 0+ !r =+ if d > 0+ then d+ else 0 size = __BITE_SIZE__ - transferChunkSize :: Parser (Int) transferChunkSize = do !n <- hexadecimal@@ -249,7 +243,6 @@ void crlf return n - --------------------------------------------------------------------- {-@@ -271,7 +264,6 @@ readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString) readUnlimitedBody i1 = do return i1- ---------------------------------------------------------------------
lib/Network/Http/Utilities.hs view
@@ -1,7 +1,7 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd+-- Copyright © 2012-2021 Athae Eredh Siniath and Others -- -- The code in this file, and the program it is a part of, is -- made available to you by its authors as open source software:@@ -17,19 +17,18 @@ -- kept separate to aid syncing changes from snap-core as they -- become available. ----{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK hide, not-home #-}- + module Network.Http.Utilities ( readResponseLine,- readHeaderFields+ readHeaderFields, ) where ------------------------------------------------------------------------------@@ -41,9 +40,10 @@ import qualified Data.ByteString.Unsafe as S import Data.Char hiding (digitToInt, isDigit, isSpace) import GHC.Exts (Int (..), Int#, (+#))-import Prelude hiding (head, take, takeWhile) import System.IO.Streams (InputStream) import qualified System.IO.Streams as Streams+import Prelude hiding (head, take, takeWhile)+ ---------------------------------------------------------------------------- import Network.Http.Types@@ -59,30 +59,28 @@ parseRequest input = do eof <- Streams.atEOF input if eof- then return Nothing- else do- line <- readResponseLine input- let (!mStr,!s) = bSp line- let (!uri, !vStr) = bSp s- let !version = pVer vStr :: (Int,Int)---- hdrs <- readHeaderFields input- return $! Nothing+ then return Nothing+ else do+ line <- readResponseLine input+ let (!mStr, !s) = bSp line+ let (!uri, !vStr) = bSp s+ let !version = pVer vStr :: (Int, Int) + -- hdrs <- readHeaderFields input+ return $! Nothing where-- pVer s = if "HTTP/" `S.isPrefixOf` s- then pVers (S.unsafeDrop 5 s)- else (1, 0)+ pVer s =+ if "HTTP/" `S.isPrefixOf` s+ then pVers (S.unsafeDrop 5 s)+ else (1, 0) - bSp = splitCh ' '+ bSp = splitCh ' ' pVers s = (c, d) where- (!a, !b) = splitCh '.' s- !c = unsafeFromNat a- !d = unsafeFromNat b-+ (!a, !b) = splitCh '.' s+ !c = unsafeFromNat a+ !d = unsafeFromNat b {- Read a single line of an HTTP response.@@ -92,21 +90,21 @@ where throwNoCRLF = throwIO $- HttpParseException "parse error: expected line ending in crlf"+ HttpParseException "parse error: expected line ending in crlf" throwBadCRLF = throwIO $- HttpParseException "parse error: got cr without subsequent lf"+ HttpParseException "parse error: got cr without subsequent lf" go !l = do !mb <- Streams.read input- !s <- maybe throwNoCRLF return mb+ !s <- maybe throwNoCRLF return mb case findCRLF s of FoundCRLF idx# -> foundCRLF l s idx#- NoCR -> noCRLF l s- LastIsCR idx# -> lastIsCR l s idx#- _ -> throwBadCRLF+ NoCR -> noCRLF l s+ LastIsCR idx# -> lastIsCR l s idx#+ _ -> throwBadCRLF foundCRLF l s idx# = do let !i1 = (I# idx#)@@ -117,94 +115,92 @@ Streams.unRead b input -- Optimize for the common case: dl is almost always "id"- let !out = if null l then a else S.concat (reverse (a:l))+ let !out = if null l then a else S.concat (reverse (a : l)) return out - noCRLF l s = go (s:l)+ noCRLF l s = go (s : l) lastIsCR l s idx# = do !t <- Streams.read input >>= maybe throwNoCRLF return if S.null t- then lastIsCR l s idx#- else do- let !c = S.unsafeHead t- if c /= 10- then throwBadCRLF- else do- let !a = S.unsafeTake (I# idx#) s- let !b = S.unsafeDrop 1 t- when (not $ S.null b) $ Streams.unRead b input- let !out = if null l then a else S.concat (reverse (a:l))- return out-+ then lastIsCR l s idx#+ else do+ let !c = S.unsafeHead t+ if c /= 10+ then throwBadCRLF+ else do+ let !a = S.unsafeTake (I# idx#) s+ let !b = S.unsafeDrop 1 t+ when (not $ S.null b) $ Streams.unRead b input+ let !out = if null l then a else S.concat (reverse (a : l))+ return out -------------------------------------------------------------------------------data CS = FoundCRLF !Int#- | NoCR- | LastIsCR !Int#- | BadCR-+data CS+ = FoundCRLF !Int#+ | NoCR+ | LastIsCR !Int#+ | BadCR ------------------------------------------------------------------------------ findCRLF :: ByteString -> CS findCRLF b = case S.elemIndex '\r' b of- Nothing -> NoCR- Just !i@(I# i#) ->- let !i' = i + 1- in if i' < S.length b- then if S.unsafeIndex b i' == 10- then FoundCRLF i#- else BadCR- else LastIsCR i#+ Nothing -> NoCR+ Just !i@(I# i#) ->+ let !i' = i + 1+ in if i' < S.length b+ then+ if S.unsafeIndex b i' == 10+ then FoundCRLF i#+ else BadCR+ else LastIsCR i# {-# INLINE findCRLF #-} - ------------------------------------------------------------------------------ splitCh :: Char -> ByteString -> (ByteString, ByteString) splitCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) where- f !i = let !a = S.unsafeTake i s- !b = S.unsafeDrop (i + 1) s- in (a, b)+ f !i =+ let !a = S.unsafeTake i s+ !b = S.unsafeDrop (i + 1) s+ in (a, b) {-# INLINE splitCh #-} - ------------------------------------------------------------------------------ breakCh :: Char -> ByteString -> (ByteString, ByteString) breakCh !c !s = maybe (s, S.empty) f (S.elemIndex c s) where- f !i = let !a = S.unsafeTake i s- !b = S.unsafeDrop i s- in (a, b)+ f !i =+ let !a = S.unsafeTake i s+ !b = S.unsafeDrop i s+ in (a, b) {-# INLINE breakCh #-} - ------------------------------------------------------------------------------ splitHeader :: ByteString -> (ByteString, ByteString) splitHeader !s = maybe (s, S.empty) f (S.elemIndex ':' s) where l = S.length s - f i = let !a = S.unsafeTake i s- in (a, skipSp (i + 1))-- skipSp !i | i >= l = S.empty- | otherwise = let c = S.unsafeIndex s i- in if isLWS $ w2c c- then skipSp $ i + 1- else S.unsafeDrop i s+ f i =+ let !a = S.unsafeTake i s+ in (a, skipSp (i + 1)) + skipSp !i+ | i >= l = S.empty+ | otherwise =+ let c = S.unsafeIndex s i+ in if isLWS $ w2c c+ then skipSp $ i + 1+ else S.unsafeDrop i s {-# INLINE splitHeader #-} -- ------------------------------------------------------------------------------ isLWS :: Char -> Bool isLWS c = c == ' ' || c == '\t' {-# INLINE isLWS #-} - ------------------------------------------------------------------------------ {-@@ -213,50 +209,50 @@ when it hits the "blank" line (ie, CRLF CRLF pair), which it consumes. -}-readHeaderFields :: InputStream ByteString -> IO [(ByteString,ByteString)]+readHeaderFields :: InputStream ByteString -> IO [(ByteString, ByteString)] readHeaderFields input = do f <- go id return $! f []- where go !dlistSoFar = do line <- readResponseLine input if S.null line- then return dlistSoFar- else do- let (!k,!v) = splitHeader line- vf <- pCont id- let vs = vf []- let !v' = if null vs then v else S.concat (v:vs)- let !t = (k,v')- go (dlistSoFar . (t:))-+ then return dlistSoFar+ else do+ let (!k, !v) = splitHeader line+ vf <- pCont id+ let vs = vf []+ let !v' = if null vs then v else S.concat (v : vs)+ let !t = (k, v')+ go (dlistSoFar . (t :)) where trimBegin = S.dropWhile isLWS pCont !dlist = do- mbS <- Streams.peek input- maybe (return dlist)- (\s -> if S.null s- then Streams.read input >> pCont dlist- else if isLWS $ w2c $ S.unsafeHead s- then procCont dlist- else return dlist)- mbS+ mbS <- Streams.peek input+ maybe+ (return dlist)+ ( \s ->+ if S.null s+ then Streams.read input >> pCont dlist+ else+ if isLWS $ w2c $ S.unsafeHead s+ then procCont dlist+ else return dlist+ )+ mbS procCont !dlist = do line <- readResponseLine input let !t = trimBegin line- pCont (dlist . (" ":) . (t:))---- ------------------------ -- utility functions --- -----------------------+ pCont (dlist . (" " :) . (t :)) +-----------------------+-- utility functions --+----------------------- ------------------------------------------------------------------------------+ -- | Note: only works for nonnegative naturals unsafeFromNat :: (Enum a, Num a, Bits a) => ByteString -> a unsafeFromNat = S.foldl' f 0@@ -264,9 +260,10 @@ zero = ord '0' f !cnt !i = cnt * 10 + toEnum (digitToInt i) - digitToInt c = if d >= 0 && d <= 9- then d- else error $ "bad digit: '" ++ [c] ++ "'"+ digitToInt c =+ if d >= 0 && d <= 9+ then d+ else error $ "bad digit: '" ++ [c] ++ "'" where !d = ord c - zero {-# INLINE unsafeFromNat #-}
tests/MockServer.hs view
@@ -1,15 +1,15 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- Copyright © 2012-2021 Athae Eredh Siniath and Others -- -- The code in this file, and the program it is a part of, is made -- available to you by its authors as open source software: you can -- redistribute it and/or modify it under a BSD licence. --- {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE PackageImports #-}+ {-# OPTIONS -fno-warn-dodgy-imports #-} module MockServer (runMockServer, localPort) where@@ -52,13 +52,13 @@ go :: IO () go = httpServe c site where- c = setAccessLog ConfigNoLog $- setErrorLog ConfigNoLog $- setHostname localHost $- setBind localHost $- setPort (fromIntegral localPort) $- setVerbose False emptyConfig-+ c =+ setAccessLog ConfigNoLog $+ setErrorLog ConfigNoLog $+ setHostname localHost $+ setBind localHost $+ setPort (fromIntegral localPort) $+ setVerbose False emptyConfig runMockServer :: IO () runMockServer = do@@ -71,27 +71,28 @@ -- site :: Snap ()-site = catch- (routeRequests)- (\e -> serveError "Splat\n" e)+site =+ catch+ (routeRequests)+ (\e -> serveError "Splat\n" e) routeRequests :: Snap () routeRequests = route- [("resource/:id", serveResource),- ("static/:id", method GET serveStatic),- ("time", serveTime),- ("", ifTop handleAsText),- ("bounce", serveRedirect),- ("local", serveLocalRedirect),- ("loop", serveRedirectEndlessly),- ("empty", serveWithoutContent),- ("postbox", method POST handlePostMethod),- ("size", handleSizeRequest),- ("api", handleRestfulRequest),- ("cookies", serveRepeatedResponseHeaders)]- <|> serveNotFound-+ [ ("resource/:id", serveResource)+ , ("static/:id", method GET serveStatic)+ , ("time", serveTime)+ , ("", ifTop handleAsText)+ , ("bounce", serveRedirect)+ , ("local", serveLocalRedirect)+ , ("loop", serveRedirectEndlessly)+ , ("empty", serveWithoutContent)+ , ("postbox", method POST handlePostMethod)+ , ("size", handleSizeRequest)+ , ("api", handleRestfulRequest)+ , ("cookies", serveRepeatedResponseHeaders)+ ]+ <|> serveNotFound serveResource :: Snap () serveResource = do@@ -99,10 +100,9 @@ let m = rqMethod r case m of- GET -> handleGetMethod- PUT -> handlePutWithExpectation- _ -> serveMethodNotAllowed-+ GET -> handleGetMethod+ PUT -> handlePutWithExpectation+ _ -> serveMethodNotAllowed serveStatic :: Snap () serveStatic = do@@ -120,12 +120,10 @@ b' <- liftIO $ S.readFile f writeBS b' - serveTime :: Snap () serveTime = do writeBS "Sun 30 Dec 12, 05:39:56.746Z\n" - -- -- Dispatch normal GET requests based on MIME type. --@@ -136,9 +134,8 @@ let mime0 = getHeader "Accept" r case mime0 of- Just "text/html" -> handleAsBrowser- _ -> handleAsText-+ Just "text/html" -> handleAsBrowser+ _ -> handleAsText handleAsBrowser :: Snap () handleAsBrowser = do@@ -147,13 +144,11 @@ modifyResponse $ setHeader "Cache-Control" "max-age=1" sendFile "tests/hello.html" - handleAsText :: Snap () handleAsText = do modifyResponse $ setContentType "text/plain" writeBS "Sounds good to me\n" - handleRestfulRequest :: Snap () handleRestfulRequest = do modifyResponse $ setResponseStatus 200 "OK"@@ -161,7 +156,6 @@ sendFile "tests/data-eu-gdp.json" - serveRedirect :: Snap () serveRedirect = do modifyResponse $ setResponseStatus 307 "Temporary Redirect"@@ -198,7 +192,6 @@ modifyResponse $ setResponseStatus 204 "No Content" modifyResponse $ setHeader "Cache-Control" "no-cache" - serveRepeatedResponseHeaders :: Snap () serveRepeatedResponseHeaders = do modifyResponse $ addHeader "Set-Cookie" "stone=diamond"@@ -215,7 +208,6 @@ b' <- readRequestBody 1024 writeLBS b' - handlePutWithExpectation :: Snap () handlePutWithExpectation = do setTimeout 5@@ -226,7 +218,6 @@ b' <- readRequestBody 1024 writeLBS b' - handleSizeRequest :: Snap () handleSizeRequest = do r <- getRequest@@ -234,7 +225,7 @@ t <- case mm of Just m -> return m- _ -> do+ _ -> do serveUnsupported return "" @@ -244,7 +235,6 @@ b' <- readRequestBody 65536 writeBS $ S.pack $ show $ L.length b' - updateResource :: Snap () updateResource = do bs' <- readRequestBody 4096@@ -262,7 +252,6 @@ where fromLazy ls' = S.concat $ L.toChunks ls' - serveNotFound :: Snap a serveNotFound = do modifyResponse $ setResponseStatus 404 "Not Found"@@ -273,13 +262,11 @@ r <- getResponse finishWith r - serveBadRequest :: Snap () serveBadRequest = do modifyResponse $ setResponseStatus 400 "Bad Request" writeBS "400 Bad Request\n" - serveMethodNotAllowed :: Snap () serveMethodNotAllowed = do modifyResponse $ setResponseStatus 405 "Method Not Allowed"@@ -289,7 +276,6 @@ r <- getResponse finishWith r - serveUnsupported :: Snap () serveUnsupported = do modifyResponse $ setResponseStatus 415 "Unsupported Media Type"@@ -297,7 +283,6 @@ r <- getResponse finishWith r - -- -- The exception will be dumped to the server's stdout, while the supplied -- message will be sent out with the response (ideally only for debugging@@ -314,12 +299,9 @@ where msg = show (e :: SomeException) - debug :: String -> Snap () debug cs = do liftIO $ do hPutStrLn stderr "" hPutStrLn stderr cs hFlush stderr--
tests/TestSuite.hs view
@@ -1,30 +1,44 @@ -- -- HTTP client for use with io-streams ----- Copyright © 2012-2014 Operational Dynamics Consulting, Pty Ltd+-- Copyright © 2012-2021 Athae Eredh Siniath and Others -- -- The code in this file, and the program it is a part of, is made -- available to you by its authors as open source software: you can -- redistribute it and/or modify it under a BSD licence. ----{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+ {-# OPTIONS -fno-warn-unused-imports #-} module TestSuite where import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder (fromByteString,- toByteString)-import qualified Blaze.ByteString.Builder.Char8 as Builder (fromChar,- fromString)+import qualified Blaze.ByteString.Builder as Builder (+ fromByteString,+ toByteString,+ )+import qualified Blaze.ByteString.Builder.Char8 as Builder (+ fromChar,+ fromString,+ ) import Control.Applicative import Control.Concurrent (MVar, newEmptyMVar, putMVar, takeMVar) import Control.Exception (Exception, bracket, handleJust) import Control.Monad (forM_, guard)-import Data.Aeson (FromJSON, ToJSON, Value (..), json, object, parseJSON,- toJSON, (.:), (.=), encode)+import Data.Aeson (+ FromJSON,+ ToJSON,+ Value (..),+ encode,+ json,+ object,+ parseJSON,+ toJSON,+ (.:),+ (.=),+ ) import Data.Aeson.Encode.Pretty import Data.Bits import qualified Data.HashMap.Strict as Map@@ -36,11 +50,11 @@ import qualified Data.Text.Encoding as Text import GHC.Generics hiding (Selector) import Network.Socket (SockAddr (..))-import Network.URI (parseURI, URI(..), URIAuth(..))+import Network.URI (URI (..), URIAuth (..), parseURI) import System.Timeout (timeout)+import Test.HUnit import Test.Hspec (Spec, describe, it) import Test.Hspec.Expectations (Selector, anyException, shouldThrow)-import Test.HUnit import Debug.Trace @@ -64,14 +78,20 @@ import MockServer (localPort) import Network.Http.Client import Network.Http.Connection (Connection (..))-import Network.Http.Inconvenience (HttpClientError (..),- TooManyRedirects (..),- splitURI, parseURL)-import Network.Http.Internal (Request (..), Response (..),- composeRequestBytes, lookupHeader)+import Network.Http.Inconvenience (+ HttpClientError (..),+ TooManyRedirects (..),+ parseURL,+ splitURI,+ )+import Network.Http.Internal (+ Request (..),+ Response (..),+ composeRequestBytes,+ lookupHeader,+ ) import Network.Http.ResponseParser (readDecimal, readResponseHeader) - localhost = S.pack ("localhost:" ++ show localPort) suite :: Spec@@ -90,7 +110,7 @@ testResponseParser1 testResponseParserMismatch testPaddedContentLength--- testTrailingWhitespace+ -- testTrailingWhitespace testChunkedEncoding testContentLength testDevoidOfContent@@ -115,8 +135,9 @@ testEstablishConnection testParsingJson1 testParsingJson2- testPostWithSimple- testPostWithJson+ testPutWithSimple+ testPutWithJson+ testMultipartUpload describe "Corner cases in protocol compliance" $ do testSendBodyFor PUT@@ -127,44 +148,48 @@ it "terminates with a blank line" $ do c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http GET "/time"- setAccept "text/plain"+ http GET "/time"+ setAccept "text/plain" let e' = Builder.toByteString $ composeRequestBytes q "booga" let n = S.length e' - 4- let (a',b') = S.splitAt n e'+ let (a', b') = S.splitAt n e' assertEqual "Termination not CRLF CRLF" "\r\n\r\n" b'- assertBool "Must be only one blank line at end of headers"+ assertBool+ "Must be only one blank line at end of headers" ('\n' /= S.last a') closeConnection c testRequestLineFormat = do- it "has a properly formatted request line" $ bracket- (fakeConnection)- (return)- (\c -> do- let q = buildRequest1 $ do+ it "has a properly formatted request line" $+ bracket+ (fakeConnection)+ (return)+ ( \c -> do+ let q = buildRequest1 $ do http GET "/time" - let e' = Builder.toByteString $ composeRequestBytes q (cHost c)- let l' = S.takeWhile (/= '\r') e'+ let e' = Builder.toByteString $ composeRequestBytes q (cHost c)+ let l' = S.takeWhile (/= '\r') e' - assertEqual "Invalid HTTP request line" "GET /time HTTP/1.1" l')+ assertEqual "Invalid HTTP request line" "GET /time HTTP/1.1" l'+ ) - it "handles empty request path" $ bracket- (fakeConnection)- (return)- (\c -> do- let q = buildRequest1 $ do+ it "handles empty request path" $+ bracket+ (fakeConnection)+ (return)+ ( \c -> do+ let q = buildRequest1 $ do http GET "" - let e' = Builder.toByteString $ composeRequestBytes q (cHost c)- let l' = S.takeWhile (/= '\r') e'-- assertEqual "Invalid HTTP request line" "GET / HTTP/1.1" l')+ let e' = Builder.toByteString $ composeRequestBytes q (cHost c)+ let l' = S.takeWhile (/= '\r') e' + assertEqual "Invalid HTTP request line" "GET / HTTP/1.1" l'+ ) fakeConnection :: IO Connection fakeConnection = do@@ -173,11 +198,10 @@ c <- makeConnection "www.example.com" (return ()) o i return c - testAcceptHeaderFormat = it "properly formats Accept header" $ do let q = buildRequest1 $ do- setAccept' [("text/html", 1),("*/*", 0.0)]+ setAccept' [("text/html", 1), ("*/*", 0.0)] let h = qHeaders q let (Just a) = lookupHeader h "Accept"@@ -186,25 +210,27 @@ testBasicAuthorizatonHeader = it "properly formats Authorization header" $ do let q = buildRequest1 $ do- setAuthorizationBasic "Aladdin" "open sesame"+ setAuthorizationBasic "Aladdin" "open sesame" let h = qHeaders q let (Just a) = lookupHeader h "Authorization" assertEqual "Failed to format header" "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" a - testConnectionHost = do it "properly caches hostname and port" $ do- bracket (openConnection "localhost" localPort)- closeConnection- (\c -> do- let h' = cHost c- assertEqual "Host value needs to be name, not IP address"- expected h')+ bracket+ (openConnection "localhost" localPort)+ closeConnection+ ( \c -> do+ let h' = cHost c+ assertEqual+ "Host value needs to be name, not IP address"+ expected+ h'+ ) where expected = S.pack $ "localhost:" ++ show localPort - {- Incidentally, Host is *not* stored in the Headers map, but is a field of the Request object.@@ -212,26 +238,25 @@ testEnsureHostField = it "has a properly formatted Host header" $ do let q1 = buildRequest1 $ do- http GET "/hello.txt"+ http GET "/hello.txt" let h1 = qHost q1 assertEqual "Incorrect Host header" Nothing h1 let q2 = buildRequest1 $ do- http GET "/hello.txt"- setHostname "other.example.com" 80+ http GET "/hello.txt"+ setHostname "other.example.com" 80 let h2 = qHost q2 assertEqual "Incorrect Host header" (Just "other.example.com") h2 let q3 = buildRequest1 $ do- http GET "/hello.txt"- setHostname "other.example.com" 54321+ http GET "/hello.txt"+ setHostname "other.example.com" 54321 let h3 = qHost q3 assertEqual "Incorrect Host header" (Just "other.example.com:54321") h3 - testResponseParser1 = it "parses a simple 200 response" $ do p <- Streams.withFileAsInput "tests/example1.txt" (\i -> readResponseHeader i)@@ -268,45 +293,50 @@ c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http GET "/time"+ http GET "/time" sendRequest c q emptyBody- receiveResponse c (\p i1 -> do- let cm = getHeader p "Transfer-Encoding"- assertEqual "Should be chunked encoding!" (Just "chunked") cm-- (i2, getCount) <- Streams.countInput i1- Streams.skipToEof i2+ receiveResponse+ c+ ( \p i1 -> do+ let cm = getHeader p "Transfer-Encoding"+ assertEqual "Should be chunked encoding!" (Just "chunked") cm - len <- getCount- assertEqual "Incorrect number of bytes read" 29 len)+ (i2, getCount) <- Streams.countInput i1+ Streams.skipToEof i2 + len <- getCount+ assertEqual "Incorrect number of bytes read" 29 len+ ) testContentLength = do it "recognzies fixed length message" $ do c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http GET "/static/statler.jpg"+ http GET "/static/statler.jpg" sendRequest c q emptyBody - receiveResponse c (\p i1 -> do- let nm = getHeader p "Content-Length"- assertMaybe "Should be a Content-Length header!" nm+ receiveResponse+ c+ ( \p i1 -> do+ let nm = getHeader p "Content-Length"+ assertMaybe "Should be a Content-Length header!" nm - let n = read $ S.unpack $ fromJust nm :: Int- assertEqual "Should be a fixed length message!" 4611 n+ let n = read $ S.unpack $ fromJust nm :: Int+ assertEqual "Should be a fixed length message!" 4611 n - (i2, getCount) <- Streams.countInput i1- x' <- Streams.readExactly 4611 i2+ (i2, getCount) <- Streams.countInput i1+ x' <- Streams.readExactly 4611 i2 - len <- getCount- assertEqual "Incorrect number of bytes read" 4611 len- assertBool "Incorrect length" (4611 == S.length x')+ len <- getCount+ assertEqual "Incorrect number of bytes read" 4611 len+ assertBool "Incorrect length" (4611 == S.length x') - end <- Streams.atEOF i2- assertBool "Expected end of stream" end)+ end <- Streams.atEOF i2+ assertBool "Expected end of stream" end+ ) it "doesn't choke if server neglects Content-Length" $ do p <- Streams.withFileAsInput "tests/example3.txt" (\i -> readResponseHeader i)@@ -319,22 +349,24 @@ it "reads body without Content-Length or Transfer-Encoding" $ do c <- fakeConnectionHttp10 let q = buildRequest1 $ do- http GET "/fake"+ http GET "/fake" sendRequest c q emptyBody- receiveResponse c (\_ i1 -> do- (i2, getCount) <- Streams.countInput i1- o <- Streams.nullOutput- Streams.connect i2 o+ receiveResponse+ c+ ( \_ i1 -> do+ (i2, getCount) <- Streams.countInput i1+ o <- Streams.nullOutput+ Streams.connect i2 o - end <- Streams.atEOF i2- assertBool "Expected end of stream" end+ end <- Streams.atEOF i2+ assertBool "Expected end of stream" end - len <- getCount- assertEqual "Incorrect number of bytes read" 4611 len)+ len <- getCount+ assertEqual "Incorrect number of bytes read" 4611 len+ ) return () - fakeConnectionHttp10 :: IO Connection fakeConnectionHttp10 = do x' <- S.readFile "tests/example3.txt"@@ -344,7 +376,6 @@ c <- makeConnection "bad.example.com" (return ()) o i return c - {- Corner case where servers responding 204 No Content are not required to transmit a Content-Length header; Snap *does* send one, so we can't test it@@ -352,24 +383,27 @@ -} testDevoidOfContent = do- it "handles 204 No Content response without Content-Length"- $ timeout_ 2 $ do- (c, mv) <- fakeConnectionNoContent- let q = buildRequest1 $ do+ it "handles 204 No Content response without Content-Length" $+ timeout_ 2 $ do+ (c, mv) <- fakeConnectionNoContent+ let q = buildRequest1 $ do http GET "/fake"- sendRequest c q emptyBody- receiveResponse c (\_ i1 -> do- (i2, getCount) <- Streams.countInput i1- o <- Streams.nullOutput- Streams.connect i2 o+ sendRequest c q emptyBody+ receiveResponse+ c+ ( \_ i1 -> do+ (i2, getCount) <- Streams.countInput i1+ o <- Streams.nullOutput+ Streams.connect i2 o - end <- Streams.atEOF i2- assertBool "Expected end of stream" end+ end <- Streams.atEOF i2+ assertBool "Expected end of stream" end - len <- getCount- assertEqual "Incorrect number of bytes read" 0 len)- putMVar mv ()- return ()+ len <- getCount+ assertEqual "Incorrect number of bytes read" 0 len+ )+ putMVar mv ()+ return () where secs :: Int secs = 10 ^ (6 :: Int)@@ -377,7 +411,6 @@ timeout_ :: Int -> IO a -> IO a timeout_ t m = timeout (t * secs) m >>= maybe (error "timeout") return - fakeConnectionNoContent :: IO (Connection, MVar ()) fakeConnectionNoContent = do x' <- S.readFile "tests/example5.txt"@@ -393,7 +426,6 @@ blockOn :: MVar () -> IO (Maybe ByteString) blockOn mv = takeMVar mv >> return Nothing - {- This had to change when we moved to an internal test server; seems Snap is doing something funny when gzipping and switching to chunked@@ -404,25 +436,28 @@ c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http GET "/static/hello.html"- setHeader "Accept-Encoding" "gzip"+ http GET "/static/hello.html"+ setHeader "Accept-Encoding" "gzip" sendRequest c q emptyBody - receiveResponse c (\p i -> do- let nm = getHeader p "Content-Encoding"- assertMaybe "Should be a Content-Encoding header!" nm- assertEqual "Content-Encoding header should be 'gzip'!" (Just "gzip") nm+ receiveResponse+ c+ ( \p i -> do+ let nm = getHeader p "Content-Encoding"+ assertMaybe "Should be a Content-Encoding header!" nm+ assertEqual "Content-Encoding header should be 'gzip'!" (Just "gzip") nm - (i2, getCount) <- Streams.countInput i- x' <- Streams.readExactly 102 i2+ (i2, getCount) <- Streams.countInput i+ x' <- Streams.readExactly 102 i2 - len <- getCount- assertEqual "Incorrect number of bytes read" 102 len- assertBool "Incorrect length" (102 == S.length x')+ len <- getCount+ assertEqual "Incorrect number of bytes read" 102 len+ assertBool "Incorrect length" (102 == S.length x') - end <- Streams.atEOF i- assertBool "Expected end of stream" end)+ end <- Streams.atEOF i+ assertBool "Expected end of stream" end+ ) {- This isn't much of a test yet; we really need to test@@ -436,70 +471,82 @@ c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http PUT "/resource/x149"- setExpectContinue+ http PUT "/resource/x149"+ setExpectContinue - sendRequest c q (\o -> do- Streams.write (Just (Builder.fromString "Hello world\n")) o)+ sendRequest+ c+ q+ ( \o -> do+ Streams.write (Just (Builder.fromString "Hello world\n")) o+ ) - receiveResponse c (\p i -> do- assertEqual "Incorrect status code" 201 (getStatusCode p)- x' <- Streams.readExactly 12 i+ receiveResponse+ c+ ( \p i -> do+ assertEqual "Incorrect status code" 201 (getStatusCode p)+ x' <- Streams.readExactly 12 i - end <- Streams.atEOF i- assertBool "Expected end of stream" end+ end <- Streams.atEOF i+ assertBool "Expected end of stream" end - assertEqual "Incorrect body" "Hello world\n" x')+ assertEqual "Incorrect body" "Hello world\n" x'+ ) closeConnection c - assertMaybe :: String -> Maybe a -> Assertion assertMaybe prefix m0 = case m0 of Nothing -> assertFailure prefix- Just _ -> assertBool "" True-+ Just _ -> assertBool "" True testPutChunks = it "PUT correctly chunks known size entity body" $ do let url = S.concat ["http://", localhost, "/size"] put url "text/plain" body handler- where- body :: OutputStream Builder -> IO ()- body o = do- let x = mconcat $ replicate 33000 (Builder.fromChar 'x')- Streams.write (Just x) o+ where+ body :: OutputStream Builder -> IO ()+ body o = do+ let x = mconcat $ replicate 33000 (Builder.fromChar 'x')+ Streams.write (Just x) o - handler :: Response -> InputStream ByteString -> IO ()- handler _ i = do- (Just b') <- Streams.read i+ handler :: Response -> InputStream ByteString -> IO ()+ handler _ i = do+ (Just b') <- Streams.read i - end <- Streams.atEOF i- assertBool "Expected end of stream" end+ end <- Streams.atEOF i+ assertBool "Expected end of stream" end - let size = readDecimal b' :: Int- assertEqual "Should have replied with correct file size" 33000 size+ let size = readDecimal b' :: Int+ assertEqual "Should have replied with correct file size" 33000 size testSendBodyFor meth = it ("Sends a request body for " ++ show meth) $ do c <- openConnection "localhost" localPort let q = buildRequest1 $ do- http meth "/size"- setContentType "text/plain"- setTransferEncoding+ http meth "/size"+ setContentType "text/plain"+ setTransferEncoding - sendRequest c q (\o -> do- Streams.write (Just (Builder.fromString "a request")) o)+ sendRequest+ c+ q+ ( \o -> do+ Streams.write (Just (Builder.fromString "a request")) o+ ) - receiveResponse c (\p i -> do- assertEqual "Incorrect status code" 200 (getStatusCode p)- (Just b') <- Streams.read i+ receiveResponse+ c+ ( \p i -> do+ assertEqual "Incorrect status code" 200 (getStatusCode p)+ (Just b') <- Streams.read i - let size = readDecimal b' :: Int- assertEqual "Should have received a request body" 9 size)+ let size = readDecimal b' :: Int+ assertEqual "Should have received a request body" 9 size+ ) closeConnection c @@ -508,118 +555,122 @@ let url = S.concat ["http://", localhost, "/size"] post url "image/jpeg" (fileBody "tests/statler.jpg") handler- where- handler :: Response -> InputStream ByteString -> IO ()- handler p i = do- let code = getStatusCode p- assertEqual "Expected 200 OK" 200 code-- (Just b') <- Streams.read i+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler p i = do+ let code = getStatusCode p+ assertEqual "Expected 200 OK" 200 code - end <- Streams.atEOF i- assertBool "Expected end of stream" end+ (Just b') <- Streams.read i - let size = readDecimal b' :: Int- assertEqual "Should have replied with correct file size" 4611 size+ end <- Streams.atEOF i+ assertBool "Expected end of stream" end + let size = readDecimal b' :: Int+ assertEqual "Should have replied with correct file size" 4611 size testPostWithForm = it "POST with form data correctly encodes parameters" $ do let url = S.concat ["http://", localhost, "/postbox"] - postForm url [ ("name", "Kermit")- , ("role", "St&gehand")- , ("country", Text.encodeUtf8 $ Text.pack "Nørway")- ] handler- where- handler :: Response -> InputStream ByteString -> IO ()- handler p i = do- let code = getStatusCode p- assertEqual "Expected 201" 201 code-- b' <- Streams.readExactly 48 i+ postForm+ url+ [ ("name", "Kermit")+ , ("role", "St&gehand")+ , ("country", Text.encodeUtf8 $ Text.pack "Nørway")+ ]+ handler+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler p i = do+ let code = getStatusCode p+ assertEqual "Expected 201" 201 code - end <- Streams.atEOF i- assertBool "Expected end of stream" end+ b' <- Streams.readExactly 48 i - assertEqual "Incorrect URL encoding"- "name=Kermit&role=St%26gehand&country=N%c3%b8rway"- b'+ end <- Streams.atEOF i+ assertBool "Expected end of stream" end + assertEqual+ "Incorrect URL encoding"+ "name=Kermit&role=St%26gehand&country=N%c3%b8rway"+ b' testGetRedirects = it "GET internal handler follows redirect on 307" $ do let url = S.concat ["http://", localhost, "/bounce"] get url handler- where- handler :: Response -> InputStream ByteString -> IO ()- handler p i1 = do- let code = getStatusCode p- assertEqual "Should have been final code" 200 code-- (i2, getCount) <- Streams.countInput i1- Streams.skipToEof i2+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler p i1 = do+ let code = getStatusCode p+ assertEqual "Should have been final code" 200 code - len <- getCount- assertEqual "Incorrect number of bytes read" 29 len+ (i2, getCount) <- Streams.countInput i1+ Streams.skipToEof i2 + len <- getCount+ assertEqual "Incorrect number of bytes read" 29 len testGetLocalRedirects = it "GET internal handler follows local redirect on 307" $ do let url = S.concat ["http://", localhost, "/local"] get url handler- where- handler :: Response -> InputStream ByteString -> IO ()- handler p i1 = do- let code = getStatusCode p- assertEqual "Should have been final code" 200 code-- (i2, getCount) <- Streams.countInput i1- Streams.skipToEof i2+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler p i1 = do+ let code = getStatusCode p+ assertEqual "Should have been final code" 200 code - len <- getCount- assertEqual "Incorrect number of bytes read" 29 len+ (i2, getCount) <- Streams.countInput i1+ Streams.skipToEof i2 + len <- getCount+ assertEqual "Incorrect number of bytes read" 29 len testSplitURI = it "check splitURI for local redirects" $ do let a1 = "http://asdf@ya.ru:8000/hello/?asd=asd&abc=2"- r1 = S.pack "/hello/?asd=asd&abc=2"+ r1 = S.pack "/hello/?asd=asd&abc=2" assertEqual "Incorrect split uri 1" (S.pack a1) (splitURI (fromJust $ parseURI a1) r1) let a2 = "http://asdf@ya.ru:8000/again/?asd=asd&abc=2"- r2 = S.pack "/again/?asd=asd&abc=2"+ r2 = S.pack "/again/?asd=asd&abc=2" assertEqual "Incorrect split uri 2" (S.pack a2) (splitURI (fromJust $ parseURI a2) r2) let a3 = "http://ya.ru:8000/here/?asd=asd&abc=2"- r3 = S.pack "/here/?asd=asd&abc=2"+ r3 = S.pack "/here/?asd=asd&abc=2" assertEqual "Incorrect split uri 3" (S.pack a3) (splitURI (fromJust $ parseURI a3) r3) let a4 = "http://ya.ru/?asd=asd&abc=2#papa"- r4 = S.pack "/?asd=asd&abc=2#papa"+ r4 = S.pack "/?asd=asd&abc=2#papa" assertEqual "Incorrect split uri 4" (S.pack a4) (splitURI (fromJust $ parseURI a4) r4) - let a5 = "http://ya.ru/?asd=asd&abc=2#papa"+ let a5 = "http://ya.ru/?asd=asd&abc=2#papa" r5 = S.pack "http://google.ru/"- assertEqual "Incorrect split uri 5" r5 (splitURI (fromJust $ parseURI a5) r5)+ assertEqual "Incorrect split uri 5" r5 (splitURI (fromJust $ parseURI a5) r5) testParseURL = it "Parse URL with chars needing encoding" $ do let url = parseURL (Text.encodeUtf8 $ Text.pack "http://example.com/α")- assertEqual "Incorrect URL parsing"- (URI "http:" (Just $ URIAuth "" "example.com" "") "/%CE%B1" "" "") url+ assertEqual+ "Incorrect URL parsing"+ (URI "http:" (Just $ URIAuth "" "example.com" "") "/%CE%B1" "" "")+ url testParseURLHasEscaped = it "Parse URL with chars already encoded" $ do let url = parseURL (Text.encodeUtf8 $ Text.pack "http://example.com/hello%20world")- assertEqual "Incorrect URL parsing"- (URI "http:" (Just $ URIAuth "" "example.com" "") "/hello%20world" "" "") url+ assertEqual+ "Incorrect URL parsing"+ (URI "http:" (Just $ URIAuth "" "example.com" "") "/hello%20world" "" "")+ url testGetFormatsRequest = it "GET includes a properly formatted request path" $ do- let url = S.concat ["http://", localhost ]+ let url = S.concat ["http://", localhost] x' <- get url concatHandler' assertBool "Incorrect context path" (S.length x' > 0)@@ -629,20 +680,20 @@ let url = S.concat ["http://", localhost, "/loop"] get url handler `shouldThrow` tooManyRedirects- where- handler :: Response -> InputStream ByteString -> IO ()- handler _ _ = do- assertBool "Should have thrown exception before getting here" False+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler _ _ = do+ assertBool "Should have thrown exception before getting here" False testRepeatedResponseHeaders = it "repeated response headers are properly concatonated" $ do let url = S.concat ["http://", localhost, "/cookies"] get url handler- where- handler :: Response -> InputStream ByteString -> IO ()- handler r _ = do- assertEqual "Invalid response headers" (Just "stone=diamond,metal=tungsten") (getHeader r "Set-Cookie")+ where+ handler :: Response -> InputStream ByteString -> IO ()+ handler r _ = do+ assertEqual "Invalid response headers" (Just "stone=diamond,metal=tungsten") (getHeader r "Set-Cookie") {- From http://stackoverflow.com/questions/6147435/is-there-an-assertexception-in-any-of-the-haskell-test-frameworks@@ -655,8 +706,8 @@ handleJust isWanted (const $ return ()) $ do _ <- action assertFailure $ "Expected exception: " ++ show ex- where isWanted = guard . (== ex)-+ where+ isWanted = guard . (== ex) testGeneralHandler = it "GET with general purpose handler throws exception on 404" $ do@@ -664,7 +715,6 @@ get url concatHandler' `shouldThrow` httpClientError 404 - tooManyRedirects :: Selector TooManyRedirects tooManyRedirects = const True @@ -672,24 +722,24 @@ httpClientError :: Int -> HttpClientError -> Bool httpClientError expected (HttpClientError actual _) = expected == actual -- testEstablishConnection = it "public establish function behaves correctly" $ do let url = S.concat ["http://", localhost, "/static/statler.jpg"] - x' <- withConnection (establishConnection url) $ (\c -> do- let q = buildRequest1 $ do- http GET "/static/statler.jpg"+ x' <-+ withConnection (establishConnection url) $+ ( \c -> do+ let q = buildRequest1 $ do+ http GET "/static/statler.jpg" -- TODO be nice if we could replace that with 'url'; -- fix the routeRequests function in TestServer maybe?- sendRequest c q emptyBody- receiveResponse c concatHandler')+ sendRequest c q emptyBody+ receiveResponse c concatHandler'+ ) let len = S.length x' assertEqual "Incorrect number of bytes read" 4611 len - testParsingJson1 = it "GET with JSON handler behaves" $ do let url = S.concat ["http://", localhost, "/static/data-eu-gdp.json"]@@ -709,6 +759,7 @@ assertEqual "Incorrect response" "Japan" (gLabel x) assertEqual "Data not parsed as expected" 2008 (fst $ last $ gData x)+ -- L.putStr $ encodePretty x {-@@ -717,52 +768,86 @@ because data is a reserved word, of course. -} -data GrossDomesticProduct = GrossDomesticProduct {- gLabel :: Text,- gData :: [(Int, Double)]-} deriving (Show, Generic)+data GrossDomesticProduct = GrossDomesticProduct+ { gLabel :: Text+ , gData :: [(Int, Double)]+ }+ deriving (Show, Generic) instance FromJSON GrossDomesticProduct where- parseJSON (Object o) = GrossDomesticProduct <$>- o .: "label" <*>- o .: "data"- parseJSON _ = undefined-+ parseJSON (Object o) =+ GrossDomesticProduct+ <$> o .: "label"+ <*> o .: "data"+ parseJSON _ = undefined instance ToJSON GrossDomesticProduct where- toJSON (GrossDomesticProduct l d) = object- ["label" .= l,- "data" .= d]-+ toJSON (GrossDomesticProduct l d) =+ object+ [ "label" .= l+ , "data" .= d+ ] -testPostWithSimple =+testPutWithSimple = it "PUT with static data" $ do let url = S.concat ["http://", localhost, "/resource/y98"] - x' <- put url "text/plain" (simpleBody b') concatHandler+ x' <- put url "text/plain" (simpleBody b') simpleHandler - assertEqual "Object was encoded to JSON as expected"- "Hello"- x'- where- b' :: ByteString- b' = S.pack "Hello"+ assertEqual+ "Object was encoded to JSON as expected"+ "Hello"+ x'+ where+ b' :: ByteString+ b' = S.pack "Hello" -testPostWithJson =+testPutWithJson = it "PUT with json data" $ do let url = S.concat ["http://", localhost, "/resource/y99"] - x' <- put url "application/json" (jsonBody obj) concatHandler+ x' <- put url "application/json" (jsonBody obj) simpleHandler - assertEqual "Object was encoded to JSON as expected"- "{\"data\":[[2000,1],[2020,0]],\"label\":\"Sealand\"}"- x'- where- obj :: GrossDomesticProduct- obj = GrossDomesticProduct {- gLabel = "Sealand",- gData = [(2000,1),(2020,0)]- }+ assertEqual+ "Object was encoded to JSON as expected"+ "{\"data\":[[2000,1],[2020,0]],\"label\":\"Sealand\"}"+ x'+ where+ obj :: GrossDomesticProduct+ obj =+ GrossDomesticProduct+ { gLabel = "Sealand"+ , gData = [(2000, 1), (2020, 0)]+ } - obj' :: ByteString- obj' = L.toStrict (encode obj)+ obj' :: ByteString+ obj' = L.toStrict (encode obj)++testMultipartUpload =+ it "PUT with json data" $ do+ let url = S.concat ["http://", localhost, "/postbox"]++ let boundary = packBoundary "bEacHV0113YB@ll"++ let q = buildRequest1 $ do+ http POST "/postbox"+ setContentMultipart boundary++ let parts =+ [ simplePart "first" Nothing "Old guys in the box."+ , filePart "second" (Just "text/plain") "tests/hello.txt"+ ]++ c <- openConnection "localhost" localPort++ sendRequest c q (multipartFormBody boundary parts)++ result <- receiveResponse c simpleHandler++ closeConnection c++ expected <- S.readFile "tests/multipart.bin"+ assertEqual+ "Multipart form data was not encoded as expected"+ expected+ result
+ tests/multipart.bin view
@@ -0,0 +1,12 @@+ +--bEacHV0113YB@ll +Content-Disposition: form-data; name="first" + +Old guys in the box. +--bEacHV0113YB@ll +Content-Disposition: form-data; name="second"; filename="hello.txt" +Content-Type: text/plain + +Hello World+ +--bEacHV0113YB@ll--