HTTP 4000.1.2 → 4000.5.0
raw patch · 24 files changed
Files
- CHANGES +35/−2
- HTTP.cabal +184/−91
- LICENSE +11/−1
- Network/Browser.hs +308/−276
- Network/BufferType.hs +17/−17
- Network/HTTP.hs +90/−38
- Network/HTTP/Auth.hs +34/−32
- Network/HTTP/Base.hs +307/−166
- Network/HTTP/Base64.hs +16/−13
- Network/HTTP/Cookie.hs +46/−50
- Network/HTTP/HandleStream.hs +61/−53
- Network/HTTP/Headers.hs +181/−26
- Network/HTTP/MD5.hs +0/−43
- Network/HTTP/MD5Aux.hs +4/−3
- Network/HTTP/Proxy.hs +76/−20
- Network/HTTP/Stream.hs +48/−42
- Network/HTTP/Utils.hs +106/−10
- Network/Stream.hs +8/−14
- Network/StreamDebugger.hs +19/−17
- Network/StreamSocket.hs +16/−11
- Network/TCP.hs +137/−98
- test/Httpd.hs +158/−0
- test/UnitTests.hs +69/−0
- test/httpTests.hs +668/−0
CHANGES view
@@ -1,6 +1,39 @@+Version 4000.4.0: release 2022-02-22+ * Restrict to GHC >=7.6 and associated cleanups (Andreas Abel)+ * Drop deprecated instance Error (Andreas Abel)+ * Preparation for mtl-2.3 (Andreas Abel)+ * General tidying (Andreas Abel)+ * Support GHC 9.2 (Bodigrim)++Version 4000.3.16: release 2021-03-20+ * Support GHC-9.0 (Oleg Genrus)+ * Various dependency bumps (multiple people)+ * Try all addresses returned by getAddrInfo (Fraser Tweedale)++Version ?++ * If the URI contains "user:pass@" part, use it for Basic Authorization+ * Add a test harness.+ * Don't leak a socket when getHostAddr throws an exception.+ * Send cookies in request format, not response format.+ * Moved BrowserAction to be a StateT IO, with instances for+ Applicative, MonadIO, MonadState.+ * Add method to control size of connection pool.+ * Consider both host and port when reusing connections.+ * Handle response code 304 "not modified" properly.+ * Fix digest authentication by fixing md5 output string rep.+ * Make the default user agent string follow the package version.+ * Document lack of HTTPS support and fail when clients try+ to use it instead of silently falling back to HTTP.+ * Add helper to set the request type and body.++Version 4000.1.2: release 2011-08-11+ * Turn off buffering for the debug log.+ * Update installation instructions.+ * Bump base dependency to support GHC 7.2.+ Version 4000.1.1: release 2010-11-28- * Be tolerant of LF (instead of CRLF which is the spec) in responses- Patch by Chris Pettitt <cpettitt@gmail.com>.+ * Be tolerant of LF (instead of CRLF which is the spec) in responses. Version 4000.1.0: release 2010-11-09 * Retroactively fixed CHANGES to refer to 4000.x.x instead of
HTTP.cabal view
@@ -1,91 +1,184 @@-Name: HTTP -Version: 4000.1.2 -Cabal-Version: >= 1.2 -Build-type: Simple -License: BSD3 -License-file: LICENSE -Copyright: - Copyright (c) 2002, Warrick Gray - Copyright (c) 2002-2005, Ian Lynagh - Copyright (c) 2003-2006, Bjorn Bringert - Copyright (c) 2004, Andre Furtado - Copyright (c) 2004, Ganesh Sittampalam - Copyright (c) 2004-2005, Dominic Steinitz - Copyright 2007 Robin Bate Boerop - Copyright 2008- Sigbjorn Finne -Author: Warrick Gray <warrick.gray@hotmail.com> -Maintainer: Ganesh Sittampalam <ganesh@earth.li> -Homepage: http://projects.haskell.org/http/ -Category: Network -Synopsis: A library for client-side HTTP -Description: - - The HTTP package supports client-side web programming in Haskell. It lets you set up - HTTP connections, transmitting requests and processing the responses coming back, all - from within the comforts of Haskell. It's dependent on the network package to operate, - but other than that, the implementation is all written in Haskell. - . - A basic API for issuing single HTTP requests + receiving responses is provided. On top - of that, a session-level abstraction is also on offer (the @BrowserAction@ monad); - it taking care of handling the management of persistent connections, proxies, - state (cookies) and authentication credentials required to handle multi-step - interactions with a web server. - . - The representation of the bytes flowing across is extensible via the use of a type class, - letting you pick the representation of requests and responses that best fits your use. - Some pre-packaged, common instances are provided for you (@ByteString@, @String@.) - . - Here's an example use: - . - > - > do - > rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/") - > -- fetch document and return it (as a 'String'.) - > fmap (take 100) (getResponseBody rsp) - > - > do - > rsp <- Network.Browser.browse $ do - > setAllowRedirects True -- handle HTTP redirects - > request $ getRequest "http://google.com/" - > fmap (take 100) (getResponseBody rsp) - > - . - Git repository available at <git://github.com/haskell/HTTP.git> - -Extra-Source-Files: CHANGES - -Flag old-base - description: Old, monolithic base - default: False - -Library - Exposed-modules: - Network.BufferType, - Network.Stream, - Network.StreamDebugger, - Network.StreamSocket, - Network.TCP, - Network.HTTP, - Network.HTTP.Headers, - Network.HTTP.Base, - Network.HTTP.Stream, - Network.HTTP.Auth, - Network.HTTP.Cookie, - Network.HTTP.Proxy, - Network.HTTP.HandleStream, - Network.Browser - Other-modules: - Network.HTTP.Base64, - Network.HTTP.MD5, - Network.HTTP.MD5Aux, - Network.HTTP.Utils - GHC-options: -fwarn-missing-signatures -Wall - Build-depends: base >= 2 && < 4.5, network, parsec, mtl - Extensions: FlexibleInstances - if flag(old-base) - Build-depends: base < 3 - else - Build-depends: base >= 3, array, old-time, bytestring - - if os(windows) - Build-depends: Win32 +Cabal-Version: 3.0+Name: HTTP+Version: 4000.5.0+Build-type: Simple+License: BSD-3-Clause+License-file: LICENSE+Author: Warrick Gray <warrick.gray@hotmail.com>+Maintainer: Ganesh Sittampalam <ganesh@earth.li>+Homepage: https://github.com/haskell/HTTP+Category: Network+Synopsis: A library for client-side HTTP+Description:++ The HTTP package supports client-side web programming in Haskell. It lets you set up+ HTTP connections, transmitting requests and processing the responses coming back, all+ from within the comforts of Haskell. It's dependent on the network package to operate,+ but other than that, the implementation is all written in Haskell.+ .+ A basic API for issuing single HTTP requests + receiving responses is provided. On top+ of that, a session-level abstraction is also on offer (the @BrowserAction@ monad);+ it taking care of handling the management of persistent connections, proxies,+ state (cookies) and authentication credentials required to handle multi-step+ interactions with a web server.+ .+ The representation of the bytes flowing across is extensible via the use of a type class,+ letting you pick the representation of requests and responses that best fits your use.+ Some pre-packaged, common instances are provided for you (@ByteString@, @String@).+ .+ Here's an example use:+ .+ >+ > do+ > rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/")+ > -- fetch document and return it (as a 'String'.)+ > fmap (take 100) (getResponseBody rsp)+ >+ > do+ > (_, rsp)+ > <- Network.Browser.browse $ do+ > setAllowRedirects True -- handle HTTP redirects+ > request $ getRequest "http://www.haskell.org/"+ > return (take 100 (rspBody rsp))+ .+ __Note:__ This package does not support HTTPS connections.+ If you need HTTPS, take a look at the following packages:+ .+ * <http://hackage.haskell.org/package/http-streams http-streams>+ .+ * <http://hackage.haskell.org/package/http-client http-client> (in combination with+ <http://hackage.haskell.org/package/http-client-tls http-client-tls>)+ .+ * <http://hackage.haskell.org/package/req req>+ .+ * <http://hackage.haskell.org/package/wreq wreq>+ .++Extra-Source-Files: CHANGES++tested-with:+ GHC == 9.12.2+ GHC == 9.10.3+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ -- CI failing for GHC 8.0 because of https://github.com/haskell/cabal/issues/10379+ -- GHC == 8.0.2++Source-Repository head+ type: git+ location: https://github.com/haskell/HTTP.git++Flag warn-as-error+ default: False+ description: Build with warnings-as-errors+ manual: True++Flag conduit10+ description: Use version 1.0.x or below of the conduit package (for the test suite)+ default: False++Flag warp-tests+ description: Test against warp+ default: False+ manual: True++Library+ Autogen-modules: Paths_HTTP+ Exposed-modules:+ Network.BufferType,+ Network.Stream,+ Network.StreamDebugger,+ Network.StreamSocket,+ Network.TCP,+ Network.HTTP,+ Network.HTTP.Headers,+ Network.HTTP.Base,+ Network.HTTP.Stream,+ Network.HTTP.Auth,+ Network.HTTP.Cookie,+ Network.HTTP.Proxy,+ Network.HTTP.HandleStream,+ Network.Browser+ Other-modules:+ Network.HTTP.Base64,+ Network.HTTP.MD5Aux,+ Network.HTTP.Utils,+ Paths_HTTP+ GHC-options: -fwarn-missing-signatures -Wall++ -- note the test harness constraints should be kept in sync with these+ -- where dependencies are shared+ build-depends:+ base >= 4.6.0.0 && < 4.22+ , array >= 0.3.0.2 && < 0.6+ , bytestring >= 0.9.1.5 && < 0.13+ , parsec >= 2.0 && < 3.2+ , time >= 1.1.2.3 && < 1.15+ , transformers >= 0.2.0.0 && < 0.7+ -- transformers-0.2.0.0 is the first to have Control.Monad.IO.Class+ -- The following dependencies are refined by flags, but they should+ -- still be mentioned here on the top-level.+ , mtl >= 2.0.0.0 && < 2.4+ , network >= 2.6 && < 3.3+ , network-uri >= 2.6 && < 2.7++ default-language: Haskell98+ default-extensions: FlexibleInstances++ if flag(warn-as-error)+ ghc-options: -Werror++ if os(windows)+ Build-depends: Win32 >= 2.2.0.0 && < 2.15++Test-Suite test+ type: exitcode-stdio-1.0++ default-language: Haskell98+ hs-source-dirs: test+ main-is: httpTests.hs++ other-modules:+ Httpd+ UnitTests++ ghc-options: -Wall++ build-depends:+ HTTP+ -- constraints inherited from HTTP+ , base+ , bytestring+ , mtl+ , network+ , network-uri+ -- extra dependencies+ , deepseq >= 1.3.0.0 && < 1.6+ , httpd-shed >= 0.4 && < 0.5+ , HUnit >= 1.2.0.1 && < 1.7+ , pureMD5 >= 0.2.4 && < 2.2+ , split >= 0.1.3 && < 0.3+ , test-framework >= 0.2.0 && < 0.9+ , test-framework-hunit >= 0.3.0 && < 0.4++ if flag(warp-tests)+ CPP-Options: -DWARP_TESTS+ build-depends:+ case-insensitive >= 0.4.0.1 && < 1.3+ , conduit >= 1.0.8 && < 1.4+ , http-types >= 0.8.0 && < 1.0+ , wai >= 2.1.0 && < 3.3+ , warp >= 2.1.0 && < 3.5++ if flag(conduit10)+ build-depends: conduit < 1.1+ else+ build-depends: conduit >= 1.1, conduit-extra >= 1.1 && < 1.4
LICENSE view
@@ -2,8 +2,18 @@ Copyright (c) 2002-2005, Ian Lynagh Copyright (c) 2003-2006, Bjorn Bringert Copyright (c) 2004, Andre Furtado-Copyright (c) 2004, Ganesh Sittampalam Copyright (c) 2004-2005, Dominic Steinitz+Copyright (c) 2007, Robin Bate Boerop+Copyright (c) 2008-2010, Sigbjorn Finne+Copyright (c) 2009, Eric Kow+Copyright (c) 2010, Antoine Latter+Copyright (c) 2004, 2010-2011, Ganesh Sittampalam+Copyright (c) 2011, Duncan Coutts+Copyright (c) 2011, Matthew Gruen+Copyright (c) 2011, Jeremy Yallop+Copyright (c) 2011, Eric Hesselink+Copyright (c) 2011, Yi Huang+Copyright (c) 2011, Tom Lokhorst All rights reserved.
Network/Browser.hs view
@@ -1,17 +1,18 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-} {- | Module : Network.Browser-Copyright : (c) Warrick Gray 2002+Copyright : See LICENSE file License : BSD- -Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>++Maintainer : Ganesh Sittampalam <ganesh@earth.li> Stability : experimental Portability : non-portable (not tested) Session-level interactions over HTTP.- -The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in -providing support for more involved, and real, request/response interactions over ++The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in+providing support for more involved, and real, request/response interactions over HTTP. Additional features supported are: * HTTP Authentication handling@@ -26,30 +27,31 @@ Example use: -> do -> rsp <- Network.Browser.browse $ do+> do+> (_, rsp)+> <- Network.Browser.browse $ do > setAllowRedirects True -- handle HTTP redirects-> request $ getRequest "http://google.com/"-> fmap (take 100) (getResponseBody rsp)- +> request $ getRequest "http://www.haskell.org/"+> return (take 100 (rspBody rsp))+ -}-module Network.Browser +module Network.Browser ( BrowserState , BrowserAction -- browser monad, effectively a state monad. , Proxy(..)- + , browse -- :: BrowserAction a -> IO a , request -- :: Request -> BrowserAction Response- + , getBrowserState -- :: BrowserAction t (BrowserState t) , withBrowserState -- :: BrowserState t -> BrowserAction t a -> BrowserAction t a- + , setAllowRedirects -- :: Bool -> BrowserAction t () , getAllowRedirects -- :: BrowserAction t Bool , setMaxRedirects -- :: Int -> BrowserAction t () , getMaxRedirects -- :: BrowserAction t (Maybe Int)- + , Authority(..) , getAuthorities , setAuthorities@@ -57,15 +59,18 @@ , Challenge(..) , Qop(..) , Algorithm(..)- + , getAuthorityGen , setAuthorityGen , setAllowBasicAuth , getAllowBasicAuth- + , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) + , setMaxPoolSize -- :: Int -> BrowserAction t ()+ , getMaxPoolSize -- :: BrowserAction t (Maybe Int)+ , setMaxAuthAttempts -- :: Maybe Int -> BrowserAction t () , getMaxAuthAttempts -- :: BrowserAction t (Maybe Int) @@ -73,21 +78,21 @@ , getCookieFilter -- :: BrowserAction t (URI -> Cookie -> IO Bool) , defaultCookieFilter -- :: URI -> Cookie -> IO Bool , userCookieFilter -- :: URI -> Cookie -> IO Bool- + , Cookie(..) , getCookies -- :: BrowserAction t [Cookie] , setCookies -- :: [Cookie] -> BrowserAction t () , addCookie -- :: Cookie -> BrowserAction t ()- + , setErrHandler -- :: (String -> IO ()) -> BrowserAction t () , setOutHandler -- :: (String -> IO ()) -> BrowserAction t ()- + , setEventHandler -- :: (BrowserEvent -> BrowserAction t ()) -> BrowserAction t ()- + , BrowserEvent(..) , BrowserEventType(..) , RequestID- + , setProxy -- :: Proxy -> BrowserAction t () , getProxy -- :: BrowserAction t Proxy @@ -95,20 +100,20 @@ , getCheckForProxy -- :: BrowserAction t Bool , setDebugLog -- :: Maybe String -> BrowserAction t ()- + , getUserAgent -- :: BrowserAction t String , setUserAgent -- :: String -> BrowserAction t ()- + , out -- :: String -> BrowserAction t () , err -- :: String -> BrowserAction t () , ioAction -- :: IO a -> BrowserAction a , defaultGETRequest , defaultGETRequest_- + , formToRequest , uriDefaultTo- + -- old and half-baked; don't use: , Form(..) , FormVar@@ -128,17 +133,27 @@ import Network.Stream ( ConnError(..), Result ) import Network.BufferType+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,13,0))+import Control.Monad.Fail+#endif import Data.Char (toLower) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe, listToMaybe, catMaybes )-import Control.Monad (filterM, liftM, when)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+#endif+import Control.Monad (filterM, forM_, when)+import Control.Monad.IO.Class+ ( MonadIO (..) )+import Control.Monad.State+ ( MonadState(..), gets, modify, StateT (..), evalStateT, withStateT ) import qualified System.IO ( hSetBuffering, hPutStr, stdout, stdin, hGetChar , BufferMode(NoBuffering, LineBuffering) )-import System.Time ( ClockTime, getClockTime )+import Data.Time.Clock ( UTCTime, getCurrentTime ) ------------------------------------------------------------------@@ -172,18 +187,18 @@ -- | @addCookie c@ adds a cookie to the browser state, removing duplicates. addCookie :: Cookie -> BrowserAction t ()-addCookie c = alterBS (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) })+addCookie c = modify (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) }) -- | @setCookies cookies@ replaces the set of cookies known to -- the browser to @cookies@. Useful when wanting to restore cookies -- used across 'browse' invocations. setCookies :: [Cookie] -> BrowserAction t ()-setCookies cs = alterBS (\b -> b { bsCookies=cs })+setCookies cs = modify (\b -> b { bsCookies=cs }) -- | @getCookies@ returns the current set of cookies known to -- the browser. getCookies :: BrowserAction t [Cookie]-getCookies = getBS bsCookies+getCookies = gets bsCookies -- ...get domain specific cookies... -- ... this needs changing for consistency with rfc2109...@@ -195,15 +210,15 @@ where cookiematch :: Cookie -> Bool cookiematch = cookieMatch (dom,path)- + -- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()-setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f })+setCookieFilter f = modify (\b -> b { bsCookieFilter=f }) -- | @getCookieFilter@ returns the current cookie acceptance filter. getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool)-getCookieFilter = getBS bsCookieFilter+getCookieFilter = gets bsCookieFilter ------------------------------------------------------------------ ----------------------- Authorisation Stuff ----------------------@@ -239,7 +254,7 @@ Notes:- - digest authentication so far ignores qop, so fails to authenticate + - digest authentication so far ignores qop, so fails to authenticate properly with qop=auth-int challenges - calculates a1 more than necessary - doesn't reverse authenticate@@ -259,60 +274,60 @@ matchURI :: URI -> Bool matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth)- + -- | @getAuthorities@ return the current set of @Authority@s known -- to the browser. getAuthorities :: BrowserAction t [Authority]-getAuthorities = getBS bsAuthorities+getAuthorities = gets bsAuthorities -- @setAuthorities as@ replaces the Browser's known set -- of 'Authority's to @as@. setAuthorities :: [Authority] -> BrowserAction t ()-setAuthorities as = alterBS (\b -> b { bsAuthorities=as })+setAuthorities as = modify (\b -> b { bsAuthorities=as }) -- @addAuthority a@ adds 'Authority' @a@ to the Browser's -- set of known authorities. addAuthority :: Authority -> BrowserAction t ()-addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b })+addAuthority a = modify (\b -> b { bsAuthorities=a:bsAuthorities b }) -- | @getAuthorityGen@ returns the current authority generator getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String)))-getAuthorityGen = getBS bsAuthorityGen+getAuthorityGen = gets bsAuthorityGen -- | @setAuthorityGen genAct@ sets the auth generator to @genAct@. setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t ()-setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f })+setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f }) -- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication. setAllowBasicAuth :: Bool -> BrowserAction t ()-setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba })+setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba }) getAllowBasicAuth :: BrowserAction t Bool-getAllowBasicAuth = getBS bsAllowBasicAuth+getAllowBasicAuth = gets bsAllowBasicAuth -- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts--- to do. If @Nothing@, rever to default max.+-- to do. If @Nothing@, revert to default max. setMaxAuthAttempts :: Maybe Int -> BrowserAction t ()-setMaxAuthAttempts mb +setMaxAuthAttempts mb | fromMaybe 0 mb < 0 = return ()- | otherwise = alterBS (\ b -> b{bsMaxAuthAttempts=mb})+ | otherwise = modify (\ b -> b{bsMaxAuthAttempts=mb}) -- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@, -- the browser's default is used. getMaxAuthAttempts :: BrowserAction t (Maybe Int)-getMaxAuthAttempts = getBS bsMaxAuthAttempts+getMaxAuthAttempts = gets bsMaxAuthAttempts -- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at -- transmitting a request. If @Nothing@, rever to default max. setMaxErrorRetries :: Maybe Int -> BrowserAction t () setMaxErrorRetries mb | fromMaybe 0 mb < 0 = return ()- | otherwise = alterBS (\ b -> b{bsMaxErrorRetries=mb})+ | otherwise = modify (\ b -> b{bsMaxErrorRetries=mb}) -- | @getMaxErrorRetries@ returns the current max number of error retries. getMaxErrorRetries :: BrowserAction t (Maybe Int)-getMaxErrorRetries = getBS bsMaxErrorRetries+getMaxErrorRetries = gets bsMaxErrorRetries -- TO BE CHANGED!!! pickChallenge :: Bool -> [Challenge] -> Maybe Challenge@@ -335,7 +350,7 @@ | otherwise = do -- prompt user for authority prompt <- getAuthorityGen- userdetails <- ioAction $ prompt uri (chRealm ch)+ userdetails <- liftIO $ prompt uri (chRealm ch) case userdetails of Nothing -> return Nothing Just (u,p) -> return (Just $ buildAuth ch u p)@@ -345,7 +360,7 @@ answerable chall = (chAlgorithm chall) == Just AlgMD5 buildAuth :: Challenge -> String -> String -> Authority- buildAuth (ChalBasic r) u p = + buildAuth (ChalBasic r) u p = AuthBasic { auSite=uri , auRealm=r , auUsername=u@@ -385,6 +400,7 @@ , bsMaxRedirects :: Maybe Int , bsMaxErrorRetries :: Maybe Int , bsMaxAuthAttempts :: Maybe Int+ , bsMaxPoolSize :: Maybe Int , bsConnectionPool :: [connection] , bsCheckProxy :: Bool , bsProxy :: Proxy@@ -395,30 +411,30 @@ } instance Show (BrowserState t) where- show bs = "BrowserState { " + show bs = "BrowserState { " ++ shows (bsCookies bs) ("\n" {- ++ show (bsAuthorities bs) ++ "\n"-} ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") -- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'.-data BrowserAction conn a - = BA { lift :: BrowserState conn -> IO (BrowserState conn,a) }--instance Monad (BrowserAction conn) where- a >>= f = BA (\b -> do { (nb,v) <- lift a b ; lift (f v) nb})- return x = BA (\b -> return (b,x))- fail x = BA (\_ -> fail x)+newtype BrowserAction conn a+ = BA { unBA :: StateT (BrowserState conn) IO a }+ deriving+ ( Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)+#if MIN_VERSION_base(4,9,0)+ , MonadFail+#endif+ ) -instance Functor (BrowserAction conn) where- fmap f = liftM f+runBA :: BrowserState conn -> BrowserAction conn a -> IO a+runBA bs = flip evalStateT bs . unBA -- | @browse act@ is the toplevel action to perform a 'BrowserAction'. -- Example use: @browse (request (getRequest yourURL))@. browse :: BrowserAction conn a -> IO a-browse act = do x <- lift act defaultBrowserState- return (snd x)+browse = runBA defaultBrowserState --- | The default browser state has the settings +-- | The default browser state has the settings defaultBrowserState :: BrowserState t defaultBrowserState = res where@@ -428,8 +444,7 @@ , bsCookies = [] , bsCookieFilter = defaultCookieFilter , bsAuthorityGen = \ _uri _realm -> do- bsErr res "No action for prompting/generating user+password credentials \- \ provided (use: setAuthorityGen); returning Nothing"+ bsErr res "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing" return Nothing , bsAuthorities = [] , bsAllowRedirects = True@@ -437,114 +452,121 @@ , bsMaxRedirects = Nothing , bsMaxErrorRetries = Nothing , bsMaxAuthAttempts = Nothing+ , bsMaxPoolSize = Nothing , bsConnectionPool = [] , bsCheckProxy = defaultAutoProxyDetect , bsProxy = noProxy- , bsDebug = Nothing + , bsDebug = Nothing , bsEvent = Nothing , bsRequestID = 0 , bsUserAgent = Nothing } --- | Alter browser state-alterBS :: (BrowserState t -> BrowserState t) -> BrowserAction t ()-alterBS f = BA (\b -> return (f b,()))--getBS :: (BrowserState t -> a) -> BrowserAction t a-getBS f = BA (\b -> return (b,f b))-+{-# DEPRECATED getBrowserState "Use Control.Monad.State.get instead." #-} -- | @getBrowserState@ returns the current browser config. Useful -- for restoring state across 'BrowserAction's. getBrowserState :: BrowserAction t (BrowserState t)-getBrowserState = getBS id+getBrowserState = get -- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@. withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a-withBrowserState bs act = BA $ \ _ -> lift act bs+withBrowserState bs = BA . withStateT (const bs) . unBA -- | @nextRequest act@ performs the browser action @act@ as -- the next request, i.e., setting up a new request context -- before doing so. nextRequest :: BrowserAction t a -> BrowserAction t a nextRequest act = do- let updReqID st = - let + let updReqID st =+ let rid = succ (bsRequestID st) in rid `seq` st{bsRequestID=rid}- alterBS updReqID+ modify updReqID act -- | Lifts an IO action into the 'BrowserAction' monad.+{-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-} ioAction :: IO a -> BrowserAction t a-ioAction a = BA (\b -> a >>= \v -> return (b,v))+ioAction = liftIO -- | @setErrHandler@ sets the IO action to call when -- the browser reports running errors. To disable any -- such, set it to @const (return ())@. setErrHandler :: (String -> IO ()) -> BrowserAction t ()-setErrHandler h = alterBS (\b -> b { bsErr=h })+setErrHandler h = modify (\b -> b { bsErr=h }) --- | @setErrHandler@ sets the IO action to call when+-- | @setOutHandler@ sets the IO action to call when -- the browser chatters info on its running. To disable any -- such, set it to @const (return ())@. setOutHandler :: (String -> IO ()) -> BrowserAction t ()-setOutHandler h = alterBS (\b -> b { bsOut=h })+setOutHandler h = modify (\b -> b { bsOut=h }) out, err :: String -> BrowserAction t ()-out s = do { f <- getBS bsOut ; ioAction $ f s }-err s = do { f <- getBS bsErr ; ioAction $ f s }+out s = do { f <- gets bsOut ; liftIO $ f s }+err s = do { f <- gets bsErr ; liftIO $ f s } -- | @setAllowRedirects onOff@ toggles the willingness to -- follow redirects (HTTP responses with 3xx status codes). setAllowRedirects :: Bool -> BrowserAction t ()-setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl})+setAllowRedirects bl = modify (\b -> b {bsAllowRedirects=bl}) -- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag. getAllowRedirects :: BrowserAction t Bool-getAllowRedirects = getBS bsAllowRedirects+getAllowRedirects = gets bsAllowRedirects --- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops+-- | @setMaxRedirects maxCount@ sets the maximum number of forwarding hops -- we are willing to jump through. A no-op if the count is negative; if zero, -- the max is set to whatever default applies. Notice that setting the max -- redirects count does /not/ enable following of redirects itself; use -- 'setAllowRedirects' to do so. setMaxRedirects :: Maybe Int -> BrowserAction t ()-setMaxRedirects c +setMaxRedirects c | fromMaybe 0 c < 0 = return ()- | otherwise = alterBS (\b -> b{bsMaxRedirects=c})+ | otherwise = modify (\b -> b{bsMaxRedirects=c}) -- | @getMaxRedirects@ returns the current setting for the max-redirect count. -- If @Nothing@, the "Network.Browser"'s default is used. getMaxRedirects :: BrowserAction t (Maybe Int)-getMaxRedirects = getBS bsMaxRedirects+getMaxRedirects = gets bsMaxRedirects +-- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool+-- that is used to cache connections between requests+setMaxPoolSize :: Maybe Int -> BrowserAction t ()+setMaxPoolSize c = modify (\b -> b{bsMaxPoolSize=c})++-- | @getMaxPoolSize@ gets the maximum size of the connection pool+-- that is used to cache connections between requests.+-- If @Nothing@, the "Network.Browser"'s default is used.+getMaxPoolSize :: BrowserAction t (Maybe Int)+getMaxPoolSize = gets bsMaxPoolSize+ -- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@. -- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted--- as the URL of the proxy to use, possibly authenticating via +-- as the URL of the proxy to use, possibly authenticating via -- 'Authority' information in @mbAuth@. setProxy :: Proxy -> BrowserAction t () setProxy p = -- Note: if user _explicitly_ sets the proxy, we turn -- off any auto-detection of proxies.- alterBS (\b -> b {bsProxy = p, bsCheckProxy=False})+ modify (\b -> b {bsProxy = p, bsCheckProxy=False}) -- | @getProxy@ returns the current proxy settings. If -- the auto-proxy flag is set to @True@, @getProxy@ will--- perform the necessary +-- perform the necessary getProxy :: BrowserAction t Proxy getProxy = do- p <- getBS bsProxy+ p <- gets bsProxy case p of -- Note: if there is a proxy, no need to perform any auto-detect. -- Presumably this is the user's explicit and preferred proxy server. Proxy{} -> return p NoProxy{} -> do- flg <- getBS bsCheckProxy+ flg <- gets bsCheckProxy if not flg- then return p + then return p else do- np <- ioAction $ fetchProxy True{-issue warning on stderr if ill-formed...-}+ np <- liftIO $ fetchProxy True{-issue warning on stderr if ill-formed...-} -- note: this resets the check-proxy flag; a one-off affair. setProxy np return np@@ -554,7 +576,7 @@ -- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy' -- for details of how this done. setCheckForProxy :: Bool -> BrowserAction t ()-setCheckForProxy flg = alterBS (\ b -> b{bsCheckProxy=flg})+setCheckForProxy flg = modify (\ b -> b{bsCheckProxy=flg}) -- | @getCheckForProxy@ returns the current check-proxy setting. -- Notice that this may not be equal to @True@ if the session has@@ -563,30 +585,37 @@ -- whether a proxy will be checked for again before any future protocol -- interactions. getCheckForProxy :: BrowserAction t Bool-getCheckForProxy = getBS bsCheckProxy+getCheckForProxy = gets bsCheckProxy -- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@ -- is @Nothing@. If set to @Just fStem@, logs of browser activity -- is appended to files of the form @fStem-url-authority@, i.e., -- @fStem@ is just the prefix for a set of log files, one per host/authority. setDebugLog :: Maybe String -> BrowserAction t ()-setDebugLog v = alterBS (\b -> b {bsDebug=v})+setDebugLog v = modify (\b -> b {bsDebug=v}) -- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It -- will be used if no explicit user agent header is found in subsequent requests.+--+-- A common form of user agent string is @\"name\/version (details)\"@. For+-- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version+-- of this HTTP package can be helpful if you ever need to track down HTTP+-- compatibility quirks. This version is available via 'httpPackageVersion'.+-- For more info see <http://en.wikipedia.org/wiki/User_agent>.+-- setUserAgent :: String -> BrowserAction t ()-setUserAgent ua = alterBS (\b -> b{bsUserAgent=Just ua})+setUserAgent ua = modify (\b -> b{bsUserAgent=Just ua}) -- | @getUserAgent@ returns the current @User-Agent:@ default string. getUserAgent :: BrowserAction t String getUserAgent = do- n <- getBS bsUserAgent+ n <- gets bsUserAgent return (maybe defaultUserAgent id n) --- | @RequestState@ is an internal tallying type keeping track of various --- per-connection counters, like the number of authorization attempts and +-- | @RequestState@ is an internal tallying type keeping track of various+-- per-connection counters, like the number of authorization attempts and -- forwards we've gone through.-data RequestState +data RequestState = RequestState { reqDenies :: Int -- ^ number of 401 responses so far , reqRedirects :: Int -- ^ number of redirects so far@@ -610,7 +639,7 @@ -- at which they occurred. data BrowserEvent = BrowserEvent- { browserTimestamp :: ClockTime+ { browserTimestamp :: UTCTime , browserRequestID :: RequestID , browserRequestURI :: {-URI-}String , browserEventType :: BrowserEventType@@ -629,19 +658,19 @@ | AuthChallenge | AuthResponse -}- + -- | @setEventHandler onBrowserEvent@ configures event handling. -- If @onBrowserEvent@ is @Nothing@, event handling is turned off; -- setting it to @Just onEv@ causes the @onEv@ IO action to be -- notified of browser events during the processing of a request -- by the Browser pipeline. setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty ()-setEventHandler mbH = alterBS (\b -> b { bsEvent=mbH})+setEventHandler mbH = modify (\b -> b { bsEvent=mbH}) buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent buildBrowserEvent bt uri reqID = do- ct <- getClockTime- return BrowserEvent + ct <- getCurrentTime+ return BrowserEvent { browserTimestamp = ct , browserRequestID = reqID , browserRequestURI = uri@@ -650,14 +679,14 @@ reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () reportEvent bt uri = do- st <- getBrowserState+ st <- get case bsEvent st of Nothing -> return () Just evH -> do- evt <- ioAction $ buildBrowserEvent bt uri (bsRequestID st)+ evt <- liftIO $ buildBrowserEvent bt uri (bsRequestID st) evH evt -- if it fails, we fail. --- | The default number of hops we are willing not to go beyond for +-- | The default number of hops we are willing not to go beyond for -- request forwardings. defaultMaxRetries :: Int defaultMaxRetries = 4@@ -683,7 +712,7 @@ -- is returned along with the 'Response' itself. request :: HStream ty => Request ty- -> BrowserAction (HandleStream ty) (URI,Response ty)+ -> BrowserAction (HandleStream ty) (URI,Response ty) request req = nextRequest $ do res <- request' nullVal initialState req reportEvent ResponseFinish (show (rqURI req))@@ -692,21 +721,22 @@ Left e -> do let errStr = ("Network.Browser.request: Error raised " ++ show e) err errStr- fail errStr+ Prelude.fail errStr where initialState = nullRequestState nullVal = buf_empty bufferOps --- | Internal helper function, explicitly carrying along per-request +-- | Internal helper function, explicitly carrying along per-request -- counts. request' :: HStream ty => ty- -> RequestState- -> Request ty- -> BrowserAction (HandleStream ty) (Result (URI,Response ty))+ -> RequestState+ -> Request ty+ -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) request' nullVal rqState rq = do let uri = rqURI rq- let uria = reqURIAuth rq + failHTTPS uri+ let uria = reqURIAuth rq -- add cookies to request cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) {- Not for now:@@ -715,56 +745,56 @@ xs -> case chopAtDelim ':' xs of (_,[]) -> id- (usr,pwd) -> withAuth- AuthBasic{ auUserName = usr+ (usr,pwd) -> withAuth+ AuthBasic{ auUserName = usr , auPassword = pwd- , auRealm = "/"- , auSite = uri- }) $ do+ , auRealm = "/"+ , auSite = uri+ }) $ do -}- when (not $ null cookies) + when (not $ null cookies) (out $ "Adding cookies to request. Cookie names: " ++ unwords (map ckName cookies)) -- add credentials to request- rq' <- - if not (reqStopOnDeny rqState) - then return rq - else do + rq' <-+ if not (reqStopOnDeny rqState)+ then return rq+ else do auth <- anticipateChallenge rq case auth of Nothing -> return rq Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)- let rq'' = insertHeaders (map cookieToHeader cookies) rq'+ let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq' p <- getProxy- def_ua <- getBS bsUserAgent- let defaultOpts = - case p of - NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua}- Proxy _ ath ->- defaultNormalizeRequestOptions- { normForProxy = True- , normUserAgent = def_ua- , normCustoms = - maybe []- (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])- ath- }+ def_ua <- gets bsUserAgent+ let defaultOpts =+ case p of+ NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua}+ Proxy _ ath ->+ defaultNormalizeRequestOptions+ { normForProxy = True+ , normUserAgent = def_ua+ , normCustoms =+ maybe []+ (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])+ ath+ } let final_req = normalizeRequest defaultOpts rq'' out ("Sending:\n" ++ show final_req)- e_rsp <- + e_rsp <- case p of NoProxy -> dorequest (reqURIAuth rq'') final_req Proxy str _ath -> do- let notURI - | null pt || null hst = - URIAuth{ uriUserInfo = ""- , uriRegName = str- , uriPort = ""- }- | otherwise = - URIAuth{ uriUserInfo = ""- , uriRegName = hst- , uriPort = pt- }+ let notURI+ | null pt || null hst =+ URIAuth{ uriUserInfo = ""+ , uriRegName = str+ , uriPort = ""+ }+ | otherwise =+ URIAuth{ uriUserInfo = ""+ , uriRegName = hst+ , uriPort = pt+ } -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! where (hst, pt) = span (':'/=) str -- Proxy can take multiple forms - look for http://host:port first,@@ -775,46 +805,50 @@ (parseURI str) out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth- dorequest proxyURIAuth final_req+ dorequest proxyURIAuth final_req mbMx <- getMaxErrorRetries case e_rsp of- Left v - | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && - (v == ErrorReset || v == ErrorClosed) ->+ Left v+ | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) &&+ (v == ErrorReset || v == ErrorClosed) -> do+ --empty connnection pool in case connection has become invalid+ modify (\b -> b { bsConnectionPool=[] }) request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq- | otherwise -> + | otherwise -> return (Left v)- Right rsp -> do + Right rsp -> do out ("Received:\n" ++ show rsp) -- add new cookies to browser state- handleCookies uri (uriAuthToString $ reqURIAuth rq) + handleCookies uri (uriAuthToString $ reqURIAuth rq) (retrieveHeaders HdrSetCookie rsp)+ -- Deal with "Connection: close" in response.+ handleConnectionClose (reqURIAuth rq) (retrieveHeaders HdrConnection rsp) mbMxAuths <- getMaxAuthAttempts case rspCode rsp of (4,0,1) -- Credentials not sent or refused. | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do out "401 - credentials again refused; exceeded retry count (2)"- return (Right (uri,rsp))- | otherwise -> do+ return (Right (uri,rsp))+ | otherwise -> do out "401 - credentials not supplied or refused; retrying.." let hdrs = retrieveHeaders HdrWWWAuthenticate rsp- flg <- getAllowBasicAuth+ flg <- getAllowBasicAuth case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> do- out "no challenge"- return (Right (uri,rsp)) {- do nothing -}+ out "no challenge"+ return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x case au of Nothing -> do- out "no auth"- return (Right (uri,rsp)) {- do nothing -}+ out "no auth"+ return (Right (uri,rsp)) {- do nothing -} Just au' -> do out "Retrying request with new credentials"- request' nullVal- rqState{ reqDenies = succ(reqDenies rqState)- , reqStopOnDeny = False- }+ request' nullVal+ rqState{ reqDenies = succ(reqDenies rqState)+ , reqStopOnDeny = False+ } (insertHeader HdrAuthorization (withAuthority au' rq) rq) (4,0,7) -- Proxy Authentication required@@ -824,7 +858,7 @@ | otherwise -> do out "407 - proxy authentication required" let hdrs = retrieveHeaders HdrProxyAuthenticate rsp- flg <- getAllowBasicAuth+ flg <- getAllowBasicAuth case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> return (Right (uri,rsp)) {- do nothing -} Just x -> do@@ -832,7 +866,7 @@ case au of Nothing -> return (Right (uri,rsp)) {- do nothing -} Just au' -> do- pxy <- getBS bsProxy+ pxy <- gets bsProxy case pxy of NoProxy -> do err "Proxy authentication required without proxy!"@@ -841,56 +875,56 @@ out "Retrying with proxy authentication" setProxy (Proxy px (Just au')) request' nullVal- rqState{ reqDenies = succ(reqDenies rqState)- , reqStopOnDeny = False- }- rq+ rqState{ reqDenies = succ(reqDenies rqState)+ , reqStopOnDeny = False+ }+ rq - (3,0,x) | x /= 5 -> do+ (3,0,x) | x `elem` [2,3,1,7] -> do out ("30" ++ show x ++ " - redirect")- allow_redirs <- allowRedirect rqState- case allow_redirs of- False -> return (Right (uri,rsp))- _ -> do+ allow_redirs <- allowRedirect rqState+ case allow_redirs of+ False -> return (Right (uri,rsp))+ _ -> do case retrieveHeaders HdrLocation rsp of- [] -> do - err "No Location: header in redirect response"+ [] -> do+ err "No Location: header in redirect response" return (Right (uri,rsp))- (Header _ u:_) -> - case parseURIReference u of+ (Header _ u:_) ->+ case parseURIReference u of Nothing -> do err ("Parse of Location: header in a redirect response failed: " ++ u) return (Right (uri,rsp)) Just newURI- | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do- err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs)- return (Right (uri, rsp))- | otherwise -> do - out ("Redirecting to " ++ show newURI_abs ++ " ...") - + | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do+ err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs)+ return (Right (uri, rsp))+ | otherwise -> do+ out ("Redirecting to " ++ show newURI_abs ++ " ...")+ -- Redirect using GET request method, depending on -- response code. let toGet = x `elem` [2,3] method = if toGet then GET else rqMethod rq rq1 = rq { rqMethod=method, rqURI=newURI_abs } rq2 = if toGet then (replaceHeader HdrContentLength "0") (rq1 {rqBody = nullVal}) else rq1- + request' nullVal- rqState{ reqDenies = 0- , reqRedirects = succ(reqRedirects rqState)- , reqStopOnDeny = True- }+ rqState{ reqDenies = 0+ , reqRedirects = succ(reqRedirects rqState)+ , reqStopOnDeny = True+ } rq2 where- newURI_abs = maybe newURI id (newURI `relativeTo` uri)+ newURI_abs = uriDefaultTo newURI uri (3,0,5) -> case retrieveHeaders HdrLocation rsp of- [] -> do - err "No Location header in proxy redirect response."+ [] -> do+ err "No Location header in proxy redirect response." return (Right (uri,rsp))- (Header _ u:_) -> - case parseURIReference u of+ (Header _ u:_) ->+ case parseURIReference u of Nothing -> do err ("Parse of Location header in a proxy redirect response failed: " ++ u) return (Right (uri,rsp))@@ -898,103 +932,89 @@ out ("Retrying with proxy " ++ show newuri ++ "...") setProxy (Proxy (uriToAuthorityString newuri) Nothing) request' nullVal rqState{ reqDenies = 0- , reqRedirects = 0- , reqRetries = succ (reqRetries rqState)- , reqStopOnDeny = True- }- rq- (3,_,_) -> redirect uri rsp+ , reqRedirects = 0+ , reqRetries = succ (reqRetries rqState)+ , reqStopOnDeny = True+ }+ rq _ -> return (Right (uri,rsp)) - where - redirect uri rsp = do- rd <- getAllowRedirects- mbMxRetries <- getMaxRedirects- if not rd || reqRedirects rqState > fromMaybe defaultMaxRetries mbMxRetries- then return (Right (uri,rsp))- else do- case retrieveHeaders HdrLocation rsp of- [] -> do - err "No Location header in redirect response."- return (Right (uri,rsp))- (Header _ u:_) -> - case parseURIReference u of- Just newURI -> do- let newURI_abs = maybe newURI id (newURI `relativeTo` uri)- out ("Redirecting to " ++ show newURI_abs ++ " ...") - request' nullVal- rqState{ reqDenies = 0- , reqRedirects = succ (reqRedirects rqState)- , reqStopOnDeny = True- }- rq{rqURI=newURI_abs}- Nothing -> do- err ("Parse of Location header in a redirect response failed: " ++ u)- return (Right (uri,rsp))- -- | The internal request handling state machine. dorequest :: (HStream ty) => URIAuth- -> Request ty- -> BrowserAction (HandleStream ty)- (Result (Response ty))+ -> Request ty+ -> BrowserAction (HandleStream ty)+ (Result (Response ty)) dorequest hst rqst = do- pool <- getBS bsConnectionPool- conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool- rsp <- + pool <- gets bsConnectionPool+ let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst+ conn <- liftIO $ filterM (\c -> c `isTCPConnectedTo` EndPoint (uriRegName hst) uPort) pool+ rsp <- case conn of- [] -> do + [] -> do out ("Creating new connection to " ++ uriAuthToString hst)- let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst- reportEvent OpenConnection (show (rqURI rqst))- c <- ioAction $ openStream (uriRegName hst) uPort- updateConnectionPool c- dorequest2 c rqst+ reportEvent OpenConnection (show (rqURI rqst))+ c <- liftIO $ openStream (uriRegName hst) uPort+ updateConnectionPool c+ dorequest2 c rqst (c:_) -> do out ("Recovering connection to " ++ uriAuthToString hst)- reportEvent ReuseConnection (show (rqURI rqst))+ reportEvent ReuseConnection (show (rqURI rqst)) dorequest2 c rqst- case rsp of - Right (Response a b c _) -> + case rsp of+ Right (Response a b c _) -> reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return () return rsp where dorequest2 c r = do- dbg <- getBS bsDebug- st <- getBrowserState- let + dbg <- gets bsDebug+ st <- get+ let onSendComplete = maybe (return ()) (\evh -> do- x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)- (lift (evh x)) st- return ())+ x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)+ runBA st (evh x)+ return ()) (bsEvent st)- ioAction $ + liftIO $ maybe (sendHTTP_notify c r onSendComplete) (\ f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c- sendHTTP_notify c' r onSendComplete)- dbg+ sendHTTP_notify c' r onSendComplete)+ dbg updateConnectionPool :: HStream hTy => HandleStream hTy- -> BrowserAction (HandleStream hTy) ()+ -> BrowserAction (HandleStream hTy) () updateConnectionPool c = do- pool <- getBS bsConnectionPool+ pool <- gets bsConnectionPool let len_pool = length pool+ maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize when (len_pool > maxPoolSize)- (ioAction $ close (last pool))- let pool' - | len_pool > maxPoolSize = init pool- | otherwise = pool- alterBS (\b -> b { bsConnectionPool=c:pool' })+ (liftIO $ close (last pool))+ let pool'+ | len_pool > maxPoolSize = init pool+ | otherwise = pool+ when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' }) return ()- --- | Maximum number of open connections we are willing to have active.-maxPoolSize :: Int-maxPoolSize = 5 +-- | Default maximum number of open connections we are willing to have active.+defaultMaxPoolSize :: Int+defaultMaxPoolSize = 5++cleanConnectionPool :: HStream hTy+ => URIAuth -> BrowserAction (HandleStream hTy) ()+cleanConnectionPool uri = do+ let ep = EndPoint (uriRegName uri) (uriAuthPort Nothing uri)+ pool <- gets bsConnectionPool+ bad <- liftIO $ mapM (\c -> c `isTCPConnectedTo` ep) pool+ let tmp = zip bad pool+ newpool = map snd $ filter (not . fst) tmp+ toclose = map snd $ filter fst tmp+ liftIO $ forM_ toclose close+ modify (\b -> b { bsConnectionPool = newpool })+ handleCookies :: URI -> String -> [Header] -> BrowserAction t () handleCookies _ _ [] = return () -- cut short the silliness. handleCookies uri dom cookieHeaders = do@@ -1003,13 +1023,22 @@ when (not $ null newCookies) (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies) filterfn <- getCookieFilter- newCookies' <- ioAction (filterM (filterfn uri) newCookies)+ newCookies' <- liftIO (filterM (filterfn uri) newCookies) when (not $ null newCookies') (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies')) mapM_ addCookie newCookies' where (errs, newCookies) = processCookieHeaders dom cookieHeaders +handleConnectionClose :: HStream hTy+ => URIAuth -> [Header]+ -> BrowserAction (HandleStream hTy) ()+handleConnectionClose _ [] = return ()+handleConnectionClose uri headers = do+ let doClose = any (== "close") $ map headerToConnType headers+ when doClose $ cleanConnectionPool uri+ where headerToConnType (Header _ t) = map toLower t+ ------------------------------------------------------------------ ----------------------- Miscellaneous ---------------------------- ------------------------------------------------------------------@@ -1030,7 +1059,11 @@ -- If the second argument is not sufficient context for determining -- a full URI then anarchy reins. uriDefaultTo :: URI -> URI -> URI+#if MIN_VERSION_network(2,4,0)+uriDefaultTo a b = a `relativeTo` b+#else uriDefaultTo a b = maybe a id (a `relativeTo` b)+#endif -- This form junk is completely untested...@@ -1055,5 +1088,4 @@ , rqURI=u } _ -> error ("unexpected request: " ++ show m)-
Network/BufferType.hs view
@@ -3,10 +3,10 @@ -- | -- Module : Network.BufferType -- Description : Abstract representation of request and response buffer types.--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne+-- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -18,10 +18,10 @@ -- -- This module provides definitions for the standard buffer types that the -- package supports, i.e., for @String@ and @ByteString@ (strict and lazy.)--- +-- ----------------------------------------------------------------------------- module Network.BufferType- ( + ( BufferType(..) , BufferOp(..)@@ -44,7 +44,7 @@ -- that the library requires to operate over data embedded in HTTP -- requests and responses. That is, we use explicit dictionaries -- for the operations, but overload the name of the dicts themselves.--- +-- class BufferType bufType where bufferOps :: BufferOp bufType @@ -57,7 +57,7 @@ instance BufferType String where bufferOps = stringBufferOp --- | @BufferOp@ encodes the I/O operations of the underlying buffer over +-- | @BufferOp@ encodes the I/O operations of the underlying buffer over -- a Handle in an (explicit) dictionary type. May not be needed, but gives -- us flexibility in explicit overriding and wrapping up of these methods. --@@ -67,7 +67,7 @@ -- -- We supply three default @BufferOp@ values, for @String@ along with the -- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@--- definitions for +-- definitions for data BufferOp a = BufferOp { buf_hGet :: Handle -> Int -> IO a@@ -92,8 +92,8 @@ -- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, -- the non-lazy kind. strictBufferOp :: BufferOp Strict.ByteString-strictBufferOp = - BufferOp +strictBufferOp =+ BufferOp { buf_hGet = Strict.hGet , buf_hGetContents = Strict.hGetContents , buf_hPut = Strict.hPut@@ -108,7 +108,7 @@ , buf_empty = Strict.empty , buf_isLineTerm = \ b -> Strict.length b == 2 && p_crlf == b || Strict.length b == 1 && p_lf == b- , buf_isEmpty = Strict.null + , buf_isEmpty = Strict.null } where p_crlf = Strict.pack crlf@@ -117,8 +117,8 @@ -- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, -- the non-strict kind. lazyBufferOp :: BufferOp Lazy.ByteString-lazyBufferOp = - BufferOp +lazyBufferOp =+ BufferOp { buf_hGet = Lazy.hGet , buf_hGetContents = Lazy.hGetContents , buf_hPut = Lazy.hPut@@ -133,7 +133,7 @@ , buf_empty = Lazy.empty , buf_isLineTerm = \ b -> Lazy.length b == 2 && p_crlf == b || Lazy.length b == 1 && p_lf == b- , buf_isEmpty = Lazy.null + , buf_isEmpty = Lazy.null } where p_crlf = Lazy.pack crlf@@ -143,7 +143,7 @@ -- It is defined in terms of @strictBufferOp@ operations, -- unpacking/converting to @String@ when needed. stringBufferOp :: BufferOp String-stringBufferOp =BufferOp +stringBufferOp =BufferOp { buf_hGet = \ h n -> buf_hGet strictBufferOp h n >>= return . Strict.unpack , buf_hGetContents = \ h -> buf_hGetContents strictBufferOp h >>= return . Strict.unpack , buf_hPut = \ h s -> buf_hPut strictBufferOp h (Strict.pack s)@@ -154,11 +154,11 @@ , buf_toStr = id , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] , buf_splitAt = splitAt- , buf_span = \ p a -> + , buf_span = \ p a -> case Strict.span p (Strict.pack a) of- (x,y) -> (Strict.unpack x, Strict.unpack y)+ (x,y) -> (Strict.unpack x, Strict.unpack y) , buf_empty = [] , buf_isLineTerm = \ b -> b == crlf || b == lf- , buf_isEmpty = null + , buf_isEmpty = null }
Network/HTTP.hs view
@@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop+-- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -27,26 +27,31 @@ -- namespace, letting you either use the default implementation here -- by importing @Network.HTTP@ or, for more specific uses, selectively -- import the modules in @Network.HTTP.*@. To wit, more than one kind of--- representation of the bulk data that flows across a HTTP connection is +-- representation of the bulk data that flows across a HTTP connection is -- supported. (see "Network.HTTP.HandleStream".)--- +-- -- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission. -- Normalization such as having the request path be in the expected form and, possibly,--- introduce a default @Host:@ header if one isn't already present. If you do not +-- introduce a default @Host:@ header if one isn't already present.+-- Normalization also takes the @"user:pass\@"@ portion out of the the URI,+-- if it was supplied, and converts it into @Authorization: Basic$ header.+-- If you do not -- want the requests tampered with, but sent as-is, please import and use the -- the "Network.HTTP.HandleStream" or "Network.HTTP.Stream" modules instead. They--- export the same functions, but leaves construction and any normalization of +-- export the same functions, but leaves construction and any normalization of -- @Request@s to the user. --+-- /NOTE:/ This package only supports HTTP; it does not support HTTPS.+-- Attempts to use HTTPS result in an error. ------------------------------------------------------------------------------module Network.HTTP +module Network.HTTP ( module Network.HTTP.Base , module Network.HTTP.Headers - {- the functionality that the implementation modules, - Network.HTTP.HandleStream and Network.HTTP.Stream,- exposes:- -}+ {- the functionality that the implementation modules,+ Network.HTTP.HandleStream and Network.HTTP.Stream,+ exposes:+ -} , simpleHTTP -- :: Request -> IO (Result Response) , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response)@@ -55,11 +60,14 @@ , respondHTTP -- :: Stream s => s -> Response -> IO () , module Network.TCP- + , getRequest -- :: String -> Request_String+ , headRequest -- :: String -> Request_String , postRequest -- :: String -> Request_String- - , getResponseBody -- :: Requesty ty -> ty+ , postRequestWithBody -- :: String -> String -> String -> Request_String++ , getResponseBody -- :: Result (Request ty) -> IO ty+ , getResponseCode -- :: Result (Request ty) -> IO ResponseCode ) where -----------------------------------------------------------------@@ -97,13 +105,14 @@ simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty)) simpleHTTP r = do auth <- getAuth r+ failHTTPS (rqURI r) c <- openStream (host auth) (fromMaybe 80 (port auth)) let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r simpleHTTP_ c norm_r- + -- | Identical to 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))-simpleHTTP_ s r = do +simpleHTTP_ s r = do let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r S.sendHTTP s norm_r @@ -112,7 +121,7 @@ -- closed upon receiving the response. sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) sendHTTP conn rq = do- let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP conn norm_r -- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but@@ -121,11 +130,11 @@ -- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty- -> Request ty- -> IO ()- -> IO (Result (Response ty))+ -> Request ty+ -> IO ()+ -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do- let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP_notify conn norm_r onSendComplete -- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@@@ -138,22 +147,57 @@ respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () respondHTTP conn rsp = S.respondHTTP conn rsp --- | @getRequest urlString@ is convenience constructor for basic GET 'Request's. If--- @urlString@ isn't a syntactically valid URL, the function raises an error.-getRequest :: String -> Request_String-getRequest urlString = ++-- | A convenience constructor for a GET 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+getRequest+ :: String -- ^URL to fetch+ -> Request_String -- ^The constructed request+getRequest urlString = case parseURI urlString of Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest GET u --- | @postRequest urlString@ is convenience constructor for POST 'Request's. If--- @urlString@ isn\'t a syntactically valid URL, the function raises an error.-postRequest :: String -> Request_String-postRequest urlString = +-- | A convenience constructor for a HEAD 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+headRequest+ :: String -- ^URL to fetch+ -> Request_String -- ^The constructed request+headRequest urlString = case parseURI urlString of+ Nothing -> error ("headRequest: Not a valid URL - " ++ urlString)+ Just u -> mkRequest HEAD u++-- | A convenience constructor for a POST 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+postRequest+ :: String -- ^URL to POST to+ -> Request_String -- ^The constructed request+postRequest urlString =+ case parseURI urlString of Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest POST u +-- | A convenience constructor for a POST 'Request'.+--+-- It constructs a request and sets the body as well as+-- the Content-Type and Content-Length headers. The contents of the body+-- are forced to calculate the value for the Content-Length header.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+postRequestWithBody+ :: String -- ^URL to POST to+ -> String -- ^Content-Type of body+ -> String -- ^The body of the request+ -> Request_String -- ^The constructed request+postRequestWithBody urlString typ body =+ case parseURI urlString of+ Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString)+ Just u -> setRequestBody (mkRequest POST u) (typ, body)+ -- | @getResponseBody response@ takes the response of a HTTP requesting action and -- tries to extricate the body of the 'Response' @response@. If the request action -- returned an error, an IO exception is raised.@@ -161,6 +205,14 @@ getResponseBody (Left err) = fail (show err) getResponseBody (Right r) = return (rspBody r) +-- | @getResponseCode response@ takes the response of a HTTP requesting action and+-- tries to extricate the status code of the 'Response' @response@. If the request action+-- returned an error, an IO exception is raised.+getResponseCode :: Result (Response ty) -> IO ResponseCode+getResponseCode (Left err) = fail (show err)+getResponseCode (Right r) = return (rspCode r)++ -- -- * TODO -- - request pipelining@@ -170,21 +222,21 @@ -- - comm timeouts -- - MIME & entity stuff (happening in separate module) -- - support \"*\" uri-request-string for OPTIONS request method--- --- +--+-- -- * Header notes: -- -- [@Host@] -- Required by HTTP\/1.1, if not supplied as part -- of a request a default Host value is extracted -- from the request-uri.--- --- [@Connection@] +--+-- [@Connection@] -- If this header is present in any request or -- response, and it's value is "close", then--- the current request\/response is the last +-- the current request\/response is the last -- to be allowed on that connection.--- +-- -- [@Expect@] -- Should a request contain a body, an Expect -- header will be added to the request. The added@@ -192,7 +244,7 @@ -- a 417 \"Expectation Failed\" response the request -- is attempted again without this added Expect -- header.--- +-- -- [@TransferEncoding,ContentLength,...@] -- if request is inconsistent with any of these -- header values then you may not receive any response@@ -205,7 +257,7 @@ -- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. -- \"101 Upgrade\" will be returned. -- Other 1xx responses are ignored.--- +-- -- [@417@] The reason for this code is \"Expectation failed\", indicating -- that the server did not like the Expect \"100-continue\" header -- added to a request. Receipt of 417 will induce another
Network/HTTP/Auth.hs view
@@ -1,16 +1,17 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Auth--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne+-- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- Representing HTTP Auth values in Haskell. -- Right now, it contains mostly functionality needed by 'Network.Browser'.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Auth ( Authority(..)@@ -26,7 +27,7 @@ import Network.HTTP.Base import Network.HTTP.Utils import Network.HTTP.Headers ( Header(..) )-import qualified Network.HTTP.MD5 as MD5 (hash)+import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str)) import qualified Network.HTTP.Base64 as Base64 (encode) import Text.ParserCombinators.Parsec ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 )@@ -37,7 +38,7 @@ -- | @Authority@ specifies the HTTP Authentication method to use for -- a given domain/realm; @Basic@ or @Digest@.-data Authority +data Authority = AuthBasic { auRealm :: String , auUsername :: String , auPassword :: String@@ -54,7 +55,7 @@ } -data Challenge +data Challenge = ChalBasic { chRealm :: String } | ChalDigest { chRealm :: String , chDomain :: [URI]@@ -73,29 +74,29 @@ show AlgMD5 = "md5" show AlgMD5sess = "md5-sess" --- | +-- | data Qop = QopAuth | QopAuthInt deriving(Eq,Show) -- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority', -- in the context of the given request.--- +-- -- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String withAuthority :: Authority -> Request ty -> String withAuthority a rq = case a of AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) AuthDigest{} -> "Digest " ++- concat [ "username=" ++ quo (auUsername a)- , ",realm=" ++ quo (auRealm a)- , ",nonce=" ++ quo (auNonce a)- , ",uri=" ++ quo digesturi- , ",response=" ++ quo rspdigest+ concat [ "username=" ++ quo (auUsername a)+ , ",realm=" ++ quo (auRealm a)+ , ",nonce=" ++ quo (auNonce a)+ , ",uri=" ++ quo digesturi+ , ",response=" ++ quo rspdigest -- plus optional stuff:- , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))- , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a))- , if null (auQop a) then "" else ",qop=auth"- ]+ , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))+ , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a))+ , if null (auQop a) then "" else ",qop=auth"+ ] where quo s = '"':s ++ "\"" @@ -103,7 +104,7 @@ a1, a2 :: String a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a- + {- If the "qop" directive's value is "auth" or is unspecified, then A2 is:@@ -122,14 +123,11 @@ stringToOctets :: String -> [Octet] stringToOctets = map (fromIntegral . fromEnum) -octetsToString :: [Octet] -> String-octetsToString = map (toEnum . fromIntegral)- base64encode :: String -> String base64encode = Base64.encode . stringToOctets md5 :: String -> String-md5 = octetsToString . MD5.hash . stringToOctets+md5 = MD5.md5s . MD5.Str kd :: String -> String -> String kd a b = md5 (a ++ ":" ++ b)@@ -137,7 +135,7 @@ --- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header +-- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header -- @www_auth@ into a 'Challenge' value. headerToChallenge :: URI -> Header -> Maybe Challenge headerToChallenge baseURI (Header _ str) =@@ -158,11 +156,11 @@ cprops = sepBy1 cprop comma - comma = do { spaces ; char ',' ; spaces }+ comma = do { spaces ; _ <- char ',' ; spaces } cprop = do { nm <- word- ; char '='+ ; _ <- char '=' ; val <- quotedstring ; return (map toLower nm,val) }@@ -175,12 +173,12 @@ -- with Maybe monad do { r <- lookup "realm" params ; n <- lookup "nonce" params- ; return $ + ; return $ ChalDigest { chRealm = r- , chDomain = (annotateURIs + , chDomain = (annotateURIs $ map parseURI- $ words - $ fromMaybe [] + $ words+ $ fromMaybe [] $ lookup "domain" params) , chNonce = n , chOpaque = lookup "opaque" params@@ -192,7 +190,11 @@ } annotateURIs :: [Maybe URI] -> [URI]+#if MIN_VERSION_network(2,4,0)+ annotateURIs = map (`relativeTo` baseURI) . catMaybes+#else annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes+#endif -- Change These: readQop :: String -> [Qop]@@ -210,9 +212,9 @@ word, quotedstring :: Parser String quotedstring =- do { char '"' -- "+ do { _ <- char '"' -- " ; str <- many (satisfy $ not . (=='"'))- ; char '"'+ ; _ <- char '"' ; return str }
Network/HTTP/Base.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Base--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne+-- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -26,12 +27,12 @@ , Request(..) , Response(..) , RequestMethod(..)- + , Request_String , Response_String , HTTPRequest , HTTPResponse- + -- ** URL Encoding , urlEncode , urlDecode@@ -40,7 +41,7 @@ -- ** URI authority parsing , URIAuthority(..) , parseURIAuthority- + -- internal , uriToAuthorityString -- :: URI -> String , uriAuthToString -- :: URIAuth -> String@@ -55,8 +56,8 @@ , ResponseData , ResponseCode , RequestData- - , NormalizeRequestOptions(..) ++ , NormalizeRequestOptions(..) , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty , RequestNormalizer @@ -76,23 +77,27 @@ , uglyDeathTransfer , readTillEmpty1 , readTillEmpty2- + , defaultGETRequest , defaultGETRequest_ , mkRequest+ , setRequestBody , defaultUserAgent+ , httpPackageVersion , libUA {- backwards compatibility, will disappear..soon -}- + , catchIO , catchIO_ , responseParseError- + , getRequestVersion , getResponseVersion , setRequestVersion , setResponseVersion- ++ , failHTTPS+ ) where import Network.URI@@ -102,9 +107,11 @@ ) import Control.Monad ( guard )-import Control.Monad.Error ()++import Data.Bits ( (.&.), (.|.), shiftL, shiftR )+import Data.Word ( Word8 ) import Data.Char ( digitToInt, intToDigit, toLower, isDigit,- isAscii, isAlphaNum )+ isAscii, isAlphaNum, ord, chr ) import Data.List ( partition, find ) import Data.Maybe ( listToMaybe, fromMaybe ) import Numeric ( readHex )@@ -113,22 +120,26 @@ import Network.BufferType ( BufferOp(..), BufferType(..) ) import Network.HTTP.Headers import Network.HTTP.Utils ( trim, crlf, sp, readsOne )+import qualified Network.HTTP.Base64 as Base64 (encode) import Text.Read.Lex (readDecP) import Text.ParserCombinators.ReadP- ( ReadP, readP_to_S, char, (<++), look, munch )+ ( ReadP, readP_to_S, char, (<++), look, munch, munch1 ) -import Control.Exception as Exception (IOException)+import Control.Exception as Exception (catch, IOException) +import qualified Paths_HTTP as Self (version)+import Data.Version (showVersion)+ ----------------------------------------------------------------- ------------------ URI Authority parsing ------------------------ ----------------------------------------------------------------- -data URIAuthority = URIAuthority { user :: Maybe String, - password :: Maybe String,- host :: String,- port :: Maybe Int- } deriving (Eq,Show)+data URIAuthority = URIAuthority { user :: Maybe String,+ password :: Maybe String,+ host :: String,+ port :: Maybe Int+ } deriving (Eq,Show) -- | Parse the authority part of a URL. --@@ -143,18 +154,26 @@ pURIAuthority :: ReadP URIAuthority pURIAuthority = do- (u,pw) <- (pUserInfo `before` char '@') - <++ return (Nothing, Nothing)- h <- munch (/=':')- p <- orNothing (char ':' >> readDecP)- look >>= guard . null - return URIAuthority{ user=u, password=pw, host=h, port=p }+ (u,pw) <- (pUserInfo `before` char '@')+ <++ return (Nothing, Nothing)+ h <- rfc2732host <++ munch (/=':')+ p <- orNothing (char ':' >> readDecP)+ look >>= guard . null+ return URIAuthority{ user=u, password=pw, host=h, port=p } +-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL+rfc2732host :: ReadP String+rfc2732host = do+ _ <- char '['+ res <- munch1 (/=']')+ _ <- char ']'+ return res+ pUserInfo :: ReadP (Maybe String, Maybe String) pUserInfo = do- u <- orNothing (munch (`notElem` ":@"))- p <- orNothing (char ':' >> munch (/='@'))- return (u,p)+ u <- orNothing (munch (`notElem` ":@"))+ p <- orNothing (char ':' >> munch (/='@'))+ return (u,p) before :: Monad m => m a -> m b -> m a before a b = a >>= \x -> b >> return x@@ -167,20 +186,20 @@ uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) uriAuthToString :: URIAuth -> String-uriAuthToString ua = - concat [ uriUserInfo ua +uriAuthToString ua =+ concat [ uriUserInfo ua , uriRegName ua- , uriPort ua- ]+ , uriPort ua+ ] uriAuthPort :: Maybe URI -> URIAuth -> Int-uriAuthPort mbURI u = +uriAuthPort mbURI u = case uriPort u of (':':s) -> readsOne id (default_port mbURI) s _ -> default_port mbURI where default_port Nothing = default_http- default_port (Just url) = + default_port (Just url) = case map toLower $ uriScheme url of "http:" -> default_http "https:" -> default_https@@ -190,21 +209,30 @@ default_http = 80 default_https = 443 +#if MIN_VERSION_base(4,13,0)+failHTTPS :: MonadFail m => URI -> m ()+#else+failHTTPS :: Monad m => URI -> m ()+#endif+failHTTPS uri+ | map toLower (uriScheme uri) == "https:" = fail "https not supported"+ | otherwise = return ()+ -- Fish out the authority from a possibly normalized Request, i.e., -- the information may either be in the request's URI or inside -- the Host: header. reqURIAuth :: Request ty -> URIAuth-reqURIAuth req = +reqURIAuth req = case uriAuthority (rqURI req) of Just ua -> ua _ -> case lookupHeader HdrHost (rqHeaders req) of Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req)- Just h -> - case toHostPort h of- (ht,p) -> URIAuth { uriUserInfo = ""- , uriRegName = ht- , uriPort = p- }+ Just h ->+ case toHostPort h of+ (ht,p) -> URIAuth { uriUserInfo = ""+ , uriRegName = ht+ , uriPort = p+ } where -- Note: just in case you're wondering..the convention is to include the ':' -- in the port part..@@ -227,7 +255,7 @@ deriving(Eq) instance Show RequestMethod where- show x = + show x = case x of HEAD -> "HEAD" PUT -> "PUT"@@ -241,18 +269,18 @@ rqMethodMap :: [(String, RequestMethod)] rqMethodMap = [("HEAD", HEAD),- ("PUT", PUT),- ("GET", GET),- ("POST", POST),+ ("PUT", PUT),+ ("GET", GET),+ ("POST", POST), ("DELETE", DELETE),- ("OPTIONS", OPTIONS),- ("TRACE", TRACE),- ("CONNECT", CONNECT)]+ ("OPTIONS", OPTIONS),+ ("TRACE", TRACE),+ ("CONNECT", CONNECT)] --- +-- -- for backwards-ish compatibility; suggest -- migrating to new Req/Resp by adding type param.--- +-- type Request_String = Request String type Response_String = Response String @@ -285,9 +313,9 @@ show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf where- ver = fromMaybe httpVersion (getRequestVersion req)- alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' - then u { uriPath = '/' : uriPath u } + ver = fromMaybe httpVersion (getRequestVersion req)+ alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/'+ then u { uriPath = '/' : uriPath u } else u instance HasHeaders (Request a) where@@ -304,7 +332,7 @@ type ResponseData = (ResponseCode,String,[Header]) -- | @RequestData@ contains the head of a HTTP request; method,--- its URL along with the auxillary/supporting header data.+-- its URL along with the auxiliary/supporting header data. type RequestData = (RequestMethod,URI,[Header]) -- | An HTTP Response.@@ -318,8 +346,8 @@ , rspHeaders :: [Header] , rspBody :: a }- --- This is an invalid representation of a received response, ++-- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1 instance Show (Response a) where show rsp@(Response (a,b,c) reason headers _) =@@ -336,27 +364,41 @@ ------------------------------------------------------------------ ------------------ Request Building ------------------------------ ------------------------------------------------------------------++-- | Deprecated. Use 'defaultUserAgent' libUA :: String libUA = "hs-HTTP-4000.0.9"+{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-} +-- | A default user agent string. The string is @\"haskell-HTTP/$version\"@+-- where @$version@ is the version of this HTTP package.+-- defaultUserAgent :: String-defaultUserAgent = libUA+defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion +-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This+-- may be useful to include in a user agent string so that you can determine+-- from server logs what version of this package HTTP clients are using.+-- This can be useful for tracking down HTTP compatibility quirks.+--+httpPackageVersion :: String+httpPackageVersion = showVersion Self.version+ defaultGETRequest :: URI -> Request_String defaultGETRequest uri = defaultGETRequest_ uri defaultGETRequest_ :: BufferType a => URI -> Request a-defaultGETRequest_ uri = mkRequest GET uri +defaultGETRequest_ uri = mkRequest GET uri -- | 'mkRequest method uri' constructs a well formed -- request for the given HTTP method and URI. It does not--- normalize the URI for the request _nor_ add the required +-- normalize the URI for the request _nor_ add the required -- Host: header. That is done either explicitly by the user -- or when requests are normalized prior to transmission. mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty mkRequest meth uri = req where- req = + req = Request { rqURI = uri , rqBody = empty , rqHeaders = [ Header HdrContentLength "0"@@ -367,16 +409,24 @@ empty = buf_empty (toBufOps req) +-- set rqBody, Content-Type and Content-Length headers.+setRequestBody :: Request_String -> (String, String) -> Request_String+setRequestBody req (typ, body) = req' { rqBody=body }+ where+ req' = replaceHeader HdrContentType typ .+ replaceHeader HdrContentLength (show $ length body) $+ req+ {- -- stub out the user info. updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri) - withHost = + withHost = case uriToAuthorityString uri{uriAuthority=updAuth} of "" -> id h -> ((Header HdrHost h):) - uri_req + uri_req | forProxy = uri | otherwise = snd (splitRequestURI uri) -}@@ -422,12 +472,12 @@ where responseStatus _l _yes@(version:code:reason) = return (version,match code,concatMap (++" ") reason)- responseStatus l _no + responseStatus l _no | null l = failWith ErrorClosed -- an assumption | otherwise = parse_err l - parse_err l = - responseParseError + parse_err l =+ responseParseError "parseResponseHead" ("Response status line parse failure: " ++ l) @@ -445,7 +495,7 @@ -- the version info explicitly in their record types. You have to use -- {get,set}{Request,Response}Version for that. withVersion :: String -> [Header] -> [Header]-withVersion v hs +withVersion v hs | v == httpVersion = hs -- don't bother adding it if the default. | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs @@ -461,7 +511,7 @@ -- | @getResponseVersion rsp@ returns the HTTP protocol version of--- the response @rsp@. If @Nothing@, the default 'httpVersion' can be +-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be -- assumed. getResponseVersion :: Response a -> Maybe String getResponseVersion r = getHttpVersion r@@ -476,7 +526,7 @@ -- version info is represented internally. getHttpVersion :: HasHeaders a => a -> Maybe String-getHttpVersion r = +getHttpVersion r = fmap toVersion $ find isHttpVersion $ getHeaders r@@ -484,7 +534,7 @@ toVersion (Header _ x) = x setHttpVersion :: HasHeaders a => a -> String -> a-setHttpVersion r v = +setHttpVersion r v = setHeaders r $ withVersion v $ dropHttpVersion $@@ -495,7 +545,7 @@ isHttpVersion :: Header -> Bool isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True-isHttpVersion _ = False +isHttpVersion _ = False @@ -529,9 +579,9 @@ where ans | rqst == HEAD = Done | otherwise = ExpectEntity- - ++ ----------------------------------------------------------------- ------------------ A little friendly funtionality --------------- -----------------------------------------------------------------@@ -555,33 +605,102 @@ Escape method: char -> '%' a b where a, b :: Hex digits -} +replacement_character :: Char+replacement_character = '\xfffd'++-- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format.+--+-- Shamelessly stolen from utf-8string-0.3.7+encodeChar :: Char -> [Word8]+encodeChar = map fromIntegral . go . ord+ where+ go oc+ | oc <= 0x7f = [oc]++ | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6)+ , 0x80 + oc .&. 0x3f+ ]++ | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12)+ , 0x80 + ((oc `shiftR` 6) .&. 0x3f)+ , 0x80 + oc .&. 0x3f+ ]+ | otherwise = [ 0xf0 + (oc `shiftR` 18)+ , 0x80 + ((oc `shiftR` 12) .&. 0x3f)+ , 0x80 + ((oc `shiftR` 6) .&. 0x3f)+ , 0x80 + oc .&. 0x3f+ ]++-- | Decode a UTF8 string packed into a list of Word8 values, directly to String+--+-- Shamelessly stolen from utf-8string-0.3.7+decode :: [Word8] -> String+decode [ ] = ""+decode (c:cs)+ | c < 0x80 = chr (fromEnum c) : decode cs+ | c < 0xc0 = replacement_character : decode cs+ | c < 0xe0 = multi1+ | c < 0xf0 = multi_byte 2 0xf 0x800+ | c < 0xf8 = multi_byte 3 0x7 0x10000+ | c < 0xfc = multi_byte 4 0x3 0x200000+ | c < 0xfe = multi_byte 5 0x1 0x4000000+ | otherwise = replacement_character : decode cs+ where+ multi1 = case cs of+ c1 : ds | c1 .&. 0xc0 == 0x80 ->+ let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f)+ in if d >= 0x000080 then toEnum d : decode ds+ else replacement_character : decode ds+ _ -> replacement_character : decode cs++ multi_byte :: Int -> Word8 -> Int -> [Char]+ multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))+ where+ aux 0 rs acc+ | overlong <= acc && acc <= 0x10ffff &&+ (acc < 0xd800 || 0xdfff < acc) &&+ (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs+ | otherwise = replacement_character : decode rs++ aux n (r:rs) acc+ | r .&. 0xc0 == 0x80 = aux (n-1) rs+ $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)++ aux _ rs _ = replacement_character : decode rs+++-- This function is a bit funny because potentially the input String could contain some actual Unicode+-- characters (though this shouldn't happen for most use cases), so we have to preserve those characters+-- while simultaneously decoding any UTF-8 data urlDecode :: String -> String-urlDecode ('%':a:b:rest) = toEnum (16 * digitToInt a + digitToInt b)- : urlDecode rest-urlDecode (h:t) = h : urlDecode t-urlDecode [] = []+urlDecode = go []+ where+ go bs ('%':a:b:rest) = go (fromIntegral (16 * digitToInt a + digitToInt b) : bs) rest+ go bs (h:t) | fromEnum h < 256 = go (fromIntegral (fromEnum h) : bs) t -- Treat ASCII as just another byte of UTF-8+ go [] [] = []+ go [] (h:t) = h : go [] t -- h >= 256, so can't be part of any UTF-8 byte sequence+ go bs rest = decode (reverse bs) ++ go [] rest urlEncode :: String -> String urlEncode [] = []-urlEncode (ch:t) +urlEncode (ch:t) | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t- | not (isAscii ch) = foldr escape (urlEncode t) (eightBs [] (fromEnum ch))- | otherwise = escape (fromEnum ch) (urlEncode t)+ | not (isAscii ch) = foldr escape (urlEncode t) (encodeChar ch)+ | otherwise = escape (fromIntegral (fromEnum ch)) (urlEncode t) where escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs)- ++ showH :: Word8 -> String -> String showH x xs- | x <= 9 = toEnum (o_0 + x) : xs- | otherwise = toEnum (o_A + (x-10)) : xs+ | x <= 9 = to (o_0 + x) : xs+ | otherwise = to (o_A + (x-10)) : xs where- o_0 = fromEnum '0'- o_A = fromEnum 'A'+ to = toEnum . fromIntegral+ fro = fromIntegral . fromEnum - eightBs :: [Int] -> Int -> [Int]- eightBs acc x- | x <= 0xff = (x:acc)- | otherwise = eightBs ((x `mod` 256) : acc) (x `div` 256)+ o_0 = fro '0'+ o_A = fro 'A' -- Encode form variables, useable in either the -- query part of a URI, or the body of a POST request.@@ -598,24 +717,28 @@ -- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ -- header.+#if MIN_VERSION_base(4,13,0)+getAuth :: MonadFail m => Request ty -> m URIAuthority+#else getAuth :: Monad m => Request ty -> m URIAuthority-getAuth r = +#endif+getAuth r = -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) case parseURIAuthority auth of- Just x -> return x + Just x -> return x Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'"- where + where auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r) uri = rqURI r {-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty-normalizeRequestURI doClose h r = +normalizeRequestURI doClose h r = (if doClose then replaceHeader HdrConnection "close" else id) $ insertHeaderIfMissing HdrHost h $ r { rqURI = (rqURI r){ uriScheme = "" , uriAuthority = Nothing- }}+ }} -- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options -- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option@@ -644,72 +767,90 @@ -- via the @NormalizeRequestOptions@ record. normalizeRequest :: NormalizeRequestOptions ty -> Request ty- -> Request ty+ -> Request ty normalizeRequest opts req = foldr (\ f -> f opts) req normalizers where --normalizers :: [RequestNormalizer ty]- normalizers = + normalizers = ( normalizeHostURI+ : normalizeBasicAuth : normalizeConnectionClose- : normalizeUserAgent + : normalizeUserAgent : normCustoms opts ) --- | @normalizeUserAgent ua x req@ augments the request @req@ with --- a @User-Agent: ua@ header if @req@ doesn't already have a +-- | @normalizeUserAgent ua x req@ augments the request @req@ with+-- a @User-Agent: ua@ header if @req@ doesn't already have a -- a @User-Agent:@ set. normalizeUserAgent :: RequestNormalizer ty-normalizeUserAgent opts req = +normalizeUserAgent opts req = case normUserAgent opts of Nothing -> req- Just ua -> + Just ua -> case findHeader HdrUserAgent req of Just u | u /= defaultUserAgent -> req _ -> replaceHeader HdrUserAgent ua req --- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ +-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ -- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then -- _replaces_ any an existing @Connection:@ header in @req@. normalizeConnectionClose :: RequestNormalizer ty-normalizeConnectionClose opts req +normalizeConnectionClose opts req | normDoClose opts = replaceHeader HdrConnection "close" req | otherwise = req +-- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@+-- if the "user:pass@" part is present in the "http://user:pass@host/path"+-- of the URI. If Authorization header was present already it is not replaced.+normalizeBasicAuth :: RequestNormalizer ty+normalizeBasicAuth _ req =+ case getAuth req of+ Just uriauth ->+ case (user uriauth, password uriauth) of+ (Just u, Just p) ->+ insertHeaderIfMissing HdrAuthorization astr req+ where+ astr = "Basic " ++ base64encode (u ++ ":" ++ p)+ base64encode = Base64.encode . stringToOctets :: String -> String+ stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8]+ (_, _) -> req+ Nothing ->req+ -- | @normalizeHostURI forProxy req@ rewrites your request to have it -- follow the expected formats by the receiving party (proxy or server.)--- +-- normalizeHostURI :: RequestNormalizer ty-normalizeHostURI opts req = +normalizeHostURI opts req = case splitRequestURI uri of ("",_uri_abs)- | forProxy -> + | forProxy -> case findHeader HdrHost req of- Nothing -> req -- no host/authority in sight..not much we can do.- Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}- , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri- }}- where - hst = case span (/='@') user_hst of- (as,'@':bs) -> - case span (/=':') as of- (_,_:_) -> bs- _ -> user_hst- _ -> user_hst+ Nothing -> req -- no host/authority in sight..not much we can do.+ Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}+ , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri+ }}+ where+ hst = case span (/='@') user_hst of+ (as,'@':bs) ->+ case span (/=':') as of+ (_,_:_) -> bs+ _ -> user_hst+ _ -> user_hst - (user_hst, pNum) = - case span isDigit (reverse h) of- (ds,':':bs) -> (reverse bs, ':':reverse ds)- _ -> (h,"")- | otherwise -> + (user_hst, pNum) =+ case span isDigit (reverse h) of+ (ds,':':bs) -> (reverse bs, ':':reverse ds)+ _ -> (h,"")+ | otherwise -> case findHeader HdrHost req of- Nothing -> req -- no host/authority in sight..not much we can do...complain?- Just{} -> req- (h,uri_abs) - | forProxy -> insertHeaderIfMissing HdrHost h req + Nothing -> req -- no host/authority in sight..not much we can do...complain?+ Just{} -> req+ (h,uri_abs)+ | forProxy -> insertHeaderIfMissing HdrHost h req | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass where- uri0 = rqURI req - -- stub out the user:pass + uri0 = rqURI req+ -- stub out the user:pass uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} forProxy = normForProxy opts@@ -720,7 +861,7 @@ resource on an origin server or gateway. In this case the absolute path of the URI MUST be transmitted (see section 3.2.1, abs_path) as the Request-URI, and the network location of the URI (authority) MUST- be transmitted in a Host header field." + be transmitted in a Host header field." We assume that this is the case, so we take the host name from the Host header if there is one, otherwise from the request-URI. Then we make the request-URI an abs_path and make sure that there@@ -733,18 +874,18 @@ -- Adds a Host header if one is NOT ALREADY PRESENT.. {-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeHostHeader :: Request ty -> Request ty-normalizeHostHeader rq = +normalizeHostHeader rq = insertHeaderIfMissing HdrHost (uriToAuthorityString $ rqURI rq)- rq- + rq+ -- Looks for a "Connection" header with the value "close". -- Returns True when this is found. findConnClose :: [Header] -> Bool findConnClose hdrs = maybe False (\ x -> map toLower (trim x) == "close")- (lookupHeader HdrConnection hdrs)+ (lookupHeader HdrConnection hdrs) -- | Used when we know exactly how many bytes to expect. linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))@@ -756,20 +897,20 @@ -- take data once and give up the rest. hopefulTransfer :: BufferOp a -> IO (Result a)- -> [a]- -> IO (Result ([Header],a))-hopefulTransfer bufOps readL strs - = readL >>= + -> [a]+ -> IO (Result ([Header],a))+hopefulTransfer bufOps readL strs+ = readL >>= either (\v -> return $ Left v) (\more -> if (buf_isEmpty bufOps more)- then return (Right ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) strs))+ then return (Right ([], buf_concat bufOps $ reverse strs)) else hopefulTransfer bufOps readL (more:strs)) -- | A necessary feature of HTTP\/1.1 -- Also the only transfer variety likely to -- return any footers. chunkedTransfer :: BufferOp a- -> IO (Result a)+ -> IO (Result a) -> (Int -> IO (Result a)) -> IO (Result ([Header], a)) chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0@@ -777,36 +918,36 @@ chunkedTransferC :: BufferOp a -> IO (Result a) -> (Int -> IO (Result a))- -> [a]- -> Int- -> IO (Result ([Header], a))+ -> [a]+ -> Int+ -> IO (Result ([Header], a)) chunkedTransferC bufOps readL readBlk acc n = do v <- readL case v of Left e -> return (Left e)- Right line - | size == 0 -> + Right line+ | size == 0 -> -- last chunk read; look for trailing headers.. fmapE (\ strs -> do- ftrs <- parseHeaders (map (buf_toStr bufOps) strs)- -- insert (computed) Content-Length header.- let ftrs' = Header HdrContentLength (show n) : ftrs+ ftrs <- parseHeaders (map (buf_toStr bufOps) strs)+ -- insert (computed) Content-Length header.+ let ftrs' = Header HdrContentLength (show n) : ftrs return (ftrs',buf_concat bufOps (reverse acc))) - (readTillEmpty2 bufOps readL [])+ (readTillEmpty2 bufOps readL []) | otherwise -> do some <- readBlk size- case some of- Left e -> return (Left e)- Right cdata -> do- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?- chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size)+ case some of+ Left e -> return (Left e)+ Right cdata -> do+ _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?+ chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size) where- size + size | buf_isEmpty bufOps line = 0- | otherwise = - case readHex (buf_toStr bufOps line) of+ | otherwise =+ case readHex (buf_toStr bufOps line) of (hx,_):_ -> hx _ -> 0 @@ -818,13 +959,13 @@ -- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) readTillEmpty1 :: BufferOp a- -> IO (Result a)+ -> IO (Result a) -> IO (Result [a]) readTillEmpty1 bufOps readL = readL >>= either (return . Left)- (\ s -> - if buf_isLineTerm bufOps s+ (\ s ->+ if buf_isLineTerm bufOps s then readTillEmpty1 bufOps readL else readTillEmpty2 bufOps readL [s]) @@ -834,14 +975,14 @@ -- thing to do - so probably indicates an -- error condition. readTillEmpty2 :: BufferOp a- -> IO (Result a)- -> [a]- -> IO (Result [a])+ -> IO (Result a)+ -> [a]+ -> IO (Result [a]) readTillEmpty2 bufOps readL list = readL >>= either (return . Left) (\ s ->- if buf_isLineTerm bufOps s || buf_isEmpty bufOps s+ if buf_isLineTerm bufOps s || buf_isEmpty bufOps s then return (Right $ reverse (s:list)) else readTillEmpty2 bufOps readL (s:list)) @@ -852,10 +993,10 @@ -- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific -- tweaks better go here. catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO a h = Prelude.catch a h+catchIO a h = Exception.catch a h catchIO_ :: IO a -> IO a -> IO a-catchIO_ a h = Prelude.catch a (const h)+catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) responseParseError :: String -> String -> Result a responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v))
Network/HTTP/Base64.hs view
@@ -8,8 +8,8 @@ -- Stability : experimental -- Portability : portable ----- Base64 encoding and decoding functions provided by Warwick Gray. --- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- Base64 encoding and decoding functions provided by Warwick Gray.+-- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> -- and <http://www.faqs.org/rfcs/rfc2045.html>. -- -----------------------------------------------------------------------------@@ -148,8 +148,8 @@ MIME applications might be undesireable. -But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only - 8 significant bits, which is more than enough for US-ASCII. +But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only+ 8 significant bits, which is more than enough for US-ASCII. -} @@ -161,9 +161,9 @@ type Octet = Word8 encodeArray :: Array Int Char-encodeArray = array (0,64) - [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') - , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') +encodeArray = array (0,64)+ [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F')+ , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')@@ -177,11 +177,11 @@ -- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) -- clearly the upmost/leftmost 8 bits of the answer are 0.--- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- Hack Alert: In the last entry of the answer, the upper 8 bits encode -- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. -- 0 represents a 4 :( int4_char3 :: [Int] -> [Char]-int4_char3 (a:b:c:d:t) = +int4_char3 (a:b:c:d:t) = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) in (chr (n `shiftR` 16 .&. 0xff)) : (chr (n `shiftR` 8 .&. 0xff))@@ -192,22 +192,24 @@ in [ (chr (n `shiftR` 16 .&. 0xff)) , (chr (n `shiftR` 8 .&. 0xff)) ] -int4_char3 [a,b] = +int4_char3 [a,b] = let n = (a `shiftL` 18 .|. b `shiftL` 12) in [ (chr (n `shiftR` 16 .&. 0xff)) ] -int4_char3 [] = [] +int4_char3 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints." +int4_char3 [] = [] + -- Convert triplets of characters to -- 4 base64 integers. The last entries -- in the list may not produce 4 integers, -- a trailing 2 character group gives 3 integers, -- while a trailing single character gives 2 integers. char3_int4 :: [Char] -> [Int]-char3_int4 (a:b:c:t) +char3_int4 (a:b:c:t) = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t @@ -216,7 +218,7 @@ in [ (n `shiftR` 18 .&. 0x3f) , (n `shiftR` 12 .&. 0x3f) , (n `shiftR` 6 .&. 0x3f) ]- + char3_int4 [a] = let n = (ord a `shiftL` 16) in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]@@ -242,6 +244,7 @@ quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit+quadruplets [_] = error "Network.HTTP.Base64.quadruplets: impossible number of characters." quadruplets [] = [] -- 24bit tail unit
Network/HTTP/Cookie.hs view
@@ -1,23 +1,23 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Cookie--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne+-- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- This module provides the data types and functions for working with HTTP cookies. -- Right now, it contains mostly functionality needed by 'Network.Browser'.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Cookie ( Cookie(..) , cookieMatch -- :: (String,String) -> Cookie -> Bool -- functions for translating cookies and headers.- , cookieToHeader -- :: Cookie -> Header+ , cookiesToHeader -- :: [Cookie] -> Header , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) ) where @@ -38,8 +38,8 @@ -- | @Cookie@ is the Haskell representation of HTTP cookie values. -- See its relevant specs for authoritative details.-data Cookie - = MkCookie +data Cookie+ = MkCookie { ckDomain :: String , ckName :: String , ckValue :: String@@ -50,25 +50,23 @@ deriving(Show,Read) instance Eq Cookie where- a == b = ckDomain a == ckDomain b - && ckName a == ckName b + a == b = ckDomain a == ckDomain b+ && ckName a == ckName b && ckPath a == ckPath b --- | @cookieToHeader ck@ serialises a @Cookie@ to an HTTP request header.-cookieToHeader :: Cookie -> Header-cookieToHeader ck = Header HdrCookie text- where- path = maybe "" (";$Path="++) (ckPath ck)- text = "$Version=" ++ fromMaybe "0" (ckVersion ck)- ++ ';' : ckName ck ++ "=" ++ ckValue ck ++ path- ++ (case ckPath ck of- Nothing -> ""- Just x -> ";$Path=" ++ x)- ++ ";$Domain=" ++ ckDomain ck+-- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header.+cookiesToHeader :: [Cookie] -> Header+cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs) +-- | Turn a list of cookies into a key=value pair list, separated by+-- semicolons.+mkCookieHeaderValue :: [Cookie] -> String+mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1+ where+ mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c -- | @cookieMatch (domain,path) ck@ performs the standard cookie--- match wrt the given domain and path. +-- match wrt the given domain and path. cookieMatch :: (String, String) -> Cookie -> Bool cookieMatch (dom,path) ck = ckDomain ck `isSuffixOf` dom &&@@ -77,13 +75,13 @@ Just p -> p `isPrefixOf` path --- | @processCookieHeaders dom hdrs@ +-- | @processCookieHeaders dom hdrs@ processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs --- | @headerToCookies dom hdr acc@ +-- | @headerToCookies dom hdr acc@ headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])-headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = case parse cookies "" val of Left{} -> (val:accErr, accCookie) Right x -> (accErr, x ++ accCookie)@@ -93,36 +91,35 @@ cookie :: Parser Cookie cookie =- do { name <- word- ; spaces_l- ; char '='- ; spaces_l- ; val1 <- cvalue- ; args <- cdetail- ; return $ mkCookie name val1 args- }+ do name <- word+ _ <- spaces_l+ _ <- char '='+ _ <- spaces_l+ val1 <- cvalue+ args <- cdetail+ return $ mkCookie name val1 args cvalue :: Parser String- + spaces_l = many (satisfy isSpace) cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return ""- + -- all keys in the result list MUST be in lower case cdetail :: Parser [(String,String)] cdetail = many $- try (do { spaces_l- ; char ';'- ; spaces_l- ; s1 <- word- ; spaces_l- ; s2 <- option "" (do { char '=' ; spaces_l ; v <- cvalue ; return v })- ; return (map toLower s1,s2)- })+ try (do _ <- spaces_l+ _ <- char ';'+ _ <- spaces_l+ s1 <- word+ _ <- spaces_l+ s2 <- option "" (char '=' >> spaces_l >> cvalue)+ return (map toLower s1,s2)+ ) mkCookie :: String -> String -> [(String,String)] -> Cookie- mkCookie nm cval more = - MkCookie { ckName = nm+ mkCookie nm cval more =+ MkCookie { ckName = nm , ckValue = cval , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) , ckPath = lookup "path" more@@ -131,15 +128,14 @@ } headerToCookies _ _ acc = acc - + word, quotedstring :: Parser String quotedstring =- do { char '"' -- "- ; str <- many (satisfy $ not . (=='"'))- ; char '"'- ; return str- }+ do _ <- char '"' -- "+ str <- many (satisfy $ not . (=='"'))+ _ <- char '"'+ return str word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))
Network/HTTP/HandleStream.hs view
@@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.HandleStream--- Copyright : (c) 2008- Sigbjorn Finne+-- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -15,16 +15,16 @@ -- not perform any kind of normalization prior to transmission (or receipt); you are -- responsible for doing any such yourself, or, if you prefer, just switch to using -- "Network.HTTP" function instead.--- +-- ------------------------------------------------------------------------------module Network.HTTP.HandleStream +module Network.HTTP.HandleStream ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty)) , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO ()- + , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString) ) where @@ -43,6 +43,7 @@ import Data.Char (toLower) import Data.Maybe (fromMaybe)+import Control.Exception (onException) import Control.Monad (when) -----------------------------------------------------------------@@ -51,16 +52,18 @@ -- | @simpleHTTP@ transmits a resource across a non-persistent connection. simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty))-simpleHTTP r = do +simpleHTTP r = do auth <- getAuth r+ failHTTPS (rqURI r) c <- openStream (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r -- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs -- the HTTP operation via the debug file @debugFile@. simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty))-simpleHTTP_debug httpLogFile r = do +simpleHTTP_debug httpLogFile r = do auth <- getAuth r+ failHTTPS (rqURI r) c0 <- openStream (host auth) (fromMaybe 80 (port auth)) c <- debugByteStream httpLogFile c0 simpleHTTP_ c r@@ -81,13 +84,13 @@ -- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty- -> Request ty- -> IO ()- -> IO (Result (Response ty))+ -> Request ty+ -> IO ()+ -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True)- catchIO (sendMain conn rq onSendComplete)- (\e -> do { close conn; ioError e })+ onException (sendMain conn rq onSendComplete)+ (close conn) where providedClose = findConnClose (rqHeaders rq) @@ -103,16 +106,18 @@ -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: HStream ty => HandleStream ty- -> Request ty- -> (IO ())- -> IO (Result (Response ty))+ -> Request ty+ -> (IO ())+ -> IO (Result (Response ty)) sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst)- writeBlock conn (buf_fromStr bufferOps $ show rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (buf_fromStr bufferOps $ show rqst) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rqBody rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst@@ -123,7 +128,7 @@ switchResponse :: HStream ty => HandleStream ty- -> Bool {- allow retry? -}+ -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request ty@@ -133,12 +138,12 @@ -- if we attempt to use the same socket then there is an excellent -- chance that the socket is not in a completely closed state. -switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = +switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = case matchResponse (rqMethod rqst) cd of Continue | not bdy_sent -> do {- Time to send the body -} writeBlock conn (rqBody rqst) >>= either (return . Left)- (\ _ -> do+ (\ _ -> do rsp <- getResponseHead conn switchResponse conn allow_retry True rsp rqst) | otherwise -> do {- keep waiting -}@@ -148,12 +153,13 @@ Retry -> do {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -}- writeBlock conn ((buf_append bufferOps)- (buf_fromStr bufferOps (show rqst))- (rqBody rqst))+ -- TODO review throwing away of result+ _ <- writeBlock conn ((buf_append bufferOps)+ (buf_fromStr bufferOps (show rqst))+ (rqBody rqst)) rsp <- getResponseHead conn switchResponse conn False bdy_sent rsp rqst- + Done -> do when (findConnClose hdrs) (closeOnEnd conn True)@@ -165,31 +171,31 @@ ExpectEntity -> do r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ maybe (maybe (hopefulTransfer bo (readLine conn) [])- (\ x -> - readsOne (linearTransfer (readBlock conn))- (return$responseParseError "unrecognized content-length value" x)- x)- cl)- (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))- (uglyDeathTransfer "sendHTTP"))+ (\ x ->+ readsOne (linearTransfer (readBlock conn))+ (return$responseParseError "unrecognized content-length value" x)+ x)+ cl)+ (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+ (uglyDeathTransfer "sendHTTP")) tc case r of Left{} -> do- close conn- return r- Right (Response _ _ hs _) -> do- when (findConnClose hs)+ close conn+ return r+ Right (Response _ _ hs _) -> do+ when (findConnClose hs) (closeOnEnd conn True)- return r+ return r where tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs bo = bufferOps- + -- reads and parses headers getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData)-getResponseHead conn = +getResponseHead conn = fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) (readTillEmpty1 bufferOps (readLine conn)) @@ -202,18 +208,18 @@ getRequestHead = do fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es)) (readTillEmpty1 bufferOps (readLine conn))- + processRequest (rm,uri,hdrs) = fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $- maybe - (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""- (\ x -> readsOne (linearTransfer (readBlock conn))- (return$responseParseError "unrecognized Content-Length value" x)- x)- - cl)- (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))- (uglyDeathTransfer "receiveHTTP"))+ maybe+ (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""+ (\ x -> readsOne (linearTransfer (readBlock conn))+ (return$responseParseError "unrecognized Content-Length value" x)+ x)++ cl)+ (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+ (uglyDeathTransfer "receiveHTTP")) tc where -- FIXME : Also handle 100-continue.@@ -225,10 +231,12 @@ -- the 'HandleStream' @hStream@. It could be used to implement simple web -- server interactions, performing the dual role to 'sendHTTP'. respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO ()-respondHTTP conn rsp = do - writeBlock conn (buf_fromStr bufferOps $ show rsp)+respondHTTP conn rsp = do+ -- TODO: review throwing away of result+ _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rspBody rsp)+ -- TODO: review throwing away of result+ _ <- writeBlock conn (rspBody rsp) return () ------------------------------------------------------------------------------@@ -237,7 +245,7 @@ headerName x = map toLower (trim x) ifChunked :: a -> a -> String -> a-ifChunked a b s = +ifChunked a b s = case headerName s of "chunked" -> a _ -> b
Network/HTTP/Headers.hs view
@@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Headers--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne+-- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -13,7 +13,7 @@ -- header values in 'Request's and 'Response's. To avoid having to provide -- separate set of operations for doing so, we introduce a type class 'HasHeaders' -- to facilitate writing such processing using overloading instead.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Headers ( HasHeaders(..) -- type class@@ -35,9 +35,9 @@ , parseHeader -- :: parseHeader :: String -> Result Header , parseHeaders -- :: [String] -> Result [Header]- + , headerMap -- :: [(String, HeaderName)]- + , HeaderSetter ) where @@ -70,15 +70,15 @@ -- Encoding HTTP header names differently, as Strings perhaps, is an -- equally fine choice..no decidedly clear winner, but let's stick -- with data constructors here.--- -data HeaderName +--+data HeaderName -- Generic Headers -- = HdrCacheControl | HdrConnection | HdrDate | HdrPragma- | HdrTransferEncoding - | HdrUpgrade + | HdrTransferEncoding+ | HdrUpgrade | HdrVia -- Request Headers -- | HdrAccept@@ -130,9 +130,164 @@ | HdrContentTransferEncoding -- | Allows for unrecognised or experimental headers. | HdrCustom String -- not in header map below.- deriving(Eq) --- | @headerMap@ is a straight assoc list for translating between header names +instance Eq HeaderName where+ HdrCustom a == HdrCustom b = (fmap toLower a) == (fmap toLower b)+ HdrCacheControl == HdrCacheControl = True+ HdrCacheControl == _ = False+ _ == HdrCacheControl = False+ HdrConnection == HdrConnection = True+ HdrConnection == _ = False+ _ == HdrConnection = False+ HdrDate == HdrDate = True+ HdrDate == _ = False+ _ == HdrDate = False+ HdrPragma == HdrPragma = True+ HdrPragma == _ = False+ _ == HdrPragma = False+ HdrTransferEncoding == HdrTransferEncoding = True+ HdrTransferEncoding == _ = False+ _ == HdrTransferEncoding = False+ HdrUpgrade == HdrUpgrade = True+ HdrUpgrade == _ = False+ _ == HdrUpgrade = False+ HdrVia == HdrVia = True+ HdrVia == _ = False+ _ == HdrVia = False+ HdrAccept == HdrAccept = True+ HdrAccept == _ = False+ _ == HdrAccept = False+ HdrAcceptCharset == HdrAcceptCharset = True+ HdrAcceptCharset == _ = False+ _ == HdrAcceptCharset = False+ HdrAcceptEncoding == HdrAcceptEncoding = True+ HdrAcceptEncoding == _ = False+ _ == HdrAcceptEncoding = False+ HdrAcceptLanguage == HdrAcceptLanguage = True+ HdrAcceptLanguage == _ = False+ _ == HdrAcceptLanguage = False+ HdrAuthorization == HdrAuthorization = True+ HdrAuthorization == _ = False+ _ == HdrAuthorization = False+ HdrCookie == HdrCookie = True+ HdrCookie == _ = False+ _ == HdrCookie = False+ HdrExpect == HdrExpect = True+ HdrExpect == _ = False+ _ == HdrExpect = False+ HdrFrom == HdrFrom = True+ HdrFrom == _ = False+ _ == HdrFrom = False+ HdrHost == HdrHost = True+ HdrHost == _ = False+ _ == HdrHost = False+ HdrIfModifiedSince == HdrIfModifiedSince = True+ HdrIfModifiedSince == _ = False+ _ == HdrIfModifiedSince = False+ HdrIfMatch == HdrIfMatch = True+ HdrIfMatch == _ = False+ _ == HdrIfMatch = False+ HdrIfNoneMatch == HdrIfNoneMatch = True+ HdrIfNoneMatch == _ = False+ _ == HdrIfNoneMatch = False+ HdrIfRange == HdrIfRange = True+ HdrIfRange == _ = False+ _ == HdrIfRange = False+ HdrIfUnmodifiedSince == HdrIfUnmodifiedSince = True+ HdrIfUnmodifiedSince == _ = False+ _ == HdrIfUnmodifiedSince = False+ HdrMaxForwards == HdrMaxForwards = True+ HdrMaxForwards == _ = False+ _ == HdrMaxForwards = False+ HdrProxyAuthorization == HdrProxyAuthorization = True+ HdrProxyAuthorization == _ = False+ _ == HdrProxyAuthorization = False+ HdrRange == HdrRange = True+ HdrRange == _ = False+ _ == HdrRange = False+ HdrReferer == HdrReferer = True+ HdrReferer == _ = False+ _ == HdrReferer = False+ HdrUserAgent == HdrUserAgent = True+ HdrUserAgent == _ = False+ _ == HdrUserAgent = False+ HdrAge == HdrAge = True+ HdrAge == _ = False+ _ == HdrAge = False+ HdrLocation == HdrLocation = True+ HdrLocation == _ = False+ _ == HdrLocation = False+ HdrProxyAuthenticate == HdrProxyAuthenticate = True+ HdrProxyAuthenticate == _ = False+ _ == HdrProxyAuthenticate = False+ HdrPublic == HdrPublic = True+ HdrPublic == _ = False+ _ == HdrPublic = False+ HdrRetryAfter == HdrRetryAfter = True+ HdrRetryAfter == _ = False+ _ == HdrRetryAfter = False+ HdrServer == HdrServer = True+ HdrServer == _ = False+ _ == HdrServer = False+ HdrSetCookie == HdrSetCookie = True+ HdrSetCookie == _ = False+ _ == HdrSetCookie = False+ HdrTE == HdrTE = True+ HdrTE == _ = False+ _ == HdrTE = False+ HdrTrailer == HdrTrailer = True+ HdrTrailer == _ = False+ _ == HdrTrailer = False+ HdrVary == HdrVary = True+ HdrVary == _ = False+ _ == HdrVary = False+ HdrWarning == HdrWarning = True+ HdrWarning == _ = False+ _ == HdrWarning = False+ HdrWWWAuthenticate == HdrWWWAuthenticate = True+ HdrWWWAuthenticate == _ = False+ _ == HdrWWWAuthenticate = False+ HdrAllow == HdrAllow = True+ HdrAllow == _ = False+ _ == HdrAllow = False+ HdrContentBase == HdrContentBase = True+ HdrContentBase == _ = False+ _ == HdrContentBase = False+ HdrContentEncoding == HdrContentEncoding = True+ HdrContentEncoding == _ = False+ _ == HdrContentEncoding = False+ HdrContentLanguage == HdrContentLanguage = True+ HdrContentLanguage == _ = False+ _ == HdrContentLanguage = False+ HdrContentLength == HdrContentLength = True+ HdrContentLength == _ = False+ _ == HdrContentLength = False+ HdrContentLocation == HdrContentLocation = True+ HdrContentLocation == _ = False+ _ == HdrContentLocation = False+ HdrContentMD5 == HdrContentMD5 = True+ HdrContentMD5 == _ = False+ _ == HdrContentMD5 = False+ HdrContentRange == HdrContentRange = True+ HdrContentRange == _ = False+ _ == HdrContentRange = False+ HdrContentType == HdrContentType = True+ HdrContentType == _ = False+ _ == HdrContentType = False+ HdrETag == HdrETag = True+ HdrETag == _ = False+ _ == HdrETag = False+ HdrExpires == HdrExpires = True+ HdrExpires == _ = False+ _ == HdrExpires = False+ HdrLastModified == HdrLastModified = True+ HdrLastModified == _ = False+ _ == HdrLastModified = False+ HdrContentTransferEncoding == HdrContentTransferEncoding = True+ HdrContentTransferEncoding == _ = False+ _ == HdrContentTransferEncoding = False++-- | @headerMap@ is a straight assoc list for translating between header names -- and values. headerMap :: [ (String,HeaderName) ] headerMap =@@ -227,12 +382,12 @@ newHeaders [] = [Header name value] -- | @replaceHeader hdr val o@ replaces the header @hdr@ with the--- value @val@, dropping any existing +-- value @val@, dropping any existing replaceHeader :: HasHeaders a => HeaderSetter a replaceHeader name value h = setHeaders h newHeaders where newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ]- + -- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing -- set. insertHeaders :: HasHeaders a => [Header] -> a -> a@@ -242,7 +397,7 @@ retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] retrieveHeaders name x = filter matchname (getHeaders x) where- matchname (Header n _) = n == name + matchname (Header n _) = n == name -- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first -- header that matches, if any.@@ -253,7 +408,7 @@ -- list @hdrs@. lookupHeader :: HeaderName -> [Header] -> Maybe String lookupHeader _ [] = Nothing-lookupHeader v (Header n s:t) +lookupHeader v (Header n s:t) | v == n = Just s | otherwise = lookupHeader v t @@ -271,26 +426,26 @@ match :: String -> String -> Bool match s1 s2 = map toLower s1 == map toLower s2- + -- | @parseHeaders hdrs@ takes a sequence of strings holding header -- information and parses them into a set of headers (preserving their -- order in the input argument.) Handles header values split up over -- multiple lines. parseHeaders :: [String] -> Result [Header]-parseHeaders = catRslts [] . - map (parseHeader . clean) . - joinExtended ""+parseHeaders = catRslts [] .+ map (parseHeader . clean) .+ joinExtended "" where -- Joins consecutive lines where the second line -- begins with ' ' or '\t'. joinExtended old [] = [old] joinExtended old (h : t)- | isLineExtension h = joinExtended (old ++ ' ' : tail h) t+ | isLineExtension h = joinExtended (old ++ ' ' : tail h) t | otherwise = old : joinExtended h t- - isLineExtension (x:_) = x == ' ' || x == '\t'- isLineExtension _ = False + isLineExtension (x:_) = x == ' ' || x == '\t'+ isLineExtension _ = False+ clean [] = [] clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t | otherwise = h : clean t@@ -299,8 +454,8 @@ -- errors here be reported or ignored? -- currently ignored. catRslts :: [a] -> [Result a] -> Result [a]- catRslts list (h:t) = + catRslts list (h:t) = case h of Left _ -> catRslts list t Right v -> catRslts (v:list) t- catRslts list [] = Right $ reverse list + catRslts list [] = Right $ reverse list
− Network/HTTP/MD5.hs
@@ -1,43 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Digest.MD5--- Copyright : (c) Dominic Steinitz 2004--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : portable------ Takes the MD5 module supplied by Ian Lynagh and wraps it so it--- takes [Octet] and returns [Octet] where the length of the result--- is always 16.--- See <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>--- and <http://www.ietf.org/rfc/rfc1321.txt>.-----------------------------------------------------------------------------------module Network.HTTP.MD5- ( hash- , Octet- ) where--import Data.List (unfoldr)-import Data.Word (Word8)-import Numeric (readHex)--import Network.HTTP.MD5Aux (md5s, Str(Str))--type Octet = Word8---- | Take [Octet] and return [Octet] according to the standard.--- The length of the result is always 16 octets or 128 bits as required--- by the standard.--hash :: [Octet] -> [Octet]-hash xs = - unfoldr f $ md5s $ Str $ map (toEnum . fromIntegral) xs- where f :: String -> Maybe (Octet,String)- f [] = Nothing- f [x] = f ['0',x]- f (x:y:zs) = Just (a,zs)- where [(a,_)] = readHex (x:y:[])
Network/HTTP/MD5Aux.hs view
@@ -1,6 +1,6 @@-module Network.HTTP.MD5Aux +module Network.HTTP.MD5Aux (md5, md5s, md5i,- MD5(..), ABCD(..), + MD5(..), ABCD(..), Zord64, Str(..), BoolList(..), WordList(..)) where import Data.Char (ord, chr)@@ -91,6 +91,7 @@ instance Num ABCD where ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + (-) = error "(-){ABCD}: no instance method defined" (*) = error "(*){ABCD}: no instance method defined" signum = error "signum{ABCD}: no instance method defined" fromInteger = error "fromInteger{ABCD}: no instance method defined"@@ -105,7 +106,7 @@ md5 m = md5_main False 0 magic_numbers m --- Returns a hex number ala the md5sum program+-- Returns a hex number à la md5sum program md5s :: (MD5 a) => a -> String md5s = abcd_to_string . md5
Network/HTTP/Proxy.hs view
@@ -2,16 +2,15 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Proxy--- Copyright : (c) 2009 Eric Kow+-- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>--- Author : Eric Kow <E.Y.Kow@brighton.ac.uk>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- Handling proxy server settings and their resolution.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Proxy ( Proxy(..)@@ -20,12 +19,23 @@ , parseProxy -- :: String -> Maybe Proxy ) where -import Control.Monad ( when, mplus, join, liftM2)+{-+#if !defined(WIN32) && defined(mingw32_HOST_OS)+#define WIN32 1+#endif+-} +import Control.Monad ( when, mplus, join, liftM2 )++#if defined(WIN32)+import Network.HTTP.Base ( catchIO )+import Control.Monad ( liftM )+import Data.List ( isPrefixOf )+#endif import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) import Network.HTTP.Auth import Network.URI- ( URI(..), URIAuth(..), parseAbsoluteURI )+ ( URI(..), URIAuth(..), parseAbsoluteURI, unEscapeString ) import System.IO ( hPutStrLn, stderr ) import System.Environment @@ -37,14 +47,20 @@ #if defined(WIN32) import System.Win32.Types ( DWORD, HKEY )-import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx )+import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValueEx ) import Control.Exception ( bracket ) import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca )++#if MIN_VERSION_Win32(2,8,0)+import System.Win32.Registry( regQueryDefaultValue )+#else+import System.Win32.Registry( regQueryValue ) #endif+#endif -- | HTTP proxies (or not) are represented via 'Proxy', specifying if a -- proxy should be used for the request (see 'Network.Browser.setProxy')-data Proxy +data Proxy = NoProxy -- ^ Don't use a proxy. | Proxy String (Maybe Authority) -- ^ Use the proxy given. Should be of the@@ -67,16 +83,18 @@ -- Consults environment variable, and in case of Windows, by querying -- the Registry (cf. @registryProxyString@.) proxyString :: IO (Maybe String)-proxyString = liftM2 mplus envProxyString registryProxyString+proxyString = liftM2 mplus envProxyString windowsProxyString -registryProxyString :: IO (Maybe String)+windowsProxyString :: IO (Maybe String) #if !defined(WIN32)-registryProxyString = return Nothing+windowsProxyString = return Nothing #else+windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString+ registryProxyLoc :: (HKEY,String) registryProxyLoc = (hive, path) where- -- some sources say proxy settings should be at + -- some sources say proxy settings should be at -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows -- \CurrentVersion\Internet Settings\ProxyServer -- but if the user sets them with IE connection panel they seem to@@ -85,14 +103,49 @@ path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" -- read proxy settings from the windows registry; this is just a best--- effort and may not work on all setups. -registryProxyString = Prelude.catch+-- effort and may not work on all setups.+registryProxyString :: IO (Maybe String)+registryProxyString = catchIO (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" if enable+#if MIN_VERSION_Win32(2,8,0)+ then fmap Just $ regQueryDefaultValue hkey "ProxyServer"+#elif MIN_VERSION_Win32(2,6,0)+ then fmap Just $ regQueryValue hkey "ProxyServer"+#else then fmap Just $ regQueryValue hkey (Just "ProxyServer")+#endif else return Nothing) (\_ -> return Nothing)++-- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..."+-- even though the following article indicates otherwise+-- https://support.microsoft.com/en-us/kb/819961+--+-- to be sure, parse strings where each entry in the ';'-separated list above is+-- either in the format "protocol=..." or "protocol://..."+--+-- only return the first "http" of them, if it exists+parseWindowsProxy :: String -> Maybe String+parseWindowsProxy s =+ case proxies of+ x:_ -> Just x+ _ -> Nothing+ where+ parts = split ';' s+ pr x = case break (== '=') x of+ (p, []) -> p -- might be in format http://+ (p, u) -> p ++ "://" ++ drop 1 u++ proxies = filter (isPrefixOf "http://") . map pr $ parts++ split :: Eq a => a -> [a] -> [[a]]+ split _ [] = []+ split a xs = case break (a ==) xs of+ (ys, []) -> [ys]+ (ys, _:zs) -> ys:split a zs+ #endif -- | @fetchProxy flg@ gets the local proxy settings and parse the string@@ -107,7 +160,7 @@ case mstr of Nothing -> return NoProxy Just str -> case parseProxy str of- Just p -> return p + Just p -> return p Nothing -> do when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines [ "invalid http proxy uri: " ++ show str@@ -119,6 +172,7 @@ -- | @parseProxy str@ translates a proxy server string into a @Proxy@ value; -- returns @Nothing@ if not well-formed. parseProxy :: String -> Maybe Proxy+parseProxy "" = Nothing parseProxy str = join . fmap uri2proxy $ parseHttpURI str@@ -144,7 +198,7 @@ where f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s} --- +-- uri2proxy :: URI -> Maybe Proxy uri2proxy uri@URI{ uriScheme = "http:" , uriAuthority = Just (URIAuth auth' hst prt)@@ -154,9 +208,9 @@ auth = case auth' of [] -> Nothing- as -> Just (AuthBasic "" usr pwd uri)+ as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri) where- (usr,pwd) = chopAtDelim ':' as+ (usr,pwd) = chopAtDelim ':' as uri2proxy _ = Nothing @@ -164,7 +218,9 @@ #if defined(WIN32) regQueryValueDWORD :: HKEY -> String -> IO DWORD regQueryValueDWORD hkey name = alloca $ \ptr -> do- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+ -- TODO: this throws away the key type returned by regQueryValueEx+ -- we should check it's what we expect instead+ _ <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) peek ptr #endif
Network/HTTP/Stream.hs view
@@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Stream--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop+-- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -20,9 +20,9 @@ -- not perform any kind of normalization prior to transmission (or receipt); you are -- responsible for doing any such yourself, or, if you prefer, just switch to using -- "Network.HTTP" function instead.--- +-- ------------------------------------------------------------------------------module Network.HTTP.Stream +module Network.HTTP.Stream ( module Network.Stream , simpleHTTP -- :: Request_String -> IO (Result Response_String)@@ -31,7 +31,7 @@ , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) , respondHTTP -- :: Stream s => s -> Response_String -> IO ()- + ) where -----------------------------------------------------------------@@ -49,6 +49,7 @@ import Data.Char (toLower) import Data.Maybe (fromMaybe)+import Control.Exception (onException) import Control.Monad (when) @@ -67,7 +68,7 @@ -- | Simple way to transmit a resource across a non-persistent connection. simpleHTTP :: Request_String -> IO (Result Response_String)-simpleHTTP r = do +simpleHTTP r = do auth <- getAuth r c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r@@ -86,8 +87,8 @@ sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True)- catchIO (sendMain conn rq onSendComplete)- (\e -> do { close conn; ioError e })+ onException (sendMain conn rq onSendComplete)+ (close conn) where providedClose = findConnClose (rqHeaders rq) @@ -102,17 +103,19 @@ -- -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)-sendMain conn rqst onSendComplete = do +sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst)- writeBlock conn (show rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (show rqst) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rqBody rqst)+ -- TODO review throwing away of result+ _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst- + -- reads and parses headers getResponseHead :: Stream s => s -> IO (Result ResponseData) getResponseHead conn = do@@ -124,7 +127,7 @@ -- to the RFC. switchResponse :: Stream s => s- -> Bool {- allow retry? -}+ -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request_String@@ -147,24 +150,25 @@ } | otherwise -> {- keep waiting -} do { rsp <- getResponseHead conn- ; switchResponse conn allow_retry bdy_sent rsp rqst + ; switchResponse conn allow_retry bdy_sent rsp rqst } Retry -> {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -}- do { writeBlock conn (show rqst ++ rqBody rqst)+ do { -- TODO review throwing away of result+ _ <- writeBlock conn (show rqst ++ rqBody rqst) ; rsp <- getResponseHead conn ; switchResponse conn False bdy_sent rsp rqst- } - + }+ Done -> do- when (findConnClose hdrs)- (closeOnEnd conn True)+ when (findConnClose hdrs)+ (closeOnEnd conn True) return (Right $ Response cd rn hdrs "") DieHorribly str -> do- close conn+ close conn return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) ExpectEntity ->@@ -172,24 +176,24 @@ cl = lookupHeader HdrContentLength hdrs in do { rslt <- case tc of- Nothing -> + Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int) Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) []- Just x -> + Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp- (readLine conn) (readBlock conn)+ (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "sendHTTP" ; case rslt of- Left e -> close conn >> return (Left e)- Right (ftrs,bdy) -> do- when (findConnClose (hdrs++ftrs))- (closeOnEnd conn True)- return (Right (Response cd rn (hdrs++ftrs) bdy))+ Left e -> close conn >> return (Left e)+ Right (ftrs,bdy) -> do+ when (findConnClose (hdrs++ftrs))+ (closeOnEnd conn True)+ return (Right (Response cd rn (hdrs++ftrs) bdy)) } --- | Receive and parse a HTTP request from the given Stream. Should be used +-- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions. receiveHTTP :: Stream s => s -> IO (Result Request_String) receiveHTTP conn = getRequestHead >>= processRequest@@ -200,13 +204,13 @@ do { lor <- readTillEmpty1 stringBufferOp (readLine conn) ; return $ lor >>= parseRequestHead }- + processRequest (Left e) = return $ Left e- processRequest (Right (rm,uri,hdrs)) = - do -- FIXME : Also handle 100-continue.+ processRequest (Right (rm,uri,hdrs)) =+ do -- FIXME : Also handle 100-continue. let tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs- rslt <- case tc of+ rslt <- case tc of Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int)@@ -214,17 +218,19 @@ Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp- (readLine conn) (readBlock conn)+ (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "receiveHTTP"- + return $ do- (ftrs,bdy) <- rslt- return (Request uri rm (hdrs++ftrs) bdy)+ (ftrs,bdy) <- rslt+ return (Request uri rm (hdrs++ftrs) bdy) --- | Very simple function, send a HTTP response over the given stream. This +-- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. respondHTTP :: Stream s => s -> Response_String -> IO ()-respondHTTP conn rsp = do writeBlock conn (show rsp)+respondHTTP conn rsp = do -- TODO review throwing away of result+ _ <- writeBlock conn (show rsp) -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rspBody rsp)- return ()+ -- TODO review throwing away of result+ _ <- writeBlock conn (rspBody rsp)+ return ()
Network/HTTP/Utils.hs view
@@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Utils--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne+-- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -14,25 +14,31 @@ ( trim -- :: String -> String , trimL -- :: String -> String , trimR -- :: String -> String- + , crlf -- :: String , lf -- :: String , sp -- :: String , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) , splitBy -- :: Eq a => a -> [a] -> [[a]]- + , readsOne -- :: Read a => (a -> b) -> b -> String -> b , dropWhileTail -- :: (a -> Bool) -> [a] -> [a] , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a])- ++ , toUTF8BS+ , fromUTF8BS ) where- ++import Data.Bits import Data.Char import Data.List ( elemIndex ) import Data.Maybe ( fromMaybe )+import Data.Word ( Word8 ) +import qualified Data.ByteString as BS+ -- | @crlf@ is our beloved two-char line terminator. crlf :: String crlf = "\r\n"@@ -56,7 +62,7 @@ -- | @trim str@ removes leading and trailing whitespace from @str@. trim :: String -> String trim xs = trimR (trimL xs)- + -- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace') -- from @str@. trimL :: String -> String@@ -68,14 +74,14 @@ trimR str = fromMaybe "" $ foldr trimIt Nothing str where trimIt x (Just xs) = Just (x:xs)- trimIt x Nothing + trimIt x Nothing | isSpace x = Nothing | otherwise = Just [x] -- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@. splitBy :: Eq a => a -> [a] -> [[a]] splitBy _ [] = []-splitBy c xs = +splitBy c xs = case break (==c) xs of (_,[]) -> [xs] (as,_:bs) -> as : splitBy c bs@@ -84,7 +90,7 @@ -- the first result and passing it to @f@. If the 'read' -- doesn't succeed, return @def@. readsOne :: Read a => (a -> b) -> b -> String -> b-readsOne f n str = +readsOne f n str = case reads str of ((v,_):_) -> f v _ -> n@@ -109,3 +115,93 @@ case break (==elt) xs of (_,[]) -> (xs,[]) (as,_:bs) -> (as,bs)++toUTF8BS :: String -> BS.ByteString+toUTF8BS = BS.pack . encodeStringUtf8++fromUTF8BS :: BS.ByteString -> String+fromUTF8BS = decodeStringUtf8 . BS.unpack++-- | Encode 'String' to a list of UTF8-encoded octets+--+-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded+-- as the replacement character (i.e. @U+FFFD@).+--+-- The code is extracted from Cabal library, written originally+-- Herbert Valerio Riedel under BSD-3-Clause license+encodeStringUtf8 :: String -> [Word8]+encodeStringUtf8 [] = []+encodeStringUtf8 (c:cs)+ | c <= '\x07F' = w8+ : encodeStringUtf8 cs+ | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 )+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 )+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD+ : encodeStringUtf8 cs+ | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 )+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | otherwise = (0xf0 .|. w8ShiftR 18 )+ : (0x80 .|. (w8ShiftR 12 .&. 0x3F))+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ where+ w8 = fromIntegral (ord c) :: Word8+ w8ShiftR :: Int -> Word8+ w8ShiftR = fromIntegral . shiftR (ord c)++-- | Decode 'String' from UTF8-encoded octets.+--+-- Invalid data in the UTF8 stream (this includes code-points @U+D800@+-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@).+--+-- See also 'encodeStringUtf8'+decodeStringUtf8 :: [Word8] -> String+decodeStringUtf8 = go+ where+ go :: [Word8] -> String+ go [] = []+ go (c : cs)+ | c <= 0x7F = chr (fromIntegral c) : go cs+ | c <= 0xBF = replacementChar : go cs+ | c <= 0xDF = twoBytes c cs+ | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF)+ | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7)+ | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3)+ | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1)+ | otherwise = replacementChar : go cs++ twoBytes :: Word8 -> [Word8] -> String+ twoBytes c0 (c1:cs')+ | c1 .&. 0xC0 == 0x80+ = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6)+ .|. fromIntegral (c1 .&. 0x3F)+ in if d >= 0x80+ then chr d : go cs'+ else replacementChar : go cs'+ twoBytes _ cs' = replacementChar : go cs'++ moreBytes :: Int -> Int -> [Word8] -> Int -> [Char]+ moreBytes 1 overlong cs' acc+ | overlong <= acc && acc <= 0x10FFFF && (acc < 0xD800 || 0xDFFF < acc)+ = chr acc : go cs'++ | otherwise+ = replacementChar : go cs'++ moreBytes byteCount overlong (cn:cs') acc+ | cn .&. 0xC0 == 0x80+ = moreBytes (byteCount-1) overlong cs'+ ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)++ moreBytes _ _ cs' _+ = replacementChar : go cs'++ replacementChar = '\xfffd'
Network/Stream.hs view
@@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.Stream--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop+-- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -32,24 +32,18 @@ , failMisc -- :: String -> Result a ) where -import Control.Monad.Error--data ConnError - = ErrorReset +data ConnError+ = ErrorReset | ErrorClosed | ErrorParse String | ErrorMisc String deriving(Show,Eq) -instance Error ConnError where- noMsg = strMsg "unknown error"- strMsg x = ErrorMisc x- -- in GHC 7.0 the Monad instance for Error no longer -- uses fail x = Left (strMsg x). failMisc is therefore -- used instead. failMisc :: String -> Result a-failMisc x = failWith (strMsg x)+failMisc x = failWith (ErrorMisc x) failParse :: String -> Result a failParse x = failWith (ErrorParse x)@@ -66,8 +60,8 @@ x <- a case x of Left e -> return (Left e)- Right r -> return (f r) - + Right r -> return (f r)+ -- | This is the type returned by many exported network functions. type Result a = Either ConnError {- error -} a {- result -}@@ -81,7 +75,7 @@ -- the input in any way, e.g. leave LF on line -- endings etc. Unless that is exactly the behaviour -- you want from your twisted instances ;)-class Stream x where +class Stream x where readLine :: x -> IO (Result String) readBlock :: x -> Int -> IO (Result String) writeBlock :: x -> String -> IO (Result ())
Network/StreamDebugger.hs view
@@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.StreamDebugger--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop+-- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -13,7 +13,7 @@ -- -- * Changes by Robin Bate Boerop <robin@bateboerop.name>: -- - Created. Made minor formatting changes.--- +-- ----------------------------------------------------------------------------- module Network.StreamDebugger ( StreamDebugger@@ -23,10 +23,11 @@ import Network.Stream (Stream(..)) import System.IO- ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile+ ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile,+ hSetBuffering, BufferMode(NoBuffering) )-import Network.TCP ( HandleStream, HStream, - StreamHooks(..), setStreamHooks, getStreamHooks )+import Network.TCP ( HandleStream, HStream,+ StreamHooks(..), setStreamHooks, getStreamHooks ) -- | Allows stream logging. Refer to 'debugStream' below. data StreamDebugger x@@ -36,17 +37,17 @@ readBlock (Dbg h x) n = do val <- readBlock x n hPutStrLn h ("--readBlock " ++ show n)- hPutStrLn h (show val)+ hPutStrLn h (show val) return val readLine (Dbg h x) = do val <- readLine x hPutStrLn h ("--readLine")- hPutStrLn h (show val)+ hPutStrLn h (show val) return val writeBlock (Dbg h x) str = do val <- writeBlock x str hPutStrLn h ("--writeBlock" ++ show str)- hPutStrLn h (show val)+ hPutStrLn h (show val) return val close (Dbg h x) = do hPutStrLn h "--closing..."@@ -56,43 +57,44 @@ hClose h closeOnEnd (Dbg h x) f = do hPutStrLn h ("--close-on-end.." ++ show f)- hFlush h + hFlush h closeOnEnd x f -- | Wraps a stream with logging I\/O. -- The first argument is a filename which is opened in @AppendMode@. debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a)-debugStream file stream = +debugStream file stream = do h <- openFile file AppendMode hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") return (Dbg h stream) debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty) debugByteStream file stream = do- sh <- getStreamHooks stream + sh <- getStreamHooks stream case sh of- Just h + Just h | hook_name h == file -> return stream -- reuse the stream hooks. _ -> do h <- openFile file AppendMode+ hSetBuffering h NoBuffering hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") setStreamHooks stream (debugStreamHooks h file) return stream debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty-debugStreamHooks h nm = +debugStreamHooks h nm = StreamHooks { hook_readBlock = \ toStr n val -> do let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} hPutStrLn h ("--readBlock " ++ show n) hPutStrLn h (either show show eval) , hook_readLine = \ toStr val -> do- let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}+ let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} hPutStrLn h ("--readLine")- hPutStrLn h (either show show eval)+ hPutStrLn h (either show show eval) , hook_writeBlock = \ toStr str val -> do hPutStrLn h ("--writeBlock " ++ show val)- hPutStrLn h (toStr str)+ hPutStrLn h (toStr str) , hook_close = do hPutStrLn h "--closing..." hFlush h
Network/StreamSocket.hs view
@@ -1,10 +1,11 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Network.StreamSocket--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop.+-- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -16,8 +17,8 @@ -- - Created separate module for instance Stream Socket. -- -- * Changes by Simon Foster:--- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules--- +-- - Split module up into to separate Network.[Stream,TCP,HTTP] modules+-- ----------------------------------------------------------------------------- module Network.StreamSocket ( handleSocketError@@ -28,14 +29,18 @@ ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result ) import Network.Socket- ( Socket, getSocketOption, shutdown, send, recv, sClose+ ( Socket, getSocketOption, shutdown , ShutdownCmd(ShutdownBoth), SocketOption(SoError) )+import Network.Socket.ByteString (send, recv)+import qualified Network.Socket+ ( close ) import Network.HTTP.Base ( catchIO )+import Network.HTTP.Utils ( fromUTF8BS, toUTF8BS ) import Control.Monad (liftM) import Control.Exception as Exception (IOException)-import System.IO.Error (catch, isEOFError)+import System.IO.Error (isEOFError) -- | Exception handler for socket operations. handleSocketError :: Socket -> IOException -> IO (Result a)@@ -49,7 +54,7 @@ myrecv :: Socket -> Int -> IO String myrecv sock len = let handler e = if isEOFError e then return [] else ioError e- in System.IO.Error.catch (recv sock len) handler+ in catchIO (fmap fromUTF8BS (recv sock len)) handler instance Stream Socket where readBlock sk n = readBlockSocket sk n@@ -58,7 +63,7 @@ close sk = do -- This slams closed the connection (which is considered rude for TCP\/IP) shutdown sk ShutdownBoth- sClose sk+ Network.Socket.close sk closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here. readBlockSocket :: Socket -> Int -> IO (Result String)@@ -72,7 +77,7 @@ } -- Use of the following function is discouraged.--- The function reads in one character at a time, +-- The function reads in one character at a time, -- which causes many calls to the kernel recv() -- hence causes many context switches. readLineSocket :: Socket -> IO (Result String)@@ -83,10 +88,10 @@ if null c || c == "\n" then return (reverse str++c) else fn (head c:str)- + writeBlockSocket :: Socket -> String -> IO (Result ()) writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk) where fn [] = return ()- fn x = send sk x >>= \i -> fn (drop i x)+ fn x = send sk (toUTF8BS x) >>= \i -> fn (drop i x)
Network/TCP.hs view
@@ -1,30 +1,32 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Network.TCP--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- Some utility functions for working with the Haskell @network@ package. Mostly--- for internal use by the @Network.HTTP@ code, but --- +-- for internal use by the @Network.HTTP@ code.+-- ----------------------------------------------------------------------------- module Network.TCP ( Connection+ , EndPoint(..) , openTCPPort , isConnectedTo , openTCPConnection , socketConnection , isTCPConnectedTo- + , HandleStream , HStream(..)- + , StreamHooks(..) , nullHooks , setStreamHooks@@ -33,14 +35,17 @@ ) where -import Network.BSD (getHostByName, hostAddresses) import Network.Socket- ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive)- , SocketType(Stream), inet_addr, connect+ ( Socket, SocketOption(KeepAlive)+ , SocketType(Stream), connect , shutdown, ShutdownCmd(..)- , sClose, setSocketOption, getPeerName- , socket, Family(AF_INET)+ , setSocketOption, getPeerName+ , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo+ , defaultHints, addrFamily, withSocketsDo+ , addrSocketType, addrAddress )+import qualified Network.Socket+ ( close ) import qualified Network.Stream as Stream ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) import Network.Stream@@ -57,6 +62,7 @@ import Data.Char ( toLower ) import Data.Word ( Word8 ) import Control.Concurrent+import Control.Exception ( IOException, bracketOnError, try ) import Control.Monad ( liftM, when ) import System.IO ( Handle, hFlush, IOMode(..), hClose ) import System.IO.Error ( isEOFError )@@ -77,14 +83,20 @@ newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} -data Conn a - = MkConn { connSock :: ! Socket- , connHandle :: Handle+data EndPoint = EndPoint { epHost :: String, epPort :: Int }++instance Eq EndPoint where+ EndPoint host1 port1 == EndPoint host2 port2 =+ map toLower host1 == map toLower host2 && port1 == port2++data Conn a+ = MkConn { connSock :: !Socket+ , connHandle :: Handle , connBuffer :: BufferOp a- , connInput :: Maybe a- , connHost :: String- , connHooks :: Maybe (StreamHooks a)- , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream.+ , connInput :: Maybe a+ , connEndPoint :: EndPoint+ , connHooks :: Maybe (StreamHooks a)+ , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. } | ConnClosed deriving(Eq)@@ -110,7 +122,7 @@ (==) _ _ = True nullHooks :: StreamHooks ty-nullHooks = StreamHooks +nullHooks = StreamHooks { hook_readLine = \ _ _ -> return () , hook_readBlock = \ _ _ _ -> return () , hook_writeBlock = \ _ _ _ -> return ()@@ -132,17 +144,17 @@ -- The library comes with instances for @ByteString@s and @String@, but -- should you want to plug in your own payload representation, defining -- your own @HStream@ instance _should_ be all that it takes.--- +-- class BufferType bufType => HStream bufType where openStream :: String -> Int -> IO (HandleStream bufType)- openSocketStream :: String -> Socket -> IO (HandleStream bufType)+ openSocketStream :: String -> Int -> Socket -> IO (HandleStream bufType) readLine :: HandleStream bufType -> IO (Result bufType) readBlock :: HandleStream bufType -> Int -> IO (Result bufType) writeBlock :: HandleStream bufType -> bufType -> IO (Result ()) close :: HandleStream bufType -> IO () closeQuick :: HandleStream bufType -> IO () closeOnEnd :: HandleStream bufType -> Bool -> IO ()- + instance HStream Strict.ByteString where openStream = openTCPConnection openSocketStream = socketConnection@@ -155,7 +167,7 @@ instance HStream Lazy.ByteString where openStream = \ a b -> openTCPConnection_ a b True- openSocketStream = \ a b -> socketConnection_ a b True+ openSocketStream = \ a b c -> socketConnection_ a b c True readBlock c n = readBlockBS c n readLine c = readLineBS c writeBlock c str = writeBlockBS c str@@ -166,10 +178,10 @@ instance Stream.Stream Connection where readBlock (Connection c) = Network.TCP.readBlock c readLine (Connection c) = Network.TCP.readLine c- writeBlock (Connection c) = Network.TCP.writeBlock c + writeBlock (Connection c) = Network.TCP.writeBlock c close (Connection c) = Network.TCP.close c closeOnEnd (Connection c) f = Network.TCP.closeEOF c f- + instance HStream String where openStream = openTCPConnection openSocketStream = socketConnection@@ -178,7 +190,7 @@ -- This function uses a buffer, at this time the buffer is just 1000 characters. -- (however many bytes this is is left to the user to decypher) readLine ref = readLineBS ref- -- The 'Connection' object allows no outward buffering, + -- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) @@ -187,14 +199,14 @@ -- at any time before a call to this function. This function is idempotent. -- (I think the behaviour here is TCP specific) close c = closeIt c null True- + -- Closes a Connection without munching the rest of the stream. closeQuick c = closeIt c null False closeOnEnd c f = closeEOF c f- + -- | @openTCPPort uri port@ establishes a connection to a remote--- host, using 'getHostByName' which possibly queries the DNS system, hence +-- host, using 'getHostByName' which possibly queries the DNS system, hence -- may trigger a network connection. openTCPPort :: String -> Int -> IO Connection openTCPPort uri port = openTCPConnection uri port >>= return.Connection@@ -206,51 +218,85 @@ openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) openTCPConnection_ uri port stashInput = do- s <- socket AF_INET Stream 6- setSocketOption s KeepAlive 1- hostA <- getHostAddr uri- let a = SockAddrInet (toEnum port) hostA- catchIO (connect s a) (\e -> sClose s >> ioError e)- socketConnection_ uri s stashInput- where- getHostAddr h = do- catchIO (inet_addr uri) -- handles ascii IP numbers- (\ _ -> do- host <- getHostByName_safe uri- case hostAddresses host of- [] -> fail ("openTCPConnection: no addresses in host entry for " ++ show h)- (ha:_) -> return ha)+ -- HACK: uri is sometimes obtained by calling Network.URI.uriRegName, and this includes+ -- the surrounding square brackets for an RFC 2732 host like [::1]. It's not clear whether+ -- it should, or whether all call sites should be using something different instead, but+ -- the simplest short-term fix is to strip any surrounding square brackets here.+ -- It shouldn't affect any as this is the only situation they can occur - see RFC 3986.+ let fixedUri =+ case uri of+ '[':(rest@(c:_)) | last rest == ']'+ -> if c == 'v' || c == 'V'+ then error $ "Unsupported post-IPv6 address " ++ uri+ else init rest+ _ -> uri - getHostByName_safe h = - catchIO (getHostByName h)- (\ _ -> fail ("openTCPConnection: host lookup failure for " ++ show h)) + -- use withSocketsDo here in case the caller hasn't used it, which would make getAddrInfo fail on Windows+ -- although withSocketsDo is supposed to wrap the entire program, in practice it is safe to use it locally+ -- like this as it just does a once-only installation of a shutdown handler to run at program exit,+ -- rather than actually shutting down after the action+ addrinfos <- withSocketsDo $ getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) (Just fixedUri) (Just . show $ port)++ let+ connectAddrInfo a = bracketOnError+ (socket (addrFamily a) Stream defaultProtocol) -- acquire+ Network.Socket.close -- release+ ( \s -> do+ setSocketOption s KeepAlive 1+ connect s (addrAddress a)+ socketConnection_ fixedUri port s stashInput )++ -- try multiple addresses; return Just connected socket or Nothing+ tryAddrInfos [] = return Nothing+ tryAddrInfos (h:t) =+ let next = \(_ :: IOException) -> tryAddrInfos t+ in try (connectAddrInfo h) >>= either next (return . Just)++ case addrinfos of+ [] -> fail "openTCPConnection: getAddrInfo returned no address information"++ -- single AddrInfo; call connectAddrInfo directly so that specific+ -- exception is thrown in event of failure+ [ai] -> connectAddrInfo ai `catchIO` (\e -> fail $+ "openTCPConnection: failed to connect to "+ ++ show (addrAddress ai) ++ ": " ++ show e)++ -- multiple AddrInfos; try each until we get a connection, or run out+ ais ->+ let+ err = fail $ "openTCPConnection: failed to connect; tried addresses: "+ ++ show (fmap addrAddress ais)+ in tryAddrInfos ais >>= maybe err return+ -- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. socketConnection :: BufferType ty => String- -> Socket- -> IO (HandleStream ty)-socketConnection hst sock = socketConnection_ hst sock False+ -> Int+ -> Socket+ -> IO (HandleStream ty)+socketConnection hst port sock = socketConnection_ hst port sock False -- Internal function used to control the on-demand streaming of input -- for /lazy/ streams. socketConnection_ :: BufferType ty => String- -> Socket- -> Bool- -> IO (HandleStream ty)-socketConnection_ hst sock stashInput = do+ -> Int+ -> Socket+ -> Bool+ -> IO (HandleStream ty)+socketConnection_ hst port sock stashInput = do h <- socketToHandle sock ReadWriteMode mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing }- let conn = MkConn + let conn = MkConn { connSock = sock- , connHandle = h- , connBuffer = bufferOps- , connInput = mb- , connHost = hst- , connHooks = Nothing- , connCloseEOF = False- }+ , connHandle = h+ , connBuffer = bufferOps+ , connInput = mb+ , connEndPoint = EndPoint hst port+ , connHooks = Nothing+ , connCloseEOF = False+ } v <- newMVar conn return (HandleStream v) @@ -274,7 +320,7 @@ suck readL hClose (connHandle conn) shutdown sk ShutdownReceive- sClose sk+ Network.Socket.close sk suck :: IO Bool -> IO () suck rd = do@@ -284,24 +330,17 @@ -- | Checks both that the underlying Socket is connected -- and that the connection peer matches the given -- host name (which is recorded locally).-isConnectedTo :: Connection -> String -> IO Bool-isConnectedTo (Connection conn) name = do- v <- readMVar (getRef conn)- case v of- ConnClosed -> print "aa" >> return False- _ - | map toLower (connHost v) == map toLower name ->- catch (getPeerName (connSock v) >> return True) (const $ return False)- | otherwise -> return False+isConnectedTo :: Connection -> EndPoint -> IO Bool+isConnectedTo (Connection conn) endPoint = isTCPConnectedTo conn endPoint -isTCPConnectedTo :: HandleStream ty -> String -> IO Bool-isTCPConnectedTo conn name = do+isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool+isTCPConnectedTo conn endPoint = do v <- readMVar (getRef conn) case v of ConnClosed -> return False- _ - | map toLower (connHost v) == map toLower name -> - catch (getPeerName (connSock v) >> return True) (const $ return False)+ _+ | connEndPoint v == endPoint ->+ catchIO (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a)@@ -309,7 +348,7 @@ x <- bufferGetBlock ref n maybe (return ()) (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x)- (connHooks' conn)+ (connHooks' conn) return x -- This function uses a buffer, at this time the buffer is just 1000 characters.@@ -319,17 +358,17 @@ x <- bufferReadLine ref maybe (return ()) (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x)- (connHooks' conn)+ (connHooks' conn) return x --- The 'Connection' object allows no outward buffering, +-- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlockBS :: HandleStream a -> a -> IO (Result ()) writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do x <- bufferPutBlock (connBuffer conn) (connHandle conn) b maybe (return ()) (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x)- (connHooks' conn)+ (connHooks' conn) return x closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO ()@@ -340,7 +379,7 @@ conn <- readMVar (getRef c) maybe (return ()) (hook_close)- (connHooks' conn)+ (connHooks' conn) closeEOF :: HandleStream ty -> Bool -> IO () closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg})@@ -353,18 +392,18 @@ modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b}) return (return a) _ -> do- Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)- (\ e -> - if isEOFError e - then do- when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ())- return (return (buf_empty (connBuffer conn)))- else return (failMisc (show e)))+ catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return)+ (\ e ->+ if isEOFError e+ then do+ when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())+ return (return (buf_empty (connBuffer conn)))+ else return (failMisc (show e))) bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ())-bufferPutBlock ops h b = - Prelude.catch (buf_hPut ops h b >> hFlush h >> return (return ()))- (\ e -> return (failMisc (show e)))+bufferPutBlock ops h b =+ catchIO (buf_hPut ops h b >> hFlush h >> return (return ()))+ (\ e -> return (failMisc (show e))) bufferReadLine :: HStream a => HandleStream a -> IO (Result a) bufferReadLine ref = onNonClosedDo ref $ \ conn -> do@@ -374,20 +413,20 @@ let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0 modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) return (return (buf_append (connBuffer conn) a newl))- _ -> Prelude.catch - (buf_hGetLine (connBuffer conn) (connHandle conn) >>= - return . return . appendNL (connBuffer conn))+ _ -> catchIO+ (buf_hGetLine (connBuffer conn) (connHandle conn) >>=+ return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e then do- when (connCloseEOF conn) $ catch (closeQuick ref) (\ _ -> return ())- return (return (buf_empty (connBuffer conn)))+ when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())+ return (return (buf_empty (connBuffer conn))) else return (failMisc (show e))) where -- yes, this s**ks.. _may_ have to be addressed if perf -- suggests worthiness. appendNL ops b = buf_snoc ops b nl- + nl :: Word8 nl = fromIntegral (fromEnum '\n') @@ -397,4 +436,4 @@ case x of ConnClosed{} -> return (failWith ErrorClosed) _ -> act x- +
+ test/Httpd.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}++module Httpd+ ( Request, Response, Server+ , mkResponse+ , reqMethod, reqURI, reqHeaders, reqBody+ , shed+#ifdef WARP_TESTS+ , warp+#endif+ )+ where++import Control.Applicative+import Control.Arrow ( (***) )+import Control.DeepSeq+import Control.Monad+import Control.Monad.Trans ( liftIO )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as BLC+#ifdef WARP_TESTS+import qualified Data.CaseInsensitive as CI+#endif+import Data.Maybe ( fromJust )+import Network.URI ( URI, parseRelativeReference )++import Network.Socket+ ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily+ , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6)+ , defaultProtocol, SocketType(Stream), listen, setSocketOption, SocketOption(ReuseAddr)+ )+#ifdef WARP_TESTS+#if MIN_VERSION_network(2,4,0)+import Network.Socket ( bind )+#else+import Network.Socket ( bindSocket, Socket, SockAddr )+#endif+#endif++import qualified Network.Shed.Httpd as Shed+ ( Request, Response(Response), initServer+ , reqMethod, reqURI, reqHeaders, reqBody+ )+#ifdef WARP_TESTS+#if !MIN_VERSION_wai(3,0,0)+import qualified Data.Conduit.Lazy as Warp+#endif++import qualified Network.HTTP.Types as Warp+ ( Status(..) )+import qualified Network.Wai as Warp+import qualified Network.Wai.Handler.Warp as Warp+ ( runSettingsSocket, defaultSettings, setPort )+#endif++data Request = Request+ {+ reqMethod :: String,+ reqURI :: URI,+ reqHeaders :: [(String, String)],+ reqBody :: String+ }++data Response = Response+ {+ respStatus :: Int,+ respHeaders :: [(String, String)],+ respBody :: String+ }++mkResponse :: Int -> [(String, String)] -> String -> Response+mkResponse = Response++type Server = Int -> (Request -> IO Response) -> IO ()++shed :: Server+shed port handler =+ () <$ Shed.initServer+ port+ (liftM responseToShed . handler . requestFromShed)+ where+ responseToShed (Response status hdrs body) =+ Shed.Response status hdrs body+ chomp = reverse . strip '\r' . reverse+ strip c (c':str) | c == c' = str+ strip c str = str+ requestFromShed request =+ Request+ {+ reqMethod = Shed.reqMethod request,+ reqURI = Shed.reqURI request,+ reqHeaders = map (id *** chomp) $ Shed.reqHeaders request,+ reqBody = Shed.reqBody request+ }++#if !MIN_VERSION_bytestring(0,10,0)+instance NFData B.ByteString where+ rnf = rnf . B.length+#endif++#ifdef WARP_TESTS+#if !MIN_VERSION_network(2,4,0)+bind :: Socket -> SockAddr -> IO ()+bind = bindSocket+#endif++warp :: Bool -> Server+warp ipv6 port handler = do+ addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream })+ (Just $ if ipv6 then "::1" else "127.0.0.1")+ (Just . show $ port)+ case addrinfos of+ [] -> fail "Couldn't obtain address information in warp"+ (addri:_) -> do+ sock <- socket (addrFamily addri) Stream defaultProtocol+ setSocketOption sock ReuseAddr 1+ bind sock (addrAddress addri)+ listen sock 5+#if MIN_VERSION_wai(3,0,0)+ Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do+ request <- requestFromWarp warpRequest+ response <- handler request+ warpRespond (responseToWarp response)+#else+ Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do+ request <- requestFromWarp warpRequest+ response <- handler request+ return (responseToWarp response)+#endif+ where+ responseToWarp (Response status hdrs body) =+ Warp.responseLBS+ (Warp.Status status B.empty)+ (map headerToWarp hdrs)+ (BLC.pack body)+ headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value)+ headerFromWarp (name, value) =+ (BC.unpack (CI.original name), BC.unpack value)+ requestFromWarp request = do+#if MIN_VERSION_wai(3,0,1)+ body <- fmap BLC.unpack $ Warp.strictRequestBody request+#else+ body <- fmap BLC.unpack $ Warp.lazyRequestBody request+ body `deepseq` return ()+#endif+ return $+ Request+ {+ reqMethod = BC.unpack (Warp.requestMethod request),+ reqURI = fromJust . parseRelativeReference .+ BC.unpack . Warp.rawPathInfo $+ request,+ reqHeaders = map headerFromWarp (Warp.requestHeaders request),+ reqBody = body+ }+#endif
+ test/UnitTests.hs view
@@ -0,0 +1,69 @@+module UnitTests ( unitTests ) where++import Network.HTTP.Base+import Network.HTTP.Headers+import Network.URI++import Data.Maybe ( fromJust )++import Test.Framework ( testGroup )+import Test.Framework.Providers.HUnit+import Test.HUnit++parseIPv4Address :: Assertion+parseIPv4Address =+ assertEqual "127.0.0.1 address is recognised"+ (Just (URIAuthority {user = Nothing, password = Nothing, host = "127.0.0.1", port = Just 5313}))+ (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://127.0.0.1:5313/foo"))))+++parseIPv6Address :: Assertion+parseIPv6Address =+ assertEqual "::1 address"+ (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313}))+ (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo"))))++customHeaderNameComparison :: Assertion+customHeaderNameComparison =+ assertEqual "custom header name" (HdrCustom "foo") (HdrCustom "Foo")++customHeaderLookup :: Assertion+customHeaderLookup =+ let val = "header value"+ h = Header (HdrCustom "foo") val++ in assertEqual "custom header lookup" (Just val)+ (lookupHeader (HdrCustom "Foo") [h])++caseInsensitiveHeaderParse :: Assertion+caseInsensitiveHeaderParse =+ let expected = [ Header HdrContentType "blah"+ , Header (HdrCustom "X-Unknown") "unused"+ ]+ input = [ "content-type: blah"+ , "X-Unknown: unused"+ ]++ match actual =+ length actual == length expected &&+ and [ hdrName a == hdrName b && hdrValue a == hdrValue b+ | (a, b) <- zip expected actual+ ]++ in case parseHeaders input of+ Left _ -> assertFailure "Failed header parse"+ Right actual -> assert (match actual)++unitTests =+ [testGroup "Unit tests"+ [ testGroup "URI parsing"+ [ testCase "Parse IPv4 address" parseIPv4Address+ , testCase "Parse IPv6 address" parseIPv6Address+ ]+ ]+ , testGroup "Header tests"+ [ testCase "Custom header name case-insensitive match" customHeaderNameComparison+ , testCase "Custom header lookup" customHeaderLookup+ , testCase "Case-insensitive parsing" caseInsensitiveHeaderParse+ ]+ ]
+ test/httpTests.hs view
@@ -0,0 +1,668 @@+{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-}+import Control.Concurrent++import Control.Applicative ((<$))+import Control.Concurrent (threadDelay)+import Control.Exception (try)+import qualified Data.ByteString.Lazy.Char8 as BL (pack)+import Data.Char (isSpace)+import qualified Data.Digest.Pure.MD5 as MD5 (md5)+import Data.List.Split (splitOn)+import Data.Maybe (fromJust)+import System.IO.Error (userError)++import qualified Httpd+import qualified UnitTests++import Network.Browser+import Network.HTTP+import Network.HTTP.Base+import Network.HTTP.Auth+import Network.HTTP.Headers+import Network.Stream (Result)+import Network.URI (uriPath, parseURI)++import System.Environment (getArgs)+import System.Info (os)+import System.IO (getChar)++import Test.Framework (defaultMainWithArgs, testGroup)+import Test.Framework.Providers.HUnit+import Test.HUnit+++basicGetRequest :: (?testUrl :: ServerAddress) => Assertion+basicGetRequest = do+ response <- simpleHTTP (getRequest (?testUrl "/basic/get"))+ code <- getResponseCode response+ assertEqual "HTTP status code" (2, 0, 0) code+ body <- getResponseBody response+ assertEqual "Receiving expected response" "It works." body++basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion+basicGetRequestLBS = do+ response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get")))))+ code <- getResponseCode response+ assertEqual "HTTP status code" (2, 0, 0) code+ body <- getResponseBody response+ assertEqual "Receiving expected response" (BL.pack "It works.") body++basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion+basicHeadRequest = do+ response <- simpleHTTP (headRequest (?testUrl "/basic/head"))+ code <- getResponseCode response+ assertEqual "HTTP status code" (2, 0, 0) code+ body <- getResponseBody response+ -- the body should be empty, since this is a HEAD request+ assertEqual "Receiving expected response" "" body++basicExample :: (?testUrl :: ServerAddress) => Assertion+basicExample = do+ result <-+ -- sample code from Network.HTTP haddock, with URL changed+ -- Note there's also a copy of the example in the .cabal file+ simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody+ assertEqual "Receiving expected response" (take 100 haskellOrgText) result++secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion+secureGetRequest = do+ response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything"))+ assertEqual "Threw expected exception"+ (Left (userError "https not supported"))+ (fmap show response) -- fmap show because Response isn't in Eq++basicPostRequest :: (?testUrl :: ServerAddress) => Assertion+basicPostRequest = do+ let sendBody = "body"+ response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post")+ "text/plain"+ sendBody+ code <- getResponseCode response+ assertEqual "HTTP status code" (2, 0, 0) code+ body <- getResponseBody response+ assertEqual "Receiving expected response"+ (show (Just "text/plain", Just "4", sendBody))+ body++userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion+userpwAuthFailure = do+ response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic"))+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "HTTP status code" ((4, 0, 1),+ "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body)+ -- in case of 401, the server returns the contents of the Authz header++userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion+userpwAuthSuccess = do+ response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic"))+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)++basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion+basicAuthFailure = do+ response <- simpleHTTP (getRequest (?testUrl "/auth/basic"))+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body)++credentialsBasic :: (?testUrl :: ServerAddress) => Authority+credentialsBasic = AuthBasic "Testing realm" "test" "password"+ (fromJust . parseURI . ?testUrl $ "/auth/basic")++basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion+basicAuthSuccess = do+ let req = getRequest (?testUrl "/auth/basic")+ let authString = withAuthority credentialsBasic req+ let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req }+ response <- simpleHTTP reqWithAuth+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)++utf8URLEncode :: Assertion+utf8URLEncode = do+ assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com"+ assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD"+ assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE"++utf8URLDecode :: Assertion+utf8URLDecode = do+ assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com"+ assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow"+ assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好"+ assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо"++browserExample :: (?testUrl :: ServerAddress) => Assertion+browserExample = do+ result <-+ -- sample code from Network.Browser haddock, with URL changed+ -- Note there's also a copy of the example in the .cabal file+ do+ (_, rsp)+ <- Network.Browser.browse $ do+ setAllowRedirects True -- handle HTTP redirects+ request $ getRequest (?testUrl "/browser/example")+ return (take 100 (rspBody rsp))+ assertEqual "Receiving expected response" (take 100 haskellOrgText) result++-- A vanilla HTTP request using Browser shouldn't send a cookie header+browserNoCookie :: (?testUrl :: ServerAddress) => Assertion+browserNoCookie = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ request $ getRequest (?testUrl "/browser/no-cookie")+ let code = rspCode response+ assertEqual "HTTP status code" (2, 0, 0) code+++-- Regression test+-- * Browser sends vanilla request to server+-- * Server sets one cookie "hello=world"+-- * Browser sends a second request+--+-- Expected: Server gets single cookie with "hello=world"+-- Actual: Server gets 3 extra cookies, which are actually cookie attributes:+-- "$Version=0;hello=world;$Domain=localhost:8080\r"+browserOneCookie :: (?testUrl :: ServerAddress) => Assertion+browserOneCookie = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ -- This first requests returns a single Set-Cookie: hello=world+ _ <- request $ getRequest (?testUrl "/browser/one-cookie/1")++ -- This second request should send a single Cookie: hello=world+ request $ getRequest (?testUrl "/browser/one-cookie/2")+ let body = rspBody response+ assertEqual "Receiving expected response" "" body+ let code = rspCode response+ assertEqual "HTTP status code" (2, 0, 0) code++browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion+browserTwoCookies = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ -- This first request returns two cookies+ _ <- request $ getRequest (?testUrl "/browser/two-cookies/1")++ -- This second request should send them back+ request $ getRequest (?testUrl "/browser/two-cookies/2")+ let body = rspBody response+ assertEqual "Receiving expected response" "" body+ let code = rspCode response+ assertEqual "HTTP status code" (2, 0, 0) code+++browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion+browserFollowsRedirect n = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get")+ assertEqual "Receiving expected response from server"+ ((2, 0, 0), "It works.")+ (rspCode response, rspBody response)++browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion+browserReturnsRedirect n = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get")+ assertEqual "Receiving expected response from server"+ ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "")+ (rspCode response, rspBody response)++authGenBasic _ "Testing realm" = return $ Just ("test", "password")+authGenBasic _ realm = fail $ "Unexpected realm " ++ realm++browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion+browserBasicAuth = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())++ setAuthorityGen authGenBasic++ request $ getRequest (?testUrl "/auth/basic")++ assertEqual "Receiving expected response from server"+ ((2, 0, 0), "Here's the secret")+ (rspCode response, rspBody response)++authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword")+authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm++browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion+browserDigestAuth = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())++ setAuthorityGen authGenDigest++ request $ getRequest (?testUrl "/auth/digest")++ assertEqual "Receiving expected response from server"+ ((2, 0, 0), "Here's the digest secret")+ (rspCode response, rspBody response)++++browserAlt :: (?altTestUrl :: ServerAddress) => Assertion+browserAlt = do+ (response) <- browse $ do++ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?altTestUrl "/basic/get")++ return response1++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response, rspBody response)++-- test that requests to multiple servers on the same host+-- don't get confused with each other+browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion+browserBoth = do+ (response1, response2) <- browse $ do+ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?testUrl "/basic/get")+ (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")++ return (response1, response2)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response2, rspBody response2)++-- test that requests to multiple servers on the same host+-- don't get confused with each other+browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion+browserBothReversed = do+ (response1, response2) <- browse $ do+ setOutHandler (const $ return ())++ (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")+ (_, response1) <- request $ getRequest (?testUrl "/basic/get")++ return (response1, response2)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response2, rspBody response2)++browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion+browserSecureRequest = do+ res <- try $ browse $ do+ setOutHandler (const $ return ())++ request $ getRequest (?secureTestUrl "/anything")++ assertEqual "Threw expected exception"+ (Left (userError "https not supported"))+ (fmap show res) -- fmap show because Response isn't in Eq++-- in case it tries to reuse the connection+browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion+browserSecureRequestAfterInsecure = do+ res <- try $ browse $ do+ setOutHandler (const $ return ())++ request $ getRequest (?testUrl "/basic/get")+ request $ getRequest (?secureTestUrl "/anything")++ assertEqual "Threw expected exception"+ (Left (userError "https not supported"))+ (fmap show res) -- fmap show because Response isn't in Eq++browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion+browserRedirectToSecure = do+ res <- try $ browse $ do+ setOutHandler (const $ return ())+ setErrHandler fail++ request $ getRequest (?testUrl "/browser/redirect/secure/301/anything")++ assertEqual "Threw expected exception"+ (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything"))+ (fmap show res) -- fmap show because Response isn't in Eq++browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion+browserTwoRequests = do+ (response1, response2) <- browse $ do+ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?testUrl "/basic/get")+ (_, response2) <- request $ getRequest (?testUrl "/basic/get2")++ return (response1, response2)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works (2).")+ (rspCode response2, rspBody response2)+++browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion+browserTwoRequestsAlt = do+ (response1, response2) <- browse $ do++ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?altTestUrl "/basic/get")+ (_, response2) <- request $ getRequest (?altTestUrl "/basic/get2")++ return (response1, response2)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server (2).")+ (rspCode response2, rspBody response2)++browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion+browserTwoRequestsBoth = do+ (response1, response2, response3, response4) <- browse $ do+ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?testUrl "/basic/get")+ (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")+ (_, response3) <- request $ getRequest (?testUrl "/basic/get2")+ (_, response4) <- request $ getRequest (?altTestUrl "/basic/get2")++ return (response1, response2, response3, response4)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response2, rspBody response2)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works (2).")+ (rspCode response3, rspBody response3)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server (2).")+ (rspCode response4, rspBody response4)++hasPrefix :: String -> String -> Maybe String+hasPrefix [] ys = Just ys+hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys+hasPrefix _ _ = Nothing++maybeRead :: Read a => String -> Maybe a+maybeRead s =+ case reads s of+ [(v, "")] -> Just v+ _ -> Nothing++splitFields = map (toPair '=' . trim isSpace) . splitOn ","++toPair c str = case break (==c) str of+ (left, _:right) -> (left, right)+ _ -> error $ "No " ++ show c ++ " in " ++ str+trim f = dropWhile f . reverse . dropWhile f . reverse++isSubsetOf xs ys = all (`elem` ys) xs++-- first bits of result text from haskell.org (just to give some representative text)+haskellOrgText =+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\+\\t<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\+\\t<head>\+\\t\t<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\+\\t\t\t\t<meta name=\"keywords\" content=\"Haskell,Applications and libraries,Books,Foreign Function Interface,Functional programming,Hac Boston,HakkuTaikai,HaskellImplementorsWorkshop/2011,Haskell Communities and Activities Report,Haskell in education,Haskell in industry\" />"++digestMatch+ username realm password+ nonce opaque+ method relativeURI makeAbsolute+ headers+ =+ common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers)+ where+ common = [("username", show username), ("realm", show realm), ("nonce", show nonce),+ ("opaque", show opaque)]+ md5 = show . MD5.md5 . BL.pack+ ha1 = md5 (username++":"++realm++":"++password)+ ha2 uri = md5 (method++":"++uri)+ response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri)+ mkUncommon uri hash = [("uri", show uri), ("response", show hash)]+ relative = mkUncommon relativeURI (response relativeURI)+ absoluteURI = makeAbsolute relativeURI+ absolute = mkUncommon absoluteURI (response absoluteURI)++processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress)+ => Httpd.Request+ -> IO Httpd.Response+processRequest req = do+ case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of+ ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works."+ ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)."+ ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."+ ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."+ ("POST", "/basic/post") ->+ let typ = lookup "Content-Type" (Httpd.reqHeaders req)+ len = lookup "Content-Length" (Httpd.reqHeaders req)+ body = Httpd.reqBody req+ in return $ Httpd.mkResponse 200 [] (show (typ, len, body))++ ("GET", "/basic/example") ->+ return $ Httpd.mkResponse 200 [] haskellOrgText++ ("GET", "/auth/basic") ->+ case lookup "Authorization" (Httpd.reqHeaders req) of+ Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret"+ x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x)++ ("GET", "/auth/digest") ->+ case lookup "Authorization" (Httpd.reqHeaders req) of+ Just (hasPrefix "Digest " -> Just (splitFields -> items))+ | digestMatch "test" "Digest testing realm" "digestpassword"+ "87e4" "057d"+ "GET" "/auth/digest" ?testUrl+ items+ -> return $ Httpd.mkResponse 200 [] "Here's the digest secret"+ x -> return $ Httpd.mkResponse+ 401+ [("WWW-Authenticate",+ "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")]+ (show x)++ ("GET", "/browser/example") ->+ return $ Httpd.mkResponse 200 [] haskellOrgText+ ("GET", "/browser/no-cookie") ->+ case lookup "Cookie" (Httpd.reqHeaders req) of+ Nothing -> return $ Httpd.mkResponse 200 [] ""+ Just s -> return $ Httpd.mkResponse 500 [] s+ ("GET", "/browser/one-cookie/1") ->+ return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] ""+ ("GET", "/browser/one-cookie/2") ->+ case lookup "Cookie" (Httpd.reqHeaders req) of+ Just "hello=world" -> return $ Httpd.mkResponse 200 [] ""+ Just s -> return $ Httpd.mkResponse 500 [] s+ Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)+ ("GET", "/browser/two-cookies/1") ->+ return $ Httpd.mkResponse 200+ [("Set-Cookie", "hello=world")+ ,("Set-Cookie", "goodbye=cruelworld")]+ ""+ ("GET", "/browser/two-cookies/2") ->+ case lookup "Cookie" (Httpd.reqHeaders req) of+ -- TODO generalise the cookie parsing to allow for whitespace/ordering variations+ Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] ""+ Just s -> return $ Httpd.mkResponse 500 [] s+ Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)+ ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->+ return $ Httpd.mkResponse n [("Location", rest)] ""+ ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->+ return $ Httpd.mkResponse n [("Location", ?testUrl rest)] ""+ ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->+ return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] ""+ _ -> return $ Httpd.mkResponse 500 [] "Unknown request"++altProcessRequest :: Httpd.Request -> IO Httpd.Response+altProcessRequest req = do+ case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of+ ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server."+ ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)."+ _ -> return $ Httpd.mkResponse 500 [] "Unknown request"++maybeTestGroup True name xs = testGroup name xs+maybeTestGroup False name _ = testGroup name []++basicTests =+ testGroup "Basic tests"+ [ testCase "Basic GET request" basicGetRequest+ , testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS+ , testCase "Network.HTTP example code" basicExample+ , testCase "Secure GET request" secureGetRequest+ , testCase "Basic POST request" basicPostRequest+ , testCase "Basic HEAD request" basicHeadRequest+ , testCase "URI user:pass Auth failure" userpwAuthFailure+ , testCase "URI user:pass Auth success" userpwAuthSuccess+ , testCase "Basic Auth failure" basicAuthFailure+ , testCase "Basic Auth success" basicAuthSuccess+ , testCase "UTF-8 urlEncode" utf8URLEncode+ , testCase "UTF-8 urlDecode" utf8URLDecode+ ]++browserTests =+ testGroup "Browser tests"+ [ testGroup "Basic"+ [+ testCase "Network.Browser example code" browserExample+ , testCase "Two requests" browserTwoRequests+ ]+ , testGroup "Secure"+ [+ testCase "Secure request" browserSecureRequest+ , testCase "After insecure" browserSecureRequestAfterInsecure+ , testCase "Redirection" browserRedirectToSecure+ ]+ , testGroup "Cookies"+ [ testCase "No cookie header" browserNoCookie+ , testCase "One cookie" browserOneCookie+ , testCase "Two cookies" browserTwoCookies+ ]+ , testGroup "Redirection"+ [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection+ -- 300 Multiple Choices: client has to handle this+ testCase "300" (browserReturnsRedirect 300)+ -- 301 Moved Permanently: should follow+ , testCase "301" (browserFollowsRedirect 301)+ -- 302 Found: should follow+ , testCase "302" (browserFollowsRedirect 302)+ -- 303 See Other: should follow (directly for GETs)+ , testCase "303" (browserFollowsRedirect 303)+ -- 304 Not Modified: maybe Browser could do something intelligent based on+ -- being given locally cached content and sending If-Modified-Since, but it+ -- doesn't at the moment+ , testCase "304" (browserReturnsRedirect 304)+ -- 305 Use Proxy: test harness doesn't have a proxy (yet)+ -- 306 Switch Proxy: obsolete+ -- 307 Temporary Redirect: should follow+ , testCase "307" (browserFollowsRedirect 307)+ -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this+ , testCase "308" (browserReturnsRedirect 308)+ ]+ , testGroup "Authentication"+ [ testCase "Basic" browserBasicAuth+ , testCase "Digest" browserDigestAuth+ ]+ ]++port80Tests =+ testGroup "Multiple servers"+ [ testCase "Alternate server" browserAlt+ , testCase "Both servers" browserBoth+ , testCase "Both servers (reversed)" browserBothReversed+ , testCase "Two requests - alternate server" browserTwoRequestsAlt+ , testCase "Two requests - both servers" browserTwoRequestsBoth+ ]++data InetFamily = IPv4 | IPv6++familyToLocalhost :: InetFamily -> String+familyToLocalhost IPv4 = "127.0.0.1"+familyToLocalhost IPv6 = "[::1]"++urlRoot :: InetFamily -> String -> Int -> String+urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam+urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n++secureRoot :: InetFamily -> String -> Int -> String+secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam+secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n++type ServerAddress = String -> String++httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress+httpAddress fam userpw port p = urlRoot fam userpw port ++ p+httpsAddress fam userpw port p = secureRoot fam userpw port ++ p++main :: IO ()+main = do+ args <- getArgs++ let servers =+ [ ("httpd-shed", Httpd.shed, IPv4)+#ifdef WARP_TESTS+ , ("warp.v6", Httpd.warp True, IPv6)+ , ("warp.v4", Httpd.warp False, IPv4)+#endif+ ]+ basePortNum, altPortNum :: Int+ basePortNum = 5812+ altPortNum = 80+ numberedServers = zip [basePortNum..] servers++ let setupNormalTests = do+ flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do+ let ?testUrl = httpAddress family "" portNum+ ?userpwUrl = httpAddress family "test:password@" portNum+ ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum+ ?secureTestUrl = httpsAddress family "" portNum+ _ <- forkIO $ server portNum processRequest+ return $ testGroup serverName [basicTests, browserTests]++ let setupAltTests = do+ let (portNum, (_, server,family)) = head numberedServers+ let ?testUrl = httpAddress family "" portNum+ ?altTestUrl = httpAddress family "" altPortNum+ _ <- forkIO $ server altPortNum altProcessRequest+ return port80Tests++ case args of+ ["server"] -> do -- run only the harness servers for diagnostic/debug purposes+ -- halt on any keypress+ _ <- setupNormalTests+ _ <- setupAltTests+ _ <- getChar+ return ()+ ("--withport80":args) -> do+ normalTests <- setupNormalTests+ altTests <- setupAltTests+ _ <- threadDelay 1000000 -- Give the server time to start :-(+ defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args+ args -> do -- run the test harness as normal+ normalTests <- setupNormalTests+ _ <- threadDelay 1000000 -- Give the server time to start :-(+ defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args