diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 . + * 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 diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -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 -Maintainer: Ganesh Sittampalam -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 - -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 +Maintainer: Ganesh Sittampalam +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: + . + * + . + * (in combination with + ) + . + * + . + * + . + +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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -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 + +Maintainer : Ganesh Sittampalam 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 . +-- 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) - diff --git a/Network/BufferType.hs b/Network/BufferType.hs --- a/Network/BufferType.hs +++ b/Network/BufferType.hs @@ -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 +-- Maintainer : Ganesh Sittampalam -- 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 } diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -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 +-- +-- Maintainer : Ganesh Sittampalam -- 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 diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs --- a/Network/HTTP/Auth.hs +++ b/Network/HTTP/Auth.hs @@ -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 +-- +-- Maintainer : Ganesh Sittampalam -- 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 } diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -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 +-- +-- Maintainer : Ganesh Sittampalam -- 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)) diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs --- a/Network/HTTP/Base64.hs +++ b/Network/HTTP/Base64.hs @@ -8,8 +8,8 @@ -- Stability : experimental -- Portability : portable -- --- Base64 encoding and decoding functions provided by Warwick Gray. --- See +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See -- and . -- ----------------------------------------------------------------------------- @@ -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 diff --git a/Network/HTTP/Cookie.hs b/Network/HTTP/Cookie.hs --- a/Network/HTTP/Cookie.hs +++ b/Network/HTTP/Cookie.hs @@ -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 +-- +-- Maintainer : Ganesh Sittampalam -- 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==':')) diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -1,10 +1,10 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.HandleStream --- Copyright : (c) 2008- Sigbjorn Finne +-- Copyright : See LICENSE file -- License : BSD --- --- Maintainer : Sigbjorn Finne +-- +-- Maintainer : Ganesh Sittampalam -- 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 diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs --- a/Network/HTTP/Headers.hs +++ b/Network/HTTP/Headers.hs @@ -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 +-- +-- Maintainer : Ganesh Sittampalam -- 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 diff --git a/Network/HTTP/MD5.hs b/Network/HTTP/MD5.hs deleted file mode 100644 --- a/Network/HTTP/MD5.hs +++ /dev/null @@ -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 --- and . --- ------------------------------------------------------------------------------ - -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:[]) diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs --- a/Network/HTTP/MD5Aux.hs +++ b/Network/HTTP/MD5Aux.hs @@ -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 diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -2,16 +2,15 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Proxy --- Copyright : (c) 2009 Eric Kow +-- Copyright : See LICENSE file -- License : BSD --- --- Maintainer : Sigbjorn Finne --- Author : Eric Kow +-- +-- Maintainer : Ganesh Sittampalam -- 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 diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs --- a/Network/HTTP/Stream.hs +++ b/Network/HTTP/Stream.hs @@ -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 +-- +-- Maintainer : Ganesh Sittampalam -- 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 () diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs --- a/Network/HTTP/Utils.hs +++ b/Network/HTTP/Utils.hs @@ -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 +-- Maintainer : Ganesh Sittampalam -- 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' diff --git a/Network/Stream.hs b/Network/Stream.hs --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -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 +-- Maintainer : Ganesh Sittampalam -- 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 ()) diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs --- a/Network/StreamDebugger.hs +++ b/Network/StreamDebugger.hs @@ -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 +-- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- @@ -13,7 +13,7 @@ -- -- * Changes by Robin Bate Boerop : -- - 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 diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -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 +-- Maintainer : Ganesh Sittampalam -- 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) diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -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 +-- Maintainer : Ganesh Sittampalam -- 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 - + diff --git a/test/Httpd.hs b/test/Httpd.hs new file mode 100644 --- /dev/null +++ b/test/Httpd.hs @@ -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 diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -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 + ] + ] diff --git a/test/httpTests.hs b/test/httpTests.hs new file mode 100644 --- /dev/null +++ b/test/httpTests.hs @@ -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 = + "\ +\\t\ +\\t\ +\\t\t\ +\\t\t\t\t" + +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