From acf257c29589d2c827dbb346fec51f9558c9adee Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 25 2020 13:56:54 +0000 Subject: ghc-HTTP-4000.3.9 base --- diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..d149851 --- /dev/null +++ b/CHANGES @@ -0,0 +1,119 @@ + * 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. + +Version 4000.1.0: release 2010-11-09 + * Retroactively fixed CHANGES to refer to 4000.x.x instead of + 4004.x.x. + * Fix problem with close looping on certain URLs due to trying + to munch the rest of the stream even on EOF. Modified from + a fix by Daniel Wagner. + * This involves a new class member for HStream and is thus an + API change, but one that will only affect clients that + define their own payload type to replace String/ByteString. + * Applied patch by Antoine Latter to fix problem with 301 and 307 + redirects. + +Version 4000.0.10: release 2010-10-29 + * Bump base dependency to support GHC 7.0. + * Stop using 'fail' from the Either monad and instead build Left + values explicitly; the behaviour of fail is changing in GHC 7.0 + and this avoids being sensitive to the change. + +Version 4000.0.9: release 2009-12-20 + + * Export headerMap from Network.HTTP.Headers + (suggested by David Leuschner.) + * Fix Network.TCP.{isTCPConnectedTo,isConnectedTo} to be useful. + * Always delay closing non-persistent connections until we reach EOF. + Delaying it until then is vital when reading the response out as a + lazy ByteString; all of the I/O may not have happened by the time we + were returning the HTTP response. Bug manifested itself occasionally + with larger responses. Courtesy of Valery Vorotyntsev; both untiring bug + hunt and fix. + * drop unused type argument from Network.Browser.BrowserEvent; needlessly general. + (patch provided by Daniel Wagner.) + +Version 4000.0.8: release 2009-08-05 + + * Incorporated proxy setting lookup and parsing contribution + by Eric Kow; provided in Network.HTTP.Proxy + * Factor out HTTP Cookies and Auth handling into separate + modules Network.HTTP.Cookie, Network.HTTP.Auth + * new Network.Browser functionality for hooking up the + proxy detection code in Network.HTTP.Proxy: + + setCheckForProxy :: Bool -> BrowserAction t () + getCheckForProxy :: BrowserAction t Bool + + If you do 'setCheckForProxy True' within a browser + session, the proxy-checking code will be called upon. + Use 'getCheckForProxy' to get the current setting for + this flag. + + * Network.Browser: if HTTP Basic Auth is allowed and + server doesn't 401-challenge with an WWW-Authenticate: + header, simply assume / realm and proceed. Preferable + than failing, even if server is the wrong. + +Version 4000.0.7: release 2009-05-22 + + * Minor release. + * Added + Network.TCP.openSocketStream :: (BufferType t) + => String {-host-} + -> Socket + -> IO (HandleStream t) + + for interfacing to pre-existing @Socket@s. Contributed and + suggested by . + +Version 4000.0.6: release 2009-04-21; changes from 4000.0.5 + + * Network.Browser: use HTTP.HandleStream.sendHTTP_notify, not HTTP.sendHTTP_notify + when issuing requests. The latter runs the risk of undoing request normalization. + * Network.HTTP.Base.normalizeRequest: when normalizing proxy-bound requests, + insert a Host: header if none present. Set it to the destination server authority, + not the proxy. + * Network.Browser: don't fail on seeing invalid cookie values, but report them + as errors and continue. + +Version 4000.0.5: release 2009-03-30; changes from 4000.0.4 + + * Get serious about comments and Haddock documentation. + * Cleaned up normalization of requests, fixing bugs and bringing together + previous disparate attempts at handling this. + * RequestMethod now supports custom verbs; use the (Custom String) constructor + * Beef up Network.HTTP.Base's support for normalizing requests and URIs: + + * added splitRequestURI which divides a URI into two; the Authority portion + (as a String) and the input URI sans the authority portion. Useful when + wanting to split up a request's URI into its Host: and abs_path pieces. + * added normalizeRequest :: Bool -> Request ty -> Request ty, which + fixes up a requests URI path and Host: info depending on whether it is + destined for a proxy or not (controlled by the Bool.) + * moved defaultRequest, defaultRequest_, libUA from Network.Browser + to Network.HTTP.Base + * added mkRequest :: RequestMethod -> URI -> Bool -> Request ty + for constructing normalized&sane Request bases on top of which + you can add custom headers, body payload etc. + diff --git a/HTTP.cabal b/HTTP.cabal new file mode 100644 index 0000000..d35a9fb --- /dev/null +++ b/HTTP.cabal @@ -0,0 +1,182 @@ +Name: HTTP +Version: 4000.3.9 +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://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 + +Source-Repository head + type: git + location: https://github.com/haskell/HTTP.git + +Flag mtl1 + description: Use the old mtl version 1. + default: False + +Flag warn-as-error + default: False + description: Build with warnings-as-errors + manual: True + +Flag network23 + description: Use version 2.3.x or below of the network package + default: False + +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: True + manual: True + +flag network-uri + description: Get Network.URI from the network-uri package + default: True + +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 + + -- note the test harness constraints should be kept in sync with these + -- where dependencies are shared + Build-depends: base >= 4.3.0.0 && < 4.11, parsec >= 2.0 && < 3.2 + Build-depends: array >= 0.3.0.2 && < 0.6, bytestring >= 0.9.1.5 && < 0.11 + Build-depends: time >= 1.1.2.3 && < 1.9 + + Extensions: FlexibleInstances + + if flag(mtl1) + Build-depends: mtl >= 1.1.1.0 && < 1.2 + CPP-Options: -DMTL1 + else + Build-depends: mtl >= 2.0 && < 2.3 + + if flag(network-uri) + Build-depends: network-uri == 2.6.*, network == 2.6.* + else + Build-depends: network >= 2.2.1.8 && < 2.6 + + if flag(warn-as-error) + ghc-options: -Werror + + if os(windows) + Build-depends: Win32 >= 2.2.0.0 && < 2.6 + +Test-Suite test + type: exitcode-stdio-1.0 + + hs-source-dirs: test + main-is: httpTests.hs + + other-modules: + Httpd + UnitTests + + -- note: version constraints for dependencies shared with the library + -- should be the same + build-depends: HTTP, + HUnit >= 1.2.0.1 && < 1.7, + httpd-shed >= 0.4 && < 0.5, + mtl >= 1.1.1.0 && < 2.3, + bytestring >= 0.9.1.5 && < 0.11, + deepseq >= 1.3.0.0 && < 1.5, + pureMD5 >= 0.2.4 && < 2.2, + base >= 4.3.0.0 && < 4.11, + split >= 0.1.3 && < 0.3, + test-framework >= 0.2.0 && < 0.9, + test-framework-hunit >= 0.3.0 && <0.4 + + if flag(network-uri) + Build-depends: network-uri == 2.6.*, network == 2.6.* + else + Build-depends: network >= 2.2.1.5 && < 2.6 + + if flag(warp-tests) + CPP-Options: -DWARP_TESTS + build-depends: + case-insensitive >= 0.4.0.1 && < 1.3, + http-types >= 0.8.0 && < 1.0, + wai >= 2.1.0 && < 3.3, + warp >= 2.1.0 && < 3.3 + + if flag(conduit10) + build-depends: + conduit >= 1.0.8 && < 1.1 + else + build-depends: + conduit >= 1.1 && < 1.3, + conduit-extra >= 1.1 && < 1.3 + + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d806bd3 --- /dev/null +++ b/LICENSE @@ -0,0 +1,46 @@ +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-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. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/Browser.hs b/Network/Browser.hs new file mode 100644 index 0000000..a018c02 --- /dev/null +++ b/Network/Browser.hs @@ -0,0 +1,1091 @@ +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-} +{- | + +Module : Network.Browser +Copyright : See LICENSE file +License : BSD + +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 +HTTP. Additional features supported are: + +* HTTP Authentication handling + +* Transparent handling of redirects + +* Cookie stores + transmission. + +* Transaction logging + +* Proxy-mediated connections. + +Example use: + +> do +> (_, rsp) +> <- Network.Browser.browse $ do +> setAllowRedirects True -- handle HTTP redirects +> request $ getRequest "http://www.haskell.org/" +> return (take 100 (rspBody rsp)) + +-} +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 + , addAuthority + , 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) + + , setCookieFilter -- :: (URI -> Cookie -> IO Bool) -> BrowserAction t () + , 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 + + , setCheckForProxy -- :: Bool -> BrowserAction t () + , 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 + ) where + +import Network.URI + ( URI(..) + , URIAuth(..) + , parseURI, parseURIReference, relativeTo + ) +import Network.StreamDebugger (debugByteStream) +import Network.HTTP hiding ( sendHTTP_notify ) +import Network.HTTP.HandleStream ( sendHTTP_notify ) +import Network.HTTP.Auth +import Network.HTTP.Cookie +import Network.HTTP.Proxy + +import Network.Stream ( ConnError(..), Result ) +import Network.BufferType + +import Data.Char (toLower) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe, listToMaybe, catMaybes ) +import Control.Applicative (Applicative (..), (<$>)) +#ifdef MTL1 +import Control.Monad (filterM, forM_, when, ap) +#else +import Control.Monad (filterM, forM_, when) +#endif +import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..)) + +import qualified System.IO + ( hSetBuffering, hPutStr, stdout, stdin, hGetChar + , BufferMode(NoBuffering, LineBuffering) + ) +import Data.Time.Clock ( UTCTime, getCurrentTime ) + + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- | @defaultCookieFilter@ is the initial cookie acceptance filter. +-- It welcomes them all into the store @:-)@ +defaultCookieFilter :: URI -> Cookie -> IO Bool +defaultCookieFilter _url _cky = return True + +-- | @userCookieFilter@ is a handy acceptance filter, asking the +-- user if he/she is willing to accept an incoming cookie before +-- adding it to the store. +userCookieFilter :: URI -> Cookie -> IO Bool +userCookieFilter url cky = do + do putStrLn ("Set-Cookie received when requesting: " ++ show url) + case ckComment cky of + Nothing -> return () + Just x -> putStrLn ("Cookie Comment:\n" ++ x) + let pth = maybe "" ('/':) (ckPath cky) + putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth) + putStrLn (ckName cky ++ '=' : ckValue cky) + System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering + System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering + System.IO.hPutStr System.IO.stdout "Accept [y/n]? " + x <- System.IO.hGetChar System.IO.stdin + System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering + System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering + return (toLower x == 'y') + +-- | @addCookie c@ adds a cookie to the browser state, removing duplicates. +addCookie :: Cookie -> BrowserAction t () +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 = modify (\b -> b { bsCookies=cs }) + +-- | @getCookies@ returns the current set of cookies known to +-- the browser. +getCookies :: BrowserAction t [Cookie] +getCookies = gets bsCookies + +-- ...get domain specific cookies... +-- ... this needs changing for consistency with rfc2109... +-- ... currently too broad. +getCookiesFor :: String -> String -> BrowserAction t [Cookie] +getCookiesFor dom path = + do cks <- getCookies + return (filter cookiematch cks) + 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 = modify (\b -> b { bsCookieFilter=f }) + +-- | @getCookieFilter@ returns the current cookie acceptance filter. +getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) +getCookieFilter = gets bsCookieFilter + +------------------------------------------------------------------ +----------------------- Authorisation Stuff ---------------------- +------------------------------------------------------------------ + +{- + +The browser handles 401 responses in the following manner: + 1) extract all WWW-Authenticate headers from a 401 response + 2) rewrite each as a Challenge object, using "headerToChallenge" + 3) pick a challenge to respond to, usually the strongest + challenge understood by the client, using "pickChallenge" + 4) generate a username/password combination using the browsers + "bsAuthorityGen" function (the default behaviour is to ask + the user) + 5) build an Authority object based upon the challenge and user + data, store this new Authority in the browser state + 6) convert the Authority to a request header and add this + to a request using "withAuthority" + 7) send the amended request + +Note that by default requests are annotated with authority headers +before the first sending, based upon previously generated Authority +objects (which contain domain information). Once a specific authority +is added to a rejected request this predictive annotation is suppressed. + +407 responses are handled in a similar manner, except + a) Authorities are not collected, only a single proxy authority + is kept by the browser + b) If the proxy used by the browser (type Proxy) is NoProxy, then + a 407 response will generate output on the "err" stream and + the response will be returned. + + +Notes: + - 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 + - doesn't properly receive AuthenticationInfo headers, so fails + to use next-nonce etc + +-} + +-- | Return authorities for a given domain and path. +-- Assumes "dom" is lower case +getAuthFor :: String -> String -> BrowserAction t [Authority] +getAuthFor dom pth = getAuthorities >>= return . (filter match) + where + match :: Authority -> Bool + match au@AuthBasic{} = matchURI (auSite au) + match au@AuthDigest{} = or (map matchURI (auDomain au)) + + 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 = gets bsAuthorities + +-- @setAuthorities as@ replaces the Browser's known set +-- of 'Authority's to @as@. +setAuthorities :: [Authority] -> BrowserAction t () +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 = modify (\b -> b { bsAuthorities=a:bsAuthorities b }) + +-- | @getAuthorityGen@ returns the current authority generator +getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) +getAuthorityGen = gets bsAuthorityGen + +-- | @setAuthorityGen genAct@ sets the auth generator to @genAct@. +setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () +setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f }) + +-- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication. +setAllowBasicAuth :: Bool -> BrowserAction t () +setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba }) + +getAllowBasicAuth :: BrowserAction t Bool +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 = 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 = 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 = modify (\ b -> b{bsMaxErrorRetries=mb}) + +-- | @getMaxErrorRetries@ returns the current max number of error retries. +getMaxErrorRetries :: BrowserAction t (Maybe Int) +getMaxErrorRetries = gets bsMaxErrorRetries + +-- TO BE CHANGED!!! +pickChallenge :: Bool -> [Challenge] -> Maybe Challenge +pickChallenge allowBasic [] + | allowBasic = Just (ChalBasic "/") -- manufacture a challenge if one missing; more robust. +pickChallenge _ ls = listToMaybe ls + +-- | Retrieve a likely looking authority for a Request. +anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority) +anticipateChallenge rq = + let uri = rqURI rq in + do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri) + ; return (listToMaybe authlist) + } + +-- | Asking the user to respond to a challenge +challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) +challengeToAuthority uri ch + | not (answerable ch) = return Nothing + | otherwise = do + -- prompt user for authority + prompt <- getAuthorityGen + userdetails <- liftIO $ prompt uri (chRealm ch) + case userdetails of + Nothing -> return Nothing + Just (u,p) -> return (Just $ buildAuth ch u p) + where + answerable :: Challenge -> Bool + answerable ChalBasic{} = True + answerable chall = (chAlgorithm chall) == Just AlgMD5 + + buildAuth :: Challenge -> String -> String -> Authority + buildAuth (ChalBasic r) u p = + AuthBasic { auSite=uri + , auRealm=r + , auUsername=u + , auPassword=p + } + + -- note to self: this is a pretty stupid operation + -- to perform isn't it? ChalX and AuthX are so very + -- similar. + buildAuth (ChalDigest r d n o _stale a q) u p = + AuthDigest { auRealm=r + , auUsername=u + , auPassword=p + , auDomain=d + , auNonce=n + , auOpaque=o + , auAlgorithm=a + , auQop=q + } + + +------------------------------------------------------------------ +------------------ Browser State Actions ------------------------- +------------------------------------------------------------------ + + +-- | @BrowserState@ is the (large) record type tracking the current +-- settings of the browser. +data BrowserState connection + = BS { bsErr, bsOut :: String -> IO () + , bsCookies :: [Cookie] + , bsCookieFilter :: URI -> Cookie -> IO Bool + , bsAuthorityGen :: URI -> String -> IO (Maybe (String,String)) + , bsAuthorities :: [Authority] + , bsAllowRedirects :: Bool + , bsAllowBasicAuth :: Bool + , bsMaxRedirects :: Maybe Int + , bsMaxErrorRetries :: Maybe Int + , bsMaxAuthAttempts :: Maybe Int + , bsMaxPoolSize :: Maybe Int + , bsConnectionPool :: [connection] + , bsCheckProxy :: Bool + , bsProxy :: Proxy + , bsDebug :: Maybe String + , bsEvent :: Maybe (BrowserEvent -> BrowserAction connection ()) + , bsRequestID :: RequestID + , bsUserAgent :: Maybe String + } + +instance Show (BrowserState t) where + 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'. +newtype BrowserAction conn a + = BA { unBA :: StateT (BrowserState conn) IO a } +#ifdef MTL1 + deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn)) + +instance Applicative (BrowserAction conn) where + pure = return + (<*>) = ap +#else + deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)) +#endif + +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 = runBA defaultBrowserState + +-- | The default browser state has the settings +defaultBrowserState :: BrowserState t +defaultBrowserState = res + where + res = BS + { bsErr = putStrLn + , bsOut = putStrLn + , bsCookies = [] + , bsCookieFilter = defaultCookieFilter + , bsAuthorityGen = \ _uri _realm -> do + bsErr res "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing" + return Nothing + , bsAuthorities = [] + , bsAllowRedirects = True + , bsAllowBasicAuth = False + , bsMaxRedirects = Nothing + , bsMaxErrorRetries = Nothing + , bsMaxAuthAttempts = Nothing + , bsMaxPoolSize = Nothing + , bsConnectionPool = [] + , bsCheckProxy = defaultAutoProxyDetect + , bsProxy = noProxy + , bsDebug = Nothing + , bsEvent = Nothing + , bsRequestID = 0 + , bsUserAgent = Nothing + } + +{-# 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 = get + +-- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@. +withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a +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 + rid = succ (bsRequestID st) + in + rid `seq` st{bsRequestID=rid} + 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 = 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 = modify (\b -> b { bsErr=h }) + +-- | @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 = modify (\b -> b { bsOut=h }) + +out, err :: String -> BrowserAction t () +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 = modify (\b -> b {bsAllowRedirects=bl}) + +-- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag. +getAllowRedirects :: BrowserAction t Bool +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, +-- 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 + | fromMaybe 0 c < 0 = return () + | 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 = 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 +-- '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. + 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 <- 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 <- gets bsCheckProxy + if not flg + then return p + else do + 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 + +-- | @setCheckForProxy flg@ sets the one-time check for proxy +-- flag to @flg@. If @True@, the session will try to determine +-- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy' +-- for details of how this done. +setCheckForProxy :: Bool -> BrowserAction t () +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 +-- set it to that via 'setCheckForProxy' and subsequently performed +-- some HTTP protocol interactions. i.e., the flag return represents +-- whether a proxy will be checked for again before any future protocol +-- interactions. +getCheckForProxy :: BrowserAction t Bool +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 = 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 = modify (\b -> b{bsUserAgent=Just ua}) + +-- | @getUserAgent@ returns the current @User-Agent:@ default string. +getUserAgent :: BrowserAction t String +getUserAgent = do + 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 +-- forwards we've gone through. +data RequestState + = RequestState + { reqDenies :: Int -- ^ number of 401 responses so far + , reqRedirects :: Int -- ^ number of redirects so far + , reqRetries :: Int -- ^ number of retries so far + , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response + } + +type RequestID = Int -- yeah, it will wrap around. + +nullRequestState :: RequestState +nullRequestState = RequestState + { reqDenies = 0 + , reqRedirects = 0 + , reqRetries = 0 + , reqStopOnDeny = True + } + +-- | @BrowserEvent@ is the event record type that a user-defined handler, set +-- via 'setEventHandler', will be passed. It indicates various state changes +-- encountered in the processing of a given 'RequestID', along with timestamps +-- at which they occurred. +data BrowserEvent + = BrowserEvent + { browserTimestamp :: UTCTime + , browserRequestID :: RequestID + , browserRequestURI :: {-URI-}String + , browserEventType :: BrowserEventType + } + +-- | 'BrowserEventType' is the enumerated list of events that the browser +-- internals will report to a user-defined event handler. +data BrowserEventType + = OpenConnection + | ReuseConnection + | RequestSent + | ResponseEnd ResponseData + | ResponseFinish +{- not yet, you will have to determine these via the ResponseEnd event. + | Redirect + | 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 = modify (\b -> b { bsEvent=mbH}) + +buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent +buildBrowserEvent bt uri reqID = do + ct <- getCurrentTime + return BrowserEvent + { browserTimestamp = ct + , browserRequestID = reqID + , browserRequestURI = uri + , browserEventType = bt + } + +reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () +reportEvent bt uri = do + st <- get + case bsEvent st of + Nothing -> return () + Just evH -> do + 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 +-- request forwardings. +defaultMaxRetries :: Int +defaultMaxRetries = 4 + +-- | The default number of error retries we are willing to perform. +defaultMaxErrorRetries :: Int +defaultMaxErrorRetries = 4 + +-- | The default maximum HTTP Authentication attempts we will make for +-- a single request. +defaultMaxAuthAttempts :: Int +defaultMaxAuthAttempts = 2 + +-- | The default setting for auto-proxy detection. +-- You may change this within a session via 'setAutoProxyDetect'. +-- To avoid initial backwards compatibility issues, leave this as @False@. +defaultAutoProxyDetect :: Bool +defaultAutoProxyDetect = False + +-- | @request httpRequest@ tries to submit the 'Request' @httpRequest@ +-- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.) +-- Upon successful delivery, the URL where the response was fetched from +-- is returned along with the 'Response' itself. +request :: HStream ty + => Request ty + -> BrowserAction (HandleStream ty) (URI,Response ty) +request req = nextRequest $ do + res <- request' nullVal initialState req + reportEvent ResponseFinish (show (rqURI req)) + case res of + Right r -> return r + Left e -> do + let errStr = ("Network.Browser.request: Error raised " ++ show e) + err errStr + fail errStr + where + initialState = nullRequestState + nullVal = buf_empty bufferOps + +-- | Internal helper function, explicitly carrying along per-request +-- counts. +request' :: HStream ty + => ty + -> RequestState + -> Request ty + -> 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) +{- Not for now: + (case uriUserInfo uria of + "" -> id + xs -> + case chopAtDelim ':' xs of + (_,[]) -> id + (usr,pwd) -> withAuth + AuthBasic{ auUserName = usr + , auPassword = pwd + , auRealm = "/" + , auSite = uri + }) $ do +-} + 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 + auth <- anticipateChallenge rq + case auth of + Nothing -> return rq + Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) + let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq' + p <- getProxy + 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 <- + 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 + } + -- 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, + -- then host:port. Fall back to just the string given (probably a host name). + let proxyURIAuth = + maybe notURI + (\parsed -> maybe notURI id (uriAuthority parsed)) + (parseURI str) + + out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth + dorequest proxyURIAuth final_req + mbMx <- getMaxErrorRetries + case e_rsp of + 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 -> + return (Left v) + Right rsp -> do + out ("Received:\n" ++ show rsp) + -- add new cookies to browser state + 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 + out "401 - credentials not supplied or refused; retrying.." + let hdrs = retrieveHeaders HdrWWWAuthenticate rsp + flg <- getAllowBasicAuth + case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> do + 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 -} + Just au' -> do + out "Retrying request with new credentials" + request' nullVal + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } + (insertHeader HdrAuthorization (withAuthority au' rq) rq) + + (4,0,7) -- Proxy Authentication required + | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do + out "407 - proxy authentication required; max deny count exceeeded (2)" + return (Right (uri,rsp)) + | otherwise -> do + out "407 - proxy authentication required" + let hdrs = retrieveHeaders HdrProxyAuthenticate rsp + flg <- getAllowBasicAuth + case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> return (Right (uri,rsp)) {- do nothing -} + Just x -> do + au <- challengeToAuthority uri x + case au of + Nothing -> return (Right (uri,rsp)) {- do nothing -} + Just au' -> do + pxy <- gets bsProxy + case pxy of + NoProxy -> do + err "Proxy authentication required without proxy!" + return (Right (uri,rsp)) + Proxy px _ -> do + out "Retrying with proxy authentication" + setProxy (Proxy px (Just au')) + request' nullVal + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } + rq + + (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 + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location: header in redirect response" + return (Right (uri,rsp)) + (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 ++ " ...") + + -- 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 + } + rq2 + where + newURI_abs = uriDefaultTo newURI uri + + (3,0,5) -> + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location header in proxy redirect response." + return (Right (uri,rsp)) + (Header _ u:_) -> + case parseURIReference u of + Nothing -> do + err ("Parse of Location header in a proxy redirect response failed: " ++ u) + return (Right (uri,rsp)) + Just newuri -> do + 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 + _ -> return (Right (uri,rsp)) + +-- | The internal request handling state machine. +dorequest :: (HStream ty) + => URIAuth + -> Request ty + -> BrowserAction (HandleStream ty) + (Result (Response ty)) +dorequest hst rqst = do + 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) + 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)) + dorequest2 c rqst + 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 <- gets bsDebug + st <- get + let + onSendComplete = + maybe (return ()) + (\evh -> do + x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) + runBA st (evh x) + return ()) + (bsEvent st) + liftIO $ + maybe (sendHTTP_notify c r onSendComplete) + (\ f -> do + c' <- debugByteStream (f++'-': uriAuthToString hst) c + sendHTTP_notify c' r onSendComplete) + dbg + +updateConnectionPool :: HStream hTy + => HandleStream hTy + -> BrowserAction (HandleStream hTy) () +updateConnectionPool c = do + pool <- gets bsConnectionPool + let len_pool = length pool + maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize + when (len_pool > maxPoolSize) + (liftIO $ close (last pool)) + let pool' + | len_pool > maxPoolSize = init pool + | otherwise = pool + when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' }) + return () + +-- | 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 + when (not $ null errs) + (err $ unlines ("Errors parsing these cookie values: ":errs)) + when (not $ null newCookies) + (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies) + filterfn <- getCookieFilter + 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 ---------------------------- +------------------------------------------------------------------ + +allowRedirect :: RequestState -> BrowserAction t Bool +allowRedirect rqState = do + rd <- getAllowRedirects + mbMxRetries <- getMaxRedirects + return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries)) + +-- | Return @True@ iff the package is able to handle requests and responses +-- over it. +supportedScheme :: URI -> Bool +supportedScheme u = uriScheme u == "http:" + +-- | @uriDefaultTo a b@ returns a URI that is consistent with the first +-- argument URI @a@ when read in the context of the second URI @b@. +-- 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... + +type FormVar = (String,String) + +data Form = Form RequestMethod URI [FormVar] + +formToRequest :: Form -> Request_String +formToRequest (Form m u vs) = + let enc = urlEncodeVars vs + in case m of + GET -> Request { rqMethod=GET + , rqHeaders=[ Header HdrContentLength "0" ] + , rqBody="" + , rqURI=u { uriQuery= '?' : enc } -- What about old query? + } + POST -> Request { rqMethod=POST + , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded", + Header HdrContentLength (show $ length enc) ] + , rqBody=enc + , rqURI=u + } + _ -> error ("unexpected request: " ++ show m) + + diff --git a/Network/BufferType.hs b/Network/BufferType.hs new file mode 100644 index 0000000..a78dc27 --- /dev/null +++ b/Network/BufferType.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.BufferType +-- Description : Abstract representation of request and response buffer types. +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- In order to give the user freedom in how request and response content +-- is represented, a sufficiently abstract representation is needed of +-- these internally. The "Network.BufferType" module provides this, defining +-- the 'BufferType' class and its ad-hoc representation of buffer operations +-- via the 'BufferOp' record. +-- +-- 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(..) + , strictBufferOp + , lazyBufferOp + , stringBufferOp + ) where + + +import qualified Data.ByteString as Strict hiding ( unpack, pack, span ) +import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span ) +import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) +import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) +import System.IO ( Handle ) +import Data.Word ( Word8 ) + +import Network.HTTP.Utils ( crlf, lf ) + +-- | The @BufferType@ class encodes, in a mixed-mode way, the interface +-- 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 + +instance BufferType Lazy.ByteString where + bufferOps = lazyBufferOp + +instance BufferType Strict.ByteString where + bufferOps = strictBufferOp + +instance BufferType String where + bufferOps = stringBufferOp + +-- | @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. +-- +-- Along with IO operations is an ad-hoc collection of functions for working +-- with these abstract buffers, as needed by the internals of the code +-- that processes requests and responses. +-- +-- We supply three default @BufferOp@ values, for @String@ along with the +-- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@ +-- definitions for +data BufferOp a + = BufferOp + { buf_hGet :: Handle -> Int -> IO a + , buf_hGetContents :: Handle -> IO a + , buf_hPut :: Handle -> a -> IO () + , buf_hGetLine :: Handle -> IO a + , buf_empty :: a + , buf_append :: a -> a -> a + , buf_concat :: [a] -> a + , buf_fromStr :: String -> a + , buf_toStr :: a -> String + , buf_snoc :: a -> Word8 -> a + , buf_splitAt :: Int -> a -> (a,a) + , buf_span :: (Char -> Bool) -> a -> (a,a) + , buf_isLineTerm :: a -> Bool + , buf_isEmpty :: a -> Bool + } + +instance Eq (BufferOp a) where + _ == _ = False + +-- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-lazy kind. +strictBufferOp :: BufferOp Strict.ByteString +strictBufferOp = + BufferOp + { buf_hGet = Strict.hGet + , buf_hGetContents = Strict.hGetContents + , buf_hPut = Strict.hPut + , buf_hGetLine = Strict.hGetLine + , buf_append = Strict.append + , buf_concat = Strict.concat + , buf_fromStr = Strict.pack + , buf_toStr = Strict.unpack + , buf_snoc = Strict.snoc + , buf_splitAt = Strict.splitAt + , buf_span = Strict.span + , 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 + } + where + p_crlf = Strict.pack crlf + p_lf = Strict.pack lf + +-- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-strict kind. +lazyBufferOp :: BufferOp Lazy.ByteString +lazyBufferOp = + BufferOp + { buf_hGet = Lazy.hGet + , buf_hGetContents = Lazy.hGetContents + , buf_hPut = Lazy.hPut + , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) + , buf_append = Lazy.append + , buf_concat = Lazy.concat + , buf_fromStr = Lazy.pack + , buf_toStr = Lazy.unpack + , buf_snoc = Lazy.snoc + , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x + , buf_span = Lazy.span + , 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 + } + where + p_crlf = Lazy.pack crlf + p_lf = Lazy.pack lf + +-- | @stringBufferOp@ is the 'BufferOp' definition over @String@s. +-- It is defined in terms of @strictBufferOp@ operations, +-- unpacking/converting to @String@ when needed. +stringBufferOp :: BufferOp String +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) + , buf_hGetLine = \ h -> buf_hGetLine strictBufferOp h >>= return . Strict.unpack + , buf_append = (++) + , buf_concat = concat + , buf_fromStr = id + , buf_toStr = id + , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] + , buf_splitAt = splitAt + , buf_span = \ p a -> + case Strict.span p (Strict.pack a) of + (x,y) -> (Strict.unpack x, Strict.unpack y) + , buf_empty = [] + , buf_isLineTerm = \ b -> b == crlf || b == lf + , buf_isEmpty = null + } + diff --git a/Network/HTTP.hs b/Network/HTTP.hs new file mode 100644 index 0000000..1ab6dd2 --- /dev/null +++ b/Network/HTTP.hs @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- The 'Network.HTTP' module provides a simple interface for sending and +-- receiving content over HTTP in Haskell. Here's how to fetch a document from +-- a URL and return it as a String: +-- +-- > +-- > simpleHTTP (getRequest "http://www.haskell.org/") >>= fmap (take 100) . getResponseBody +-- > -- fetch document and return it (as a 'String'.) +-- +-- Other functions let you control the submission and transfer of HTTP +-- 'Request's and 'Response's more carefully, letting you integrate the use +-- of 'Network.HTTP' functionality into your application. +-- +-- The module also exports the main types of the package, 'Request' and 'Response', +-- along with 'Header' and functions for working with these. +-- +-- The actual functionality is implemented by modules in the @Network.HTTP.*@ +-- 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 +-- 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. +-- 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 +-- @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 + , module Network.HTTP.Headers + + {- 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) + , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response) + , receiveHTTP -- :: Stream s => s -> IO (Result Request) + , respondHTTP -- :: Stream s => s -> Response -> IO () + + , module Network.TCP + + , getRequest -- :: String -> Request_String + , headRequest -- :: String -> Request_String + , postRequest -- :: String -> Request_String + , postRequestWithBody -- :: String -> String -> String -> Request_String + + , getResponseBody -- :: Result (Request ty) -> IO ty + , getResponseCode -- :: Result (Request ty) -> IO ResponseCode + ) where + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.HTTP.Headers +import Network.HTTP.Base +import qualified Network.HTTP.HandleStream as S +-- old implementation: import Network.HTTP.Stream +import Network.TCP +import Network.Stream ( Result ) +import Network.URI ( parseURI ) + +import Data.Maybe ( fromMaybe ) + +{- + Note: if you switch over/back to using Network.HTTP.Stream here, you'll + have to wrap the results from 'openStream' as Connections via 'hstreamToConnection' + prior to delegating to the Network.HTTP.Stream functions. +-} + +-- | @simpleHTTP req@ transmits the 'Request' @req@ by opening a /direct/, non-persistent +-- connection to the HTTP server that @req@ is destined for, followed by transmitting +-- it and gathering up the response as a 'Result'. Prior to sending the request, +-- it is normalized (via 'normalizeRequest'). If you have to mediate the request +-- via an HTTP proxy, you will have to normalize the request yourself. Or switch to +-- using 'Network.Browser' instead. +-- +-- Examples: +-- +-- > simpleHTTP (getRequest "http://hackage.haskell.org/") +-- > simpleHTTP (getRequest "http://hackage.haskell.org:8012/") + +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 + let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r + S.sendHTTP s norm_r + +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ (after normalization) over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- 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 + S.sendHTTP conn norm_r + +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + S.sendHTTP_notify conn norm_r onSendComplete + +-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ +receiveHTTP :: HStream ty => HandleStream ty -> IO (Result (Request ty)) +receiveHTTP conn = S.receiveHTTP conn + +-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over +-- 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 = S.respondHTTP conn rsp + + +-- | 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 + +-- | 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. +getResponseBody :: Result (Response ty) -> IO ty +getResponseBody (Left err) = fail (show err) +getResponseBody (Right r) = return (rspBody r) + +-- | @getResponseBody 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 +-- - https upgrade (includes full TLS, i.e. SSL, implementation) +-- - use of Stream classes will pay off +-- - consider C implementation of encryption\/decryption +-- - 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@] +-- If this header is present in any request or +-- response, and it's value is "close", then +-- 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 +-- header has the value \"100-continue\". After +-- 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 +-- or will generate an error response (probably 4xx). +-- +-- +-- * Response code notes +-- Some response codes induce special behaviour: +-- +-- [@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 +-- request attempt (without Expect header), unless no Expect header +-- had been added (in which case 417 response is returned). diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs new file mode 100644 index 0000000..81df3e7 --- /dev/null +++ b/Network/HTTP/Auth.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Auth +-- Copyright : See LICENSE file +-- License : BSD +-- +-- 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(..) + , Algorithm(..) + , Challenge(..) + , Qop(..) + + , headerToChallenge -- :: URI -> Header -> Maybe Challenge + , withAuthority -- :: Authority -> Request ty -> String + ) where + +import Network.URI +import Network.HTTP.Base +import Network.HTTP.Utils +import Network.HTTP.Headers ( Header(..) ) +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 ) + +import Data.Char +import Data.Maybe +import Data.Word ( Word8 ) + +-- | @Authority@ specifies the HTTP Authentication method to use for +-- a given domain/realm; @Basic@ or @Digest@. +data Authority + = AuthBasic { auRealm :: String + , auUsername :: String + , auPassword :: String + , auSite :: URI + } + | AuthDigest{ auRealm :: String + , auUsername :: String + , auPassword :: String + , auNonce :: String + , auAlgorithm :: Maybe Algorithm + , auDomain :: [URI] + , auOpaque :: Maybe String + , auQop :: [Qop] + } + + +data Challenge + = ChalBasic { chRealm :: String } + | ChalDigest { chRealm :: String + , chDomain :: [URI] + , chNonce :: String + , chOpaque :: Maybe String + , chStale :: Bool + , chAlgorithm ::Maybe Algorithm + , chQop :: [Qop] + } + +-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. +data Algorithm = AlgMD5 | AlgMD5sess + deriving(Eq) + +instance Show Algorithm where + 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 + -- 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" + ] + where + quo s = '"':s ++ "\"" + + rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) + + a1, a2 :: String + a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a + + {- + If the "qop" directive's value is "auth" or is unspecified, then A2 + is: + A2 = Method ":" digest-uri-value + If the "qop" value is "auth-int", then A2 is: + A2 = Method ":" digest-uri-value ":" H(entity-body) + -} + a2 = show (rqMethod rq) ++ ":" ++ digesturi + + digesturi = show (rqURI rq) + noncevalue = auNonce a + +type Octet = Word8 + +-- FIXME: these probably only work right for latin-1 strings +stringToOctets :: String -> [Octet] +stringToOctets = map (fromIntegral . fromEnum) + +base64encode :: String -> String +base64encode = Base64.encode . stringToOctets + +md5 :: String -> String +md5 = MD5.md5s . MD5.Str + +kd :: String -> String -> String +kd a b = md5 (a ++ ":" ++ b) + + + + +-- | @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) = + case parse challenge "" str of + Left{} -> Nothing + Right (name,props) -> case name of + "basic" -> mkBasic props + "digest" -> mkDigest props + _ -> Nothing + where + challenge :: Parser (String,[(String,String)]) + challenge = + do { nme <- word + ; spaces + ; pps <- cprops + ; return (map toLower nme,pps) + } + + cprops = sepBy1 cprop comma + + comma = do { spaces ; _ <- char ',' ; spaces } + + cprop = + do { nm <- word + ; _ <- char '=' + ; val <- quotedstring + ; return (map toLower nm,val) + } + + mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge + + mkBasic params = fmap ChalBasic (lookup "realm" params) + + mkDigest params = + -- with Maybe monad + do { r <- lookup "realm" params + ; n <- lookup "nonce" params + ; return $ + ChalDigest { chRealm = r + , chDomain = (annotateURIs + $ map parseURI + $ words + $ fromMaybe [] + $ lookup "domain" params) + , chNonce = n + , chOpaque = lookup "opaque" params + , chStale = "true" == (map toLower + $ fromMaybe "" (lookup "stale" params)) + , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params) + , chQop = readQop (fromMaybe "" $ lookup "qop" params) + } + } + + 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] + readQop = catMaybes . (map strToQop) . (splitBy ',') + + strToQop qs = case map toLower (trim qs) of + "auth" -> Just QopAuth + "auth-int" -> Just QopAuthInt + _ -> Nothing + + readAlgorithm astr = case map toLower (trim astr) of + "md5" -> Just AlgMD5 + "md5-sess" -> Just AlgMD5sess + _ -> Nothing + +word, quotedstring :: Parser String +quotedstring = + do { _ <- char '"' -- " + ; str <- many (satisfy $ not . (=='"')) + ; _ <- char '"' + ; return str + } + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs new file mode 100644 index 0000000..72939de --- /dev/null +++ b/Network/HTTP/Base.hs @@ -0,0 +1,994 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Base +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Definitions of @Request@ and @Response@ types along with functions +-- for normalizing them. It is assumed to be an internal module; user +-- code should, if possible, import @Network.HTTP@ to access the functionality +-- that this module provides. +-- +-- Additionally, the module exports internal functions for working with URLs, +-- and for handling the processing of requests and responses coming back. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Base + ( + -- ** Constants + httpVersion -- :: String + + -- ** HTTP + , Request(..) + , Response(..) + , RequestMethod(..) + + , Request_String + , Response_String + , HTTPRequest + , HTTPResponse + + -- ** URL Encoding + , urlEncode + , urlDecode + , urlEncodeVars + + -- ** URI authority parsing + , URIAuthority(..) + , parseURIAuthority + + -- internal + , uriToAuthorityString -- :: URI -> String + , uriAuthToString -- :: URIAuth -> String + , uriAuthPort -- :: Maybe URI -> URIAuth -> Int + , reqURIAuth -- :: Request ty -> URIAuth + + , parseResponseHead -- :: [String] -> Result ResponseData + , parseRequestHead -- :: [String] -> Result RequestData + + , ResponseNextStep(..) + , matchResponse + , ResponseData + , ResponseCode + , RequestData + + , NormalizeRequestOptions(..) + , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty + , RequestNormalizer + + , normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty + + , splitRequestURI + + , getAuth + , normalizeRequestURI + , normalizeHostHeader + , findConnClose + + -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) + , linearTransfer + , hopefulTransfer + , chunkedTransfer + , 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 + ( URI(uriAuthority, uriPath, uriScheme) + , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort) + , parseURIReference + ) + +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, ord, chr ) +import Data.List ( partition, find ) +import Data.Maybe ( listToMaybe, fromMaybe ) +import Numeric ( readHex ) + +import Network.Stream +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, munch1 ) + +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) + +-- | Parse the authority part of a URL. +-- +-- > RFC 1732, section 3.1: +-- > +-- > //:@:/ +-- > Some or all of the parts ":@", ":", +-- > ":", and "/" may be excluded. +parseURIAuthority :: String -> Maybe URIAuthority +parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s)) + + +pURIAuthority :: ReadP URIAuthority +pURIAuthority = do + (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) + +before :: Monad m => m a -> m b -> m a +before a b = a >>= \x -> b >> return x + +orNothing :: ReadP a -> ReadP (Maybe a) +orNothing p = fmap Just p <++ return Nothing + +-- This function duplicates old Network.URI.authority behaviour. +uriToAuthorityString :: URI -> String +uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) + +uriAuthToString :: URIAuth -> String +uriAuthToString ua = + concat [ uriUserInfo ua + , uriRegName ua + , uriPort ua + ] + +uriAuthPort :: Maybe URI -> URIAuth -> Int +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) = + case map toLower $ uriScheme url of + "http:" -> default_http + "https:" -> default_https + -- todo: refine + _ -> default_http + + 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. +reqURIAuth :: Request ty -> URIAuth +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 + } + where + -- Note: just in case you're wondering..the convention is to include the ':' + -- in the port part.. + toHostPort h = break (==':') h + +----------------------------------------------------------------- +------------------ HTTP Messages -------------------------------- +----------------------------------------------------------------- + + +-- Protocol version +httpVersion :: String +httpVersion = "HTTP/1.1" + + +-- | The HTTP request method, to be used in the 'Request' object. +-- We are missing a few of the stranger methods, but these are +-- not really necessary until we add full TLS. +data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String + deriving(Eq) + +instance Show RequestMethod where + show x = + case x of + HEAD -> "HEAD" + PUT -> "PUT" + GET -> "GET" + POST -> "POST" + DELETE -> "DELETE" + OPTIONS -> "OPTIONS" + TRACE -> "TRACE" + CONNECT -> "CONNECT" + Custom c -> c + +rqMethodMap :: [(String, RequestMethod)] +rqMethodMap = [("HEAD", HEAD), + ("PUT", PUT), + ("GET", GET), + ("POST", POST), + ("DELETE", DELETE), + ("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 + +-- Hmm..I really want to use these for the record +-- type, but it will upset codebases wanting to +-- migrate (and live with using pre-HTTPbis versions.) +type HTTPRequest a = Request a +type HTTPResponse a = Response a + +-- | An HTTP Request. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output. +data Request a = + Request { rqURI :: URI -- ^ might need changing in future + -- 1) to support '*' uri in OPTIONS request + -- 2) transparent support for both relative + -- & absolute uris, although this should + -- already work (leave scheme & host parts empty). + , rqMethod :: RequestMethod + , rqHeaders :: [Header] + , rqBody :: a + } + +-- Notice that request body is not included, +-- this show function is used to serialise +-- a request for the transport link, we send +-- the body separately where possible. +instance Show (Request a) where + show req@(Request u m h _) = + 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 } + else u + +instance HasHeaders (Request a) where + getHeaders = rqHeaders + setHeaders rq hdrs = rq { rqHeaders=hdrs } + +-- | For easy pattern matching, HTTP response codes @xyz@ are +-- represented as @(x,y,z)@. +type ResponseCode = (Int,Int,Int) + +-- | @ResponseData@ contains the head of a response payload; +-- HTTP response code, accompanying text description + header +-- fields. +type ResponseData = (ResponseCode,String,[Header]) + +-- | @RequestData@ contains the head of a HTTP request; method, +-- its URL along with the auxillary/supporting header data. +type RequestData = (RequestMethod,URI,[Header]) + +-- | An HTTP Response. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output, additionally the output will +-- show an HTTP version of 1.1 instead of the actual version returned +-- by a server. +data Response a = + Response { rspCode :: ResponseCode + , rspReason :: String + , rspHeaders :: [Header] + , rspBody :: a + } + +-- 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 _) = + ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf + ++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf + where + ver = fromMaybe httpVersion (getResponseVersion rsp) + +instance HasHeaders (Response a) where + getHeaders = rspHeaders + setHeaders rsp hdrs = rsp { rspHeaders=hdrs } + + +------------------------------------------------------------------ +------------------ 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 = "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 + +-- | '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 +-- 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 = + Request { rqURI = uri + , rqBody = empty + , rqHeaders = [ Header HdrContentLength "0" + , Header HdrUserAgent defaultUserAgent + ] + , rqMethod = meth + } + + 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 = + case uriToAuthorityString uri{uriAuthority=updAuth} of + "" -> id + h -> ((Header HdrHost h):) + + uri_req + | forProxy = uri + | otherwise = snd (splitRequestURI uri) +-} + + +toBufOps :: BufferType a => Request a -> BufferOp a +toBufOps _ = bufferOps + +----------------------------------------------------------------- +------------------ Parsing -------------------------------------- +----------------------------------------------------------------- + +-- Parsing a request +parseRequestHead :: [String] -> Result RequestData +parseRequestHead [] = Left ErrorClosed +parseRequestHead (com:hdrs) = do + (version,rqm,uri) <- requestCommand com (words com) + hdrs' <- parseHeaders hdrs + return (rqm,uri,withVer version hdrs') + where + withVer [] hs = hs + withVer (h:_) hs = withVersion h hs + + requestCommand l _yes@(rqm:uri:version) = + case (parseURIReference uri, lookup rqm rqMethodMap) of + (Just u, Just r) -> return (version,r,u) + (Just u, Nothing) -> return (version,Custom rqm,u) + _ -> parse_err l + requestCommand l _ + | null l = failWith ErrorClosed + | otherwise = parse_err l + + parse_err l = responseParseError "parseRequestHead" + ("Request command line parse failure: " ++ l) + +-- Parsing a response +parseResponseHead :: [String] -> Result ResponseData +parseResponseHead [] = failWith ErrorClosed +parseResponseHead (sts:hdrs) = do + (version,code,reason) <- responseStatus sts (words sts) + hdrs' <- parseHeaders hdrs + return (code,reason, withVersion version hdrs') + where + responseStatus _l _yes@(version:code:reason) = + return (version,match code,concatMap (++" ") reason) + responseStatus l _no + | null l = failWith ErrorClosed -- an assumption + | otherwise = parse_err l + + parse_err l = + responseParseError + "parseResponseHead" + ("Response status line parse failure: " ++ l) + + match [a,b,c] = (digitToInt a, + digitToInt b, + digitToInt c) + match _ = (-1,-1,-1) -- will create appropriate behaviour + +-- To avoid changing the @RequestData@ and @ResponseData@ types +-- just for this (and the upstream backwards compat. woes that +-- will result in), encode version info as a custom header. +-- Used by 'parseResponseData' and 'parseRequestData'. +-- +-- Note: the Request and Response types do not currently represent +-- 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 + | v == httpVersion = hs -- don't bother adding it if the default. + | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs + +-- | @getRequestVersion req@ returns the HTTP protocol version of +-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed. +getRequestVersion :: Request a -> Maybe String +getRequestVersion r = getHttpVersion r + +-- | @setRequestVersion v req@ returns a new request, identical to +-- @req@, but with its HTTP version set to @v@. +setRequestVersion :: String -> Request a -> Request a +setRequestVersion s r = setHttpVersion r s + + +-- | @getResponseVersion rsp@ returns the HTTP protocol version of +-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be +-- assumed. +getResponseVersion :: Response a -> Maybe String +getResponseVersion r = getHttpVersion r + +-- | @setResponseVersion v rsp@ returns a new response, identical to +-- @rsp@, but with its HTTP version set to @v@. +setResponseVersion :: String -> Response a -> Response a +setResponseVersion s r = setHttpVersion r s + +-- internal functions for accessing HTTP-version info in +-- requests and responses. Not exported as it exposes ho +-- version info is represented internally. + +getHttpVersion :: HasHeaders a => a -> Maybe String +getHttpVersion r = + fmap toVersion $ + find isHttpVersion $ + getHeaders r + where + toVersion (Header _ x) = x + +setHttpVersion :: HasHeaders a => a -> String -> a +setHttpVersion r v = + setHeaders r $ + withVersion v $ + dropHttpVersion $ + getHeaders r + +dropHttpVersion :: [Header] -> [Header] +dropHttpVersion hs = filter (not.isHttpVersion) hs + +isHttpVersion :: Header -> Bool +isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True +isHttpVersion _ = False + + + +----------------------------------------------------------------- +------------------ HTTP Send / Recv ---------------------------------- +----------------------------------------------------------------- + +data ResponseNextStep + = Continue + | Retry + | Done + | ExpectEntity + | DieHorribly String + +matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep +matchResponse rqst rsp = + case rsp of + (1,0,0) -> Continue + (1,0,1) -> Done -- upgrade to TLS + (1,_,_) -> Continue -- default + (2,0,4) -> Done + (2,0,5) -> Done + (2,_,_) -> ans + (3,0,4) -> Done + (3,0,5) -> Done + (3,_,_) -> ans + (4,1,7) -> Retry -- Expectation failed + (4,_,_) -> ans + (5,_,_) -> ans + (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised") + where + ans | rqst == HEAD = Done + | otherwise = ExpectEntity + + + +----------------------------------------------------------------- +------------------ A little friendly funtionality --------------- +----------------------------------------------------------------- + + +{- + I had a quick look around but couldn't find any RFC about + the encoding of data on the query string. I did find an + IETF memo, however, so this is how I justify the urlEncode + and urlDecode methods. + + Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) + + Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. + Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" + URI delims: "<" | ">" | "#" | "%" | <"> + Unallowed ASCII: + + Also unallowed: any non-us-ascii character + + 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 = 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) + | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = 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 = to (o_0 + x) : xs + | otherwise = to (o_A + (x-10)) : xs + where + to = toEnum . fromIntegral + fro = fromIntegral . fromEnum + + 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. +-- I have no source for this information except experience, +-- this sort of encoding worked fine in CGI programming. +urlEncodeVars :: [(String,String)] -> String +urlEncodeVars ((n,v):t) = + let (same,diff) = partition ((==n) . fst) t + in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) + ++ urlEncodeRest diff + where urlEncodeRest [] = [] + urlEncodeRest diff = '&' : urlEncodeVars diff +urlEncodeVars [] = [] + +-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ +-- header. +getAuth :: Monad m => Request ty -> m URIAuthority +getAuth r = + -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) + case parseURIAuthority auth of + Just x -> return x + Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" + 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 = + (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 +data NormalizeRequestOptions ty + = NormalizeRequestOptions + { normDoClose :: Bool + , normForProxy :: Bool + , normUserAgent :: Maybe String + , normCustoms :: [RequestNormalizer ty] + } + +-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites +-- a request into some normalized form. +type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty + +defaultNormalizeRequestOptions :: NormalizeRequestOptions ty +defaultNormalizeRequestOptions = NormalizeRequestOptions + { normDoClose = False + , normForProxy = False + , normUserAgent = Just defaultUserAgent + , normCustoms = [] + } + +-- | @normalizeRequest opts req@ is the entry point to use to normalize your +-- request prior to transmission (or other use.) Normalization is controlled +-- via the @NormalizeRequestOptions@ record. +normalizeRequest :: NormalizeRequestOptions ty + -> Request ty + -> Request ty +normalizeRequest opts req = foldr (\ f -> f opts) req normalizers + where + --normalizers :: [RequestNormalizer ty] + normalizers = + ( normalizeHostURI + : normalizeBasicAuth + : normalizeConnectionClose + : normalizeUserAgent + : normCustoms opts + ) + +-- | @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 = + case normUserAgent opts of + Nothing -> req + Just ua -> + case findHeader HdrUserAgent req of + Just u | u /= defaultUserAgent -> req + _ -> replaceHeader HdrUserAgent ua req + +-- | @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 + | 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 = + case splitRequestURI uri of + ("",_uri_abs) + | 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 + + (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 + | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass + where + uri0 = rqURI req + -- stub out the user:pass + uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} + + forProxy = normForProxy opts + +{- Comments re: above rewriting: + RFC 2616, section 5.1.2: + "The most common form of Request-URI is that used to identify a + 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." + 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 + is a Host header. +-} + +splitRequestURI :: URI -> ({-authority-}String, URI) +splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing}) + +-- 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 = + insertHeaderIfMissing HdrHost + (uriToAuthorityString $ rqURI 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) + +-- | Used when we know exactly how many bytes to expect. +linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) +linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) + +-- | Used when nothing about data is known, +-- Unfortunately waiting for a socket closure +-- causes bad behaviour. Here we just +-- take data once and give up the rest. +hopefulTransfer :: BufferOp a + -> IO (Result a) + -> [a] + -> IO (Result ([Header],a)) +hopefulTransfer bufOps readL strs + = readL >>= + either (\v -> return $ Left v) + (\more -> if (buf_isEmpty bufOps more) + 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) + -> (Int -> IO (Result a)) + -> IO (Result ([Header], a)) +chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0 + +chunkedTransferC :: BufferOp a + -> IO (Result a) + -> (Int -> IO (Result 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 -> + -- 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 + return (ftrs',buf_concat bufOps (reverse acc))) + + (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) + where + size + | buf_isEmpty bufOps line = 0 + | otherwise = + case readHex (buf_toStr bufOps line) of + (hx,_):_ -> hx + _ -> 0 + +-- | Maybe in the future we will have a sensible thing +-- to do here, at that time we might want to change +-- the name. +uglyDeathTransfer :: String -> IO (Result ([Header],a)) +uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding") + +-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) +readTillEmpty1 :: BufferOp a + -> IO (Result a) + -> IO (Result [a]) +readTillEmpty1 bufOps readL = + readL >>= + either (return . Left) + (\ s -> + if buf_isLineTerm bufOps s + then readTillEmpty1 bufOps readL + else readTillEmpty2 bufOps readL [s]) + +-- | Read lines until an empty line (CRLF), +-- also accepts a connection close as end of +-- input, which is not an HTTP\/1.1 compliant +-- thing to do - so probably indicates an +-- error condition. +readTillEmpty2 :: BufferOp 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 + then return (Right $ reverse (s:list)) + else readTillEmpty2 bufOps readL (s:list)) + +-- +-- Misc +-- + +-- | @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 = Exception.catch a h + +catchIO_ :: IO a -> IO a -> IO a +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 new file mode 100644 index 0000000..bd1c28b --- /dev/null +++ b/Network/HTTP/Base64.hs @@ -0,0 +1,282 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Binary.Base64 +-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See +-- and . +-- +----------------------------------------------------------------------------- + +module Network.HTTP.Base64 + ( encode + , decode + , chop72 + , Octet + ) where + +{------------------------------------------------------------------------ +This is what RFC2045 had to say: + +6.8. Base64 Content-Transfer-Encoding + + The Base64 Content-Transfer-Encoding is designed to represent + arbitrary sequences of octets in a form that need not be humanly + readable. The encoding and decoding algorithms are simple, but the + encoded data are consistently only about 33 percent larger than the + unencoded data. This encoding is virtually identical to the one used + in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421. + + A 65-character subset of US-ASCII is used, enabling 6 bits to be + represented per printable character. (The extra 65th character, "=", + is used to signify a special processing function.) + + NOTE: This subset has the important property that it is represented + identically in all versions of ISO 646, including US-ASCII, and all + characters in the subset are also represented identically in all + versions of EBCDIC. Other popular encodings, such as the encoding + used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and + the base85 encoding specified as part of Level 2 PostScript, do not + share these properties, and thus do not fulfill the portability + requirements a binary transport encoding for mail must meet. + + The encoding process represents 24-bit groups of input bits as output + strings of 4 encoded characters. Proceeding from left to right, a + 24-bit input group is formed by concatenating 3 8bit input groups. + These 24 bits are then treated as 4 concatenated 6-bit groups, each + of which is translated into a single digit in the base64 alphabet. + When encoding a bit stream via the base64 encoding, the bit stream + must be presumed to be ordered with the most-significant-bit first. + That is, the first bit in the stream will be the high-order bit in + the first 8bit byte, and the eighth bit will be the low-order bit in + the first 8bit byte, and so on. + + Each 6-bit group is used as an index into an array of 64 printable + characters. The character referenced by the index is placed in the + output string. These characters, identified in Table 1, below, are + selected so as to be universally representable, and the set excludes + characters with particular significance to SMTP (e.g., ".", CR, LF) + and to the multipart boundary delimiters defined in RFC 2046 (e.g., + "-"). + + + + Table 1: The Base64 Alphabet + + Value Encoding Value Encoding Value Encoding Value Encoding + 0 A 17 R 34 i 51 z + 1 B 18 S 35 j 52 0 + 2 C 19 T 36 k 53 1 + 3 D 20 U 37 l 54 2 + 4 E 21 V 38 m 55 3 + 5 F 22 W 39 n 56 4 + 6 G 23 X 40 o 57 5 + 7 H 24 Y 41 p 58 6 + 8 I 25 Z 42 q 59 7 + 9 J 26 a 43 r 60 8 + 10 K 27 b 44 s 61 9 + 11 L 28 c 45 t 62 + + 12 M 29 d 46 u 63 / + 13 N 30 e 47 v + 14 O 31 f 48 w (pad) = + 15 P 32 g 49 x + 16 Q 33 h 50 y + + The encoded output stream must be represented in lines of no more + than 76 characters each. All line breaks or other characters not + found in Table 1 must be ignored by decoding software. In base64 + data, characters other than those in Table 1, line breaks, and other + white space probably indicate a transmission error, about which a + warning message or even a message rejection might be appropriate + under some circumstances. + + Special processing is performed if fewer than 24 bits are available + at the end of the data being encoded. A full encoding quantum is + always completed at the end of a body. When fewer than 24 input bits + are available in an input group, zero bits are added (on the right) + to form an integral number of 6-bit groups. Padding at the end of + the data is performed using the "=" character. Since all base64 + input is an integral number of octets, only the following cases can + arise: (1) the final quantum of encoding input is an integral + multiple of 24 bits; here, the final unit of encoded output will be + an integral multiple of 4 characters with no "=" padding, (2) the + final quantum of encoding input is exactly 8 bits; here, the final + unit of encoded output will be two characters followed by two "=" + padding characters, or (3) the final quantum of encoding input is + exactly 16 bits; here, the final unit of encoded output will be three + characters followed by one "=" padding character. + + Because it is used only for padding at the end of the data, the + occurrence of any "=" characters may be taken as evidence that the + end of the data has been reached (without truncation in transit). No + such assurance is possible, however, when the number of octets + transmitted was a multiple of three and no "=" characters are + present. + + Any characters outside of the base64 alphabet are to be ignored in + base64-encoded data. + + Care must be taken to use the proper octets for line breaks if base64 + encoding is applied directly to text material that has not been + converted to canonical form. In particular, text line breaks must be + converted into CRLF sequences prior to base64 encoding. The + important thing to note is that this may be done directly by the + encoder rather than in a prior canonicalization step in some + implementations. + + NOTE: There is no need to worry about quoting potential boundary + delimiters within base64-encoded bodies within multipart entities + because no hyphen characters are used in the base64 encoding. + +----------------------------------------------------------------------------} + +{- + +The following properties should hold: + + decode . encode = id + decode . chop72 . encode = id + +I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, +the second variation corresponds better with the RFC above, but outside of +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. +-} + + +import Data.Array (Array, array, (!)) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.Char (chr, ord) +import Data.Word (Word8) + +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') + , (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') + , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') + , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') + , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') + , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') + , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') + , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] + + +-- 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 +-- 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) = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) + in (chr (n `shiftR` 16 .&. 0xff)) + : (chr (n `shiftR` 8 .&. 0xff)) + : (chr (n .&. 0xff)) : int4_char3 t + +int4_char3 [a,b,c] = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) + in [ (chr (n `shiftR` 16 .&. 0xff)) + , (chr (n `shiftR` 8 .&. 0xff)) ] + +int4_char3 [a,b] = + let n = (a `shiftL` 18 .|. b `shiftL` 12) + in [ (chr (n `shiftR` 16 .&. 0xff)) ] + +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) + = 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 + +char3_int4 [a,b] + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) + 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)] + +char3_int4 [] = [] + + +-- Retrieve base64 char, given an array index integer in the range [0..63] +enc1 :: Int -> Char +enc1 ch = encodeArray!ch + + +-- | Cut up a string into 72 char lines, each line terminated by CRLF. + +chop72 :: String -> String +chop72 str = let (bgn,end) = splitAt 70 str + in if null end then bgn else "\r\n" ++ chop72 end + + +-- Pads a base64 code to a multiple of 4 characters, using the special +-- '=' character. +quadruplets :: [Char] -> [Char] +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 + + +enc :: [Int] -> [Char] +enc = quadruplets . map enc1 + + +dcd :: String -> [Int] +dcd [] = [] +dcd (h:t) + | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t + | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t + | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t + | h == '+' = 62 : dcd t + | h == '/' = 63 : dcd t + | h == '=' = [] -- terminate data stream + | otherwise = dcd t + + +-- Principal encoding and decoding functions. + +encode :: [Octet] -> String +encode = enc . char3_int4 . (map (chr .fromIntegral)) + +{- +prop_base64 os = + os == (f . g . h) os + where types = (os :: [Word8]) + f = map (fromIntegral. ord) + g = decode . encode + h = map (chr . fromIntegral) +-} + +decode :: String -> [Octet] +decode = (map (fromIntegral . ord)) . int4_char3 . dcd diff --git a/Network/HTTP/Cookie.hs b/Network/HTTP/Cookie.hs new file mode 100644 index 0000000..1b5175d --- /dev/null +++ b/Network/HTTP/Cookie.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Cookie +-- Copyright : See LICENSE file +-- License : BSD +-- +-- 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. + , cookiesToHeader -- :: [Cookie] -> Header + , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) + ) where + +import Network.HTTP.Headers + +import Data.Char +import Data.List +import Data.Maybe + +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, option, try + , (<|>), sepBy1 + ) + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- | @Cookie@ is the Haskell representation of HTTP cookie values. +-- See its relevant specs for authoritative details. +data Cookie + = MkCookie + { ckDomain :: String + , ckName :: String + , ckValue :: String + , ckPath :: Maybe String + , ckComment :: Maybe String + , ckVersion :: Maybe String + } + deriving(Show,Read) + +instance Eq Cookie where + a == b = ckDomain a == ckDomain b + && ckName a == ckName b + && ckPath a == ckPath b + +-- | @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. +cookieMatch :: (String, String) -> Cookie -> Bool +cookieMatch (dom,path) ck = + ckDomain ck `isSuffixOf` dom && + case ckPath ck of + Nothing -> True + Just p -> p `isPrefixOf` path + + +-- | @processCookieHeaders dom hdrs@ +processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) +processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs + +-- | @headerToCookies dom hdr acc@ +headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = + case parse cookies "" val of + Left{} -> (val:accErr, accCookie) + Right x -> (accErr, x ++ accCookie) + where + cookies :: Parser [Cookie] + cookies = sepBy1 cookie (char ',') + + cookie :: Parser Cookie + cookie = + 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 "" (char '=' >> spaces_l >> cvalue) + return (map toLower s1,s2) + ) + + mkCookie :: String -> String -> [(String,String)] -> Cookie + mkCookie nm cval more = + MkCookie { ckName = nm + , ckValue = cval + , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) + , ckPath = lookup "path" more + , ckVersion = lookup "version" more + , ckComment = lookup "comment" more + } +headerToCookies _ _ acc = acc + + + + +word, quotedstring :: Parser String +quotedstring = + 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 new file mode 100644 index 0000000..29ef82a --- /dev/null +++ b/Network/HTTP/HandleStream.hs @@ -0,0 +1,252 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.HandleStream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- A 'HandleStream'-based version of "Network.HTTP" interface. +-- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- 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 + ( 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 + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.BufferType +import Network.Stream ( fmapE, Result ) +import Network.StreamDebugger ( debugByteStream ) +import Network.TCP (HStream(..), HandleStream ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim, readsOne ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Exception (onException) +import Control.Monad (when) + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + +-- | @simpleHTTP@ transmits a resource across a non-persistent connection. +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 + +-- | @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 + auth <- getAuth r + failHTTPS (rqURI r) + c0 <- openStream (host auth) (fromMaybe 80 (port auth)) + c <- debugByteStream httpLogFile c0 + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +simpleHTTP_ s r = sendHTTP s r + +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- closed upon receiving the response. +sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +sendHTTP conn rq = sendHTTP_notify conn rq (return ()) + +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + onException (sendMain conn rq onSendComplete) + (close conn) + where + providedClose = findConnClose (rqHeaders rq) + +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- 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)) +sendMain conn rqst onSendComplete = do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + -- TODO review throwing away of result + _ <- writeBlock conn (buf_fromStr bufferOps $ show rqst) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO review throwing away of result + _ <- writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst + + -- Hmmm, this could go bad if we keep getting "100 Continue" + -- responses... Except this should never happen according + -- to the RFC. + +switchResponse :: HStream ty + => HandleStream ty + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request ty + -> IO (Result (Response ty)) +switchResponse _ _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- 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 = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> do {- Time to send the body -} + writeBlock conn (rqBody rqst) >>= either (return . Left) + (\ _ -> do + rsp <- getResponseHead conn + switchResponse conn allow_retry True rsp rqst) + | otherwise -> do {- keep waiting -} + rsp <- getResponseHead conn + switchResponse conn allow_retry bdy_sent rsp rqst + + Retry -> do {- Request with "Expect" header failed. + Trouble is the request contains Expects + other than "100-Continue" -} + -- 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) + return (Right $ Response cd rn hdrs (buf_empty bufferOps)) + + DieHorribly str -> do + close conn + return (responseParseError "Invalid response:" str) + 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")) + tc + case r of + Left{} -> do + close conn + return r + Right (Response _ _ hs _) -> do + when (findConnClose hs) + (closeOnEnd conn True) + 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 = + fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) + (readTillEmpty1 bufferOps (readLine conn)) + +-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ +receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy)) +receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + 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")) + tc + where + -- FIXME : Also handle 100-continue. + tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + bo = bufferOps + +-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over +-- 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 + -- TODO: review throwing away of result + _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO: review throwing away of result + _ <- writeBlock conn (rspBody rsp) + return () + +------------------------------------------------------------------------------ + +headerName :: String -> String +headerName x = map toLower (trim x) + +ifChunked :: a -> a -> String -> a +ifChunked a b s = + case headerName s of + "chunked" -> a + _ -> b + diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs new file mode 100644 index 0000000..a3bcb47 --- /dev/null +++ b/Network/HTTP/Headers.hs @@ -0,0 +1,306 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Headers +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- This module provides the data types for representing HTTP headers, and +-- operations for looking up header values and working with sequences of +-- 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 + + , Header(..) + , mkHeader -- :: HeaderName -> String -> Header + , hdrName -- :: Header -> HeaderName + , hdrValue -- :: Header -> String + + , HeaderName(..) + + , insertHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaders -- :: HasHeaders a => [Header] -> a -> a + , retrieveHeaders -- :: HasHeaders a => HeaderName -> a -> [Header] + , replaceHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String + , lookupHeader -- :: HeaderName -> [Header] -> Maybe String + + , parseHeader -- :: parseHeader :: String -> Result Header + , parseHeaders -- :: [String] -> Result [Header] + + , headerMap -- :: [(String, HeaderName)] + + , HeaderSetter + ) where + +import Data.Char (toLower) +import Network.Stream (Result, failParse) +import Network.HTTP.Utils ( trim, split, crlf ) + +-- | The @Header@ data type pairs header names & values. +data Header = Header HeaderName String + +hdrName :: Header -> HeaderName +hdrName (Header h _) = h + +hdrValue :: Header -> String +hdrValue (Header _ v) = v + +-- | Header constructor as a function, hiding above rep. +mkHeader :: HeaderName -> String -> Header +mkHeader = Header + +instance Show Header where + show (Header key value) = shows key (':':' ':value ++ crlf) + +-- | HTTP @HeaderName@ type, a Haskell data constructor for each +-- specification-defined header, prefixed with @Hdr@ and CamelCased, +-- (i.e., eliding the @-@ in the process.) Should you require using +-- a custom header, there's the @HdrCustom@ constructor which takes +-- a @String@ argument. +-- +-- 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 + -- Generic Headers -- + = HdrCacheControl + | HdrConnection + | HdrDate + | HdrPragma + | HdrTransferEncoding + | HdrUpgrade + | HdrVia + -- Request Headers -- + | HdrAccept + | HdrAcceptCharset + | HdrAcceptEncoding + | HdrAcceptLanguage + | HdrAuthorization + | HdrCookie + | HdrExpect + | HdrFrom + | HdrHost + | HdrIfModifiedSince + | HdrIfMatch + | HdrIfNoneMatch + | HdrIfRange + | HdrIfUnmodifiedSince + | HdrMaxForwards + | HdrProxyAuthorization + | HdrRange + | HdrReferer + | HdrUserAgent + -- Response Headers + | HdrAge + | HdrLocation + | HdrProxyAuthenticate + | HdrPublic + | HdrRetryAfter + | HdrServer + | HdrSetCookie + | HdrTE + | HdrTrailer + | HdrVary + | HdrWarning + | HdrWWWAuthenticate + -- Entity Headers + | HdrAllow + | HdrContentBase + | HdrContentEncoding + | HdrContentLanguage + | HdrContentLength + | HdrContentLocation + | HdrContentMD5 + | HdrContentRange + | HdrContentType + | HdrETag + | HdrExpires + | HdrLastModified + -- | MIME entity headers (for sub-parts) + | 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 +-- and values. +headerMap :: [ (String,HeaderName) ] +headerMap = + [ p "Cache-Control" HdrCacheControl + , p "Connection" HdrConnection + , p "Date" HdrDate + , p "Pragma" HdrPragma + , p "Transfer-Encoding" HdrTransferEncoding + , p "Upgrade" HdrUpgrade + , p "Via" HdrVia + , p "Accept" HdrAccept + , p "Accept-Charset" HdrAcceptCharset + , p "Accept-Encoding" HdrAcceptEncoding + , p "Accept-Language" HdrAcceptLanguage + , p "Authorization" HdrAuthorization + , p "Cookie" HdrCookie + , p "Expect" HdrExpect + , p "From" HdrFrom + , p "Host" HdrHost + , p "If-Modified-Since" HdrIfModifiedSince + , p "If-Match" HdrIfMatch + , p "If-None-Match" HdrIfNoneMatch + , p "If-Range" HdrIfRange + , p "If-Unmodified-Since" HdrIfUnmodifiedSince + , p "Max-Forwards" HdrMaxForwards + , p "Proxy-Authorization" HdrProxyAuthorization + , p "Range" HdrRange + , p "Referer" HdrReferer + , p "User-Agent" HdrUserAgent + , p "Age" HdrAge + , p "Location" HdrLocation + , p "Proxy-Authenticate" HdrProxyAuthenticate + , p "Public" HdrPublic + , p "Retry-After" HdrRetryAfter + , p "Server" HdrServer + , p "Set-Cookie" HdrSetCookie + , p "TE" HdrTE + , p "Trailer" HdrTrailer + , p "Vary" HdrVary + , p "Warning" HdrWarning + , p "WWW-Authenticate" HdrWWWAuthenticate + , p "Allow" HdrAllow + , p "Content-Base" HdrContentBase + , p "Content-Encoding" HdrContentEncoding + , p "Content-Language" HdrContentLanguage + , p "Content-Length" HdrContentLength + , p "Content-Location" HdrContentLocation + , p "Content-MD5" HdrContentMD5 + , p "Content-Range" HdrContentRange + , p "Content-Type" HdrContentType + , p "ETag" HdrETag + , p "Expires" HdrExpires + , p "Last-Modified" HdrLastModified + , p "Content-Transfer-Encoding" HdrContentTransferEncoding + ] + where + p a b = (a,b) + +instance Show HeaderName where + show (HdrCustom s) = s + show x = case filter ((==x).snd) headerMap of + [] -> error "headerMap incomplete" + (h:_) -> fst h + +-- | @HasHeaders@ is a type class for types containing HTTP headers, allowing +-- you to write overloaded header manipulation functions +-- for both 'Request' and 'Response' data types, for instance. +class HasHeaders x where + getHeaders :: x -> [Header] + setHeaders :: x -> [Header] -> x + +-- Header manipulation functions + +type HeaderSetter a = HeaderName -> String -> a -> a + +-- | @insertHeader hdr val x@ inserts a header with the given header name +-- and value. Does not check for existing headers with same name, allowing +-- duplicates to be introduce (use 'replaceHeader' if you want to avoid this.) +insertHeader :: HasHeaders a => HeaderSetter a +insertHeader name value x = setHeaders x newHeaders + where + newHeaders = (Header name value) : getHeaders x + +-- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous +-- header with name @hdr@ exists in @x@. +insertHeaderIfMissing :: HasHeaders a => HeaderSetter a +insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) + where + newHeaders list@(h@(Header n _): rest) + | n == name = list + | otherwise = h : newHeaders rest + newHeaders [] = [Header name value] + +-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the +-- 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 +insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) + +-- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@. +retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] +retrieveHeaders name x = filter matchname (getHeaders x) + where + matchname (Header n _) = n == name + +-- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first +-- header that matches, if any. +findHeader :: HasHeaders a => HeaderName -> a -> Maybe String +findHeader n x = lookupHeader n (getHeaders x) + +-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the +-- list @hdrs@. +lookupHeader :: HeaderName -> [Header] -> Maybe String +lookupHeader _ [] = Nothing +lookupHeader v (Header n s:t) + | v == n = Just s + | otherwise = lookupHeader v t + +-- | @parseHeader headerNameAndValueString@ tries to unscramble a +-- @header: value@ pairing and returning it as a 'Header'. +parseHeader :: String -> Result Header +parseHeader str = + case split ':' str of + Nothing -> failParse ("Unable to parse header: " ++ str) + Just (k,v) -> return $ Header (fn k) (trim $ drop 1 v) + where + fn k = case map snd $ filter (match k . fst) headerMap of + [] -> (HdrCustom k) + (h:_) -> h + + 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 "" + 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 + | otherwise = old : joinExtended h t + + isLineExtension (x:_) = x == ' ' || x == '\t' + isLineExtension _ = False + + clean [] = [] + clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t + | otherwise = h : clean t + + -- tolerant of errors? should parse + -- errors here be reported or ignored? + -- currently ignored. + catRslts :: [a] -> [Result a] -> Result [a] + catRslts list (h:t) = + case h of + Left _ -> catRslts list t + Right v -> catRslts (v:list) t + catRslts list [] = Right $ reverse list diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs new file mode 100644 index 0000000..60d1c2b --- /dev/null +++ b/Network/HTTP/MD5Aux.hs @@ -0,0 +1,343 @@ +module Network.HTTP.MD5Aux + (md5, md5s, md5i, + MD5(..), ABCD(..), + Zord64, Str(..), BoolList(..), WordList(..)) where + +import Data.Char (ord, chr) +import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) +import Data.Word (Word32, Word64) + +rotL :: Word32 -> Int -> Word32 +rotL x = rotateL x + +type Zord64 = Word64 + +-- ===================== TYPES AND CLASS DEFINTIONS ======================== + + +type XYZ = (Word32, Word32, Word32) +type Rotation = Int +newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) +newtype Str = Str String +newtype BoolList = BoolList [Bool] +newtype WordList = WordList ([Word32], Word64) + +-- Anything we want to work out the MD5 of must be an instance of class MD5 + +class MD5 a where + get_next :: a -> ([Word32], Int, a) -- get the next blocks worth + -- \ \ \------ the rest of the input + -- \ \--------- the number of bits returned + -- \--------------- the bits returned in 32bit words + len_pad :: Word64 -> a -> a -- append the padding and length + finished :: a -> Bool -- Have we run out of input yet? + + +-- Mainly exists because it's fairly easy to do MD5s on input where the +-- length is not a multiple of 8 + +instance MD5 BoolList where + get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) + where (ys, zs) = splitAt 512 s + len_pad l (BoolList bs) + = BoolList (bs ++ [True] + ++ replicate (fromIntegral $ (447 - l) .&. 511) False + ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] + ) + where mangle [] = [] + mangle xs = reverse ys ++ mangle zs + where (ys, zs) = splitAt 8 xs + finished (BoolList s) = s == [] + + +-- The string instance is fairly straightforward + +instance MD5 Str where + get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) + where (ys, zs) = splitAt 64 s + len_pad c64 (Str s) = Str (s ++ padding ++ l) + where padding = '\128':replicate (fromIntegral zeros) '\000' + zeros = shiftR ((440 - c64) .&. 511) 3 + l = length_to_chars 8 c64 + finished (Str s) = s == "" + + +-- YA instance that is believed will be useful + +instance MD5 WordList where + get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) + where (xs, ys) = splitAt 16 ws + taken = if l > 511 then 512 else l .&. 511 + len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) + where beginning = if length ws > 0 then start ++ lastone' else [] + start = init ws + lastone = last ws + offset = c64 .&. 31 + lastone' = [if offset > 0 then lastone + theone else lastone] + theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) + (fromIntegral $ offset .&. (31 - 7)) + nextish = if offset == 0 then [128] else [] + c64' = c64 + (32 - offset) + num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) + blanks = replicate num_blanks 0 + lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) + topsize = fromIntegral $ shiftR c64 32 + size = [lowsize, topsize] + newlen = l .&. (complement 511) + + if c64 .&. 511 >= 448 then 1024 else 512 + finished (WordList (_, z)) = z == 0 + + +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" + abs = error "abs{ABCD}: no instance method defined" +-- ===================== EXPORTED FUNCTIONS ======================== + + +-- The simplest function, gives you the MD5 of a string as 4-tuple of +-- 32bit words. + +md5 :: (MD5 a) => a -> ABCD +md5 m = md5_main False 0 magic_numbers m + + +-- Returns a hex number ala the md5sum program + +md5s :: (MD5 a) => a -> String +md5s = abcd_to_string . md5 + + +-- Returns an integer equivalent to the above hex number + +md5i :: (MD5 a) => a -> Integer +md5i = abcd_to_integer . md5 + + +-- ===================== THE CORE ALGORITHM ======================== + + +-- Decides what to do. The first argument indicates if padding has been +-- added. The second is the length mod 2^64 so far. Then we have the +-- starting state, the rest of the string and the final state. + +md5_main :: (MD5 a) => + Bool -- Have we added padding yet? + -> Word64 -- The length so far mod 2^64 + -> ABCD -- The initial state + -> a -- The non-processed portion of the message + -> ABCD -- The resulting state +md5_main padded ilen abcd m + = if finished m && padded + then abcd + else md5_main padded' (ilen + 512) (abcd + abcd') m'' + where (m16, l, m') = get_next m + len' = ilen + fromIntegral l + ((m16', _, m''), padded') = if not padded && l < 512 + then (get_next $ len_pad len' m, True) + else ((m16, l, m'), padded) + abcd' = md5_do_block abcd m16' + + +-- md5_do_block processes a 512 bit block by calling md5_round 4 times to +-- apply each round with the correct constants and permutations of the +-- block + +md5_do_block :: ABCD -- Initial state + -> [Word32] -- The block to be processed - 16 32bit words + -> ABCD -- Resulting state +md5_do_block abcd0 w = abcd4 + where (r1, r2, r3, r4) = rounds + {- + map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] + -- [(5 * x + 1) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] + -- [(3 * x + 5) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] + -- [(7 * x) `mod` 16 | x <- [0..15]] + -} + perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] + perm5 _ = error "broke at perm5" + perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] + perm3 _ = error "broke at perm3" + perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] + perm7 _ = error "broke at perm7" + abcd1 = md5_round md5_f abcd0 w r1 + abcd2 = md5_round md5_g abcd1 (perm5 w) r2 + abcd3 = md5_round md5_h abcd2 (perm3 w) r3 + abcd4 = md5_round md5_i abcd3 (perm7 w) r4 + + +-- md5_round does one of the rounds. It takes an auxiliary function and foldls +-- (md5_inner_function f) to repeatedly apply it to the initial state with the +-- correct constants + +md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I + -- for those of you with a copy of + -- the prayer book^W^WRFC) + -> ABCD -- Initial state + -> [Word32] -- The 16 32bit words of input + -> [(Rotation, Word32)] -- The list of 16 rotations and + -- additive constants + -> ABCD -- Resulting state +md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' + where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns + + +-- Apply one of the functions md5_[fghi] and put the new ABCD together + +md5_inner_function :: (XYZ -> Word32) -- Auxiliary function + -> ABCD -- Initial state + -> (Rotation, Word32) -- The rotation and additive + -- constant (X[i] + T[j]) + -> ABCD -- Resulting state +md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) + where mid_a = a + f(b,c,d) + ki + rot_a = rotL mid_a s + a' = b + rot_a + + +-- The 4 auxiliary functions + +md5_f :: XYZ -> Word32 +md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) +{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} + +md5_g :: XYZ -> Word32 +md5_g (x, y, z) = md5_f (z, x, y) +{- was: (x .&. z) .|. (y .&. (complement z)) -} + +md5_h :: XYZ -> Word32 +md5_h (x, y, z) = x `xor` y `xor` z + +md5_i :: XYZ -> Word32 +md5_i (x, y, z) = y `xor` (x .|. (complement z)) + + +-- The magic numbers from the RFC. + +magic_numbers :: ABCD +magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) + + +-- The 4 lists of (rotation, additive constant) tuples, one for each round + +rounds :: ([(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)]) +rounds = (r1, r2, r3, r4) + where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), + (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), + (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), + (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), + (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), + (s14, 0x49b40821)] + r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), + (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), + (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), + (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), + (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), + (s24, 0x8d2a4c8a)] + r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), + (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), + (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), + (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), + (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), + (s34, 0xc4ac5665)] + r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), + (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), + (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), + (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), + (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), + (s44, 0xeb86d391)] + s11 = 7 + s12 = 12 + s13 = 17 + s14 = 22 + s21 = 5 + s22 = 9 + s23 = 14 + s24 = 20 + s31 = 4 + s32 = 11 + s33 = 16 + s34 = 23 + s41 = 6 + s42 = 10 + s43 = 15 + s44 = 21 + + +-- ===================== CONVERSION FUNCTIONS ======================== + + +-- Turn the 4 32 bit words into a string representing the hex number they +-- represent. + +abcd_to_string :: ABCD -> String +abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] + + +-- Split the 32 bit word up, swap the chunks over and convert the numbers +-- to their hex equivalents. + +display_32bits_as_hex :: Word32 -> String +display_32bits_as_hex w = swap_pairs cs + where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] + getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + +-- Convert to an integer, performing endianness magic as we go + +abcd_to_integer :: ABCD -> Integer +abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + + rev_num b * 2^(64 :: Int) + + rev_num c * 2^(32 :: Int) + + rev_num d + +rev_num :: Word32 -> Integer +rev_num i = toInteger j `mod` (2^(32 :: Int)) + -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ + where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) + 0 [0,8,16,24] + +-- Used to convert a 64 byte string to 16 32bit words + +string_to_word32s :: String -> [Word32] +string_to_word32s "" = [] +string_to_word32s ss = this:string_to_word32s ss' + where (s, ss') = splitAt 4 ss + this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s + + +-- Used to convert a list of 512 bools to 16 32bit words + +bools_to_word32s :: [Bool] -> [Word32] +bools_to_word32s [] = [] +bools_to_word32s bs = this:bools_to_word32s rest + where (bs1, bs1') = splitAt 8 bs + (bs2, bs2') = splitAt 8 bs1' + (bs3, bs3') = splitAt 8 bs2' + (bs4, rest) = splitAt 8 bs3' + this = boolss_to_word32 [bs1, bs2, bs3, bs4] + bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 + boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 + + +-- Convert the size into a list of characters used by the len_pad function +-- for strings + +length_to_chars :: Int -> Word64 -> String +length_to_chars 0 _ = [] +length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) + where this = chr $ fromIntegral $ n .&. 255 + diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs new file mode 100644 index 0000000..a46c0d9 --- /dev/null +++ b/Network/HTTP/Proxy.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Proxy +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Handling proxy server settings and their resolution. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Proxy + ( Proxy(..) + , noProxy -- :: Proxy + , fetchProxy -- :: Bool -> IO Proxy + , parseProxy -- :: String -> Maybe Proxy + ) where + +{- +#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, unEscapeString ) +import System.IO ( hPutStrLn, stderr ) +import System.Environment + +{- +#if !defined(WIN32) && defined(mingw32_HOST_OS) +#define WIN32 1 +#endif +-} + +#if defined(WIN32) +import System.Win32.Types ( DWORD, HKEY ) +import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx ) +import Control.Exception ( bracket ) +import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#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 + = NoProxy -- ^ Don't use a proxy. + | Proxy String + (Maybe Authority) -- ^ Use the proxy given. Should be of the + -- form "http:\/\/host:port", "host", "host:port", or "http:\/\/host". + -- Additionally, an optional 'Authority' for authentication with the proxy. + + +noProxy :: Proxy +noProxy = NoProxy + +-- | @envProxyString@ locates proxy server settings by looking +-- up env variable @HTTP_PROXY@ (or its lower-case equivalent.) +-- If no mapping found, returns @Nothing@. +envProxyString :: IO (Maybe String) +envProxyString = do + env <- getEnvironment + return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) + +-- | @proxyString@ tries to locate the user's proxy server setting. +-- Consults environment variable, and in case of Windows, by querying +-- the Registry (cf. @registryProxyString@.) +proxyString :: IO (Maybe String) +proxyString = liftM2 mplus envProxyString windowsProxyString + +windowsProxyString :: IO (Maybe String) +#if !defined(WIN32) +windowsProxyString = return Nothing +#else +windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString + +registryProxyLoc :: (HKEY,String) +registryProxyLoc = (hive, path) + where + -- 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 + -- end up in the following place: + hive = hKEY_CURRENT_USER + 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 :: IO (Maybe String) +registryProxyString = catchIO + (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do + enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" + if enable + then fmap Just $ regQueryValue hkey (Just "ProxyServer") + 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 +-- into a @Proxy@ value. If you want to be informed of ill-formed proxy +-- configuration strings, supply @True@ for @flg@. +-- Proxy settings are sourced from the @HTTP_PROXY@ environment variable, +-- and in the case of Windows platforms, by consulting IE/WinInet's proxy +-- setting in the Registry. +fetchProxy :: Bool -> IO Proxy +fetchProxy warnIfIllformed = do + mstr <- proxyString + case mstr of + Nothing -> return NoProxy + Just str -> case parseProxy str of + Just p -> return p + Nothing -> do + when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines + [ "invalid http proxy uri: " ++ show str + , "proxy uri must be http with a hostname" + , "ignoring http proxy, trying a direct connection" + ] + return NoProxy + +-- | @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 + `mplus` parseHttpURI ("http://" ++ str) + where + parseHttpURI str' = + case parseAbsoluteURI str' of + Just uri@URI{uriAuthority = Just{}} -> Just (fixUserInfo uri) + _ -> Nothing + + -- Note: we need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ + -- which lack the @\"http://\"@ URI scheme. The problem is that + -- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme + -- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. + -- + -- So our strategy is to try parsing as normal uri first and if it lacks the + -- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. + -- + +-- | tidy up user portion, don't want the trailing "\@". +fixUserInfo :: URI -> URI +fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } + 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) + } = + Just (Proxy (hst ++ prt) auth) + where + auth = + case auth' of + [] -> Nothing + as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri) + where + (usr,pwd) = chopAtDelim ':' as + +uri2proxy _ = Nothing + +-- utilities +#if defined(WIN32) +regQueryValueDWORD :: HKEY -> String -> IO DWORD +regQueryValueDWORD hkey name = alloca $ \ptr -> do + -- 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 new file mode 100644 index 0000000..112b719 --- /dev/null +++ b/Network/HTTP/Stream.hs @@ -0,0 +1,236 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Stream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Transmitting HTTP requests and responses holding @String@ in their payload bodies. +-- This is one of the implementation modules for the "Network.HTTP" interface, representing +-- request and response content as @String@s and transmitting them in non-packed form +-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles. +-- It is mostly here for backwards compatibility, representing how requests and responses +-- were transmitted up until the 4.x releases of the HTTP package. +-- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- 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.Stream + + , simpleHTTP -- :: Request_String -> IO (Result Response_String) + , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , 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 + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.Stream +import Network.StreamDebugger (debugStream) +import Network.TCP (openTCPPort) +import Network.BufferType ( stringBufferOp ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Exception (onException) +import Control.Monad (when) + + +-- Turn on to enable HTTP traffic logging +debug :: Bool +debug = False + +-- File that HTTP traffic logs go to +httpLogFile :: String +httpLogFile = "http-debug.log" + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + + +-- | Simple way to transmit a resource across a non-persistent connection. +simpleHTTP :: Request_String -> IO (Result Response_String) +simpleHTTP r = do + auth <- getAuth r + c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) +simpleHTTP_ s r + | not debug = sendHTTP s r + | otherwise = do + s' <- debugStream httpLogFile s + sendHTTP s' r + +sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) +sendHTTP conn rq = sendHTTP_notify conn rq (return ()) + +sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + onException (sendMain conn rq onSendComplete) + (close conn) + where + providedClose = findConnClose (rqHeaders rq) + +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- 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 + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + -- TODO review throwing away of result + _ <- writeBlock conn (show rqst) + -- write body immediately, don't wait for 100 CONTINUE + -- 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 + lor <- readTillEmpty1 stringBufferOp (readLine conn) + return $ lor >>= parseResponseHead + +-- Hmmm, this could go bad if we keep getting "100 Continue" +-- responses... Except this should never happen according +-- to the RFC. +switchResponse :: Stream s + => s + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request_String + -> IO (Result Response_String) +switchResponse _ _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- 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 = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> {- Time to send the body -} + do { val <- writeBlock conn (rqBody rqst) + ; case val of + Left e -> return (Left e) + Right _ -> + do { rsp <- getResponseHead conn + ; switchResponse conn allow_retry True rsp rqst + } + } + | otherwise -> {- keep waiting -} + do { rsp <- getResponseHead conn + ; 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 { -- 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) + return (Right $ Response cd rn hdrs "") + + DieHorribly str -> do + close conn + return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) + + ExpectEntity -> + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + in + do { rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer (readBlock conn) (read x :: Int) + Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer stringBufferOp + (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)) + } + +-- | 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 + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = + 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. + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer (readBlock conn) (read x :: Int) + Nothing -> return (Right ([], "")) -- hopefulTransfer "" + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer stringBufferOp + (readLine conn) (readBlock conn) + _ -> uglyDeathTransfer "receiveHTTP" + + return $ do + (ftrs,bdy) <- rslt + return (Request uri rm (hdrs++ftrs) bdy) + +-- | 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 -- TODO review throwing away of result + _ <- writeBlock conn (show rsp) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO review throwing away of result + _ <- writeBlock conn (rspBody rsp) + return () diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs new file mode 100644 index 0000000..3cf00ad --- /dev/null +++ b/Network/HTTP/Utils.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Utils +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Set of utility functions and definitions used by package modules. +-- +module Network.HTTP.Utils + ( 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]) + + ) where + +import Data.Char +import Data.List ( elemIndex ) +import Data.Maybe ( fromMaybe ) + +-- | @crlf@ is our beloved two-char line terminator. +crlf :: String +crlf = "\r\n" + +-- | @lf@ is a tolerated line terminator, per RFC 2616 section 19.3. +lf :: String +lf = "\n" + +-- | @sp@ lets you save typing one character. +sp :: String +sp = " " + +-- | @split delim ls@ splits a list into two parts, the @delim@ occurring +-- at the head of the second list. If @delim@ isn't in @ls@, @Nothing@ is +-- returned. +split :: Eq a => a -> [a] -> Maybe ([a],[a]) +split delim list = case delim `elemIndex` list of + Nothing -> Nothing + Just x -> Just $ splitAt x list + +-- | @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 +trimL xs = dropWhile isSpace xs + +-- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace') +-- from @str@. +trimR :: String -> String +trimR str = fromMaybe "" $ foldr trimIt Nothing str + where + trimIt x (Just xs) = Just (x:xs) + 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 = + case break (==c) xs of + (_,[]) -> [xs] + (as,_:bs) -> as : splitBy c bs + +-- | @readsOne f def str@ tries to 'read' @str@, taking +-- 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 = + case reads str of + ((v,_):_) -> f v + _ -> n + + +-- | @dropWhileTail p ls@ chops off trailing elements from @ls@ +-- until @p@ returns @False@. +dropWhileTail :: (a -> Bool) -> [a] -> [a] +dropWhileTail f ls = + case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] } + where + chop x (Just xs) = Just (x:xs) + chop x _ + | f x = Nothing + | otherwise = Just [x] + +-- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence +-- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second +-- list is empty and the first is equal to @ls@. +chopAtDelim :: Eq a => a -> [a] -> ([a],[a]) +chopAtDelim elt xs = + case break (==elt) xs of + (_,[]) -> (xs,[]) + (as,_:bs) -> (as,bs) diff --git a/Network/Stream.hs b/Network/Stream.hs new file mode 100644 index 0000000..43caa61 --- /dev/null +++ b/Network/Stream.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.Stream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An library for creating abstract streams. Originally part of Gray's\/Bringert's +-- HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Removed unnecessary import statements. +-- - Moved Debug code to StreamDebugger.hs +-- - Moved Socket-related code to StreamSocket.hs. +-- +-- * Changes by Simon Foster: +-- - Split Network.HTTPmodule up into to separate +-- Network.[Stream,TCP,HTTP] modules +----------------------------------------------------------------------------- +module Network.Stream + ( Stream(..) + , ConnError(..) + , Result + , bindE + , fmapE + + , failParse -- :: String -> Result a + , failWith -- :: ConnError -> Result a + , failMisc -- :: String -> Result a + ) where + +import Control.Monad.Error + +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) + +failParse :: String -> Result a +failParse x = failWith (ErrorParse x) + +failWith :: ConnError -> Result a +failWith x = Left x + +bindE :: Result a -> (a -> Result b) -> Result b +bindE (Left e) _ = Left e +bindE (Right v) f = f v + +fmapE :: (a -> Result b) -> IO (Result a) -> IO (Result b) +fmapE f a = do + x <- a + case x of + Left e -> return (Left e) + Right r -> return (f r) + +-- | This is the type returned by many exported network functions. +type Result a = Either ConnError {- error -} + a {- result -} + +-- | Streams should make layering of TLS protocol easier in future, +-- they allow reading/writing to files etc for debugging, +-- they allow use of protocols other than TCP/IP +-- and they allow customisation. +-- +-- Instances of this class should not trim +-- 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 + readLine :: x -> IO (Result String) + readBlock :: x -> Int -> IO (Result String) + writeBlock :: x -> String -> IO (Result ()) + close :: x -> IO () + closeOnEnd :: x -> Bool -> IO () + -- ^ True => shutdown the connection when response has been read / end-of-stream + -- has been reached. diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs new file mode 100644 index 0000000..04b5f0a --- /dev/null +++ b/Network/StreamDebugger.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.StreamDebugger +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Implements debugging of @Stream@s. Originally part of Gray's\/Bringert's +-- HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Created. Made minor formatting changes. +-- +----------------------------------------------------------------------------- +module Network.StreamDebugger + ( StreamDebugger + , debugStream + , debugByteStream + ) where + +import Network.Stream (Stream(..)) +import System.IO + ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, + hSetBuffering, BufferMode(NoBuffering) + ) +import Network.TCP ( HandleStream, HStream, + StreamHooks(..), setStreamHooks, getStreamHooks ) + +-- | Allows stream logging. Refer to 'debugStream' below. +data StreamDebugger x + = Dbg Handle x + +instance (Stream x) => Stream (StreamDebugger x) where + readBlock (Dbg h x) n = + do val <- readBlock x n + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (show val) + return val + readLine (Dbg h x) = + do val <- readLine x + hPutStrLn h ("--readLine") + 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) + return val + close (Dbg h x) = + do hPutStrLn h "--closing..." + hFlush h + close x + hPutStrLn h "--closed." + hClose h + closeOnEnd (Dbg h x) f = + do hPutStrLn h ("--close-on-end.." ++ show f) + 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 = + 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 + case sh of + 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 = + 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} + hPutStrLn h ("--readLine") + hPutStrLn h (either show show eval) + , hook_writeBlock = \ toStr str val -> do + hPutStrLn h ("--writeBlock " ++ show val) + hPutStrLn h (toStr str) + , hook_close = do + hPutStrLn h "--closing..." + hFlush h + hClose h + , hook_name = nm + } diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs new file mode 100644 index 0000000..f619e4d --- /dev/null +++ b/Network/StreamSocket.hs @@ -0,0 +1,93 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.StreamSocket +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Made dependencies explicit in import statements. +-- - Removed false dependencies in import statements. +-- - Created separate module for instance Stream Socket. +-- +-- * Changes by Simon Foster: +-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules +-- +----------------------------------------------------------------------------- +module Network.StreamSocket + ( handleSocketError + , myrecv + ) where + +import Network.Stream + ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result + ) +import Network.Socket + ( Socket, getSocketOption, shutdown, send, recv, sClose + , ShutdownCmd(ShutdownBoth), SocketOption(SoError) + ) + +import Network.HTTP.Base ( catchIO ) +import Control.Monad (liftM) +import Control.Exception as Exception (IOException) +import System.IO.Error (isEOFError) + +-- | Exception handler for socket operations. +handleSocketError :: Socket -> IOException -> IO (Result a) +handleSocketError sk e = + do se <- getSocketOption sk SoError + case se of + 0 -> ioError e + 10054 -> return $ Left ErrorReset -- reset + _ -> return $ Left $ ErrorMisc $ show se + +myrecv :: Socket -> Int -> IO String +myrecv sock len = + let handler e = if isEOFError e then return [] else ioError e + in catchIO (recv sock len) handler + +instance Stream Socket where + readBlock sk n = readBlockSocket sk n + readLine sk = readLineSocket sk + writeBlock sk str = writeBlockSocket sk str + close sk = do + -- This slams closed the connection (which is considered rude for TCP\/IP) + shutdown sk ShutdownBoth + sClose 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) +readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk) + where + fn x = do { str <- myrecv sk x + ; let len = length str + ; if len < x + then ( fn (x-len) >>= \more -> return (str++more) ) + else return str + } + +-- Use of the following function is discouraged. +-- 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) +readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk) + where + fn str = do + c <- myrecv sk 1 -- like eating through a straw. + 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) + diff --git a/Network/TCP.hs b/Network/TCP.hs new file mode 100644 index 0000000..8d8a0e3 --- /dev/null +++ b/Network/TCP.hs @@ -0,0 +1,414 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.TCP +-- Copyright : See LICENSE file +-- License : BSD +-- +-- 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. +-- +----------------------------------------------------------------------------- +module Network.TCP + ( Connection + , EndPoint(..) + , openTCPPort + , isConnectedTo + + , openTCPConnection + , socketConnection + , isTCPConnectedTo + + , HandleStream + , HStream(..) + + , StreamHooks(..) + , nullHooks + , setStreamHooks + , getStreamHooks + , hstreamToConnection + + ) where + +import Network.Socket + ( Socket, SocketOption(KeepAlive) + , SocketType(Stream), connect + , shutdown, ShutdownCmd(..) + , sClose, setSocketOption, getPeerName + , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo + , defaultHints, addrFamily, withSocketsDo + , addrSocketType, addrAddress + ) +import qualified Network.Stream as Stream + ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) +import Network.Stream + ( ConnError(..) + , Result + , failWith + , failMisc + ) +import Network.BufferType + +import Network.HTTP.Base ( catchIO ) +import Network.Socket ( socketToHandle ) + +import Data.Char ( toLower ) +import Data.Word ( Word8 ) +import Control.Concurrent +import Control.Exception ( onException ) +import Control.Monad ( liftM, when ) +import System.IO ( Handle, hFlush, IOMode(..), hClose ) +import System.IO.Error ( isEOFError ) + +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy + +----------------------------------------------------------------- +------------------ TCP Connections ------------------------------ +----------------------------------------------------------------- + +-- | The 'Connection' newtype is a wrapper that allows us to make +-- connections an instance of the Stream class, without GHC extensions. +-- While this looks sort of like a generic reference to the transport +-- layer it is actually TCP specific, which can be seen in the +-- implementation of the 'Stream Connection' instance. +newtype Connection = Connection (HandleStream String) + +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 + , connEndPoint :: EndPoint + , connHooks :: Maybe (StreamHooks a) + , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. + } + | ConnClosed + deriving(Eq) + +hstreamToConnection :: HandleStream String -> Connection +hstreamToConnection h = Connection h + +connHooks' :: Conn a -> Maybe (StreamHooks a) +connHooks' ConnClosed{} = Nothing +connHooks' x = connHooks x + +-- all of these are post-op hooks +data StreamHooks ty + = StreamHooks + { hook_readLine :: (ty -> String) -> Result ty -> IO () + , hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO () + , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO () + , hook_close :: IO () + , hook_name :: String -- hack alert: name of the hook itself. + } + +instance Eq ty => Eq (StreamHooks ty) where + (==) _ _ = True + +nullHooks :: StreamHooks ty +nullHooks = StreamHooks + { hook_readLine = \ _ _ -> return () + , hook_readBlock = \ _ _ _ -> return () + , hook_writeBlock = \ _ _ _ -> return () + , hook_close = return () + , hook_name = "" + } + +setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () +setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) + +getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty)) +getStreamHooks h = readMVar (getRef h) >>= return.connHooks + +-- | @HStream@ overloads the use of 'HandleStream's, letting you +-- overload the handle operations over the type that is communicated +-- across the handle. It comes in handy for @Network.HTTP@ 'Request' +-- and 'Response's as the payload representation isn't fixed, but overloaded. +-- +-- 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 -> 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 + readBlock c n = readBlockBS c n + readLine c = readLineBS c + writeBlock c str = writeBlockBS c str + close c = closeIt c Strict.null True + closeQuick c = closeIt c Strict.null False + closeOnEnd c f = closeEOF c f + +instance HStream Lazy.ByteString where + openStream = \ a b -> openTCPConnection_ 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 + close c = closeIt c Lazy.null True + closeQuick c = closeIt c Lazy.null False + closeOnEnd c f = closeEOF c f + +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 + close (Connection c) = Network.TCP.close c + closeOnEnd (Connection c) f = Network.TCP.closeEOF c f + +instance HStream String where + openStream = openTCPConnection + openSocketStream = socketConnection + readBlock ref n = readBlockBS ref n + + -- 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, + -- since in general messages are serialised in their entirety. + writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) + + -- Closes a Connection. Connection will no longer + -- allow any of the other Stream functions. Notice that a Connection may close + -- 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 +-- may trigger a network connection. +openTCPPort :: String -> Int -> IO Connection +openTCPPort uri port = openTCPConnection uri port >>= return.Connection + +-- Add a "persistent" option? Current persistent is default. +-- Use "Result" type for synchronous exception reporting? +openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty) +openTCPConnection uri port = openTCPConnection_ uri port False + +openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) +openTCPConnection_ uri port stashInput = do + -- 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 + + + -- 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) + case addrinfos of + [] -> fail "openTCPConnection: getAddrInfo returned no address information" + (a:_) -> do + s <- socket (addrFamily a) Stream defaultProtocol + onException (do + setSocketOption s KeepAlive 1 + connect s (addrAddress a) + socketConnection_ fixedUri port s stashInput + ) (sClose s) + +-- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. +socketConnection :: BufferType ty + => String + -> 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 + -> 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 + { connSock = sock + , connHandle = h + , connBuffer = bufferOps + , connInput = mb + , connEndPoint = EndPoint hst port + , connHooks = Nothing + , connCloseEOF = False + } + v <- newMVar conn + return (HandleStream v) + +closeConnection :: HStream a => HandleStream a -> IO Bool -> IO () +closeConnection ref readL = do + -- won't hold onto the lock for the duration + -- we are draining it...ToDo: have Connection + -- into a shutting-down state so that other + -- threads will simply back off if/when attempting + -- to also close it. + c <- readMVar (getRef ref) + closeConn c `catchIO` (\_ -> return ()) + modifyMVar_ (getRef ref) (\ _ -> return ConnClosed) + where + -- Be kind to peer & close gracefully. + closeConn ConnClosed = return () + closeConn conn = do + let sk = connSock conn + hFlush (connHandle conn) + shutdown sk ShutdownSend + suck readL + hClose (connHandle conn) + shutdown sk ShutdownReceive + sClose sk + + suck :: IO Bool -> IO () + suck rd = do + f <- rd + if f then return () else suck rd + +-- | Checks both that the underlying Socket is connected +-- and that the connection peer matches the given +-- host name (which is recorded locally). +isConnectedTo :: Connection -> EndPoint -> IO Bool +isConnectedTo (Connection conn) endPoint = isTCPConnectedTo conn endPoint + +isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool +isTCPConnectedTo conn endPoint = do + v <- readMVar (getRef conn) + case v of + ConnClosed -> 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) +readBlockBS ref n = onNonClosedDo ref $ \ conn -> do + x <- bufferGetBlock ref n + maybe (return ()) + (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) + (connHooks' conn) + return x + +-- This function uses a buffer, at this time the buffer is just 1000 characters. +-- (however many bytes this is is left for the user to decipher) +readLineBS :: HStream a => HandleStream a -> IO (Result a) +readLineBS ref = onNonClosedDo ref $ \ conn -> do + x <- bufferReadLine ref + maybe (return ()) + (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) + (connHooks' conn) + return x + +-- 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) + return x + +closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO () +closeIt c p b = do + closeConnection c (if b + then readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True} + else return True) + conn <- readMVar (getRef c) + maybe (return ()) + (hook_close) + (connHooks' conn) + +closeEOF :: HandleStream ty -> Bool -> IO () +closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg}) + +bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a) +bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do + case connInput conn of + Just c -> do + let (a,b) = buf_splitAt (connBuffer conn) n c + modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b}) + return (return a) + _ -> do + 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 = + 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 + case connInput conn of + Just c -> do + let (a,b0) = buf_span (connBuffer conn) (/='\n') c + 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)) + _ -> catchIO + (buf_hGetLine (connBuffer conn) (connHandle conn) >>= + return . return . appendNL (connBuffer conn)) + (\ e -> + if isEOFError e + then do + 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') + +onNonClosedDo :: HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b) +onNonClosedDo h act = do + x <- readMVar (getRef h) + case x of + ConnClosed{} -> return (failWith ErrorClosed) + _ -> act x + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 index 0000000..e2c31e7 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/test/Httpd.hs b/test/Httpd.hs new file mode 100644 index 0000000..6a841e4 --- /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 index 0000000..0b8a7bc --- /dev/null +++ b/test/UnitTests.hs @@ -0,0 +1,32 @@ +module UnitTests ( unitTests ) where + +import Network.HTTP.Base +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")))) + +unitTests = + [testGroup "Unit tests" + [ testGroup "URI parsing" + [ testCase "Parse IPv4 address" parseIPv4Address + , testCase "Parse IPv6 address" parseIPv6Address + ] + ] + ] diff --git a/test/httpTests.hs b/test/httpTests.hs new file mode 100644 index 0000000..c843218 --- /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 shouln'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