diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,126 +1,130 @@ -# ChangeLog for http-conduit - -## 2.3.7.3 - -* Relax test suite version bounds - -## 2.3.7.2 - -* Add the `network3` flag - -## 2.3.7.1 - -* Properly skip whitespace after JSON body [#401](https://github.com/snoyberg/http-client/issues/401) - -## 2.3.7 - -* Ensure entire JSON response body is consumed [#395](https://github.com/snoyberg/http-client/issues/395) - -## 2.3.6.1 - -* Add back compatibility with older http-client version [#393](https://github.com/snoyberg/http-client/pull/393) - -## 2.3.6 - -* Add `httpSource` to `Network.HTTP.Client.Conduit` [#390](https://github.com/snoyberg/http-client/pull/390). - -## 2.3.5 - -* Adds `addToRequestQueryString` helper function - -## 2.3.4 - -* Reexport RequestHeaders from Network.HTTP.Types (what was intended in last version) -* Fix mistake in ChangeLog - -## 2.3.3 - -* Reexport Header, QueryItem and ResponseHeaders from Network.HTTP.Types -* Rewrite a type signature of setRequestHeaders with RequestHeaders - -## 2.3.2 - -* Adds `parseRequestThrow`, `parseRequestThrow_`, and - `setRequestCheckStatus` to `Network.HTTP.Simple`. - See [#304](https://github.com/snoyberg/http-client/issues/304) - -## 2.3.1 - -* Reexport Query from Network.HTTP.Types -* Rewrite a type signatures of getRequestQueryString and setRequestQueryString with Query - -## 2.3.0 - -* conduit 1.3 support - * NOTE: Even for older versions of conduit, this includes dropping - support for finalizers -* `http` returns a `Source` instead of a `ResumableSource` (due to lack of - finalizers) -* Drop monad-control for unliftio -* Removed some deprecated functions: `withManager`, `withManagerSettings`, - `conduitManagerSettings` - -## 2.2.4 - -* Add `httpBS` to `Network.HTTP.Simple` - -## 2.2.3.2 - -* Add proper headers for `httpJSON` and `httpJSONEither` [#284](https://github.com/snoyberg/http-client/issues/284) - -## 2.2.3.1 - -* Minor README improvement - -## 2.2.3 - -* Add `withResponse` to `Network.HTTP.Simple` - -## 2.2.2.1 - -* setRequestBodyJSON works with aeson's toEncoding function (>= 0.11) - [#230](https://github.com/snoyberg/http-client/pull/230) - -## 2.2.2 - -* Add `httpNoBody` to `Network.HTTP.Simple` - -## 2.2.1 - -* Add `httpSource` to `Network.HTTP.Simple` - -## 2.2.0.1 - -* Doc fixes - -## 2.2.0 - -* Upgrade to http-client 0.5 - -## 2.1.11 - -* Switch to non-throwing behavior in `Network.HTTP.Simple` [#193](https://github.com/snoyberg/http-client/issues/193) - -## 2.1.10.1 - -* Fix mistaken `@since` comments - -## 2.1.10 - -* Add the `Network.HTTP.Simple` module - -## 2.1.9 - -* cabal file cleanup - -## 2.1.8 - -* Move HasHttpManager from http-conduit to http-client [#147](https://github.com/snoyberg/http-client/pull/147) - -## 2.1.7 - -* Deprecate `conduitManagerSettings`, re-export `tlsManagerSettings` [#136](https://github.com/snoyberg/http-client/issues/136) [#137](https://github.com/snoyberg/http-client/issues/137) - -## 2.1.6 - -* Deprecate `withManager` and `withManagerSettings` +# ChangeLog for http-conduit + +## 2.3.7.4 + +* Introduces the `aeson` cabal file [#448](https://github.com/snoyberg/http-client/issues/448) + +## 2.3.7.3 + +* Relax test suite version bounds + +## 2.3.7.2 + +* Add the `network3` flag + +## 2.3.7.1 + +* Properly skip whitespace after JSON body [#401](https://github.com/snoyberg/http-client/issues/401) + +## 2.3.7 + +* Ensure entire JSON response body is consumed [#395](https://github.com/snoyberg/http-client/issues/395) + +## 2.3.6.1 + +* Add back compatibility with older http-client version [#393](https://github.com/snoyberg/http-client/pull/393) + +## 2.3.6 + +* Add `httpSource` to `Network.HTTP.Client.Conduit` [#390](https://github.com/snoyberg/http-client/pull/390). + +## 2.3.5 + +* Adds `addToRequestQueryString` helper function + +## 2.3.4 + +* Reexport RequestHeaders from Network.HTTP.Types (what was intended in last version) +* Fix mistake in ChangeLog + +## 2.3.3 + +* Reexport Header, QueryItem and ResponseHeaders from Network.HTTP.Types +* Rewrite a type signature of setRequestHeaders with RequestHeaders + +## 2.3.2 + +* Adds `parseRequestThrow`, `parseRequestThrow_`, and + `setRequestCheckStatus` to `Network.HTTP.Simple`. + See [#304](https://github.com/snoyberg/http-client/issues/304) + +## 2.3.1 + +* Reexport Query from Network.HTTP.Types +* Rewrite a type signatures of getRequestQueryString and setRequestQueryString with Query + +## 2.3.0 + +* conduit 1.3 support + * NOTE: Even for older versions of conduit, this includes dropping + support for finalizers +* `http` returns a `Source` instead of a `ResumableSource` (due to lack of + finalizers) +* Drop monad-control for unliftio +* Removed some deprecated functions: `withManager`, `withManagerSettings`, + `conduitManagerSettings` + +## 2.2.4 + +* Add `httpBS` to `Network.HTTP.Simple` + +## 2.2.3.2 + +* Add proper headers for `httpJSON` and `httpJSONEither` [#284](https://github.com/snoyberg/http-client/issues/284) + +## 2.2.3.1 + +* Minor README improvement + +## 2.2.3 + +* Add `withResponse` to `Network.HTTP.Simple` + +## 2.2.2.1 + +* setRequestBodyJSON works with aeson's toEncoding function (>= 0.11) + [#230](https://github.com/snoyberg/http-client/pull/230) + +## 2.2.2 + +* Add `httpNoBody` to `Network.HTTP.Simple` + +## 2.2.1 + +* Add `httpSource` to `Network.HTTP.Simple` + +## 2.2.0.1 + +* Doc fixes + +## 2.2.0 + +* Upgrade to http-client 0.5 + +## 2.1.11 + +* Switch to non-throwing behavior in `Network.HTTP.Simple` [#193](https://github.com/snoyberg/http-client/issues/193) + +## 2.1.10.1 + +* Fix mistaken `@since` comments + +## 2.1.10 + +* Add the `Network.HTTP.Simple` module + +## 2.1.9 + +* cabal file cleanup + +## 2.1.8 + +* Move HasHttpManager from http-conduit to http-client [#147](https://github.com/snoyberg/http-client/pull/147) + +## 2.1.7 + +* Deprecate `conduitManagerSettings`, re-export `tlsManagerSettings` [#136](https://github.com/snoyberg/http-client/issues/136) [#137](https://github.com/snoyberg/http-client/issues/137) + +## 2.1.6 + +* Deprecate `withManager` and `withManagerSettings` diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,25 +1,25 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, Michael Snoyman. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/HTTP/Client/Conduit.hs b/Network/HTTP/Client/Conduit.hs --- a/Network/HTTP/Client/Conduit.hs +++ b/Network/HTTP/Client/Conduit.hs @@ -1,192 +1,192 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} --- | A new, experimental API to replace "Network.HTTP.Conduit". --- --- For most users, "Network.HTTP.Simple" is probably a better choice. For more --- information, see: --- --- --- --- For more information on using this module, please be sure to read the --- documentation in the "Network.HTTP.Client" module. -module Network.HTTP.Client.Conduit - ( -- * Conduit-specific interface - withResponse - , responseOpen - , responseClose - , acquireResponse - , httpSource - -- * Manager helpers - , defaultManagerSettings - , newManager - , newManagerSettings - -- * General HTTP client interface - , module Network.HTTP.Client - , httpLbs - , httpNoBody - -- * Lower-level conduit functions - , requestBodySource - , requestBodySourceChunked - , bodyReaderSource - ) where - -import Control.Monad (unless) -import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) -import Control.Monad.Reader (MonadReader (..), runReaderT) -import Control.Monad.Trans.Resource (MonadResource) -import Data.Acquire (Acquire, mkAcquire, with) -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Conduit (ConduitM, ($$+), ($$++), - await, yield, bracketP) -import Data.Int (Int64) -import Data.IORef (newIORef, readIORef, writeIORef) -import Network.HTTP.Client hiding (closeManager, - defaultManagerSettings, httpLbs, - newManager, responseClose, - responseOpen, - withResponse, BodyReader, brRead, brConsume, httpNoBody) -import qualified Network.HTTP.Client as H -import Network.HTTP.Client.TLS (tlsManagerSettings) - --- | Conduit powered version of 'H.withResponse'. Differences are: --- --- * Response body is represented as a @Producer@. --- --- * Generalized to any instance of @MonadUnliftIO@, not just @IO@. --- --- * The @Manager@ is contained by a @MonadReader@ context. --- --- Since 2.1.0 -withResponse :: (MonadUnliftIO m, MonadIO n, MonadReader env m, HasHttpManager env) - => Request - -> (Response (ConduitM i ByteString n ()) -> m a) - -> m a -withResponse req f = do - env <- ask - withRunInIO $ \run -> with (acquireResponse req env) (run . f) - --- | An @Acquire@ for getting a @Response@. --- --- Since 2.1.0 -acquireResponse :: (MonadIO n, MonadReader env m, HasHttpManager env) - => Request - -> m (Acquire (Response (ConduitM i ByteString n ()))) -acquireResponse req = do - env <- ask - let man = getHttpManager env - return $ do - res <- mkAcquire (H.responseOpen req man) H.responseClose - return $ fmap bodyReaderSource res - --- | TLS-powered manager settings. --- --- Since 2.1.0 -defaultManagerSettings :: ManagerSettings -defaultManagerSettings = tlsManagerSettings - --- | Get a new manager using 'defaultManagerSettings'. --- --- Since 2.1.0 -newManager :: MonadIO m => m Manager -newManager = newManagerSettings defaultManagerSettings - --- | Get a new manager using the given settings. --- --- Since 2.1.0 -newManagerSettings :: MonadIO m => ManagerSettings -> m Manager -newManagerSettings = liftIO . H.newManager - --- | Conduit-powered version of 'H.responseOpen'. --- --- See 'withResponse' for the differences with 'H.responseOpen'. --- --- Since 2.1.0 -responseOpen :: (MonadIO m, MonadIO n, MonadReader env m, HasHttpManager env) - => Request - -> m (Response (ConduitM i ByteString n ())) -responseOpen req = do - env <- ask - liftIO $ fmap bodyReaderSource `fmap` H.responseOpen req (getHttpManager env) - --- | Generalized version of 'H.responseClose'. --- --- Since 2.1.0 -responseClose :: MonadIO m => Response body -> m () -responseClose = liftIO . H.responseClose - -bodyReaderSource :: MonadIO m - => H.BodyReader - -> ConduitM i ByteString m () -bodyReaderSource br = - loop - where - loop = do - bs <- liftIO $ H.brRead br - unless (S.null bs) $ do - yield bs - loop - -requestBodySource :: Int64 -> ConduitM () ByteString IO () -> RequestBody -requestBodySource size = RequestBodyStream size . srcToPopperIO - -requestBodySourceChunked :: ConduitM () ByteString IO () -> RequestBody -requestBodySourceChunked = RequestBodyStreamChunked . srcToPopperIO - -srcToPopperIO :: ConduitM () ByteString IO () -> GivesPopper () -srcToPopperIO src f = do - (rsrc0, ()) <- src $$+ return () - irsrc <- newIORef rsrc0 - let popper :: IO ByteString - popper = do - rsrc <- readIORef irsrc - (rsrc', mres) <- rsrc $$++ await - writeIORef irsrc rsrc' - case mres of - Nothing -> return S.empty - Just bs - | S.null bs -> popper - | otherwise -> return bs - f popper - --- | Same as 'H.httpLbs', except it uses the @Manager@ in the reader environment. --- --- Since 2.1.1 -httpLbs :: (MonadIO m, HasHttpManager env, MonadReader env m) - => Request - -> m (Response L.ByteString) -httpLbs req = do - env <- ask - let man = getHttpManager env - liftIO $ H.httpLbs req man - --- | Same as 'H.httpNoBody', except it uses the @Manager@ in the reader environment. --- --- This can be more convenient that using 'withManager' as it avoids the need --- to specify the base monad for the response body. --- --- Since 2.1.2 -httpNoBody :: (MonadIO m, HasHttpManager env, MonadReader env m) - => Request - -> m (Response ()) -httpNoBody req = do - env <- ask - let man = getHttpManager env - liftIO $ H.httpNoBody req man - --- | Same as 'Network.HTTP.Simple.httpSource', but uses 'Manager' --- from Reader environment instead of the global one. --- --- Since 2.3.6 -httpSource - :: (MonadResource m, MonadIO n, MonadReader env m, HasHttpManager env) - => Request - -> (Response (ConduitM () ByteString n ()) -> ConduitM () r m ()) - -> ConduitM () r m () -httpSource request withRes = do - env <- ask - bracketP - (runReaderT (responseOpen request) env) - responseClose - withRes +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +-- | A new, experimental API to replace "Network.HTTP.Conduit". +-- +-- For most users, "Network.HTTP.Simple" is probably a better choice. For more +-- information, see: +-- +-- +-- +-- For more information on using this module, please be sure to read the +-- documentation in the "Network.HTTP.Client" module. +module Network.HTTP.Client.Conduit + ( -- * Conduit-specific interface + withResponse + , responseOpen + , responseClose + , acquireResponse + , httpSource + -- * Manager helpers + , defaultManagerSettings + , newManager + , newManagerSettings + -- * General HTTP client interface + , module Network.HTTP.Client + , httpLbs + , httpNoBody + -- * Lower-level conduit functions + , requestBodySource + , requestBodySourceChunked + , bodyReaderSource + ) where + +import Control.Monad (unless) +import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) +import Control.Monad.Reader (MonadReader (..), runReaderT) +import Control.Monad.Trans.Resource (MonadResource) +import Data.Acquire (Acquire, mkAcquire, with) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Conduit (ConduitM, ($$+), ($$++), + await, yield, bracketP) +import Data.Int (Int64) +import Data.IORef (newIORef, readIORef, writeIORef) +import Network.HTTP.Client hiding (closeManager, + defaultManagerSettings, httpLbs, + newManager, responseClose, + responseOpen, + withResponse, BodyReader, brRead, brConsume, httpNoBody) +import qualified Network.HTTP.Client as H +import Network.HTTP.Client.TLS (tlsManagerSettings) + +-- | Conduit powered version of 'H.withResponse'. Differences are: +-- +-- * Response body is represented as a @Producer@. +-- +-- * Generalized to any instance of @MonadUnliftIO@, not just @IO@. +-- +-- * The @Manager@ is contained by a @MonadReader@ context. +-- +-- Since 2.1.0 +withResponse :: (MonadUnliftIO m, MonadIO n, MonadReader env m, HasHttpManager env) + => Request + -> (Response (ConduitM i ByteString n ()) -> m a) + -> m a +withResponse req f = do + env <- ask + withRunInIO $ \run -> with (acquireResponse req env) (run . f) + +-- | An @Acquire@ for getting a @Response@. +-- +-- Since 2.1.0 +acquireResponse :: (MonadIO n, MonadReader env m, HasHttpManager env) + => Request + -> m (Acquire (Response (ConduitM i ByteString n ()))) +acquireResponse req = do + env <- ask + let man = getHttpManager env + return $ do + res <- mkAcquire (H.responseOpen req man) H.responseClose + return $ fmap bodyReaderSource res + +-- | TLS-powered manager settings. +-- +-- Since 2.1.0 +defaultManagerSettings :: ManagerSettings +defaultManagerSettings = tlsManagerSettings + +-- | Get a new manager using 'defaultManagerSettings'. +-- +-- Since 2.1.0 +newManager :: MonadIO m => m Manager +newManager = newManagerSettings defaultManagerSettings + +-- | Get a new manager using the given settings. +-- +-- Since 2.1.0 +newManagerSettings :: MonadIO m => ManagerSettings -> m Manager +newManagerSettings = liftIO . H.newManager + +-- | Conduit-powered version of 'H.responseOpen'. +-- +-- See 'withResponse' for the differences with 'H.responseOpen'. +-- +-- Since 2.1.0 +responseOpen :: (MonadIO m, MonadIO n, MonadReader env m, HasHttpManager env) + => Request + -> m (Response (ConduitM i ByteString n ())) +responseOpen req = do + env <- ask + liftIO $ fmap bodyReaderSource `fmap` H.responseOpen req (getHttpManager env) + +-- | Generalized version of 'H.responseClose'. +-- +-- Since 2.1.0 +responseClose :: MonadIO m => Response body -> m () +responseClose = liftIO . H.responseClose + +bodyReaderSource :: MonadIO m + => H.BodyReader + -> ConduitM i ByteString m () +bodyReaderSource br = + loop + where + loop = do + bs <- liftIO $ H.brRead br + unless (S.null bs) $ do + yield bs + loop + +requestBodySource :: Int64 -> ConduitM () ByteString IO () -> RequestBody +requestBodySource size = RequestBodyStream size . srcToPopperIO + +requestBodySourceChunked :: ConduitM () ByteString IO () -> RequestBody +requestBodySourceChunked = RequestBodyStreamChunked . srcToPopperIO + +srcToPopperIO :: ConduitM () ByteString IO () -> GivesPopper () +srcToPopperIO src f = do + (rsrc0, ()) <- src $$+ return () + irsrc <- newIORef rsrc0 + let popper :: IO ByteString + popper = do + rsrc <- readIORef irsrc + (rsrc', mres) <- rsrc $$++ await + writeIORef irsrc rsrc' + case mres of + Nothing -> return S.empty + Just bs + | S.null bs -> popper + | otherwise -> return bs + f popper + +-- | Same as 'H.httpLbs', except it uses the @Manager@ in the reader environment. +-- +-- Since 2.1.1 +httpLbs :: (MonadIO m, HasHttpManager env, MonadReader env m) + => Request + -> m (Response L.ByteString) +httpLbs req = do + env <- ask + let man = getHttpManager env + liftIO $ H.httpLbs req man + +-- | Same as 'H.httpNoBody', except it uses the @Manager@ in the reader environment. +-- +-- This can be more convenient that using 'withManager' as it avoids the need +-- to specify the base monad for the response body. +-- +-- Since 2.1.2 +httpNoBody :: (MonadIO m, HasHttpManager env, MonadReader env m) + => Request + -> m (Response ()) +httpNoBody req = do + env <- ask + let man = getHttpManager env + liftIO $ H.httpNoBody req man + +-- | Same as 'Network.HTTP.Simple.httpSource', but uses 'Manager' +-- from Reader environment instead of the global one. +-- +-- Since 2.3.6 +httpSource + :: (MonadResource m, MonadIO n, MonadReader env m, HasHttpManager env) + => Request + -> (Response (ConduitM () ByteString n ()) -> ConduitM () r m ()) + -> ConduitM () r m () +httpSource request withRes = do + env <- ask + bracketP + (runReaderT (responseOpen request) env) + responseClose + withRes diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -1,352 +1,352 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} --- | --- --- = Simpler API --- --- The API below is rather low-level. The "Network.HTTP.Simple" module provides --- a higher-level API with built-in support for things like JSON request and --- response bodies. For most users, this will be an easier place to start. You --- can read the tutorial at: --- --- --- --- = Lower-level API --- --- This module contains everything you need to initiate HTTP connections. If --- you want a simple interface based on URLs, you can use 'simpleHttp'. If you --- want raw power, 'http' is the underlying workhorse of this package. Some --- examples: --- --- > -- Just download an HTML document and print it. --- > import Network.HTTP.Conduit --- > import qualified Data.ByteString.Lazy as L --- > --- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr --- --- This example uses interleaved IO to write the response body to a file in --- constant memory space. --- --- > import Data.Conduit.Binary (sinkFile) -- Exported from the package conduit-extra --- > import Network.HTTP.Conduit --- > import Conduit (runConduit, (.|)) --- > import Control.Monad.Trans.Resource (runResourceT) --- > --- > main :: IO () --- > main = do --- > request <- parseRequest "http://google.com/" --- > manager <- newManager tlsManagerSettings --- > runResourceT $ do --- > response <- http request manager --- > runConduit $ responseBody response .| sinkFile "google.html" --- --- The following headers are automatically set by this module, and should not --- be added to 'requestHeaders': --- --- * Cookie --- --- * Content-Length --- --- * Transfer-Encoding --- --- Note: In previous versions, the Host header would be set by this module in --- all cases. Starting from 1.6.1, if a Host header is present in --- @requestHeaders@, it will be used in place of the header this module would --- have generated. This can be useful for calling a server which utilizes --- virtual hosting. --- --- Use `cookieJar` If you want to supply cookies with your request: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > import Network.HTTP.Conduit --- > import Network --- > import Data.Time.Clock --- > import Data.Time.Calendar --- > import qualified Control.Exception as E --- > import Network.HTTP.Types.Status (statusCode) --- > --- > past :: UTCTime --- > past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) --- > --- > future :: UTCTime --- > future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0) --- > --- > cookie :: Cookie --- > cookie = Cookie { cookie_name = "password_hash" --- > , cookie_value = "abf472c35f8297fbcabf2911230001234fd2" --- > , cookie_expiry_time = future --- > , cookie_domain = "example.com" --- > , cookie_path = "/" --- > , cookie_creation_time = past --- > , cookie_last_access_time = past --- > , cookie_persistent = False --- > , cookie_host_only = False --- > , cookie_secure_only = False --- > , cookie_http_only = False --- > } --- > --- > main = do --- > request' <- parseRequest "http://example.com/secret-page" --- > manager <- newManager tlsManagerSettings --- > let request = request' { cookieJar = Just $ createCookieJar [cookie] } --- > fmap Just (httpLbs request manager) `E.catch` --- > (\ex -> case ex of --- > HttpExceptionRequest _ (StatusCodeException res _) -> --- > if statusCode (responseStatus res) == 403 --- > then (putStrLn "login failed" >> return Nothing) --- > else return Nothing --- > _ -> E.throw ex) --- --- Cookies are implemented according to RFC 6265. --- --- Note that by default, the functions in this package will throw exceptions --- for non-2xx status codes. If you would like to avoid this, you should use --- 'checkStatus', e.g.: --- --- > import Data.Conduit.Binary (sinkFile) --- > import Network.HTTP.Conduit --- > import qualified Data.Conduit as C --- > import Network --- > --- > main :: IO () --- > main = do --- > request' <- parseRequest "http://www.yesodweb.com/does-not-exist" --- > let request = request' { checkStatus = \_ _ _ -> Nothing } --- > manager <- newManager tlsManagerSettings --- > res <- httpLbs request manager --- > print res --- --- By default, when connecting to websites using HTTPS, functions in this --- package will throw an exception if the TLS certificate doesn't validate. To --- continue the HTTPS transaction even if the TLS cerficate validation fails, --- you should use 'mkManagerSetttings' as follows: --- --- > import Network.Connection (TLSSettings (..)) --- > import Network.HTTP.Conduit --- > --- > main :: IO () --- > main = do --- > request <- parseRequest "https://github.com/" --- > let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing --- > manager <- newManager settings --- > res <- httpLbs request manager --- > print res --- --- For more information, please be sure to read the documentation in the --- "Network.HTTP.Client" module. - -module Network.HTTP.Conduit - ( -- * Perform a request - simpleHttp - , httpLbs - , http - -- * Datatypes - , Proxy (..) - , RequestBody (..) - -- ** Request - , Request - , method - , secure - , host - , port - , path - , queryString - , requestHeaders - , requestBody - , proxy - , hostAddress - , rawBody - , decompress - , redirectCount -#if MIN_VERSION_http_client(0,6,2) - , shouldStripHeaderOnRedirect -#endif - , checkResponse - , responseTimeout - , cookieJar - , requestVersion - , HCC.setQueryString - -- *** Request body - , requestBodySource - , requestBodySourceChunked - , requestBodySourceIO - , requestBodySourceChunkedIO - -- * Response - , Response - , responseStatus - , responseVersion - , responseHeaders - , responseBody - , responseCookieJar - -- * Manager - , Manager - , newManager - , closeManager - -- ** Settings - , ManagerSettings - , tlsManagerSettings - , mkManagerSettings - , managerConnCount - , managerResponseTimeout - , managerTlsConnection - -- ** Response timeout - , HC.ResponseTimeout - , HC.responseTimeoutMicro - , HC.responseTimeoutNone - , HC.responseTimeoutDefault - -- * Cookies - , Cookie(..) - , CookieJar - , createCookieJar - , destroyCookieJar - -- * Utility functions - , parseUrl - , parseUrlThrow - , parseRequest - , parseRequest_ - , defaultRequest - , applyBasicAuth - , addProxy - , lbsResponse - , getRedirectedRequest - -- * Decompression predicates - , alwaysDecompress - , browserDecompress - -- * Request bodies - -- | "Network.HTTP.Client.MultipartFormData" provides an API for building - -- form-data request bodies. - , urlEncodedBody - -- * Exceptions - , HttpException (..) - , HCC.HttpExceptionContent (..) - ) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.IORef (readIORef, writeIORef, newIORef) -import Data.Int (Int64) -import Control.Applicative as A ((<$>)) -import Control.Monad.IO.Unlift (MonadIO (liftIO)) -import Control.Monad.Trans.Resource - -import qualified Network.HTTP.Client as Client (httpLbs, responseOpen, responseClose) -import qualified Network.HTTP.Client as HC -import qualified Network.HTTP.Client.Conduit as HCC -import Network.HTTP.Client.Internal (createCookieJar, - destroyCookieJar) -import Network.HTTP.Client.Internal (Manager, ManagerSettings, - closeManager, managerConnCount, - managerResponseTimeout, - managerTlsConnection, newManager) -import Network.HTTP.Client (parseUrl, parseUrlThrow, urlEncodedBody, applyBasicAuth, - defaultRequest, parseRequest, parseRequest_) -import Network.HTTP.Client.Internal (addProxy, alwaysDecompress, - browserDecompress) -import Network.HTTP.Client.Internal (getRedirectedRequest) -import Network.HTTP.Client.TLS (mkManagerSettings, - tlsManagerSettings) -import Network.HTTP.Client.Internal (Cookie (..), CookieJar (..), - HttpException (..), Proxy (..), - Request (..), RequestBody (..), - Response (..)) - --- | Download the specified 'Request', returning the results as a 'Response'. --- --- This is a simplified version of 'http' for the common case where you simply --- want the response data as a simple datatype. If you want more power, such as --- interleaved actions on the response body during download, you'll need to use --- 'http' directly. This function is defined as: --- --- @httpLbs = 'lbsResponse' <=< 'http'@ --- --- Even though the 'Response' contains a lazy bytestring, this --- function does /not/ utilize lazy I/O, and therefore the entire --- response body will live in memory. If you want constant memory --- usage, you'll need to use @conduit@ packages's --- 'C.Source' returned by 'http'. --- --- This function will 'throwIO' an 'HttpException' for any --- response with a non-2xx status code (besides 3xx redirects up --- to a limit of 10 redirects). This behavior can be modified by --- changing the 'checkStatus' field of your request. --- --- Note: Unlike previous versions, this function will perform redirects, as --- specified by the 'redirectCount' setting. -httpLbs :: MonadIO m => Request -> Manager -> m (Response L.ByteString) -httpLbs r m = liftIO $ Client.httpLbs r m - --- | Download the specified URL, following any redirects, and --- return the response body. --- --- This function will 'throwIO' an 'HttpException' for any --- response with a non-2xx status code (besides 3xx redirects up --- to a limit of 10 redirects). It uses 'parseUrlThrow' to parse the --- input. This function essentially wraps 'httpLbs'. --- --- Note: Even though this function returns a lazy bytestring, it --- does /not/ utilize lazy I/O, and therefore the entire response --- body will live in memory. If you want constant memory usage, --- you'll need to use the @conduit@ package and 'http' directly. --- --- Note: This function creates a new 'Manager'. It should be avoided --- in production code. -simpleHttp :: MonadIO m => String -> m L.ByteString -simpleHttp url = liftIO $ do - man <- newManager tlsManagerSettings - req <- liftIO $ parseUrlThrow url - responseBody A.<$> httpLbs (setConnectionClose req) man - -setConnectionClose :: Request -> Request -setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req} - -lbsResponse :: Monad m - => Response (ConduitM () S.ByteString m ()) - -> m (Response L.ByteString) -lbsResponse res = do - bss <- runConduit $ responseBody res .| CL.consume - return res - { responseBody = L.fromChunks bss - } - -http :: MonadResource m - => Request - -> Manager - -> m (Response (ConduitM i S.ByteString m ())) -http req man = do - (key, res) <- allocate (Client.responseOpen req man) Client.responseClose - return res { responseBody = do - HCC.bodyReaderSource $ responseBody res - release key - } - -requestBodySource :: Int64 -> ConduitM () S.ByteString (ResourceT IO) () -> RequestBody -requestBodySource size = RequestBodyStream size . srcToPopper - -requestBodySourceChunked :: ConduitM () S.ByteString (ResourceT IO) () -> RequestBody -requestBodySourceChunked = RequestBodyStreamChunked . srcToPopper - -srcToPopper :: ConduitM () S.ByteString (ResourceT IO) () -> HCC.GivesPopper () -srcToPopper src f = runResourceT $ do - (rsrc0, ()) <- src $$+ return () - irsrc <- liftIO $ newIORef rsrc0 - is <- getInternalState - let popper :: IO S.ByteString - popper = do - rsrc <- readIORef irsrc - (rsrc', mres) <- runInternalState (rsrc $$++ await) is - writeIORef irsrc rsrc' - case mres of - Nothing -> return S.empty - Just bs - | S.null bs -> popper - | otherwise -> return bs - liftIO $ f popper - -requestBodySourceIO :: Int64 -> ConduitM () S.ByteString IO () -> RequestBody -requestBodySourceIO = HCC.requestBodySource - -requestBodySourceChunkedIO :: ConduitM () S.ByteString IO () -> RequestBody -requestBodySourceChunkedIO = HCC.requestBodySourceChunked +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- = Simpler API +-- +-- The API below is rather low-level. The "Network.HTTP.Simple" module provides +-- a higher-level API with built-in support for things like JSON request and +-- response bodies. For most users, this will be an easier place to start. You +-- can read the tutorial at: +-- +-- +-- +-- = Lower-level API +-- +-- This module contains everything you need to initiate HTTP connections. If +-- you want a simple interface based on URLs, you can use 'simpleHttp'. If you +-- want raw power, 'http' is the underlying workhorse of this package. Some +-- examples: +-- +-- > -- Just download an HTML document and print it. +-- > import Network.HTTP.Conduit +-- > import qualified Data.ByteString.Lazy as L +-- > +-- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr +-- +-- This example uses interleaved IO to write the response body to a file in +-- constant memory space. +-- +-- > import Data.Conduit.Binary (sinkFile) -- Exported from the package conduit-extra +-- > import Network.HTTP.Conduit +-- > import Conduit (runConduit, (.|)) +-- > import Control.Monad.Trans.Resource (runResourceT) +-- > +-- > main :: IO () +-- > main = do +-- > request <- parseRequest "http://google.com/" +-- > manager <- newManager tlsManagerSettings +-- > runResourceT $ do +-- > response <- http request manager +-- > runConduit $ responseBody response .| sinkFile "google.html" +-- +-- The following headers are automatically set by this module, and should not +-- be added to 'requestHeaders': +-- +-- * Cookie +-- +-- * Content-Length +-- +-- * Transfer-Encoding +-- +-- Note: In previous versions, the Host header would be set by this module in +-- all cases. Starting from 1.6.1, if a Host header is present in +-- @requestHeaders@, it will be used in place of the header this module would +-- have generated. This can be useful for calling a server which utilizes +-- virtual hosting. +-- +-- Use `cookieJar` If you want to supply cookies with your request: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > import Network.HTTP.Conduit +-- > import Network +-- > import Data.Time.Clock +-- > import Data.Time.Calendar +-- > import qualified Control.Exception as E +-- > import Network.HTTP.Types.Status (statusCode) +-- > +-- > past :: UTCTime +-- > past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) +-- > +-- > future :: UTCTime +-- > future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0) +-- > +-- > cookie :: Cookie +-- > cookie = Cookie { cookie_name = "password_hash" +-- > , cookie_value = "abf472c35f8297fbcabf2911230001234fd2" +-- > , cookie_expiry_time = future +-- > , cookie_domain = "example.com" +-- > , cookie_path = "/" +-- > , cookie_creation_time = past +-- > , cookie_last_access_time = past +-- > , cookie_persistent = False +-- > , cookie_host_only = False +-- > , cookie_secure_only = False +-- > , cookie_http_only = False +-- > } +-- > +-- > main = do +-- > request' <- parseRequest "http://example.com/secret-page" +-- > manager <- newManager tlsManagerSettings +-- > let request = request' { cookieJar = Just $ createCookieJar [cookie] } +-- > fmap Just (httpLbs request manager) `E.catch` +-- > (\ex -> case ex of +-- > HttpExceptionRequest _ (StatusCodeException res _) -> +-- > if statusCode (responseStatus res) == 403 +-- > then (putStrLn "login failed" >> return Nothing) +-- > else return Nothing +-- > _ -> E.throw ex) +-- +-- Cookies are implemented according to RFC 6265. +-- +-- Note that by default, the functions in this package will throw exceptions +-- for non-2xx status codes. If you would like to avoid this, you should use +-- 'checkStatus', e.g.: +-- +-- > import Data.Conduit.Binary (sinkFile) +-- > import Network.HTTP.Conduit +-- > import qualified Data.Conduit as C +-- > import Network +-- > +-- > main :: IO () +-- > main = do +-- > request' <- parseRequest "http://www.yesodweb.com/does-not-exist" +-- > let request = request' { checkStatus = \_ _ _ -> Nothing } +-- > manager <- newManager tlsManagerSettings +-- > res <- httpLbs request manager +-- > print res +-- +-- By default, when connecting to websites using HTTPS, functions in this +-- package will throw an exception if the TLS certificate doesn't validate. To +-- continue the HTTPS transaction even if the TLS cerficate validation fails, +-- you should use 'mkManagerSetttings' as follows: +-- +-- > import Network.Connection (TLSSettings (..)) +-- > import Network.HTTP.Conduit +-- > +-- > main :: IO () +-- > main = do +-- > request <- parseRequest "https://github.com/" +-- > let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing +-- > manager <- newManager settings +-- > res <- httpLbs request manager +-- > print res +-- +-- For more information, please be sure to read the documentation in the +-- "Network.HTTP.Client" module. + +module Network.HTTP.Conduit + ( -- * Perform a request + simpleHttp + , httpLbs + , http + -- * Datatypes + , Proxy (..) + , RequestBody (..) + -- ** Request + , Request + , method + , secure + , host + , port + , path + , queryString + , requestHeaders + , requestBody + , proxy + , hostAddress + , rawBody + , decompress + , redirectCount +#if MIN_VERSION_http_client(0,6,2) + , shouldStripHeaderOnRedirect +#endif + , checkResponse + , responseTimeout + , cookieJar + , requestVersion + , HCC.setQueryString + -- *** Request body + , requestBodySource + , requestBodySourceChunked + , requestBodySourceIO + , requestBodySourceChunkedIO + -- * Response + , Response + , responseStatus + , responseVersion + , responseHeaders + , responseBody + , responseCookieJar + -- * Manager + , Manager + , newManager + , closeManager + -- ** Settings + , ManagerSettings + , tlsManagerSettings + , mkManagerSettings + , managerConnCount + , managerResponseTimeout + , managerTlsConnection + -- ** Response timeout + , HC.ResponseTimeout + , HC.responseTimeoutMicro + , HC.responseTimeoutNone + , HC.responseTimeoutDefault + -- * Cookies + , Cookie(..) + , CookieJar + , createCookieJar + , destroyCookieJar + -- * Utility functions + , parseUrl + , parseUrlThrow + , parseRequest + , parseRequest_ + , defaultRequest + , applyBasicAuth + , addProxy + , lbsResponse + , getRedirectedRequest + -- * Decompression predicates + , alwaysDecompress + , browserDecompress + -- * Request bodies + -- | "Network.HTTP.Client.MultipartFormData" provides an API for building + -- form-data request bodies. + , urlEncodedBody + -- * Exceptions + , HttpException (..) + , HCC.HttpExceptionContent (..) + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.IORef (readIORef, writeIORef, newIORef) +import Data.Int (Int64) +import Control.Applicative as A ((<$>)) +import Control.Monad.IO.Unlift (MonadIO (liftIO)) +import Control.Monad.Trans.Resource + +import qualified Network.HTTP.Client as Client (httpLbs, responseOpen, responseClose) +import qualified Network.HTTP.Client as HC +import qualified Network.HTTP.Client.Conduit as HCC +import Network.HTTP.Client.Internal (createCookieJar, + destroyCookieJar) +import Network.HTTP.Client.Internal (Manager, ManagerSettings, + closeManager, managerConnCount, + managerResponseTimeout, + managerTlsConnection, newManager) +import Network.HTTP.Client (parseUrl, parseUrlThrow, urlEncodedBody, applyBasicAuth, + defaultRequest, parseRequest, parseRequest_) +import Network.HTTP.Client.Internal (addProxy, alwaysDecompress, + browserDecompress) +import Network.HTTP.Client.Internal (getRedirectedRequest) +import Network.HTTP.Client.TLS (mkManagerSettings, + tlsManagerSettings) +import Network.HTTP.Client.Internal (Cookie (..), CookieJar (..), + HttpException (..), Proxy (..), + Request (..), RequestBody (..), + Response (..)) + +-- | Download the specified 'Request', returning the results as a 'Response'. +-- +-- This is a simplified version of 'http' for the common case where you simply +-- want the response data as a simple datatype. If you want more power, such as +-- interleaved actions on the response body during download, you'll need to use +-- 'http' directly. This function is defined as: +-- +-- @httpLbs = 'lbsResponse' <=< 'http'@ +-- +-- Even though the 'Response' contains a lazy bytestring, this +-- function does /not/ utilize lazy I/O, and therefore the entire +-- response body will live in memory. If you want constant memory +-- usage, you'll need to use @conduit@ packages's +-- 'C.Source' returned by 'http'. +-- +-- This function will 'throwIO' an 'HttpException' for any +-- response with a non-2xx status code (besides 3xx redirects up +-- to a limit of 10 redirects). This behavior can be modified by +-- changing the 'checkStatus' field of your request. +-- +-- Note: Unlike previous versions, this function will perform redirects, as +-- specified by the 'redirectCount' setting. +httpLbs :: MonadIO m => Request -> Manager -> m (Response L.ByteString) +httpLbs r m = liftIO $ Client.httpLbs r m + +-- | Download the specified URL, following any redirects, and +-- return the response body. +-- +-- This function will 'throwIO' an 'HttpException' for any +-- response with a non-2xx status code (besides 3xx redirects up +-- to a limit of 10 redirects). It uses 'parseUrlThrow' to parse the +-- input. This function essentially wraps 'httpLbs'. +-- +-- Note: Even though this function returns a lazy bytestring, it +-- does /not/ utilize lazy I/O, and therefore the entire response +-- body will live in memory. If you want constant memory usage, +-- you'll need to use the @conduit@ package and 'http' directly. +-- +-- Note: This function creates a new 'Manager'. It should be avoided +-- in production code. +simpleHttp :: MonadIO m => String -> m L.ByteString +simpleHttp url = liftIO $ do + man <- newManager tlsManagerSettings + req <- liftIO $ parseUrlThrow url + responseBody A.<$> httpLbs (setConnectionClose req) man + +setConnectionClose :: Request -> Request +setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req} + +lbsResponse :: Monad m + => Response (ConduitM () S.ByteString m ()) + -> m (Response L.ByteString) +lbsResponse res = do + bss <- runConduit $ responseBody res .| CL.consume + return res + { responseBody = L.fromChunks bss + } + +http :: MonadResource m + => Request + -> Manager + -> m (Response (ConduitM i S.ByteString m ())) +http req man = do + (key, res) <- allocate (Client.responseOpen req man) Client.responseClose + return res { responseBody = do + HCC.bodyReaderSource $ responseBody res + release key + } + +requestBodySource :: Int64 -> ConduitM () S.ByteString (ResourceT IO) () -> RequestBody +requestBodySource size = RequestBodyStream size . srcToPopper + +requestBodySourceChunked :: ConduitM () S.ByteString (ResourceT IO) () -> RequestBody +requestBodySourceChunked = RequestBodyStreamChunked . srcToPopper + +srcToPopper :: ConduitM () S.ByteString (ResourceT IO) () -> HCC.GivesPopper () +srcToPopper src f = runResourceT $ do + (rsrc0, ()) <- src $$+ return () + irsrc <- liftIO $ newIORef rsrc0 + is <- getInternalState + let popper :: IO S.ByteString + popper = do + rsrc <- readIORef irsrc + (rsrc', mres) <- runInternalState (rsrc $$++ await) is + writeIORef irsrc rsrc' + case mres of + Nothing -> return S.empty + Just bs + | S.null bs -> popper + | otherwise -> return bs + liftIO $ f popper + +requestBodySourceIO :: Int64 -> ConduitM () S.ByteString IO () -> RequestBody +requestBodySourceIO = HCC.requestBodySource + +requestBodySourceChunkedIO :: ConduitM () S.ByteString IO () -> RequestBody +requestBodySourceChunkedIO = HCC.requestBodySourceChunked diff --git a/Network/HTTP/Simple.hs b/Network/HTTP/Simple.hs --- a/Network/HTTP/Simple.hs +++ b/Network/HTTP/Simple.hs @@ -1,478 +1,501 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} --- | Simplified interface for common HTTP client interactions. Tutorial --- available at --- --- --- Important note: 'H.Request' is an instance of 'Data.String.IsString', and --- therefore recommended usage is to turn on @OverloadedStrings@, e.g. --- --- > {-# LANGUAGE OverloadedStrings #-} --- > import Network.HTTP.Simple --- > import qualified Data.ByteString.Char8 as B8 --- > --- > main :: IO () --- > main = httpBS "http://example.com" >>= B8.putStrLn . getResponseBody --- --- The `Data.String.IsString` instance uses `H.parseRequest` behind the scenes and inherits its behavior. -module Network.HTTP.Simple - ( -- * Perform requests - httpBS - , httpLBS - , httpNoBody - , httpJSON - , httpJSONEither - , httpSink - , httpSource - , withResponse - -- * Types - , H.Header - , H.Query - , H.QueryItem - , H.Request - , H.RequestHeaders - , H.Response - , H.ResponseHeaders - , JSONException (..) - , H.HttpException (..) - , H.Proxy (..) - -- * Request constructions - , H.defaultRequest - , H.parseRequest - , H.parseRequest_ - , parseRequestThrow - , parseRequestThrow_ - -- * Request lenses - -- ** Basics - , setRequestMethod - , setRequestSecure - , setRequestHost - , setRequestPort - , setRequestPath - , addRequestHeader - , getRequestHeader - , setRequestHeader - , setRequestHeaders - , setRequestQueryString - , getRequestQueryString - , addToRequestQueryString - -- ** Request body - , setRequestBody - , setRequestBodyJSON - , setRequestBodyLBS - , setRequestBodySource - , setRequestBodyFile - , setRequestBodyURLEncoded - -- ** Special fields - , H.setRequestIgnoreStatus - , H.setRequestCheckStatus - , setRequestBasicAuth - , setRequestManager - , setRequestProxy - -- * Response lenses - , getResponseStatus - , getResponseStatusCode - , getResponseHeader - , getResponseHeaders - , getResponseBody - -- * Alternate spellings - , httpLbs - ) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Network.HTTP.Client as H -import qualified Network.HTTP.Client.Internal as HI -import qualified Network.HTTP.Client.TLS as H -import Network.HTTP.Client.Conduit (bodyReaderSource) -import qualified Network.HTTP.Client.Conduit as HC -import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) -import Data.Aeson (FromJSON (..), Value) -import Data.Aeson.Parser (json') -import qualified Data.Aeson.Types as A -import qualified Data.Aeson as A -import qualified Data.Traversable as T -import Control.Exception (throw, throwIO, Exception) -import Data.Monoid -import Data.Typeable (Typeable) -import qualified Data.Conduit as C -import Data.Conduit (runConduit, (.|), ConduitM) -import qualified Data.Conduit.Attoparsec as C -import qualified Network.HTTP.Types as H -import Data.Int (Int64) -import Control.Monad.Trans.Resource (MonadResource, MonadThrow) -import qualified Control.Exception as E (bracket) -import Data.Void (Void) -import qualified Data.Attoparsec.ByteString as Atto -import qualified Data.Attoparsec.ByteString.Char8 as Atto8 - --- | Perform an HTTP request and return the body as a @ByteString@. --- --- @since 2.2.4 -httpBS :: MonadIO m => H.Request -> m (H.Response S.ByteString) -httpBS req = liftIO $ do - man <- H.getGlobalManager - fmap L.toStrict `fmap` H.httpLbs req man - --- | Perform an HTTP request and return the body as a lazy --- @ByteString@. Note that the entire value will be read into memory --- at once (no lazy I\/O will be performed). The advantage of a lazy --- @ByteString@ here (versus using 'httpBS') is--if needed--a better --- in-memory representation. --- --- @since 2.1.10 -httpLBS :: MonadIO m => H.Request -> m (H.Response L.ByteString) -httpLBS req = liftIO $ do - man <- H.getGlobalManager - H.httpLbs req man - --- | Perform an HTTP request and ignore the response body. --- --- @since 2.2.2 -httpNoBody :: MonadIO m => H.Request -> m (H.Response ()) -httpNoBody req = liftIO $ do - man <- H.getGlobalManager - H.httpNoBody req man - --- | Perform an HTTP request and parse the body as JSON. In the event of an --- JSON parse errors, a 'JSONException' runtime exception will be thrown. --- --- @since 2.1.10 -httpJSON :: (MonadIO m, FromJSON a) => H.Request -> m (H.Response a) -httpJSON req = liftIO $ httpJSONEither req >>= T.mapM (either throwIO return) - --- | Perform an HTTP request and parse the body as JSON. In the event of an --- JSON parse errors, a @Left@ value will be returned. --- --- @since 2.1.10 -httpJSONEither :: (MonadIO m, FromJSON a) - => H.Request - -> m (H.Response (Either JSONException a)) -httpJSONEither req = liftIO $ httpSink req' sink - where - req' = addRequestHeader H.hAccept "application/json" req - sink orig = fmap (\x -> fmap (const x) orig) $ do - eres1 <- C.sinkParserEither (json' <* (Atto8.skipSpace *> Atto.endOfInput)) - - case eres1 of - Left e -> return $ Left $ JSONParseException req' orig e - Right value -> - case A.fromJSON value of - A.Error e -> return $ Left $ JSONConversionException - req' (fmap (const value) orig) e - A.Success x -> return $ Right x - --- | An exception that can occur when parsing JSON --- --- @since 2.1.10 -data JSONException - = JSONParseException H.Request (H.Response ()) C.ParseError - | JSONConversionException H.Request (H.Response Value) String - deriving (Show, Typeable) -instance Exception JSONException - --- | Perform an HTTP request and consume the body with the given 'C.Sink' --- --- @since 2.1.10 -httpSink :: MonadUnliftIO m - => H.Request - -> (H.Response () -> ConduitM S.ByteString Void m a) - -> m a -httpSink req sink = withRunInIO $ \run -> do - man <- H.getGlobalManager - E.bracket - (H.responseOpen req man) - H.responseClose - $ \res -> run - $ runConduit - $ bodyReaderSource (getResponseBody res) - .| sink (fmap (const ()) res) - --- | Perform an HTTP request, and get the response body as a Source. --- --- The second argument to this function tells us how to make the --- Source from the Response itself. This allows you to perform actions --- with the status or headers, for example, in addition to the raw --- bytes themselves. If you just care about the response body, you can --- use 'getResponseBody' as the second argument here. --- --- @ --- \{\-# LANGUAGE OverloadedStrings \#\-} --- import Control.Monad.IO.Class (liftIO) --- import Control.Monad.Trans.Resource (runResourceT) --- import Data.Conduit (($$)) --- import qualified Data.Conduit.Binary as CB --- import qualified Data.Conduit.List as CL --- import Network.HTTP.Simple --- import System.IO (stdout) --- --- main :: IO () --- main = --- runResourceT --- $ httpSource "http://httpbin.org/robots.txt" getSrc --- $$ CB.sinkHandle stdout --- where --- getSrc res = do --- liftIO $ print (getResponseStatus res, getResponseHeaders res) --- getResponseBody res --- @ --- --- @since 2.2.1 -httpSource :: (MonadResource m, MonadIO n) - => H.Request - -> (H.Response (C.ConduitM i S.ByteString n ()) - -> C.ConduitM i o m r) - -> C.ConduitM i o m r -httpSource req withRes = do - man <- liftIO H.getGlobalManager - C.bracketP (H.responseOpen req man) H.responseClose - (withRes . fmap bodyReaderSource) - --- | Perform an action with the given request. This employes the --- bracket pattern. --- --- This is similar to 'httpSource', but does not require --- 'MonadResource' and allows the result to not contain a 'C.ConduitM' --- value. --- --- @since 2.2.3 -withResponse :: (MonadUnliftIO m, MonadIO n) - => H.Request - -> (H.Response (C.ConduitM i S.ByteString n ()) -> m a) - -> m a -withResponse req withRes = withRunInIO $ \run -> do - man <- H.getGlobalManager - E.bracket - (H.responseOpen req man) - H.responseClose - (run . withRes . fmap bodyReaderSource) - --- | Same as 'parseRequest', except will throw an 'HttpException' in the --- event of a non-2XX response. This uses 'throwErrorStatusCodes' to --- implement 'checkResponse'. --- --- Exactly the same as 'parseUrlThrow', but has a name that is more --- consistent with the other parseRequest functions. --- --- @since 2.3.2 -parseRequestThrow :: MonadThrow m => String -> m HC.Request -parseRequestThrow = HC.parseUrlThrow - --- | Same as 'parseRequestThrow', but parse errors cause an impure --- exception. Mostly useful for static strings which are known to be --- correctly formatted. --- --- @since 2.3.2 -parseRequestThrow_ :: String -> HC.Request -parseRequestThrow_ = either throw id . HC.parseUrlThrow - --- | Alternate spelling of 'httpLBS' --- --- @since 2.1.10 -httpLbs :: MonadIO m => H.Request -> m (H.Response L.ByteString) -httpLbs = httpLBS - --- | Set the request method --- --- @since 2.1.10 -setRequestMethod :: S.ByteString -> H.Request -> H.Request -setRequestMethod x req = req { H.method = x } - --- | Set whether this is a secure/HTTPS (@True@) or insecure/HTTP --- (@False@) request --- --- @since 2.1.10 -setRequestSecure :: Bool -> H.Request -> H.Request -setRequestSecure x req = req { H.secure = x } - --- | Set the destination host of the request --- --- @since 2.1.10 -setRequestHost :: S.ByteString -> H.Request -> H.Request -setRequestHost x r = r { H.host = x } - --- | Set the destination port of the request --- --- @since 2.1.10 -setRequestPort :: Int -> H.Request -> H.Request -setRequestPort x r = r { H.port = x } - --- | Lens for the requested path info of the request --- --- @since 2.1.10 -setRequestPath :: S.ByteString -> H.Request -> H.Request -setRequestPath x r = r { H.path = x } - --- | Add a request header name/value combination --- --- @since 2.1.10 -addRequestHeader :: H.HeaderName -> S.ByteString -> H.Request -> H.Request -addRequestHeader name val req = - req { H.requestHeaders = (name, val) : H.requestHeaders req } - --- | Get all request header values for the given name --- --- @since 2.1.10 -getRequestHeader :: H.HeaderName -> H.Request -> [S.ByteString] -getRequestHeader name = - map snd . filter (\(x, _) -> x == name) . H.requestHeaders - --- | Set the given request header to the given list of values. Removes any --- previously set header values with the same name. --- --- @since 2.1.10 -setRequestHeader :: H.HeaderName -> [S.ByteString] -> H.Request -> H.Request -setRequestHeader name vals req = - req { H.requestHeaders = - filter (\(x, _) -> x /= name) (H.requestHeaders req) - ++ (map (name, ) vals) - } - --- | Set the request headers, wiping out __all__ previously set headers. This --- means if you use 'setRequestHeaders' to set some headers and also use one of --- the other setters that modifies the @content-type@ header (such as --- 'setRequestBodyJSON'), be sure that 'setRequestHeaders' is evaluated --- __first__. --- --- @since 2.1.10 -setRequestHeaders :: H.RequestHeaders -> H.Request -> H.Request -setRequestHeaders x req = req { H.requestHeaders = x } - --- | Get the query string parameters --- --- @since 2.1.10 -getRequestQueryString :: H.Request -> H.Query -getRequestQueryString = H.parseQuery . H.queryString - --- | Set the query string parameters --- --- @since 2.1.10 -setRequestQueryString :: H.Query -> H.Request -> H.Request -setRequestQueryString = H.setQueryString - --- | Add to the existing query string parameters. --- --- @since 2.3.5 -addToRequestQueryString :: H.Query -> H.Request -> H.Request -addToRequestQueryString additions req = setRequestQueryString q req - where q = additions <> getRequestQueryString req - --- | Set the request body to the given 'H.RequestBody'. You may want to --- consider using one of the convenience functions in the modules, e.g. --- 'requestBodyJSON'. --- --- /Note/: This will not modify the request method. For that, please use --- 'requestMethod'. You likely don't want the default of @GET@. --- --- @since 2.1.10 -setRequestBody :: H.RequestBody -> H.Request -> H.Request -setRequestBody x req = req { H.requestBody = x } - --- | Set the request body as a JSON value --- --- /Note/: This will not modify the request method. For that, please use --- 'requestMethod'. You likely don't want the default of @GET@. --- --- This also sets the @Content-Type@ to @application/json; charset=utf-8@ --- --- @since 2.1.10 -setRequestBodyJSON :: A.ToJSON a => a -> H.Request -> H.Request -setRequestBodyJSON x req = - req { H.requestHeaders - = (H.hContentType, "application/json; charset=utf-8") - : filter (\(y, _) -> y /= H.hContentType) (H.requestHeaders req) - , H.requestBody = H.RequestBodyLBS $ A.encode x - } - --- | Set the request body as a lazy @ByteString@ --- --- /Note/: This will not modify the request method. For that, please use --- 'requestMethod'. You likely don't want the default of @GET@. --- --- @since 2.1.10 -setRequestBodyLBS :: L.ByteString -> H.Request -> H.Request -setRequestBodyLBS = setRequestBody . H.RequestBodyLBS - --- | Set the request body as a 'C.Source' --- --- /Note/: This will not modify the request method. For that, please use --- 'requestMethod'. You likely don't want the default of @GET@. --- --- @since 2.1.10 -setRequestBodySource :: Int64 -- ^ length of source - -> ConduitM () S.ByteString IO () - -> H.Request - -> H.Request -setRequestBodySource len src req = req { H.requestBody = HC.requestBodySource len src } - --- | Set the request body as a file --- --- /Note/: This will not modify the request method. For that, please use --- 'requestMethod'. You likely don't want the default of @GET@. --- --- @since 2.1.10 -setRequestBodyFile :: FilePath -> H.Request -> H.Request -setRequestBodyFile = setRequestBody . HI.RequestBodyIO . H.streamFile - --- | Set the request body as URL encoded data --- --- /Note/: This will change the request method to @POST@ and set the @content-type@ --- to @application/x-www-form-urlencoded@ --- --- @since 2.1.10 -setRequestBodyURLEncoded :: [(S.ByteString, S.ByteString)] -> H.Request -> H.Request -setRequestBodyURLEncoded = H.urlEncodedBody - --- | Set basic auth with the given username and password --- --- @since 2.1.10 -setRequestBasicAuth :: S.ByteString -- ^ username - -> S.ByteString -- ^ password - -> H.Request - -> H.Request -setRequestBasicAuth = H.applyBasicAuth - --- | Instead of using the default global 'H.Manager', use the supplied --- @Manager@. --- --- @since 2.1.10 -setRequestManager :: H.Manager -> H.Request -> H.Request -setRequestManager x req = req { HI.requestManagerOverride = Just x } - --- | Override the default proxy server settings --- --- @since 2.1.10 -setRequestProxy :: Maybe H.Proxy -> H.Request -> H.Request -setRequestProxy x req = req { H.proxy = x } - --- | Get the status of the response --- --- @since 2.1.10 -getResponseStatus :: H.Response a -> H.Status -getResponseStatus = H.responseStatus - --- | Get the integral status code of the response --- --- @since 2.1.10 -getResponseStatusCode :: H.Response a -> Int -getResponseStatusCode = H.statusCode . getResponseStatus - --- | Get all response header values with the given name --- --- @since 2.1.10 -getResponseHeader :: H.HeaderName -> H.Response a -> [S.ByteString] -getResponseHeader name = map snd . filter (\(x, _) -> x == name) . H.responseHeaders - --- | Get all response headers --- --- @since 2.1.10 -getResponseHeaders :: H.Response a -> [(H.HeaderName, S.ByteString)] -getResponseHeaders = H.responseHeaders - --- | Get the response body --- --- @since 2.1.10 -getResponseBody :: H.Response a -> a -getResponseBody = H.responseBody +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Simplified interface for common HTTP client interactions. Tutorial +-- available at +-- +-- +-- Important note: 'H.Request' is an instance of 'Data.String.IsString', and +-- therefore recommended usage is to turn on @OverloadedStrings@, e.g. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > import Network.HTTP.Simple +-- > import qualified Data.ByteString.Char8 as B8 +-- > +-- > main :: IO () +-- > main = httpBS "http://example.com" >>= B8.putStrLn . getResponseBody +-- +-- The `Data.String.IsString` instance uses `H.parseRequest` behind the scenes and inherits its behavior. +module Network.HTTP.Simple + ( -- * Perform requests + httpBS + , httpLBS + , httpNoBody +#ifdef VERSION_aeson + , httpJSON + , httpJSONEither +#endif + , httpSink + , httpSource + , withResponse + -- * Types + , H.Header + , H.Query + , H.QueryItem + , H.Request + , H.RequestHeaders + , H.Response + , H.ResponseHeaders +#ifdef VERSION_aeson + , JSONException (..) +#endif + , H.HttpException (..) + , H.Proxy (..) + -- * Request constructions + , H.defaultRequest + , H.parseRequest + , H.parseRequest_ + , parseRequestThrow + , parseRequestThrow_ + -- * Request lenses + -- ** Basics + , setRequestMethod + , setRequestSecure + , setRequestHost + , setRequestPort + , setRequestPath + , addRequestHeader + , getRequestHeader + , setRequestHeader + , setRequestHeaders + , setRequestQueryString + , getRequestQueryString + , addToRequestQueryString + -- ** Request body + , setRequestBody +#ifdef VERSION_aeson + , setRequestBodyJSON +#endif + , setRequestBodyLBS + , setRequestBodySource + , setRequestBodyFile + , setRequestBodyURLEncoded + -- ** Special fields + , H.setRequestIgnoreStatus + , H.setRequestCheckStatus + , setRequestBasicAuth + , setRequestManager + , setRequestProxy + -- * Response lenses + , getResponseStatus + , getResponseStatusCode + , getResponseHeader + , getResponseHeaders + , getResponseBody + -- * Alternate spellings + , httpLbs + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Client.Internal as HI +import qualified Network.HTTP.Client.TLS as H +import Network.HTTP.Client.Conduit (bodyReaderSource) +import qualified Network.HTTP.Client.Conduit as HC +import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) + +#ifdef VERSION_aeson +import Data.Aeson (FromJSON (..), Value) +import Data.Aeson.Parser (json') +import qualified Data.Aeson.Types as A +import qualified Data.Aeson as A +#endif + +import qualified Data.Traversable as T +import Control.Exception (throw, throwIO, Exception) +import Data.Monoid +import Data.Typeable (Typeable) +import qualified Data.Conduit as C +import Data.Conduit (runConduit, (.|), ConduitM) +import qualified Data.Conduit.Attoparsec as C +import qualified Network.HTTP.Types as H +import Data.Int (Int64) +import Control.Monad.Trans.Resource (MonadResource, MonadThrow) +import qualified Control.Exception as E (bracket) +import Data.Void (Void) +import qualified Data.Attoparsec.ByteString as Atto +import qualified Data.Attoparsec.ByteString.Char8 as Atto8 + +-- | Perform an HTTP request and return the body as a @ByteString@. +-- +-- @since 2.2.4 +httpBS :: MonadIO m => H.Request -> m (H.Response S.ByteString) +httpBS req = liftIO $ do + man <- H.getGlobalManager + fmap L.toStrict `fmap` H.httpLbs req man + +-- | Perform an HTTP request and return the body as a lazy +-- @ByteString@. Note that the entire value will be read into memory +-- at once (no lazy I\/O will be performed). The advantage of a lazy +-- @ByteString@ here (versus using 'httpBS') is--if needed--a better +-- in-memory representation. +-- +-- @since 2.1.10 +httpLBS :: MonadIO m => H.Request -> m (H.Response L.ByteString) +httpLBS req = liftIO $ do + man <- H.getGlobalManager + H.httpLbs req man + +-- | Perform an HTTP request and ignore the response body. +-- +-- @since 2.2.2 +httpNoBody :: MonadIO m => H.Request -> m (H.Response ()) +httpNoBody req = liftIO $ do + man <- H.getGlobalManager + H.httpNoBody req man + +#ifdef VERSION_aeson +-- | Perform an HTTP request and parse the body as JSON. In the event of an +-- JSON parse errors, a 'JSONException' runtime exception will be thrown. +-- +-- NOTE: Depends on the @aeson@ cabal flag being enabled +-- +-- @since 2.1.10 +httpJSON :: (MonadIO m, FromJSON a) => H.Request -> m (H.Response a) +httpJSON req = liftIO $ httpJSONEither req >>= T.mapM (either throwIO return) + +-- | Perform an HTTP request and parse the body as JSON. In the event of an +-- JSON parse errors, a @Left@ value will be returned. +-- +-- NOTE: Depends on the @aeson@ cabal flag being enabled +-- +-- @since 2.1.10 +httpJSONEither :: (MonadIO m, FromJSON a) + => H.Request + -> m (H.Response (Either JSONException a)) +httpJSONEither req = liftIO $ httpSink req' sink + where + req' = addRequestHeader H.hAccept "application/json" req + sink orig = fmap (\x -> fmap (const x) orig) $ do + eres1 <- C.sinkParserEither (json' <* (Atto8.skipSpace *> Atto.endOfInput)) + + case eres1 of + Left e -> return $ Left $ JSONParseException req' orig e + Right value -> + case A.fromJSON value of + A.Error e -> return $ Left $ JSONConversionException + req' (fmap (const value) orig) e + A.Success x -> return $ Right x + +-- | An exception that can occur when parsing JSON +-- +-- NOTE: Depends on the @aeson@ cabal flag being enabled +-- +-- @since 2.1.10 +data JSONException + = JSONParseException H.Request (H.Response ()) C.ParseError + | JSONConversionException H.Request (H.Response Value) String + deriving (Show, Typeable) +instance Exception JSONException +#endif + +-- | Perform an HTTP request and consume the body with the given 'C.Sink' +-- +-- @since 2.1.10 +httpSink :: MonadUnliftIO m + => H.Request + -> (H.Response () -> ConduitM S.ByteString Void m a) + -> m a +httpSink req sink = withRunInIO $ \run -> do + man <- H.getGlobalManager + E.bracket + (H.responseOpen req man) + H.responseClose + $ \res -> run + $ runConduit + $ bodyReaderSource (getResponseBody res) + .| sink (fmap (const ()) res) + +-- | Perform an HTTP request, and get the response body as a Source. +-- +-- The second argument to this function tells us how to make the +-- Source from the Response itself. This allows you to perform actions +-- with the status or headers, for example, in addition to the raw +-- bytes themselves. If you just care about the response body, you can +-- use 'getResponseBody' as the second argument here. +-- +-- @ +-- \{\-# LANGUAGE OverloadedStrings \#\-} +-- import Control.Monad.IO.Class (liftIO) +-- import Control.Monad.Trans.Resource (runResourceT) +-- import Data.Conduit (($$)) +-- import qualified Data.Conduit.Binary as CB +-- import qualified Data.Conduit.List as CL +-- import Network.HTTP.Simple +-- import System.IO (stdout) +-- +-- main :: IO () +-- main = +-- runResourceT +-- $ httpSource "http://httpbin.org/robots.txt" getSrc +-- $$ CB.sinkHandle stdout +-- where +-- getSrc res = do +-- liftIO $ print (getResponseStatus res, getResponseHeaders res) +-- getResponseBody res +-- @ +-- +-- @since 2.2.1 +httpSource :: (MonadResource m, MonadIO n) + => H.Request + -> (H.Response (C.ConduitM i S.ByteString n ()) + -> C.ConduitM i o m r) + -> C.ConduitM i o m r +httpSource req withRes = do + man <- liftIO H.getGlobalManager + C.bracketP (H.responseOpen req man) H.responseClose + (withRes . fmap bodyReaderSource) + +-- | Perform an action with the given request. This employes the +-- bracket pattern. +-- +-- This is similar to 'httpSource', but does not require +-- 'MonadResource' and allows the result to not contain a 'C.ConduitM' +-- value. +-- +-- @since 2.2.3 +withResponse :: (MonadUnliftIO m, MonadIO n) + => H.Request + -> (H.Response (C.ConduitM i S.ByteString n ()) -> m a) + -> m a +withResponse req withRes = withRunInIO $ \run -> do + man <- H.getGlobalManager + E.bracket + (H.responseOpen req man) + H.responseClose + (run . withRes . fmap bodyReaderSource) + +-- | Same as 'parseRequest', except will throw an 'HttpException' in the +-- event of a non-2XX response. This uses 'throwErrorStatusCodes' to +-- implement 'checkResponse'. +-- +-- Exactly the same as 'parseUrlThrow', but has a name that is more +-- consistent with the other parseRequest functions. +-- +-- @since 2.3.2 +parseRequestThrow :: MonadThrow m => String -> m HC.Request +parseRequestThrow = HC.parseUrlThrow + +-- | Same as 'parseRequestThrow', but parse errors cause an impure +-- exception. Mostly useful for static strings which are known to be +-- correctly formatted. +-- +-- @since 2.3.2 +parseRequestThrow_ :: String -> HC.Request +parseRequestThrow_ = either throw id . HC.parseUrlThrow + +-- | Alternate spelling of 'httpLBS' +-- +-- @since 2.1.10 +httpLbs :: MonadIO m => H.Request -> m (H.Response L.ByteString) +httpLbs = httpLBS + +-- | Set the request method +-- +-- @since 2.1.10 +setRequestMethod :: S.ByteString -> H.Request -> H.Request +setRequestMethod x req = req { H.method = x } + +-- | Set whether this is a secure/HTTPS (@True@) or insecure/HTTP +-- (@False@) request +-- +-- @since 2.1.10 +setRequestSecure :: Bool -> H.Request -> H.Request +setRequestSecure x req = req { H.secure = x } + +-- | Set the destination host of the request +-- +-- @since 2.1.10 +setRequestHost :: S.ByteString -> H.Request -> H.Request +setRequestHost x r = r { H.host = x } + +-- | Set the destination port of the request +-- +-- @since 2.1.10 +setRequestPort :: Int -> H.Request -> H.Request +setRequestPort x r = r { H.port = x } + +-- | Lens for the requested path info of the request +-- +-- @since 2.1.10 +setRequestPath :: S.ByteString -> H.Request -> H.Request +setRequestPath x r = r { H.path = x } + +-- | Add a request header name/value combination +-- +-- @since 2.1.10 +addRequestHeader :: H.HeaderName -> S.ByteString -> H.Request -> H.Request +addRequestHeader name val req = + req { H.requestHeaders = (name, val) : H.requestHeaders req } + +-- | Get all request header values for the given name +-- +-- @since 2.1.10 +getRequestHeader :: H.HeaderName -> H.Request -> [S.ByteString] +getRequestHeader name = + map snd . filter (\(x, _) -> x == name) . H.requestHeaders + +-- | Set the given request header to the given list of values. Removes any +-- previously set header values with the same name. +-- +-- @since 2.1.10 +setRequestHeader :: H.HeaderName -> [S.ByteString] -> H.Request -> H.Request +setRequestHeader name vals req = + req { H.requestHeaders = + filter (\(x, _) -> x /= name) (H.requestHeaders req) + ++ (map (name, ) vals) + } + +-- | Set the request headers, wiping out __all__ previously set headers. This +-- means if you use 'setRequestHeaders' to set some headers and also use one of +-- the other setters that modifies the @content-type@ header (such as +-- 'setRequestBodyJSON'), be sure that 'setRequestHeaders' is evaluated +-- __first__. +-- +-- @since 2.1.10 +setRequestHeaders :: H.RequestHeaders -> H.Request -> H.Request +setRequestHeaders x req = req { H.requestHeaders = x } + +-- | Get the query string parameters +-- +-- @since 2.1.10 +getRequestQueryString :: H.Request -> H.Query +getRequestQueryString = H.parseQuery . H.queryString + +-- | Set the query string parameters +-- +-- @since 2.1.10 +setRequestQueryString :: H.Query -> H.Request -> H.Request +setRequestQueryString = H.setQueryString + +-- | Add to the existing query string parameters. +-- +-- @since 2.3.5 +addToRequestQueryString :: H.Query -> H.Request -> H.Request +addToRequestQueryString additions req = setRequestQueryString q req + where q = additions <> getRequestQueryString req + +-- | Set the request body to the given 'H.RequestBody'. You may want to +-- consider using one of the convenience functions in the modules, e.g. +-- 'requestBodyJSON'. +-- +-- /Note/: This will not modify the request method. For that, please use +-- 'requestMethod'. You likely don't want the default of @GET@. +-- +-- @since 2.1.10 +setRequestBody :: H.RequestBody -> H.Request -> H.Request +setRequestBody x req = req { H.requestBody = x } + +#ifdef VERSION_aeson +-- | Set the request body as a JSON value +-- +-- /Note/: This will not modify the request method. For that, please use +-- 'requestMethod'. You likely don't want the default of @GET@. +-- +-- This also sets the @Content-Type@ to @application/json; charset=utf-8@ +-- +-- NOTE: Depends on the @aeson@ cabal flag being enabled +-- +-- @since 2.1.10 +setRequestBodyJSON :: A.ToJSON a => a -> H.Request -> H.Request +setRequestBodyJSON x req = + req { H.requestHeaders + = (H.hContentType, "application/json; charset=utf-8") + : filter (\(y, _) -> y /= H.hContentType) (H.requestHeaders req) + , H.requestBody = H.RequestBodyLBS $ A.encode x + } +#endif + +-- | Set the request body as a lazy @ByteString@ +-- +-- /Note/: This will not modify the request method. For that, please use +-- 'requestMethod'. You likely don't want the default of @GET@. +-- +-- @since 2.1.10 +setRequestBodyLBS :: L.ByteString -> H.Request -> H.Request +setRequestBodyLBS = setRequestBody . H.RequestBodyLBS + +-- | Set the request body as a 'C.Source' +-- +-- /Note/: This will not modify the request method. For that, please use +-- 'requestMethod'. You likely don't want the default of @GET@. +-- +-- @since 2.1.10 +setRequestBodySource :: Int64 -- ^ length of source + -> ConduitM () S.ByteString IO () + -> H.Request + -> H.Request +setRequestBodySource len src req = req { H.requestBody = HC.requestBodySource len src } + +-- | Set the request body as a file +-- +-- /Note/: This will not modify the request method. For that, please use +-- 'requestMethod'. You likely don't want the default of @GET@. +-- +-- @since 2.1.10 +setRequestBodyFile :: FilePath -> H.Request -> H.Request +setRequestBodyFile = setRequestBody . HI.RequestBodyIO . H.streamFile + +-- | Set the request body as URL encoded data +-- +-- /Note/: This will change the request method to @POST@ and set the @content-type@ +-- to @application/x-www-form-urlencoded@ +-- +-- @since 2.1.10 +setRequestBodyURLEncoded :: [(S.ByteString, S.ByteString)] -> H.Request -> H.Request +setRequestBodyURLEncoded = H.urlEncodedBody + +-- | Set basic auth with the given username and password +-- +-- @since 2.1.10 +setRequestBasicAuth :: S.ByteString -- ^ username + -> S.ByteString -- ^ password + -> H.Request + -> H.Request +setRequestBasicAuth = H.applyBasicAuth + +-- | Instead of using the default global 'H.Manager', use the supplied +-- @Manager@. +-- +-- @since 2.1.10 +setRequestManager :: H.Manager -> H.Request -> H.Request +setRequestManager x req = req { HI.requestManagerOverride = Just x } + +-- | Override the default proxy server settings +-- +-- @since 2.1.10 +setRequestProxy :: Maybe H.Proxy -> H.Request -> H.Request +setRequestProxy x req = req { H.proxy = x } + +-- | Get the status of the response +-- +-- @since 2.1.10 +getResponseStatus :: H.Response a -> H.Status +getResponseStatus = H.responseStatus + +-- | Get the integral status code of the response +-- +-- @since 2.1.10 +getResponseStatusCode :: H.Response a -> Int +getResponseStatusCode = H.statusCode . getResponseStatus + +-- | Get all response header values with the given name +-- +-- @since 2.1.10 +getResponseHeader :: H.HeaderName -> H.Response a -> [S.ByteString] +getResponseHeader name = map snd . filter (\(x, _) -> x == name) . H.responseHeaders + +-- | Get all response headers +-- +-- @since 2.1.10 +getResponseHeaders :: H.Response a -> [(H.HeaderName, S.ByteString)] +getResponseHeaders = H.responseHeaders + +-- | Get the response body +-- +-- @since 2.1.10 +getResponseBody :: H.Response a -> a +getResponseBody = H.responseBody diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,10 @@ -http-conduit -============ - -Provides for making efficient HTTP/HTTPS requests, providing either a simple or -streaming interface. - -Full tutorial docs are available at: -https://haskell-lang.org/library/http-client - -The `Network.HTTP.Conduit.Browser` module has been moved to +http-conduit +============ + +Provides for making efficient HTTP/HTTPS requests, providing either a simple or +streaming interface. + +Full tutorial docs are available at: +https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md + +The `Network.HTTP.Conduit.Browser` module has been moved to diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,8 +1,8 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple -> import System.Cmd (system) - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain diff --git a/certificate.pem b/certificate.pem --- a/certificate.pem +++ b/certificate.pem @@ -1,15 +1,15 @@ ------BEGIN CERTIFICATE----- -MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV -BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX -aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF -MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50 -ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB -gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx -EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs -+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV -HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM -b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk -D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0 -k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw -VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w== ------END CERTIFICATE----- +-----BEGIN CERTIFICATE----- +MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV +BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX +aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF +MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50 +ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB +gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx +EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs ++p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV +HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM +b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk +D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0 +k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw +VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w== +-----END CERTIFICATE----- diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,84 +1,96 @@ -name: http-conduit -version: 2.3.7.3 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman -synopsis: HTTP client package with conduit interface and HTTPS support. -description: Hackage documentation generation is not reliable. For up to date documentation, please see: . -category: Web, Conduit -stability: Stable -cabal-version: >= 1.8 -build-type: Simple -homepage: http://www.yesodweb.com/book/http-conduit -extra-source-files: test/main.hs - , test/CookieTest.hs - , multipart-example.bin - , nyan.gif - , certificate.pem - , key.pem - , README.md - , ChangeLog.md - -library - build-depends: base >= 4 && < 5 - , aeson >= 0.8 - , attoparsec - , bytestring >= 0.9.1.4 - , transformers >= 0.2 - , resourcet >= 1.1 - , conduit >= 1.2 - , conduit-extra >= 1.1 - , http-types >= 0.7 - , http-client >= 0.5.13 && < 0.7 - , http-client-tls >= 0.3 && < 0.4 - , mtl - , unliftio-core - - if !impl(ghc>=7.9) - build-depends: void >= 0.5.5 - exposed-modules: Network.HTTP.Conduit - Network.HTTP.Client.Conduit - Network.HTTP.Simple - ghc-options: -Wall - -test-suite test - main-is: main.hs - other-modules: CookieTest - type: exitcode-stdio-1.0 - hs-source-dirs: test - - ghc-options: -Wall - cpp-options: -DDEBUG - build-depends: base >= 4 && < 5 - , HUnit - , hspec >= 1.3 - , data-default-class - , connection >= 0.2 - , warp-tls - , time - , blaze-builder - , bytestring - , text - , transformers - , conduit >= 1.1 - , utf8-string - , case-insensitive - , unliftio - , wai >= 3.0 && < 3.3 - , warp >= 3.0.0.2 && < 3.4 - , wai-conduit - , http-types - , cookie - , http-client - , http-conduit - , conduit-extra - , streaming-commons - , aeson - , temporary - , resourcet - , network - -source-repository head - type: git - location: git://github.com/snoyberg/http-client.git +cabal-version: >= 1.10 +name: http-conduit +version: 2.3.7.4 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: HTTP client package with conduit interface and HTTPS support. +description: Hackage documentation generation is not reliable. For up to date documentation, please see: . +category: Web, Conduit +stability: Stable +build-type: Simple +homepage: http://www.yesodweb.com/book/http-conduit +extra-source-files: test/main.hs + , test/CookieTest.hs + , multipart-example.bin + , nyan.gif + , certificate.pem + , key.pem + , README.md + , ChangeLog.md + +flag aeson + manual: True + description: Enable the dependency on aeson + default: True + +library + default-language: Haskell2010 + build-depends: base >= 4.10 && < 5 + , attoparsec + , bytestring >= 0.9.1.4 + , transformers >= 0.2 + , resourcet >= 1.1 + , conduit >= 1.2 + , conduit-extra >= 1.1 + , http-types >= 0.7 + , http-client >= 0.5.13 && < 0.8 + , http-client-tls >= 0.3 && < 0.4 + , mtl + , unliftio-core + + if flag(aeson) + build-depends: aeson >= 0.8 + + if !impl(ghc>=7.9) + build-depends: void >= 0.5.5 + exposed-modules: Network.HTTP.Conduit + Network.HTTP.Client.Conduit + Network.HTTP.Simple + ghc-options: -Wall + +test-suite test + default-language: Haskell2010 + main-is: main.hs + other-modules: CookieTest + type: exitcode-stdio-1.0 + hs-source-dirs: test + + ghc-options: -Wall + cpp-options: -DDEBUG + build-depends: base >= 4 && < 5 + , HUnit + , hspec >= 1.3 + , data-default-class + , connection >= 0.2 + , warp-tls + , tls < 1.5 || >= 1.5.2 + , time + , blaze-builder + , bytestring + , text + , transformers + , conduit >= 1.1 + , utf8-string + , case-insensitive + , unliftio + , wai >= 3.0 && < 3.3 + , warp >= 3.0.0.2 && < 3.4 + , wai-conduit + , http-types + , cookie + , http-client + , http-conduit + , conduit-extra + , streaming-commons + , temporary + , resourcet + , network + + if flag(aeson) + build-depends: aeson + +source-repository head + type: git + location: git://github.com/snoyberg/http-client.git diff --git a/key.pem b/key.pem --- a/key.pem +++ b/key.pem @@ -1,15 +1,15 @@ ------BEGIN RSA PRIVATE KEY----- -MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd -thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD -JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB -AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63 -CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM -MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp -ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid -Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B -5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs -eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV -YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv -jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG -T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8= ------END RSA PRIVATE KEY----- +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd +thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD +JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB +AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63 +CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM +MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp +ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid +Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B +5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs +eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV +YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv +jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG +T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8= +-----END RSA PRIVATE KEY----- diff --git a/test/CookieTest.hs b/test/CookieTest.hs --- a/test/CookieTest.hs +++ b/test/CookieTest.hs @@ -1,558 +1,580 @@ -module CookieTest (cookieTest) where - -import Prelude hiding (exp) -import Test.Hspec -import qualified Data.ByteString as BS -import Test.HUnit hiding (path) -import Network.HTTP.Client -import qualified Network.HTTP.Conduit as HC -import Data.ByteString.UTF8 -import Data.Monoid -import Data.Time.Clock -import Data.Time.Calendar -import qualified Data.CaseInsensitive as CI -import Web.Cookie - -default_request :: HC.Request -default_request = HC.parseRequest_ "http://www.google.com/" - -default_cookie :: Cookie -default_cookie = Cookie { cookie_name = fromString "name" - , cookie_value = fromString "value" - , cookie_expiry_time = default_time - , cookie_domain = fromString "www.google.com" - , cookie_path = fromString "/" - , cookie_creation_time = default_time - , cookie_last_access_time = default_time - , cookie_persistent = False - , cookie_host_only = False - , cookie_secure_only = False - , cookie_http_only = False - } - -default_time :: UTCTime -default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) - -default_diff_time :: DiffTime -default_diff_time = secondsToDiffTime 1209600 - -default_set_cookie :: SetCookie -default_set_cookie = def { setCookieName = fromString "name" - , setCookieValue = fromString "value" - , setCookiePath = Just $ fromString "/" - , setCookieExpires = Just default_time - , setCookieMaxAge = Just default_diff_time - , setCookieDomain = Just $ fromString "www.google.com" - , setCookieHttpOnly = False - , setCookieSecure = False - } - -testValidIp :: IO () -testValidIp = assertBool "Couldn't parse valid IP address" $ - isIpAddress $ fromString "1.2.3.4" - -testIpNumTooHigh :: IO () -testIpNumTooHigh = assertBool "One of the digits in the IP address is too large" $ - not $ isIpAddress $ fromString "501.2.3.4" - -testTooManySegmentsInIp :: IO () -testTooManySegmentsInIp = assertBool "Too many segments in the ip address" $ - not $ isIpAddress $ fromString "1.2.3.4.5" - -testCharsInIp :: IO () -testCharsInIp = assertBool "Chars are not allowed in IP addresses" $ - not $ isIpAddress $ fromString "1.2a3.4.5" - -testDomainMatchesSuccess :: IO () -testDomainMatchesSuccess = assertBool "Domains should match" $ - domainMatches (fromString "www.google.com") (fromString "google.com") - -testSameDomain :: IO () -testSameDomain = assertBool "Same domain should match" $ - domainMatches domain domain - where domain = fromString "www.google.com" - -testSiblingDomain :: IO () -testSiblingDomain = assertBool "Sibling domain should not match" $ - not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com") - -testParentDomain :: IO () -testParentDomain = assertBool "Parent domain should fail" $ - not $ domainMatches (fromString "google.com") (fromString "www.google.com") - -testNaiveSuffixDomain :: IO () -testNaiveSuffixDomain = assertBool "Naively checking for suffix for domain matching should fail" $ - not $ domainMatches (fromString "agoogle.com") (fromString "google.com") - -testDefaultPath :: IO () -testDefaultPath = assertEqual "Getting default path from a request" - (fromString "/") (defaultPath default_request) - -testShortDefaultPath :: IO () -testShortDefaultPath = assertEqual "Getting default path from a short path" - (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"}) - -testPopulatedDefaultPath :: IO () -testPopulatedDefaultPath = assertEqual "Getting default path from a request with a path" - (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"}) - -testParamsDefaultPath :: IO () -testParamsDefaultPath = assertEqual "Getting default path from a request with a path and GET params" - (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"}) - -testDefaultPathEndingInSlash :: IO () -testDefaultPathEndingInSlash = assertEqual "Getting default path that ends in a slash" - (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"}) - -testSamePathsMatch :: IO () -testSamePathsMatch = assertBool "The same path should match" $ - pathMatches path' path' - where path' = fromString "/a/path" - -testPathSlashAtEnd :: IO () -testPathSlashAtEnd = assertBool "Putting the slash at the end should still match paths" $ - pathMatches (fromString "/a/path/to/here") (fromString "/a/path/") - -testPathNoSlashAtEnd :: IO () -testPathNoSlashAtEnd = assertBool "Not putting the slash at the end should still match paths" $ - pathMatches (fromString "/a/path/to/here") (fromString "/a/path") - -testDivergingPaths :: IO () -testDivergingPaths = assertBool "Diverging paths don't match" $ - not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path") - -testCookieEqualitySuccess :: IO () -testCookieEqualitySuccess = assertEqual "The same cookies should be equal" - cookie cookie - where cookie = default_cookie - -testCookieEqualityResiliance :: IO () -testCookieEqualityResiliance = assertEqual "Cookies should still be equal if extra options are changed" - (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True}) - -testDomainChangesEquality :: IO () -testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $ - default_cookie /= (default_cookie {cookie_domain = fromString "/search"}) - -testRemoveCookie :: IO () -testRemoveCookie = assertEqual "Removing a cookie works" - (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) - -testRemoveNonexistantCookie :: IO () -testRemoveNonexistantCookie = assertEqual "Removing a nonexistent cookie doesn't work" - (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie]) - -testRemoveCorrectCookie :: IO () -testRemoveCorrectCookie = assertEqual "Removing only the correct cookie" - (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for]) - where search_for = default_cookie {cookie_name = fromString "name1"} - red_herring = default_cookie {cookie_name = fromString "name2"} - -testEvictExpiredCookies :: IO () -testEvictExpiredCookies = assertEqual "Evicting expired cookies works" - (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle) - where a = default_cookie { cookie_name = fromString "a" - , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) - } - b = default_cookie { cookie_name = fromString "b" - , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) - } - c = default_cookie { cookie_name = fromString "c" - , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) - } - d = default_cookie { cookie_name = fromString "d" - , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) - } - middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) - -testEvictNoCookies :: IO () -testEvictNoCookies = assertEqual "Evicting empty cookie jar" - (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle) - where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) - -testComputeCookieStringUpdateLastAccessTime :: IO () -testComputeCookieStringUpdateLastAccessTime = assertEqual "Updates last access time upon using cookies" - (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True) - where request = default_request - cookie_jar = createCookieJar [default_cookie] - now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}] - -testComputeCookieStringHostOnly :: IO () -testComputeCookieStringHostOnly = assertEqual "Host only cookies should match host exactly" - (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request - cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}] - -testComputeCookieStringHostOnlyFilter :: IO () -testComputeCookieStringHostOnlyFilter = assertEqual "Host only cookies shouldn't match subdomain" - (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.host = fromString "sub1.sub2.google.com"} - cookie_jar = createCookieJar [default_cookie { cookie_host_only = True - , cookie_domain = fromString "sub2.google.com" - } - ] - -testComputeCookieStringDomainMatching :: IO () -testComputeCookieStringDomainMatching = assertEqual "Domain matching works for new requests" - (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.host = fromString "sub1.sub2.google.com"} - cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}] - -testComputeCookieStringPathMatching :: IO () -testComputeCookieStringPathMatching = assertEqual "Path matching works for new requests" - (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.path = fromString "/a/path/to/nowhere"} - cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] - -testComputeCookieStringPathMatchingFails :: IO () -testComputeCookieStringPathMatchingFails = assertEqual "Path matching fails when it should" - (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"} - cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] - -testComputeCookieStringPathMatchingWithParms :: IO () -testComputeCookieStringPathMatchingWithParms = assertEqual "Path matching succeeds when request has GET params" - (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"} - cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] - -testComputeCookieStringSecure :: IO () -testComputeCookieStringSecure = assertEqual "Secure flag filters properly" - (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True) - where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}] - -testComputeCookieStringHttpOnly :: IO () -testComputeCookieStringHttpOnly = assertEqual "http-only flag filters properly" - (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False) - where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}] - -testComputeCookieStringSort :: IO () -testComputeCookieStringSort = assertEqual "Sorting works correctly" - (fromString "c1=v1;c3=v3;c4=v4;c2=v2", cookie_jar_out) format_output - where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) - cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" - , cookie_value = fromString "v1" - , cookie_path = fromString "/all/encompassing/request" - } - , default_cookie { cookie_name = fromString "c2" - , cookie_value = fromString "v2" - , cookie_path = fromString "/all" - } - , default_cookie { cookie_name = fromString "c3" - , cookie_value = fromString "v3" - , cookie_path = fromString "/all/encompassing" - , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - } - , default_cookie { cookie_name = fromString "c4" - , cookie_value = fromString "v4" - , cookie_path = fromString "/all/encompassing" - , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) - } - ] - cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1" - , cookie_value = fromString "v1" - , cookie_path = fromString "/all/encompassing/request" - , cookie_last_access_time = now - } - , default_cookie { cookie_name = fromString "c2" - , cookie_value = fromString "v2" - , cookie_path = fromString "/all" - , cookie_last_access_time = now - } - , default_cookie { cookie_name = fromString "c3" - , cookie_value = fromString "v3" - , cookie_path = fromString "/all/encompassing" - , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - , cookie_last_access_time = now - } - , default_cookie { cookie_name = fromString "c4" - , cookie_value = fromString "v4" - , cookie_path = fromString "/all/encompassing" - , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) - , cookie_last_access_time = now - } - ] - request = default_request {HC.path = fromString "/all/encompassing/request/path"} - format_output = computeCookieString request cookie_jar default_time False - -testInsertCookiesIntoRequestWorks :: IO () -testInsertCookiesIntoRequestWorks = assertEqual "Inserting cookies works" - [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers - where out_headers = HC.requestHeaders req - (req, _) = insertCookiesIntoRequest req' cookie_jar default_time - cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key" - , cookie_value = fromString "val" - } - ] - req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie", - fromString "otherkey=otherval")]} - -testReceiveSetCookie :: IO () -testReceiveSetCookie = assertEqual "Receiving a Set-Cookie" - (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) - -testReceiveSetCookieTrailingDot :: IO () -testReceiveSetCookieTrailingDot = assertEqual "Receiving a Set-Cookie with a trailing domain dot" - (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."} - -testReceiveSetCookieLeadingDot :: IO () -testReceiveSetCookieLeadingDot = assertEqual "Receiving a Set-Cookie with a leading domain dot" - (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} - -testReceiveSetCookieNoDomain :: IO () -testReceiveSetCookieNoDomain = assertEqual "Receiving cookie without domain" - (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Nothing} - -testReceiveSetCookieEmptyDomain :: IO () -testReceiveSetCookieEmptyDomain = assertEqual "Receiving cookie with empty domain" - (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty} - --- Can't test public suffixes until that module is written - -testReceiveSetCookieNonMatchingDomain :: IO () -testReceiveSetCookieNonMatchingDomain = assertEqual "Receiving cookie with non-matching domain" - (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"} - -testReceiveSetCookieHostOnly :: IO () -testReceiveSetCookieHostOnly = assertBool "Checking host-only flag gets set" $ - cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieDomain = Nothing} - -testReceiveSetCookieHostOnlyNotSet :: IO () -testReceiveSetCookieHostOnlyNotSet = assertBool "Checking host-only flag doesn't get set" $ - not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"} - -testReceiveSetCookieHttpOnly :: IO () -testReceiveSetCookieHttpOnly = assertBool "Checking http-only flag gets set" $ - cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieHttpOnly = True} - -testReceiveSetCookieHttpOnlyNotSet :: IO () -testReceiveSetCookieHttpOnlyNotSet = assertBool "Checking http-only flag doesn't get set" $ - not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieHttpOnly = False} - -testReceiveSetCookieHttpOnlyDrop :: IO () -testReceiveSetCookieHttpOnlyDrop = assertEqual "Checking non http request gets dropped" - (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieHttpOnly = True} - -testReceiveSetCookieName :: IO () -testReceiveSetCookieName = assertEqual "Name gets set correctly" - (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) - -testReceiveSetCookieValue :: IO () -testReceiveSetCookieValue = assertEqual "Value gets set correctly" - (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) - -testReceiveSetCookieExpiry :: IO () -testReceiveSetCookieExpiry = assertEqual "Expiry gets set correctly" - now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) - where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) - -testReceiveSetCookieNoMaxAge :: IO () -testReceiveSetCookieNoMaxAge = assertEqual "Expiry is based on the given value" - default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar []) - where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing} - -testReceiveSetCookieNoExpiry :: IO () -testReceiveSetCookieNoExpiry = assertEqual "Expiry is based on max age" - now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar []) - where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) - cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing} - -testReceiveSetCookieNoExpiryNoMaxAge :: IO () -testReceiveSetCookieNoExpiryNoMaxAge = assertBool "Expiry is set to a future date" $ - default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar []) - where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing } - -testReceiveSetCookiePath :: IO () -testReceiveSetCookiePath = assertEqual "Path gets set correctly" - (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"} - -testReceiveSetCookieNoPath :: IO () -testReceiveSetCookieNoPath = assertEqual "Path gets set correctly when nonexistent" - (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookiePath = Nothing} - request = default_request {HC.path = fromString "/a/path/to/nowhere"} - -testReceiveSetCookieCreationTime :: IO () -testReceiveSetCookieCreationTime = assertEqual "Creation time gets set correctly" - now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) - where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - -testReceiveSetCookieAccessTime :: IO () -testReceiveSetCookieAccessTime = assertEqual "Last access time gets set correctly" - now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) - where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - -testReceiveSetCookiePersistent :: IO () -testReceiveSetCookiePersistent = assertBool "Persistent flag gets set correctly" $ - cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieExpires = Just default_time} - -testReceiveSetCookieSecure :: IO () -testReceiveSetCookieSecure = assertBool "Secure flag gets set correctly" $ - cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieSecure = True} - -testReceiveSetCookieMaxAge :: IO () -testReceiveSetCookieMaxAge = assertEqual "Max-Age gets set correctly" - total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) - where set_cookie = default_set_cookie { setCookieExpires = Nothing - , setCookieMaxAge = Just $ secondsToDiffTime 10 - } - now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) - total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) - -testReceiveSetCookiePreferMaxAge :: IO () -testReceiveSetCookiePreferMaxAge = assertEqual "Max-Age is preferred over Expires" - total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) - where set_cookie = default_set_cookie { setCookieExpires = Just exp - , setCookieMaxAge = Just $ secondsToDiffTime 10 - } - exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5) - now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) - total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) - -testReceiveSetCookieExisting :: IO () -testReceiveSetCookieExisting = assertEqual "Existing cookie gets updated" - t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie]) - where set_cookie = default_set_cookie { setCookieExpires = Just t - , setCookieMaxAge = Nothing - } - t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) - -testReceiveSetCookieExistingCreation :: IO () -testReceiveSetCookieExistingCreation = assertEqual "Creation time gets updated in existing cookie" - default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie]) - where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) - -testReceiveSetCookieExistingHttpOnly :: IO () -testReceiveSetCookieExistingHttpOnly = assertEqual "Existing http-only cookie gets dropped" - default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie]) - where existing_cookie = default_cookie {cookie_http_only = True} - -testMonoidPreferRecent :: IO () -testMonoidPreferRecent = assertEqual "Monoid prefers more recent cookies" - (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `Data.Monoid.mappend` createCookieJar [c2]) - where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)} - c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)} - cct cj = cookie_creation_time $ head $ destroyCookieJar cj - -ipParseTests :: Spec -ipParseTests = do - it "Valid IP" testValidIp - it "Digit Too High" testIpNumTooHigh - it "Too Many Segments" testTooManySegmentsInIp - it "Chars in IP" testCharsInIp - -domainMatchingTests :: Spec -domainMatchingTests = do - it "Should Match" testDomainMatchesSuccess - it "Same Domain" testSameDomain - it "Sibling Domain" testSiblingDomain - it "Parent Domain" testParentDomain - it "Checking for Naive suffix-check" testNaiveSuffixDomain - -defaultPathTests :: Spec -defaultPathTests = do - it "Basic default path test" testDefaultPath - it "Basic populated default path" testPopulatedDefaultPath - it "Default path from request with GET params works" testParamsDefaultPath - it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash - it "Getting a short default path" testShortDefaultPath - -pathMatchingTests :: Spec -pathMatchingTests = do - it "Same paths match" testSamePathsMatch - it "Putting slash at end" testPathSlashAtEnd - it "Not putting slash at end" testPathNoSlashAtEnd - it "Diverging paths don't match" testDivergingPaths - -equalityTests :: Spec -equalityTests = do - it "The same cookie should be equal to itself" testCookieEqualitySuccess - it "Changing extra options shouldn't change equality" testCookieEqualityResiliance - it "Changing a cookie's domain should change its equality" testDomainChangesEquality - -removeTests :: Spec -removeTests = do - it "Removing a cookie works" testRemoveCookie - it "Removing a nonexistent cookie doesn't work" testRemoveNonexistantCookie - it "Removing the correct cookie" testRemoveCorrectCookie - -evictionTests :: Spec -evictionTests = do - it "Testing eviction" testEvictExpiredCookies - it "Evicting from empty cookie jar" testEvictNoCookies - -sendingTests :: Spec -sendingTests = do - it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime - it "Host-only flag matches exact host" testComputeCookieStringHostOnly - it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter - it "Domain matching works properly" testComputeCookieStringDomainMatching - it "Path matching works" testComputeCookieStringPathMatching - it "Path matching fails when it should" testComputeCookieStringPathMatchingFails - it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms - it "Secure flag filters correctly" testComputeCookieStringSecure - it "Http-only flag filters correctly" testComputeCookieStringHttpOnly - it "Sorting works correctly" testComputeCookieStringSort - it "Inserting cookie header works" testInsertCookiesIntoRequestWorks - -receivingTests :: Spec -receivingTests = do - it "Can receive set-cookie" testReceiveSetCookie - it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot - it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot - it "Set-Cookie with no domain" testReceiveSetCookieNoDomain - it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain - it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain - it "Host-only flag gets set" testReceiveSetCookieHostOnly - it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet - it "Http-only flag gets set" testReceiveSetCookieHttpOnly - it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet - it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop - it "Name gets set correctly" testReceiveSetCookieName - it "Value gets set correctly" testReceiveSetCookieValue - it "Expiry gets set correctly" testReceiveSetCookieExpiry - it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry - it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge - it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge - it "Path gets set correctly when nonexistent" testReceiveSetCookieNoPath - it "Path gets set correctly" testReceiveSetCookiePath - it "Creation time gets set correctly" testReceiveSetCookieCreationTime - it "Last access time gets set correctly" testReceiveSetCookieAccessTime - it "Persistent flag gets set correctly" testReceiveSetCookiePersistent - it "Existing cookie gets updated" testReceiveSetCookieExisting - it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation - it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly - it "Secure flag gets set correctly" testReceiveSetCookieSecure - it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge - it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge - -monoidTests :: Spec -monoidTests = do - it "Monoid prefers more recent cookies" testMonoidPreferRecent - -cookieTest :: Spec -cookieTest = do - describe "ipParseTests" ipParseTests - describe "domainMatchingTests" domainMatchingTests - describe "defaultPathTests" defaultPathTests - describe "pathMatchingTests" pathMatchingTests - describe "equalityTests" equalityTests - describe "removeTests" removeTests - describe "evictionTests" evictionTests - describe "sendingTests" sendingTests - describe "receivingTests" receivingTests - describe "monoidTest" monoidTests +{-# OPTIONS_GHC -Wno-orphans #-} + +module CookieTest (cookieTest) where + +import Prelude hiding (exp) +import Test.Hspec +import qualified Data.ByteString as BS +import Test.HUnit hiding (path) +import Network.HTTP.Client +import qualified Network.HTTP.Conduit as HC +import Data.ByteString.UTF8 +import Data.Monoid +import Data.Time.Clock +import Data.Time.Calendar +import qualified Data.CaseInsensitive as CI +import Web.Cookie + +-- We use these Eq instances here because they make sense and may be added to the library in +-- the future. We do not add them now because they would silently break the old Eq behavior, +-- which was `equivCookie`. +instance Eq Cookie where + (==) = equalCookie + +instance Eq CookieJar where + (==) = equalCookieJar + +instance Eq body => Eq (Response body) where + resp == resp' = and + [ responseStatus resp == responseStatus resp' + , responseVersion resp == responseVersion resp' + , responseHeaders resp == responseHeaders resp' + , responseBody resp == responseBody resp' + , responseCookieJar resp `equivCookieJar` responseCookieJar resp' -- ! + -- , responseClose -- ! + ] + +default_request :: HC.Request +default_request = HC.parseRequest_ "http://www.google.com/" + +default_cookie :: Cookie +default_cookie = Cookie { cookie_name = fromString "name" + , cookie_value = fromString "value" + , cookie_expiry_time = default_time + , cookie_domain = fromString "www.google.com" + , cookie_path = fromString "/" + , cookie_creation_time = default_time + , cookie_last_access_time = default_time + , cookie_persistent = False + , cookie_host_only = False + , cookie_secure_only = False + , cookie_http_only = False + } + +default_time :: UTCTime +default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) + +default_diff_time :: DiffTime +default_diff_time = secondsToDiffTime 1209600 + +default_set_cookie :: SetCookie +default_set_cookie = def { setCookieName = fromString "name" + , setCookieValue = fromString "value" + , setCookiePath = Just $ fromString "/" + , setCookieExpires = Just default_time + , setCookieMaxAge = Just default_diff_time + , setCookieDomain = Just $ fromString "www.google.com" + , setCookieHttpOnly = False + , setCookieSecure = False + } + +testValidIp :: IO () +testValidIp = assertBool "Couldn't parse valid IP address" $ + isIpAddress $ fromString "1.2.3.4" + +testIpNumTooHigh :: IO () +testIpNumTooHigh = assertBool "One of the digits in the IP address is too large" $ + not $ isIpAddress $ fromString "501.2.3.4" + +testTooManySegmentsInIp :: IO () +testTooManySegmentsInIp = assertBool "Too many segments in the ip address" $ + not $ isIpAddress $ fromString "1.2.3.4.5" + +testCharsInIp :: IO () +testCharsInIp = assertBool "Chars are not allowed in IP addresses" $ + not $ isIpAddress $ fromString "1.2a3.4.5" + +testDomainMatchesSuccess :: IO () +testDomainMatchesSuccess = assertBool "Domains should match" $ + domainMatches (fromString "www.google.com") (fromString "google.com") + +testSameDomain :: IO () +testSameDomain = assertBool "Same domain should match" $ + domainMatches domain domain + where domain = fromString "www.google.com" + +testSiblingDomain :: IO () +testSiblingDomain = assertBool "Sibling domain should not match" $ + not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com") + +testParentDomain :: IO () +testParentDomain = assertBool "Parent domain should fail" $ + not $ domainMatches (fromString "google.com") (fromString "www.google.com") + +testNaiveSuffixDomain :: IO () +testNaiveSuffixDomain = assertBool "Naively checking for suffix for domain matching should fail" $ + not $ domainMatches (fromString "agoogle.com") (fromString "google.com") + +testDefaultPath :: IO () +testDefaultPath = assertEqual "Getting default path from a request" + (fromString "/") (defaultPath default_request) + +testShortDefaultPath :: IO () +testShortDefaultPath = assertEqual "Getting default path from a short path" + (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"}) + +testPopulatedDefaultPath :: IO () +testPopulatedDefaultPath = assertEqual "Getting default path from a request with a path" + (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"}) + +testParamsDefaultPath :: IO () +testParamsDefaultPath = assertEqual "Getting default path from a request with a path and GET params" + (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"}) + +testDefaultPathEndingInSlash :: IO () +testDefaultPathEndingInSlash = assertEqual "Getting default path that ends in a slash" + (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"}) + +testSamePathsMatch :: IO () +testSamePathsMatch = assertBool "The same path should match" $ + pathMatches path' path' + where path' = fromString "/a/path" + +testPathSlashAtEnd :: IO () +testPathSlashAtEnd = assertBool "Putting the slash at the end should still match paths" $ + pathMatches (fromString "/a/path/to/here") (fromString "/a/path/") + +testPathNoSlashAtEnd :: IO () +testPathNoSlashAtEnd = assertBool "Not putting the slash at the end should still match paths" $ + pathMatches (fromString "/a/path/to/here") (fromString "/a/path") + +testDivergingPaths :: IO () +testDivergingPaths = assertBool "Diverging paths don't match" $ + not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path") + +testCookieEqualitySuccess :: IO () +testCookieEqualitySuccess = assertEqual "The same cookies should be equal" + cookie cookie + where cookie = default_cookie + +testCookieEqualityResiliance :: IO () +testCookieEqualityResiliance = assertBool "Cookies should still be equal if extra options are changed" $ + (default_cookie {cookie_persistent = True}) `equivCookie` (default_cookie {cookie_host_only = True}) + +testDomainChangesEquality :: IO () +testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $ + default_cookie /= (default_cookie {cookie_domain = fromString "/search"}) + +testRemoveCookie :: IO () +testRemoveCookie = assertEqual "Removing a cookie works" + (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) + +testRemoveNonexistantCookie :: IO () +testRemoveNonexistantCookie = assertEqual "Removing a nonexistent cookie doesn't work" + (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie]) + +testRemoveCorrectCookie :: IO () +testRemoveCorrectCookie = assertEqual "Removing only the correct cookie" + (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for]) + where search_for = default_cookie {cookie_name = fromString "name1"} + red_herring = default_cookie {cookie_name = fromString "name2"} + +testEvictExpiredCookies :: IO () +testEvictExpiredCookies = assertEqual "Evicting expired cookies works" + (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle) + where a = default_cookie { cookie_name = fromString "a" + , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) + } + b = default_cookie { cookie_name = fromString "b" + , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) + } + c = default_cookie { cookie_name = fromString "c" + , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) + } + d = default_cookie { cookie_name = fromString "d" + , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) + } + middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) + +testEvictNoCookies :: IO () +testEvictNoCookies = assertEqual "Evicting empty cookie jar" + (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle) + where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) + +testComputeCookieStringUpdateLastAccessTime :: IO () +testComputeCookieStringUpdateLastAccessTime = assertEqual "Updates last access time upon using cookies" + (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True) + where request = default_request + cookie_jar = createCookieJar [default_cookie] + now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}] + +testComputeCookieStringHostOnly :: IO () +testComputeCookieStringHostOnly = assertEqual "Host only cookies should match host exactly" + (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request + cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}] + +testComputeCookieStringHostOnlyFilter :: IO () +testComputeCookieStringHostOnlyFilter = assertEqual "Host only cookies shouldn't match subdomain" + (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.host = fromString "sub1.sub2.google.com"} + cookie_jar = createCookieJar [default_cookie { cookie_host_only = True + , cookie_domain = fromString "sub2.google.com" + } + ] + +testComputeCookieStringDomainMatching :: IO () +testComputeCookieStringDomainMatching = assertEqual "Domain matching works for new requests" + (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.host = fromString "sub1.sub2.google.com"} + cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}] + +testComputeCookieStringPathMatching :: IO () +testComputeCookieStringPathMatching = assertEqual "Path matching works for new requests" + (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.path = fromString "/a/path/to/nowhere"} + cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] + +testComputeCookieStringPathMatchingFails :: IO () +testComputeCookieStringPathMatchingFails = assertEqual "Path matching fails when it should" + (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"} + cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] + +testComputeCookieStringPathMatchingWithParms :: IO () +testComputeCookieStringPathMatchingWithParms = assertEqual "Path matching succeeds when request has GET params" + (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"} + cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] + +testComputeCookieStringSecure :: IO () +testComputeCookieStringSecure = assertEqual "Secure flag filters properly" + (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True) + where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}] + +testComputeCookieStringHttpOnly :: IO () +testComputeCookieStringHttpOnly = assertEqual "http-only flag filters properly" + (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False) + where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}] + +testComputeCookieStringSort :: IO () +testComputeCookieStringSort = do + assertEqual "Sorting works correctly (computed string)" (fst format_output) (fromString "c1=v1;c3=v3;c4=v4;c2=v2") + assertBool "Sorting works correctly (remaining jar)" $ (snd format_output) `equivCookieJar` cookie_jar_out + where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) + cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" + , cookie_value = fromString "v1" + , cookie_path = fromString "/all/encompassing/request" + } + , default_cookie { cookie_name = fromString "c2" + , cookie_value = fromString "v2" + , cookie_path = fromString "/all" + } + , default_cookie { cookie_name = fromString "c3" + , cookie_value = fromString "v3" + , cookie_path = fromString "/all/encompassing" + , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + } + , default_cookie { cookie_name = fromString "c4" + , cookie_value = fromString "v4" + , cookie_path = fromString "/all/encompassing" + , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) + } + ] + cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1" + , cookie_value = fromString "v1" + , cookie_path = fromString "/all/encompassing/request" + , cookie_last_access_time = now + } + , default_cookie { cookie_name = fromString "c2" + , cookie_value = fromString "v2" + , cookie_path = fromString "/all" + , cookie_last_access_time = now + } + , default_cookie { cookie_name = fromString "c3" + , cookie_value = fromString "v3" + , cookie_path = fromString "/all/encompassing" + , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + , cookie_last_access_time = now + } + , default_cookie { cookie_name = fromString "c4" + , cookie_value = fromString "v4" + , cookie_path = fromString "/all/encompassing" + , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) + , cookie_last_access_time = now + } + ] + request = default_request {HC.path = fromString "/all/encompassing/request/path"} + format_output = computeCookieString request cookie_jar default_time False + +testInsertCookiesIntoRequestWorks :: IO () +testInsertCookiesIntoRequestWorks = assertEqual "Inserting cookies works" + [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers + where out_headers = HC.requestHeaders req + (req, _) = insertCookiesIntoRequest req' cookie_jar default_time + cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key" + , cookie_value = fromString "val" + } + ] + req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie", + fromString "otherkey=otherval")]} + +testReceiveSetCookie :: IO () +testReceiveSetCookie = assertBool "Receiving a Set-Cookie" $ + (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) + +testReceiveSetCookieTrailingDot :: IO () +testReceiveSetCookieTrailingDot = assertEqual "Receiving a Set-Cookie with a trailing domain dot" + (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."} + +testReceiveSetCookieLeadingDot :: IO () +testReceiveSetCookieLeadingDot = assertBool "Receiving a Set-Cookie with a leading domain dot" $ + (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} + +testReceiveSetCookieNoDomain :: IO () +testReceiveSetCookieNoDomain = assertBool "Receiving cookie without domain" $ + (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Nothing} + +testReceiveSetCookieEmptyDomain :: IO () +testReceiveSetCookieEmptyDomain = assertBool "Receiving cookie with empty domain" $ + (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty} + +-- Can't test public suffixes until that module is written + +testReceiveSetCookieNonMatchingDomain :: IO () +testReceiveSetCookieNonMatchingDomain = assertEqual "Receiving cookie with non-matching domain" + (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"} + +testReceiveSetCookieHostOnly :: IO () +testReceiveSetCookieHostOnly = assertBool "Checking host-only flag gets set" $ + cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieDomain = Nothing} + +testReceiveSetCookieHostOnlyNotSet :: IO () +testReceiveSetCookieHostOnlyNotSet = assertBool "Checking host-only flag doesn't get set" $ + not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"} + +testReceiveSetCookieHttpOnly :: IO () +testReceiveSetCookieHttpOnly = assertBool "Checking http-only flag gets set" $ + cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieHttpOnly = True} + +testReceiveSetCookieHttpOnlyNotSet :: IO () +testReceiveSetCookieHttpOnlyNotSet = assertBool "Checking http-only flag doesn't get set" $ + not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieHttpOnly = False} + +testReceiveSetCookieHttpOnlyDrop :: IO () +testReceiveSetCookieHttpOnlyDrop = assertEqual "Checking non http request gets dropped" + (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieHttpOnly = True} + +testReceiveSetCookieName :: IO () +testReceiveSetCookieName = assertEqual "Name gets set correctly" + (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) + +testReceiveSetCookieValue :: IO () +testReceiveSetCookieValue = assertEqual "Value gets set correctly" + (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) + +testReceiveSetCookieExpiry :: IO () +testReceiveSetCookieExpiry = assertEqual "Expiry gets set correctly" + now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) + where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) + +testReceiveSetCookieNoMaxAge :: IO () +testReceiveSetCookieNoMaxAge = assertEqual "Expiry is based on the given value" + default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar []) + where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing} + +testReceiveSetCookieNoExpiry :: IO () +testReceiveSetCookieNoExpiry = assertEqual "Expiry is based on max age" + now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar []) + where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) + cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing} + +testReceiveSetCookieNoExpiryNoMaxAge :: IO () +testReceiveSetCookieNoExpiryNoMaxAge = assertBool "Expiry is set to a future date" $ + default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar []) + where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing } + +testReceiveSetCookiePath :: IO () +testReceiveSetCookiePath = assertEqual "Path gets set correctly" + (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"} + +testReceiveSetCookieNoPath :: IO () +testReceiveSetCookieNoPath = assertEqual "Path gets set correctly when nonexistent" + (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookiePath = Nothing} + request = default_request {HC.path = fromString "/a/path/to/nowhere"} + +testReceiveSetCookieCreationTime :: IO () +testReceiveSetCookieCreationTime = assertEqual "Creation time gets set correctly" + now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) + where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + +testReceiveSetCookieAccessTime :: IO () +testReceiveSetCookieAccessTime = assertEqual "Last access time gets set correctly" + now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) + where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + +testReceiveSetCookiePersistent :: IO () +testReceiveSetCookiePersistent = assertBool "Persistent flag gets set correctly" $ + cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieExpires = Just default_time} + +testReceiveSetCookieSecure :: IO () +testReceiveSetCookieSecure = assertBool "Secure flag gets set correctly" $ + cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieSecure = True} + +testReceiveSetCookieMaxAge :: IO () +testReceiveSetCookieMaxAge = assertEqual "Max-Age gets set correctly" + total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) + where set_cookie = default_set_cookie { setCookieExpires = Nothing + , setCookieMaxAge = Just $ secondsToDiffTime 10 + } + now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) + total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) + +testReceiveSetCookiePreferMaxAge :: IO () +testReceiveSetCookiePreferMaxAge = assertEqual "Max-Age is preferred over Expires" + total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) + where set_cookie = default_set_cookie { setCookieExpires = Just exp + , setCookieMaxAge = Just $ secondsToDiffTime 10 + } + exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5) + now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) + total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) + +testReceiveSetCookieExisting :: IO () +testReceiveSetCookieExisting = assertEqual "Existing cookie gets updated" + t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie]) + where set_cookie = default_set_cookie { setCookieExpires = Just t + , setCookieMaxAge = Nothing + } + t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) + +testReceiveSetCookieExistingCreation :: IO () +testReceiveSetCookieExistingCreation = assertEqual "Creation time gets updated in existing cookie" + default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie]) + where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) + +testReceiveSetCookieExistingHttpOnly :: IO () +testReceiveSetCookieExistingHttpOnly = assertEqual "Existing http-only cookie gets dropped" + default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie]) + where existing_cookie = default_cookie {cookie_http_only = True} + +testMonoidPreferRecent :: IO () +testMonoidPreferRecent = assertEqual "Monoid prefers more recent cookies" + (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `Data.Monoid.mappend` createCookieJar [c2]) + where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)} + c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)} + cct cj = cookie_creation_time $ head $ destroyCookieJar cj + +ipParseTests :: Spec +ipParseTests = do + it "Valid IP" testValidIp + it "Digit Too High" testIpNumTooHigh + it "Too Many Segments" testTooManySegmentsInIp + it "Chars in IP" testCharsInIp + +domainMatchingTests :: Spec +domainMatchingTests = do + it "Should Match" testDomainMatchesSuccess + it "Same Domain" testSameDomain + it "Sibling Domain" testSiblingDomain + it "Parent Domain" testParentDomain + it "Checking for Naive suffix-check" testNaiveSuffixDomain + +defaultPathTests :: Spec +defaultPathTests = do + it "Basic default path test" testDefaultPath + it "Basic populated default path" testPopulatedDefaultPath + it "Default path from request with GET params works" testParamsDefaultPath + it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash + it "Getting a short default path" testShortDefaultPath + +pathMatchingTests :: Spec +pathMatchingTests = do + it "Same paths match" testSamePathsMatch + it "Putting slash at end" testPathSlashAtEnd + it "Not putting slash at end" testPathNoSlashAtEnd + it "Diverging paths don't match" testDivergingPaths + +equalityTests :: Spec +equalityTests = do + it "The same cookie should be equal to itself" testCookieEqualitySuccess + it "Changing extra options shouldn't change equality" testCookieEqualityResiliance + it "Changing a cookie's domain should change its equality" testDomainChangesEquality + +removeTests :: Spec +removeTests = do + it "Removing a cookie works" testRemoveCookie + it "Removing a nonexistent cookie doesn't work" testRemoveNonexistantCookie + it "Removing the correct cookie" testRemoveCorrectCookie + +evictionTests :: Spec +evictionTests = do + it "Testing eviction" testEvictExpiredCookies + it "Evicting from empty cookie jar" testEvictNoCookies + +sendingTests :: Spec +sendingTests = do + it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime + it "Host-only flag matches exact host" testComputeCookieStringHostOnly + it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter + it "Domain matching works properly" testComputeCookieStringDomainMatching + it "Path matching works" testComputeCookieStringPathMatching + it "Path matching fails when it should" testComputeCookieStringPathMatchingFails + it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms + it "Secure flag filters correctly" testComputeCookieStringSecure + it "Http-only flag filters correctly" testComputeCookieStringHttpOnly + it "Sorting works correctly" testComputeCookieStringSort + it "Inserting cookie header works" testInsertCookiesIntoRequestWorks + +receivingTests :: Spec +receivingTests = do + it "Can receive set-cookie" testReceiveSetCookie + it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot + it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot + it "Set-Cookie with no domain" testReceiveSetCookieNoDomain + it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain + it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain + it "Host-only flag gets set" testReceiveSetCookieHostOnly + it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet + it "Http-only flag gets set" testReceiveSetCookieHttpOnly + it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet + it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop + it "Name gets set correctly" testReceiveSetCookieName + it "Value gets set correctly" testReceiveSetCookieValue + it "Expiry gets set correctly" testReceiveSetCookieExpiry + it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry + it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge + it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge + it "Path gets set correctly when nonexistent" testReceiveSetCookieNoPath + it "Path gets set correctly" testReceiveSetCookiePath + it "Creation time gets set correctly" testReceiveSetCookieCreationTime + it "Last access time gets set correctly" testReceiveSetCookieAccessTime + it "Persistent flag gets set correctly" testReceiveSetCookiePersistent + it "Existing cookie gets updated" testReceiveSetCookieExisting + it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation + it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly + it "Secure flag gets set correctly" testReceiveSetCookieSecure + it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge + it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge + +monoidTests :: Spec +monoidTests = do + it "Monoid prefers more recent cookies" testMonoidPreferRecent + +cookieTest :: Spec +cookieTest = do + describe "ipParseTests" ipParseTests + describe "domainMatchingTests" domainMatchingTests + describe "defaultPathTests" defaultPathTests + describe "pathMatchingTests" pathMatchingTests + describe "equalityTests" equalityTests + describe "removeTests" removeTests + describe "evictionTests" evictionTests + describe "sendingTests" sendingTests + describe "receivingTests" receivingTests + describe "monoidTest" monoidTests diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,625 +1,631 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -import Test.Hspec -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Test.HUnit -import Network.Wai hiding (requestBody) -import Network.Wai.Conduit (responseSource, sourceRequestBody) -import Network.HTTP.Client (streamFile) -import System.IO.Temp (withSystemTempFile) -import qualified Network.Wai as Wai -import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort, setBeforeMainLoop, Settings, setTimeout) -import Network.HTTP.Conduit hiding (port) -import qualified Network.HTTP.Conduit as NHC -import Network.HTTP.Client.MultipartFormData -import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay) -import Network.HTTP.Types -import UnliftIO.Exception (try, SomeException, bracket, onException, IOException) -import qualified Data.IORef as I -import qualified Control.Exception as E (catch) -import qualified Network.Socket as NS -import CookieTest (cookieTest) -#if MIN_VERSION_conduit(1,1,0) -import Data.Conduit.Network (runTCPServer, serverSettings, appSink, appSource, ServerSettings) -import Data.Streaming.Network (bindPortTCP, setAfterBind) -#define bindPort bindPortTCP -#else -import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings) -#endif -import qualified Data.Conduit.Network -import System.IO.Unsafe (unsafePerformIO) -import Data.Conduit ((.|), yield, Flush (Chunk, Flush), await, runConduit) -import Control.Monad (void, forever) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString.UTF8 (fromString) -import Data.Conduit.List (sourceList) -import Data.CaseInsensitive (mk) -import Data.List (partition) -import qualified Data.Conduit.List as CL -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder (fromByteString) -import System.IO -import Data.Time.Clock -import Data.Time.Calendar -import qualified Network.Wai.Handler.WarpTLS as WT -import Network.Connection (settingDisableCertificateValidation) -import Data.Default.Class (def) -import qualified Data.Aeson as A -import qualified Network.HTTP.Simple as Simple -import Data.Monoid (mempty) -import Control.Monad.Trans.Resource (runResourceT) - -past :: UTCTime -past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) - -future :: UTCTime -future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0) - -cookie :: Cookie -cookie = Cookie { cookie_name = "key" - , cookie_value = "value" - , cookie_expiry_time = future - , cookie_domain = "127.0.0.1" - , cookie_path = "/dump_cookies" - , cookie_creation_time = past - , cookie_last_access_time = past - , cookie_persistent = False - , cookie_host_only = False - , cookie_secure_only = False - , cookie_http_only = False - } - -cookie_jar :: CookieJar -cookie_jar = createCookieJar [cookie] - -app :: Wai.Request -> IO Wai.Response -app req = - case pathInfo req of - [] -> - if maybe False ("example.com:" `S.isPrefixOf`) $ lookup "host" $ Wai.requestHeaders req - then return $ responseLBS status200 [] "homepage for example.com" - else return $ responseLBS status200 [] "homepage" - ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies" - ["cookie_redir1"] -> return $ responseLBS status303 [tastyCookie, (hLocation, "/checkcookie")] "" - ["checkcookie"] -> return $ case lookup hCookie $ Wai.requestHeaders req of - Just "flavor=chocolate-chip" -> responseLBS status200 [] "nom-nom-nom" - _ -> responseLBS status412 [] "Baaaw where's my chocolate?" - ["infredir", i'] -> - let i = read $ T.unpack i' :: Int - in return $ responseLBS status303 - [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)] - (L8.pack $ show i) - ["dump_cookies"] -> return $ responseLBS status200 [] $ L.fromChunks $ return $ maybe "" id $ lookup hCookie $ Wai.requestHeaders req - ["delayed"] -> return $ responseSource status200 [("foo", "bar")] $ do - yield Flush - liftIO $ threadDelay 30000000 - yield $ Chunk $ fromByteString "Hello World!" - _ -> return $ responseLBS status404 [] "not found" - - where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") - -nextPort :: I.IORef Int -nextPort = unsafePerformIO $ I.newIORef 15452 -{-# NOINLINE nextPort #-} - -getPort :: IO Int -getPort = do - port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p + 1) - esocket <- try $ bindPort port "*4" - case esocket of - Left (_ :: IOException) -> getPort - Right socket -> do - NS.close socket - return port - -withApp :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () -withApp app' f = withApp' (const app') f - -withApp' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () -withApp' = withAppSettings id - -withAppSettings :: (Settings -> Settings) - -> (Int -> Wai.Request -> IO Wai.Response) - -> (Int -> IO ()) - -> IO () -withAppSettings modSettings app' f = do - port <- getPort - baton <- newEmptyMVar - bracket - (forkIO $ runSettings (modSettings $ - setPort port - $ setBeforeMainLoop (putMVar baton ()) - defaultSettings) (app'' port) `onException` putMVar baton ()) - killThread - (const $ takeMVar baton >> f port) - where - app'' port req sendResponse = do - res <- app' port req - sendResponse res - -withAppTls :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () -withAppTls app' f = withAppTls' (const app') f - -withAppTls' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () -withAppTls' app' f = do - port <- getPort - baton <- newEmptyMVar - bracket - (forkIO $ WT.runTLS WT.defaultTlsSettings ( - setPort port - $ setBeforeMainLoop (putMVar baton ()) - defaultSettings) - (app'' port) `onException` putMVar baton ()) - killThread - (const $ takeMVar baton >> f port) - where - app'' port req sendResponse = do - res <- app' port req - sendResponse res - -main :: IO () -main = do - mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] - hspec $ do - cookieTest - describe "simpleHttp" $ do - it "gets homepage" $ withApp app $ \port -> do - lbs <- simpleHttp $ "http://127.0.0.1:" ++ show port - lbs @?= "homepage" - it "throws exception on 404" $ withApp app $ \port -> do - elbs <- try $ simpleHttp $ concat ["http://127.0.0.1:", show port, "/404"] - case elbs of - Left (HttpExceptionRequest _ StatusCodeException {}) -> return () - _ -> error "Expected an exception" - describe "httpLbs" $ do - it "preserves 'set-cookie' headers" $ withApp app $ \port -> do - request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] - manager <- newManager tlsManagerSettings - response <- httpLbs request manager - let setCookie = mk (fromString "Set-Cookie") - (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.responseHeaders response) - assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 - it "redirects set cookies" $ withApp app $ \port -> do - request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"] - manager <- newManager tlsManagerSettings - response <- httpLbs request manager - (responseBody response) @?= "nom-nom-nom" - it "user-defined cookie jar works" $ withApp app $ \port -> do - request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] - manager <- newManager tlsManagerSettings - response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager - (responseBody response) @?= "key=value" - it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do - request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] - manager <- newManager tlsManagerSettings - response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager - (responseBody response) @?= "key=value" - it "cookie jar is available in response" $ withApp app $ \port -> do - request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] - manager <- newManager tlsManagerSettings - response <- httpLbs (request {cookieJar = Just Data.Monoid.mempty}) manager - (length $ destroyCookieJar $ responseCookieJar response) @?= 1 - it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do - request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] - manager <- newManager tlsManagerSettings - let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request) - response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager - (responseBody response) @?= "key2=value2" - it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do - request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] - manager <- newManager tlsManagerSettings - response <- httpLbs (request {cookieJar = Nothing}) manager - (responseCookieJar response) @?= mempty - it "TLS" $ withAppTls app $ \port -> do - request <- parseUrlThrow $ "https://127.0.0.1:" ++ show port - let set = mkManagerSettings - def - { settingDisableCertificateValidation = True - } - Nothing - manager <- newManager set - response <- httpLbs request manager - responseBody response @?= "homepage" - describe "manager" $ do - it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do - --FIXME clearSocketsList - manager <- newManager tlsManagerSettings - let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port1 - let Just req2 = parseUrlThrow $ "http://127.0.0.1:" ++ show port2 - runResourceT $ do - _res1a <- http req1 manager - _res1b <- http req1 manager - _res2 <- http req2 manager - return () - --FIXME requireAllSocketsClosed - describe "http" $ do - it "response body" $ withApp app $ \port -> do - manager <- newManager tlsManagerSettings - req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - runResourceT $ do - res1 <- http req manager - bss <- runConduit $ responseBody res1 .| CL.consume - res2 <- httpLbs req manager - liftIO $ L.fromChunks bss `shouldBe` responseBody res2 - describe "DOS protection" $ do - it "overlong headers" $ overLongHeaders $ \port -> do - manager <- newManager tlsManagerSettings - let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port - res1 <- try $ runResourceT $ http req1 manager - case res1 of - Left e -> show (e :: SomeException) @?= show (HttpExceptionRequest req1 OverlongHeaders) - _ -> error "Shouldn't have worked" - it "not overlong headers" $ notOverLongHeaders $ \port -> do - manager <- newManager tlsManagerSettings - let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port - _ <- httpLbs req1 manager - return () - describe "redirects" $ do - it "doesn't double escape" $ redir $ \port -> do - manager <- newManager tlsManagerSettings - let go (encoded, final) = do - let Just req1 = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/redir/", encoded] - res <- httpLbs req1 manager - liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 - liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final] - mapM_ go - [ ("hello world%2F", "hello world/") - , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום") - , ("simple", "simple") - , ("hello%20world", "hello world") - , ("hello%20world%3f%23", "hello world?#") - ] - it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do - let Just req = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/infredir/0"] - let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i) - manager <- newManager tlsManagerSettings - E.catch (void $ runResourceT $ http req{redirectCount=5} manager) - $ \e -> - case e of - HttpExceptionRequest _ (TooManyRedirects redirs) -> - mapM_ go (zip redirs [5,4..0 :: Int]) - _ -> error $ show e - describe "chunked request body" $ do - it "works" $ echo $ \port -> do - manager <- newManager tlsManagerSettings - let go bss = do - let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port - src = sourceList bss - lbs = L.fromChunks bss - res <- httpLbs req1 - { requestBody = requestBodySourceChunked src - } manager - liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 - let ts = S.concat . L.toChunks - liftIO $ ts (responseBody res) @?= ts lbs - mapM_ go - [ ["hello", "world"] - , replicate 500 "foo\003\n\r" - ] - describe "no status message" $ do - it "works" $ noStatusMessage $ \port -> do - req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - manager <- newManager tlsManagerSettings - res <- httpLbs req manager - liftIO $ do - Network.HTTP.Conduit.responseStatus res `shouldBe` status200 - responseBody res `shouldBe` "foo" - - describe "response body too short" $ do - it "throws an exception" $ wrongLength $ \port -> do - req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - manager <- newManager tlsManagerSettings - eres <- try $ httpLbs req manager - liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres - `shouldBe` Left (show $ HttpExceptionRequest req $ ResponseBodyTooShort 50 18) - - describe "chunked response body" $ do - it "no chunk terminator" $ wrongLengthChunk1 $ \port -> do - req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - manager <- newManager tlsManagerSettings - eres <- try $ httpLbs req manager - liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres - `shouldBe` Left (show (HttpExceptionRequest req IncompleteHeaders)) - it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do - req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - manager <- newManager tlsManagerSettings - eres <- try $ httpLbs req manager - liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres - `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) - it "invalid chunk" $ invalidChunk $ \port -> do - req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - manager <- newManager tlsManagerSettings - eres <- try $ httpLbs req manager - liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres - `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) - - it "missing header" $ rawApp - "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\n\r\n\r\n" - $ \port -> do - req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - manager <- newManager tlsManagerSettings - eres <- try $ httpLbs req manager - liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres - `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) - - it "junk header" $ rawApp - "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\njunk\r\n\r\n" - $ \port -> do - req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port - manager <- newManager tlsManagerSettings - eres <- try $ httpLbs req manager - liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres - `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) - - describe "redirect" $ do - it "ignores large response bodies" $ do - let app' port req = - case pathInfo req of - ["foo"] -> return $ responseLBS status200 [] "Hello World!" - _ -> return $ responseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" - manager <- newManager tlsManagerSettings - withApp' app' $ \port -> do - req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port - res <- httpLbs req manager - liftIO $ do - Network.HTTP.Conduit.responseStatus res `shouldBe` status200 - responseBody res `shouldBe` "Hello World!" - describe "multipart/form-data" $ do - it "formats correctly" $ do - let bd = "---------------------------190723902820679116301912680260" - (RequestBodyStream _ givesPopper) <- renderParts bd - [partBS "email" "" - ,partBS "parent_id" "70488" - ,partBS "captcha" "" - ,partBS "homeboard" "0chan.hk" - ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим." - ,partFileSource "upload" "nyan.gif" - ] - ires <- I.newIORef S.empty - let loop front popper = do - bs <- popper - if S.null bs - then I.writeIORef ires $ S.concat $ front [] - else loop (front . (bs:)) popper - givesPopper $ loop id - mfd <- I.readIORef ires - exam <- S.readFile "multipart-example.bin" - mfd @?= exam - - describe "HTTP/1.0" $ do - it "BaseHTTP" $ do - let baseHTTP app' = do - _ <- runConduit $ appSource app' .| await - runConduit $ yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" .| appSink app' - manager <- newManager tlsManagerSettings - withCApp baseHTTP $ \port -> do - req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port - res1 <- httpLbs req manager - res2 <- httpLbs req manager - liftIO $ res1 @?= res2 - - describe "hostAddress" $ do - it "overrides host" $ withApp app $ \port -> do - req' <- parseUrlThrow $ "http://example.com:" ++ show port - let req = req' { hostAddress = Just 0x0100007f } -- 127.0.0.1 - manager <- newManager tlsManagerSettings - res <- httpLbs req manager - responseBody res @?= "homepage for example.com" - - describe "managerResponseTimeout" $ do - it "works" $ withApp app $ \port -> do - req1 <- parseUrlThrow $ "http://localhost:" ++ show port - let req2 = req1 { responseTimeout = responseTimeoutMicro 5000000 } - man <- newManager tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro 1 } - eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man - case eres1 of - Left (HttpExceptionRequest _ ConnectionTimeout{}) -> return () - _ -> error "Did not time out" - _ <- httpLbs req2 man - return () - - describe "delayed body" $ do - it "works" $ withApp app $ \port -> do - req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/delayed" - man <- newManager tlsManagerSettings - _ <- runResourceT $ http req man - return () - - it "reuse/connection close tries again" $ do - withAppSettings (setTimeout 1) (const app) $ \port -> do - req <- parseUrlThrow $ "http://localhost:" ++ show port - man <- newManager tlsManagerSettings - res1 <- httpLbs req man - threadDelay 3000000 - res2 <- httpLbs req man - let f res = res - { NHC.responseHeaders = filter (not . isDate) (NHC.responseHeaders res) - } - isDate ("date", _) = True - isDate _ = False - f res2 `shouldBe` f res1 - - it "setQueryString" $ do - ref <- I.newIORef undefined - let app' req = do - I.writeIORef ref $ Wai.queryString req - return $ responseLBS status200 [] "" - withApp app' $ \port -> do - let qs = - [ ("foo", Just "bar") - , (TE.encodeUtf8 "שלום", Just "hola") - , ("noval", Nothing) - ] - man <- newManager tlsManagerSettings - req <- parseUrlThrow $ "http://localhost:" ++ show port - _ <- httpLbs (setQueryString qs req) man - res <- I.readIORef ref - res `shouldBe` qs - - describe "Simple.JSON" $ do - it "normal" $ jsonApp $ \port -> do - req <- parseUrlThrow $ "http://localhost:" ++ show port - value <- Simple.httpJSON req - responseBody value `shouldBe` jsonValue - it "trailing whitespace" $ jsonApp $ \port -> do - req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/trailing" - value <- Simple.httpJSON req - responseBody value `shouldBe` jsonValue - - it "RequestBodyIO" $ echo $ \port -> do - manager <- newManager tlsManagerSettings - let go bss = withSystemTempFile "request-body-io" $ \tmpfp tmph -> do - liftIO $ do - mapM_ (S.hPutStr tmph) bss - hClose tmph - - let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port - lbs = L.fromChunks bss - res <- httpLbs req1 - { requestBody = RequestBodyIO (streamFile tmpfp) - } manager - liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 - let ts = S.concat . L.toChunks - liftIO $ ts (responseBody res) @?= ts lbs - mapM_ go - [ ["hello", "world"] - , replicate 500 "foo\003\n\r" - ] - -withCApp :: (Data.Conduit.Network.AppData -> IO ()) -> (Int -> IO ()) -> IO () -withCApp app' f = do - port <- getPort - baton <- newEmptyMVar - let start = putMVar baton () -#if MIN_VERSION_conduit(1,1,0) - settings :: ServerSettings - settings = setAfterBind (const start) (serverSettings port "*") -#else - settings :: ServerSettings IO - settings = (serverSettings port "*" :: ServerSettings IO) { serverAfterBind = const start } -#endif - bracket - (forkIO $ runTCPServer settings app' `onException` start) - killThread - (const $ takeMVar baton >> f port) - -overLongHeaders :: (Int -> IO ()) -> IO () -overLongHeaders = - withCApp $ \app' -> runConduit $ src .| appSink app' - where - src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" - -notOverLongHeaders :: (Int -> IO ()) -> IO () -notOverLongHeaders = withCApp $ \app' -> do - runConduit $ appSource app' .| CL.drop 1 - runConduit $ src .| appSink app' - where - src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] - -redir :: (Int -> IO ()) -> IO () -redir = - withApp' redirApp - where - redirApp port req = - case pathInfo req of - ["redir", foo] -> return $ responseLBS status301 - [ ("Location", S8.pack (concat ["http://127.0.0.1:", show port, "/content/"]) `S.append` escape foo) - ] - "" - ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo] - _ -> return $ responseLBS status404 [] "" - escape = S8.concatMap (S8.pack . encodeUrlChar) . TE.encodeUtf8 - - encodeUrlChar :: Char -> String - encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] - encodeUrlChar c@'-' = [c] - encodeUrlChar c@'_' = [c] - encodeUrlChar c@'.' = [c] - encodeUrlChar c@'~' = [c] - encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] - -echo :: (Int -> IO ()) -> IO () -echo = withApp $ \req -> do - bss <- runConduit $ sourceRequestBody req .| CL.consume - return $ responseLBS status200 [] $ L.fromChunks bss - -noStatusMessage :: (Int -> IO ()) -> IO () -noStatusMessage = - withCApp $ \app' -> runConduit $ src .| appSink app' - where - src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin" - -wrongLength :: (Int -> IO ()) -> IO () -wrongLength = - withCApp $ \app' -> do - _ <- runConduit $ appSource app' .| await - runConduit $ src .| appSink app' - where - src = do - yield "HTTP/1.0 200 OK\r\nContent-Length: 50\r\n\r\n" - yield "Not quite 50 bytes" - -wrongLengthChunk1 :: (Int -> IO ()) -> IO () -wrongLengthChunk1 = - withCApp $ \app' -> do - _ <- runConduit $ appSource app' .| await - runConduit $ src .| appSink app' - where - src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n" - -wrongLengthChunk2 :: (Int -> IO ()) -> IO () -wrongLengthChunk2 = - withCApp $ \app' -> do - _ <- runConduit $ appSource app' .| await - runConduit $ src .| appSink app' - where - src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n5\r\npedia\r\nE\r\nin\r\n\r\nch\r\n" - -invalidChunk :: (Int -> IO ()) -> IO () -invalidChunk = - withCApp $ \app' -> do - _ <- runConduit $ appSource app' .| await - runConduit $ src .| appSink app' - where - src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\ngarbage\r\nef\r\n0\r\n\r\n" - -rawApp :: S8.ByteString -> (Int -> IO ()) -> IO () -rawApp bs = - withCApp $ \app' -> do - _ <- runConduit $ appSource app' .| await - runConduit $ src .| appSink app' - where - src = yield bs - -jsonApp :: (Int -> IO ()) -> IO () -jsonApp = withApp $ \req -> return $ responseLBS - status200 - [ ("Content-Type", "application/json") - ] $ - case pathInfo req of - [] -> A.encode jsonValue - ["trailing"] -> L.append (A.encode jsonValue) " \n\r\n\t " - x -> error $ "unsupported: " ++ show x - -jsonValue :: A.Value -jsonValue = A.object - [ "name" A..= ("Alice" :: String) - , "age" A..= (35 :: Int) - ] +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Test.Hspec +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Test.HUnit +import Network.Wai hiding (requestBody) +import Network.Wai.Conduit (responseSource, sourceRequestBody) +import Network.HTTP.Client (streamFile) +import System.IO.Temp (withSystemTempFile) +import qualified Network.Wai as Wai +import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort, setBeforeMainLoop, Settings, setTimeout) +import Network.HTTP.Conduit hiding (port) +import qualified Network.HTTP.Conduit as NHC +import Network.HTTP.Client.MultipartFormData +import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay) +import Network.HTTP.Types +import UnliftIO.Exception (try, SomeException, bracket, onException, IOException) +import qualified Data.IORef as I +import qualified Control.Exception as E (catch) +import qualified Network.Socket as NS +import CookieTest (cookieTest) +#if MIN_VERSION_conduit(1,1,0) +import Data.Conduit.Network (runTCPServer, serverSettings, appSink, appSource, ServerSettings) +import Data.Streaming.Network (bindPortTCP, setAfterBind) +#define bindPort bindPortTCP +#else +import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings) +#endif +import qualified Data.Conduit.Network +import System.IO.Unsafe (unsafePerformIO) +import Data.Conduit ((.|), yield, Flush (Chunk, Flush), await, runConduit) +import Control.Monad (void, forever) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString.UTF8 (fromString) +import Data.Conduit.List (sourceList) +import Data.CaseInsensitive (mk) +import Data.List (partition) +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder (fromByteString) +import System.IO +import Data.Time.Clock +import Data.Time.Calendar +import qualified Network.Wai.Handler.WarpTLS as WT +import Network.Connection (settingDisableCertificateValidation) +import Data.Default.Class (def) +#ifdef VERSION_aeson +import qualified Data.Aeson as A +#endif +import qualified Network.HTTP.Simple as Simple +import Data.Monoid (mempty) +import Control.Monad.Trans.Resource (runResourceT) + +past :: UTCTime +past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) + +future :: UTCTime +future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0) + +cookie :: Cookie +cookie = Cookie { cookie_name = "key" + , cookie_value = "value" + , cookie_expiry_time = future + , cookie_domain = "127.0.0.1" + , cookie_path = "/dump_cookies" + , cookie_creation_time = past + , cookie_last_access_time = past + , cookie_persistent = False + , cookie_host_only = False + , cookie_secure_only = False + , cookie_http_only = False + } + +cookie_jar :: CookieJar +cookie_jar = createCookieJar [cookie] + +app :: Wai.Request -> IO Wai.Response +app req = + case pathInfo req of + [] -> + if maybe False ("example.com:" `S.isPrefixOf`) $ lookup "host" $ Wai.requestHeaders req + then return $ responseLBS status200 [] "homepage for example.com" + else return $ responseLBS status200 [] "homepage" + ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies" + ["cookie_redir1"] -> return $ responseLBS status303 [tastyCookie, (hLocation, "/checkcookie")] "" + ["checkcookie"] -> return $ case lookup hCookie $ Wai.requestHeaders req of + Just "flavor=chocolate-chip" -> responseLBS status200 [] "nom-nom-nom" + _ -> responseLBS status412 [] "Baaaw where's my chocolate?" + ["infredir", i'] -> + let i = read $ T.unpack i' :: Int + in return $ responseLBS status303 + [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)] + (L8.pack $ show i) + ["dump_cookies"] -> return $ responseLBS status200 [] $ L.fromChunks $ return $ maybe "" id $ lookup hCookie $ Wai.requestHeaders req + ["delayed"] -> return $ responseSource status200 [("foo", "bar")] $ do + yield Flush + liftIO $ threadDelay 30000000 + yield $ Chunk $ fromByteString "Hello World!" + _ -> return $ responseLBS status404 [] "not found" + + where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") + +nextPort :: I.IORef Int +nextPort = unsafePerformIO $ I.newIORef 15452 +{-# NOINLINE nextPort #-} + +getPort :: IO Int +getPort = do + port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p + 1) + esocket <- try $ bindPort port "*4" + case esocket of + Left (_ :: IOException) -> getPort + Right socket -> do + NS.close socket + return port + +withApp :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () +withApp app' f = withApp' (const app') f + +withApp' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () +withApp' = withAppSettings id + +withAppSettings :: (Settings -> Settings) + -> (Int -> Wai.Request -> IO Wai.Response) + -> (Int -> IO ()) + -> IO () +withAppSettings modSettings app' f = do + port <- getPort + baton <- newEmptyMVar + bracket + (forkIO $ runSettings (modSettings $ + setPort port + $ setBeforeMainLoop (putMVar baton ()) + defaultSettings) (app'' port) `onException` putMVar baton ()) + killThread + (const $ takeMVar baton >> f port) + where + app'' port req sendResponse = do + res <- app' port req + sendResponse res + +withAppTls :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () +withAppTls app' f = withAppTls' (const app') f + +withAppTls' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () +withAppTls' app' f = do + port <- getPort + baton <- newEmptyMVar + bracket + (forkIO $ WT.runTLS WT.defaultTlsSettings ( + setPort port + $ setBeforeMainLoop (putMVar baton ()) + defaultSettings) + (app'' port) `onException` putMVar baton ()) + killThread + (const $ takeMVar baton >> f port) + where + app'' port req sendResponse = do + res <- app' port req + sendResponse res + +main :: IO () +main = do + mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] + hspec $ do + cookieTest + describe "simpleHttp" $ do + it "gets homepage" $ withApp app $ \port -> do + lbs <- simpleHttp $ "http://127.0.0.1:" ++ show port + lbs @?= "homepage" + it "throws exception on 404" $ withApp app $ \port -> do + elbs <- try $ simpleHttp $ concat ["http://127.0.0.1:", show port, "/404"] + case elbs of + Left (HttpExceptionRequest _ StatusCodeException {}) -> return () + _ -> error "Expected an exception" + describe "httpLbs" $ do + it "preserves 'set-cookie' headers" $ withApp app $ \port -> do + request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] + manager <- newManager tlsManagerSettings + response <- httpLbs request manager + let setCookie = mk (fromString "Set-Cookie") + (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.responseHeaders response) + assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 + it "redirects set cookies" $ withApp app $ \port -> do + request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"] + manager <- newManager tlsManagerSettings + response <- httpLbs request manager + (responseBody response) @?= "nom-nom-nom" + it "user-defined cookie jar works" $ withApp app $ \port -> do + request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] + manager <- newManager tlsManagerSettings + response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager + (responseBody response) @?= "key=value" + it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do + request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] + manager <- newManager tlsManagerSettings + response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager + (responseBody response) @?= "key=value" + it "cookie jar is available in response" $ withApp app $ \port -> do + request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] + manager <- newManager tlsManagerSettings + response <- httpLbs (request {cookieJar = Just Data.Monoid.mempty}) manager + (length $ destroyCookieJar $ responseCookieJar response) @?= 1 + it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do + request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] + manager <- newManager tlsManagerSettings + let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request) + response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager + (responseBody response) @?= "key2=value2" + it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do + request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] + manager <- newManager tlsManagerSettings + response <- httpLbs (request {cookieJar = Nothing}) manager + (responseCookieJar response) @?= mempty + it "TLS" $ withAppTls app $ \port -> do + request <- parseUrlThrow $ "https://127.0.0.1:" ++ show port + let set = mkManagerSettings + def + { settingDisableCertificateValidation = True + } + Nothing + manager <- newManager set + response <- httpLbs request manager + responseBody response @?= "homepage" + describe "manager" $ do + it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do + --FIXME clearSocketsList + manager <- newManager tlsManagerSettings + let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port1 + let Just req2 = parseUrlThrow $ "http://127.0.0.1:" ++ show port2 + runResourceT $ do + _res1a <- http req1 manager + _res1b <- http req1 manager + _res2 <- http req2 manager + return () + --FIXME requireAllSocketsClosed + describe "http" $ do + it "response body" $ withApp app $ \port -> do + manager <- newManager tlsManagerSettings + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + runResourceT $ do + res1 <- http req manager + bss <- runConduit $ responseBody res1 .| CL.consume + res2 <- httpLbs req manager + liftIO $ L.fromChunks bss `shouldBe` responseBody res2 + describe "DOS protection" $ do + it "overlong headers" $ overLongHeaders $ \port -> do + manager <- newManager tlsManagerSettings + let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port + res1 <- try $ runResourceT $ http req1 manager + case res1 of + Left e -> show (e :: SomeException) @?= show (HttpExceptionRequest req1 OverlongHeaders) + _ -> error "Shouldn't have worked" + it "not overlong headers" $ notOverLongHeaders $ \port -> do + manager <- newManager tlsManagerSettings + let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port + _ <- httpLbs req1 manager + return () + describe "redirects" $ do + it "doesn't double escape" $ redir $ \port -> do + manager <- newManager tlsManagerSettings + let go (encoded, final) = do + let Just req1 = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/redir/", encoded] + res <- httpLbs req1 manager + liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 + liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final] + mapM_ go + [ ("hello world%2F", "hello world/") + , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום") + , ("simple", "simple") + , ("hello%20world", "hello world") + , ("hello%20world%3f%23", "hello world?#") + ] + it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do + let Just req = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/infredir/0"] + let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i) + manager <- newManager tlsManagerSettings + E.catch (void $ runResourceT $ http req{redirectCount=5} manager) + $ \e -> + case e of + HttpExceptionRequest _ (TooManyRedirects redirs) -> + mapM_ go (zip redirs [5,4..0 :: Int]) + _ -> error $ show e + describe "chunked request body" $ do + it "works" $ echo $ \port -> do + manager <- newManager tlsManagerSettings + let go bss = do + let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port + src = sourceList bss + lbs = L.fromChunks bss + res <- httpLbs req1 + { requestBody = requestBodySourceChunked src + } manager + liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 + let ts = S.concat . L.toChunks + liftIO $ ts (responseBody res) @?= ts lbs + mapM_ go + [ ["hello", "world"] + , replicate 500 "foo\003\n\r" + ] + describe "no status message" $ do + it "works" $ noStatusMessage $ \port -> do + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + manager <- newManager tlsManagerSettings + res <- httpLbs req manager + liftIO $ do + Network.HTTP.Conduit.responseStatus res `shouldBe` status200 + responseBody res `shouldBe` "foo" + + describe "response body too short" $ do + it "throws an exception" $ wrongLength $ \port -> do + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show $ HttpExceptionRequest req $ ResponseBodyTooShort 50 18) + + describe "chunked response body" $ do + it "no chunk terminator" $ wrongLengthChunk1 $ \port -> do + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show (HttpExceptionRequest req IncompleteHeaders)) + it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) + it "invalid chunk" $ invalidChunk $ \port -> do + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) + + it "missing header" $ rawApp + "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\n\r\n\r\n" + $ \port -> do + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) + + it "junk header" $ rawApp + "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\njunk\r\n\r\n" + $ \port -> do + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + manager <- newManager tlsManagerSettings + eres <- try $ httpLbs req manager + liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres + `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) + + describe "redirect" $ do + it "ignores large response bodies" $ do + let app' port req = + case pathInfo req of + ["foo"] -> return $ responseLBS status200 [] "Hello World!" + _ -> return $ responseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" + manager <- newManager tlsManagerSettings + withApp' app' $ \port -> do + req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port + res <- httpLbs req manager + liftIO $ do + Network.HTTP.Conduit.responseStatus res `shouldBe` status200 + responseBody res `shouldBe` "Hello World!" + describe "multipart/form-data" $ do + it "formats correctly" $ do + let bd = "---------------------------190723902820679116301912680260" + (RequestBodyStream _ givesPopper) <- renderParts bd + [partBS "email" "" + ,partBS "parent_id" "70488" + ,partBS "captcha" "" + ,partBS "homeboard" "0chan.hk" + ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим." + ,partFileSource "upload" "nyan.gif" + ] + ires <- I.newIORef S.empty + let loop front popper = do + bs <- popper + if S.null bs + then I.writeIORef ires $ S.concat $ front [] + else loop (front . (bs:)) popper + givesPopper $ loop id + mfd <- I.readIORef ires + exam <- S.readFile "multipart-example.bin" + mfd @?= exam + + describe "HTTP/1.0" $ do + it "BaseHTTP" $ do + let baseHTTP app' = do + _ <- runConduit $ appSource app' .| await + runConduit $ yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" .| appSink app' + manager <- newManager tlsManagerSettings + withCApp baseHTTP $ \port -> do + req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port + res1 <- httpLbs req manager + res2 <- httpLbs req manager + liftIO $ res1 @?= res2 + + describe "hostAddress" $ do + it "overrides host" $ withApp app $ \port -> do + req' <- parseUrlThrow $ "http://example.com:" ++ show port + let req = req' { hostAddress = Just $ NS.tupleToHostAddress (127, 0, 0, 1) } + manager <- newManager tlsManagerSettings + res <- httpLbs req manager + responseBody res @?= "homepage for example.com" + + describe "managerResponseTimeout" $ do + it "works" $ withApp app $ \port -> do + req1 <- parseUrlThrow $ "http://localhost:" ++ show port + let req2 = req1 { responseTimeout = responseTimeoutMicro 5000000 } + man <- newManager tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro 1 } + eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man + case eres1 of + Left (HttpExceptionRequest _ ConnectionTimeout{}) -> return () + _ -> error "Did not time out" + _ <- httpLbs req2 man + return () + + describe "delayed body" $ do + it "works" $ withApp app $ \port -> do + req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/delayed" + man <- newManager tlsManagerSettings + _ <- runResourceT $ http req man + return () + + it "reuse/connection close tries again" $ do + withAppSettings (setTimeout 1) (const app) $ \port -> do + req <- parseUrlThrow $ "http://localhost:" ++ show port + man <- newManager tlsManagerSettings + res1 <- httpLbs req man + threadDelay 3000000 + res2 <- httpLbs req man + let f res = res + { NHC.responseHeaders = filter (not . isDate) (NHC.responseHeaders res) + } + isDate ("date", _) = True + isDate _ = False + f res2 `shouldBe` f res1 + + it "setQueryString" $ do + ref <- I.newIORef undefined + let app' req = do + I.writeIORef ref $ Wai.queryString req + return $ responseLBS status200 [] "" + withApp app' $ \port -> do + let qs = + [ ("foo", Just "bar") + , (TE.encodeUtf8 "שלום", Just "hola") + , ("noval", Nothing) + ] + man <- newManager tlsManagerSettings + req <- parseUrlThrow $ "http://localhost:" ++ show port + _ <- httpLbs (setQueryString qs req) man + res <- I.readIORef ref + res `shouldBe` qs + +#ifdef VERSION_aeson + describe "Simple.JSON" $ do + it "normal" $ jsonApp $ \port -> do + req <- parseUrlThrow $ "http://localhost:" ++ show port + value <- Simple.httpJSON req + responseBody value `shouldBe` jsonValue + it "trailing whitespace" $ jsonApp $ \port -> do + req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/trailing" + value <- Simple.httpJSON req + responseBody value `shouldBe` jsonValue +#endif + + it "RequestBodyIO" $ echo $ \port -> do + manager <- newManager tlsManagerSettings + let go bss = withSystemTempFile "request-body-io" $ \tmpfp tmph -> do + liftIO $ do + mapM_ (S.hPutStr tmph) bss + hClose tmph + + let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port + lbs = L.fromChunks bss + res <- httpLbs req1 + { requestBody = RequestBodyIO (streamFile tmpfp) + } manager + liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 + let ts = S.concat . L.toChunks + liftIO $ ts (responseBody res) @?= ts lbs + mapM_ go + [ ["hello", "world"] + , replicate 500 "foo\003\n\r" + ] + +withCApp :: (Data.Conduit.Network.AppData -> IO ()) -> (Int -> IO ()) -> IO () +withCApp app' f = do + port <- getPort + baton <- newEmptyMVar + let start = putMVar baton () +#if MIN_VERSION_conduit(1,1,0) + settings :: ServerSettings + settings = setAfterBind (const start) (serverSettings port "*") +#else + settings :: ServerSettings IO + settings = (serverSettings port "*" :: ServerSettings IO) { serverAfterBind = const start } +#endif + bracket + (forkIO $ runTCPServer settings app' `onException` start) + killThread + (const $ takeMVar baton >> f port) + +overLongHeaders :: (Int -> IO ()) -> IO () +overLongHeaders = + withCApp $ \app' -> runConduit $ src .| appSink app' + where + src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" + +notOverLongHeaders :: (Int -> IO ()) -> IO () +notOverLongHeaders = withCApp $ \app' -> do + runConduit $ appSource app' .| CL.drop 1 + runConduit $ src .| appSink app' + where + src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] + +redir :: (Int -> IO ()) -> IO () +redir = + withApp' redirApp + where + redirApp port req = + case pathInfo req of + ["redir", foo] -> return $ responseLBS status301 + [ ("Location", S8.pack (concat ["http://127.0.0.1:", show port, "/content/"]) `S.append` escape foo) + ] + "" + ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo] + _ -> return $ responseLBS status404 [] "" + escape = S8.concatMap (S8.pack . encodeUrlChar) . TE.encodeUtf8 + + encodeUrlChar :: Char -> String + encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] + encodeUrlChar c@'-' = [c] + encodeUrlChar c@'_' = [c] + encodeUrlChar c@'.' = [c] + encodeUrlChar c@'~' = [c] + encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] + +echo :: (Int -> IO ()) -> IO () +echo = withApp $ \req -> do + bss <- runConduit $ sourceRequestBody req .| CL.consume + return $ responseLBS status200 [] $ L.fromChunks bss + +noStatusMessage :: (Int -> IO ()) -> IO () +noStatusMessage = + withCApp $ \app' -> runConduit $ src .| appSink app' + where + src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin" + +wrongLength :: (Int -> IO ()) -> IO () +wrongLength = + withCApp $ \app' -> do + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' + where + src = do + yield "HTTP/1.0 200 OK\r\nContent-Length: 50\r\n\r\n" + yield "Not quite 50 bytes" + +wrongLengthChunk1 :: (Int -> IO ()) -> IO () +wrongLengthChunk1 = + withCApp $ \app' -> do + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' + where + src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n" + +wrongLengthChunk2 :: (Int -> IO ()) -> IO () +wrongLengthChunk2 = + withCApp $ \app' -> do + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' + where + src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n5\r\npedia\r\nE\r\nin\r\n\r\nch\r\n" + +invalidChunk :: (Int -> IO ()) -> IO () +invalidChunk = + withCApp $ \app' -> do + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' + where + src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\ngarbage\r\nef\r\n0\r\n\r\n" + +rawApp :: S8.ByteString -> (Int -> IO ()) -> IO () +rawApp bs = + withCApp $ \app' -> do + _ <- runConduit $ appSource app' .| await + runConduit $ src .| appSink app' + where + src = yield bs + +#ifdef VERSION_aeson +jsonApp :: (Int -> IO ()) -> IO () +jsonApp = withApp $ \req -> return $ responseLBS + status200 + [ ("Content-Type", "application/json") + ] $ + case pathInfo req of + [] -> A.encode jsonValue + ["trailing"] -> L.append (A.encode jsonValue) " \n\r\n\t " + x -> error $ "unsupported: " ++ show x + +jsonValue :: A.Value +jsonValue = A.object + [ "name" A..= ("Alice" :: String) + , "age" A..= (35 :: Int) + ] +#endif