HTTP 3000.0.0 → 4000.5.0
raw patch · 24 files changed
Files
- CHANGES +133/−0
- HTTP.cabal +178/−20
- LICENSE +11/−1
- Network/Browser.hs +1091/−976
- Network/BufferType.hs +164/−0
- Network/HTTP.hs +262/−1049
- Network/HTTP/Auth.hs +221/−0
- Network/HTTP/Base.hs +1002/−0
- Network/HTTP/Base64.hs +27/−29
- Network/HTTP/Cookie.hs +141/−0
- Network/HTTP/HandleStream.hs +252/−0
- Network/HTTP/Headers.hs +461/−0
- Network/HTTP/MD5.hs +0/−44
- Network/HTTP/MD5Aux.hs +17/−29
- Network/HTTP/Proxy.hs +226/−0
- Network/HTTP/Stream.hs +236/−0
- Network/HTTP/Utils.hs +207/−0
- Network/Stream.hs +46/−136
- Network/StreamDebugger.hs +103/−0
- Network/StreamSocket.hs +97/−0
- Network/TCP.hs +391/−146
- test/Httpd.hs +158/−0
- test/UnitTests.hs +69/−0
- test/httpTests.hs +668/−0
+ CHANGES view
@@ -0,0 +1,133 @@+Version 4000.4.0: release 2022-02-22+ * Restrict to GHC >=7.6 and associated cleanups (Andreas Abel)+ * Drop deprecated instance Error (Andreas Abel)+ * Preparation for mtl-2.3 (Andreas Abel)+ * General tidying (Andreas Abel)+ * Support GHC 9.2 (Bodigrim)++Version 4000.3.16: release 2021-03-20+ * Support GHC-9.0 (Oleg Genrus)+ * Various dependency bumps (multiple people)+ * Try all addresses returned by getAddrInfo (Fraser Tweedale)++Version ?++ * If the URI contains "user:pass@" part, use it for Basic Authorization+ * Add a test harness.+ * Don't leak a socket when getHostAddr throws an exception.+ * Send cookies in request format, not response format.+ * Moved BrowserAction to be a StateT IO, with instances for+ Applicative, MonadIO, MonadState.+ * Add method to control size of connection pool.+ * Consider both host and port when reusing connections.+ * Handle response code 304 "not modified" properly.+ * Fix digest authentication by fixing md5 output string rep.+ * Make the default user agent string follow the package version.+ * Document lack of HTTPS support and fail when clients try+ to use it instead of silently falling back to HTTP.+ * Add helper to set the request type and body.++Version 4000.1.2: release 2011-08-11+ * Turn off buffering for the debug log.+ * Update installation instructions.+ * Bump base dependency to support GHC 7.2.++Version 4000.1.1: release 2010-11-28+ * Be tolerant of LF (instead of CRLF which is the spec) in responses.++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 <http://trac.haskell.org/http/ticket/7>.++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.+
HTTP.cabal view
@@ -1,26 +1,184 @@+Cabal-Version: 3.0 Name: HTTP-Version: 3000.0.0-License: BSD3+Version: 4000.5.0+Build-type: Simple+License: BSD-3-Clause License-file: LICENSE-Copyright: - Copyright (c) 2002, Warrick Gray- Copyright (c) 2002-2005, Ian Lynagh- Copyright (c) 2003-2006, Bjorn Bringert- Copyright (c) 2004, Andre Furtado- Copyright (c) 2004, Ganesh Sittampalam- Copyright (c) 2004-2005, Dominic Steinitz Author: Warrick Gray <warrick.gray@hotmail.com>-Maintainer: Bjorn Bringert <bjorn@bringert.net>-Homepage: http://www.haskell.org/http/-Description: A library for client-side HTTP-Build-depends: base, network, parsec-Exposed-modules: +Maintainer: Ganesh Sittampalam <ganesh@earth.li>+Homepage: https://github.com/haskell/HTTP+Category: Network+Synopsis: A library for client-side HTTP+Description:++ The HTTP package supports client-side web programming in Haskell. It lets you set up+ HTTP connections, transmitting requests and processing the responses coming back, all+ from within the comforts of Haskell. It's dependent on the network package to operate,+ but other than that, the implementation is all written in Haskell.+ .+ A basic API for issuing single HTTP requests + receiving responses is provided. On top+ of that, a session-level abstraction is also on offer (the @BrowserAction@ monad);+ it taking care of handling the management of persistent connections, proxies,+ state (cookies) and authentication credentials required to handle multi-step+ interactions with a web server.+ .+ The representation of the bytes flowing across is extensible via the use of a type class,+ letting you pick the representation of requests and responses that best fits your use.+ Some pre-packaged, common instances are provided for you (@ByteString@, @String@).+ .+ Here's an example use:+ .+ >+ > do+ > rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/")+ > -- fetch document and return it (as a 'String'.)+ > fmap (take 100) (getResponseBody rsp)+ >+ > do+ > (_, rsp)+ > <- Network.Browser.browse $ do+ > setAllowRedirects True -- handle HTTP redirects+ > request $ getRequest "http://www.haskell.org/"+ > return (take 100 (rspBody rsp))+ .+ __Note:__ This package does not support HTTPS connections.+ If you need HTTPS, take a look at the following packages:+ .+ * <http://hackage.haskell.org/package/http-streams http-streams>+ .+ * <http://hackage.haskell.org/package/http-client http-client> (in combination with+ <http://hackage.haskell.org/package/http-client-tls http-client-tls>)+ .+ * <http://hackage.haskell.org/package/req req>+ .+ * <http://hackage.haskell.org/package/wreq wreq>+ .++Extra-Source-Files: CHANGES++tested-with:+ GHC == 9.12.2+ GHC == 9.10.3+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ -- CI failing for GHC 8.0 because of https://github.com/haskell/cabal/issues/10379+ -- GHC == 8.0.2++Source-Repository head+ type: git+ location: https://github.com/haskell/HTTP.git++Flag warn-as-error+ default: False+ description: Build with warnings-as-errors+ manual: True++Flag conduit10+ description: Use version 1.0.x or below of the conduit package (for the test suite)+ default: False++Flag warp-tests+ description: Test against warp+ default: False+ manual: True++Library+ Autogen-modules: Paths_HTTP+ Exposed-modules:+ Network.BufferType, Network.Stream,- Network.TCP, - Network.HTTP,+ 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:+ Other-modules: Network.HTTP.Base64,- Network.HTTP.MD5,- Network.HTTP.MD5Aux-GHC-options: -O -fwarn-missing-signatures+ Network.HTTP.MD5Aux,+ Network.HTTP.Utils,+ Paths_HTTP+ GHC-options: -fwarn-missing-signatures -Wall++ -- note the test harness constraints should be kept in sync with these+ -- where dependencies are shared+ build-depends:+ base >= 4.6.0.0 && < 4.22+ , array >= 0.3.0.2 && < 0.6+ , bytestring >= 0.9.1.5 && < 0.13+ , parsec >= 2.0 && < 3.2+ , time >= 1.1.2.3 && < 1.15+ , transformers >= 0.2.0.0 && < 0.7+ -- transformers-0.2.0.0 is the first to have Control.Monad.IO.Class+ -- The following dependencies are refined by flags, but they should+ -- still be mentioned here on the top-level.+ , mtl >= 2.0.0.0 && < 2.4+ , network >= 2.6 && < 3.3+ , network-uri >= 2.6 && < 2.7++ default-language: Haskell98+ default-extensions: FlexibleInstances++ if flag(warn-as-error)+ ghc-options: -Werror++ if os(windows)+ Build-depends: Win32 >= 2.2.0.0 && < 2.15++Test-Suite test+ type: exitcode-stdio-1.0++ default-language: Haskell98+ hs-source-dirs: test+ main-is: httpTests.hs++ other-modules:+ Httpd+ UnitTests++ ghc-options: -Wall++ build-depends:+ HTTP+ -- constraints inherited from HTTP+ , base+ , bytestring+ , mtl+ , network+ , network-uri+ -- extra dependencies+ , deepseq >= 1.3.0.0 && < 1.6+ , httpd-shed >= 0.4 && < 0.5+ , HUnit >= 1.2.0.1 && < 1.7+ , pureMD5 >= 0.2.4 && < 2.2+ , split >= 0.1.3 && < 0.3+ , test-framework >= 0.2.0 && < 0.9+ , test-framework-hunit >= 0.3.0 && < 0.4++ if flag(warp-tests)+ CPP-Options: -DWARP_TESTS+ build-depends:+ case-insensitive >= 0.4.0.1 && < 1.3+ , conduit >= 1.0.8 && < 1.4+ , http-types >= 0.8.0 && < 1.0+ , wai >= 2.1.0 && < 3.3+ , warp >= 2.1.0 && < 3.5++ if flag(conduit10)+ build-depends: conduit < 1.1+ else+ build-depends: conduit >= 1.1, conduit-extra >= 1.1 && < 1.4
LICENSE view
@@ -2,8 +2,18 @@ Copyright (c) 2002-2005, Ian Lynagh Copyright (c) 2003-2006, Bjorn Bringert Copyright (c) 2004, Andre Furtado-Copyright (c) 2004, Ganesh Sittampalam Copyright (c) 2004-2005, Dominic Steinitz+Copyright (c) 2007, Robin Bate Boerop+Copyright (c) 2008-2010, Sigbjorn Finne+Copyright (c) 2009, Eric Kow+Copyright (c) 2010, Antoine Latter+Copyright (c) 2004, 2010-2011, Ganesh Sittampalam+Copyright (c) 2011, Duncan Coutts+Copyright (c) 2011, Matthew Gruen+Copyright (c) 2011, Jeremy Yallop+Copyright (c) 2011, Eric Hesselink+Copyright (c) 2011, Yi Huang+Copyright (c) 2011, Tom Lokhorst All rights reserved.
Network/Browser.hs view
@@ -1,976 +1,1091 @@--------------------------------------------------------------------------------- |--- Module : Network.Browser--- Copyright : (c) Warrick Gray 2002--- License : BSD--- --- Maintainer : bjorn@bringert.net--- Stability : experimental--- Portability : non-portable (not tested)------ An HTTP\/1.1 compatible wrapper for the HTTP module.------------------------------------------------------------------------------- -{--- Change Log:- - altered 'closeTCP' to 'close', for consistency with altered HTTP- - added debugging settings to browser.-- To Do: - - testing!!!- - remove BrowserAction type? Possibly replace with IORef?- - (more todo's in the HTTP mod)---}--module Network.Browser (- BrowserState,- BrowserAction, -- browser monad, effectively a state monad.- Cookie,- Form(..),- Proxy(..),- - browse, -- BrowserAction a -> IO a- request, -- Request -> BrowserAction Response- - setAllowRedirects,- getAllowRedirects,- - Authority(..),- getAuthorities, - setAuthorities, - addAuthority, - getAuthorityGen, - setAuthorityGen, - setAllowBasicAuth,-- setCookieFilter,- defaultCookieFilter,- userCookieFilter,- - getCookies,- setCookies,- addCookie,-- setErrHandler,- setOutHandler,-- setProxy,-- setDebugLog,-- out,- err,- ioAction, -- :: IO a -> BrowserAction a-- defaultGETRequest,- formToRequest,- uriDefaultTo,- uriTrimHost-) where--import Network.HTTP--import Data.Char (toLower,isAlphaNum,isSpace)-import Data.List (isPrefixOf,isSuffixOf,elemIndex,elemIndices)-import Data.Maybe-import Control.Monad (foldM,filterM,liftM,when)-import Text.ParserCombinators.Parsec-import Network.URI--import qualified System.IO-import Data.Word (Word8)-import qualified Network.HTTP.MD5 as MD5-import qualified Network.HTTP.Base64 as Base64--type Octet = Word8-------------------------------------------------------------------------------------------- Miscellaneous -------------------------------------------------------------------------------------------------word, quotedstring :: Parser String-quotedstring =- do { char '"'- ; str <- many (satisfy $ not . (=='"'))- ; char '"'- ; return str- }--word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))---- misc string fns-trim :: String -> String-trim = let dropspace = dropWhile isSpace in- reverse . dropspace . reverse . dropspace----- | Splits a list into two parts, the delimiter occurs--- at the head of the second list. Nothing is returned--- when no occurance of the delimiter is found.-split :: Eq a => a -> [a] -> Maybe ([a],[a])-split delim list = case delim `elemIndex` list of- Nothing -> Nothing- Just x -> Just $ splitAt x list- ----- | Removes delimiters.-splitMany :: Eq a => a -> [a] -> [[a]]-splitMany delim str = fn str ixs- where- ixs = elemIndices delim str- fn _ [] = []- fn ls (h:t) = let (a,b) = splitAt h ls in a : fn b t----- | Returns a URI that is consistent with the first--- argument uri when read in the context of a second.--- If second argument is not sufficient context for--- determining a full URI then anarchy reins.-uriDefaultTo :: URI -> URI -> URI-uriDefaultTo a b =- case a `relativeTo` b of- Nothing -> a- Just x -> x---uriTrimHost :: URI -> URI-uriTrimHost uri = uri { uriScheme="", uriAuthority=Nothing }--------------------------------------------------------------------------------------------- Cookie Stuff ---------------------------------------------------------------------------------------------------- Some conventions: --- assume ckDomain is lowercase----data Cookie = MkCookie { ckDomain- , ckName- , ckValue :: String- , ckPath- , ckComment- , ckVersion :: Maybe String- }- deriving(Show,Read)---instance Eq Cookie where- a == b = ckDomain a == ckDomain b - && ckName a == ckName b - && ckPath a == ckPath b----defaultCookieFilter :: URI -> Cookie -> IO Bool-defaultCookieFilter url cky = return True--userCookieFilter :: URI -> Cookie -> IO Bool-userCookieFilter url cky =- do putStrLn ("Set-Cookie received when requesting: " ++ show url)- case ckComment cky of- Nothing -> return ()- Just x -> putStrLn ("Cookie Comment:\n" ++ x)- putStrLn ("Domain/Path: " ++ ckDomain cky ++ - case ckPath cky of- Nothing -> ""- Just x -> "/" ++ x)- 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')- ----- | Serialise a Cookie for inclusion in a request.-cookieToHeader :: Cookie -> Header-cookieToHeader ck = Header HdrCookie text- where- text = "$Version=" ++ fromMaybe "0" (ckVersion ck)- ++ ';' : ckName ck ++ "=" ++ ckValue ck- ++ (case ckPath ck of- Nothing -> ""- Just x -> ";$Path=" ++ x)- ++ ";$Domain=" ++ ckDomain ck----{- replace "error" call with [] in final version? -}-headerToCookies :: String -> Header -> [Cookie]-headerToCookies dom (Header HdrSetCookie val) = - case parse cookies "" val of- Left e -> error ("Cookie parse failure on: " ++ val ++ " " ++ show e)- Right x -> x- where- cookies :: Parser [Cookie]- cookies = sepBy1 cookie (char ',')-- cookie :: Parser Cookie- cookie =- do { name <- word- ; spaces- ; char '='- ; spaces- ; val <- cvalue- ; args <- cdetail- ; return $ mkCookie name val args- }-- cvalue :: Parser String- - spaces = many (satisfy isSpace)-- cvalue = quotedstring <|> many1 (satisfy $ not . (==';'))- - -- all keys in the result list MUST be in lower case- cdetail :: Parser [(String,String)]- cdetail = many $- try (do { spaces- ; char ';'- ; spaces- ; s1 <- word- ; spaces- ; s2 <- option "" (do { char '=' ; spaces ; v <- cvalue ; return v })- ; return (map toLower s1,s2)- })-- mkCookie :: String -> String -> [(String,String)] -> Cookie- mkCookie nm val more = MkCookie { ckName=nm- , ckValue=val- , ckDomain=map toLower (fromMaybe dom (lookup "domain" more))- , ckPath=lookup "path" more- , ckVersion=lookup "version" more- , ckComment=lookup "comment" more- }-- ---- | Adds a cookie to the browser state, removing duplicates.-addCookie :: Cookie -> BrowserAction ()-addCookie c = alterBS (\b -> b { bsCookies=c : fn (bsCookies b) })- where- fn = filter (not . (==c))--setCookies :: [Cookie] -> BrowserAction ()-setCookies cs = alterBS (\b -> b { bsCookies=cs })--getCookies :: BrowserAction [Cookie]-getCookies = getBS bsCookies---- ...get domain specific cookies...--- ... this needs changing for consistency with rfc2109...--- ... currently too broad.-getCookiesFor :: String -> String -> BrowserAction [Cookie]-getCookiesFor dom path =- do cks <- getCookies- return (filter cookiematch cks)- where- cookiematch :: Cookie -> Bool- cookiematch ck = ckDomain ck `isSuffixOf` dom- && case ckPath ck of- Nothing -> True- Just p -> p `isPrefixOf` path- --setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction ()-setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f })--getCookieFilter :: BrowserAction (URI -> Cookie -> IO Bool)-getCookieFilter = getBS 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---}---data Algorithm = AlgMD5 | AlgMD5sess- deriving(Eq)--instance Show Algorithm where- show AlgMD5 = "md5"- show AlgMD5sess = "md5-sess"---data Qop = QopAuth | QopAuthInt- deriving(Eq,Show)---data Challenge = ChalBasic { chRealm :: String }- | ChalDigest { chRealm :: String- , chDomain :: [URI]- , chNonce :: String- , chOpaque :: Maybe String- , chStale :: Bool- , chAlgorithm ::Maybe Algorithm- , chQop :: [Qop]- }---- | Convert WWW-Authenticate header into a Challenge object-headerToChallenge :: URI -> Header -> Maybe Challenge-headerToChallenge baseURI (Header _ str) =- case parse challenge "" str of- Left e -> Nothing- Right (name,props) -> case name of- "basic" -> mkBasic props- "digest" -> mkDigest props- _ -> Nothing- where- challenge :: Parser (String,[(String,String)])- challenge =- do { nme <- word- ; 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)- }-- quotedstring =- do { char '"'- ; str <- many (satisfy (not.(=='"')))- ; char '"'- ; return str- } - - 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]- annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes-- -- Change These:- readQop :: String -> [Qop]- readQop = catMaybes . (map strToQop) . (splitMany ',')-- strToQop str = case map toLower (trim str) of- "auth" -> Just QopAuth- "auth-int" -> Just QopAuthInt- _ -> Nothing-- readAlgorithm str = case map toLower (trim str) of- "md5" -> Just AlgMD5- "md5-sess" -> Just AlgMD5sess- _ -> Nothing---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]- }----- | Return authorities for a given domain and path.--- Assumes "dom" is lower case-getAuthFor :: String -> String -> BrowserAction [Authority]-getAuthFor dom pth =- do { list <- getAuthorities- ; return (filter match list)- }- where- match :: Authority -> Bool- match (AuthBasic _ _ _ s) = matchURI s- match (AuthDigest _ _ _ _ _ ds _ _) = or (map matchURI ds) -- matchURI :: URI -> Bool- matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth)- ---- | Interacting with browser state:-getAuthorities :: BrowserAction [Authority]-getAuthorities = getBS bsAuthorities--setAuthorities :: [Authority] -> BrowserAction ()-setAuthorities as = alterBS (\b -> b { bsAuthorities=as })--addAuthority :: Authority -> BrowserAction ()-addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b })--getAuthorityGen :: BrowserAction (URI -> String -> IO (Maybe (String,String)))-getAuthorityGen = getBS bsAuthorityGen--setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction ()-setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f })--setAllowBasicAuth :: Bool -> BrowserAction ()-setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba })------- TO BE CHANGED!!!-pickChallenge :: [Challenge] -> Maybe Challenge-pickChallenge = listToMaybe------ | Retrieve a likely looking authority for a Request.-anticipateChallenge :: Request -> BrowserAction (Maybe Authority)-anticipateChallenge rq =- let uri = rqURI rq in- do { authlist <- getAuthFor (uriToAuthorityString uri) (uriPath uri)- ; return (listToMaybe authlist)- }----- | Asking the user to respond to a challenge-challengeToAuthority :: URI -> Challenge -> BrowserAction (Maybe Authority)-challengeToAuthority uri ch =- -- prompt user for authority- if answerable ch then- do { prompt <- getAuthorityGen- ; userdetails <- ioAction $ prompt uri (chRealm ch)- ; case userdetails of- Nothing -> return Nothing- Just (u,p) -> return (Just $ buildAuth ch u p)- }- else return Nothing- where- answerable :: Challenge -> Bool- answerable (ChalBasic _) = True- answerable ch = (chAlgorithm ch) == 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 s a q) u p =- AuthDigest { auRealm=r- , auUsername=u- , auPassword=p- , auDomain=d- , auNonce=n- , auOpaque=o- , auAlgorithm=a- , auQop=q- }----- | Generating a credentials value from an Authority, in--- the context of a specific request. If a client nonce--- was to be used then this function might need to--- be of type ... -> BrowserAction String-withAuthority :: Authority -> Request -> String-withAuthority a rq = case a of- AuthBasic _ _ user pass ->- "basic " ++ base64encode (auUsername a ++ ':' : auPassword a)- AuthDigest _ _ _ _ _ _ _ _ ->- "digest username=\"" ++ auUsername a - ++ "\",realm=\"" ++ auRealm a- ++ "\",nonce=\"" ++ auNonce a- ++ "\",uri=\"" ++ digesturi- ++ ",response=\"" ++ rspdigest - ++ "\""- -- plus optional stuff:- ++ ( if isJust (auAlgorithm a) then "" else ",algorithm=\"" ++ show (fromJust $ auAlgorithm a) ++ "\"" )- ++ ( if isJust (auOpaque a) then "" else ",opaque=\"" ++ (fromJust $ auOpaque a) ++ "\"" )- ++ ( if null (auQop a) then "" else ",qop=auth" )- where- rspdigest = "\"" - ++ map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2))- ++ "\""-- -- FIXME: these probably only work right for latin-1 strings- stringToOctets :: String -> [Octet]- stringToOctets = map (fromIntegral . fromEnum)- octetsToString :: [Octet] -> String- octetsToString = map (toEnum . fromIntegral)- base64encode :: String -> String- base64encode = Base64.encode . stringToOctets- md5 :: String -> String- md5 = octetsToString . MD5.hash . stringToOctets-- kd :: String -> String -> String- kd a b = md5 (a ++ ":" ++ b)-- 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---------------------------------------------------------------------------------------- Proxy Stuff --------------------------------------------------------------------------------------------------------data Proxy = NoProxy- | Proxy String (Maybe Authority)---------------------------------------------------------------------------------------- Browser State Actions -----------------------------------------------------------------------------------------------data BrowserState = 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- , bsConnectionPool :: [Connection]- , bsProxy :: Proxy- , bsDebug :: Maybe String- }--instance Show BrowserState where- show bs = "BrowserState { " - ++ show (bsCookies bs) ++ "\n"- {- ++ show (bsAuthorities bs) ++ "\n"-}- ++ "AllowRedirects: " ++ show (bsAllowRedirects bs)- ++ "} "----- Simple DIY stateful behaviour, with IO-data BrowserAction a = BA { lift :: (BrowserState -> IO (BrowserState,a)) }--instance Monad BrowserAction where- a >>= f = BA (\b -> do { (nb,v) <- lift a b ; lift (f v) nb})- return x = BA (\b -> return (b,x))--instance Functor BrowserAction where- fmap f = liftM f----- | Apply a browser action to a state.-browse :: BrowserAction a -> IO a-browse act = do x <- lift act defaultBrowserState- return (snd x)- where- defaultBrowserState :: BrowserState- defaultBrowserState = - BS { bsErr = putStrLn- , bsOut = putStrLn- , bsCookies = []- , bsCookieFilter = defaultCookieFilter- , bsAuthorityGen = (error "bsAuthGen wanted")- , bsAuthorities = []- , bsAllowRedirects = True- , bsAllowBasicAuth = False- , bsConnectionPool = []- , bsProxy = NoProxy- , bsDebug = Nothing - }---- | Alter browser state-alterBS :: (BrowserState -> BrowserState) -> BrowserAction ()-alterBS f = BA (\b -> return (f b,()))--getBS :: (BrowserState -> a) -> BrowserAction a-getBS f = BA (\b -> return (b,f b))---- | Do an io action-ioAction :: IO a -> BrowserAction a-ioAction a = BA (\b -> a >>= \v -> return (b,v))----- Stream handlers-setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction ()-setErrHandler h = alterBS (\b -> b { bsErr=h })-setOutHandler h = alterBS (\b -> b { bsOut=h })--out, err :: String -> BrowserAction ()-out s = do { f <- getBS bsOut ; ioAction $ f s }-err s = do { f <- getBS bsErr ; ioAction $ f s }---- Redirects-setAllowRedirects :: Bool -> BrowserAction ()-setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl})--getAllowRedirects :: BrowserAction Bool-getAllowRedirects = getBS bsAllowRedirects----- Proxy-setProxy :: Proxy -> BrowserAction ()-setProxy p = alterBS (\b -> b {bsProxy = p})--getProxy :: BrowserAction Proxy-getProxy = getBS bsProxy----- Debug-setDebugLog :: Maybe String -> BrowserAction ()-setDebugLog v = alterBS (\b -> b {bsDebug=v})----- Page control-type RequestState = ( Int -- number of 401 responses so far- , Int -- number of redirects so far- , Int -- number of retrys so far- , Bool -- whether to pre-empt 401 response- )------ Surely the most important bit:-request :: Request -> BrowserAction (URI,Response)-request = request' initialState- where- initialState = (0,0,0,True)---request' :: RequestState -> Request -> BrowserAction (URI,Response)-request' (denycount,redirectcount,retrycount,preempt) rq =- do -- add cookies to request- let uri = rqURI rq- cookies <- getCookiesFor (uriToAuthorityString uri) (uriPath uri)- - when (not $ null cookies) - (out $ "Adding cookies to request. Cookie names: " - ++ foldl spaceappend "" (map ckName cookies))- - -- add credentials to request- rq' <- if not preempt then return rq else- do { auth <- anticipateChallenge rq- ; case auth of- Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)- Nothing -> return rq- }- - let rq'' = insertHeaders (map cookieToHeader cookies) rq'-- p <- getProxy-- out ("Sending:\n" ++ show rq'') - e_rsp <- case p of- NoProxy -> dorequest (uriAuth $ rqURI rq'') rq''- Proxy str ath ->- let rq''' = case ath of - Nothing -> rq''- Just x -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq''- in dorequest (URIAuth "" str "") rq'''-- case e_rsp of- Left v -> if (retrycount < 4) && (v == ErrorReset || v == ErrorClosed)- then request' (denycount,redirectcount,retrycount+1,preempt) rq- else error ("Exception raised in request: " ++ show v)- Right rsp -> do - out ("Received:\n" ++ show rsp)-- -- add new cookies to browser state- let cookieheaders = retrieveHeaders HdrSetCookie rsp- let newcookies = concat (map (headerToCookies $ uriToAuthorityString uri) cookieheaders)-- when (not $ null newcookies)- (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newcookies)- - filterfn <- getCookieFilter- newcookies' <- ioAction (filterM (filterfn uri) newcookies)- foldM (\_ -> addCookie) () newcookies'-- when (not $ null newcookies)- (out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies'))- - case rspCode rsp of- (4,0,1) -> -- Credentials not sent or refused.- out "401 - credentials not sent or refused" >>- if denycount > 2 then return (uri,rsp) else- do { let hdrs = retrieveHeaders HdrWWWAuthenticate rsp- ; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of- Just x ->- do { au <- challengeToAuthority uri x- ; case au of- Just au' ->- out "Retrying request with new credentials" >>- request' (denycount+1,redirectcount,retrycount,False)- (insertHeader HdrAuthorization (withAuthority au' rq) rq)- Nothing -> return (uri,rsp) {- do nothing -}- }- - Nothing -> return (uri,rsp) {- do nothing -}- }- -- (4,0,7) -> -- Proxy Authentication required- out "407 - proxy authentication required" >>- if denycount > 2 then return (uri,rsp) else- do { let hdrs = retrieveHeaders HdrProxyAuthenticate rsp- ; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of- Just x ->- do { au <- challengeToAuthority uri x- ; case au of- Just au' ->- do { pxy <- getBS bsProxy- ; case pxy of- NoProxy ->- do { err "Proxy authentication required without proxy!"- ; return (uri,rsp)- }- Proxy x y ->- do { out "Retrying with proxy authentication"- ; setProxy (Proxy x $ Just au')- ; request' (denycount+1,redirectcount,retrycount,False) rq- }- } - Nothing -> return (uri,rsp) {- do nothing -}- }- - Nothing -> return (uri,rsp) {- do nothing -}- }--- (3,0,3) -> -- Redirect using GET request method.- do { out "303 - redirect using GET"- ; rd <- getAllowRedirects- ; if not rd || redirectcount > 4 then return (uri,rsp) else- case retrieveHeaders HdrLocation rsp of- (Header _ u:_) -> case parseURIReference u of- Just newuri ->- let newuri' = case newuri `relativeTo` uri of- Nothing -> newuri- Just x -> x- in do { out ("Redirecting to " ++ show newuri' ++ " ...") - ; let rq = rq { rqMethod=GET, rqURI=newuri', rqBody="" }- ; request' (0,redirectcount+1,retrycount,True)- (replaceHeader HdrContentLength "0" rq) - }- Nothing ->- do { err ("Parse of Location header in a redirect response failed: " ++ u)- ; return (uri,rsp)- }- [] -> do { err "No Location header in redirect response"- ; return (uri,rsp)- }- }- - (3,0,5) ->- case retrieveHeaders HdrLocation rsp of- (Header _ u:_) -> case parseURIReference u of- Just newuri ->- do { out ("Retrying with proxy " ++ show newuri ++ "...")- ; setProxy (Proxy (uriToAuthorityString newuri) Nothing)- ; request' (0,0,retrycount+1,True) rq- }- Nothing ->- do { err ("Parse of Location header in a proxy redirect response failed: " ++ u)- ; return (uri,rsp)- }- [] -> do { err "No Location header in proxy redirect response."- ; return (uri,rsp)- }- -- (3,_,_) -> redirect uri rsp- _ -> return (uri,rsp)-- where - spaceappend :: String -> String -> String- spaceappend x y = x ++ ' ' : y-- redirect uri rsp = do- rd <- getAllowRedirects- if not rd || redirectcount > 4 then return (uri,rsp) else do- case retrieveHeaders HdrLocation rsp of- (Header _ u:_) -> case parseURIReference u of- Just newuri -> do- let newuri' = case newuri `relativeTo` uri of- Nothing -> newuri- Just x -> x- out ("Redirecting to " ++ show newuri' ++ " ...") - request' (0,redirectcount+1,retrycount,True) (rq { rqURI=newuri' }) - Nothing -> do- err ("Parse of Location header in a redirect response failed: " ++ u)- return (uri,rsp)- [] -> do err "No Location header in redirect response."- return (uri,rsp)--- dorequest :: URIAuth -> Request -> BrowserAction (Either ConnError Response)- dorequest hst rqst = - do { pool <- getBS bsConnectionPool- ; conn <- ioAction $ filterM (\c -> c `isConnectedTo` uriAuthToString hst) pool- ; rsp <- case conn of- [] -> do { out ("Creating new connection to " ++ uriAuthToString hst)- ; let port = case uriPort hst of- (':':s) -> read s- _ -> 80- ; c <- ioAction $ openTCPPort (uriRegName hst) port- ; let pool' = if length pool > 5- then init pool- else pool- ; when (length pool > 5)- (ioAction $ close (last pool))- ; alterBS (\b -> b { bsConnectionPool=c:pool' })- ; dorequest2 hst c rqst- }- (c:_) ->- do { out ("Recovering connection to " ++ uriAuthToString hst)- ; dorequest2 hst c rqst- }- ; - ; return rsp- }-- dorequest2 hst c r =- do { dbg <- getBS bsDebug- ; ioAction $ case dbg of- Nothing -> sendHTTP c r- Just f ->- debugStream (f++'-': uriAuthToString hst) c - >>= \c' -> sendHTTP c' r - }- ---uriAuth x = case uriAuthority x of- Just ua -> ua- _ -> error ("No uri authority for: "++show x)--uriAuthToString :: URIAuth -> String-uriAuthToString URIAuth { uriUserInfo = uinfo- , uriRegName = regname- , uriPort = port- } =- ((if null uinfo then id else (uinfo++))- . (regname++)- . (port++)) ""---- This function duplicates old Network.URI.authority behaviour.-uriToAuthorityString :: URI -> String-uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u)----------------------------------------------------------------------------------------- Request Building ----------------------------------------------------------------------------------------------------libUA = "haskell-libwww/0.1"--defaultGETRequest :: URI -> Request-defaultGETRequest uri = - Request { rqURI=uri- , rqBody=""- , rqHeaders=[ Header HdrContentLength "0"- , Header HdrUserAgent libUA- ]- , rqMethod=GET- }------ This form junk is completely untested...--type FormVar = (String,String)--data Form = Form RequestMethod URI [FormVar]---formToRequest :: Form -> Request-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- }+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-}+{- |++Module : Network.Browser+Copyright : See LICENSE file+License : BSD++Maintainer : Ganesh Sittampalam <ganesh@earth.li>+Stability : experimental+Portability : non-portable (not tested)++Session-level interactions over HTTP.++The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in+providing support for more involved, and real, request/response interactions over+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+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,13,0))+import Control.Monad.Fail+#endif++import Data.Char (toLower)+import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe, listToMaybe, catMaybes )+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+#endif+import Control.Monad (filterM, forM_, when)+import Control.Monad.IO.Class+ ( MonadIO (..) )+import Control.Monad.State+ ( MonadState(..), gets, modify, StateT (..), evalStateT, withStateT )++import qualified System.IO+ ( hSetBuffering, hPutStr, stdout, stdin, hGetChar+ , BufferMode(NoBuffering, LineBuffering)+ )+import 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@, revert 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 }+ deriving+ ( Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)+#if MIN_VERSION_base(4,9,0)+ , MonadFail+#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 maximum number of forwarding hops+-- we are willing to jump through. A no-op if the count is negative; if zero,+-- the max is set to whatever default applies. Notice that setting the max+-- redirects count does /not/ enable following of redirects itself; use+-- 'setAllowRedirects' to do so.+setMaxRedirects :: Maybe Int -> BrowserAction t ()+setMaxRedirects c+ | 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+-- compatibility quirks. This version is available via 'httpPackageVersion'.+-- For more info see <http://en.wikipedia.org/wiki/User_agent>.+--+setUserAgent :: String -> BrowserAction t ()+setUserAgent ua = 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+ Prelude.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)+
+ Network/BufferType.hs view
@@ -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 <ganesh@earth.li>+-- 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+ }+
Network/HTTP.hs view
@@ -1,1052 +1,265 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005--- License : BSD--- --- Maintainer : bjorn@bringert.net--- Stability : experimental--- Portability : non-portable (not tested)------ An easy HTTP interface enjoy.------ * Changes by Simon Foster:--- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules--- - Created functions receiveHTTP and responseHTTP to allow server side interactions--- (although 100-continue is unsupported and I haven't checked for standard compliancy).--- - Pulled the transfer functions from sendHTTP to global scope to allow access by--- above functions.------ * Changes by Graham Klyne:--- - export httpVersion--- - use new URI module (similar to old, but uses revised URI datatype)------ * Changes by Bjorn Bringert:------ - handle URIs with a port number--- - added debugging toggle--- - disabled 100-continue transfers to get HTTP\/1.0 compatibility--- - change 'ioError' to 'throw'--- - Added simpleHTTP_, which takes a stream argument.------ * Changes from 0.1--- - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class.--- - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses.--- - reworking of the use of Stream, including alterations to make 'sendHTTP' generic--- and the addition of a debugging stream.--- - simplified error handling.--- --- * 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).----------------------------------------------------------------------------------module Network.HTTP (- module Network.Stream,- module Network.TCP,-- -- ** Constants- httpVersion,- - -- ** HTTP - Request(..),- Response(..),- RequestMethod(..),- simpleHTTP, simpleHTTP_,- sendHTTP,- receiveHTTP,- respondHTTP,-- -- ** Header Functions- HasHeaders,- Header(..),- HeaderName(..),- insertHeader,- insertHeaderIfMissing,- insertHeaders,- retrieveHeaders,- replaceHeader,- findHeader,-- -- ** URL Encoding- urlEncode,- urlDecode,- urlEncodeVars,-- -- ** URI authority parsing- URIAuthority(..),- parseURIAuthority-) where---------------------------------------------------------------------------------------- Imports ----------------------------------------------------------------------------------------------------------import Control.Exception as Exception---- Networking-import Network (withSocketsDo)-import Network.BSD-import Network.URI-import Network.Socket-import Network.Stream-import Network.TCP----- Util-import Data.Bits ((.&.))-import Data.Char-import Data.List (isPrefixOf,partition,elemIndex)-import Data.Maybe-import Data.Array.MArray-import Data.IORef-import Control.Concurrent-import Control.Monad (when,liftM,guard)-import Control.Monad.ST (ST,stToIO)-import Numeric (readHex)-import Text.ParserCombinators.ReadP-import Text.Read.Lex -import System.IO-import System.IO.Error (isEOFError)-import qualified System.IO.Error--import Foreign.C.Error----- 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 --------------------------------------------------------------------------------------------------------------- remove leading and trailing whitespace.-trim :: String -> String-trim = let dropspace = dropWhile isSpace in- reverse . dropspace . reverse . dropspace----- Split a list into two parts, the delimiter occurs--- at the head of the second list. Nothing is returned--- when no occurance of the delimiter is found.-split :: Eq a => a -> [a] -> Maybe ([a],[a])-split delim list = case delim `elemIndex` list of- Nothing -> Nothing- Just x -> Just $ splitAt x list- ---crlf = "\r\n"-sp = " "-------------------------------------------------------------------------------------- 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:--- >--- > //<user>:<password>@<host>:<port>/<url-path>--- > Some or all of the parts "<user>:<password>@", ":<password>",--- > ":<port>", and "/<url-path>" 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 <- munch (/=':')- p <- orNothing (char ':' >> readDecP)- look >>= guard . null - return URIAuthority{ user=u, password=pw, host=h, port=p }--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-------------------------------------------------------------------------------------- Header Data --------------------------------------------------------------------------------------------------------- | The Header data type pairs header names & values.-data Header = Header HeaderName String---instance Show Header where- show (Header key value) = show key ++ ": " ++ value ++ crlf----- | HTTP Header Name type:--- Why include this at all? I have some reasons--- 1) prevent spelling errors of header names,--- 2) remind everyone of what headers are available,--- 3) might speed up searches for specific headers.------ Arguments against:--- 1) makes customising header names laborious--- 2) increases code volume.----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- | 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)----- Translation between header names and values,--- good candidate for improvement.-headerMap :: [ (String,HeaderName) ]-headerMap - = [ ("Cache-Control" ,HdrCacheControl )- , ("Connection" ,HdrConnection )- , ("Date" ,HdrDate ) - , ("Pragma" ,HdrPragma )- , ("Transfer-Encoding" ,HdrTransferEncoding ) - , ("Upgrade" ,HdrUpgrade ) - , ("Via" ,HdrVia )- , ("Accept" ,HdrAccept )- , ("Accept-Charset" ,HdrAcceptCharset )- , ("Accept-Encoding" ,HdrAcceptEncoding )- , ("Accept-Language" ,HdrAcceptLanguage )- , ("Authorization" ,HdrAuthorization )- , ("From" ,HdrFrom )- , ("Host" ,HdrHost )- , ("If-Modified-Since" ,HdrIfModifiedSince )- , ("If-Match" ,HdrIfMatch )- , ("If-None-Match" ,HdrIfNoneMatch )- , ("If-Range" ,HdrIfRange ) - , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince )- , ("Max-Forwards" ,HdrMaxForwards )- , ("Proxy-Authorization" ,HdrProxyAuthorization)- , ("Range" ,HdrRange ) - , ("Referer" ,HdrReferer )- , ("User-Agent" ,HdrUserAgent )- , ("Age" ,HdrAge )- , ("Location" ,HdrLocation )- , ("Proxy-Authenticate" ,HdrProxyAuthenticate )- , ("Public" ,HdrPublic )- , ("Retry-After" ,HdrRetryAfter )- , ("Server" ,HdrServer )- , ("Vary" ,HdrVary )- , ("Warning" ,HdrWarning )- , ("WWW-Authenticate" ,HdrWWWAuthenticate )- , ("Allow" ,HdrAllow )- , ("Content-Base" ,HdrContentBase )- , ("Content-Encoding" ,HdrContentEncoding )- , ("Content-Language" ,HdrContentLanguage )- , ("Content-Length" ,HdrContentLength )- , ("Content-Location" ,HdrContentLocation )- , ("Content-MD5" ,HdrContentMD5 )- , ("Content-Range" ,HdrContentRange )- , ("Content-Type" ,HdrContentType )- , ("ETag" ,HdrETag )- , ("Expires" ,HdrExpires )- , ("Last-Modified" ,HdrLastModified )- , ("Set-Cookie" ,HdrSetCookie )- , ("Cookie" ,HdrCookie )- , ("Expect" ,HdrExpect ) ]---instance Show HeaderName where- show (HdrCustom s) = s- show x = case filter ((==x).snd) headerMap of- [] -> error "headerMap incomplete"- (h:_) -> fst h-------- | This class allows us to write generic header manipulation functions--- for both 'Request' and 'Response' data types.-class HasHeaders x where- getHeaders :: x -> [Header]- setHeaders :: x -> [Header] -> x------ Header manipulation functions-insertHeader, replaceHeader, insertHeaderIfMissing- :: HasHeaders a => HeaderName -> String -> a -> a----- | Inserts a header with the given name and value.--- Allows duplicate header names.-insertHeader name value x = setHeaders x newHeaders- where- newHeaders = (Header name value) : getHeaders x----- | Adds the new header only if no previous header shares--- the same name.-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]-- ---- | Removes old headers with duplicate name.-replaceHeader name value x = setHeaders x newHeaders- where- newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]- ---- | Inserts multiple headers.-insertHeaders :: HasHeaders a => [Header] -> a -> a-insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)----- | Gets a list of headers with a particular 'HeaderName'.-retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]-retrieveHeaders name x = filter matchname (getHeaders x)- where- matchname (Header n _) | n == name = True- matchname _ = False----- | Lookup presence of specific HeaderName in a list of Headers--- Returns the value from the first matching header.-findHeader :: HasHeaders a => HeaderName -> a -> Maybe String-findHeader n x = lookupHeader n (getHeaders x)---- An anomally really:-lookupHeader :: HeaderName -> [Header] -> Maybe String-lookupHeader v (Header n s:t) | v == n = Just s- | otherwise = lookupHeader v t-lookupHeader _ _ = Nothing-----{--instance HasHeaders [Header]-...requires -fglasgow-exts, and is not really necessary anyway...--}---------------------------------------------------------------------------------------- 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 | OPTIONS | TRACE- deriving(Show,Eq)--rqMethodMap = [("HEAD", HEAD),- ("PUT", PUT),- ("GET", GET),- ("POST", POST),- ("OPTIONS", OPTIONS),- ("TRACE", TRACE)]---- | An HTTP Request.--- The 'Show' instance of this type is used for message serialisation,--- which means no body data is output.-data Request =- 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 :: String- }------- 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 where- show (Request u m h _) =- show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf- ++ foldr (++) [] (map show h) ++ crlf- where- alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' - then u { uriPath = '/' : uriPath u } - else u---instance HasHeaders Request where- getHeaders = rqHeaders- setHeaders rq hdrs = rq { rqHeaders=hdrs }-------type ResponseCode = (Int,Int,Int)-type ResponseData = (ResponseCode,String,[Header])-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 =- Response { rspCode :: ResponseCode- , rspReason :: String- , rspHeaders :: [Header]- , rspBody :: String- }- ----- 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 where- show (Response (a,b,c) reason headers _) =- httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf- ++ foldr (++) [] (map show headers) ++ crlf----instance HasHeaders Response where- getHeaders = rspHeaders- setHeaders rsp hdrs = rsp { rspHeaders=hdrs }-------------------------------------------------------------------------------------- Parsing ----------------------------------------------------------------------------------------------------------parseHeader :: String -> Result Header-parseHeader str =- case split ':' str of- Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)- Just (k,v) -> Right $ 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 :: [String] -> Result [Header]-parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended ""- where- -- Joins consecutive lines where the second line- -- begins with ' ' or '\t'.- joinExtended old (h : t)- | not (null h) && (head h == ' ' || head h == '\t')- = joinExtended (old ++ ' ' : tail h) t- | otherwise = old : joinExtended h t- joinExtended old [] = [old]-- clean [] = []- clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t- | otherwise = h : clean t-- -- tollerant 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 - ---- Parsing a request-parseRequestHead :: [String] -> Result RequestData-parseRequestHead [] = Left ErrorClosed-parseRequestHead (com:hdrs) =- requestCommand com `bindE` \(version,rqm,uri) ->- parseHeaders hdrs `bindE` \hdrs' ->- Right (rqm,uri,hdrs')- where- requestCommand line- = case words line of- yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of- (Just u, Just r) -> Right (version,r,u)- _ -> Left (ErrorParse $ "Request command line parse failure: " ++ line)- no -> if null line- then Left ErrorClosed- else Left (ErrorParse $ "Request command line parse failure: " ++ line) ---- Parsing a response-parseResponseHead :: [String] -> Result ResponseData-parseResponseHead [] = Left ErrorClosed-parseResponseHead (sts:hdrs) = - responseStatus sts `bindE` \(version,code,reason) ->- parseHeaders hdrs `bindE` \hdrs' ->- Right (code,reason,hdrs')- where-- responseStatus line- = case words line of- yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason)- no -> if null line - then Left ErrorClosed -- an assumption- else Left (ErrorParse $ "Response status line parse failure: " ++ line)--- match [a,b,c] = (digitToInt a,- digitToInt b,- digitToInt c)- match _ = (-1,-1,-1) -- will create appropriate behaviour--- -------------------------------------------------------------------------------------- HTTP Send / Recv ------------------------------------------------------------------------------------------------------data Behaviour = Continue- | Retry- | Done- | ExpectEntity- | DieHorribly String------matchResponse :: RequestMethod -> ResponseCode -> Behaviour-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- ---- | Simple way to get a resource across a non-persistant connection.--- Headers that may be altered:--- Host Altered only if no Host header is supplied, HTTP\/1.1--- requires a Host header.--- Connection Where no allowance is made for persistant connections--- the Connection header will be set to "close"-simpleHTTP :: Request -> IO (Result Response)-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 -> IO (Result Response)-simpleHTTP_ s r =- do - auth <- getAuth r- let r' = fixReq auth r - rsp <- if debug then do- s' <- debugStream httpLogFile s- sendHTTP s' r'- else- sendHTTP s r'- -- already done by sendHTTP because of "Connection: close" header- --; close s - return rsp- where- {- 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.- fixReq :: URIAuthority -> Request -> Request- fixReq URIAuthority{host=h} r = - replaceHeader HdrConnection "close" $- insertHeaderIfMissing HdrHost h $- r { rqURI = (rqURI r){ uriScheme = "", - uriAuthority = Nothing } } --getAuth :: Monad m => Request -> m URIAuthority-getAuth r = case parseURIAuthority auth of- Just x -> return x - Nothing -> fail $ "Error parsing URI authority '"- ++ auth ++ "'"- where auth = case findHeader HdrHost r of- Just h -> h- Nothing -> uriToAuthorityString (rqURI r)--sendHTTP :: Stream s => s -> Request -> IO (Result Response)-sendHTTP conn rq = - do { let a_rq = fixHostHeader rq- ; rsp <- Exception.catch (main a_rq)- (\e -> do { close conn; throw e })- ; let fn list = when (or $ map findConnClose list)- (close conn)- ; either (\_ -> fn [rqHeaders rq])- (\r -> fn [rqHeaders rq,rspHeaders r])- rsp- ; return rsp- }- where --- 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.- main :: Request -> IO (Result Response)- main rqst =- do - --let str = if null (rqBody rqst)- -- then show rqst- -- else show (insertHeader HdrExpect "100-continue" rqst)- writeBlock conn (show rqst)- -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rqBody rqst)- rsp <- getResponseHead - switchResponse True False rsp rqst- - -- reads and parses headers- getResponseHead :: IO (Result ResponseData)- getResponseHead =- do { lor <- readTillEmpty1 conn- ; return $ lor `bindE` parseResponseHead- }-- -- Hmmm, this could go bad if we keep getting "100 Continue"- -- responses... Except this should never happen according- -- to the RFC.- switchResponse :: Bool {- allow retry? -}- -> Bool {- is body sent? -}- -> Result ResponseData- -> Request- -> IO (Result Response)- - 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 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- ; switchResponse allow_retry True rsp rqst- }- }- | otherwise -> {- keep waiting -}- do { rsp <- getResponseHead- ; switchResponse allow_retry bdy_sent rsp rqst - }-- Retry -> {- Request with "Expect" header failed.- Trouble is the request contains Expects- other than "100-Continue" -}- do { writeBlock conn (show rqst ++ rqBody rqst)- ; rsp <- getResponseHead- ; switchResponse False bdy_sent rsp rqst- } - - Done ->- return (Right $ Response cd rn hdrs "")-- DieHorribly str ->- return $ Left $ ErrorParse ("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 conn (read x :: Int)- Nothing -> hopefulTransfer conn ""- Just x -> - case map toLower (trim x) of- "chunked" -> chunkedTransfer conn- _ -> uglyDeathTransfer conn- ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) - }-- - -- Adds a Host header if one is NOT ALREADY PRESENT- fixHostHeader :: Request -> Request- fixHostHeader rq =- let uri = rqURI rq- host = uriToAuthorityString uri- in insertHeaderIfMissing HdrHost host rq- - -- Looks for a "Connection" header with the value "close".- -- Returns True when this is found.- findConnClose :: [Header] -> Bool- findConnClose hdrs =- case lookupHeader HdrConnection hdrs of- Nothing -> False- Just x -> map toLower (trim x) == "close"---- This function duplicates old Network.URI.authority behaviour.-uriToAuthorityString :: URI -> String-uriToAuthorityString URI{uriAuthority=Nothing} = ""-uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua ++- uriRegName ua ++- uriPort ua---- | Receive and parse a HTTP request from the given Stream. Should be used --- for server side interactions.-receiveHTTP :: Stream s => s -> IO (Result Request)-receiveHTTP conn = do rq <- getRequestHead- processRequest rq - where- -- reads and parses headers- getRequestHead :: IO (Result RequestData)- getRequestHead =- do { lor <- readTillEmpty1 conn- ; return $ lor `bindE` 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 conn (read x :: Int)- Nothing -> return (Right ([], "")) -- hopefulTransfer ""- Just x ->- case map toLower (trim x) of- "chunked" -> chunkedTransfer conn- _ -> uglyDeathTransfer conn- - return $ rslt `bindE` \(ftrs,bdy) -> Right (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 -> IO ()-respondHTTP conn rsp = do writeBlock conn (show rsp)- -- write body immediately, don't wait for 100 CONTINUE- writeBlock conn (rspBody rsp)- return ()---- The following functions were in the where clause of sendHTTP, they have--- been moved to global scope so other functions can access them. ---- | Used when we know exactly how many bytes to expect.-linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))-linearTransfer conn n- = do info <- readBlock conn n- return $ info `bindE` \str -> Right ([],str)---- | 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 :: Stream s => s -> String -> IO (Result ([Header],String))-hopefulTransfer conn str- = readLine conn >>= - either (\v -> return $ Left v)- (\more -> if null more - then return (Right ([],str)) - else hopefulTransfer conn (str++more))--- | A necessary feature of HTTP\/1.1--- Also the only transfer variety likely to--- return any footers.-chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))-chunkedTransfer conn- = chunkedTransferC conn 0 >>= \v ->- return $ v `bindE` \(ftrs,count,info) ->- let myftrs = Header HdrContentLength (show count) : ftrs - in Right (myftrs,info)--chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))-chunkedTransferC conn n- = readLine conn >>= \v -> case v of- Left e -> return (Left e)- Right line ->- let size = ( if null line || (head line) == '0'- then 0- else case readHex line of- (n,_):_ -> n- _ -> 0- )- in if size == 0- then do { rs <- readTillEmpty2 conn []- ; return $- rs `bindE` \strs ->- parseHeaders strs `bindE` \ftrs ->- Right (ftrs,n,"")- }- else do { some <- readBlock conn size- ; readLine conn- ; more <- chunkedTransferC conn (n+size)- ; return $ - some `bindE` \cdata ->- more `bindE` \(ftrs,m,mdata) -> - Right (ftrs,m,cdata++mdata) - } ---- | Maybe in the future we will have a sensible thing--- to do here, at that time we might want to change--- the name.-uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))-uglyDeathTransfer conn- = return $ Left $ ErrorParse "Unknown Transfer-Encoding"---- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)-readTillEmpty1 :: Stream s => s -> IO (Result [String])-readTillEmpty1 conn =- do { line <- readLine conn- ; case line of- Left e -> return $ Left e- Right s ->- if s == crlf- then readTillEmpty1 conn- else readTillEmpty2 conn [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 :: Stream s => s -> [String] -> IO (Result [String])-readTillEmpty2 conn list =- do { line <- readLine conn- ; case line of- Left e -> return $ Left e- Right s ->- if s == crlf || null s- then return (Right $ reverse (s:list))- else readTillEmpty2 conn (s:list)- }-- ------------------------------------------------------------------------------------- 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: <US-ASCII coded characters 00-1F and 7F hexadecimal>- <US-ASCII coded character 20 hexadecimal>- Also unallowed: any non-us-ascii character-- Escape method: char -> '%' a b where a, b :: Hex digits--}--urlEncode, urlDecode :: String -> String--urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)- : urlDecode rest-urlDecode (h:t) = h : urlDecode t-urlDecode [] = []--urlEncode (h:t) =- let str = if reserved (ord h) then escape h else [h]- in str ++ urlEncode t- where- reserved x- | x >= ord 'a' && x <= ord 'z' = False- | x >= ord 'A' && x <= ord 'Z' = False- | x >= ord '0' && x <= ord '9' = False- | x <= 0x20 || x >= 0x7F = True- | otherwise = x `elem` map ord [';','/','?',':','@','&'- ,'=','+',',','$','{','}'- ,'|','\\','^','[',']','`'- ,'<','>','#','%','"']- -- wouldn't it be nice if the compiler- -- optimised the above for us?-- escape x = - let y = ord x - in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]--urlEncode [] = []- ----- 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 [] = []+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- 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)++-- | @getResponseCode response@ takes the response of a HTTP requesting action and+-- tries to extricate the status code of the 'Response' @response@. If the request action+-- returned an error, an IO exception is raised.+getResponseCode :: Result (Response ty) -> IO ResponseCode+getResponseCode (Left err) = fail (show err)+getResponseCode (Right r) = return (rspCode r)+++--+-- * TODO+-- - request pipelining+-- - 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).
+ Network/HTTP/Auth.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Auth+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Representing HTTP Auth values in Haskell.+-- Right now, it contains mostly functionality needed by 'Network.Browser'.+--+-----------------------------------------------------------------------------+module Network.HTTP.Auth+ ( Authority(..)+ , 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==':'))
+ Network/HTTP/Base.hs view
@@ -0,0 +1,1002 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Base+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- 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 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:+-- >+-- > //<user>:<password>@<host>:<port>/<url-path>+-- > Some or all of the parts "<user>:<password>@", ":<password>",+-- > ":<port>", and "/<url-path>" 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++#if MIN_VERSION_base(4,13,0)+failHTTPS :: MonadFail m => URI -> m ()+#else+failHTTPS :: Monad m => URI -> m ()+#endif+failHTTPS uri+ | map toLower (uriScheme uri) == "https:" = fail "https not supported"+ | otherwise = return ()++-- Fish out the authority from a possibly normalized Request, i.e.,+-- the information may either be in the request's URI or inside+-- the Host: header.+reqURIAuth :: Request ty -> URIAuth+reqURIAuth req =+ 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 auxiliary/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: <US-ASCII coded characters 00-1F and 7F hexadecimal>+ <US-ASCII coded character 20 hexadecimal>+ 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.+#if MIN_VERSION_base(4,13,0)+getAuth :: MonadFail m => Request ty -> m URIAuthority+#else+getAuth :: Monad m => Request ty -> m URIAuthority+#endif+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))
Network/HTTP/Base64.hs view
@@ -8,19 +8,18 @@ -- Stability : experimental -- Portability : portable ----- Base64 encoding and decoding functions provided by Warwick Gray. --- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- Base64 encoding and decoding functions provided by Warwick Gray.+-- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> -- and <http://www.faqs.org/rfcs/rfc2045.html>. -- ----------------------------------------------------------------------------- -module Network.HTTP.Base64 (- encode,- decode,- chop72-) where--+module Network.HTTP.Base64+ ( encode+ , decode+ , chop72+ , Octet+ ) where {------------------------------------------------------------------------ This is what RFC2045 had to say:@@ -135,10 +134,8 @@ delimiters within base64-encoded bodies within multipart entities because no hyphen characters are used in the base64 encoding. - ----------------------------------------------------------------------------} - {- The following properties should hold:@@ -151,26 +148,22 @@ MIME applications might be undesireable. --But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only - 8 significant bits, which is more than enough for US-ASCII. +But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only+ 8 significant bits, which is more than enough for US-ASCII. -} ---import Data.Array-import Data.Bits-import Data.Int-import Data.Char (chr,ord)+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') +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')@@ -184,11 +177,11 @@ -- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) -- clearly the upmost/leftmost 8 bits of the answer are 0.--- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- Hack Alert: In the last entry of the answer, the upper 8 bits encode -- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. -- 0 represents a 4 :( int4_char3 :: [Int] -> [Char]-int4_char3 (a:b:c:d:t) = +int4_char3 (a:b:c:d:t) = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) in (chr (n `shiftR` 16 .&. 0xff)) : (chr (n `shiftR` 8 .&. 0xff))@@ -199,22 +192,24 @@ in [ (chr (n `shiftR` 16 .&. 0xff)) , (chr (n `shiftR` 8 .&. 0xff)) ] -int4_char3 [a,b] = +int4_char3 [a,b] = let n = (a `shiftL` 18 .|. b `shiftL` 12) in [ (chr (n `shiftR` 16 .&. 0xff)) ] -int4_char3 [] = [] +int4_char3 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints." +int4_char3 [] = [] + -- Convert triplets of characters to -- 4 base64 integers. The last entries -- in the list may not produce 4 integers, -- a trailing 2 character group gives 3 integers, -- while a trailing single character gives 2 integers. char3_int4 :: [Char] -> [Int]-char3_int4 (a:b:c:t) +char3_int4 (a:b:c:t) = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t @@ -223,7 +218,7 @@ in [ (n `shiftR` 18 .&. 0x3f) , (n `shiftR` 12 .&. 0x3f) , (n `shiftR` 6 .&. 0x3f) ]- + char3_int4 [a] = let n = (ord a `shiftL` 16) in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]@@ -245,9 +240,11 @@ -- 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 @@ -255,6 +252,7 @@ enc = quadruplets . map enc1 +dcd :: String -> [Int] dcd [] = [] dcd (h:t) | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t
+ Network/HTTP/Cookie.hs view
@@ -0,0 +1,141 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Cookie+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- This module provides the data types and functions for working with HTTP cookies.+-- Right now, it contains mostly functionality needed by 'Network.Browser'.+--+-----------------------------------------------------------------------------+module Network.HTTP.Cookie+ ( Cookie(..)+ , cookieMatch -- :: (String,String) -> Cookie -> Bool++ -- functions for translating cookies and headers.+ , 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==':'))
+ Network/HTTP/HandleStream.hs view
@@ -0,0 +1,252 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.HandleStream+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- 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+
+ Network/HTTP/Headers.hs view
@@ -0,0 +1,461 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Headers+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- 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.++instance Eq HeaderName where+ HdrCustom a == HdrCustom b = (fmap toLower a) == (fmap toLower b)+ HdrCacheControl == HdrCacheControl = True+ HdrCacheControl == _ = False+ _ == HdrCacheControl = False+ HdrConnection == HdrConnection = True+ HdrConnection == _ = False+ _ == HdrConnection = False+ HdrDate == HdrDate = True+ HdrDate == _ = False+ _ == HdrDate = False+ HdrPragma == HdrPragma = True+ HdrPragma == _ = False+ _ == HdrPragma = False+ HdrTransferEncoding == HdrTransferEncoding = True+ HdrTransferEncoding == _ = False+ _ == HdrTransferEncoding = False+ HdrUpgrade == HdrUpgrade = True+ HdrUpgrade == _ = False+ _ == HdrUpgrade = False+ HdrVia == HdrVia = True+ HdrVia == _ = False+ _ == HdrVia = False+ HdrAccept == HdrAccept = True+ HdrAccept == _ = False+ _ == HdrAccept = False+ HdrAcceptCharset == HdrAcceptCharset = True+ HdrAcceptCharset == _ = False+ _ == HdrAcceptCharset = False+ HdrAcceptEncoding == HdrAcceptEncoding = True+ HdrAcceptEncoding == _ = False+ _ == HdrAcceptEncoding = False+ HdrAcceptLanguage == HdrAcceptLanguage = True+ HdrAcceptLanguage == _ = False+ _ == HdrAcceptLanguage = False+ HdrAuthorization == HdrAuthorization = True+ HdrAuthorization == _ = False+ _ == HdrAuthorization = False+ HdrCookie == HdrCookie = True+ HdrCookie == _ = False+ _ == HdrCookie = False+ HdrExpect == HdrExpect = True+ HdrExpect == _ = False+ _ == HdrExpect = False+ HdrFrom == HdrFrom = True+ HdrFrom == _ = False+ _ == HdrFrom = False+ HdrHost == HdrHost = True+ HdrHost == _ = False+ _ == HdrHost = False+ HdrIfModifiedSince == HdrIfModifiedSince = True+ HdrIfModifiedSince == _ = False+ _ == HdrIfModifiedSince = False+ HdrIfMatch == HdrIfMatch = True+ HdrIfMatch == _ = False+ _ == HdrIfMatch = False+ HdrIfNoneMatch == HdrIfNoneMatch = True+ HdrIfNoneMatch == _ = False+ _ == HdrIfNoneMatch = False+ HdrIfRange == HdrIfRange = True+ HdrIfRange == _ = False+ _ == HdrIfRange = False+ HdrIfUnmodifiedSince == HdrIfUnmodifiedSince = True+ HdrIfUnmodifiedSince == _ = False+ _ == HdrIfUnmodifiedSince = False+ HdrMaxForwards == HdrMaxForwards = True+ HdrMaxForwards == _ = False+ _ == HdrMaxForwards = False+ HdrProxyAuthorization == HdrProxyAuthorization = True+ HdrProxyAuthorization == _ = False+ _ == HdrProxyAuthorization = False+ HdrRange == HdrRange = True+ HdrRange == _ = False+ _ == HdrRange = False+ HdrReferer == HdrReferer = True+ HdrReferer == _ = False+ _ == HdrReferer = False+ HdrUserAgent == HdrUserAgent = True+ HdrUserAgent == _ = False+ _ == HdrUserAgent = False+ HdrAge == HdrAge = True+ HdrAge == _ = False+ _ == HdrAge = False+ HdrLocation == HdrLocation = True+ HdrLocation == _ = False+ _ == HdrLocation = False+ HdrProxyAuthenticate == HdrProxyAuthenticate = True+ HdrProxyAuthenticate == _ = False+ _ == HdrProxyAuthenticate = False+ HdrPublic == HdrPublic = True+ HdrPublic == _ = False+ _ == HdrPublic = False+ HdrRetryAfter == HdrRetryAfter = True+ HdrRetryAfter == _ = False+ _ == HdrRetryAfter = False+ HdrServer == HdrServer = True+ HdrServer == _ = False+ _ == HdrServer = False+ HdrSetCookie == HdrSetCookie = True+ HdrSetCookie == _ = False+ _ == HdrSetCookie = False+ HdrTE == HdrTE = True+ HdrTE == _ = False+ _ == HdrTE = False+ HdrTrailer == HdrTrailer = True+ HdrTrailer == _ = False+ _ == HdrTrailer = False+ HdrVary == HdrVary = True+ HdrVary == _ = False+ _ == HdrVary = False+ HdrWarning == HdrWarning = True+ HdrWarning == _ = False+ _ == HdrWarning = False+ HdrWWWAuthenticate == HdrWWWAuthenticate = True+ HdrWWWAuthenticate == _ = False+ _ == HdrWWWAuthenticate = False+ HdrAllow == HdrAllow = True+ HdrAllow == _ = False+ _ == HdrAllow = False+ HdrContentBase == HdrContentBase = True+ HdrContentBase == _ = False+ _ == HdrContentBase = False+ HdrContentEncoding == HdrContentEncoding = True+ HdrContentEncoding == _ = False+ _ == HdrContentEncoding = False+ HdrContentLanguage == HdrContentLanguage = True+ HdrContentLanguage == _ = False+ _ == HdrContentLanguage = False+ HdrContentLength == HdrContentLength = True+ HdrContentLength == _ = False+ _ == HdrContentLength = False+ HdrContentLocation == HdrContentLocation = True+ HdrContentLocation == _ = False+ _ == HdrContentLocation = False+ HdrContentMD5 == HdrContentMD5 = True+ HdrContentMD5 == _ = False+ _ == HdrContentMD5 = False+ HdrContentRange == HdrContentRange = True+ HdrContentRange == _ = False+ _ == HdrContentRange = False+ HdrContentType == HdrContentType = True+ HdrContentType == _ = False+ _ == HdrContentType = False+ HdrETag == HdrETag = True+ HdrETag == _ = False+ _ == HdrETag = False+ HdrExpires == HdrExpires = True+ HdrExpires == _ = False+ _ == HdrExpires = False+ HdrLastModified == HdrLastModified = True+ HdrLastModified == _ = False+ _ == HdrLastModified = False+ HdrContentTransferEncoding == HdrContentTransferEncoding = True+ HdrContentTransferEncoding == _ = False+ _ == HdrContentTransferEncoding = False++-- | @headerMap@ is a straight assoc list for translating between header names+-- and values.+headerMap :: [ (String,HeaderName) ]+headerMap =+ [ 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
− Network/HTTP/MD5.hs
@@ -1,44 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Digest.MD5--- Copyright : (c) Dominic Steinitz 2004--- License : BSD-style (see the file ReadMe.tex)--- --- Maintainer : dominic.steinitz@blueyonder.co.uk--- Stability : experimental--- Portability : portable------ Takes the MD5 module supplied by Ian Lynagh and wraps it so it--- takes [Octet] and returns [Octet] where the length of the result--- is always 16.--- See <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>--- and <http://www.ietf.org/rfc/rfc1321.txt>.-----------------------------------------------------------------------------------module Network.HTTP.MD5 (- -- * Function Types- hash) where--import Data.Char(chr)-import Data.List(unfoldr)-import Numeric(readHex)--import Network.HTTP.MD5Aux-import Data.Word (Word8)--type Octet = Word8---- | Take [Octet] and return [Octet] according to the standard.--- The length of the result is always 16 octets or 128 bits as required--- by the standard.--hash :: [Octet] -> [Octet]-hash xs = - unfoldr f $ md5s $ Str $ map (chr . fromIntegral) xs- where f :: String -> Maybe (Octet,String)- f [] = - Nothing- f (x:y:zs) = - Just (fromIntegral a,zs)- where [(a,_)] = readHex (x:y:[])
Network/HTTP/MD5Aux.hs view
@@ -1,31 +1,15 @@-module Network.HTTP.MD5Aux +module Network.HTTP.MD5Aux (md5, md5s, md5i,- MD5(..), ABCD(..), + MD5(..), ABCD(..), Zord64, Str(..), BoolList(..), WordList(..)) where -import Data.Char-import Data.Bits-import Data.Word--{--Nasty kludge to create a type Zord64 which is really a Word64 but works-how we want in hugs ands nhc98 too...-Also need a rotate left function that actually works.--#ifdef __GLASGOW_HASKELL__-#define rotL rotateL-#include "Zord64_EASY.hs"-#else--> import Zord64_HARD- -> rotL :: Word32 -> Rotation -> Word32-> rotL a s = shiftL a s .|. shiftL a (s-32)--#endif--}+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 ========================@@ -36,7 +20,7 @@ newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) newtype Str = Str String newtype BoolList = BoolList [Bool]-newtype WordList = WordList ([Word32], Zord64)+newtype WordList = WordList ([Word32], Word64) -- Anything we want to work out the MD5 of must be an instance of class MD5 @@ -45,7 +29,7 @@ -- \ \ \------ the rest of the input -- \ \--------- the number of bits returned -- \--------------- the bits returned in 32bit words- len_pad :: Zord64 -> a -> a -- append the padding and length+ len_pad :: Word64 -> a -> a -- append the padding and length finished :: a -> Bool -- Have we run out of input yet? @@ -107,7 +91,11 @@ 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 ======================== @@ -118,7 +106,7 @@ md5 m = md5_main False 0 magic_numbers m --- Returns a hex number ala the md5sum program+-- Returns a hex number à la md5sum program md5s :: (MD5 a) => a -> String md5s = abcd_to_string . md5@@ -139,7 +127,7 @@ md5_main :: (MD5 a) => Bool -- Have we added padding yet?- -> Zord64 -- The length so far mod 2^64+ -> Word64 -- The length so far mod 2^64 -> ABCD -- The initial state -> a -- The non-processed portion of the message -> ABCD -- The resulting state@@ -348,7 +336,7 @@ -- Convert the size into a list of characters used by the len_pad function -- for strings -length_to_chars :: Int -> Zord64 -> String+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
+ Network/HTTP/Proxy.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Proxy+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Handling proxy server settings and their resolution.+--+-----------------------------------------------------------------------------+module Network.HTTP.Proxy+ ( Proxy(..)+ , 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, regQueryValueEx )+import Control.Exception ( bracket )+import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca )++#if MIN_VERSION_Win32(2,8,0)+import System.Win32.Registry( regQueryDefaultValue )+#else+import System.Win32.Registry( regQueryValue )+#endif+#endif++-- | HTTP proxies (or not) are represented via 'Proxy', specifying if a+-- proxy should be used for the request (see 'Network.Browser.setProxy')+data Proxy+ = 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+#if MIN_VERSION_Win32(2,8,0)+ then fmap Just $ regQueryDefaultValue hkey "ProxyServer"+#elif MIN_VERSION_Win32(2,6,0)+ then fmap Just $ regQueryValue hkey "ProxyServer"+#else+ then fmap Just $ regQueryValue hkey (Just "ProxyServer")+#endif+ else return Nothing)+ (\_ -> return Nothing)++-- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..."+-- even though the following article indicates otherwise+-- https://support.microsoft.com/en-us/kb/819961+--+-- to be sure, parse strings where each entry in the ';'-separated list above is+-- either in the format "protocol=..." or "protocol://..."+--+-- only return the first "http" of them, if it exists+parseWindowsProxy :: String -> Maybe String+parseWindowsProxy s =+ case proxies of+ x:_ -> Just x+ _ -> Nothing+ where+ parts = split ';' s+ pr x = case break (== '=') x of+ (p, []) -> p -- might be in format http://+ (p, u) -> p ++ "://" ++ drop 1 u++ proxies = filter (isPrefixOf "http://") . map pr $ parts++ split :: Eq a => a -> [a] -> [[a]]+ split _ [] = []+ split a xs = case break (a ==) xs of+ (ys, []) -> [ys]+ (ys, _:zs) -> ys:split a zs++#endif++-- | @fetchProxy flg@ gets the local proxy settings and parse the string+-- 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
+ Network/HTTP/Stream.hs view
@@ -0,0 +1,236 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Stream+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- 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 ()
+ Network/HTTP/Utils.hs view
@@ -0,0 +1,207 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Utils+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- 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])++ , toUTF8BS+ , fromUTF8BS+ ) where++import Data.Bits+import Data.Char+import Data.List ( elemIndex )+import Data.Maybe ( fromMaybe )+import Data.Word ( Word8 )++import qualified Data.ByteString as BS++-- | @crlf@ is our beloved two-char line terminator.+crlf :: String+crlf = "\r\n"++-- | @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)++toUTF8BS :: String -> BS.ByteString+toUTF8BS = BS.pack . encodeStringUtf8++fromUTF8BS :: BS.ByteString -> String+fromUTF8BS = decodeStringUtf8 . BS.unpack++-- | Encode 'String' to a list of UTF8-encoded octets+--+-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded+-- as the replacement character (i.e. @U+FFFD@).+--+-- The code is extracted from Cabal library, written originally+-- Herbert Valerio Riedel under BSD-3-Clause license+encodeStringUtf8 :: String -> [Word8]+encodeStringUtf8 [] = []+encodeStringUtf8 (c:cs)+ | c <= '\x07F' = w8+ : encodeStringUtf8 cs+ | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 )+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 )+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD+ : encodeStringUtf8 cs+ | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 )+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | otherwise = (0xf0 .|. w8ShiftR 18 )+ : (0x80 .|. (w8ShiftR 12 .&. 0x3F))+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ where+ w8 = fromIntegral (ord c) :: Word8+ w8ShiftR :: Int -> Word8+ w8ShiftR = fromIntegral . shiftR (ord c)++-- | Decode 'String' from UTF8-encoded octets.+--+-- Invalid data in the UTF8 stream (this includes code-points @U+D800@+-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@).+--+-- See also 'encodeStringUtf8'+decodeStringUtf8 :: [Word8] -> String+decodeStringUtf8 = go+ where+ go :: [Word8] -> String+ go [] = []+ go (c : cs)+ | c <= 0x7F = chr (fromIntegral c) : go cs+ | c <= 0xBF = replacementChar : go cs+ | c <= 0xDF = twoBytes c cs+ | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF)+ | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7)+ | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3)+ | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1)+ | otherwise = replacementChar : go cs++ twoBytes :: Word8 -> [Word8] -> String+ twoBytes c0 (c1:cs')+ | c1 .&. 0xC0 == 0x80+ = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6)+ .|. fromIntegral (c1 .&. 0x3F)+ in if d >= 0x80+ then chr d : go cs'+ else replacementChar : go cs'+ twoBytes _ cs' = replacementChar : go cs'++ moreBytes :: Int -> Int -> [Word8] -> Int -> [Char]+ moreBytes 1 overlong cs' acc+ | overlong <= acc && acc <= 0x10FFFF && (acc < 0xD800 || 0xDFFF < acc)+ = chr acc : go cs'++ | otherwise+ = replacementChar : go cs'++ moreBytes byteCount overlong (cn:cs') acc+ | cn .&. 0xC0 == 0x80+ = moreBytes (byteCount-1) overlong cs'+ ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)++ moreBytes _ _ cs' _+ = replacementChar : go cs'++ replacementChar = '\xfffd'
Network/Stream.hs view
@@ -1,68 +1,71 @@ ----------------------------------------------------------------------------- -- | -- Module : Network.Stream--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- Copyright : See LICENSE file -- License : BSD ----- Maintainer : bjorn@bringert.net+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- 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 <robin@bateboerop.name>:+-- - Removed unnecessary import statements.+-- - Moved Debug code to StreamDebugger.hs+-- - Moved Socket-related code to StreamSocket.hs.+-- -- * Changes by Simon Foster:--- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules--- +-- - Split Network.HTTPmodule up into to separate+-- Network.[Stream,TCP,HTTP] modules ------------------------------------------------------------------------------module Network.Stream (- -- ** Streams- Debug,- Stream(..),- debugStream,- - -- ** Errors- ConnError(..),- Result,- handleSocketError,- bindE,- myrecv+module Network.Stream+ ( Stream(..)+ , ConnError(..)+ , Result+ , bindE+ , fmapE -) where+ , failParse -- :: String -> Result a+ , failWith -- :: ConnError -> Result a+ , failMisc -- :: String -> Result a+ ) where -import Control.Exception as Exception-import System.IO.Error+data ConnError+ = ErrorReset+ | ErrorClosed+ | ErrorParse String+ | ErrorMisc String+ deriving(Show,Eq) --- Networking-import Network (withSocketsDo)-import Network.BSD-import Network.URI-import Network.Socket+-- 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 (ErrorMisc x) -import Control.Monad (when,liftM,guard)-import System.IO+failParse :: String -> Result a+failParse x = failWith (ErrorParse x) -data ConnError = ErrorReset - | ErrorClosed- | ErrorParse String- | ErrorMisc String- deriving(Show,Eq)+failWith :: ConnError -> Result a+failWith x = Left x --- error propagating:--- we could've used a monad, but that would lead us--- into using the "-fglasgow-exts" compile flag.-bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b+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 -} ------------------------------------------------------------------------------------- Gentle Art of Socket Sucking ------------------------------------------------------------------------------------ -- | 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@@ -72,104 +75,11 @@ -- the input in any way, e.g. leave LF on line -- endings etc. Unless that is exactly the behaviour -- you want from your twisted instances ;)-class Stream x where +class Stream x where readLine :: x -> IO (Result String) readBlock :: x -> Int -> IO (Result String) writeBlock :: x -> String -> IO (Result ()) close :: x -> IO ()-------- Exception handler for socket operations-handleSocketError :: Socket -> Exception -> IO (Result a)-handleSocketError sk e =- do { se <- getSocketOption sk SoError- ; if se == 0- then throw e- else return $ if se == 10054 -- reset- then Left ErrorReset- else Left $ ErrorMisc $ show se- }-----instance Stream Socket where- readBlock sk n = (liftM Right $ fn n) `Exception.catch` (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.- readLine sk = (liftM Right $ fn "") `Exception.catch` (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)- }- - writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)- where- fn [] = return ()- fn x = send sk x >>= \i -> fn (drop i x)-- -- This slams closed the connection (which is considered rude for TCP\/IP)- close sk = shutdown sk ShutdownBoth >> sClose sk--myrecv :: Socket -> Int -> IO String-myrecv sock len =- let handler e = if isEOFError e then return [] else ioError e- in System.IO.Error.catch (recv sock len) handler---- | Allows stream logging.--- Refer to 'debugStream' below.-data Debug x = Dbg Handle x---instance (Stream x) => Stream (Debug x) where- readBlock (Dbg h c) n =- do { val <- readBlock c n- ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)- ; return val- }-- readLine (Dbg h c) =- do { val <- readLine c- ; hPutStrLn h ("readLine " ++ show val)- ; return val- }-- writeBlock (Dbg h c) str =- do { val <- writeBlock c str- ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)- ; return val- }-- close (Dbg h c) =- do { hPutStrLn h "closing..."- ; hFlush h- ; close c- ; hPutStrLn h "...closed"- ; hClose h- }----- | Wraps a stream with logging I\/O, the first--- argument is a filename which is opened in AppendMode.-debugStream :: (Stream a) => String -> a -> IO (Debug a)-debugStream file stm = - do { h <- openFile file AppendMode- ; hPutStrLn h "File opened for appending."- ; return (Dbg h stm)- }+ closeOnEnd :: x -> Bool -> IO ()+ -- ^ True => shutdown the connection when response has been read / end-of-stream+ -- has been reached.
+ Network/StreamDebugger.hs view
@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.StreamDebugger+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- 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 <robin@bateboerop.name>:+-- - 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+ }
+ Network/StreamSocket.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.StreamSocket+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+-- - 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 separate 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+ , ShutdownCmd(ShutdownBoth), SocketOption(SoError)+ )+import Network.Socket.ByteString (send, recv)+import qualified Network.Socket+ ( close )++import Network.HTTP.Base ( catchIO )+import Network.HTTP.Utils ( fromUTF8BS, toUTF8BS )+import Control.Monad (liftM)+import Control.Exception as Exception (IOException)+import System.IO.Error (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 (fmap fromUTF8BS (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+ Network.Socket.close sk+ closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here.++readBlockSocket :: Socket -> Int -> IO (Result String)+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 (toUTF8BS x) >>= \i -> fn (drop i x)+
Network/TCP.hs view
@@ -1,194 +1,439 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Network.TCP--- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- Copyright : See LICENSE file -- License : BSD ----- Maintainer : bjorn@bringert.net+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) ----- An easy access TCP library. Makes the use of TCP in Haskell much easier.--- This was originally part of Gray's\/Bringert's HTTP module.+-- Some utility functions for working with the Haskell @network@ package. Mostly+-- for internal use by the @Network.HTTP@ code. ----- * Changes by Simon Foster:--- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules--- ------------------------------------------------------------------------------module Network.TCP (- -- ** Connections- Conn(..),- Connection(..),- openTCP,- openTCPPort,- isConnectedTo-) where+module Network.TCP+ ( Connection+ , EndPoint(..)+ , openTCPPort+ , isConnectedTo -import Control.Exception as Exception+ , openTCPConnection+ , socketConnection+ , isTCPConnectedTo --- Networking-import Network (withSocketsDo)-import Network.BSD-import Network.URI+ , HandleStream+ , HStream(..)++ , StreamHooks(..)+ , nullHooks+ , setStreamHooks+ , getStreamHooks+ , hstreamToConnection++ ) where+ import Network.Socket+ ( Socket, SocketOption(KeepAlive)+ , SocketType(Stream), connect+ , shutdown, ShutdownCmd(..)+ , setSocketOption, getPeerName+ , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo+ , defaultHints, addrFamily, withSocketsDo+ , addrSocketType, addrAddress+ )+import qualified Network.Socket+ ( close )+import qualified Network.Stream as Stream+ ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) import Network.Stream+ ( ConnError(..)+ , Result+ , failWith+ , failMisc+ )+import Network.BufferType -import Data.List (isPrefixOf,partition,elemIndex)-import Data.Char-import Data.IORef-import Control.Monad (when,liftM,guard)-import System.IO+import Network.HTTP.Base ( catchIO )+import Network.Socket ( socketToHandle ) +import Data.Char ( toLower )+import Data.Word ( Word8 )+import Control.Concurrent+import Control.Exception ( IOException, bracketOnError, try )+import Control.Monad ( liftM, when )+import System.IO ( Handle, hFlush, IOMode(..), hClose )+import System.IO.Error ( isEOFError )++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 StreamIn\/Out classes, without ghc extensions.+-- 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 = ConnRef {getRef :: IORef Conn}+newtype Connection = Connection (HandleStream String) +newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} --- | The 'Conn' object allows input buffering, and maintenance of --- some admin-type data.-data Conn = MkConn { connSock :: ! Socket- , connAddr :: ! SockAddr - , connBffr :: ! String - , connHost :: String- }- | ConnClosed- deriving(Eq)+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 --- | Open a connection to port 80 on a remote host.-openTCP :: String -> IO Connection-openTCP host = openTCPPort host 80+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 --- | This function establishes a connection to a remote--- host, it uses "getHostByName" which interrogates the--- DNS system, hence may trigger a network connection.+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. ----- Add a "persistant" option? Current persistant is default.--- Use "Result" type for synchronous exception reporting?-openTCPPort :: String -> Int -> IO Connection-openTCPPort uri port = - do { s <- socket AF_INET Stream 6- ; setSocketOption s KeepAlive 1- ; host <- Exception.catch (inet_addr uri) -- handles ascii IP numbers- (\_ -> getHostByName uri >>= \host ->- case hostAddresses host of- [] -> return (error "no addresses in host entry")- (h:_) -> return h)- ; let a = SockAddrInet (toEnum port) host- ; Exception.catch (connect s a) (\e -> sClose s >> throw e)- ; v <- newIORef (MkConn s a [] uri)- ; return (ConnRef v)- }+-- 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 Stream Connection where- readBlock ref n = - readIORef (getRef ref) >>= \conn -> case conn of- ConnClosed -> return (Left ErrorClosed)- (MkConn sk addr bfr hst)- | length bfr >= n ->- do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) })- ; return (Right $ take n bfr)- }- | otherwise ->- do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })- ; more <- readBlock sk (n - length bfr)- ; return $ case more of- Left _ -> more- Right s -> (Right $ bfr ++ s)- }+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 - -- 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 =- readIORef (getRef ref) >>= \conn -> case conn of- ConnClosed -> return (Left ErrorClosed)- (MkConn sk addr bfr _)- | null bfr -> {- read in buffer -}- do { str <- myrecv sk 1000 -- DON'T use "readBlock sk 1000" !!- -- ... since that call will loop.- ; let len = length str- ; if len == 0 {- indicates a closed connection -}- then return (Right "")- else modifyIORef (getRef ref) (\c -> c { connBffr=str })- >> readLine ref -- recursion- }- | otherwise ->- case elemIndex '\n' bfr of- Nothing -> {- need recursion to finish line -}- do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })- ; more <- readLine ref -- contains extra recursion - ; return $ more `bindE` \str -> Right (bfr++str)- }- Just i -> {- end of line found -}- let (bgn,end) = splitAt i bfr in- do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) })- ; return (Right (bgn++['\n']))- }+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 - -- The 'Connection' object allows no outward buffering, + -- 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 =- readIORef (getRef ref) >>= \conn -> case conn of- ConnClosed -> return (Left ErrorClosed)- (MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk)- where- fn sk addr s- | null s = return (Right ()) -- done- | otherwise =- getSocketOption sk SoError >>= \se ->- if se == 0- then sendTo sk s addr >>= \i -> fn sk addr (drop i s)- else writeIORef (getRef ref) ConnClosed >>- if se == 10054- then return (Left ErrorReset)- else return (Left $ ErrorMisc $ show se)-+ 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 ref = - do { c <- readIORef (getRef ref)- ; closeConn c `Exception.catch` (\_ -> return ())- ; writeIORef (getRef ref) ConnClosed- }- where- -- Be kind to peer & close gracefully.- closeConn (ConnClosed) = return ()- closeConn (MkConn sk addr [] _) =- do { shutdown sk ShutdownSend- ; suck ref- ; shutdown sk ShutdownReceive- ; sClose sk- }+ close c = closeIt c null True - suck :: Connection -> IO ()- suck cn = readLine cn >>= - either (\_ -> return ()) -- catch errors & ignore- (\x -> if null x then return () else suck cn)+ -- 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)++ let+ connectAddrInfo a = bracketOnError+ (socket (addrFamily a) Stream defaultProtocol) -- acquire+ Network.Socket.close -- release+ ( \s -> do+ setSocketOption s KeepAlive 1+ connect s (addrAddress a)+ socketConnection_ fixedUri port s stashInput )++ -- try multiple addresses; return Just connected socket or Nothing+ tryAddrInfos [] = return Nothing+ tryAddrInfos (h:t) =+ let next = \(_ :: IOException) -> tryAddrInfos t+ in try (connectAddrInfo h) >>= either next (return . Just)++ case addrinfos of+ [] -> fail "openTCPConnection: getAddrInfo returned no address information"++ -- single AddrInfo; call connectAddrInfo directly so that specific+ -- exception is thrown in event of failure+ [ai] -> connectAddrInfo ai `catchIO` (\e -> fail $+ "openTCPConnection: failed to connect to "+ ++ show (addrAddress ai) ++ ": " ++ show e)++ -- multiple AddrInfos; try each until we get a connection, or run out+ ais ->+ let+ err = fail $ "openTCPConnection: failed to connect; tried addresses: "+ ++ show (fmap addrAddress ais)+ in tryAddrInfos ais >>= maybe err return++-- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'.+socketConnection :: BufferType ty+ => String+ -> 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+ Network.Socket.close 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 -> String -> IO Bool-isConnectedTo conn name =- do { v <- readIORef (getRef conn)- ; case v of- ConnClosed -> return False- (MkConn sk _ _ h) ->- if (map toLower h == map toLower name)- then sIsConnected sk- else return False- }+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
+ test/Httpd.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}++module Httpd+ ( Request, Response, Server+ , mkResponse+ , reqMethod, reqURI, reqHeaders, reqBody+ , shed+#ifdef WARP_TESTS+ , warp+#endif+ )+ where++import Control.Applicative+import Control.Arrow ( (***) )+import Control.DeepSeq+import Control.Monad+import Control.Monad.Trans ( liftIO )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as BLC+#ifdef WARP_TESTS+import qualified Data.CaseInsensitive as CI+#endif+import Data.Maybe ( fromJust )+import Network.URI ( URI, parseRelativeReference )++import Network.Socket+ ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily+ , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6)+ , defaultProtocol, SocketType(Stream), listen, setSocketOption, SocketOption(ReuseAddr)+ )+#ifdef WARP_TESTS+#if MIN_VERSION_network(2,4,0)+import Network.Socket ( bind )+#else+import Network.Socket ( bindSocket, Socket, SockAddr )+#endif+#endif++import qualified Network.Shed.Httpd as Shed+ ( Request, Response(Response), initServer+ , reqMethod, reqURI, reqHeaders, reqBody+ )+#ifdef WARP_TESTS+#if !MIN_VERSION_wai(3,0,0)+import qualified Data.Conduit.Lazy as Warp+#endif++import qualified Network.HTTP.Types as Warp+ ( Status(..) )+import qualified Network.Wai as Warp+import qualified Network.Wai.Handler.Warp as Warp+ ( runSettingsSocket, defaultSettings, setPort )+#endif++data Request = Request+ {+ reqMethod :: String,+ reqURI :: URI,+ reqHeaders :: [(String, String)],+ reqBody :: String+ }++data Response = Response+ {+ respStatus :: Int,+ respHeaders :: [(String, String)],+ respBody :: String+ }++mkResponse :: Int -> [(String, String)] -> String -> Response+mkResponse = Response++type Server = Int -> (Request -> IO Response) -> IO ()++shed :: Server+shed port handler =+ () <$ Shed.initServer+ port+ (liftM responseToShed . handler . requestFromShed)+ where+ responseToShed (Response status hdrs body) =+ Shed.Response status hdrs body+ chomp = reverse . strip '\r' . reverse+ strip c (c':str) | c == c' = str+ strip c str = str+ requestFromShed request =+ Request+ {+ reqMethod = Shed.reqMethod request,+ reqURI = Shed.reqURI request,+ reqHeaders = map (id *** chomp) $ Shed.reqHeaders request,+ reqBody = Shed.reqBody request+ }++#if !MIN_VERSION_bytestring(0,10,0)+instance NFData B.ByteString where+ rnf = rnf . B.length+#endif++#ifdef WARP_TESTS+#if !MIN_VERSION_network(2,4,0)+bind :: Socket -> SockAddr -> IO ()+bind = bindSocket+#endif++warp :: Bool -> Server+warp ipv6 port handler = do+ addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream })+ (Just $ if ipv6 then "::1" else "127.0.0.1")+ (Just . show $ port)+ case addrinfos of+ [] -> fail "Couldn't obtain address information in warp"+ (addri:_) -> do+ sock <- socket (addrFamily addri) Stream defaultProtocol+ setSocketOption sock ReuseAddr 1+ bind sock (addrAddress addri)+ listen sock 5+#if MIN_VERSION_wai(3,0,0)+ Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do+ request <- requestFromWarp warpRequest+ response <- handler request+ warpRespond (responseToWarp response)+#else+ Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do+ request <- requestFromWarp warpRequest+ response <- handler request+ return (responseToWarp response)+#endif+ where+ responseToWarp (Response status hdrs body) =+ Warp.responseLBS+ (Warp.Status status B.empty)+ (map headerToWarp hdrs)+ (BLC.pack body)+ headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value)+ headerFromWarp (name, value) =+ (BC.unpack (CI.original name), BC.unpack value)+ requestFromWarp request = do+#if MIN_VERSION_wai(3,0,1)+ body <- fmap BLC.unpack $ Warp.strictRequestBody request+#else+ body <- fmap BLC.unpack $ Warp.lazyRequestBody request+ body `deepseq` return ()+#endif+ return $+ Request+ {+ reqMethod = BC.unpack (Warp.requestMethod request),+ reqURI = fromJust . parseRelativeReference .+ BC.unpack . Warp.rawPathInfo $+ request,+ reqHeaders = map headerFromWarp (Warp.requestHeaders request),+ reqBody = body+ }+#endif
+ test/UnitTests.hs view
@@ -0,0 +1,69 @@+module UnitTests ( unitTests ) where++import Network.HTTP.Base+import Network.HTTP.Headers+import Network.URI++import Data.Maybe ( fromJust )++import Test.Framework ( testGroup )+import Test.Framework.Providers.HUnit+import Test.HUnit++parseIPv4Address :: Assertion+parseIPv4Address =+ assertEqual "127.0.0.1 address is recognised"+ (Just (URIAuthority {user = Nothing, password = Nothing, host = "127.0.0.1", port = Just 5313}))+ (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://127.0.0.1:5313/foo"))))+++parseIPv6Address :: Assertion+parseIPv6Address =+ assertEqual "::1 address"+ (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313}))+ (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo"))))++customHeaderNameComparison :: Assertion+customHeaderNameComparison =+ assertEqual "custom header name" (HdrCustom "foo") (HdrCustom "Foo")++customHeaderLookup :: Assertion+customHeaderLookup =+ let val = "header value"+ h = Header (HdrCustom "foo") val++ in assertEqual "custom header lookup" (Just val)+ (lookupHeader (HdrCustom "Foo") [h])++caseInsensitiveHeaderParse :: Assertion+caseInsensitiveHeaderParse =+ let expected = [ Header HdrContentType "blah"+ , Header (HdrCustom "X-Unknown") "unused"+ ]+ input = [ "content-type: blah"+ , "X-Unknown: unused"+ ]++ match actual =+ length actual == length expected &&+ and [ hdrName a == hdrName b && hdrValue a == hdrValue b+ | (a, b) <- zip expected actual+ ]++ in case parseHeaders input of+ Left _ -> assertFailure "Failed header parse"+ Right actual -> assert (match actual)++unitTests =+ [testGroup "Unit tests"+ [ testGroup "URI parsing"+ [ testCase "Parse IPv4 address" parseIPv4Address+ , testCase "Parse IPv6 address" parseIPv6Address+ ]+ ]+ , testGroup "Header tests"+ [ testCase "Custom header name case-insensitive match" customHeaderNameComparison+ , testCase "Custom header lookup" customHeaderLookup+ , testCase "Case-insensitive parsing" caseInsensitiveHeaderParse+ ]+ ]
+ test/httpTests.hs view
@@ -0,0 +1,668 @@+{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-}+import Control.Concurrent++import Control.Applicative ((<$))+import Control.Concurrent (threadDelay)+import Control.Exception (try)+import qualified Data.ByteString.Lazy.Char8 as BL (pack)+import Data.Char (isSpace)+import qualified Data.Digest.Pure.MD5 as MD5 (md5)+import Data.List.Split (splitOn)+import Data.Maybe (fromJust)+import System.IO.Error (userError)++import qualified Httpd+import qualified UnitTests++import Network.Browser+import Network.HTTP+import Network.HTTP.Base+import Network.HTTP.Auth+import Network.HTTP.Headers+import Network.Stream (Result)+import Network.URI (uriPath, parseURI)++import System.Environment (getArgs)+import System.Info (os)+import System.IO (getChar)++import Test.Framework (defaultMainWithArgs, testGroup)+import Test.Framework.Providers.HUnit+import Test.HUnit+++basicGetRequest :: (?testUrl :: ServerAddress) => Assertion+basicGetRequest = do+ response <- simpleHTTP (getRequest (?testUrl "/basic/get"))+ code <- getResponseCode response+ assertEqual "HTTP status code" (2, 0, 0) code+ body <- getResponseBody response+ assertEqual "Receiving expected response" "It works." body++basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion+basicGetRequestLBS = do+ response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get")))))+ code <- getResponseCode response+ assertEqual "HTTP status code" (2, 0, 0) code+ body <- getResponseBody response+ assertEqual "Receiving expected response" (BL.pack "It works.") body++basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion+basicHeadRequest = do+ response <- simpleHTTP (headRequest (?testUrl "/basic/head"))+ code <- getResponseCode response+ assertEqual "HTTP status code" (2, 0, 0) code+ body <- getResponseBody response+ -- the body should be empty, since this is a HEAD request+ assertEqual "Receiving expected response" "" body++basicExample :: (?testUrl :: ServerAddress) => Assertion+basicExample = do+ result <-+ -- sample code from Network.HTTP haddock, with URL changed+ -- Note there's also a copy of the example in the .cabal file+ simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody+ assertEqual "Receiving expected response" (take 100 haskellOrgText) result++secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion+secureGetRequest = do+ response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything"))+ assertEqual "Threw expected exception"+ (Left (userError "https not supported"))+ (fmap show response) -- fmap show because Response isn't in Eq++basicPostRequest :: (?testUrl :: ServerAddress) => Assertion+basicPostRequest = do+ let sendBody = "body"+ response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post")+ "text/plain"+ sendBody+ code <- getResponseCode response+ assertEqual "HTTP status code" (2, 0, 0) code+ body <- getResponseBody response+ assertEqual "Receiving expected response"+ (show (Just "text/plain", Just "4", sendBody))+ body++userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion+userpwAuthFailure = do+ response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic"))+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "HTTP status code" ((4, 0, 1),+ "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body)+ -- in case of 401, the server returns the contents of the Authz header++userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion+userpwAuthSuccess = do+ response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic"))+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)++basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion+basicAuthFailure = do+ response <- simpleHTTP (getRequest (?testUrl "/auth/basic"))+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body)++credentialsBasic :: (?testUrl :: ServerAddress) => Authority+credentialsBasic = AuthBasic "Testing realm" "test" "password"+ (fromJust . parseURI . ?testUrl $ "/auth/basic")++basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion+basicAuthSuccess = do+ let req = getRequest (?testUrl "/auth/basic")+ let authString = withAuthority credentialsBasic req+ let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req }+ response <- simpleHTTP reqWithAuth+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)++utf8URLEncode :: Assertion+utf8URLEncode = do+ assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com"+ assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD"+ assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE"++utf8URLDecode :: Assertion+utf8URLDecode = do+ assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com"+ assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow"+ assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好"+ assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо"++browserExample :: (?testUrl :: ServerAddress) => Assertion+browserExample = do+ result <-+ -- sample code from Network.Browser haddock, with URL changed+ -- Note there's also a copy of the example in the .cabal file+ do+ (_, rsp)+ <- Network.Browser.browse $ do+ setAllowRedirects True -- handle HTTP redirects+ request $ getRequest (?testUrl "/browser/example")+ return (take 100 (rspBody rsp))+ assertEqual "Receiving expected response" (take 100 haskellOrgText) result++-- A vanilla HTTP request using Browser shouldn't send a cookie header+browserNoCookie :: (?testUrl :: ServerAddress) => Assertion+browserNoCookie = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ request $ getRequest (?testUrl "/browser/no-cookie")+ let code = rspCode response+ assertEqual "HTTP status code" (2, 0, 0) code+++-- Regression test+-- * Browser sends vanilla request to server+-- * Server sets one cookie "hello=world"+-- * Browser sends a second request+--+-- Expected: Server gets single cookie with "hello=world"+-- Actual: Server gets 3 extra cookies, which are actually cookie attributes:+-- "$Version=0;hello=world;$Domain=localhost:8080\r"+browserOneCookie :: (?testUrl :: ServerAddress) => Assertion+browserOneCookie = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ -- This first requests returns a single Set-Cookie: hello=world+ _ <- request $ getRequest (?testUrl "/browser/one-cookie/1")++ -- This second request should send a single Cookie: hello=world+ request $ getRequest (?testUrl "/browser/one-cookie/2")+ let body = rspBody response+ assertEqual "Receiving expected response" "" body+ let code = rspCode response+ assertEqual "HTTP status code" (2, 0, 0) code++browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion+browserTwoCookies = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ -- This first request returns two cookies+ _ <- request $ getRequest (?testUrl "/browser/two-cookies/1")++ -- This second request should send them back+ request $ getRequest (?testUrl "/browser/two-cookies/2")+ let body = rspBody response+ assertEqual "Receiving expected response" "" body+ let code = rspCode response+ assertEqual "HTTP status code" (2, 0, 0) code+++browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion+browserFollowsRedirect n = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get")+ assertEqual "Receiving expected response from server"+ ((2, 0, 0), "It works.")+ (rspCode response, rspBody response)++browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion+browserReturnsRedirect n = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())+ request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get")+ assertEqual "Receiving expected response from server"+ ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "")+ (rspCode response, rspBody response)++authGenBasic _ "Testing realm" = return $ Just ("test", "password")+authGenBasic _ realm = fail $ "Unexpected realm " ++ realm++browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion+browserBasicAuth = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())++ setAuthorityGen authGenBasic++ request $ getRequest (?testUrl "/auth/basic")++ assertEqual "Receiving expected response from server"+ ((2, 0, 0), "Here's the secret")+ (rspCode response, rspBody response)++authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword")+authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm++browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion+browserDigestAuth = do+ (_, response) <- browse $ do+ setOutHandler (const $ return ())++ setAuthorityGen authGenDigest++ request $ getRequest (?testUrl "/auth/digest")++ assertEqual "Receiving expected response from server"+ ((2, 0, 0), "Here's the digest secret")+ (rspCode response, rspBody response)++++browserAlt :: (?altTestUrl :: ServerAddress) => Assertion+browserAlt = do+ (response) <- browse $ do++ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?altTestUrl "/basic/get")++ return response1++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response, rspBody response)++-- test that requests to multiple servers on the same host+-- don't get confused with each other+browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion+browserBoth = do+ (response1, response2) <- browse $ do+ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?testUrl "/basic/get")+ (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")++ return (response1, response2)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response2, rspBody response2)++-- test that requests to multiple servers on the same host+-- don't get confused with each other+browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion+browserBothReversed = do+ (response1, response2) <- browse $ do+ setOutHandler (const $ return ())++ (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")+ (_, response1) <- request $ getRequest (?testUrl "/basic/get")++ return (response1, response2)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response2, rspBody response2)++browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion+browserSecureRequest = do+ res <- try $ browse $ do+ setOutHandler (const $ return ())++ request $ getRequest (?secureTestUrl "/anything")++ assertEqual "Threw expected exception"+ (Left (userError "https not supported"))+ (fmap show res) -- fmap show because Response isn't in Eq++-- in case it tries to reuse the connection+browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion+browserSecureRequestAfterInsecure = do+ res <- try $ browse $ do+ setOutHandler (const $ return ())++ request $ getRequest (?testUrl "/basic/get")+ request $ getRequest (?secureTestUrl "/anything")++ assertEqual "Threw expected exception"+ (Left (userError "https not supported"))+ (fmap show res) -- fmap show because Response isn't in Eq++browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion+browserRedirectToSecure = do+ res <- try $ browse $ do+ setOutHandler (const $ return ())+ setErrHandler fail++ request $ getRequest (?testUrl "/browser/redirect/secure/301/anything")++ assertEqual "Threw expected exception"+ (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything"))+ (fmap show res) -- fmap show because Response isn't in Eq++browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion+browserTwoRequests = do+ (response1, response2) <- browse $ do+ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?testUrl "/basic/get")+ (_, response2) <- request $ getRequest (?testUrl "/basic/get2")++ return (response1, response2)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works (2).")+ (rspCode response2, rspBody response2)+++browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion+browserTwoRequestsAlt = do+ (response1, response2) <- browse $ do++ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?altTestUrl "/basic/get")+ (_, response2) <- request $ getRequest (?altTestUrl "/basic/get2")++ return (response1, response2)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server (2).")+ (rspCode response2, rspBody response2)++browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion+browserTwoRequestsBoth = do+ (response1, response2, response3, response4) <- browse $ do+ setOutHandler (const $ return ())++ (_, response1) <- request $ getRequest (?testUrl "/basic/get")+ (_, response2) <- request $ getRequest (?altTestUrl "/basic/get")+ (_, response3) <- request $ getRequest (?testUrl "/basic/get2")+ (_, response4) <- request $ getRequest (?altTestUrl "/basic/get2")++ return (response1, response2, response3, response4)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works.")+ (rspCode response1, rspBody response1)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server.")+ (rspCode response2, rspBody response2)++ assertEqual "Receiving expected response from main server"+ ((2, 0, 0), "It works (2).")+ (rspCode response3, rspBody response3)++ assertEqual "Receiving expected response from alternate server"+ ((2, 0, 0), "This is the alternate server (2).")+ (rspCode response4, rspBody response4)++hasPrefix :: String -> String -> Maybe String+hasPrefix [] ys = Just ys+hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys+hasPrefix _ _ = Nothing++maybeRead :: Read a => String -> Maybe a+maybeRead s =+ case reads s of+ [(v, "")] -> Just v+ _ -> Nothing++splitFields = map (toPair '=' . trim isSpace) . splitOn ","++toPair c str = case break (==c) str of+ (left, _:right) -> (left, right)+ _ -> error $ "No " ++ show c ++ " in " ++ str+trim f = dropWhile f . reverse . dropWhile f . reverse++isSubsetOf xs ys = all (`elem` ys) xs++-- first bits of result text from haskell.org (just to give some representative text)+haskellOrgText =+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\+\\t<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\+\\t<head>\+\\t\t<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\+\\t\t\t\t<meta name=\"keywords\" content=\"Haskell,Applications and libraries,Books,Foreign Function Interface,Functional programming,Hac Boston,HakkuTaikai,HaskellImplementorsWorkshop/2011,Haskell Communities and Activities Report,Haskell in education,Haskell in industry\" />"++digestMatch+ username realm password+ nonce opaque+ method relativeURI makeAbsolute+ headers+ =+ common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers)+ where+ common = [("username", show username), ("realm", show realm), ("nonce", show nonce),+ ("opaque", show opaque)]+ md5 = show . MD5.md5 . BL.pack+ ha1 = md5 (username++":"++realm++":"++password)+ ha2 uri = md5 (method++":"++uri)+ response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri)+ mkUncommon uri hash = [("uri", show uri), ("response", show hash)]+ relative = mkUncommon relativeURI (response relativeURI)+ absoluteURI = makeAbsolute relativeURI+ absolute = mkUncommon absoluteURI (response absoluteURI)++processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress)+ => Httpd.Request+ -> IO Httpd.Response+processRequest req = do+ case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of+ ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works."+ ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)."+ ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."+ ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."+ ("POST", "/basic/post") ->+ let typ = lookup "Content-Type" (Httpd.reqHeaders req)+ len = lookup "Content-Length" (Httpd.reqHeaders req)+ body = Httpd.reqBody req+ in return $ Httpd.mkResponse 200 [] (show (typ, len, body))++ ("GET", "/basic/example") ->+ return $ Httpd.mkResponse 200 [] haskellOrgText++ ("GET", "/auth/basic") ->+ case lookup "Authorization" (Httpd.reqHeaders req) of+ Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret"+ x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x)++ ("GET", "/auth/digest") ->+ case lookup "Authorization" (Httpd.reqHeaders req) of+ Just (hasPrefix "Digest " -> Just (splitFields -> items))+ | digestMatch "test" "Digest testing realm" "digestpassword"+ "87e4" "057d"+ "GET" "/auth/digest" ?testUrl+ items+ -> return $ Httpd.mkResponse 200 [] "Here's the digest secret"+ x -> return $ Httpd.mkResponse+ 401+ [("WWW-Authenticate",+ "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")]+ (show x)++ ("GET", "/browser/example") ->+ return $ Httpd.mkResponse 200 [] haskellOrgText+ ("GET", "/browser/no-cookie") ->+ case lookup "Cookie" (Httpd.reqHeaders req) of+ Nothing -> return $ Httpd.mkResponse 200 [] ""+ Just s -> return $ Httpd.mkResponse 500 [] s+ ("GET", "/browser/one-cookie/1") ->+ return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] ""+ ("GET", "/browser/one-cookie/2") ->+ case lookup "Cookie" (Httpd.reqHeaders req) of+ Just "hello=world" -> return $ Httpd.mkResponse 200 [] ""+ Just s -> return $ Httpd.mkResponse 500 [] s+ Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)+ ("GET", "/browser/two-cookies/1") ->+ return $ Httpd.mkResponse 200+ [("Set-Cookie", "hello=world")+ ,("Set-Cookie", "goodbye=cruelworld")]+ ""+ ("GET", "/browser/two-cookies/2") ->+ case lookup "Cookie" (Httpd.reqHeaders req) of+ -- TODO generalise the cookie parsing to allow for whitespace/ordering variations+ Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] ""+ Just s -> return $ Httpd.mkResponse 500 [] s+ Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req)+ ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->+ return $ Httpd.mkResponse n [("Location", rest)] ""+ ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->+ return $ Httpd.mkResponse n [("Location", ?testUrl rest)] ""+ ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) ->+ return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] ""+ _ -> return $ Httpd.mkResponse 500 [] "Unknown request"++altProcessRequest :: Httpd.Request -> IO Httpd.Response+altProcessRequest req = do+ case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of+ ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server."+ ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)."+ _ -> return $ Httpd.mkResponse 500 [] "Unknown request"++maybeTestGroup True name xs = testGroup name xs+maybeTestGroup False name _ = testGroup name []++basicTests =+ testGroup "Basic tests"+ [ testCase "Basic GET request" basicGetRequest+ , testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS+ , testCase "Network.HTTP example code" basicExample+ , testCase "Secure GET request" secureGetRequest+ , testCase "Basic POST request" basicPostRequest+ , testCase "Basic HEAD request" basicHeadRequest+ , testCase "URI user:pass Auth failure" userpwAuthFailure+ , testCase "URI user:pass Auth success" userpwAuthSuccess+ , testCase "Basic Auth failure" basicAuthFailure+ , testCase "Basic Auth success" basicAuthSuccess+ , testCase "UTF-8 urlEncode" utf8URLEncode+ , testCase "UTF-8 urlDecode" utf8URLDecode+ ]++browserTests =+ testGroup "Browser tests"+ [ testGroup "Basic"+ [+ testCase "Network.Browser example code" browserExample+ , testCase "Two requests" browserTwoRequests+ ]+ , testGroup "Secure"+ [+ testCase "Secure request" browserSecureRequest+ , testCase "After insecure" browserSecureRequestAfterInsecure+ , testCase "Redirection" browserRedirectToSecure+ ]+ , testGroup "Cookies"+ [ testCase "No cookie header" browserNoCookie+ , testCase "One cookie" browserOneCookie+ , testCase "Two cookies" browserTwoCookies+ ]+ , testGroup "Redirection"+ [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection+ -- 300 Multiple Choices: client has to handle this+ testCase "300" (browserReturnsRedirect 300)+ -- 301 Moved Permanently: should follow+ , testCase "301" (browserFollowsRedirect 301)+ -- 302 Found: should follow+ , testCase "302" (browserFollowsRedirect 302)+ -- 303 See Other: should follow (directly for GETs)+ , testCase "303" (browserFollowsRedirect 303)+ -- 304 Not Modified: maybe Browser could do something intelligent based on+ -- being given locally cached content and sending If-Modified-Since, but it+ -- doesn't at the moment+ , testCase "304" (browserReturnsRedirect 304)+ -- 305 Use Proxy: test harness doesn't have a proxy (yet)+ -- 306 Switch Proxy: obsolete+ -- 307 Temporary Redirect: should follow+ , testCase "307" (browserFollowsRedirect 307)+ -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this+ , testCase "308" (browserReturnsRedirect 308)+ ]+ , testGroup "Authentication"+ [ testCase "Basic" browserBasicAuth+ , testCase "Digest" browserDigestAuth+ ]+ ]++port80Tests =+ testGroup "Multiple servers"+ [ testCase "Alternate server" browserAlt+ , testCase "Both servers" browserBoth+ , testCase "Both servers (reversed)" browserBothReversed+ , testCase "Two requests - alternate server" browserTwoRequestsAlt+ , testCase "Two requests - both servers" browserTwoRequestsBoth+ ]++data InetFamily = IPv4 | IPv6++familyToLocalhost :: InetFamily -> String+familyToLocalhost IPv4 = "127.0.0.1"+familyToLocalhost IPv6 = "[::1]"++urlRoot :: InetFamily -> String -> Int -> String+urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam+urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n++secureRoot :: InetFamily -> String -> Int -> String+secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam+secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n++type ServerAddress = String -> String++httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress+httpAddress fam userpw port p = urlRoot fam userpw port ++ p+httpsAddress fam userpw port p = secureRoot fam userpw port ++ p++main :: IO ()+main = do+ args <- getArgs++ let servers =+ [ ("httpd-shed", Httpd.shed, IPv4)+#ifdef WARP_TESTS+ , ("warp.v6", Httpd.warp True, IPv6)+ , ("warp.v4", Httpd.warp False, IPv4)+#endif+ ]+ basePortNum, altPortNum :: Int+ basePortNum = 5812+ altPortNum = 80+ numberedServers = zip [basePortNum..] servers++ let setupNormalTests = do+ flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do+ let ?testUrl = httpAddress family "" portNum+ ?userpwUrl = httpAddress family "test:password@" portNum+ ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum+ ?secureTestUrl = httpsAddress family "" portNum+ _ <- forkIO $ server portNum processRequest+ return $ testGroup serverName [basicTests, browserTests]++ let setupAltTests = do+ let (portNum, (_, server,family)) = head numberedServers+ let ?testUrl = httpAddress family "" portNum+ ?altTestUrl = httpAddress family "" altPortNum+ _ <- forkIO $ server altPortNum altProcessRequest+ return port80Tests++ case args of+ ["server"] -> do -- run only the harness servers for diagnostic/debug purposes+ -- halt on any keypress+ _ <- setupNormalTests+ _ <- setupAltTests+ _ <- getChar+ return ()+ ("--withport80":args) -> do+ normalTests <- setupNormalTests+ altTests <- setupAltTests+ _ <- threadDelay 1000000 -- Give the server time to start :-(+ defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args+ args -> do -- run the test harness as normal+ normalTests <- setupNormalTests+ _ <- threadDelay 1000000 -- Give the server time to start :-(+ defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args