diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,11 +1,10 @@ -Name: HTTP -Version: 3001.1.5 -Cabal-Version: >= 1.2 -Build-type: Simple -License: BSD3 -License-file: LICENSE -Category: Network -Copyright: +Name: HTTP +Version: 4000.0.0 +Cabal-Version: >= 1.2 +Build-type: Simple +License: BSD3 +License-file: LICENSE +Copyright: Copyright (c) 2002, Warrick Gray Copyright (c) 2002-2005, Ian Lynagh Copyright (c) 2003-2006, Bjorn Bringert @@ -13,34 +12,49 @@ Copyright (c) 2004, Ganesh Sittampalam Copyright (c) 2004-2005, Dominic Steinitz Copyright 2007 Robin Bate Boerop -Author: Warrick Gray -Maintainer: Bjorn Bringert -Homepage: http://www.haskell.org/http/ -Description: A library for client-side HTTP -Synopsis: A library for client-side HTTP +Author: Warrick Gray +Maintainer: Sigbjorn Finne +Homepage: http://www.haskell.org/http/ +Description: + A library for client-side HTTP, version 2. Rewrite of existing HTTP + package to allow overloaded representation of HTTP request bodies + and responses. Provides three such instances: lazy and strict 'ByteString', + along with the good old @String@. + + + Inspired in part by Jonas Aadahl et al's work on ByteString'ifying HTTP + a couple of years ago. + + + Git repository available at + Flag old-base description: Old, monolithic base default: False Library Exposed-modules: + Network.BufferType, Network.Stream, Network.StreamDebugger, Network.StreamSocket, Network.TCP, Network.HTTP, Network.HTTP.Headers, + Network.HTTP.Base, + Network.HTTP.Stream, + Network.HTTP.HandleStream, Network.Browser Other-modules: Network.HTTP.Base64, Network.HTTP.MD5, - Network.HTTP.MD5Aux - GHC-options: -fwarn-missing-signatures - Extensions: DeriveDataTypeable - Build-depends: network, parsec + Network.HTTP.MD5Aux, + Network.HTTP.Utils + GHC-options: -fwarn-missing-signatures -Wall + Build-depends: network, parsec, bytestring if flag(old-base) Build-depends: base < 3 else - Build-depends: base >= 3 && < 4, array + Build-depends: base >= 3, array diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -31,7 +31,7 @@ module Network.Browser ( BrowserState, BrowserAction, -- browser monad, effectively a state monad. - Cookie(..), + Cookie, Form(..), Proxy(..), @@ -76,17 +76,20 @@ import Network.URI ( URI(uriAuthority, uriScheme, uriPath, uriQuery) - , URIAuth(URIAuth, uriUserInfo, uriPort, uriRegName) + , URIAuth(..) , parseURI, parseURIReference, relativeTo ) -import Network.StreamDebugger (debugStream) -import Network.TCP (Connection, isConnectedTo) +import Network.StreamDebugger (debugByteStream) import Network.HTTP import qualified Network.HTTP.MD5 as MD5 (hash) import qualified Network.HTTP.Base64 as Base64 (encode) +import Network.Stream ( ConnError(..) ) +import Network.BufferType +import Network.HTTP.Utils ( trim, splitBy ) + import Data.Char (toLower,isAlphaNum,isSpace) -import Data.List (isPrefixOf,isSuffixOf,elemIndex,elemIndices) +import Data.List (isPrefixOf,isSuffixOf) import Data.Maybe (fromMaybe, listToMaybe, catMaybes, fromJust, isJust) import Control.Monad (foldM, filterM, liftM, when) import Text.ParserCombinators.Parsec @@ -108,7 +111,7 @@ word, quotedstring :: Parser String quotedstring = - do { char '"' + do { char '"' -- " ; str <- many (satisfy $ not . (=='"')) ; char '"' ; return str @@ -116,31 +119,7 @@ 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 @@ -181,7 +160,7 @@ defaultCookieFilter :: URI -> Cookie -> IO Bool -defaultCookieFilter url cky = return True +defaultCookieFilter _url _cky = return True userCookieFilter :: URI -> Cookie -> IO Bool userCookieFilter url cky = @@ -230,59 +209,62 @@ cookie :: Parser Cookie cookie = do { name <- word - ; spaces + ; spaces_l ; char '=' - ; spaces - ; val <- cvalue + ; spaces_l + ; val1 <- cvalue ; args <- cdetail - ; return $ mkCookie name val args + ; return $ mkCookie name val1 args } cvalue :: Parser String - spaces = many (satisfy isSpace) + spaces_l = many (satisfy isSpace) - cvalue = quotedstring <|> many (satisfy $ not . (==';')) + 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 + try (do { spaces_l ; char ';' - ; spaces + ; spaces_l ; s1 <- word - ; spaces - ; s2 <- option "" (do { char '=' ; spaces ; v <- cvalue ; return v }) + ; spaces_l + ; s2 <- option "" (do { char '=' ; spaces_l ; 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 - } + 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 _ _ = [] + -- | Adds a cookie to the browser state, removing duplicates. -addCookie :: Cookie -> BrowserAction () +addCookie :: Cookie -> BrowserAction t () addCookie c = alterBS (\b -> b { bsCookies=c : fn (bsCookies b) }) where fn = filter (not . (==c)) -setCookies :: [Cookie] -> BrowserAction () +setCookies :: [Cookie] -> BrowserAction t () setCookies cs = alterBS (\b -> b { bsCookies=cs }) -getCookies :: BrowserAction [Cookie] +getCookies :: BrowserAction t [Cookie] getCookies = getBS bsCookies -- ...get domain specific cookies... -- ... this needs changing for consistency with rfc2109... -- ... currently too broad. -getCookiesFor :: String -> String -> BrowserAction [Cookie] +getCookiesFor :: String -> String -> BrowserAction t [Cookie] getCookiesFor dom path = do cks <- getCookies return (filter cookiematch cks) @@ -294,10 +276,10 @@ Just p -> p `isPrefixOf` path -setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction () +setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f }) -getCookieFilter :: BrowserAction (URI -> Cookie -> IO Bool) +getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) getCookieFilter = getBS bsCookieFilter ------------------------------------------------------------------ @@ -312,8 +294,8 @@ 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 do nothing - which means to not retry with a new username/password combination) + "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 @@ -370,7 +352,7 @@ headerToChallenge :: URI -> Header -> Maybe Challenge headerToChallenge baseURI (Header _ str) = case parse challenge "" str of - Left e -> Nothing + Left{} -> Nothing Right (name,props) -> case name of "basic" -> mkBasic props "digest" -> mkDigest props @@ -395,13 +377,6 @@ ; 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) @@ -431,14 +406,14 @@ -- Change These: readQop :: String -> [Qop] - readQop = catMaybes . (map strToQop) . (splitMany ',') + readQop = catMaybes . (map strToQop) . (splitBy ',') - strToQop str = case map toLower (trim str) of + strToQop qs = case map toLower (trim qs) of "auth" -> Just QopAuth "auth-int" -> Just QopAuthInt _ -> Nothing - readAlgorithm str = case map toLower (trim str) of + readAlgorithm astr = case map toLower (trim astr) of "md5" -> Just AlgMD5 "md5-sess" -> Just AlgMD5sess _ -> Nothing @@ -462,7 +437,7 @@ -- | Return authorities for a given domain and path. -- Assumes "dom" is lower case -getAuthFor :: String -> String -> BrowserAction [Authority] +getAuthFor :: String -> String -> BrowserAction t [Authority] getAuthFor dom pth = do { list <- getAuthorities ; return (filter match list) @@ -477,22 +452,22 @@ -- | Interacting with browser state: -getAuthorities :: BrowserAction [Authority] +getAuthorities :: BrowserAction t [Authority] getAuthorities = getBS bsAuthorities -setAuthorities :: [Authority] -> BrowserAction () +setAuthorities :: [Authority] -> BrowserAction t () setAuthorities as = alterBS (\b -> b { bsAuthorities=as }) -addAuthority :: Authority -> BrowserAction () +addAuthority :: Authority -> BrowserAction t () addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b }) -getAuthorityGen :: BrowserAction (URI -> String -> IO (Maybe (String,String))) +getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) getAuthorityGen = getBS bsAuthorityGen -setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction () +setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f }) -setAllowBasicAuth :: Bool -> BrowserAction () +setAllowBasicAuth :: Bool -> BrowserAction t () setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba }) @@ -505,7 +480,7 @@ -- | Retrieve a likely looking authority for a Request. -anticipateChallenge :: Request -> BrowserAction (Maybe Authority) +anticipateChallenge :: HTTPRequest ty -> BrowserAction t (Maybe Authority) anticipateChallenge rq = let uri = rqURI rq in do { authlist <- getAuthFor (uriToAuthorityString uri) (uriPath uri) @@ -514,7 +489,7 @@ -- | Asking the user to respond to a challenge -challengeToAuthority :: URI -> Challenge -> BrowserAction (Maybe Authority) +challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) challengeToAuthority uri ch = -- prompt user for authority if answerable ch then @@ -528,7 +503,7 @@ where answerable :: Challenge -> Bool answerable (ChalBasic _) = True - answerable ch = (chAlgorithm ch) == Just AlgMD5 + answerable chall = (chAlgorithm chall) == Just AlgMD5 buildAuth :: Challenge -> String -> String -> Authority buildAuth (ChalBasic r) u p = @@ -541,7 +516,7 @@ -- 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 = + buildAuth (ChalDigest r d n o _stale a q) u p = AuthDigest { auRealm=r , auUsername=u , auPassword=p @@ -557,12 +532,11 @@ -- 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 :: Authority -> HTTPRequest ty -> String withAuthority a rq = case a of - AuthBasic _ _ user pass -> - "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) - AuthDigest _ _ _ _ _ _ _ _ -> - "Digest username=\"" ++ auUsername a + AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) + AuthDigest{} -> + "Digest username=\"" ++ auUsername a -- " ++ "\",realm=\"" ++ auRealm a ++ "\",nonce=\"" ++ auNonce a ++ "\",uri=\"" ++ digesturi @@ -577,19 +551,6 @@ ++ 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 @@ -605,7 +566,23 @@ digesturi = show (rqURI rq) noncevalue = auNonce a +-- 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) + + ------------------------------------------------------------------ ------------------ Proxy Stuff ----------------------------------- ------------------------------------------------------------------ @@ -620,368 +597,370 @@ ------------------------------------------------------------------ -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 - } +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 + , bsConnectionPool :: [connection] + , bsProxy :: Proxy + , bsDebug :: Maybe String + } -instance Show BrowserState where +instance Show (BrowserState t) where show bs = "BrowserState { " - ++ show (bsCookies bs) ++ "\n" + ++ shows (bsCookies bs) ("\n" {- ++ show (bsAuthorities bs) ++ "\n"-} - ++ "AllowRedirects: " ++ show (bsAllowRedirects bs) - ++ "} " + ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") -- Simple DIY stateful behaviour, with IO -data BrowserAction a = BA { lift :: (BrowserState -> IO (BrowserState,a)) } +data BrowserAction conn a + = BA { lift :: BrowserState conn -> IO (BrowserState conn,a) } -instance Monad BrowserAction where +instance Monad (BrowserAction conn) where a >>= f = BA (\b -> do { (nb,v) <- lift a b ; lift (f v) nb}) return x = BA (\b -> return (b,x)) -instance Functor BrowserAction where +instance Functor (BrowserAction conn) where fmap f = liftM f - -- | Apply a browser action to a state. -browse :: BrowserAction a -> IO a -browse act = do (bs, x) <- lift act defaultBrowserState - closePooledConnections bs - return x - where - defaultBrowserState :: BrowserState - defaultBrowserState = - BS { bsErr = putStrLn - , bsOut = putStrLn - , bsCookies = [] - , bsCookieFilter = defaultCookieFilter - , bsAuthorityGen = \_ _ -> return Nothing - , bsAuthorities = [] - , bsAllowRedirects = True - , bsAllowBasicAuth = False - , bsConnectionPool = [] - , bsProxy = NoProxy - , bsDebug = Nothing - } +browse :: BrowserAction conn a -> IO a +browse act = do x <- lift act defaultBrowserState + return (snd x) --- | --- Close all connections that are in bs' connection pool. --- This should have some sort of exception handling, soldier on until --- all the connections have been closed. Not sure about portability --- issues. -closePooledConnections :: BrowserState -> IO () -closePooledConnections = mapM_ close . bsConnectionPool +defaultBrowserState :: BrowserState t +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 :: (BrowserState t -> BrowserState t) -> BrowserAction t () alterBS f = BA (\b -> return (f b,())) -getBS :: (BrowserState -> a) -> BrowserAction a +getBS :: (BrowserState t -> a) -> BrowserAction t a getBS f = BA (\b -> return (b,f b)) -- | Do an io action -ioAction :: IO a -> BrowserAction a +ioAction :: IO a -> BrowserAction t a ioAction a = BA (\b -> a >>= \v -> return (b,v)) - -- Stream handlers -setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction () +setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction t () setErrHandler h = alterBS (\b -> b { bsErr=h }) setOutHandler h = alterBS (\b -> b { bsOut=h }) -out, err :: String -> BrowserAction () +out, err :: String -> BrowserAction t () out s = do { f <- getBS bsOut ; ioAction $ f s } err s = do { f <- getBS bsErr ; ioAction $ f s } -- Redirects -setAllowRedirects :: Bool -> BrowserAction () +setAllowRedirects :: Bool -> BrowserAction t () setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl}) -getAllowRedirects :: BrowserAction Bool +getAllowRedirects :: BrowserAction t Bool getAllowRedirects = getBS bsAllowRedirects -- Proxy -setProxy :: Proxy -> BrowserAction () +setProxy :: Proxy -> BrowserAction t () setProxy p = alterBS (\b -> b {bsProxy = p}) -getProxy :: BrowserAction Proxy +getProxy :: BrowserAction t Proxy getProxy = getBS bsProxy -- Debug -setDebugLog :: Maybe String -> BrowserAction () +setDebugLog :: Maybe String -> BrowserAction t () 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 - ) - +data RequestState + = RequestState + { reqDenies :: Int -- ^ number of 401 responses so far + , reqRedirects :: Int -- ^ number of redirects so far + , reqRetries :: Int -- ^ number of retrys so far + , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response + } +nullRequestState :: RequestState +nullRequestState = RequestState + { reqDenies = 0 + , reqRedirects = 0 + , reqRetries = 0 + , reqStopOnDeny = True + } --- Surely the most important bit: -request :: Request -> BrowserAction (URI,Response) -request = request' initialState - where - initialState = (0,0,0,True) +-- limits we are willing to not go beyond for method retries and number of auth deny responses. +maxRetries :: Int +maxRetries = 4 +maxDenies :: Int +maxDenies = 2 -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' +-- Surely the most important bit: +request :: HStream ty + => HTTPRequest ty + -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty) +request req = request' nullVal initialState req + where + initialState = nullRequestState + nullVal = buf_empty bufferOps - p <- getProxy +request' :: HStream ty + => ty + -> RequestState + -> HTTPRequest ty + -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty) +request' nullVal rqState 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 (reqStopOnDeny rqState) + then return rq + else do + auth <- anticipateChallenge rq + case auth of + Nothing -> return rq + Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) + let rq'' = insertHeaders (map cookieToHeader cookies) rq' + 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'' - -- 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). - proxyURIAuth = - maybe notURI - (\parsed -> maybe notURI - id (uriAuthority parsed)) - (parseURI str) - notURI = - -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! - let (host, port) = span (':'/=) str - in - if null port || null host - then URIAuth "" str "" - else URIAuth "" host port - in - do - out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth - dorequest proxyURIAuth 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) + out ("Sending:\n" ++ show rq'') + e_rsp <- + case p of + NoProxy -> dorequest (uriAuth $ rqURI rq'') rq'' + Proxy str ath -> do + let rq''' = maybe rq'' + (\x -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq'') + ath + 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) - -- add new cookies to browser state - let cookieheaders = retrieveHeaders HdrSetCookie rsp - let newcookies = concat (map (headerToCookies $ uriToAuthorityString uri) cookieheaders) + out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth + dorequest proxyURIAuth rq''' + case e_rsp of + Left v + | (reqRetries rqState < maxRetries) && (v == ErrorReset || v == ErrorClosed) -> + request' nullVal rqState{reqRetries=reqRetries rqState + 1} rq + | otherwise -> 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) + 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' + 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')) + 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 -} - } + case rspCode rsp of + (4,0,1) -- Credentials not sent or refused. + | reqDenies rqState > maxDenies -> do + out "401 - credentials again refused; exceeded retry count (2)" + return (uri,rsp) + | otherwise -> do + out "401 - credentials not supplied or refused; retrying.." + let hdrs = retrieveHeaders HdrWWWAuthenticate rsp + case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> return (uri,rsp) {- do nothing -} + Just x -> do + au <- challengeToAuthority uri x + case au of + Nothing -> return (uri,rsp) {- do nothing -} + Just au' -> do + out "Retrying request with new credentials" + request' nullVal + rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False} + (insertHeader HdrAuthorization (withAuthority au' rq) rq) + (4,0,7) -- Proxy Authentication required + | reqDenies rqState > maxDenies -> do + out "407 - proxy authentication required; max deny count exceeeded (2)" + return (uri,rsp) + | otherwise -> do + out "407 - proxy authentication required" + let hdrs = retrieveHeaders HdrProxyAuthenticate rsp + case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> return (uri,rsp) {- do nothing -} + Just x -> do + au <- challengeToAuthority uri x + case au of + Nothing -> return (uri,rsp) {- do nothing -} + Just au' -> do + pxy <- getBS bsProxy + case pxy of + NoProxy -> do + err "Proxy authentication required without proxy!" + return (uri,rsp) + Proxy px _ -> do + out "Retrying with proxy authentication" + setProxy (Proxy px (Just au')) + request' nullVal + rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False} + rq - (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,0,x) | x == 3 || x == 2 -> do -- Redirect using GET request method. + out ("30" ++ show x ++ " - redirect using GET") + rd <- getAllowRedirects + if not rd || reqRedirects rqState > maxRetries + then return (uri,rsp) + else + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location header in redirect response" + return (uri,rsp) + (Header _ u:_) -> + case parseURIReference u of + Nothing -> do + err ("Parse of Location header in a redirect response failed: " ++ u) + return (uri,rsp) + Just newuri -> do + out ("Redirecting to " ++ show newuri' ++ " ...") + let rq1 = rq { rqMethod=GET, rqURI=newuri', rqBody=nullVal } + request' nullVal + rqState{reqDenies=0, reqRedirects=reqRedirects rqState + 1, reqStopOnDeny=True} + (replaceHeader HdrContentLength "0" rq1) + where + newuri' = maybe newuri id (newuri `relativeTo` uri) - (3,_,_) -> redirect uri rsp - _ -> return (uri,rsp) + (3,0,5) -> + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location header in proxy redirect response." + return (uri,rsp) + (Header _ u:_) -> + case parseURIReference u of + Nothing -> do + err ("Parse of Location header in a proxy redirect response failed: " ++ u) + return (uri,rsp) + Just newuri -> do + out ("Retrying with proxy " ++ show newuri ++ "...") + setProxy (Proxy (uriToAuthorityString newuri) Nothing) + request' nullVal rqState{ reqDenies=0 + , reqRedirects=0 + , reqRetries=reqRetries rqState + 1 + , reqStopOnDeny=True + } + rq + (3,_,_) -> redirect uri rsp + _ -> return (uri,rsp) - where - spaceappend :: String -> String -> String - spaceappend x y = x ++ ' ' : y + where + redirect uri rsp = do + rd <- getAllowRedirects + if not rd || reqRedirects rqState > maxRetries + then return (uri,rsp) + else do + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location header in redirect response." + return (uri,rsp) + (Header _ u:_) -> + case parseURIReference u of + Just newuri -> do + let newuri' = maybe newuri id (newuri `relativeTo` uri) + out ("Redirecting to " ++ show newuri' ++ " ...") + request' nullVal + rqState{reqDenies=0, reqRedirects=reqRedirects rqState + 1, reqStopOnDeny=True} + rq{rqURI=newuri'} + Nothing -> do + err ("Parse of Location header in a redirect response failed: " ++ u) + return (uri,rsp) - 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) +spaceappend :: String -> String -> String +spaceappend x y = x ++ ' ' : y - dorequest :: URIAuth -> Request -> BrowserAction (Either ConnError Response) - dorequest hst rqst = +dorequest :: (HStream ty) + => URIAuth -> HTTPRequest ty -> BrowserAction (HandleStream ty) (Either ConnError (HTTPResponse ty)) +dorequest hst rqst = do { pool <- getBS bsConnectionPool - ; conn <- ioAction $ filterM (\c -> c `isConnectedTo` uriAuthToString hst) pool + ; conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool ; rsp <- case conn of [] -> do { out ("Creating new connection to " ++ uriAuthToString hst) - ; let port = case uriPort hst of + ; let aport = case uriPort hst of (':':s) -> read s _ -> 80 - ; c <- ioAction $ openTCPPort (uriRegName hst) port + ; c <- ioAction $ openStream (uriRegName hst) aport ; 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 + ; dorequest2 c rqst } (c:_) -> do { out ("Recovering connection to " ++ uriAuthToString hst) - ; dorequest2 hst c rqst + ; dorequest2 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 - } + where + dorequest2 c r = do + dbg <- getBS bsDebug + ioAction $ + case dbg of + Nothing -> sendHTTP c r + Just f -> do + c' <- debugByteStream (f++'-': uriAuthToString hst) c + sendHTTP c' r - - uriAuth :: URI -> URIAuth 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 :: String libUA = "haskell-libwww/0.1" @@ -995,8 +974,6 @@ , rqMethod=GET } - - -- This form junk is completely untested... type FormVar = (String,String) @@ -1019,3 +996,4 @@ , 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,132 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.BufferType +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Operations over wire-transmitted values. +-- +----------------------------------------------------------------------------- +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 ) + +-- | 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 these dicts. +-- +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 + +-- Encode 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. +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_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 :: 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_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 && crlf == b + , buf_isEmpty = Strict.null + } + where + crlf = Strict.pack "\r\n" + +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_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 && crlf == b + , buf_isEmpty = Lazy.null + } + where + crlf = Lazy.pack "\r\n" + +stringBufferOp :: BufferOp String +stringBufferOp =BufferOp + { buf_hGet = \ h n -> Strict.hGet h n >>= return . Strict.unpack + , buf_hGetContents = \ h -> Strict.hGetContents h >>= return . Strict.unpack + , buf_hPut = \ h s -> Strict.hPut h (Strict.pack s) + , buf_hGetLine = \ h -> Strict.hGetLine h >>= return . Strict.unpack + , buf_append = (++) + , 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 + , buf_isEmpty = null + } + where + crlf = "\r\n" diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -93,640 +93,31 @@ -- had been added (in which case 417 response is returned). -- ----------------------------------------------------------------------------- -module Network.HTTP ( - module Network.Stream, - module Network.TCP, - - -- ** Constants - httpVersion, - - -- ** HTTP - Request(..), - RequestData, - Response(..), - RequestMethod(..), - ResponseCode, - simpleHTTP, simpleHTTP_, - sendHTTP, - receiveHTTP, - processRequest, - getRequestHead, - respondHTTP, - - -- ** Header Functions - module Network.HTTP.Headers, - - -- ** URL Encoding - urlEncode, - urlDecode, - urlEncodeVars, +module Network.HTTP + ( module Network.HTTP.HandleStream + , module Network.HTTP.Base + , module Network.HTTP.Headers - -- ** URI authority parsing - URIAuthority(..), - getAuth, - parseURIAuthority -) where +{- + , simpleHTTP -- :: Request -> IO (Result Response) + , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) + , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response) + , receiveHTTP -- :: Stream s => s -> IO (Result Request) + , respondHTTP -- :: Stream s => s -> Response -> IO () +-} + , module Network.TCP + ) where ----------------------------------------------------------------- ------------------ Imports -------------------------------------- ----------------------------------------------------------------- -import Network.URI - ( URI(URI, uriScheme, uriAuthority, uriPath) - , URIAuth(uriUserInfo, uriRegName, uriPort) - , parseURIReference - , unEscapeString, escapeURIString, isUnescapedInURI - ) import Network.HTTP.Headers -import Network.Stream -import Network.StreamDebugger (debugStream) -import Network.TCP (openTCPPort) - -import Control.Exception as Exception (catch, throw) -import Data.Bits ((.&.)) -import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower) -import Data.List (partition, intersperse) -import Data.Maybe (listToMaybe, fromMaybe) -import Control.Monad (when, guard) -import Numeric (readHex) -import Text.Read.Lex (readDecP) -import Text.ParserCombinators.ReadP - ( ReadP, readP_to_S, char, (<++), look, munch ) -import Data.Typeable - --- 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 - - -crlf, sp :: String -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 1738, 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 - ------------------------------------------------------------------ ------------------- 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 | Custom String - deriving(Show,Eq) - -rqMethodMap :: [(String, RequestMethod)] -rqMethodMap = [("HEAD", HEAD), - ("PUT", PUT), - ("GET", GET), - ("POST", POST), - ("DELETE", DELETE), - ("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 - } deriving (Typeable) +import Network.HTTP.Base +--import Network.HTTP.Stream +import Network.HTTP.HandleStream +import Network.TCP --- 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 - } deriving (Typeable) - --- 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 -------------------------------------- ------------------------------------------------------------------ - --- 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,port=p} r = - let h' = h ++ maybe "" ((':':) . show) p in - 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 -> linearTransferStrLen conn x - 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 conn - case rq of - Left e -> return (Left e) - Right r -> processRequest conn r - --- | Reads and parses request headers. -getRequestHead :: Stream s => s -> IO (Result RequestData) -getRequestHead conn = - do { lor <- readTillEmpty1 conn - ; return $ lor `bindE` parseRequestHead - } - --- | Process request body (called after successful getRequestHead) -processRequest :: Stream s => s -> RequestData -> IO (Result Request) -processRequest conn (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 -> linearTransferStrLen conn x - 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. - -linearTransferStrLen :: Stream s => s -> String -> IO (Result ([Header],String)) -linearTransferStrLen conn ns = - case reads ns of - [(n,"")] -> linearTransfer conn n - _ -> return $ Left $ ErrorParse $ "Content-Length header contains not a number: " ++ show ns - --- | 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 - 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 --------------- ------------------------------------------------------------------ - --- | Formats name-value pairs as application\/x-www-form-urlencoded. -urlEncodeVars :: [(String,String)] -> String -urlEncodeVars xs = - concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs] - --- | Converts a single value to the application\/x-www-form-urlencoded encoding. -urlEncode :: String -> String -urlEncode = replace ' ' '+' . escapeURIString okChar - where okChar c = c == ' ' || - (isUnescapedInURI c && c `notElem` "&=+") - --- | Converts a single value from the --- application\/x-www-form-urlencoded encoding. -urlDecode :: String -> String -urlDecode = unEscapeString . replace '+' ' ' - --- | Replaces all instances of a value in a list by another value. -replace :: Eq a => - a -- ^ Value to look for - -> a -- ^ Value to replace it with - -> [a] -- ^ Input list - -> [a] -- ^ Output list -replace x y = map (\z -> if z == x then y else z) 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,552 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Base +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An easy HTTP interface; base types. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Base + ( + -- ** Constants + httpVersion + + -- ** HTTP + , Request + , Response + , RequestMethod(..) + + , HTTPRequest(..) + , HTTPResponse(..) + + -- ** URL Encoding + , urlEncode + , urlDecode + , urlEncodeVars + + -- ** URI authority parsing + , URIAuthority(..) + , parseURIAuthority + + -- internal + , crlf + , sp + , uriToAuthorityString -- :: URI -> String + , uriAuthToString -- :: URIAuth -> String + , parseResponseHead + , parseRequestHead + , ResponseNextStep(..) + , matchResponse + , ResponseData + , ResponseCode + , RequestData + + , getAuth + , normalizeRequestURI + , normalizeHostHeader + , findConnClose + + -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) + , linearTransfer + , hopefulTransfer + , chunkedTransfer + , uglyDeathTransfer + , readTillEmpty1 + , readTillEmpty2 + + , catchIO + , catchIO_ + ) where + +import Network.URI + ( URI(uriAuthority, uriPath, uriScheme) + , URIAuth(uriUserInfo, uriRegName, uriPort) + , parseURIReference + ) + +import Control.Monad ( guard ) +import Data.Char ( ord, digitToInt, intToDigit, toLower ) +import Data.List ( partition ) +import Data.Maybe ( listToMaybe ) +import Numeric ( showHex, readHex ) + +import Network.Stream +import Network.BufferType ( BufferOp(..) ) +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim ) + +import Text.Read.Lex (readDecP) +import Text.ParserCombinators.ReadP + ( ReadP, readP_to_S, char, (<++), look, munch ) + +import Control.Exception as Exception (IOException) + +----------------------------------------------------------------- +------------------ 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 + +-- 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 + ] + +----------------------------------------------------------------- +------------------ 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 + deriving(Show,Eq) + +rqMethodMap :: [(String, RequestMethod)] +rqMethodMap = [("HEAD", HEAD), + ("PUT", PUT), + ("GET", GET), + ("POST", POST), + ("DELETE", DELETE), + ("OPTIONS", OPTIONS), + ("TRACE", TRACE)] + +type Request = HTTPRequest String +type Response = HTTPResponse String + +-- | An HTTP Request. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output. +data HTTPRequest 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 + } + + + +crlf, sp :: String +crlf = "\r\n" +sp = " " + +-- 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 (HTTPRequest a) 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 (HTTPRequest a) where + getHeaders = rqHeaders + setHeaders rq hdrs = rq { rqHeaders=hdrs } + +-- | For easy pattern matching, HTTP response codes @xyz@ are +-- represented as @(x,y,z)@. +type ResponseCode = (Int,Int,Int) + +-- | @ResponseData@ contains the head of a response payload; +-- HTTP response code, accompanying text description + header +-- fields. +type ResponseData = (ResponseCode,String,[Header]) + +-- | @RequestData@ contains the head of a HTTP request; method, +-- its URL along with the auxillary/supporting header data. +type RequestData = (RequestMethod,URI,[Header]) + +-- | An HTTP Response. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output, additionally the output will +-- show an HTTP version of 1.1 instead of the actual version returned +-- by a server. +data HTTPResponse 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 (HTTPResponse a) where + show (Response (a,b,c) reason headers _) = + httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf + ++ foldr (++) [] (map show headers) ++ crlf + +instance HasHeaders (HTTPResponse a) where + getHeaders = rspHeaders + setHeaders rsp hdrs = rsp { rspHeaders=hdrs } + +----------------------------------------------------------------- +------------------ Parsing -------------------------------------- +----------------------------------------------------------------- + +-- 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 parse_err + _no + | null line -> Left ErrorClosed + | otherwise -> Left parse_err + where + parse_err = 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 + | null line -> Left ErrorClosed -- an assumption + | otherwise -> Left parse_err + where + parse_err = (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 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 +-} + +urlEncode, urlDecode :: String -> String + +urlDecode ('%':a:b:rest) = toEnum (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 = '%':showHex (ord x) "" + +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 [] = [] + +-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ +-- header. +getAuth :: Monad m => HTTPRequest ty -> m URIAuthority +getAuth r = + -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) + case parseURIAuthority auth of + Just x -> return x + Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" + where + auth = + case findHeader HdrHost r of + Just h -> h + Nothing -> uriToAuthorityString (rqURI r) + + {- 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. +normalizeRequestURI :: URIAuthority -> HTTPRequest ty -> HTTPRequest ty +normalizeRequestURI URIAuthority{host=h} r = + replaceHeader HdrConnection "close" $ + insertHeaderIfMissing HdrHost h $ + r { rqURI = (rqURI r){ uriScheme = "" + , uriAuthority = Nothing + }} + +-- Adds a Host header if one is NOT ALREADY PRESENT +normalizeHostHeader :: HTTPRequest ty -> HTTPRequest 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 + = do info <- readBlk 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 :: 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 ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) 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 = do + v <- chunkedTransferC bufOps readL readBlk 0 + return $ v `bindE` \(ftrs,count,info) -> + let myftrs = Header HdrContentLength (show count) : ftrs + in Right (myftrs,info) + +chunkedTransferC :: BufferOp a + -> IO (Result a) + -> (Int -> IO (Result a)) + -> Int + -> IO (Result ([Header],Int,a)) +chunkedTransferC bufOps readL readBlk n = do + v <- readL + case v of + Left e -> return (Left e) + Right line + | size == 0 -> do + rs <- readTillEmpty2 bufOps readL [] + return $ + rs `bindE` \strs -> + parseHeaders (map (buf_toStr bufOps) strs) `bindE` \ftrs -> + Right (ftrs,n,buf_empty bufOps) + | otherwise -> do + some <- readBlk size + readL + more <- chunkedTransferC bufOps {-nullVal isNull isLineEnd toStr append -} readL readBlk (n+size) + return $ + some `bindE` \cdata -> + more `bindE` \(ftrs,m,mdata) -> + Right (ftrs,m,buf_append bufOps cdata mdata) + 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 :: IO (Result ([Header],a)) +uglyDeathTransfer + = return $ Left $ ErrorParse "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 = Prelude.catch a h + +catchIO_ :: IO a -> IO a -> IO a +catchIO_ a h = Prelude.catch a (const h) + 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,214 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.HandleStream +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- A HandleStream version of Network.HTTP.Stream's public offerings. +-- +----------------------------------------------------------------------------- +module Network.HTTP.HandleStream + ( simpleHTTP -- :: HTTPRequest ty -> IO (Result (HTTPResponse ty)) + , simpleHTTP_ -- :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) + , sendHTTP -- :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTResponse ty)) + , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (HTTPRequest ty)) + , respondHTTP -- :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO () + + , simpleHTTP_debug -- :: FilePath -> HTTPRequest DebugString -> IO (HTTPResponse DebugString) + ) where + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.BufferType +import Network.Stream ( ConnError(..), bindE, Result ) +import Network.StreamDebugger ( debugByteStream ) +import Network.TCP (HStream(..), HandleStream ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Monad (when) + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + +-- | 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 :: HStream ty => HTTPRequest ty -> IO (Result (HTTPResponse ty)) +simpleHTTP r = do + auth <- getAuth r + c <- openStream (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +simpleHTTP_debug :: HStream ty => FilePath -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) +simpleHTTP_debug httpLogFile r = do + auth <- getAuth 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 -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) +simpleHTTP_ s r = do + auth <- getAuth r + let r' = normalizeRequestURI auth r + rsp <- sendHTTP s r' + return rsp + +sendHTTP :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) +sendHTTP conn rq = do + let a_rq = normalizeHostHeader rq + rsp <- catchIO (sendMain conn a_rq) + (\e -> do { close conn; ioError e }) + let fn list = when (or $ map findConnClose list) + (close conn) + either (\_ -> fn [rqHeaders rq]) + (\r -> fn [rqHeaders rq,rspHeaders r]) + rsp + return rsp + +-- 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 -> HTTPRequest ty -> IO (Result (HTTPResponse ty)) +sendMain conn rqst = do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + writeBlock conn (buf_fromStr bufferOps $ show rqst) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rqBody rqst) + 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 + -> HTTPRequest ty + -> IO (Result (HTTPResponse 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" -} + writeBlock conn ((buf_append bufferOps) + (buf_fromStr bufferOps (show rqst)) + (rqBody rqst)) + rsp <- getResponseHead conn + switchResponse conn False bdy_sent rsp rqst + + Done -> return (Right $ Response cd rn hdrs (buf_empty bufferOps)) + + DieHorribly str -> return $ Left $ ErrorParse ("Invalid response: " ++ str) + + ExpectEntity -> do + rslt <- + case tc of + Nothing -> + case cl of + Nothing -> hopefulTransfer bo (readLine conn) [] + Just x -> + case reads x of + ((v,_):_) -> linearTransfer (readBlock conn) v + _ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x))) + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn) + _ -> uglyDeathTransfer + return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) + + 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 = do + lor <- readTillEmpty1 bufferOps (readLine conn) + return $ lor `bindE` \es -> parseResponseHead (map (buf_toStr bufferOps) es) + +-- | Receive and parse a HTTP request from the given Stream. Should be used +-- for server side interactions. +receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (HTTPRequest bufTy)) +receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = + do { lor <- readTillEmpty1 bufferOps (readLine conn) + ; return $ lor `bindE` \es -> parseRequestHead (map (buf_toStr bufferOps) es) + } + + processRequest (rm,uri,hdrs) = do + rslt <- + case tc of + Nothing -> + case cl of + Nothing -> return (Right ([], buf_empty bo)) -- hopefulTransfer "" + Just x -> + case reads x of + ((v,_):_) -> linearTransfer (readBlock conn) v + _ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x))) + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn) + _ -> uglyDeathTransfer + + return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy) + where + -- FIXME : Also handle 100-continue. + tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + bo = bufferOps + +-- | Very simple function, send a HTTP response over the given stream. This +-- could be improved on to use different transfer types. +respondHTTP :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO () +respondHTTP conn rsp = do + writeBlock conn (buf_fromStr bufferOps $ show rsp) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rspBody rsp) + return () diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs --- a/Network/HTTP/Headers.hs +++ b/Network/HTTP/Headers.hs @@ -47,6 +47,7 @@ ( HasHeaders(..) , Header(..) , HeaderName(..) + , insertHeader , insertHeaderIfMissing , insertHeaders @@ -55,31 +56,14 @@ , findHeader , lookupHeader , parseHeaders - , parseHeader - , headerMap + ) where -import Data.Char (isSpace, toLower) -import Data.List (elemIndex) +import Data.Char (toLower) import Network.Stream (Result, ConnError(ErrorParse)) - --- 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 :: String -crlf = "\r\n" +import Network.HTTP.Utils ( trim, split, crlf ) --- | The Header data type pairs header names & values. +-- | The @Header@ data type pairs header names & values. data Header = Header HeaderName String instance Show Header where @@ -95,123 +79,122 @@ -- 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. +-- Long discussions can be had on this topic! +-- +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 ) ] - +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 "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 "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 "Set-Cookie" HdrSetCookie + , p "Cookie" HdrCookie + , p "Expect" HdrExpect + ] + where + p a b = (a,b) instance Show HeaderName where show (HdrCustom s) = s @@ -229,7 +212,6 @@ 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 @@ -246,9 +228,9 @@ newHeaders [] = [Header name value] -- | Removes old headers with duplicate name. -replaceHeader name value x = setHeaders x newHeaders +replaceHeader name value h = setHeaders h newHeaders where - newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ] + newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ] -- | Inserts multiple headers. insertHeaders :: HasHeaders a => [Header] -> a -> a diff --git a/Network/HTTP/MD5.hs b/Network/HTTP/MD5.hs --- a/Network/HTTP/MD5.hs +++ b/Network/HTTP/MD5.hs @@ -21,7 +21,6 @@ , Octet ) where -import Data.Char (chr) import Data.List (unfoldr) import Data.Word (Word8) import Numeric (readHex) @@ -36,8 +35,9 @@ hash :: [Octet] -> [Octet] hash xs = - unfoldr f $ md5s $ Str $ map (chr . fromIntegral) xs + unfoldr f $ md5s $ Str $ map (toEnum . fromIntegral) xs where f :: String -> Maybe (Octet,String) f [] = Nothing - f (x:y:zs) = Just (fromIntegral a,zs) + f [x] = f ['0',x] + f (x:y:zs) = Just (a,zs) where [(a,_)] = readHex (x:y:[]) diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs --- a/Network/HTTP/MD5Aux.hs +++ b/Network/HTTP/MD5Aux.hs @@ -4,11 +4,12 @@ Zord64, Str(..), BoolList(..), WordList(..)) where import Data.Char (ord, chr) -import Data.Bits (Bits, rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) +import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) import Data.Word (Word32, Word64) -rotL :: Bits a => a -> Int -> a +rotL :: Word32 -> Int -> Word32 rotL x = rotateL x + type Zord64 = Word64 -- ===================== TYPES AND CLASS DEFINTIONS ======================== @@ -19,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 @@ -28,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? @@ -87,10 +88,13 @@ finished (WordList (_, z)) = z == 0 -add :: ABCD -> ABCD -> ABCD -ABCD (a1, b1, c1, d1) `add` ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) - +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" + 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 ======================== @@ -122,14 +126,14 @@ 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 md5_main padded ilen abcd m = if finished m && padded then abcd - else md5_main padded' (ilen + 512) (abcd `add` abcd') m'' + else md5_main padded' (ilen + 512) (abcd + abcd') m'' where (m16, l, m') = get_next m len' = ilen + fromIntegral l ((m16', _, m''), padded') = if not padded && l < 512 @@ -331,7 +335,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/Stream.hs b/Network/HTTP/Stream.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Stream.hs @@ -0,0 +1,307 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop +-- License : BSD +-- +-- Maintainer : bjorn@bringert.net +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An easy HTTP interface enjoy. +-- +-- * Changes by Robin Bate Boerop : +-- - Made dependencies explicit in import statements. +-- - Removed false dependencies in import statements. +-- - Added missing type signatures. +-- - Moved Header-related code to Network.HTTP.Headers module. +-- +-- * 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.Stream + ( module Network.Stream + + , simpleHTTP -- :: Request -> IO (Result Response) + , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) + , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response) + , receiveHTTP -- :: Stream s => s -> IO (Result Request) + , respondHTTP -- :: Stream s => s -> Response -> 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.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 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' = normalizeRequestURI 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 + +sendHTTP :: Stream s => s -> Request -> IO (Result Response) +sendHTTP conn rq = + do { let a_rq = normalizeHostHeader rq + ; rsp <- catchIO (main a_rq) + (\e -> do { close conn; ioError 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 stringBufferOp (readLine 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 (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 + ; return $ rslt `bindE` \(ftrs,bdy) -> 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) +receiveHTTP conn = getRequestHead >>= processRequest + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = + do { lor <- readTillEmpty1 stringBufferOp (readLine 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 (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 + + 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 () 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,67 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Utils +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne +-- License : BSD +-- +-- Maintainer : Sigbjorn Finne +-- 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 + + , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) + , splitBy -- :: Eq a => a -> [a] -> [[a]] + + ) where + +import Data.Char +import Data.List ( elemIndex ) +import Data.Maybe ( fromMaybe ) + +-- | @crlf@ is our beloved two-char line terminator. +crlf :: String +crlf = "\r\n" + +-- | @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 + diff --git a/Network/Stream.hs b/Network/Stream.hs --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -27,11 +27,12 @@ , bindE ) where -data ConnError = ErrorReset - | ErrorClosed - | ErrorParse String - | ErrorMisc String - deriving(Show,Eq) +data ConnError + = ErrorReset + | ErrorClosed + | ErrorParse String + | ErrorMisc String + deriving(Show,Eq) bindE :: Result a -> (a -> Result b) -> Result b bindE (Left e) _ = Left e @@ -55,4 +56,3 @@ readBlock :: x -> Int -> IO (Result String) writeBlock :: x -> String -> IO (Result ()) close :: x -> IO () - diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs --- a/Network/StreamDebugger.hs +++ b/Network/StreamDebugger.hs @@ -18,12 +18,14 @@ module Network.StreamDebugger ( StreamDebugger , debugStream + , debugByteStream ) where import Network.Stream (Stream(..)) import System.IO ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile ) +import Network.TCP ( HandleStream, StreamHooks(..), HStream, setStreamHooks ) -- | Allows stream logging. Refer to 'debugStream' below. data StreamDebugger x @@ -57,3 +59,26 @@ hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") return (Dbg h stream) +debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty) +debugByteStream file stream = + do h <- openFile file AppendMode + hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") + setStreamHooks stream (debugStreamHooks h) + return stream + +debugStreamHooks :: HStream ty => Handle -> StreamHooks ty +debugStreamHooks h = + 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 ++ ' ' : show eval) + , hook_readLine = \ toStr val -> do + let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} + hPutStrLn h ("readLine " ++ show eval) + , hook_writeBlock = \ toStr str val -> do + hPutStrLn h ("writeBlock " ++ show val ++ ' ' : toStr str) + , hook_close = do + hPutStrLn h "closing..." + hFlush h + hClose h + } diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -32,53 +32,58 @@ , ShutdownCmd(ShutdownBoth), SocketOption(SoError) ) +import Network.HTTP.Base ( catchIO ) import Control.Monad (liftM) -import Control.Exception as Exception (Exception, catch, throw) +import Control.Exception as Exception (IOException) import System.IO.Error (catch, isEOFError) -- | Exception handler for socket operations. -handleSocketError :: Socket -> Exception -> IO (Result a) +handleSocketError :: Socket -> IOException -> IO (Result a) handleSocketError sk e = do se <- getSocketOption sk SoError case se of - 0 -> throw e + 0 -> ioError e 10054 -> return $ Left ErrorReset -- reset _ -> return $ 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 _ 0 = return "" myrecv sock len = let handler e = if isEOFError e then return [] else ioError e in System.IO.Error.catch (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 = shutdown sk ShutdownBoth >> sClose sk + -- This slams closed the connection (which is considered rude for TCP\/IP) + +readBlockSocket :: Socket -> Int -> IO (Result String) +readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk) + where + fn x = do { str <- myrecv sk x + ; let len = length str + ; if len < x + then ( fn (x-len) >>= \more -> return (str++more) ) + else return str + } + +-- Use of the following function is discouraged. +-- The function reads in one character at a time, +-- which causes many calls to the kernel recv() +-- hence causes many context switches. +readLineSocket :: Socket -> IO (Result String) +readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk) + where + fn str = do + c <- myrecv sk 1 -- like eating through a straw. + if null c || c == "\n" + then return (reverse str++c) + else fn (head c:str) + +writeBlockSocket :: Socket -> String -> IO (Result ()) +writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk) + where + fn [] = return () + fn x = send sk x >>= \i -> fn (drop i x) diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Network.TCP @@ -17,176 +18,319 @@ -- - Removed unused exported functions. -- -- * Changes by Simon Foster: --- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules +-- - Split module up into to separate Network.[Stream,TCP,HTTP] modules -- ----------------------------------------------------------------------------- module Network.TCP ( Connection , openTCPPort , isConnectedTo + + , openTCPConnection + , isTCPConnectedTo + + , HandleStream + , HStream(..) + + , StreamHooks(..) + , nullHooks + , setStreamHooks ) where import Network.BSD (getHostByName, hostAddresses) import Network.Socket - ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive, SoError) - , SocketType(Stream), inet_addr, connect, sendTo + ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive) + , SocketType(Stream), inet_addr, connect , shutdown, ShutdownCmd(ShutdownSend, ShutdownReceive) - , sClose, sIsConnected, setSocketOption, getSocketOption + , sClose, sIsConnected, setSocketOption , socket, Family(AF_INET) ) +import qualified Network.Stream as Stream + ( Stream(readBlock, readLine, writeBlock, close) ) import Network.Stream - ( Stream(readBlock, readLine, writeBlock, close) - , ConnError(ErrorMisc, ErrorReset, ErrorClosed) - , bindE + ( ConnError(..) + , Result ) -import Network.StreamSocket (myrecv, handleSocketError) +import Network.BufferType -import Control.Exception as Exception (catch, catchJust, finally, ioErrors, throw) -import Data.List (elemIndex) -import Data.Char (toLower) -import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import Network.HTTP.Base ( catchIO ) +import Network.Socket ( socketToHandle ) +import Data.Char ( toLower ) +import Data.Maybe ( fromMaybe ) +import Data.Word ( Word8 ) +import Control.Concurrent +import Control.Monad ( liftM ) +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) -data Conn = MkConn { connSock :: ! Socket - , connAddr :: ! SockAddr - , connBffr :: ! String - , connHost :: String - } - | ConnClosed - deriving(Eq) +newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} +data Conn a + = MkConn { connSock :: ! Socket + , connHandle :: Handle + , connBuffer :: BufferOp a + , connInput :: Maybe a + , connHost :: String + , connHooks :: Maybe (StreamHooks a) + } + | ConnClosed + deriving(Eq) + +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 () + } + +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 () + } + +setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () +setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) + +class BufferType bufType => HStream bufType where + openStream :: String -> Int -> 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 () + +instance HStream Strict.ByteString where + openStream = openTCPConnection + readBlock c n = readBlockBS c n + readLine c = readLineBS c + writeBlock c str = writeBlockBS c str + close c = closeIt c Strict.null + +instance HStream Lazy.ByteString where + openStream = \ a b -> openTCPConnection_ a b True + readBlock c n = readBlockBS c n + readLine c = readLineBS c + writeBlock c str = writeBlockBS c str + close c = closeIt c Lazy.null + +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 + +instance HStream String where + openStream = openTCPConnection + readBlock ref n = readBlockBS ref n + + -- This function uses a buffer, at this time the buffer is just 1000 characters. + -- (however many bytes this is is left to the user to decypher) + readLine ref = readLineBS ref + -- The 'Connection' object allows no outward buffering, + -- since in general messages are serialised in their entirety. + writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) + + -- Closes a Connection. Connection will no longer + -- allow any of the other Stream functions. Notice that a Connection may close + -- at any time before a call to this function. This function is idempotent. + -- (I think the behaviour here is TCP specific) + close c = closeIt c null + -- | This function establishes a connection to a remote -- host, it uses "getHostByName" which interrogates the -- DNS system, hence may trigger a network connection. -- --- Add a "persistant" option? Current persistant is default. --- Use "Result" type for synchronous exception reporting? openTCPPort :: String -> Int -> IO Connection -openTCPPort uri port = +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 { s <- socket AF_INET Stream 6 ; setSocketOption s KeepAlive 1 - ; host <- Exception.catch (inet_addr uri) -- handles ascii IP numbers - (\_ -> getHostByName uri >>= \host -> + ; host <- catchIO (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) + ; catchIO (connect s a) (\e -> sClose s >> ioError e) + ; h <- socketToHandle s ReadWriteMode + ; mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing } + ; let conn = + (MkConn { connSock = s + , connHandle = h + , connBuffer = bufferOps + , connInput = mb + , connHost = uri + , connHooks = Nothing + }) + ; v <- newMVar conn + ; return (HandleStream v) } -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) - } +closeConnection :: 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 + shutdown sk ShutdownSend + suck readL + hClose (connHandle conn) + shutdown sk ShutdownReceive + sClose sk - -- 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'])) - } + 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 (Connection conn) name = do + v <- readMVar (getRef conn) + case v of + ConnClosed -> return False + _ + | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v) + | otherwise -> return False +isTCPConnectedTo :: HandleStream ty -> String -> IO Bool +isTCPConnectedTo conn name = do + v <- readMVar (getRef conn) + case v of + ConnClosed -> return False + _ + | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v) + | otherwise -> return False - -- 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) +readBlockBS :: HandleStream a -> Int -> IO (Result a) +readBlockBS ref n = do + conn <- readMVar (getRef ref) + x <- + case conn of + ConnClosed -> return (Left ErrorClosed) + MkConn{} -> bufferGetBlock ref n -- (connBuffer conn) (connInput conn) (connHandle conn) n + fromMaybe (return ()) (fmap (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) (connHooks' conn)) + return x - -- 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) - ; Exception.catchJust Exception.ioErrors (closeConn c) (\_ -> return ()) - ; writeIORef (getRef ref) ConnClosed - } - where - -- Be kind to peer & close gracefully. - closeConn (ConnClosed) = return () - closeConn (MkConn sk addr [] _) = - (`Exception.finally` sClose sk) $ - do { shutdown sk ShutdownSend - ; suck ref - ; shutdown sk ShutdownReceive - } - - suck :: Connection -> IO () - suck cn = readLine cn >>= - either (\_ -> return ()) -- catch errors & ignore - (\x -> if null x then return () else suck cn) +-- 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) +readLineBS :: HandleStream a -> IO (Result a) +readLineBS ref = do + conn <- readMVar (getRef ref) + x <- + case conn of + ConnClosed -> return (Left ErrorClosed) + MkConn{} -> bufferReadLine ref -- (connBuffer conn) (connHandle conn) (connInput conn) + fromMaybe (return ()) (fmap (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) (connHooks' conn)) + return x --- | 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 - } +-- 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 = do + conn <- readMVar (getRef ref) + x <- + case conn of + ConnClosed -> return (Left ErrorClosed) + MkConn{} -> bufferPutBlock (connBuffer conn) (connHandle conn) b + fromMaybe (return ()) (fmap (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x) (connHooks' conn)) + return x +closeIt :: HandleStream ty -> (ty -> Bool) -> IO () +closeIt c p = do + closeConnection c (readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True}) + conn <- readMVar (getRef c) + fromMaybe (return ()) (fmap (\ h -> hook_close h) (connHooks' conn)) + + +bufferGetBlock :: HandleStream a -> Int -> IO (Result a) +bufferGetBlock ref n = do + conn <- readMVar (getRef ref) + case conn of + ConnClosed -> return (Left ErrorClosed) + MkConn{} -> 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 (Right a) + _ -> do + Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.Right) + (\ e -> if isEOFError e + then return (Right (buf_empty (connBuffer conn))) + else return (Left (ErrorMisc (show e)))) + +bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) +bufferPutBlock ops h b = + Prelude.catch (buf_hPut ops h b >> hFlush h >> return (Right ())) + (\ e -> return (Left (ErrorMisc (show e)))) + +bufferReadLine :: HandleStream a -> IO (Result a) -- BufferOp a -> Handle -> IO (Result a) +bufferReadLine ref = do + conn <- readMVar (getRef ref) + case conn of + ConnClosed -> return (Left ErrorClosed) + MkConn{} -> 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 (Right (buf_append (connBuffer conn) a newl)) + _ -> Prelude.catch + (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . Right . appendNL (connBuffer conn)) + (\ e -> + if isEOFError e + then return (Right (buf_empty (connBuffer conn))) + else return (Left (ErrorMisc (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')