http-conduit 2.3.7.3 → 2.3.7.4
raw patch · 12 files changed
+2555/−2488 lines, 12 filesdep +tlsdep ~basesetup-changed
Dependencies added: tls
Dependency ranges changed: base
Files
- ChangeLog.md +130/−126
- LICENSE +25/−25
- Network/HTTP/Client/Conduit.hs +192/−192
- Network/HTTP/Conduit.hs +352/−352
- Network/HTTP/Simple.hs +501/−478
- README.md +10/−10
- Setup.lhs +8/−8
- certificate.pem +15/−15
- http-conduit.cabal +96/−84
- key.pem +15/−15
- test/CookieTest.hs +580/−558
- test/main.hs +631/−625
ChangeLog.md view
@@ -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`
LICENSE view
@@ -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.
Network/HTTP/Client/Conduit.hs view
@@ -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:------ <https://haskell-lang.org/library/http-client>------ 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: +-- +-- <https://haskell-lang.org/library/http-client> +-- +-- 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
Network/HTTP/Conduit.hs view
@@ -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:------ <https://haskell-lang.org/library/http-client>------ = 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: +-- +-- <https://haskell-lang.org/library/http-client> +-- +-- = 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
Network/HTTP/Simple.hs view
@@ -1,478 +1,501 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE OverloadedStrings #-}--- | Simplified interface for common HTTP client interactions. Tutorial--- available at--- <https://haskell-lang.org/library/http-client>------ 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 +-- <https://haskell-lang.org/library/http-client> +-- +-- 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
README.md view
@@ -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://hackage.haskell.org/package/http-conduit-browser/>+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 <http://hackage.haskell.org/package/http-conduit-browser/>
Setup.lhs view
@@ -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
certificate.pem view
@@ -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-----
http-conduit.cabal view
@@ -1,84 +1,96 @@-name: http-conduit-version: 2.3.7.3-license: BSD3-license-file: LICENSE-author: Michael Snoyman <michael@snoyman.com>-maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: HTTP client package with conduit interface and HTTPS support.-description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-conduit>.-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 <michael@snoyman.com> +maintainer: Michael Snoyman <michael@snoyman.com> +synopsis: HTTP client package with conduit interface and HTTPS support. +description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-conduit>. +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
key.pem view
@@ -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-----
test/CookieTest.hs view
@@ -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
test/main.hs view
@@ -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