diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,6 +1,24 @@ + * 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,110 @@ -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 +Name: HTTP +Version: 4000.2.0 +Cabal-Version: >= 1.8 +Build-type: Simple +License: BSD3 +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://google.com/" + > fmap (take 100) (getResponseBody rsp) + > + +Extra-Source-Files: CHANGES + +Source-Repository head + type: git + location: https://github.com/haskell/HTTP.git + +Flag old-base + description: Old, monolithic base + default: False + +Flag mtl1 + description: Use the old mtl version 1. + 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.MD5Aux, + Network.HTTP.Utils + Paths_HTTP + GHC-options: -fwarn-missing-signatures -Wall + Build-depends: base >= 2 && < 4.5, network, parsec + Extensions: FlexibleInstances + if flag(old-base) + Build-depends: base < 3 + else + Build-depends: base >= 3, array, old-time, bytestring + if flag(mtl1) + Build-depends: mtl >= 1.1 && < 1.2 + CPP-Options: -DMTL1 + else + Build-depends: mtl >= 2.0 && < 2.1 + + if os(windows) + Build-depends: Win32 + +Test-Suite test + type: exitcode-stdio-1.0 + + build-tools: ghc >= 6.10 && < 7.4 + + hs-source-dirs: test + main-is: httpTests.hs + + build-depends: HTTP, + HUnit, + httpd-shed, + base >= 2 && < 4.5, + network, + split >= 0.1 && < 0.2, + test-framework, + test-framework-hunit 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,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-} {- | Module : Network.Browser @@ -26,11 +27,12 @@ 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 @@ -66,6 +68,9 @@ , 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) @@ -132,7 +137,13 @@ import Data.Char (toLower) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe, listToMaybe, catMaybes ) -import Control.Monad (filterM, liftM, when) +import Control.Applicative (Applicative (..), (<$>)) +#ifdef MTL1 +import Control.Monad (filterM, when, ap) +#else +import Control.Monad (filterM, when) +#endif +import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..)) import qualified System.IO ( hSetBuffering, hPutStr, stdout, stdin, hGetChar @@ -172,18 +183,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... @@ -199,11 +210,11 @@ -- | @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 ---------------------- @@ -264,55 +275,55 @@ -- | @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. setMaxAuthAttempts :: Maybe Int -> BrowserAction t () 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 +346,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) @@ -385,6 +396,7 @@ , bsMaxRedirects :: Maybe Int , bsMaxErrorRetries :: Maybe Int , bsMaxAuthAttempts :: Maybe Int + , bsMaxPoolSize :: Maybe Int , bsConnectionPool :: [connection] , bsCheckProxy :: Bool , bsProxy :: Proxy @@ -401,22 +413,25 @@ ++ "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) } +newtype BrowserAction conn a + = BA { unBA :: StateT (BrowserState conn) IO a } +#ifdef MTL1 + deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn)) -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) +instance Applicative (BrowserAction conn) where + pure = return + (<*>) = ap +#else + deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)) +#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 defaultBrowserState :: BrowserState t @@ -428,8 +443,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,6 +451,7 @@ , bsMaxRedirects = Nothing , bsMaxErrorRetries = Nothing , bsMaxAuthAttempts = Nothing + , bsMaxPoolSize = Nothing , bsConnectionPool = [] , bsCheckProxy = defaultAutoProxyDetect , bsProxy = noProxy @@ -446,21 +461,15 @@ , 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 @@ -472,37 +481,38 @@ 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 -- 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 -- we are willing to jump through. A no-op if the count is negative; if zero, @@ -512,13 +522,24 @@ setMaxRedirects :: Maybe Int -> BrowserAction t () 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 @@ -527,24 +548,24 @@ 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 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 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 +575,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,24 +584,31 @@ -- 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 +-- compatability 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 @@ -636,7 +664,7 @@ -- 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 @@ -650,11 +678,11 @@ 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 @@ -706,6 +734,7 @@ -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) request' nullVal rqState rq = do let uri = rqURI rq + failHTTPS uri let uria = reqURIAuth rq -- add cookies to request cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) @@ -733,9 +762,9 @@ 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 + def_ua <- gets bsUserAgent let defaultOpts = case p of NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} @@ -832,7 +861,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!" @@ -846,7 +875,7 @@ } 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 @@ -903,35 +932,8 @@ , reqStopOnDeny = True } rq - (3,_,_) -> redirect uri rsp _ -> 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 @@ -939,15 +941,15 @@ -> BrowserAction (HandleStream ty) (Result (Response ty)) dorequest hst rqst = do - pool <- getBS bsConnectionPool - conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool + 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 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 + c <- liftIO $ openStream (uriRegName hst) uPort updateConnectionPool c dorequest2 c rqst (c:_) -> do @@ -960,17 +962,17 @@ return rsp where dorequest2 c r = do - dbg <- getBS bsDebug - st <- getBrowserState + dbg <- gets bsDebug + st <- get let onSendComplete = maybe (return ()) (\evh -> do x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) - (lift (evh x)) st + runBA st (evh x) return ()) (bsEvent st) - ioAction $ + liftIO $ maybe (sendHTTP_notify c r onSendComplete) (\ f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c @@ -981,19 +983,20 @@ => 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)) + (liftIO $ close (last pool)) let pool' | len_pool > maxPoolSize = init pool | otherwise = pool - alterBS (\b -> b { bsConnectionPool=c: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 handleCookies :: URI -> String -> [Header] -> BrowserAction t () handleCookies _ _ [] = return () -- cut short the silliness. @@ -1003,7 +1006,7 @@ 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' diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -38,6 +38,8 @@ -- 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.Base @@ -58,6 +60,7 @@ , getRequest -- :: String -> Request_String , postRequest -- :: String -> Request_String + , postRequestWithBody -- :: String -> String -> String -> Request_String , getResponseBody -- :: Requesty ty -> ty ) where @@ -97,6 +100,7 @@ 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 @@ -153,6 +157,18 @@ case parseURI urlString of Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest POST u + +-- | @postRequestWithBody urlString typ body@ is convenience constructor for +-- POST 'Request's. 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 @urlString@ isn\'t a syntactically valid URL, the function raises +-- an error. +postRequestWithBody :: String -> String -> String -> Request_String +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 diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs --- a/Network/HTTP/Auth.hs +++ b/Network/HTTP/Auth.hs @@ -26,7 +26,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 ) @@ -122,14 +122,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) @@ -158,11 +155,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) } @@ -210,9 +207,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 @@ -80,8 +80,10 @@ , defaultGETRequest , defaultGETRequest_ , mkRequest + , setRequestBody , defaultUserAgent + , httpPackageVersion , libUA {- backwards compatibility, will disappear..soon -} , catchIO @@ -92,6 +94,8 @@ , getResponseVersion , setRequestVersion , setResponseVersion + + , failHTTPS ) where @@ -120,6 +124,9 @@ import Control.Exception as Exception (IOException) +import qualified Paths_HTTP as Self (version) +import Data.Version (showVersion) + ----------------------------------------------------------------- ------------------ URI Authority parsing ------------------------ ----------------------------------------------------------------- @@ -190,6 +197,11 @@ default_http = 80 default_https = 443 +failHTTPS :: Monad m => URI -> m () +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. @@ -336,12 +348,26 @@ ------------------------------------------------------------------ ------------------ 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 @@ -367,6 +393,14 @@ 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) @@ -800,7 +834,7 @@ 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.? + _ <- 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 diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs --- a/Network/HTTP/Base64.hs +++ b/Network/HTTP/Base64.hs @@ -196,11 +196,13 @@ 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, @@ -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 @@ -17,7 +17,7 @@ , cookieMatch -- :: (String,String) -> Cookie -> Bool -- functions for translating cookies and headers. - , cookieToHeader -- :: Cookie -> Header + , cookiesToHeader -- :: [Cookie] -> Header , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) ) where @@ -54,18 +54,16 @@ && 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. @@ -93,14 +91,13 @@ 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 @@ -111,14 +108,14 @@ -- 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 = @@ -136,10 +133,9 @@ 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 @@ -53,6 +53,7 @@ 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)) simpleHTTP_ c r @@ -61,6 +62,7 @@ simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty)) 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 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/StreamDebugger.hs b/Network/StreamDebugger.hs --- a/Network/StreamDebugger.hs +++ b/Network/StreamDebugger.hs @@ -23,7 +23,8 @@ 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 ) @@ -75,6 +76,7 @@ | 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 diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Network.StreamSocket diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -15,6 +15,7 @@ ----------------------------------------------------------------------------- module Network.TCP ( Connection + , EndPoint(..) , openTCPPort , isConnectedTo @@ -77,12 +78,18 @@ newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} +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 + , connEndPoint :: EndPoint , connHooks :: Maybe (StreamHooks a) , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. } @@ -135,7 +142,7 @@ -- 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 ()) @@ -155,7 +162,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 @@ -205,14 +212,16 @@ openTCPConnection uri port = openTCPConnection_ uri port False openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) -openTCPConnection_ uri port stashInput = do - s <- socket AF_INET Stream 6 +openTCPConnection_ uri port stashInput = withSocket $ \s -> do 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 + connect s a + socketConnection_ uri port s stashInput where + withSocket action = do + s <- socket AF_INET Stream 6 + catchIO (action s) (\e -> sClose s >> ioError e) getHostAddr h = do catchIO (inet_addr uri) -- handles ascii IP numbers (\ _ -> do @@ -228,18 +237,20 @@ -- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. socketConnection :: BufferType ty => String + -> Int -> Socket -> IO (HandleStream ty) -socketConnection hst sock = socketConnection_ hst sock False +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 + -> Int -> Socket -> Bool -> IO (HandleStream ty) -socketConnection_ hst sock stashInput = do +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 @@ -247,7 +258,7 @@ , connHandle = h , connBuffer = bufferOps , connInput = mb - , connHost = hst + , connEndPoint = EndPoint hst port , connHooks = Nothing , connCloseEOF = False } @@ -284,23 +295,23 @@ -- | 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 +isConnectedTo :: Connection -> EndPoint -> IO Bool +isConnectedTo (Connection conn) endPoint = do v <- readMVar (getRef conn) case v of ConnClosed -> print "aa" >> return False _ - | map toLower (connHost v) == map toLower name -> + | connEndPoint v == endPoint -> catch (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False -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 -> + | connEndPoint v == endPoint -> catch (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False diff --git a/test/httpTests.hs b/test/httpTests.hs new file mode 100644 --- /dev/null +++ b/test/httpTests.hs @@ -0,0 +1,574 @@ +{-# LANGUAGE ViewPatterns #-} +import Control.Concurrent + +import Control.Applicative ((<$)) +import Control.Concurrent (threadDelay) +import Control.Exception (try) +import Data.Char (isSpace) +import Data.List.Split (splitOn) +import Data.Maybe (fromJust) +import System.IO.Error (userError) + +import qualified Network.Shed.Httpd as Httpd + +import Network.Browser +import Network.HTTP +import Network.HTTP.Auth +import Network.HTTP.Headers +import Network.Stream (Result) +import Network.URI (uriPath, parseURI) + +import System.Environment (getArgs) +import System.IO (getChar) + +import Test.Framework (defaultMainWithArgs, testGroup) +import Test.Framework.Providers.HUnit +import Test.HUnit + + +basicGetRequest :: 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 + +basicExample :: Assertion +basicExample = do + result <- + -- sample code from Network.HTTP haddock, with URL changed + simpleHTTP (getRequest (testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody + assertEqual "Receiving expected response" (take 100 haskellOrgText) result + +secureGetRequest :: 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 :: 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\r", Just "4\r", sendBody)) + body + +basicAuthFailure :: 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 = AuthBasic "Testing realm" "test" "password" + (fromJust . parseURI . testUrl $ "/auth/basic") + +basicAuthSuccess :: 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) + +browserExample :: Assertion +browserExample = do + result <- + -- sample code from Network.Browser haddock, with URL changed + 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 shouln't send a cookie header +browserNoCookie :: 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 :: Assertion +browserOneCookie = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 + -- 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 :: Assertion +browserTwoCookies = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 + -- 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 :: Int -> Assertion +browserFollowsRedirect n = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 + 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 :: Int -> Assertion +browserReturnsRedirect n = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 + 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 :: Assertion +browserBasicAuth = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 + + 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 :: Assertion +browserDigestAuth = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 + + 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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 :: 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" + +processRequest :: Httpd.Request -> IO Httpd.Response +processRequest req = do + case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of + ("GET", "/basic/get") -> return $ Httpd.Response 200 [] "It works." + ("GET", "/basic/get2") -> return $ Httpd.Response 200 [] "It works (2)." + ("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.Response 200 [] (show (typ, len, body)) + + ("GET", "/basic/example") -> + return $ Httpd.Response 200 [] haskellOrgText + + ("GET", "/auth/basic") -> + case lookup "Authorization" (Httpd.reqHeaders req) of + Just "Basic dGVzdDpwYXNzd29yZA==\r" -> return $ Httpd.Response 200 [] "Here's the secret" + x -> return $ Httpd.Response 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)) + | [("username", show "test"), ("realm", show "Digest testing realm"), ("nonce", show "87e4"), + ("uri", show (testUrl "/auth/digest")), ("opaque", show "057d"), + ("response", show "ace810a3cfb830489a3b48e90a02b2ae")] `isSubsetOf` items + -> return $ Httpd.Response 200 [] "Here's the digest secret" + | [("username", show "test"), ("realm", show "Digest testing realm"), ("nonce", show "87e4"), + ("uri", show "/auth/digest"), ("opaque", show "057d"), + ("response", show "4845c3faf4dcb125b8dcc88b5c20bb89")] `isSubsetOf` items + -> return $ Httpd.Response 200 [] "Here's the digest secret" + x -> return $ Httpd.Response + 401 + [("WWW-Authenticate", + "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")] + (show x) + + ("GET", "/browser/example") -> + return $ Httpd.Response 200 [] haskellOrgText + ("GET", "/browser/no-cookie") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + Nothing -> return $ Httpd.Response 200 [] "" + Just s -> return $ Httpd.Response 500 [] s + ("GET", "/browser/one-cookie/1") -> + return $ Httpd.Response 200 [("Set-Cookie", "hello=world")] "" + ("GET", "/browser/one-cookie/2") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + -- TODO: is it correct to expect the \r at the end? + Just "hello=world\r" -> return $ Httpd.Response 200 [] "" + Just s -> return $ Httpd.Response 500 [] s + Nothing -> return $ Httpd.Response 500 [] (show $ Httpd.reqHeaders req) + ("GET", "/browser/two-cookies/1") -> + return $ Httpd.Response 200 + [("Set-Cookie", "hello=world") + ,("Set-Cookie", "goodbye=cruelworld")] + "" + ("GET", "/browser/two-cookies/2") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + -- TODO: is it correct to expect the \r at the end? + -- TODO generalise the cookie parsing to allow for whitespace/ordering variations + Just "goodbye=cruelworld; hello=world\r" -> return $ Httpd.Response 200 [] "" + Just s -> return $ Httpd.Response 500 [] s + Nothing -> return $ Httpd.Response 500 [] (show $ Httpd.reqHeaders req) + ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.Response n [("Location", rest)] "" + ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.Response n [("Location", testUrl rest)] "" + ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.Response n [("Location", secureTestUrl rest)] "" + _ -> return $ Httpd.Response 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.Response 200 [] "This is the alternate server." + ("GET", "/basic/get2") -> return $ Httpd.Response 200 [] "This is the alternate server (2)." + _ -> return $ Httpd.Response 500 [] "Unknown request" + +getResponseCode :: Result (Response a) -> IO ResponseCode +getResponseCode (Left err) = fail (show err) +getResponseCode (Right r) = return (rspCode r) + +maybeTestGroup True name xs = testGroup name xs +maybeTestGroup False name _ = testGroup name [] + +tests port80Server = + [ testGroup "Basic tests" + [ testCase "Basic GET request" basicGetRequest + , testCase "Network.HTTP example code" basicExample + , testCase "Secure GET request" secureGetRequest + , testCase "Basic POST request" basicPostRequest + , testCase "Basic Auth failure" basicAuthFailure + , testCase "Basic Auth success" basicAuthSuccess + ] + , testGroup "Browser tests" + [ testGroup "Basic" + [ + -- github issue 14 + -- testCase "Two requests" browserTwoRequests + testCase "Network.Browser example code" browserExample + ] + , 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 + ] + ] + , maybeTestGroup port80Server "Multiple servers" + [ testCase "Alternate server" browserAlt + , testCase "Both servers" browserBoth + , testCase "Both servers (reversed)" browserBothReversed + -- github issue 14 + -- , testCase "Two requests - alternate server" browserTwoRequestsAlt + -- , testCase "Two requests - both servers" browserTwoRequestsBoth + ] + ] + +portNum :: Int +portNum = 5812 + +altPortNum :: Int +altPortNum = 80 + +urlRoot :: Int -> String +urlRoot 80 = "http://localhost" +urlRoot n = "http://localhost:" ++ show n + +secureRoot :: Int -> String +secureRoot 443 = "https://localhost" +secureRoot n = "https://localhost:" ++ show n + +testUrl :: String -> String +testUrl p = urlRoot portNum ++ p + +altTestUrl :: String -> String +altTestUrl p = urlRoot altPortNum ++ p + +secureTestUrl :: String -> String +secureTestUrl p = secureRoot portNum ++ p + +main :: IO () +main = do + args <- getArgs + case args of + ["server"] -> do -- run only the harness servers for diagnostic/debug purposes + -- halt on any keypress + _ <- forkIO (() <$ Httpd.initServer portNum processRequest) + _ <- forkIO (() <$ Httpd.initServer altPortNum altProcessRequest) + _ <- getChar + return () + ("--withport80":args) -> do + _ <- forkIO (() <$ Httpd.initServer portNum processRequest) + _ <- forkIO (() <$ Httpd.initServer altPortNum altProcessRequest) + _ <- threadDelay 1000000 -- Give the server time to start :-( + defaultMainWithArgs (tests True) args + args -> do -- run the test harness as normal + _ <- forkIO (() <$ Httpd.initServer portNum processRequest) + _ <- threadDelay 1000000 -- Give the server time to start :-( + defaultMainWithArgs (tests False) args +