diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -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 . + +Version 4000.0.6: release 2009-04-21; changes from 4000.0.5 + + * Network.Browser: use HTTP.HandleStream.sendHTTP_notify, not HTTP.sendHTTP_notify + when issuing requests. The latter runs the risk of undoing request normalization. + * Network.HTTP.Base.normalizeRequest: when normalizing proxy-bound requests, + insert a Host: header if none present. Set it to the destination server authority, + not the proxy. + * Network.Browser: don't fail on seeing invalid cookie values, but report them + as errors and continue. + +Version 4000.0.5: release 2009-03-30; changes from 4000.0.4 + + * Get serious about comments and Haddock documentation. + * Cleaned up normalization of requests, fixing bugs and bringing together + previous disparate attempts at handling this. + * RequestMethod now supports custom verbs; use the (Custom String) constructor + * Beef up Network.HTTP.Base's support for normalizing requests and URIs: + + * added splitRequestURI which divides a URI into two; the Authority portion + (as a String) and the input URI sans the authority portion. Useful when + wanting to split up a request's URI into its Host: and abs_path pieces. + * added normalizeRequest :: Bool -> Request ty -> Request ty, which + fixes up a requests URI path and Host: info depending on whether it is + destined for a proxy or not (controlled by the Bool.) + * moved defaultRequest, defaultRequest_, libUA from Network.Browser + to Network.HTTP.Base + * added mkRequest :: RequestMethod -> URI -> Bool -> Request ty + for constructing normalized&sane Request bases on top of which + you can add custom headers, body payload etc. + diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -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 -Maintainer: Bjorn Bringert -Homepage: http://www.haskell.org/http/ -Description: A library for client-side HTTP -Build-depends: base, network, parsec -Exposed-modules: +Maintainer: Ganesh Sittampalam +Homepage: https://github.com/haskell/HTTP +Category: Network +Synopsis: A library for client-side HTTP +Description: + + The HTTP package supports client-side web programming in Haskell. It lets you set up + HTTP connections, transmitting requests and processing the responses coming back, all + from within the comforts of Haskell. It's dependent on the network package to operate, + but other than that, the implementation is all written in Haskell. + . + A basic API for issuing single HTTP requests + receiving responses is provided. On top + of that, a session-level abstraction is also on offer (the @BrowserAction@ monad); + it taking care of handling the management of persistent connections, proxies, + state (cookies) and authentication credentials required to handle multi-step + interactions with a web server. + . + The representation of the bytes flowing across is extensible via the use of a type class, + letting you pick the representation of requests and responses that best fits your use. + Some pre-packaged, common instances are provided for you (@ByteString@, @String@). + . + Here's an example use: + . + > + > do + > rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/") + > -- fetch document and return it (as a 'String'.) + > fmap (take 100) (getResponseBody rsp) + > + > do + > (_, rsp) + > <- Network.Browser.browse $ do + > setAllowRedirects True -- handle HTTP redirects + > request $ getRequest "http://www.haskell.org/" + > return (take 100 (rspBody rsp)) + . + __Note:__ This package does not support HTTPS connections. + If you need HTTPS, take a look at the following packages: + . + * + . + * (in combination with + ) + . + * + . + * + . + +Extra-Source-Files: CHANGES + +tested-with: + GHC == 9.12.2 + GHC == 9.10.3 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + -- CI failing for GHC 8.0 because of https://github.com/haskell/cabal/issues/10379 + -- GHC == 8.0.2 + +Source-Repository head + type: git + location: https://github.com/haskell/HTTP.git + +Flag warn-as-error + default: False + description: Build with warnings-as-errors + manual: True + +Flag conduit10 + description: Use version 1.0.x or below of the conduit package (for the test suite) + default: False + +Flag warp-tests + description: Test against warp + default: False + manual: True + +Library + Autogen-modules: Paths_HTTP + Exposed-modules: + Network.BufferType, Network.Stream, - Network.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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -2,8 +2,18 @@ Copyright (c) 2002-2005, Ian Lynagh Copyright (c) 2003-2006, Bjorn Bringert Copyright (c) 2004, Andre Furtado -Copyright (c) 2004, Ganesh Sittampalam Copyright (c) 2004-2005, Dominic Steinitz +Copyright (c) 2007, Robin Bate Boerop +Copyright (c) 2008-2010, Sigbjorn Finne +Copyright (c) 2009, Eric Kow +Copyright (c) 2010, Antoine Latter +Copyright (c) 2004, 2010-2011, Ganesh Sittampalam +Copyright (c) 2011, Duncan Coutts +Copyright (c) 2011, Matthew Gruen +Copyright (c) 2011, Jeremy Yallop +Copyright (c) 2011, Eric Hesselink +Copyright (c) 2011, Yi Huang +Copyright (c) 2011, Tom Lokhorst All rights reserved. diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -1,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 +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 . +-- +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) + diff --git a/Network/BufferType.hs b/Network/BufferType.hs new file mode 100644 --- /dev/null +++ b/Network/BufferType.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.BufferType +-- Description : Abstract representation of request and response buffer types. +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- In order to give the user freedom in how request and response content +-- is represented, a sufficiently abstract representation is needed of +-- these internally. The "Network.BufferType" module provides this, defining +-- the 'BufferType' class and its ad-hoc representation of buffer operations +-- via the 'BufferOp' record. +-- +-- This module provides definitions for the standard buffer types that the +-- package supports, i.e., for @String@ and @ByteString@ (strict and lazy.) +-- +----------------------------------------------------------------------------- +module Network.BufferType + ( + BufferType(..) + + , BufferOp(..) + , strictBufferOp + , lazyBufferOp + , stringBufferOp + ) where + + +import qualified Data.ByteString as Strict hiding ( unpack, pack, span ) +import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span ) +import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) +import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) +import System.IO ( Handle ) +import Data.Word ( Word8 ) + +import Network.HTTP.Utils ( crlf, lf ) + +-- | The @BufferType@ class encodes, in a mixed-mode way, the interface +-- that the library requires to operate over data embedded in HTTP +-- requests and responses. That is, we use explicit dictionaries +-- for the operations, but overload the name of the dicts themselves. +-- +class BufferType bufType where + bufferOps :: BufferOp bufType + +instance BufferType Lazy.ByteString where + bufferOps = lazyBufferOp + +instance BufferType Strict.ByteString where + bufferOps = strictBufferOp + +instance BufferType String where + bufferOps = stringBufferOp + +-- | @BufferOp@ encodes the I/O operations of the underlying buffer over +-- a Handle in an (explicit) dictionary type. May not be needed, but gives +-- us flexibility in explicit overriding and wrapping up of these methods. +-- +-- Along with IO operations is an ad-hoc collection of functions for working +-- with these abstract buffers, as needed by the internals of the code +-- that processes requests and responses. +-- +-- We supply three default @BufferOp@ values, for @String@ along with the +-- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@ +-- definitions for +data BufferOp a + = BufferOp + { buf_hGet :: Handle -> Int -> IO a + , buf_hGetContents :: Handle -> IO a + , buf_hPut :: Handle -> a -> IO () + , buf_hGetLine :: Handle -> IO a + , buf_empty :: a + , buf_append :: a -> a -> a + , buf_concat :: [a] -> a + , buf_fromStr :: String -> a + , buf_toStr :: a -> String + , buf_snoc :: a -> Word8 -> a + , buf_splitAt :: Int -> a -> (a,a) + , buf_span :: (Char -> Bool) -> a -> (a,a) + , buf_isLineTerm :: a -> Bool + , buf_isEmpty :: a -> Bool + } + +instance Eq (BufferOp a) where + _ == _ = False + +-- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-lazy kind. +strictBufferOp :: BufferOp Strict.ByteString +strictBufferOp = + BufferOp + { buf_hGet = Strict.hGet + , buf_hGetContents = Strict.hGetContents + , buf_hPut = Strict.hPut + , buf_hGetLine = Strict.hGetLine + , buf_append = Strict.append + , buf_concat = Strict.concat + , buf_fromStr = Strict.pack + , buf_toStr = Strict.unpack + , buf_snoc = Strict.snoc + , buf_splitAt = Strict.splitAt + , buf_span = Strict.span + , buf_empty = Strict.empty + , buf_isLineTerm = \ b -> Strict.length b == 2 && p_crlf == b || + Strict.length b == 1 && p_lf == b + , buf_isEmpty = Strict.null + } + where + p_crlf = Strict.pack crlf + p_lf = Strict.pack lf + +-- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-strict kind. +lazyBufferOp :: BufferOp Lazy.ByteString +lazyBufferOp = + BufferOp + { buf_hGet = Lazy.hGet + , buf_hGetContents = Lazy.hGetContents + , buf_hPut = Lazy.hPut + , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) + , buf_append = Lazy.append + , buf_concat = Lazy.concat + , buf_fromStr = Lazy.pack + , buf_toStr = Lazy.unpack + , buf_snoc = Lazy.snoc + , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x + , buf_span = Lazy.span + , buf_empty = Lazy.empty + , buf_isLineTerm = \ b -> Lazy.length b == 2 && p_crlf == b || + Lazy.length b == 1 && p_lf == b + , buf_isEmpty = Lazy.null + } + where + p_crlf = Lazy.pack crlf + p_lf = Lazy.pack lf + +-- | @stringBufferOp@ is the 'BufferOp' definition over @String@s. +-- It is defined in terms of @strictBufferOp@ operations, +-- unpacking/converting to @String@ when needed. +stringBufferOp :: BufferOp String +stringBufferOp =BufferOp + { buf_hGet = \ h n -> buf_hGet strictBufferOp h n >>= return . Strict.unpack + , buf_hGetContents = \ h -> buf_hGetContents strictBufferOp h >>= return . Strict.unpack + , buf_hPut = \ h s -> buf_hPut strictBufferOp h (Strict.pack s) + , buf_hGetLine = \ h -> buf_hGetLine strictBufferOp h >>= return . Strict.unpack + , buf_append = (++) + , buf_concat = concat + , buf_fromStr = id + , buf_toStr = id + , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] + , buf_splitAt = splitAt + , buf_span = \ p a -> + case Strict.span p (Strict.pack a) of + (x,y) -> (Strict.unpack x, Strict.unpack y) + , buf_empty = [] + , buf_isLineTerm = \ b -> b == crlf || b == lf + , buf_isEmpty = null + } + diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -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: --- > --- > //:@:/ --- > Some or all of the parts ":@", ":", --- > ":", and "/" may be excluded. -parseURIAuthority :: String -> Maybe URIAuthority -parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s)) - - -pURIAuthority :: ReadP URIAuthority -pURIAuthority = do - (u,pw) <- (pUserInfo `before` char '@') - <++ return (Nothing, Nothing) - h <- 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: - - 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 +-- 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). diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Auth.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Auth +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Representing HTTP Auth values in Haskell. +-- Right now, it contains mostly functionality needed by 'Network.Browser'. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Auth + ( Authority(..) + , Algorithm(..) + , Challenge(..) + , Qop(..) + + , headerToChallenge -- :: URI -> Header -> Maybe Challenge + , withAuthority -- :: Authority -> Request ty -> String + ) where + +import Network.URI +import Network.HTTP.Base +import Network.HTTP.Utils +import Network.HTTP.Headers ( Header(..) ) +import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str)) +import qualified Network.HTTP.Base64 as Base64 (encode) +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 ) + +import Data.Char +import Data.Maybe +import Data.Word ( Word8 ) + +-- | @Authority@ specifies the HTTP Authentication method to use for +-- a given domain/realm; @Basic@ or @Digest@. +data Authority + = AuthBasic { auRealm :: String + , auUsername :: String + , auPassword :: String + , auSite :: URI + } + | AuthDigest{ auRealm :: String + , auUsername :: String + , auPassword :: String + , auNonce :: String + , auAlgorithm :: Maybe Algorithm + , auDomain :: [URI] + , auOpaque :: Maybe String + , auQop :: [Qop] + } + + +data Challenge + = ChalBasic { chRealm :: String } + | ChalDigest { chRealm :: String + , chDomain :: [URI] + , chNonce :: String + , chOpaque :: Maybe String + , chStale :: Bool + , chAlgorithm ::Maybe Algorithm + , chQop :: [Qop] + } + +-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. +data Algorithm = AlgMD5 | AlgMD5sess + deriving(Eq) + +instance Show Algorithm where + show AlgMD5 = "md5" + show AlgMD5sess = "md5-sess" + +-- | +data Qop = QopAuth | QopAuthInt + deriving(Eq,Show) + +-- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority', +-- in the context of the given request. +-- +-- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String +withAuthority :: Authority -> Request ty -> String +withAuthority a rq = case a of + AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) + AuthDigest{} -> + "Digest " ++ + concat [ "username=" ++ quo (auUsername a) + , ",realm=" ++ quo (auRealm a) + , ",nonce=" ++ quo (auNonce a) + , ",uri=" ++ quo digesturi + , ",response=" ++ quo rspdigest + -- plus optional stuff: + , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a)) + , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a)) + , if null (auQop a) then "" else ",qop=auth" + ] + where + quo s = '"':s ++ "\"" + + rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) + + a1, a2 :: String + a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a + + {- + If the "qop" directive's value is "auth" or is unspecified, then A2 + is: + A2 = Method ":" digest-uri-value + If the "qop" value is "auth-int", then A2 is: + A2 = Method ":" digest-uri-value ":" H(entity-body) + -} + a2 = show (rqMethod rq) ++ ":" ++ digesturi + + digesturi = show (rqURI rq) + noncevalue = auNonce a + +type Octet = Word8 + +-- FIXME: these probably only work right for latin-1 strings +stringToOctets :: String -> [Octet] +stringToOctets = map (fromIntegral . fromEnum) + +base64encode :: String -> String +base64encode = Base64.encode . stringToOctets + +md5 :: String -> String +md5 = MD5.md5s . MD5.Str + +kd :: String -> String -> String +kd a b = md5 (a ++ ":" ++ b) + + + + +-- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header +-- @www_auth@ into a 'Challenge' value. +headerToChallenge :: URI -> Header -> Maybe Challenge +headerToChallenge baseURI (Header _ str) = + case parse challenge "" str of + Left{} -> Nothing + Right (name,props) -> case name of + "basic" -> mkBasic props + "digest" -> mkDigest props + _ -> Nothing + where + challenge :: Parser (String,[(String,String)]) + challenge = + do { nme <- word + ; spaces + ; pps <- cprops + ; return (map toLower nme,pps) + } + + cprops = sepBy1 cprop comma + + comma = do { spaces ; _ <- char ',' ; spaces } + + cprop = + do { nm <- word + ; _ <- char '=' + ; val <- quotedstring + ; return (map toLower nm,val) + } + + mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge + + mkBasic params = fmap ChalBasic (lookup "realm" params) + + mkDigest params = + -- with Maybe monad + do { r <- lookup "realm" params + ; n <- lookup "nonce" params + ; return $ + ChalDigest { chRealm = r + , chDomain = (annotateURIs + $ map parseURI + $ words + $ fromMaybe [] + $ lookup "domain" params) + , chNonce = n + , chOpaque = lookup "opaque" params + , chStale = "true" == (map toLower + $ fromMaybe "" (lookup "stale" params)) + , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params) + , chQop = readQop (fromMaybe "" $ lookup "qop" params) + } + } + + annotateURIs :: [Maybe URI] -> [URI] +#if MIN_VERSION_network(2,4,0) + annotateURIs = map (`relativeTo` baseURI) . catMaybes +#else + annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes +#endif + + -- Change These: + readQop :: String -> [Qop] + readQop = catMaybes . (map strToQop) . (splitBy ',') + + strToQop qs = case map toLower (trim qs) of + "auth" -> Just QopAuth + "auth-int" -> Just QopAuthInt + _ -> Nothing + + readAlgorithm astr = case map toLower (trim astr) of + "md5" -> Just AlgMD5 + "md5-sess" -> Just AlgMD5sess + _ -> Nothing + +word, quotedstring :: Parser String +quotedstring = + do { _ <- char '"' -- " + ; str <- many (satisfy $ not . (=='"')) + ; _ <- char '"' + ; return str + } + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Base.hs @@ -0,0 +1,1002 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Base +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Definitions of @Request@ and @Response@ types along with functions +-- for normalizing them. It is assumed to be an internal module; user +-- code should, if possible, import @Network.HTTP@ to access the functionality +-- that this module provides. +-- +-- Additionally, the module exports internal functions for working with URLs, +-- and for handling the processing of requests and responses coming back. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Base + ( + -- ** Constants + httpVersion -- :: String + + -- ** HTTP + , Request(..) + , Response(..) + , RequestMethod(..) + + , Request_String + , Response_String + , HTTPRequest + , HTTPResponse + + -- ** URL Encoding + , urlEncode + , urlDecode + , urlEncodeVars + + -- ** URI authority parsing + , URIAuthority(..) + , parseURIAuthority + + -- internal + , uriToAuthorityString -- :: URI -> String + , uriAuthToString -- :: URIAuth -> String + , uriAuthPort -- :: Maybe URI -> URIAuth -> Int + , reqURIAuth -- :: Request ty -> URIAuth + + , parseResponseHead -- :: [String] -> Result ResponseData + , parseRequestHead -- :: [String] -> Result RequestData + + , ResponseNextStep(..) + , matchResponse + , ResponseData + , ResponseCode + , RequestData + + , NormalizeRequestOptions(..) + , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty + , RequestNormalizer + + , normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty + + , splitRequestURI + + , getAuth + , normalizeRequestURI + , normalizeHostHeader + , findConnClose + + -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) + , linearTransfer + , hopefulTransfer + , chunkedTransfer + , uglyDeathTransfer + , readTillEmpty1 + , readTillEmpty2 + + , defaultGETRequest + , defaultGETRequest_ + , mkRequest + , setRequestBody + + , defaultUserAgent + , httpPackageVersion + , libUA {- backwards compatibility, will disappear..soon -} + + , catchIO + , catchIO_ + , responseParseError + + , getRequestVersion + , getResponseVersion + , setRequestVersion + , setResponseVersion + + , failHTTPS + + ) where + +import Network.URI + ( URI(uriAuthority, uriPath, uriScheme) + , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort) + , parseURIReference + ) + +import Control.Monad ( guard ) + +import Data.Bits ( (.&.), (.|.), shiftL, shiftR ) +import Data.Word ( Word8 ) +import Data.Char ( digitToInt, intToDigit, toLower, isDigit, + isAscii, isAlphaNum, ord, chr ) +import Data.List ( partition, find ) +import Data.Maybe ( listToMaybe, fromMaybe ) +import Numeric ( readHex ) + +import Network.Stream +import Network.BufferType ( BufferOp(..), BufferType(..) ) +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim, crlf, sp, readsOne ) +import qualified Network.HTTP.Base64 as Base64 (encode) + +import Text.Read.Lex (readDecP) +import Text.ParserCombinators.ReadP + ( ReadP, readP_to_S, char, (<++), look, munch, munch1 ) + +import Control.Exception as Exception (catch, IOException) + +import qualified Paths_HTTP as Self (version) +import Data.Version (showVersion) + +----------------------------------------------------------------- +------------------ URI Authority parsing ------------------------ +----------------------------------------------------------------- + +data URIAuthority = URIAuthority { user :: Maybe String, + password :: Maybe String, + host :: String, + port :: Maybe Int + } deriving (Eq,Show) + +-- | Parse the authority part of a URL. +-- +-- > RFC 1732, section 3.1: +-- > +-- > //:@:/ +-- > Some or all of the parts ":@", ":", +-- > ":", and "/" may be excluded. +parseURIAuthority :: String -> Maybe URIAuthority +parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s)) + + +pURIAuthority :: ReadP URIAuthority +pURIAuthority = do + (u,pw) <- (pUserInfo `before` char '@') + <++ return (Nothing, Nothing) + h <- rfc2732host <++ munch (/=':') + p <- orNothing (char ':' >> readDecP) + look >>= guard . null + return URIAuthority{ user=u, password=pw, host=h, port=p } + +-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL +rfc2732host :: ReadP String +rfc2732host = do + _ <- char '[' + res <- munch1 (/=']') + _ <- char ']' + return res + +pUserInfo :: ReadP (Maybe String, Maybe String) +pUserInfo = do + u <- orNothing (munch (`notElem` ":@")) + p <- orNothing (char ':' >> munch (/='@')) + return (u,p) + +before :: Monad m => m a -> m b -> m a +before a b = a >>= \x -> b >> return x + +orNothing :: ReadP a -> ReadP (Maybe a) +orNothing p = fmap Just p <++ return Nothing + +-- This function duplicates old Network.URI.authority behaviour. +uriToAuthorityString :: URI -> String +uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) + +uriAuthToString :: URIAuth -> String +uriAuthToString ua = + concat [ uriUserInfo ua + , uriRegName ua + , uriPort ua + ] + +uriAuthPort :: Maybe URI -> URIAuth -> Int +uriAuthPort mbURI u = + case uriPort u of + (':':s) -> readsOne id (default_port mbURI) s + _ -> default_port mbURI + where + default_port Nothing = default_http + default_port (Just url) = + case map toLower $ uriScheme url of + "http:" -> default_http + "https:" -> default_https + -- todo: refine + _ -> default_http + + default_http = 80 + default_https = 443 + +#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: + + 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)) diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs --- a/Network/HTTP/Base64.hs +++ b/Network/HTTP/Base64.hs @@ -8,19 +8,18 @@ -- Stability : experimental -- Portability : portable -- --- Base64 encoding and decoding functions provided by Warwick Gray. --- See +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See -- and . -- ----------------------------------------------------------------------------- -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 diff --git a/Network/HTTP/Cookie.hs b/Network/HTTP/Cookie.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Cookie.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Cookie +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- This module provides the data types and functions for working with HTTP cookies. +-- Right now, it contains mostly functionality needed by 'Network.Browser'. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Cookie + ( Cookie(..) + , cookieMatch -- :: (String,String) -> Cookie -> Bool + + -- functions for translating cookies and headers. + , cookiesToHeader -- :: [Cookie] -> Header + , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) + ) where + +import Network.HTTP.Headers + +import Data.Char +import Data.List +import Data.Maybe + +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, option, try + , (<|>), sepBy1 + ) + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- | @Cookie@ is the Haskell representation of HTTP cookie values. +-- See its relevant specs for authoritative details. +data Cookie + = MkCookie + { ckDomain :: String + , ckName :: String + , ckValue :: String + , ckPath :: Maybe String + , ckComment :: Maybe String + , ckVersion :: Maybe String + } + deriving(Show,Read) + +instance Eq Cookie where + a == b = ckDomain a == ckDomain b + && ckName a == ckName b + && ckPath a == ckPath b + +-- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header. +cookiesToHeader :: [Cookie] -> Header +cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs) + +-- | Turn a list of cookies into a key=value pair list, separated by +-- semicolons. +mkCookieHeaderValue :: [Cookie] -> String +mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1 + where + mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c + +-- | @cookieMatch (domain,path) ck@ performs the standard cookie +-- match wrt the given domain and path. +cookieMatch :: (String, String) -> Cookie -> Bool +cookieMatch (dom,path) ck = + ckDomain ck `isSuffixOf` dom && + case ckPath ck of + Nothing -> True + Just p -> p `isPrefixOf` path + + +-- | @processCookieHeaders dom hdrs@ +processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) +processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs + +-- | @headerToCookies dom hdr acc@ +headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = + case parse cookies "" val of + Left{} -> (val:accErr, accCookie) + Right x -> (accErr, x ++ accCookie) + where + cookies :: Parser [Cookie] + cookies = sepBy1 cookie (char ',') + + cookie :: Parser Cookie + cookie = + do name <- word + _ <- spaces_l + _ <- char '=' + _ <- spaces_l + val1 <- cvalue + args <- cdetail + return $ mkCookie name val1 args + + cvalue :: Parser String + + spaces_l = many (satisfy isSpace) + + cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return "" + + -- all keys in the result list MUST be in lower case + cdetail :: Parser [(String,String)] + cdetail = many $ + try (do _ <- spaces_l + _ <- char ';' + _ <- spaces_l + s1 <- word + _ <- spaces_l + s2 <- option "" (char '=' >> spaces_l >> cvalue) + return (map toLower s1,s2) + ) + + mkCookie :: String -> String -> [(String,String)] -> Cookie + mkCookie nm cval more = + MkCookie { ckName = nm + , ckValue = cval + , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) + , ckPath = lookup "path" more + , ckVersion = lookup "version" more + , ckComment = lookup "comment" more + } +headerToCookies _ _ acc = acc + + + + +word, quotedstring :: Parser String +quotedstring = + do _ <- char '"' -- " + str <- many (satisfy $ not . (=='"')) + _ <- char '"' + return str + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/HandleStream.hs @@ -0,0 +1,252 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.HandleStream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- A 'HandleStream'-based version of "Network.HTTP" interface. +-- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- not perform any kind of normalization prior to transmission (or receipt); you are +-- responsible for doing any such yourself, or, if you prefer, just switch to using +-- "Network.HTTP" function instead. +-- +----------------------------------------------------------------------------- +module Network.HTTP.HandleStream + ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) + , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) + , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) + , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) + , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty)) + , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO () + + , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString) + ) where + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.BufferType +import Network.Stream ( fmapE, Result ) +import Network.StreamDebugger ( debugByteStream ) +import Network.TCP (HStream(..), HandleStream ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim, readsOne ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Exception (onException) +import Control.Monad (when) + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + +-- | @simpleHTTP@ transmits a resource across a non-persistent connection. +simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty)) +simpleHTTP r = do + auth <- getAuth r + failHTTPS (rqURI r) + c <- openStream (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +-- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs +-- the HTTP operation via the debug file @debugFile@. +simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty)) +simpleHTTP_debug httpLogFile r = do + auth <- getAuth r + failHTTPS (rqURI r) + c0 <- openStream (host auth) (fromMaybe 80 (port auth)) + c <- debugByteStream httpLogFile c0 + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +simpleHTTP_ s r = sendHTTP s r + +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- closed upon receiving the response. +sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +sendHTTP conn rq = sendHTTP_notify conn rq (return ()) + +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + onException (sendMain conn rq onSendComplete) + (close conn) + where + providedClose = findConnClose (rqHeaders rq) + +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- Since we would wait forever, I have disabled use of 100-continue for now. +sendMain :: HStream ty + => HandleStream ty + -> Request ty + -> (IO ()) + -> IO (Result (Response ty)) +sendMain conn rqst onSendComplete = do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + -- TODO review throwing away of result + _ <- writeBlock conn (buf_fromStr bufferOps $ show rqst) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO review throwing away of result + _ <- writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst + + -- Hmmm, this could go bad if we keep getting "100 Continue" + -- responses... Except this should never happen according + -- to the RFC. + +switchResponse :: HStream ty + => HandleStream ty + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request ty + -> IO (Result (Response ty)) +switchResponse _ _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- if we attempt to use the same socket then there is an excellent + -- chance that the socket is not in a completely closed state. + +switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> do {- Time to send the body -} + writeBlock conn (rqBody rqst) >>= either (return . Left) + (\ _ -> do + rsp <- getResponseHead conn + switchResponse conn allow_retry True rsp rqst) + | otherwise -> do {- keep waiting -} + rsp <- getResponseHead conn + switchResponse conn allow_retry bdy_sent rsp rqst + + Retry -> do {- Request with "Expect" header failed. + Trouble is the request contains Expects + other than "100-Continue" -} + -- TODO review throwing away of result + _ <- writeBlock conn ((buf_append bufferOps) + (buf_fromStr bufferOps (show rqst)) + (rqBody rqst)) + rsp <- getResponseHead conn + switchResponse conn False bdy_sent rsp rqst + + Done -> do + when (findConnClose hdrs) + (closeOnEnd conn True) + return (Right $ Response cd rn hdrs (buf_empty bufferOps)) + + DieHorribly str -> do + close conn + return (responseParseError "Invalid response:" str) + ExpectEntity -> do + r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ + maybe (maybe (hopefulTransfer bo (readLine conn) []) + (\ x -> + readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized content-length value" x) + x) + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "sendHTTP")) + tc + case r of + Left{} -> do + close conn + return r + Right (Response _ _ hs _) -> do + when (findConnClose hs) + (closeOnEnd conn True) + return r + + where + tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + bo = bufferOps + +-- reads and parses headers +getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData) +getResponseHead conn = + fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) + (readTillEmpty1 bufferOps (readLine conn)) + +-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ +receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy)) +receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = do + fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es)) + (readTillEmpty1 bufferOps (readLine conn)) + + processRequest (rm,uri,hdrs) = + fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $ + maybe + (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer "" + (\ x -> readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized Content-Length value" x) + x) + + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "receiveHTTP")) + tc + where + -- FIXME : Also handle 100-continue. + tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + bo = bufferOps + +-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over +-- the 'HandleStream' @hStream@. It could be used to implement simple web +-- server interactions, performing the dual role to 'sendHTTP'. +respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () +respondHTTP conn rsp = do + -- TODO: review throwing away of result + _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO: review throwing away of result + _ <- writeBlock conn (rspBody rsp) + return () + +------------------------------------------------------------------------------ + +headerName :: String -> String +headerName x = map toLower (trim x) + +ifChunked :: a -> a -> String -> a +ifChunked a b s = + case headerName s of + "chunked" -> a + _ -> b + diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Headers.hs @@ -0,0 +1,461 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Headers +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- This module provides the data types for representing HTTP headers, and +-- operations for looking up header values and working with sequences of +-- header values in 'Request's and 'Response's. To avoid having to provide +-- separate set of operations for doing so, we introduce a type class 'HasHeaders' +-- to facilitate writing such processing using overloading instead. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Headers + ( HasHeaders(..) -- type class + + , Header(..) + , mkHeader -- :: HeaderName -> String -> Header + , hdrName -- :: Header -> HeaderName + , hdrValue -- :: Header -> String + + , HeaderName(..) + + , insertHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaders -- :: HasHeaders a => [Header] -> a -> a + , retrieveHeaders -- :: HasHeaders a => HeaderName -> a -> [Header] + , replaceHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String + , lookupHeader -- :: HeaderName -> [Header] -> Maybe String + + , parseHeader -- :: parseHeader :: String -> Result Header + , parseHeaders -- :: [String] -> Result [Header] + + , headerMap -- :: [(String, HeaderName)] + + , HeaderSetter + ) where + +import Data.Char (toLower) +import Network.Stream (Result, failParse) +import Network.HTTP.Utils ( trim, split, crlf ) + +-- | The @Header@ data type pairs header names & values. +data Header = Header HeaderName String + +hdrName :: Header -> HeaderName +hdrName (Header h _) = h + +hdrValue :: Header -> String +hdrValue (Header _ v) = v + +-- | Header constructor as a function, hiding above rep. +mkHeader :: HeaderName -> String -> Header +mkHeader = Header + +instance Show Header where + show (Header key value) = shows key (':':' ':value ++ crlf) + +-- | HTTP @HeaderName@ type, a Haskell data constructor for each +-- specification-defined header, prefixed with @Hdr@ and CamelCased, +-- (i.e., eliding the @-@ in the process.) Should you require using +-- a custom header, there's the @HdrCustom@ constructor which takes +-- a @String@ argument. +-- +-- Encoding HTTP header names differently, as Strings perhaps, is an +-- equally fine choice..no decidedly clear winner, but let's stick +-- with data constructors here. +-- +data HeaderName + -- Generic Headers -- + = HdrCacheControl + | HdrConnection + | HdrDate + | HdrPragma + | HdrTransferEncoding + | HdrUpgrade + | HdrVia + -- Request Headers -- + | HdrAccept + | HdrAcceptCharset + | HdrAcceptEncoding + | HdrAcceptLanguage + | HdrAuthorization + | HdrCookie + | HdrExpect + | HdrFrom + | HdrHost + | HdrIfModifiedSince + | HdrIfMatch + | HdrIfNoneMatch + | HdrIfRange + | HdrIfUnmodifiedSince + | HdrMaxForwards + | HdrProxyAuthorization + | HdrRange + | HdrReferer + | HdrUserAgent + -- Response Headers + | HdrAge + | HdrLocation + | HdrProxyAuthenticate + | HdrPublic + | HdrRetryAfter + | HdrServer + | HdrSetCookie + | HdrTE + | HdrTrailer + | HdrVary + | HdrWarning + | HdrWWWAuthenticate + -- Entity Headers + | HdrAllow + | HdrContentBase + | HdrContentEncoding + | HdrContentLanguage + | HdrContentLength + | HdrContentLocation + | HdrContentMD5 + | HdrContentRange + | HdrContentType + | HdrETag + | HdrExpires + | HdrLastModified + -- | MIME entity headers (for sub-parts) + | HdrContentTransferEncoding + -- | Allows for unrecognised or experimental headers. + | HdrCustom String -- not in header map below. + +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 diff --git a/Network/HTTP/MD5.hs b/Network/HTTP/MD5.hs deleted file mode 100644 --- a/Network/HTTP/MD5.hs +++ /dev/null @@ -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 --- and . --- ------------------------------------------------------------------------------ - -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:[]) diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs --- a/Network/HTTP/MD5Aux.hs +++ b/Network/HTTP/MD5Aux.hs @@ -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 diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Proxy.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Proxy +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Handling proxy server settings and their resolution. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Proxy + ( Proxy(..) + , noProxy -- :: Proxy + , fetchProxy -- :: Bool -> IO Proxy + , parseProxy -- :: String -> Maybe Proxy + ) where + +{- +#if !defined(WIN32) && defined(mingw32_HOST_OS) +#define WIN32 1 +#endif +-} + +import Control.Monad ( when, mplus, join, liftM2 ) + +#if defined(WIN32) +import Network.HTTP.Base ( catchIO ) +import Control.Monad ( liftM ) +import Data.List ( isPrefixOf ) +#endif +import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) +import Network.HTTP.Auth +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI, unEscapeString ) +import System.IO ( hPutStrLn, stderr ) +import System.Environment + +{- +#if !defined(WIN32) && defined(mingw32_HOST_OS) +#define WIN32 1 +#endif +-} + +#if defined(WIN32) +import System.Win32.Types ( DWORD, HKEY ) +import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, 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 diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Stream.hs @@ -0,0 +1,236 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Stream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Transmitting HTTP requests and responses holding @String@ in their payload bodies. +-- This is one of the implementation modules for the "Network.HTTP" interface, representing +-- request and response content as @String@s and transmitting them in non-packed form +-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles. +-- It is mostly here for backwards compatibility, representing how requests and responses +-- were transmitted up until the 4.x releases of the HTTP package. +-- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- not perform any kind of normalization prior to transmission (or receipt); you are +-- responsible for doing any such yourself, or, if you prefer, just switch to using +-- "Network.HTTP" function instead. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Stream + ( module Network.Stream + + , simpleHTTP -- :: Request_String -> IO (Result Response_String) + , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) + , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) + , respondHTTP -- :: Stream s => s -> Response_String -> IO () + + ) where + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.Stream +import Network.StreamDebugger (debugStream) +import Network.TCP (openTCPPort) +import Network.BufferType ( stringBufferOp ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Exception (onException) +import Control.Monad (when) + + +-- Turn on to enable HTTP traffic logging +debug :: Bool +debug = False + +-- File that HTTP traffic logs go to +httpLogFile :: String +httpLogFile = "http-debug.log" + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + + +-- | Simple way to transmit a resource across a non-persistent connection. +simpleHTTP :: Request_String -> IO (Result Response_String) +simpleHTTP r = do + auth <- getAuth r + c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) +simpleHTTP_ s r + | not debug = sendHTTP s r + | otherwise = do + s' <- debugStream httpLogFile s + sendHTTP s' r + +sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) +sendHTTP conn rq = sendHTTP_notify conn rq (return ()) + +sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + onException (sendMain conn rq onSendComplete) + (close conn) + where + providedClose = findConnClose (rqHeaders rq) + +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- Since we would wait forever, I have disabled use of 100-continue for now. +sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) +sendMain conn rqst onSendComplete = do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + -- TODO review throwing away of result + _ <- writeBlock conn (show rqst) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO review throwing away of result + _ <- writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst + +-- reads and parses headers +getResponseHead :: Stream s => s -> IO (Result ResponseData) +getResponseHead conn = do + lor <- readTillEmpty1 stringBufferOp (readLine conn) + return $ lor >>= parseResponseHead + +-- Hmmm, this could go bad if we keep getting "100 Continue" +-- responses... Except this should never happen according +-- to the RFC. +switchResponse :: Stream s + => s + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request_String + -> IO (Result Response_String) +switchResponse _ _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- if we attempt to use the same socket then there is an excellent + -- chance that the socket is not in a completely closed state. +switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> {- Time to send the body -} + do { val <- writeBlock conn (rqBody rqst) + ; case val of + Left e -> return (Left e) + Right _ -> + do { rsp <- getResponseHead conn + ; switchResponse conn allow_retry True rsp rqst + } + } + | otherwise -> {- keep waiting -} + do { rsp <- getResponseHead conn + ; switchResponse conn allow_retry bdy_sent rsp rqst + } + + Retry -> {- Request with "Expect" header failed. + Trouble is the request contains Expects + other than "100-Continue" -} + do { -- TODO review throwing away of result + _ <- writeBlock conn (show rqst ++ rqBody rqst) + ; rsp <- getResponseHead conn + ; switchResponse conn False bdy_sent rsp rqst + } + + Done -> do + when (findConnClose hdrs) + (closeOnEnd conn True) + return (Right $ Response cd rn hdrs "") + + DieHorribly str -> do + close conn + return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) + + ExpectEntity -> + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + in + do { rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer (readBlock conn) (read x :: Int) + Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer stringBufferOp + (readLine conn) (readBlock conn) + _ -> uglyDeathTransfer "sendHTTP" + ; case rslt of + Left e -> close conn >> return (Left e) + Right (ftrs,bdy) -> do + when (findConnClose (hdrs++ftrs)) + (closeOnEnd conn True) + return (Right (Response cd rn (hdrs++ftrs) bdy)) + } + +-- | Receive and parse a HTTP request from the given Stream. Should be used +-- for server side interactions. +receiveHTTP :: Stream s => s -> IO (Result Request_String) +receiveHTTP conn = getRequestHead >>= processRequest + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = + do { lor <- readTillEmpty1 stringBufferOp (readLine conn) + ; return $ lor >>= parseRequestHead + } + + processRequest (Left e) = return $ Left e + processRequest (Right (rm,uri,hdrs)) = + do -- FIXME : Also handle 100-continue. + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer (readBlock conn) (read x :: Int) + Nothing -> return (Right ([], "")) -- hopefulTransfer "" + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer stringBufferOp + (readLine conn) (readBlock conn) + _ -> uglyDeathTransfer "receiveHTTP" + + return $ do + (ftrs,bdy) <- rslt + return (Request uri rm (hdrs++ftrs) bdy) + +-- | Very simple function, send a HTTP response over the given stream. This +-- could be improved on to use different transfer types. +respondHTTP :: Stream s => s -> Response_String -> IO () +respondHTTP conn rsp = do -- TODO review throwing away of result + _ <- writeBlock conn (show rsp) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO review throwing away of result + _ <- writeBlock conn (rspBody rsp) + return () diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Utils.hs @@ -0,0 +1,207 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Utils +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Set of utility functions and definitions used by package modules. +-- +module Network.HTTP.Utils + ( trim -- :: String -> String + , trimL -- :: String -> String + , trimR -- :: String -> String + + , crlf -- :: String + , lf -- :: String + , sp -- :: String + + , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) + , splitBy -- :: Eq a => a -> [a] -> [[a]] + + , readsOne -- :: Read a => (a -> b) -> b -> String -> b + + , dropWhileTail -- :: (a -> Bool) -> [a] -> [a] + , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a]) + + , 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' diff --git a/Network/Stream.hs b/Network/Stream.hs --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -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 -- Stability : experimental -- Portability : non-portable (not tested) -- -- An library for creating abstract streams. Originally part of Gray's\/Bringert's -- HTTP module. -- +-- * Changes by Robin Bate Boerop : +-- - Removed unnecessary import statements. +-- - Moved Debug code to StreamDebugger.hs +-- - Moved Socket-related code to StreamSocket.hs. +-- -- * Changes by Simon Foster: --- - Split 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. diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs new file mode 100644 --- /dev/null +++ b/Network/StreamDebugger.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.StreamDebugger +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Implements debugging of @Stream@s. Originally part of Gray's\/Bringert's +-- HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Created. Made minor formatting changes. +-- +----------------------------------------------------------------------------- +module Network.StreamDebugger + ( StreamDebugger + , debugStream + , debugByteStream + ) where + +import Network.Stream (Stream(..)) +import System.IO + ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, + hSetBuffering, BufferMode(NoBuffering) + ) +import Network.TCP ( HandleStream, HStream, + StreamHooks(..), setStreamHooks, getStreamHooks ) + +-- | Allows stream logging. Refer to 'debugStream' below. +data StreamDebugger x + = Dbg Handle x + +instance (Stream x) => Stream (StreamDebugger x) where + readBlock (Dbg h x) n = + do val <- readBlock x n + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (show val) + return val + readLine (Dbg h x) = + do val <- readLine x + hPutStrLn h ("--readLine") + hPutStrLn h (show val) + return val + writeBlock (Dbg h x) str = + do val <- writeBlock x str + hPutStrLn h ("--writeBlock" ++ show str) + hPutStrLn h (show val) + return val + close (Dbg h x) = + do hPutStrLn h "--closing..." + hFlush h + close x + hPutStrLn h "--closed." + hClose h + closeOnEnd (Dbg h x) f = + do hPutStrLn h ("--close-on-end.." ++ show f) + hFlush h + closeOnEnd x f + +-- | Wraps a stream with logging I\/O. +-- The first argument is a filename which is opened in @AppendMode@. +debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a) +debugStream file stream = + do h <- openFile file AppendMode + hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") + return (Dbg h stream) + +debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty) +debugByteStream file stream = do + sh <- getStreamHooks stream + case sh of + Just h + | hook_name h == file -> return stream -- reuse the stream hooks. + _ -> do + h <- openFile file AppendMode + hSetBuffering h NoBuffering + hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") + setStreamHooks stream (debugStreamHooks h file) + return stream + +debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty +debugStreamHooks h nm = + StreamHooks + { hook_readBlock = \ toStr n val -> do + let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (either show show eval) + , hook_readLine = \ toStr val -> do + let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} + hPutStrLn h ("--readLine") + hPutStrLn h (either show show eval) + , hook_writeBlock = \ toStr str val -> do + hPutStrLn h ("--writeBlock " ++ show val) + hPutStrLn h (toStr str) + , hook_close = do + hPutStrLn h "--closing..." + hFlush h + hClose h + , hook_name = nm + } diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs new file mode 100644 --- /dev/null +++ b/Network/StreamSocket.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.StreamSocket +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Made dependencies explicit in import statements. +-- - Removed false dependencies in import statements. +-- - Created separate module for instance Stream Socket. +-- +-- * Changes by Simon Foster: +-- - Split module up into to 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) + diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -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 -- 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 diff --git a/test/Httpd.hs b/test/Httpd.hs new file mode 100644 --- /dev/null +++ b/test/Httpd.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP #-} + +module Httpd + ( Request, Response, Server + , mkResponse + , reqMethod, reqURI, reqHeaders, reqBody + , shed +#ifdef WARP_TESTS + , warp +#endif + ) + where + +import Control.Applicative +import Control.Arrow ( (***) ) +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans ( liftIO ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +#ifdef WARP_TESTS +import qualified Data.CaseInsensitive as CI +#endif +import Data.Maybe ( fromJust ) +import Network.URI ( URI, parseRelativeReference ) + +import Network.Socket + ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily + , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6) + , defaultProtocol, SocketType(Stream), listen, setSocketOption, SocketOption(ReuseAddr) + ) +#ifdef WARP_TESTS +#if MIN_VERSION_network(2,4,0) +import Network.Socket ( bind ) +#else +import Network.Socket ( bindSocket, Socket, SockAddr ) +#endif +#endif + +import qualified Network.Shed.Httpd as Shed + ( Request, Response(Response), initServer + , reqMethod, reqURI, reqHeaders, reqBody + ) +#ifdef WARP_TESTS +#if !MIN_VERSION_wai(3,0,0) +import qualified Data.Conduit.Lazy as Warp +#endif + +import qualified Network.HTTP.Types as Warp + ( Status(..) ) +import qualified Network.Wai as Warp +import qualified Network.Wai.Handler.Warp as Warp + ( runSettingsSocket, defaultSettings, setPort ) +#endif + +data Request = Request + { + reqMethod :: String, + reqURI :: URI, + reqHeaders :: [(String, String)], + reqBody :: String + } + +data Response = Response + { + respStatus :: Int, + respHeaders :: [(String, String)], + respBody :: String + } + +mkResponse :: Int -> [(String, String)] -> String -> Response +mkResponse = Response + +type Server = Int -> (Request -> IO Response) -> IO () + +shed :: Server +shed port handler = + () <$ Shed.initServer + port + (liftM responseToShed . handler . requestFromShed) + where + responseToShed (Response status hdrs body) = + Shed.Response status hdrs body + chomp = reverse . strip '\r' . reverse + strip c (c':str) | c == c' = str + strip c str = str + requestFromShed request = + Request + { + reqMethod = Shed.reqMethod request, + reqURI = Shed.reqURI request, + reqHeaders = map (id *** chomp) $ Shed.reqHeaders request, + reqBody = Shed.reqBody request + } + +#if !MIN_VERSION_bytestring(0,10,0) +instance NFData B.ByteString where + rnf = rnf . B.length +#endif + +#ifdef WARP_TESTS +#if !MIN_VERSION_network(2,4,0) +bind :: Socket -> SockAddr -> IO () +bind = bindSocket +#endif + +warp :: Bool -> Server +warp ipv6 port handler = do + addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) + (Just $ if ipv6 then "::1" else "127.0.0.1") + (Just . show $ port) + case addrinfos of + [] -> fail "Couldn't obtain address information in warp" + (addri:_) -> do + sock <- socket (addrFamily addri) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bind sock (addrAddress addri) + listen sock 5 +#if MIN_VERSION_wai(3,0,0) + Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do + request <- requestFromWarp warpRequest + response <- handler request + warpRespond (responseToWarp response) +#else + Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do + request <- requestFromWarp warpRequest + response <- handler request + return (responseToWarp response) +#endif + where + responseToWarp (Response status hdrs body) = + Warp.responseLBS + (Warp.Status status B.empty) + (map headerToWarp hdrs) + (BLC.pack body) + headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value) + headerFromWarp (name, value) = + (BC.unpack (CI.original name), BC.unpack value) + requestFromWarp request = do +#if MIN_VERSION_wai(3,0,1) + body <- fmap BLC.unpack $ Warp.strictRequestBody request +#else + body <- fmap BLC.unpack $ Warp.lazyRequestBody request + body `deepseq` return () +#endif + return $ + Request + { + reqMethod = BC.unpack (Warp.requestMethod request), + reqURI = fromJust . parseRelativeReference . + BC.unpack . Warp.rawPathInfo $ + request, + reqHeaders = map headerFromWarp (Warp.requestHeaders request), + reqBody = body + } +#endif diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -0,0 +1,69 @@ +module UnitTests ( unitTests ) where + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.URI + +import Data.Maybe ( fromJust ) + +import Test.Framework ( testGroup ) +import Test.Framework.Providers.HUnit +import Test.HUnit + +parseIPv4Address :: Assertion +parseIPv4Address = + assertEqual "127.0.0.1 address is recognised" + (Just (URIAuthority {user = Nothing, password = Nothing, host = "127.0.0.1", port = Just 5313})) + (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://127.0.0.1:5313/foo")))) + + +parseIPv6Address :: Assertion +parseIPv6Address = + assertEqual "::1 address" + (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313})) + (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo")))) + +customHeaderNameComparison :: Assertion +customHeaderNameComparison = + assertEqual "custom header name" (HdrCustom "foo") (HdrCustom "Foo") + +customHeaderLookup :: Assertion +customHeaderLookup = + let val = "header value" + h = Header (HdrCustom "foo") val + + in assertEqual "custom header lookup" (Just val) + (lookupHeader (HdrCustom "Foo") [h]) + +caseInsensitiveHeaderParse :: Assertion +caseInsensitiveHeaderParse = + let expected = [ Header HdrContentType "blah" + , Header (HdrCustom "X-Unknown") "unused" + ] + input = [ "content-type: blah" + , "X-Unknown: unused" + ] + + match actual = + length actual == length expected && + and [ hdrName a == hdrName b && hdrValue a == hdrValue b + | (a, b) <- zip expected actual + ] + + in case parseHeaders input of + Left _ -> assertFailure "Failed header parse" + Right actual -> assert (match actual) + +unitTests = + [testGroup "Unit tests" + [ testGroup "URI parsing" + [ testCase "Parse IPv4 address" parseIPv4Address + , testCase "Parse IPv6 address" parseIPv6Address + ] + ] + , testGroup "Header tests" + [ testCase "Custom header name case-insensitive match" customHeaderNameComparison + , testCase "Custom header lookup" customHeaderLookup + , testCase "Case-insensitive parsing" caseInsensitiveHeaderParse + ] + ] diff --git a/test/httpTests.hs b/test/httpTests.hs new file mode 100644 --- /dev/null +++ b/test/httpTests.hs @@ -0,0 +1,668 @@ +{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-} +import Control.Concurrent + +import Control.Applicative ((<$)) +import Control.Concurrent (threadDelay) +import Control.Exception (try) +import qualified Data.ByteString.Lazy.Char8 as BL (pack) +import Data.Char (isSpace) +import qualified Data.Digest.Pure.MD5 as MD5 (md5) +import Data.List.Split (splitOn) +import Data.Maybe (fromJust) +import System.IO.Error (userError) + +import qualified Httpd +import qualified UnitTests + +import Network.Browser +import Network.HTTP +import Network.HTTP.Base +import Network.HTTP.Auth +import Network.HTTP.Headers +import Network.Stream (Result) +import Network.URI (uriPath, parseURI) + +import System.Environment (getArgs) +import System.Info (os) +import System.IO (getChar) + +import Test.Framework (defaultMainWithArgs, testGroup) +import Test.Framework.Providers.HUnit +import Test.HUnit + + +basicGetRequest :: (?testUrl :: ServerAddress) => Assertion +basicGetRequest = do + response <- simpleHTTP (getRequest (?testUrl "/basic/get")) + code <- getResponseCode response + assertEqual "HTTP status code" (2, 0, 0) code + body <- getResponseBody response + assertEqual "Receiving expected response" "It works." body + +basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion +basicGetRequestLBS = do + response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get"))))) + code <- getResponseCode response + assertEqual "HTTP status code" (2, 0, 0) code + body <- getResponseBody response + assertEqual "Receiving expected response" (BL.pack "It works.") body + +basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion +basicHeadRequest = do + response <- simpleHTTP (headRequest (?testUrl "/basic/head")) + code <- getResponseCode response + assertEqual "HTTP status code" (2, 0, 0) code + body <- getResponseBody response + -- the body should be empty, since this is a HEAD request + assertEqual "Receiving expected response" "" body + +basicExample :: (?testUrl :: ServerAddress) => Assertion +basicExample = do + result <- + -- sample code from Network.HTTP haddock, with URL changed + -- Note there's also a copy of the example in the .cabal file + simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody + assertEqual "Receiving expected response" (take 100 haskellOrgText) result + +secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion +secureGetRequest = do + response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything")) + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show response) -- fmap show because Response isn't in Eq + +basicPostRequest :: (?testUrl :: ServerAddress) => Assertion +basicPostRequest = do + let sendBody = "body" + response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post") + "text/plain" + sendBody + code <- getResponseCode response + assertEqual "HTTP status code" (2, 0, 0) code + body <- getResponseBody response + assertEqual "Receiving expected response" + (show (Just "text/plain", Just "4", sendBody)) + body + +userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion +userpwAuthFailure = do + response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic")) + code <- getResponseCode response + body <- getResponseBody response + assertEqual "HTTP status code" ((4, 0, 1), + "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body) + -- in case of 401, the server returns the contents of the Authz header + +userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion +userpwAuthSuccess = do + response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic")) + code <- getResponseCode response + body <- getResponseBody response + assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) + +basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion +basicAuthFailure = do + response <- simpleHTTP (getRequest (?testUrl "/auth/basic")) + code <- getResponseCode response + body <- getResponseBody response + assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body) + +credentialsBasic :: (?testUrl :: ServerAddress) => Authority +credentialsBasic = AuthBasic "Testing realm" "test" "password" + (fromJust . parseURI . ?testUrl $ "/auth/basic") + +basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion +basicAuthSuccess = do + let req = getRequest (?testUrl "/auth/basic") + let authString = withAuthority credentialsBasic req + let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req } + response <- simpleHTTP reqWithAuth + code <- getResponseCode response + body <- getResponseBody response + assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) + +utf8URLEncode :: Assertion +utf8URLEncode = do + assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com" + assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD" + assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE" + +utf8URLDecode :: Assertion +utf8URLDecode = do + assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com" + assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow" + assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好" + assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо" + +browserExample :: (?testUrl :: ServerAddress) => Assertion +browserExample = do + result <- + -- sample code from Network.Browser haddock, with URL changed + -- Note there's also a copy of the example in the .cabal file + do + (_, rsp) + <- Network.Browser.browse $ do + setAllowRedirects True -- handle HTTP redirects + request $ getRequest (?testUrl "/browser/example") + return (take 100 (rspBody rsp)) + assertEqual "Receiving expected response" (take 100 haskellOrgText) result + +-- A vanilla HTTP request using Browser shouldn't send a cookie header +browserNoCookie :: (?testUrl :: ServerAddress) => Assertion +browserNoCookie = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + request $ getRequest (?testUrl "/browser/no-cookie") + let code = rspCode response + assertEqual "HTTP status code" (2, 0, 0) code + + +-- Regression test +-- * Browser sends vanilla request to server +-- * Server sets one cookie "hello=world" +-- * Browser sends a second request +-- +-- Expected: Server gets single cookie with "hello=world" +-- Actual: Server gets 3 extra cookies, which are actually cookie attributes: +-- "$Version=0;hello=world;$Domain=localhost:8080\r" +browserOneCookie :: (?testUrl :: ServerAddress) => Assertion +browserOneCookie = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + -- This first requests returns a single Set-Cookie: hello=world + _ <- request $ getRequest (?testUrl "/browser/one-cookie/1") + + -- This second request should send a single Cookie: hello=world + request $ getRequest (?testUrl "/browser/one-cookie/2") + let body = rspBody response + assertEqual "Receiving expected response" "" body + let code = rspCode response + assertEqual "HTTP status code" (2, 0, 0) code + +browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion +browserTwoCookies = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + -- This first request returns two cookies + _ <- request $ getRequest (?testUrl "/browser/two-cookies/1") + + -- This second request should send them back + request $ getRequest (?testUrl "/browser/two-cookies/2") + let body = rspBody response + assertEqual "Receiving expected response" "" body + let code = rspCode response + assertEqual "HTTP status code" (2, 0, 0) code + + +browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion +browserFollowsRedirect n = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") + assertEqual "Receiving expected response from server" + ((2, 0, 0), "It works.") + (rspCode response, rspBody response) + +browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion +browserReturnsRedirect n = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") + assertEqual "Receiving expected response from server" + ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "") + (rspCode response, rspBody response) + +authGenBasic _ "Testing realm" = return $ Just ("test", "password") +authGenBasic _ realm = fail $ "Unexpected realm " ++ realm + +browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion +browserBasicAuth = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + + setAuthorityGen authGenBasic + + request $ getRequest (?testUrl "/auth/basic") + + assertEqual "Receiving expected response from server" + ((2, 0, 0), "Here's the secret") + (rspCode response, rspBody response) + +authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword") +authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm + +browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion +browserDigestAuth = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + + setAuthorityGen authGenDigest + + request $ getRequest (?testUrl "/auth/digest") + + assertEqual "Receiving expected response from server" + ((2, 0, 0), "Here's the digest secret") + (rspCode response, rspBody response) + + + +browserAlt :: (?altTestUrl :: ServerAddress) => Assertion +browserAlt = do + (response) <- browse $ do + + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") + + return response1 + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response, rspBody response) + +-- test that requests to multiple servers on the same host +-- don't get confused with each other +browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion +browserBoth = do + (response1, response2) <- browse $ do + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?testUrl "/basic/get") + (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") + + return (response1, response2) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response2, rspBody response2) + +-- test that requests to multiple servers on the same host +-- don't get confused with each other +browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion +browserBothReversed = do + (response1, response2) <- browse $ do + setOutHandler (const $ return ()) + + (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") + (_, response1) <- request $ getRequest (?testUrl "/basic/get") + + return (response1, response2) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response2, rspBody response2) + +browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion +browserSecureRequest = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + + request $ getRequest (?secureTestUrl "/anything") + + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show res) -- fmap show because Response isn't in Eq + +-- in case it tries to reuse the connection +browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion +browserSecureRequestAfterInsecure = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + + request $ getRequest (?testUrl "/basic/get") + request $ getRequest (?secureTestUrl "/anything") + + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show res) -- fmap show because Response isn't in Eq + +browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion +browserRedirectToSecure = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + setErrHandler fail + + request $ getRequest (?testUrl "/browser/redirect/secure/301/anything") + + assertEqual "Threw expected exception" + (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything")) + (fmap show res) -- fmap show because Response isn't in Eq + +browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion +browserTwoRequests = do + (response1, response2) <- browse $ do + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?testUrl "/basic/get") + (_, response2) <- request $ getRequest (?testUrl "/basic/get2") + + return (response1, response2) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works (2).") + (rspCode response2, rspBody response2) + + +browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion +browserTwoRequestsAlt = do + (response1, response2) <- browse $ do + + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") + (_, response2) <- request $ getRequest (?altTestUrl "/basic/get2") + + return (response1, response2) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server (2).") + (rspCode response2, rspBody response2) + +browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion +browserTwoRequestsBoth = do + (response1, response2, response3, response4) <- browse $ do + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?testUrl "/basic/get") + (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") + (_, response3) <- request $ getRequest (?testUrl "/basic/get2") + (_, response4) <- request $ getRequest (?altTestUrl "/basic/get2") + + return (response1, response2, response3, response4) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response2, rspBody response2) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works (2).") + (rspCode response3, rspBody response3) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server (2).") + (rspCode response4, rspBody response4) + +hasPrefix :: String -> String -> Maybe String +hasPrefix [] ys = Just ys +hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys +hasPrefix _ _ = Nothing + +maybeRead :: Read a => String -> Maybe a +maybeRead s = + case reads s of + [(v, "")] -> Just v + _ -> Nothing + +splitFields = map (toPair '=' . trim isSpace) . splitOn "," + +toPair c str = case break (==c) str of + (left, _:right) -> (left, right) + _ -> error $ "No " ++ show c ++ " in " ++ str +trim f = dropWhile f . reverse . dropWhile f . reverse + +isSubsetOf xs ys = all (`elem` ys) xs + +-- first bits of result text from haskell.org (just to give some representative text) +haskellOrgText = + "\ +\\t\ +\\t\ +\\t\t\ +\\t\t\t\t" + +digestMatch + username realm password + nonce opaque + method relativeURI makeAbsolute + headers + = + common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers) + where + common = [("username", show username), ("realm", show realm), ("nonce", show nonce), + ("opaque", show opaque)] + md5 = show . MD5.md5 . BL.pack + ha1 = md5 (username++":"++realm++":"++password) + ha2 uri = md5 (method++":"++uri) + response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri) + mkUncommon uri hash = [("uri", show uri), ("response", show hash)] + relative = mkUncommon relativeURI (response relativeURI) + absoluteURI = makeAbsolute relativeURI + absolute = mkUncommon absoluteURI (response absoluteURI) + +processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) + => Httpd.Request + -> IO Httpd.Response +processRequest req = do + case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of + ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works." + ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)." + ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." + ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." + ("POST", "/basic/post") -> + let typ = lookup "Content-Type" (Httpd.reqHeaders req) + len = lookup "Content-Length" (Httpd.reqHeaders req) + body = Httpd.reqBody req + in return $ Httpd.mkResponse 200 [] (show (typ, len, body)) + + ("GET", "/basic/example") -> + return $ Httpd.mkResponse 200 [] haskellOrgText + + ("GET", "/auth/basic") -> + case lookup "Authorization" (Httpd.reqHeaders req) of + Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret" + x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x) + + ("GET", "/auth/digest") -> + case lookup "Authorization" (Httpd.reqHeaders req) of + Just (hasPrefix "Digest " -> Just (splitFields -> items)) + | digestMatch "test" "Digest testing realm" "digestpassword" + "87e4" "057d" + "GET" "/auth/digest" ?testUrl + items + -> return $ Httpd.mkResponse 200 [] "Here's the digest secret" + x -> return $ Httpd.mkResponse + 401 + [("WWW-Authenticate", + "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")] + (show x) + + ("GET", "/browser/example") -> + return $ Httpd.mkResponse 200 [] haskellOrgText + ("GET", "/browser/no-cookie") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + Nothing -> return $ Httpd.mkResponse 200 [] "" + Just s -> return $ Httpd.mkResponse 500 [] s + ("GET", "/browser/one-cookie/1") -> + return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] "" + ("GET", "/browser/one-cookie/2") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + Just "hello=world" -> return $ Httpd.mkResponse 200 [] "" + Just s -> return $ Httpd.mkResponse 500 [] s + Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) + ("GET", "/browser/two-cookies/1") -> + return $ Httpd.mkResponse 200 + [("Set-Cookie", "hello=world") + ,("Set-Cookie", "goodbye=cruelworld")] + "" + ("GET", "/browser/two-cookies/2") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + -- TODO generalise the cookie parsing to allow for whitespace/ordering variations + Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] "" + Just s -> return $ Httpd.mkResponse 500 [] s + Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) + ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.mkResponse n [("Location", rest)] "" + ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.mkResponse n [("Location", ?testUrl rest)] "" + ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] "" + _ -> return $ Httpd.mkResponse 500 [] "Unknown request" + +altProcessRequest :: Httpd.Request -> IO Httpd.Response +altProcessRequest req = do + case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of + ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server." + ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)." + _ -> return $ Httpd.mkResponse 500 [] "Unknown request" + +maybeTestGroup True name xs = testGroup name xs +maybeTestGroup False name _ = testGroup name [] + +basicTests = + testGroup "Basic tests" + [ testCase "Basic GET request" basicGetRequest + , testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS + , testCase "Network.HTTP example code" basicExample + , testCase "Secure GET request" secureGetRequest + , testCase "Basic POST request" basicPostRequest + , testCase "Basic HEAD request" basicHeadRequest + , testCase "URI user:pass Auth failure" userpwAuthFailure + , testCase "URI user:pass Auth success" userpwAuthSuccess + , testCase "Basic Auth failure" basicAuthFailure + , testCase "Basic Auth success" basicAuthSuccess + , testCase "UTF-8 urlEncode" utf8URLEncode + , testCase "UTF-8 urlDecode" utf8URLDecode + ] + +browserTests = + testGroup "Browser tests" + [ testGroup "Basic" + [ + testCase "Network.Browser example code" browserExample + , testCase "Two requests" browserTwoRequests + ] + , testGroup "Secure" + [ + testCase "Secure request" browserSecureRequest + , testCase "After insecure" browserSecureRequestAfterInsecure + , testCase "Redirection" browserRedirectToSecure + ] + , testGroup "Cookies" + [ testCase "No cookie header" browserNoCookie + , testCase "One cookie" browserOneCookie + , testCase "Two cookies" browserTwoCookies + ] + , testGroup "Redirection" + [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection + -- 300 Multiple Choices: client has to handle this + testCase "300" (browserReturnsRedirect 300) + -- 301 Moved Permanently: should follow + , testCase "301" (browserFollowsRedirect 301) + -- 302 Found: should follow + , testCase "302" (browserFollowsRedirect 302) + -- 303 See Other: should follow (directly for GETs) + , testCase "303" (browserFollowsRedirect 303) + -- 304 Not Modified: maybe Browser could do something intelligent based on + -- being given locally cached content and sending If-Modified-Since, but it + -- doesn't at the moment + , testCase "304" (browserReturnsRedirect 304) + -- 305 Use Proxy: test harness doesn't have a proxy (yet) + -- 306 Switch Proxy: obsolete + -- 307 Temporary Redirect: should follow + , testCase "307" (browserFollowsRedirect 307) + -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this + , testCase "308" (browserReturnsRedirect 308) + ] + , testGroup "Authentication" + [ testCase "Basic" browserBasicAuth + , testCase "Digest" browserDigestAuth + ] + ] + +port80Tests = + testGroup "Multiple servers" + [ testCase "Alternate server" browserAlt + , testCase "Both servers" browserBoth + , testCase "Both servers (reversed)" browserBothReversed + , testCase "Two requests - alternate server" browserTwoRequestsAlt + , testCase "Two requests - both servers" browserTwoRequestsBoth + ] + +data InetFamily = IPv4 | IPv6 + +familyToLocalhost :: InetFamily -> String +familyToLocalhost IPv4 = "127.0.0.1" +familyToLocalhost IPv6 = "[::1]" + +urlRoot :: InetFamily -> String -> Int -> String +urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam +urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n + +secureRoot :: InetFamily -> String -> Int -> String +secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam +secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n + +type ServerAddress = String -> String + +httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress +httpAddress fam userpw port p = urlRoot fam userpw port ++ p +httpsAddress fam userpw port p = secureRoot fam userpw port ++ p + +main :: IO () +main = do + args <- getArgs + + let servers = + [ ("httpd-shed", Httpd.shed, IPv4) +#ifdef WARP_TESTS + , ("warp.v6", Httpd.warp True, IPv6) + , ("warp.v4", Httpd.warp False, IPv4) +#endif + ] + basePortNum, altPortNum :: Int + basePortNum = 5812 + altPortNum = 80 + numberedServers = zip [basePortNum..] servers + + let setupNormalTests = do + flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do + let ?testUrl = httpAddress family "" portNum + ?userpwUrl = httpAddress family "test:password@" portNum + ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum + ?secureTestUrl = httpsAddress family "" portNum + _ <- forkIO $ server portNum processRequest + return $ testGroup serverName [basicTests, browserTests] + + let setupAltTests = do + let (portNum, (_, server,family)) = head numberedServers + let ?testUrl = httpAddress family "" portNum + ?altTestUrl = httpAddress family "" altPortNum + _ <- forkIO $ server altPortNum altProcessRequest + return port80Tests + + case args of + ["server"] -> do -- run only the harness servers for diagnostic/debug purposes + -- halt on any keypress + _ <- setupNormalTests + _ <- setupAltTests + _ <- getChar + return () + ("--withport80":args) -> do + normalTests <- setupNormalTests + altTests <- setupAltTests + _ <- threadDelay 1000000 -- Give the server time to start :-( + defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args + args -> do -- run the test harness as normal + normalTests <- setupNormalTests + _ <- threadDelay 1000000 -- Give the server time to start :-( + defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args