diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/http-streams.cabal b/http-streams.cabal --- a/http-streams.cabal +++ b/http-streams.cabal @@ -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, diff --git a/lib/Network/Http/Client.hs b/lib/Network/Http/Client.hs --- a/lib/Network/Http/Client.hs +++ b/lib/Network/Http/Client.hs @@ -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 diff --git a/lib/Network/Http/Connection.hs b/lib/Network/Http/Connection.hs --- a/lib/Network/Http/Connection.hs +++ b/lib/Network/Http/Connection.hs @@ -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 diff --git a/lib/Network/Http/Inconvenience.hs b/lib/Network/Http/Inconvenience.hs --- a/lib/Network/Http/Inconvenience.hs +++ b/lib/Network/Http/Inconvenience.hs @@ -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 --- ) --- +{- | +URL-escapes a string (see +) +-} urlEncode :: ByteString -> URL urlEncode = Builder.toByteString . urlEncodeBuilder {-# INLINE urlEncode #-} - --- --- | URL-escapes a string (see --- ) into a 'Builder'. --- +{- | +URL-escapes a string (see +) 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 diff --git a/lib/Network/Http/ResponseParser.hs b/lib/Network/Http/ResponseParser.hs --- a/lib/Network/Http/ResponseParser.hs +++ b/lib/Network/Http/ResponseParser.hs @@ -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 - --------------------------------------------------------------------- diff --git a/lib/Network/Http/Utilities.hs b/lib/Network/Http/Utilities.hs --- a/lib/Network/Http/Utilities.hs +++ b/lib/Network/Http/Utilities.hs @@ -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 #-} diff --git a/tests/MockServer.hs b/tests/MockServer.hs --- a/tests/MockServer.hs +++ b/tests/MockServer.hs @@ -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 - - diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -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 diff --git a/tests/multipart.bin b/tests/multipart.bin new file mode 100644 --- /dev/null +++ b/tests/multipart.bin @@ -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--