diff --git a/HTTP.cabal b/HTTP.cabal new file mode 100644 --- /dev/null +++ b/HTTP.cabal @@ -0,0 +1,26 @@ +Name: HTTP +Version: 3000.0.0 +License: BSD3 +License-file: LICENSE +Copyright: + Copyright (c) 2002, Warrick Gray + Copyright (c) 2002-2005, Ian Lynagh + Copyright (c) 2003-2006, Bjorn Bringert + Copyright (c) 2004, Andre Furtado + Copyright (c) 2004, Ganesh Sittampalam + Copyright (c) 2004-2005, Dominic Steinitz +Author: Warrick Gray +Maintainer: Bjorn Bringert +Homepage: http://www.haskell.org/http/ +Description: A library for client-side HTTP +Build-depends: base, network, parsec +Exposed-modules: + Network.Stream, + Network.TCP, + Network.HTTP, + Network.Browser +Other-modules: + Network.HTTP.Base64, + Network.HTTP.MD5, + Network.HTTP.MD5Aux +GHC-options: -O -fwarn-missing-signatures diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,36 @@ +Copyright (c) 2002, Warrick Gray +Copyright (c) 2002-2005, Ian Lynagh +Copyright (c) 2003-2006, Bjorn Bringert +Copyright (c) 2004, Andre Furtado +Copyright (c) 2004, Ganesh Sittampalam +Copyright (c) 2004-2005, Dominic Steinitz + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/Browser.hs b/Network/Browser.hs new file mode 100644 --- /dev/null +++ b/Network/Browser.hs @@ -0,0 +1,976 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.Browser +-- Copyright : (c) Warrick Gray 2002 +-- License : BSD +-- +-- Maintainer : bjorn@bringert.net +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An HTTP\/1.1 compatible wrapper for the HTTP module. +----------------------------------------------------------------------------- + +{- + + Change Log: + - altered 'closeTCP' to 'close', for consistency with altered HTTP + - added debugging settings to browser. + + To Do: + - testing!!! + - remove BrowserAction type? Possibly replace with IORef? + - (more todo's in the HTTP mod) + +-} + +module Network.Browser ( + BrowserState, + BrowserAction, -- browser monad, effectively a state monad. + Cookie, + Form(..), + Proxy(..), + + browse, -- BrowserAction a -> IO a + request, -- Request -> BrowserAction Response + + setAllowRedirects, + getAllowRedirects, + + Authority(..), + getAuthorities, + setAuthorities, + addAuthority, + getAuthorityGen, + setAuthorityGen, + setAllowBasicAuth, + + setCookieFilter, + defaultCookieFilter, + userCookieFilter, + + getCookies, + setCookies, + addCookie, + + setErrHandler, + setOutHandler, + + setProxy, + + setDebugLog, + + out, + err, + ioAction, -- :: IO a -> BrowserAction a + + defaultGETRequest, + formToRequest, + uriDefaultTo, + uriTrimHost +) where + +import Network.HTTP + +import Data.Char (toLower,isAlphaNum,isSpace) +import Data.List (isPrefixOf,isSuffixOf,elemIndex,elemIndices) +import Data.Maybe +import Control.Monad (foldM,filterM,liftM,when) +import Text.ParserCombinators.Parsec +import Network.URI + +import qualified System.IO +import Data.Word (Word8) +import qualified Network.HTTP.MD5 as MD5 +import qualified Network.HTTP.Base64 as Base64 + +type Octet = Word8 + +------------------------------------------------------------------ +----------------------- Miscellaneous ---------------------------- +------------------------------------------------------------------ + +word, quotedstring :: Parser String +quotedstring = + do { char '"' + ; str <- many (satisfy $ not . (=='"')) + ; char '"' + ; return str + } + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) + +-- misc string fns +trim :: String -> String +trim = let dropspace = dropWhile isSpace in + reverse . dropspace . reverse . dropspace + + +-- | Splits a list into two parts, the delimiter occurs +-- at the head of the second list. Nothing is returned +-- when no occurance of the delimiter is found. +split :: Eq a => a -> [a] -> Maybe ([a],[a]) +split delim list = case delim `elemIndex` list of + Nothing -> Nothing + Just x -> Just $ splitAt x list + + + +-- | Removes delimiters. +splitMany :: Eq a => a -> [a] -> [[a]] +splitMany delim str = fn str ixs + where + ixs = elemIndices delim str + fn _ [] = [] + fn ls (h:t) = let (a,b) = splitAt h ls in a : fn b t + + +-- | Returns a URI that is consistent with the first +-- argument uri when read in the context of a second. +-- If second argument is not sufficient context for +-- determining a full URI then anarchy reins. +uriDefaultTo :: URI -> URI -> URI +uriDefaultTo a b = + case a `relativeTo` b of + Nothing -> a + Just x -> x + + +uriTrimHost :: URI -> URI +uriTrimHost uri = uri { uriScheme="", uriAuthority=Nothing } + + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- Some conventions: +-- assume ckDomain is lowercase +-- +data Cookie = MkCookie { ckDomain + , ckName + , ckValue :: String + , ckPath + , ckComment + , ckVersion :: Maybe String + } + deriving(Show,Read) + + +instance Eq Cookie where + a == b = ckDomain a == ckDomain b + && ckName a == ckName b + && ckPath a == ckPath b + + + +defaultCookieFilter :: URI -> Cookie -> IO Bool +defaultCookieFilter url cky = return True + +userCookieFilter :: URI -> Cookie -> IO Bool +userCookieFilter url cky = + do putStrLn ("Set-Cookie received when requesting: " ++ show url) + case ckComment cky of + Nothing -> return () + Just x -> putStrLn ("Cookie Comment:\n" ++ x) + putStrLn ("Domain/Path: " ++ ckDomain cky ++ + case ckPath cky of + Nothing -> "" + Just x -> "/" ++ x) + putStrLn (ckName cky ++ '=' : ckValue cky) + System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering + System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering + System.IO.hPutStr System.IO.stdout "Accept [y/n]? " + x <- System.IO.hGetChar System.IO.stdin + System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering + System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering + return (toLower x == 'y') + + + +-- | Serialise a Cookie for inclusion in a request. +cookieToHeader :: Cookie -> Header +cookieToHeader ck = Header HdrCookie text + where + text = "$Version=" ++ fromMaybe "0" (ckVersion ck) + ++ ';' : ckName ck ++ "=" ++ ckValue ck + ++ (case ckPath ck of + Nothing -> "" + Just x -> ";$Path=" ++ x) + ++ ";$Domain=" ++ ckDomain ck + + + +{- replace "error" call with [] in final version? -} +headerToCookies :: String -> Header -> [Cookie] +headerToCookies dom (Header HdrSetCookie val) = + case parse cookies "" val of + Left e -> error ("Cookie parse failure on: " ++ val ++ " " ++ show e) + Right x -> x + where + cookies :: Parser [Cookie] + cookies = sepBy1 cookie (char ',') + + cookie :: Parser Cookie + cookie = + do { name <- word + ; spaces + ; char '=' + ; spaces + ; val <- cvalue + ; args <- cdetail + ; return $ mkCookie name val args + } + + cvalue :: Parser String + + spaces = many (satisfy isSpace) + + cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) + + -- all keys in the result list MUST be in lower case + cdetail :: Parser [(String,String)] + cdetail = many $ + try (do { spaces + ; char ';' + ; spaces + ; s1 <- word + ; spaces + ; s2 <- option "" (do { char '=' ; spaces ; v <- cvalue ; return v }) + ; return (map toLower s1,s2) + }) + + mkCookie :: String -> String -> [(String,String)] -> Cookie + mkCookie nm val more = MkCookie { ckName=nm + , ckValue=val + , ckDomain=map toLower (fromMaybe dom (lookup "domain" more)) + , ckPath=lookup "path" more + , ckVersion=lookup "version" more + , ckComment=lookup "comment" more + } + + + +-- | Adds a cookie to the browser state, removing duplicates. +addCookie :: Cookie -> BrowserAction () +addCookie c = alterBS (\b -> b { bsCookies=c : fn (bsCookies b) }) + where + fn = filter (not . (==c)) + +setCookies :: [Cookie] -> BrowserAction () +setCookies cs = alterBS (\b -> b { bsCookies=cs }) + +getCookies :: BrowserAction [Cookie] +getCookies = getBS bsCookies + +-- ...get domain specific cookies... +-- ... this needs changing for consistency with rfc2109... +-- ... currently too broad. +getCookiesFor :: String -> String -> BrowserAction [Cookie] +getCookiesFor dom path = + do cks <- getCookies + return (filter cookiematch cks) + where + cookiematch :: Cookie -> Bool + cookiematch ck = ckDomain ck `isSuffixOf` dom + && case ckPath ck of + Nothing -> True + Just p -> p `isPrefixOf` path + + +setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction () +setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f }) + +getCookieFilter :: BrowserAction (URI -> Cookie -> IO Bool) +getCookieFilter = getBS bsCookieFilter + +------------------------------------------------------------------ +----------------------- Authorisation Stuff ---------------------- +------------------------------------------------------------------ + +{- + +The browser handles 401 responses in the following manner: + 1) extract all WWW-Authenticate headers from a 401 response + 2) rewrite each as a Challenge object, using "headerToChallenge" + 3) pick a challenge to respond to, usually the strongest + challenge understood by the client, using "pickChallenge" + 4) generate a username/password combination using the browsers + "bsAuthorityGen" function (the default behaviour is to ask + the user) + 5) build an Authority object based upon the challenge and user + data, store this new Authority in the browser state + 6) convert the Authority to a request header and add this + to a request using "withAuthority" + 7) send the amended request + +Note that by default requests are annotated with authority headers +before the first sending, based upon previously generated Authority +objects (which contain domain information). Once a specific authority +is added to a rejected request this predictive annotation is suppressed. + +407 responses are handled in a similar manner, except + a) Authorities are not collected, only a single proxy authority + is kept by the browser + b) If the proxy used by the browser (type Proxy) is NoProxy, then + a 407 response will generate output on the "err" stream and + the response will be returned. + + +Notes: + - digest authentication so far ignores qop, so fails to authenticate + properly with qop=auth-int challenges + - calculates a1 more than necessary + - doesn't reverse authenticate + - doesn't properly receive AuthenticationInfo headers, so fails + to use next-nonce etc + +-} + + +data Algorithm = AlgMD5 | AlgMD5sess + deriving(Eq) + +instance Show Algorithm where + show AlgMD5 = "md5" + show AlgMD5sess = "md5-sess" + + +data Qop = QopAuth | QopAuthInt + deriving(Eq,Show) + + +data Challenge = ChalBasic { chRealm :: String } + | ChalDigest { chRealm :: String + , chDomain :: [URI] + , chNonce :: String + , chOpaque :: Maybe String + , chStale :: Bool + , chAlgorithm ::Maybe Algorithm + , chQop :: [Qop] + } + +-- | Convert WWW-Authenticate header into a Challenge object +headerToChallenge :: URI -> Header -> Maybe Challenge +headerToChallenge baseURI (Header _ str) = + case parse challenge "" str of + Left e -> Nothing + Right (name,props) -> case name of + "basic" -> mkBasic props + "digest" -> mkDigest props + _ -> Nothing + where + challenge :: Parser (String,[(String,String)]) + challenge = + do { nme <- word + ; pps <- cprops + ; return (map toLower nme,pps) + } + + cprops = sepBy1 cprop comma + + comma = do { spaces ; char ',' ; spaces } + + cprop = + do { nm <- word + ; char '=' + ; val <- quotedstring + ; return (map toLower nm,val) + } + + quotedstring = + do { char '"' + ; str <- many (satisfy (not.(=='"'))) + ; char '"' + ; return str + } + + mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge + + mkBasic params = fmap ChalBasic (lookup "realm" params) + + mkDigest params = + -- with Maybe monad + do { r <- lookup "realm" params + ; n <- lookup "nonce" params + ; return $ + ChalDigest { chRealm = r + , chDomain = (annotateURIs + $ map parseURI + $ words + $ fromMaybe [] + $ lookup "domain" params) + , chNonce = n + , chOpaque = lookup "opaque" params + , chStale = "true" == (map toLower + $ fromMaybe "" (lookup "stale" params)) + , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params) + , chQop = readQop (fromMaybe "" $ lookup "qop" params) + } + } + + annotateURIs :: [Maybe URI] -> [URI] + annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes + + -- Change These: + readQop :: String -> [Qop] + readQop = catMaybes . (map strToQop) . (splitMany ',') + + strToQop str = case map toLower (trim str) of + "auth" -> Just QopAuth + "auth-int" -> Just QopAuthInt + _ -> Nothing + + readAlgorithm str = case map toLower (trim str) of + "md5" -> Just AlgMD5 + "md5-sess" -> Just AlgMD5sess + _ -> Nothing + + +data Authority = AuthBasic { auRealm :: String + , auUsername :: String + , auPassword :: String + , auSite :: URI + } + | AuthDigest { auRealm :: String + , auUsername :: String + , auPassword :: String + , auNonce :: String + , auAlgorithm :: Maybe Algorithm + , auDomain :: [URI] + , auOpaque :: Maybe String + , auQop :: [Qop] + } + + +-- | Return authorities for a given domain and path. +-- Assumes "dom" is lower case +getAuthFor :: String -> String -> BrowserAction [Authority] +getAuthFor dom pth = + do { list <- getAuthorities + ; return (filter match list) + } + where + match :: Authority -> Bool + match (AuthBasic _ _ _ s) = matchURI s + match (AuthDigest _ _ _ _ _ ds _ _) = or (map matchURI ds) + + matchURI :: URI -> Bool + matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) + + +-- | Interacting with browser state: +getAuthorities :: BrowserAction [Authority] +getAuthorities = getBS bsAuthorities + +setAuthorities :: [Authority] -> BrowserAction () +setAuthorities as = alterBS (\b -> b { bsAuthorities=as }) + +addAuthority :: Authority -> BrowserAction () +addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b }) + +getAuthorityGen :: BrowserAction (URI -> String -> IO (Maybe (String,String))) +getAuthorityGen = getBS bsAuthorityGen + +setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction () +setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f }) + +setAllowBasicAuth :: Bool -> BrowserAction () +setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba }) + + + + +-- TO BE CHANGED!!! +pickChallenge :: [Challenge] -> Maybe Challenge +pickChallenge = listToMaybe + + + +-- | Retrieve a likely looking authority for a Request. +anticipateChallenge :: Request -> BrowserAction (Maybe Authority) +anticipateChallenge rq = + let uri = rqURI rq in + do { authlist <- getAuthFor (uriToAuthorityString uri) (uriPath uri) + ; return (listToMaybe authlist) + } + + +-- | Asking the user to respond to a challenge +challengeToAuthority :: URI -> Challenge -> BrowserAction (Maybe Authority) +challengeToAuthority uri ch = + -- prompt user for authority + if answerable ch then + do { prompt <- getAuthorityGen + ; userdetails <- ioAction $ prompt uri (chRealm ch) + ; case userdetails of + Nothing -> return Nothing + Just (u,p) -> return (Just $ buildAuth ch u p) + } + else return Nothing + where + answerable :: Challenge -> Bool + answerable (ChalBasic _) = True + answerable ch = (chAlgorithm ch) == Just AlgMD5 + + buildAuth :: Challenge -> String -> String -> Authority + buildAuth (ChalBasic r) u p = + AuthBasic { auSite=uri + , auRealm=r + , auUsername=u + , auPassword=p + } + + -- note to self: this is a pretty stupid operation + -- to perform isn't it? ChalX and AuthX are so very + -- similar. + buildAuth (ChalDigest r d n o s a q) u p = + AuthDigest { auRealm=r + , auUsername=u + , auPassword=p + , auDomain=d + , auNonce=n + , auOpaque=o + , auAlgorithm=a + , auQop=q + } + + +-- | Generating a credentials value from an Authority, in +-- the context of a specific request. If a client nonce +-- was to be used then this function might need to +-- be of type ... -> BrowserAction String +withAuthority :: Authority -> Request -> String +withAuthority a rq = case a of + AuthBasic _ _ user pass -> + "basic " ++ base64encode (auUsername a ++ ':' : auPassword a) + AuthDigest _ _ _ _ _ _ _ _ -> + "digest username=\"" ++ auUsername a + ++ "\",realm=\"" ++ auRealm a + ++ "\",nonce=\"" ++ auNonce a + ++ "\",uri=\"" ++ digesturi + ++ ",response=\"" ++ rspdigest + ++ "\"" + -- plus optional stuff: + ++ ( if isJust (auAlgorithm a) then "" else ",algorithm=\"" ++ show (fromJust $ auAlgorithm a) ++ "\"" ) + ++ ( if isJust (auOpaque a) then "" else ",opaque=\"" ++ (fromJust $ auOpaque a) ++ "\"" ) + ++ ( if null (auQop a) then "" else ",qop=auth" ) + where + rspdigest = "\"" + ++ map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) + ++ "\"" + + -- FIXME: these probably only work right for latin-1 strings + stringToOctets :: String -> [Octet] + stringToOctets = map (fromIntegral . fromEnum) + octetsToString :: [Octet] -> String + octetsToString = map (toEnum . fromIntegral) + base64encode :: String -> String + base64encode = Base64.encode . stringToOctets + md5 :: String -> String + md5 = octetsToString . MD5.hash . stringToOctets + + kd :: String -> String -> String + kd a b = md5 (a ++ ":" ++ b) + + a1, a2 :: String + a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a + + {- + If the "qop" directive's value is "auth" or is unspecified, then A2 + is: + A2 = Method ":" digest-uri-value + If the "qop" value is "auth-int", then A2 is: + A2 = Method ":" digest-uri-value ":" H(entity-body) + -} + a2 = show (rqMethod rq) ++ ":" ++ digesturi + + digesturi = show (rqURI rq) + noncevalue = auNonce a + + +------------------------------------------------------------------ +------------------ Proxy Stuff ----------------------------------- +------------------------------------------------------------------ + +data Proxy = NoProxy + | Proxy String (Maybe Authority) + + +------------------------------------------------------------------ +------------------ Browser State Actions ------------------------- +------------------------------------------------------------------ + + +data BrowserState = BS { bsErr, bsOut :: String -> IO () + , bsCookies :: [Cookie] + , bsCookieFilter :: URI -> Cookie -> IO Bool + , bsAuthorityGen :: URI -> String -> IO (Maybe (String,String)) + , bsAuthorities :: [Authority] + , bsAllowRedirects :: Bool + , bsAllowBasicAuth :: Bool + , bsConnectionPool :: [Connection] + , bsProxy :: Proxy + , bsDebug :: Maybe String + } + +instance Show BrowserState where + show bs = "BrowserState { " + ++ show (bsCookies bs) ++ "\n" + {- ++ show (bsAuthorities bs) ++ "\n"-} + ++ "AllowRedirects: " ++ show (bsAllowRedirects bs) + ++ "} " + + +-- Simple DIY stateful behaviour, with IO +data BrowserAction a = BA { lift :: (BrowserState -> IO (BrowserState,a)) } + +instance Monad BrowserAction where + a >>= f = BA (\b -> do { (nb,v) <- lift a b ; lift (f v) nb}) + return x = BA (\b -> return (b,x)) + +instance Functor BrowserAction where + fmap f = liftM f + + +-- | Apply a browser action to a state. +browse :: BrowserAction a -> IO a +browse act = do x <- lift act defaultBrowserState + return (snd x) + where + defaultBrowserState :: BrowserState + defaultBrowserState = + BS { bsErr = putStrLn + , bsOut = putStrLn + , bsCookies = [] + , bsCookieFilter = defaultCookieFilter + , bsAuthorityGen = (error "bsAuthGen wanted") + , bsAuthorities = [] + , bsAllowRedirects = True + , bsAllowBasicAuth = False + , bsConnectionPool = [] + , bsProxy = NoProxy + , bsDebug = Nothing + } + +-- | Alter browser state +alterBS :: (BrowserState -> BrowserState) -> BrowserAction () +alterBS f = BA (\b -> return (f b,())) + +getBS :: (BrowserState -> a) -> BrowserAction a +getBS f = BA (\b -> return (b,f b)) + +-- | Do an io action +ioAction :: IO a -> BrowserAction a +ioAction a = BA (\b -> a >>= \v -> return (b,v)) + + +-- Stream handlers +setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction () +setErrHandler h = alterBS (\b -> b { bsErr=h }) +setOutHandler h = alterBS (\b -> b { bsOut=h }) + +out, err :: String -> BrowserAction () +out s = do { f <- getBS bsOut ; ioAction $ f s } +err s = do { f <- getBS bsErr ; ioAction $ f s } + +-- Redirects +setAllowRedirects :: Bool -> BrowserAction () +setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl}) + +getAllowRedirects :: BrowserAction Bool +getAllowRedirects = getBS bsAllowRedirects + + +-- Proxy +setProxy :: Proxy -> BrowserAction () +setProxy p = alterBS (\b -> b {bsProxy = p}) + +getProxy :: BrowserAction Proxy +getProxy = getBS bsProxy + + +-- Debug +setDebugLog :: Maybe String -> BrowserAction () +setDebugLog v = alterBS (\b -> b {bsDebug=v}) + + +-- Page control +type RequestState = ( Int -- number of 401 responses so far + , Int -- number of redirects so far + , Int -- number of retrys so far + , Bool -- whether to pre-empt 401 response + ) + + + +-- Surely the most important bit: +request :: Request -> BrowserAction (URI,Response) +request = request' initialState + where + initialState = (0,0,0,True) + + +request' :: RequestState -> Request -> BrowserAction (URI,Response) +request' (denycount,redirectcount,retrycount,preempt) rq = + do -- add cookies to request + let uri = rqURI rq + cookies <- getCookiesFor (uriToAuthorityString uri) (uriPath uri) + + when (not $ null cookies) + (out $ "Adding cookies to request. Cookie names: " + ++ foldl spaceappend "" (map ckName cookies)) + + -- add credentials to request + rq' <- if not preempt then return rq else + do { auth <- anticipateChallenge rq + ; case auth of + Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) + Nothing -> return rq + } + + let rq'' = insertHeaders (map cookieToHeader cookies) rq' + + p <- getProxy + + out ("Sending:\n" ++ show rq'') + e_rsp <- case p of + NoProxy -> dorequest (uriAuth $ rqURI rq'') rq'' + Proxy str ath -> + let rq''' = case ath of + Nothing -> rq'' + Just x -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq'' + in dorequest (URIAuth "" str "") rq''' + + case e_rsp of + Left v -> if (retrycount < 4) && (v == ErrorReset || v == ErrorClosed) + then request' (denycount,redirectcount,retrycount+1,preempt) rq + else error ("Exception raised in request: " ++ show v) + Right rsp -> do + out ("Received:\n" ++ show rsp) + + -- add new cookies to browser state + let cookieheaders = retrieveHeaders HdrSetCookie rsp + let newcookies = concat (map (headerToCookies $ uriToAuthorityString uri) cookieheaders) + + when (not $ null newcookies) + (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newcookies) + + filterfn <- getCookieFilter + newcookies' <- ioAction (filterM (filterfn uri) newcookies) + foldM (\_ -> addCookie) () newcookies' + + when (not $ null newcookies) + (out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies')) + + case rspCode rsp of + (4,0,1) -> -- Credentials not sent or refused. + out "401 - credentials not sent or refused" >> + if denycount > 2 then return (uri,rsp) else + do { let hdrs = retrieveHeaders HdrWWWAuthenticate rsp + ; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of + Just x -> + do { au <- challengeToAuthority uri x + ; case au of + Just au' -> + out "Retrying request with new credentials" >> + request' (denycount+1,redirectcount,retrycount,False) + (insertHeader HdrAuthorization (withAuthority au' rq) rq) + Nothing -> return (uri,rsp) {- do nothing -} + } + + Nothing -> return (uri,rsp) {- do nothing -} + } + + + (4,0,7) -> -- Proxy Authentication required + out "407 - proxy authentication required" >> + if denycount > 2 then return (uri,rsp) else + do { let hdrs = retrieveHeaders HdrProxyAuthenticate rsp + ; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of + Just x -> + do { au <- challengeToAuthority uri x + ; case au of + Just au' -> + do { pxy <- getBS bsProxy + ; case pxy of + NoProxy -> + do { err "Proxy authentication required without proxy!" + ; return (uri,rsp) + } + Proxy x y -> + do { out "Retrying with proxy authentication" + ; setProxy (Proxy x $ Just au') + ; request' (denycount+1,redirectcount,retrycount,False) rq + } + } + Nothing -> return (uri,rsp) {- do nothing -} + } + + Nothing -> return (uri,rsp) {- do nothing -} + } + + + (3,0,3) -> -- Redirect using GET request method. + do { out "303 - redirect using GET" + ; rd <- getAllowRedirects + ; if not rd || redirectcount > 4 then return (uri,rsp) else + case retrieveHeaders HdrLocation rsp of + (Header _ u:_) -> case parseURIReference u of + Just newuri -> + let newuri' = case newuri `relativeTo` uri of + Nothing -> newuri + Just x -> x + in do { out ("Redirecting to " ++ show newuri' ++ " ...") + ; let rq = rq { rqMethod=GET, rqURI=newuri', rqBody="" } + ; request' (0,redirectcount+1,retrycount,True) + (replaceHeader HdrContentLength "0" rq) + } + Nothing -> + do { err ("Parse of Location header in a redirect response failed: " ++ u) + ; return (uri,rsp) + } + [] -> do { err "No Location header in redirect response" + ; return (uri,rsp) + } + } + + (3,0,5) -> + case retrieveHeaders HdrLocation rsp of + (Header _ u:_) -> case parseURIReference u of + Just newuri -> + do { out ("Retrying with proxy " ++ show newuri ++ "...") + ; setProxy (Proxy (uriToAuthorityString newuri) Nothing) + ; request' (0,0,retrycount+1,True) rq + } + Nothing -> + do { err ("Parse of Location header in a proxy redirect response failed: " ++ u) + ; return (uri,rsp) + } + [] -> do { err "No Location header in proxy redirect response." + ; return (uri,rsp) + } + + + (3,_,_) -> redirect uri rsp + _ -> return (uri,rsp) + + where + spaceappend :: String -> String -> String + spaceappend x y = x ++ ' ' : y + + redirect uri rsp = do + rd <- getAllowRedirects + if not rd || redirectcount > 4 then return (uri,rsp) else do + case retrieveHeaders HdrLocation rsp of + (Header _ u:_) -> case parseURIReference u of + Just newuri -> do + let newuri' = case newuri `relativeTo` uri of + Nothing -> newuri + Just x -> x + out ("Redirecting to " ++ show newuri' ++ " ...") + request' (0,redirectcount+1,retrycount,True) (rq { rqURI=newuri' }) + Nothing -> do + err ("Parse of Location header in a redirect response failed: " ++ u) + return (uri,rsp) + [] -> do err "No Location header in redirect response." + return (uri,rsp) + + + dorequest :: URIAuth -> Request -> BrowserAction (Either ConnError Response) + dorequest hst rqst = + do { pool <- getBS bsConnectionPool + ; conn <- ioAction $ filterM (\c -> c `isConnectedTo` uriAuthToString hst) pool + ; rsp <- case conn of + [] -> do { out ("Creating new connection to " ++ uriAuthToString hst) + ; let port = case uriPort hst of + (':':s) -> read s + _ -> 80 + ; c <- ioAction $ openTCPPort (uriRegName hst) port + ; let pool' = if length pool > 5 + then init pool + else pool + ; when (length pool > 5) + (ioAction $ close (last pool)) + ; alterBS (\b -> b { bsConnectionPool=c:pool' }) + ; dorequest2 hst c rqst + } + (c:_) -> + do { out ("Recovering connection to " ++ uriAuthToString hst) + ; dorequest2 hst c rqst + } + ; + ; return rsp + } + + dorequest2 hst c r = + do { dbg <- getBS bsDebug + ; ioAction $ case dbg of + Nothing -> sendHTTP c r + Just f -> + debugStream (f++'-': uriAuthToString hst) c + >>= \c' -> sendHTTP c' r + } + + + +uriAuth x = case uriAuthority x of + Just ua -> ua + _ -> error ("No uri authority for: "++show x) + +uriAuthToString :: URIAuth -> String +uriAuthToString URIAuth { uriUserInfo = uinfo + , uriRegName = regname + , uriPort = port + } = + ((if null uinfo then id else (uinfo++)) + . (regname++) + . (port++)) "" + +-- This function duplicates old Network.URI.authority behaviour. +uriToAuthorityString :: URI -> String +uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) + + + +------------------------------------------------------------------ +------------------ Request Building ------------------------------ +------------------------------------------------------------------ + + +libUA = "haskell-libwww/0.1" + +defaultGETRequest :: URI -> Request +defaultGETRequest uri = + Request { rqURI=uri + , rqBody="" + , rqHeaders=[ Header HdrContentLength "0" + , Header HdrUserAgent libUA + ] + , rqMethod=GET + } + + + +-- This form junk is completely untested... + +type FormVar = (String,String) + +data Form = Form RequestMethod URI [FormVar] + + +formToRequest :: Form -> Request +formToRequest (Form m u vs) = + let enc = urlEncodeVars vs + in case m of + GET -> Request { rqMethod=GET + , rqHeaders=[ Header HdrContentLength "0" ] + , rqBody="" + , rqURI=u { uriQuery= '?' : enc } -- What about old query? + } + POST -> Request { rqMethod=POST + , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded", + Header HdrContentLength (show $ length enc) ] + , rqBody=enc + , rqURI=u + } diff --git a/Network/HTTP.hs b/Network/HTTP.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP.hs @@ -0,0 +1,1052 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005 +-- License : BSD +-- +-- Maintainer : bjorn@bringert.net +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An easy HTTP interface enjoy. +-- +-- * Changes by Simon Foster: +-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules +-- - Created functions receiveHTTP and responseHTTP to allow server side interactions +-- (although 100-continue is unsupported and I haven't checked for standard compliancy). +-- - Pulled the transfer functions from sendHTTP to global scope to allow access by +-- above functions. +-- +-- * Changes by Graham Klyne: +-- - export httpVersion +-- - use new URI module (similar to old, but uses revised URI datatype) +-- +-- * Changes by Bjorn Bringert: +-- +-- - handle URIs with a port number +-- - added debugging toggle +-- - disabled 100-continue transfers to get HTTP\/1.0 compatibility +-- - change 'ioError' to 'throw' +-- - Added simpleHTTP_, which takes a stream argument. +-- +-- * Changes from 0.1 +-- - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class. +-- - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses. +-- - reworking of the use of Stream, including alterations to make 'sendHTTP' generic +-- and the addition of a debugging stream. +-- - simplified error handling. +-- +-- * TODO +-- - request pipelining +-- - https upgrade (includes full TLS, i.e. SSL, implementation) +-- - use of Stream classes will pay off +-- - consider C implementation of encryption\/decryption +-- - comm timeouts +-- - MIME & entity stuff (happening in separate module) +-- - support \"*\" uri-request-string for OPTIONS request method +-- +-- +-- * Header notes: +-- +-- [@Host@] +-- Required by HTTP\/1.1, if not supplied as part +-- of a request a default Host value is extracted +-- from the request-uri. +-- +-- [@Connection@] +-- If this header is present in any request or +-- response, and it's value is "close", then +-- the current request\/response is the last +-- to be allowed on that connection. +-- +-- [@Expect@] +-- Should a request contain a body, an Expect +-- header will be added to the request. The added +-- header has the value \"100-continue\". After +-- a 417 \"Expectation Failed\" response the request +-- is attempted again without this added Expect +-- header. +-- +-- [@TransferEncoding,ContentLength,...@] +-- if request is inconsistent with any of these +-- header values then you may not receive any response +-- or will generate an error response (probably 4xx). +-- +-- +-- * Response code notes +-- Some response codes induce special behaviour: +-- +-- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. +-- \"101 Upgrade\" will be returned. +-- Other 1xx responses are ignored. +-- +-- [@417@] The reason for this code is \"Expectation failed\", indicating +-- that the server did not like the Expect \"100-continue\" header +-- added to a request. Receipt of 417 will induce another +-- request attempt (without Expect header), unless no Expect header +-- had been added (in which case 417 response is returned). +-- +----------------------------------------------------------------------------- +module Network.HTTP ( + module Network.Stream, + module Network.TCP, + + -- ** Constants + httpVersion, + + -- ** HTTP + Request(..), + Response(..), + RequestMethod(..), + simpleHTTP, simpleHTTP_, + sendHTTP, + receiveHTTP, + respondHTTP, + + -- ** Header Functions + HasHeaders, + Header(..), + HeaderName(..), + insertHeader, + insertHeaderIfMissing, + insertHeaders, + retrieveHeaders, + replaceHeader, + findHeader, + + -- ** URL Encoding + urlEncode, + urlDecode, + urlEncodeVars, + + -- ** URI authority parsing + URIAuthority(..), + parseURIAuthority +) where + + + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Control.Exception as Exception + +-- Networking +import Network (withSocketsDo) +import Network.BSD +import Network.URI +import Network.Socket +import Network.Stream +import Network.TCP + + +-- Util +import Data.Bits ((.&.)) +import Data.Char +import Data.List (isPrefixOf,partition,elemIndex) +import Data.Maybe +import Data.Array.MArray +import Data.IORef +import Control.Concurrent +import Control.Monad (when,liftM,guard) +import Control.Monad.ST (ST,stToIO) +import Numeric (readHex) +import Text.ParserCombinators.ReadP +import Text.Read.Lex +import System.IO +import System.IO.Error (isEOFError) +import qualified System.IO.Error + +import Foreign.C.Error + + +-- Turn on to enable HTTP traffic logging +debug :: Bool +debug = False + +-- File that HTTP traffic logs go to +httpLogFile :: String +httpLogFile = "http-debug.log" + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + +-- remove leading and trailing whitespace. +trim :: String -> String +trim = let dropspace = dropWhile isSpace in + reverse . dropspace . reverse . dropspace + + +-- Split a list into two parts, the delimiter occurs +-- at the head of the second list. Nothing is returned +-- when no occurance of the delimiter is found. +split :: Eq a => a -> [a] -> Maybe ([a],[a]) +split delim list = case delim `elemIndex` list of + Nothing -> Nothing + Just x -> Just $ splitAt x list + + + +crlf = "\r\n" +sp = " " + +----------------------------------------------------------------- +------------------ URI Authority parsing ------------------------ +----------------------------------------------------------------- + +data URIAuthority = URIAuthority { user :: Maybe String, + password :: Maybe String, + host :: String, + port :: Maybe Int + } deriving (Eq,Show) + +-- | Parse the authority part of a URL. +-- +-- > RFC 1732, section 3.1: +-- > +-- > //:@:/ +-- > Some or all of the parts ":@", ":", +-- > ":", and "/" may be excluded. +parseURIAuthority :: String -> Maybe URIAuthority +parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s)) + + +pURIAuthority :: ReadP URIAuthority +pURIAuthority = do + (u,pw) <- (pUserInfo `before` char '@') + <++ return (Nothing, Nothing) + h <- munch (/=':') + p <- orNothing (char ':' >> readDecP) + look >>= guard . null + return URIAuthority{ user=u, password=pw, host=h, port=p } + +pUserInfo :: ReadP (Maybe String, Maybe String) +pUserInfo = do + u <- orNothing (munch (`notElem` ":@")) + p <- orNothing (char ':' >> munch (/='@')) + return (u,p) + +before :: Monad m => m a -> m b -> m a +before a b = a >>= \x -> b >> return x + +orNothing :: ReadP a -> ReadP (Maybe a) +orNothing p = fmap Just p <++ return Nothing + +----------------------------------------------------------------- +------------------ Header Data ---------------------------------- +----------------------------------------------------------------- + + +-- | The Header data type pairs header names & values. +data Header = Header HeaderName String + + +instance Show Header where + show (Header key value) = show key ++ ": " ++ value ++ crlf + + +-- | HTTP Header Name type: +-- Why include this at all? I have some reasons +-- 1) prevent spelling errors of header names, +-- 2) remind everyone of what headers are available, +-- 3) might speed up searches for specific headers. +-- +-- Arguments against: +-- 1) makes customising header names laborious +-- 2) increases code volume. +-- +data HeaderName = + -- Generic Headers -- + HdrCacheControl + | HdrConnection + | HdrDate + | HdrPragma + | HdrTransferEncoding + | HdrUpgrade + | HdrVia + + -- Request Headers -- + | HdrAccept + | HdrAcceptCharset + | HdrAcceptEncoding + | HdrAcceptLanguage + | HdrAuthorization + | HdrCookie + | HdrExpect + | HdrFrom + | HdrHost + | HdrIfModifiedSince + | HdrIfMatch + | HdrIfNoneMatch + | HdrIfRange + | HdrIfUnmodifiedSince + | HdrMaxForwards + | HdrProxyAuthorization + | HdrRange + | HdrReferer + | HdrUserAgent + + -- Response Headers + | HdrAge + | HdrLocation + | HdrProxyAuthenticate + | HdrPublic + | HdrRetryAfter + | HdrServer + | HdrSetCookie + | HdrVary + | HdrWarning + | HdrWWWAuthenticate + + -- Entity Headers + | HdrAllow + | HdrContentBase + | HdrContentEncoding + | HdrContentLanguage + | HdrContentLength + | HdrContentLocation + | HdrContentMD5 + | HdrContentRange + | HdrContentType + | HdrETag + | HdrExpires + | HdrLastModified + + -- Mime entity headers (for sub-parts) + | HdrContentTransferEncoding + + -- | Allows for unrecognised or experimental headers. + | HdrCustom String -- not in header map below. + deriving(Eq) + + +-- Translation between header names and values, +-- good candidate for improvement. +headerMap :: [ (String,HeaderName) ] +headerMap + = [ ("Cache-Control" ,HdrCacheControl ) + , ("Connection" ,HdrConnection ) + , ("Date" ,HdrDate ) + , ("Pragma" ,HdrPragma ) + , ("Transfer-Encoding" ,HdrTransferEncoding ) + , ("Upgrade" ,HdrUpgrade ) + , ("Via" ,HdrVia ) + , ("Accept" ,HdrAccept ) + , ("Accept-Charset" ,HdrAcceptCharset ) + , ("Accept-Encoding" ,HdrAcceptEncoding ) + , ("Accept-Language" ,HdrAcceptLanguage ) + , ("Authorization" ,HdrAuthorization ) + , ("From" ,HdrFrom ) + , ("Host" ,HdrHost ) + , ("If-Modified-Since" ,HdrIfModifiedSince ) + , ("If-Match" ,HdrIfMatch ) + , ("If-None-Match" ,HdrIfNoneMatch ) + , ("If-Range" ,HdrIfRange ) + , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince ) + , ("Max-Forwards" ,HdrMaxForwards ) + , ("Proxy-Authorization" ,HdrProxyAuthorization) + , ("Range" ,HdrRange ) + , ("Referer" ,HdrReferer ) + , ("User-Agent" ,HdrUserAgent ) + , ("Age" ,HdrAge ) + , ("Location" ,HdrLocation ) + , ("Proxy-Authenticate" ,HdrProxyAuthenticate ) + , ("Public" ,HdrPublic ) + , ("Retry-After" ,HdrRetryAfter ) + , ("Server" ,HdrServer ) + , ("Vary" ,HdrVary ) + , ("Warning" ,HdrWarning ) + , ("WWW-Authenticate" ,HdrWWWAuthenticate ) + , ("Allow" ,HdrAllow ) + , ("Content-Base" ,HdrContentBase ) + , ("Content-Encoding" ,HdrContentEncoding ) + , ("Content-Language" ,HdrContentLanguage ) + , ("Content-Length" ,HdrContentLength ) + , ("Content-Location" ,HdrContentLocation ) + , ("Content-MD5" ,HdrContentMD5 ) + , ("Content-Range" ,HdrContentRange ) + , ("Content-Type" ,HdrContentType ) + , ("ETag" ,HdrETag ) + , ("Expires" ,HdrExpires ) + , ("Last-Modified" ,HdrLastModified ) + , ("Set-Cookie" ,HdrSetCookie ) + , ("Cookie" ,HdrCookie ) + , ("Expect" ,HdrExpect ) ] + + +instance Show HeaderName where + show (HdrCustom s) = s + show x = case filter ((==x).snd) headerMap of + [] -> error "headerMap incomplete" + (h:_) -> fst h + + + + + +-- | This class allows us to write generic header manipulation functions +-- for both 'Request' and 'Response' data types. +class HasHeaders x where + getHeaders :: x -> [Header] + setHeaders :: x -> [Header] -> x + + + +-- Header manipulation functions +insertHeader, replaceHeader, insertHeaderIfMissing + :: HasHeaders a => HeaderName -> String -> a -> a + + +-- | Inserts a header with the given name and value. +-- Allows duplicate header names. +insertHeader name value x = setHeaders x newHeaders + where + newHeaders = (Header name value) : getHeaders x + + +-- | Adds the new header only if no previous header shares +-- the same name. +insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) + where + newHeaders list@(h@(Header n _): rest) + | n == name = list + | otherwise = h : newHeaders rest + newHeaders [] = [Header name value] + + + +-- | Removes old headers with duplicate name. +replaceHeader name value x = setHeaders x newHeaders + where + newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ] + + +-- | Inserts multiple headers. +insertHeaders :: HasHeaders a => [Header] -> a -> a +insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) + + +-- | Gets a list of headers with a particular 'HeaderName'. +retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] +retrieveHeaders name x = filter matchname (getHeaders x) + where + matchname (Header n _) | n == name = True + matchname _ = False + + +-- | Lookup presence of specific HeaderName in a list of Headers +-- Returns the value from the first matching header. +findHeader :: HasHeaders a => HeaderName -> a -> Maybe String +findHeader n x = lookupHeader n (getHeaders x) + +-- An anomally really: +lookupHeader :: HeaderName -> [Header] -> Maybe String +lookupHeader v (Header n s:t) | v == n = Just s + | otherwise = lookupHeader v t +lookupHeader _ _ = Nothing + + + + +{- +instance HasHeaders [Header] +...requires -fglasgow-exts, and is not really necessary anyway... +-} + + + +----------------------------------------------------------------- +------------------ HTTP Messages -------------------------------- +----------------------------------------------------------------- + + +-- Protocol version +httpVersion :: String +httpVersion = "HTTP/1.1" + + +-- | The HTTP request method, to be used in the 'Request' object. +-- We are missing a few of the stranger methods, but these are +-- not really necessary until we add full TLS. +data RequestMethod = HEAD | PUT | GET | POST | OPTIONS | TRACE + deriving(Show,Eq) + +rqMethodMap = [("HEAD", HEAD), + ("PUT", PUT), + ("GET", GET), + ("POST", POST), + ("OPTIONS", OPTIONS), + ("TRACE", TRACE)] + +-- | An HTTP Request. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output. +data Request = + Request { rqURI :: URI -- ^ might need changing in future + -- 1) to support '*' uri in OPTIONS request + -- 2) transparent support for both relative + -- & absolute uris, although this should + -- already work (leave scheme & host parts empty). + , rqMethod :: RequestMethod + , rqHeaders :: [Header] + , rqBody :: String + } + + + + +-- Notice that request body is not included, +-- this show function is used to serialise +-- a request for the transport link, we send +-- the body separately where possible. +instance Show Request where + show (Request u m h _) = + show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf + ++ foldr (++) [] (map show h) ++ crlf + where + alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' + then u { uriPath = '/' : uriPath u } + else u + + +instance HasHeaders Request where + getHeaders = rqHeaders + setHeaders rq hdrs = rq { rqHeaders=hdrs } + + + + + + +type ResponseCode = (Int,Int,Int) +type ResponseData = (ResponseCode,String,[Header]) +type RequestData = (RequestMethod,URI,[Header]) + +-- | An HTTP Response. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output, additionally the output will +-- show an HTTP version of 1.1 instead of the actual version returned +-- by a server. +data Response = + Response { rspCode :: ResponseCode + , rspReason :: String + , rspHeaders :: [Header] + , rspBody :: String + } + + + +-- This is an invalid representation of a received response, +-- since we have made the assumption that all responses are HTTP/1.1 +instance Show Response where + show (Response (a,b,c) reason headers _) = + httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf + ++ foldr (++) [] (map show headers) ++ crlf + + + +instance HasHeaders Response where + getHeaders = rspHeaders + setHeaders rsp hdrs = rsp { rspHeaders=hdrs } + +----------------------------------------------------------------- +------------------ Parsing -------------------------------------- +----------------------------------------------------------------- + +parseHeader :: String -> Result Header +parseHeader str = + case split ':' str of + Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str) + Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v) + where + fn k = case map snd $ filter (match k . fst) headerMap of + [] -> (HdrCustom k) + (h:_) -> h + + match :: String -> String -> Bool + match s1 s2 = map toLower s1 == map toLower s2 + + +parseHeaders :: [String] -> Result [Header] +parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended "" + where + -- Joins consecutive lines where the second line + -- begins with ' ' or '\t'. + joinExtended old (h : t) + | not (null h) && (head h == ' ' || head h == '\t') + = joinExtended (old ++ ' ' : tail h) t + | otherwise = old : joinExtended h t + joinExtended old [] = [old] + + clean [] = [] + clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t + | otherwise = h : clean t + + -- tollerant of errors? should parse + -- errors here be reported or ignored? + -- currently ignored. + catRslts :: [a] -> [Result a] -> Result [a] + catRslts list (h:t) = + case h of + Left _ -> catRslts list t + Right v -> catRslts (v:list) t + catRslts list [] = Right $ reverse list + + +-- Parsing a request +parseRequestHead :: [String] -> Result RequestData +parseRequestHead [] = Left ErrorClosed +parseRequestHead (com:hdrs) = + requestCommand com `bindE` \(version,rqm,uri) -> + parseHeaders hdrs `bindE` \hdrs' -> + Right (rqm,uri,hdrs') + where + requestCommand line + = case words line of + yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of + (Just u, Just r) -> Right (version,r,u) + _ -> Left (ErrorParse $ "Request command line parse failure: " ++ line) + no -> if null line + then Left ErrorClosed + else Left (ErrorParse $ "Request command line parse failure: " ++ line) + +-- Parsing a response +parseResponseHead :: [String] -> Result ResponseData +parseResponseHead [] = Left ErrorClosed +parseResponseHead (sts:hdrs) = + responseStatus sts `bindE` \(version,code,reason) -> + parseHeaders hdrs `bindE` \hdrs' -> + Right (code,reason,hdrs') + where + + responseStatus line + = case words line of + yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason) + no -> if null line + then Left ErrorClosed -- an assumption + else Left (ErrorParse $ "Response status line parse failure: " ++ line) + + + match [a,b,c] = (digitToInt a, + digitToInt b, + digitToInt c) + match _ = (-1,-1,-1) -- will create appropriate behaviour + + + + +----------------------------------------------------------------- +------------------ HTTP Send / Recv ---------------------------------- +----------------------------------------------------------------- + +data Behaviour = Continue + | Retry + | Done + | ExpectEntity + | DieHorribly String + + + + + +matchResponse :: RequestMethod -> ResponseCode -> Behaviour +matchResponse rqst rsp = + case rsp of + (1,0,0) -> Continue + (1,0,1) -> Done -- upgrade to TLS + (1,_,_) -> Continue -- default + (2,0,4) -> Done + (2,0,5) -> Done + (2,_,_) -> ans + (3,0,4) -> Done + (3,0,5) -> Done + (3,_,_) -> ans + (4,1,7) -> Retry -- Expectation failed + (4,_,_) -> ans + (5,_,_) -> ans + (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised") + where + ans | rqst == HEAD = Done + | otherwise = ExpectEntity + + +-- | Simple way to get a resource across a non-persistant connection. +-- Headers that may be altered: +-- Host Altered only if no Host header is supplied, HTTP\/1.1 +-- requires a Host header. +-- Connection Where no allowance is made for persistant connections +-- the Connection header will be set to "close" +simpleHTTP :: Request -> IO (Result Response) +simpleHTTP r = + do + auth <- getAuth r + c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response) +simpleHTTP_ s r = + do + auth <- getAuth r + let r' = fixReq auth r + rsp <- if debug then do + s' <- debugStream httpLogFile s + sendHTTP s' r' + else + sendHTTP s r' + -- already done by sendHTTP because of "Connection: close" header + --; close s + return rsp + where + {- RFC 2616, section 5.1.2: + "The most common form of Request-URI is that used to identify a + resource on an origin server or gateway. In this case the absolute + path of the URI MUST be transmitted (see section 3.2.1, abs_path) as + the Request-URI, and the network location of the URI (authority) MUST + be transmitted in a Host header field." -} + -- we assume that this is the case, so we take the host name from + -- the Host header if there is one, otherwise from the request-URI. + -- Then we make the request-URI an abs_path and make sure that there + -- is a Host header. + fixReq :: URIAuthority -> Request -> Request + fixReq URIAuthority{host=h} r = + replaceHeader HdrConnection "close" $ + insertHeaderIfMissing HdrHost h $ + r { rqURI = (rqURI r){ uriScheme = "", + uriAuthority = Nothing } } + +getAuth :: Monad m => Request -> m URIAuthority +getAuth r = case parseURIAuthority auth of + Just x -> return x + Nothing -> fail $ "Error parsing URI authority '" + ++ auth ++ "'" + where auth = case findHeader HdrHost r of + Just h -> h + Nothing -> uriToAuthorityString (rqURI r) + +sendHTTP :: Stream s => s -> Request -> IO (Result Response) +sendHTTP conn rq = + do { let a_rq = fixHostHeader rq + ; rsp <- Exception.catch (main a_rq) + (\e -> do { close conn; throw e }) + ; let fn list = when (or $ map findConnClose list) + (close conn) + ; either (\_ -> fn [rqHeaders rq]) + (\r -> fn [rqHeaders rq,rspHeaders r]) + rsp + ; return rsp + } + where +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- Since we would wait forever, I have disabled use of 100-continue for now. + main :: Request -> IO (Result Response) + main rqst = + do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + writeBlock conn (show rqst) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rqBody rqst) + rsp <- getResponseHead + switchResponse True False rsp rqst + + -- reads and parses headers + getResponseHead :: IO (Result ResponseData) + getResponseHead = + do { lor <- readTillEmpty1 conn + ; return $ lor `bindE` parseResponseHead + } + + -- Hmmm, this could go bad if we keep getting "100 Continue" + -- responses... Except this should never happen according + -- to the RFC. + switchResponse :: Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request + -> IO (Result Response) + + switchResponse _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- if we attempt to use the same socket then there is an excellent + -- chance that the socket is not in a completely closed state. + + switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> {- Time to send the body -} + do { val <- writeBlock conn (rqBody rqst) + ; case val of + Left e -> return (Left e) + Right _ -> + do { rsp <- getResponseHead + ; switchResponse allow_retry True rsp rqst + } + } + | otherwise -> {- keep waiting -} + do { rsp <- getResponseHead + ; switchResponse allow_retry bdy_sent rsp rqst + } + + Retry -> {- Request with "Expect" header failed. + Trouble is the request contains Expects + other than "100-Continue" -} + do { writeBlock conn (show rqst ++ rqBody rqst) + ; rsp <- getResponseHead + ; switchResponse False bdy_sent rsp rqst + } + + Done -> + return (Right $ Response cd rn hdrs "") + + DieHorribly str -> + return $ Left $ ErrorParse ("Invalid response: " ++ str) + + ExpectEntity -> + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + in + do { rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer conn (read x :: Int) + Nothing -> hopefulTransfer conn "" + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer conn + _ -> uglyDeathTransfer conn + ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) + } + + + -- Adds a Host header if one is NOT ALREADY PRESENT + fixHostHeader :: Request -> Request + fixHostHeader rq = + let uri = rqURI rq + host = uriToAuthorityString uri + in insertHeaderIfMissing HdrHost host rq + + -- Looks for a "Connection" header with the value "close". + -- Returns True when this is found. + findConnClose :: [Header] -> Bool + findConnClose hdrs = + case lookupHeader HdrConnection hdrs of + Nothing -> False + Just x -> map toLower (trim x) == "close" + +-- This function duplicates old Network.URI.authority behaviour. +uriToAuthorityString :: URI -> String +uriToAuthorityString URI{uriAuthority=Nothing} = "" +uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua ++ + uriRegName ua ++ + uriPort ua + +-- | Receive and parse a HTTP request from the given Stream. Should be used +-- for server side interactions. +receiveHTTP :: Stream s => s -> IO (Result Request) +receiveHTTP conn = do rq <- getRequestHead + processRequest rq + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = + do { lor <- readTillEmpty1 conn + ; return $ lor `bindE` parseRequestHead + } + + processRequest (Left e) = return $ Left e + processRequest (Right (rm,uri,hdrs)) = + do -- FIXME : Also handle 100-continue. + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer conn (read x :: Int) + Nothing -> return (Right ([], "")) -- hopefulTransfer "" + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer conn + _ -> uglyDeathTransfer conn + + return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy) + + +-- | Very simple function, send a HTTP response over the given stream. This +-- could be improved on to use different transfer types. +respondHTTP :: Stream s => s -> Response -> IO () +respondHTTP conn rsp = do writeBlock conn (show rsp) + -- write body immediately, don't wait for 100 CONTINUE + writeBlock conn (rspBody rsp) + return () + +-- The following functions were in the where clause of sendHTTP, they have +-- been moved to global scope so other functions can access them. + +-- | Used when we know exactly how many bytes to expect. +linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String)) +linearTransfer conn n + = do info <- readBlock conn n + return $ info `bindE` \str -> Right ([],str) + +-- | Used when nothing about data is known, +-- Unfortunately waiting for a socket closure +-- causes bad behaviour. Here we just +-- take data once and give up the rest. +hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String)) +hopefulTransfer conn str + = readLine conn >>= + either (\v -> return $ Left v) + (\more -> if null more + then return (Right ([],str)) + else hopefulTransfer conn (str++more)) +-- | A necessary feature of HTTP\/1.1 +-- Also the only transfer variety likely to +-- return any footers. +chunkedTransfer :: Stream s => s -> IO (Result ([Header],String)) +chunkedTransfer conn + = chunkedTransferC conn 0 >>= \v -> + return $ v `bindE` \(ftrs,count,info) -> + let myftrs = Header HdrContentLength (show count) : ftrs + in Right (myftrs,info) + +chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String)) +chunkedTransferC conn n + = readLine conn >>= \v -> case v of + Left e -> return (Left e) + Right line -> + let size = ( if null line || (head line) == '0' + then 0 + else case readHex line of + (n,_):_ -> n + _ -> 0 + ) + in if size == 0 + then do { rs <- readTillEmpty2 conn [] + ; return $ + rs `bindE` \strs -> + parseHeaders strs `bindE` \ftrs -> + Right (ftrs,n,"") + } + else do { some <- readBlock conn size + ; readLine conn + ; more <- chunkedTransferC conn (n+size) + ; return $ + some `bindE` \cdata -> + more `bindE` \(ftrs,m,mdata) -> + Right (ftrs,m,cdata++mdata) + } + +-- | Maybe in the future we will have a sensible thing +-- to do here, at that time we might want to change +-- the name. +uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String)) +uglyDeathTransfer conn + = return $ Left $ ErrorParse "Unknown Transfer-Encoding" + +-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) +readTillEmpty1 :: Stream s => s -> IO (Result [String]) +readTillEmpty1 conn = + do { line <- readLine conn + ; case line of + Left e -> return $ Left e + Right s -> + if s == crlf + then readTillEmpty1 conn + else readTillEmpty2 conn [s] + } + +-- | Read lines until an empty line (CRLF), +-- also accepts a connection close as end of +-- input, which is not an HTTP\/1.1 compliant +-- thing to do - so probably indicates an +-- error condition. +readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String]) +readTillEmpty2 conn list = + do { line <- readLine conn + ; case line of + Left e -> return $ Left e + Right s -> + if s == crlf || null s + then return (Right $ reverse (s:list)) + else readTillEmpty2 conn (s:list) + } + + +----------------------------------------------------------------- +------------------ A little friendly funtionality --------------- +----------------------------------------------------------------- + + +{- + I had a quick look around but couldn't find any RFC about + the encoding of data on the query string. I did find an + IETF memo, however, so this is how I justify the urlEncode + and urlDecode methods. + + Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) + + Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. + Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" + URI delims: "<" | ">" | "#" | "%" | <"> + Unallowed ASCII: + + Also unallowed: any non-us-ascii character + + Escape method: char -> '%' a b where a, b :: Hex digits +-} + +urlEncode, urlDecode :: String -> String + +urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b) + : urlDecode rest +urlDecode (h:t) = h : urlDecode t +urlDecode [] = [] + +urlEncode (h:t) = + let str = if reserved (ord h) then escape h else [h] + in str ++ urlEncode t + where + reserved x + | x >= ord 'a' && x <= ord 'z' = False + | x >= ord 'A' && x <= ord 'Z' = False + | x >= ord '0' && x <= ord '9' = False + | x <= 0x20 || x >= 0x7F = True + | otherwise = x `elem` map ord [';','/','?',':','@','&' + ,'=','+',',','$','{','}' + ,'|','\\','^','[',']','`' + ,'<','>','#','%','"'] + -- wouldn't it be nice if the compiler + -- optimised the above for us? + + escape x = + let y = ord x + in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ] + +urlEncode [] = [] + + + +-- Encode form variables, useable in either the +-- query part of a URI, or the body of a POST request. +-- I have no source for this information except experience, +-- this sort of encoding worked fine in CGI programming. +urlEncodeVars :: [(String,String)] -> String +urlEncodeVars ((n,v):t) = + let (same,diff) = partition ((==n) . fst) t + in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) + ++ urlEncodeRest diff + where urlEncodeRest [] = [] + urlEncodeRest diff = '&' : urlEncodeVars diff +urlEncodeVars [] = [] diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Base64.hs @@ -0,0 +1,284 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Binary.Base64 +-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See +-- and . +-- +----------------------------------------------------------------------------- + +module Network.HTTP.Base64 ( + encode, + decode, + chop72 +) where + + + +{------------------------------------------------------------------------ +This is what RFC2045 had to say: + +6.8. Base64 Content-Transfer-Encoding + + The Base64 Content-Transfer-Encoding is designed to represent + arbitrary sequences of octets in a form that need not be humanly + readable. The encoding and decoding algorithms are simple, but the + encoded data are consistently only about 33 percent larger than the + unencoded data. This encoding is virtually identical to the one used + in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421. + + A 65-character subset of US-ASCII is used, enabling 6 bits to be + represented per printable character. (The extra 65th character, "=", + is used to signify a special processing function.) + + NOTE: This subset has the important property that it is represented + identically in all versions of ISO 646, including US-ASCII, and all + characters in the subset are also represented identically in all + versions of EBCDIC. Other popular encodings, such as the encoding + used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and + the base85 encoding specified as part of Level 2 PostScript, do not + share these properties, and thus do not fulfill the portability + requirements a binary transport encoding for mail must meet. + + The encoding process represents 24-bit groups of input bits as output + strings of 4 encoded characters. Proceeding from left to right, a + 24-bit input group is formed by concatenating 3 8bit input groups. + These 24 bits are then treated as 4 concatenated 6-bit groups, each + of which is translated into a single digit in the base64 alphabet. + When encoding a bit stream via the base64 encoding, the bit stream + must be presumed to be ordered with the most-significant-bit first. + That is, the first bit in the stream will be the high-order bit in + the first 8bit byte, and the eighth bit will be the low-order bit in + the first 8bit byte, and so on. + + Each 6-bit group is used as an index into an array of 64 printable + characters. The character referenced by the index is placed in the + output string. These characters, identified in Table 1, below, are + selected so as to be universally representable, and the set excludes + characters with particular significance to SMTP (e.g., ".", CR, LF) + and to the multipart boundary delimiters defined in RFC 2046 (e.g., + "-"). + + + + Table 1: The Base64 Alphabet + + Value Encoding Value Encoding Value Encoding Value Encoding + 0 A 17 R 34 i 51 z + 1 B 18 S 35 j 52 0 + 2 C 19 T 36 k 53 1 + 3 D 20 U 37 l 54 2 + 4 E 21 V 38 m 55 3 + 5 F 22 W 39 n 56 4 + 6 G 23 X 40 o 57 5 + 7 H 24 Y 41 p 58 6 + 8 I 25 Z 42 q 59 7 + 9 J 26 a 43 r 60 8 + 10 K 27 b 44 s 61 9 + 11 L 28 c 45 t 62 + + 12 M 29 d 46 u 63 / + 13 N 30 e 47 v + 14 O 31 f 48 w (pad) = + 15 P 32 g 49 x + 16 Q 33 h 50 y + + The encoded output stream must be represented in lines of no more + than 76 characters each. All line breaks or other characters not + found in Table 1 must be ignored by decoding software. In base64 + data, characters other than those in Table 1, line breaks, and other + white space probably indicate a transmission error, about which a + warning message or even a message rejection might be appropriate + under some circumstances. + + Special processing is performed if fewer than 24 bits are available + at the end of the data being encoded. A full encoding quantum is + always completed at the end of a body. When fewer than 24 input bits + are available in an input group, zero bits are added (on the right) + to form an integral number of 6-bit groups. Padding at the end of + the data is performed using the "=" character. Since all base64 + input is an integral number of octets, only the following cases can + arise: (1) the final quantum of encoding input is an integral + multiple of 24 bits; here, the final unit of encoded output will be + an integral multiple of 4 characters with no "=" padding, (2) the + final quantum of encoding input is exactly 8 bits; here, the final + unit of encoded output will be two characters followed by two "=" + padding characters, or (3) the final quantum of encoding input is + exactly 16 bits; here, the final unit of encoded output will be three + characters followed by one "=" padding character. + + Because it is used only for padding at the end of the data, the + occurrence of any "=" characters may be taken as evidence that the + end of the data has been reached (without truncation in transit). No + such assurance is possible, however, when the number of octets + transmitted was a multiple of three and no "=" characters are + present. + + Any characters outside of the base64 alphabet are to be ignored in + base64-encoded data. + + Care must be taken to use the proper octets for line breaks if base64 + encoding is applied directly to text material that has not been + converted to canonical form. In particular, text line breaks must be + converted into CRLF sequences prior to base64 encoding. The + important thing to note is that this may be done directly by the + encoder rather than in a prior canonicalization step in some + implementations. + + NOTE: There is no need to worry about quoting potential boundary + delimiters within base64-encoded bodies within multipart entities + because no hyphen characters are used in the base64 encoding. + + +----------------------------------------------------------------------------} + + +{- + +The following properties should hold: + + decode . encode = id + decode . chop72 . encode = id + +I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, +the second variation corresponds better with the RFC above, but outside of +MIME applications might be undesireable. + + + +But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only + 8 significant bits, which is more than enough for US-ASCII. +-} + + + + +import Data.Array +import Data.Bits +import Data.Int +import Data.Char (chr,ord) +import Data.Word (Word8) + +type Octet = Word8 + +encodeArray :: Array Int Char +encodeArray = array (0,64) + [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') + , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') + , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') + , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') + , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d') + , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') + , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') + , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') + , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') + , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') + , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] + + +-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) +-- clearly the upmost/leftmost 8 bits of the answer are 0. +-- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. +-- 0 represents a 4 :( +int4_char3 :: [Int] -> [Char] +int4_char3 (a:b:c:d:t) = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) + in (chr (n `shiftR` 16 .&. 0xff)) + : (chr (n `shiftR` 8 .&. 0xff)) + : (chr (n .&. 0xff)) : int4_char3 t + +int4_char3 [a,b,c] = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) + in [ (chr (n `shiftR` 16 .&. 0xff)) + , (chr (n `shiftR` 8 .&. 0xff)) ] + +int4_char3 [a,b] = + let n = (a `shiftL` 18 .|. b `shiftL` 12) + in [ (chr (n `shiftR` 16 .&. 0xff)) ] + +int4_char3 [] = [] + + + + +-- Convert triplets of characters to +-- 4 base64 integers. The last entries +-- in the list may not produce 4 integers, +-- a trailing 2 character group gives 3 integers, +-- while a trailing single character gives 2 integers. +char3_int4 :: [Char] -> [Int] +char3_int4 (a:b:c:t) + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) + in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t + +char3_int4 [a,b] + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) + in [ (n `shiftR` 18 .&. 0x3f) + , (n `shiftR` 12 .&. 0x3f) + , (n `shiftR` 6 .&. 0x3f) ] + +char3_int4 [a] + = let n = (ord a `shiftL` 16) + in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)] + +char3_int4 [] = [] + + +-- Retrieve base64 char, given an array index integer in the range [0..63] +enc1 :: Int -> Char +enc1 ch = encodeArray!ch + + +-- | Cut up a string into 72 char lines, each line terminated by CRLF. + +chop72 :: String -> String +chop72 str = let (bgn,end) = splitAt 70 str + in if null end then bgn else "\r\n" ++ chop72 end + + +-- Pads a base64 code to a multiple of 4 characters, using the special +-- '=' character. +quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t +quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit +quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit +quadruplets [] = [] -- 24bit tail unit + + +enc :: [Int] -> [Char] +enc = quadruplets . map enc1 + + +dcd [] = [] +dcd (h:t) + | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t + | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t + | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t + | h == '+' = 62 : dcd t + | h == '/' = 63 : dcd t + | h == '=' = [] -- terminate data stream + | otherwise = dcd t + + +-- Principal encoding and decoding functions. + +encode :: [Octet] -> String +encode = enc . char3_int4 . (map (chr .fromIntegral)) + +{- +prop_base64 os = + os == (f . g . h) os + where types = (os :: [Word8]) + f = map (fromIntegral. ord) + g = decode . encode + h = map (chr . fromIntegral) +-} + +decode :: String -> [Octet] +decode = (map (fromIntegral . ord)) . int4_char3 . dcd diff --git a/Network/HTTP/MD5.hs b/Network/HTTP/MD5.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/MD5.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Digest.MD5 +-- Copyright : (c) Dominic Steinitz 2004 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Takes the MD5 module supplied by Ian Lynagh and wraps it so it +-- takes [Octet] and returns [Octet] where the length of the result +-- is always 16. +-- See +-- and . +-- +----------------------------------------------------------------------------- + +module Network.HTTP.MD5 ( + -- * Function Types + hash) where + +import Data.Char(chr) +import Data.List(unfoldr) +import Numeric(readHex) + +import Network.HTTP.MD5Aux +import Data.Word (Word8) + +type Octet = Word8 + +-- | Take [Octet] and return [Octet] according to the standard. +-- The length of the result is always 16 octets or 128 bits as required +-- by the standard. + +hash :: [Octet] -> [Octet] +hash xs = + unfoldr f $ md5s $ Str $ map (chr . fromIntegral) xs + where f :: String -> Maybe (Octet,String) + f [] = + Nothing + f (x:y:zs) = + Just (fromIntegral a,zs) + where [(a,_)] = readHex (x:y:[]) diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/MD5Aux.hs @@ -0,0 +1,355 @@ +module Network.HTTP.MD5Aux + (md5, md5s, md5i, + MD5(..), ABCD(..), + Zord64, Str(..), BoolList(..), WordList(..)) where + +import Data.Char +import Data.Bits +import Data.Word + +{- +Nasty kludge to create a type Zord64 which is really a Word64 but works +how we want in hugs ands nhc98 too... +Also need a rotate left function that actually works. + +#ifdef __GLASGOW_HASKELL__ +#define rotL rotateL +#include "Zord64_EASY.hs" +#else + +> import Zord64_HARD + +> rotL :: Word32 -> Rotation -> Word32 +> rotL a s = shiftL a s .|. shiftL a (s-32) + +#endif +-} + +rotL x = rotateL x +type Zord64 = Word64 + +-- ===================== TYPES AND CLASS DEFINTIONS ======================== + + +type XYZ = (Word32, Word32, Word32) +type Rotation = Int +newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) +newtype Str = Str String +newtype BoolList = BoolList [Bool] +newtype WordList = WordList ([Word32], Zord64) + +-- Anything we want to work out the MD5 of must be an instance of class MD5 + +class MD5 a where + get_next :: a -> ([Word32], Int, a) -- get the next blocks worth + -- \ \ \------ the rest of the input + -- \ \--------- the number of bits returned + -- \--------------- the bits returned in 32bit words + len_pad :: Zord64 -> a -> a -- append the padding and length + finished :: a -> Bool -- Have we run out of input yet? + + +-- Mainly exists because it's fairly easy to do MD5s on input where the +-- length is not a multiple of 8 + +instance MD5 BoolList where + get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) + where (ys, zs) = splitAt 512 s + len_pad l (BoolList bs) + = BoolList (bs ++ [True] + ++ replicate (fromIntegral $ (447 - l) .&. 511) False + ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] + ) + where mangle [] = [] + mangle xs = reverse ys ++ mangle zs + where (ys, zs) = splitAt 8 xs + finished (BoolList s) = s == [] + + +-- The string instance is fairly straightforward + +instance MD5 Str where + get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) + where (ys, zs) = splitAt 64 s + len_pad c64 (Str s) = Str (s ++ padding ++ l) + where padding = '\128':replicate (fromIntegral zeros) '\000' + zeros = shiftR ((440 - c64) .&. 511) 3 + l = length_to_chars 8 c64 + finished (Str s) = s == "" + + +-- YA instance that is believed will be useful + +instance MD5 WordList where + get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) + where (xs, ys) = splitAt 16 ws + taken = if l > 511 then 512 else l .&. 511 + len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) + where beginning = if length ws > 0 then start ++ lastone' else [] + start = init ws + lastone = last ws + offset = c64 .&. 31 + lastone' = [if offset > 0 then lastone + theone else lastone] + theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) + (fromIntegral $ offset .&. (31 - 7)) + nextish = if offset == 0 then [128] else [] + c64' = c64 + (32 - offset) + num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) + blanks = replicate num_blanks 0 + lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) + topsize = fromIntegral $ shiftR c64 32 + size = [lowsize, topsize] + newlen = l .&. (complement 511) + + if c64 .&. 511 >= 448 then 1024 else 512 + finished (WordList (_, z)) = z == 0 + + +instance Num ABCD where + ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + + +-- ===================== EXPORTED FUNCTIONS ======================== + + +-- The simplest function, gives you the MD5 of a string as 4-tuple of +-- 32bit words. + +md5 :: (MD5 a) => a -> ABCD +md5 m = md5_main False 0 magic_numbers m + + +-- Returns a hex number ala the md5sum program + +md5s :: (MD5 a) => a -> String +md5s = abcd_to_string . md5 + + +-- Returns an integer equivalent to the above hex number + +md5i :: (MD5 a) => a -> Integer +md5i = abcd_to_integer . md5 + + +-- ===================== THE CORE ALGORITHM ======================== + + +-- Decides what to do. The first argument indicates if padding has been +-- added. The second is the length mod 2^64 so far. Then we have the +-- starting state, the rest of the string and the final state. + +md5_main :: (MD5 a) => + Bool -- Have we added padding yet? + -> Zord64 -- The length so far mod 2^64 + -> ABCD -- The initial state + -> a -- The non-processed portion of the message + -> ABCD -- The resulting state +md5_main padded ilen abcd m + = if finished m && padded + then abcd + else md5_main padded' (ilen + 512) (abcd + abcd') m'' + where (m16, l, m') = get_next m + len' = ilen + fromIntegral l + ((m16', _, m''), padded') = if not padded && l < 512 + then (get_next $ len_pad len' m, True) + else ((m16, l, m'), padded) + abcd' = md5_do_block abcd m16' + + +-- md5_do_block processes a 512 bit block by calling md5_round 4 times to +-- apply each round with the correct constants and permutations of the +-- block + +md5_do_block :: ABCD -- Initial state + -> [Word32] -- The block to be processed - 16 32bit words + -> ABCD -- Resulting state +md5_do_block abcd0 w = abcd4 + where (r1, r2, r3, r4) = rounds + {- + map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] + -- [(5 * x + 1) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] + -- [(3 * x + 5) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] + -- [(7 * x) `mod` 16 | x <- [0..15]] + -} + perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] + perm5 _ = error "broke at perm5" + perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] + perm3 _ = error "broke at perm3" + perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] + perm7 _ = error "broke at perm7" + abcd1 = md5_round md5_f abcd0 w r1 + abcd2 = md5_round md5_g abcd1 (perm5 w) r2 + abcd3 = md5_round md5_h abcd2 (perm3 w) r3 + abcd4 = md5_round md5_i abcd3 (perm7 w) r4 + + +-- md5_round does one of the rounds. It takes an auxiliary function and foldls +-- (md5_inner_function f) to repeatedly apply it to the initial state with the +-- correct constants + +md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I + -- for those of you with a copy of + -- the prayer book^W^WRFC) + -> ABCD -- Initial state + -> [Word32] -- The 16 32bit words of input + -> [(Rotation, Word32)] -- The list of 16 rotations and + -- additive constants + -> ABCD -- Resulting state +md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' + where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns + + +-- Apply one of the functions md5_[fghi] and put the new ABCD together + +md5_inner_function :: (XYZ -> Word32) -- Auxiliary function + -> ABCD -- Initial state + -> (Rotation, Word32) -- The rotation and additive + -- constant (X[i] + T[j]) + -> ABCD -- Resulting state +md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) + where mid_a = a + f(b,c,d) + ki + rot_a = rotL mid_a s + a' = b + rot_a + + +-- The 4 auxiliary functions + +md5_f :: XYZ -> Word32 +md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) +{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} + +md5_g :: XYZ -> Word32 +md5_g (x, y, z) = md5_f (z, x, y) +{- was: (x .&. z) .|. (y .&. (complement z)) -} + +md5_h :: XYZ -> Word32 +md5_h (x, y, z) = x `xor` y `xor` z + +md5_i :: XYZ -> Word32 +md5_i (x, y, z) = y `xor` (x .|. (complement z)) + + +-- The magic numbers from the RFC. + +magic_numbers :: ABCD +magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) + + +-- The 4 lists of (rotation, additive constant) tuples, one for each round + +rounds :: ([(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)]) +rounds = (r1, r2, r3, r4) + where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), + (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), + (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), + (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), + (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), + (s14, 0x49b40821)] + r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), + (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), + (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), + (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), + (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), + (s24, 0x8d2a4c8a)] + r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), + (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), + (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), + (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), + (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), + (s34, 0xc4ac5665)] + r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), + (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), + (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), + (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), + (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), + (s44, 0xeb86d391)] + s11 = 7 + s12 = 12 + s13 = 17 + s14 = 22 + s21 = 5 + s22 = 9 + s23 = 14 + s24 = 20 + s31 = 4 + s32 = 11 + s33 = 16 + s34 = 23 + s41 = 6 + s42 = 10 + s43 = 15 + s44 = 21 + + +-- ===================== CONVERSION FUNCTIONS ======================== + + +-- Turn the 4 32 bit words into a string representing the hex number they +-- represent. + +abcd_to_string :: ABCD -> String +abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] + + +-- Split the 32 bit word up, swap the chunks over and convert the numbers +-- to their hex equivalents. + +display_32bits_as_hex :: Word32 -> String +display_32bits_as_hex w = swap_pairs cs + where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] + getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + +-- Convert to an integer, performing endianness magic as we go + +abcd_to_integer :: ABCD -> Integer +abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + + rev_num b * 2^(64 :: Int) + + rev_num c * 2^(32 :: Int) + + rev_num d + +rev_num :: Word32 -> Integer +rev_num i = toInteger j `mod` (2^(32 :: Int)) + -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ + where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) + 0 [0,8,16,24] + +-- Used to convert a 64 byte string to 16 32bit words + +string_to_word32s :: String -> [Word32] +string_to_word32s "" = [] +string_to_word32s ss = this:string_to_word32s ss' + where (s, ss') = splitAt 4 ss + this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s + + +-- Used to convert a list of 512 bools to 16 32bit words + +bools_to_word32s :: [Bool] -> [Word32] +bools_to_word32s [] = [] +bools_to_word32s bs = this:bools_to_word32s rest + where (bs1, bs1') = splitAt 8 bs + (bs2, bs2') = splitAt 8 bs1' + (bs3, bs3') = splitAt 8 bs2' + (bs4, rest) = splitAt 8 bs3' + this = boolss_to_word32 [bs1, bs2, bs3, bs4] + bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 + boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 + + +-- Convert the size into a list of characters used by the len_pad function +-- for strings + +length_to_chars :: Int -> Zord64 -> 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/Stream.hs b/Network/Stream.hs new file mode 100644 --- /dev/null +++ b/Network/Stream.hs @@ -0,0 +1,175 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.Stream +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004 +-- License : BSD +-- +-- Maintainer : bjorn@bringert.net +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An library for creating abstract streams. Originally part of Gray's\/Bringert's +-- HTTP module. +-- +-- * Changes by Simon Foster: +-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules +-- +----------------------------------------------------------------------------- +module Network.Stream ( + -- ** Streams + Debug, + Stream(..), + debugStream, + + -- ** Errors + ConnError(..), + Result, + handleSocketError, + bindE, + myrecv + +) where + +import Control.Exception as Exception +import System.IO.Error + +-- Networking +import Network (withSocketsDo) +import Network.BSD +import Network.URI +import Network.Socket + +import Control.Monad (when,liftM,guard) +import System.IO + +data ConnError = ErrorReset + | ErrorClosed + | ErrorParse String + | ErrorMisc String + deriving(Show,Eq) + +-- error propagating: +-- we could've used a monad, but that would lead us +-- into using the "-fglasgow-exts" compile flag. +bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b +bindE (Left e) _ = Left e +bindE (Right v) f = f v + +-- | This is the type returned by many exported network functions. +type Result a = Either ConnError {- error -} + a {- result -} + +----------------------------------------------------------------- +------------------ Gentle Art of Socket Sucking ----------------- +----------------------------------------------------------------- + +-- | Streams should make layering of TLS protocol easier in future, +-- they allow reading/writing to files etc for debugging, +-- they allow use of protocols other than TCP/IP +-- and they allow customisation. +-- +-- Instances of this class should not trim +-- the input in any way, e.g. leave LF on line +-- endings etc. Unless that is exactly the behaviour +-- you want from your twisted instances ;) +class Stream x where + readLine :: x -> IO (Result String) + readBlock :: x -> Int -> IO (Result String) + writeBlock :: x -> String -> IO (Result ()) + close :: x -> IO () + + + + + +-- Exception handler for socket operations +handleSocketError :: Socket -> Exception -> IO (Result a) +handleSocketError sk e = + do { se <- getSocketOption sk SoError + ; if se == 0 + then throw e + else return $ if se == 10054 -- reset + then Left ErrorReset + else Left $ ErrorMisc $ show se + } + + + + +instance Stream Socket where + readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk) + where + fn x = do { str <- myrecv sk x + ; let len = length str + ; if len < x + then ( fn (x-len) >>= \more -> return (str++more) ) + else return str + } + + -- Use of the following function is discouraged. + -- The function reads in one character at a time, + -- which causes many calls to the kernel recv() + -- hence causes many context switches. + readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk) + where + fn str = + do { c <- myrecv sk 1 -- like eating through a straw. + ; if null c || c == "\n" + then return (reverse str++c) + else fn (head c:str) + } + + writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk) + where + fn [] = return () + fn x = send sk x >>= \i -> fn (drop i x) + + -- This slams closed the connection (which is considered rude for TCP\/IP) + close sk = shutdown sk ShutdownBoth >> sClose sk + +myrecv :: Socket -> Int -> IO String +myrecv sock len = + let handler e = if isEOFError e then return [] else ioError e + in System.IO.Error.catch (recv sock len) handler + +-- | Allows stream logging. +-- Refer to 'debugStream' below. +data Debug x = Dbg Handle x + + +instance (Stream x) => Stream (Debug x) where + readBlock (Dbg h c) n = + do { val <- readBlock c n + ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val) + ; return val + } + + readLine (Dbg h c) = + do { val <- readLine c + ; hPutStrLn h ("readLine " ++ show val) + ; return val + } + + writeBlock (Dbg h c) str = + do { val <- writeBlock c str + ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str) + ; return val + } + + close (Dbg h c) = + do { hPutStrLn h "closing..." + ; hFlush h + ; close c + ; hPutStrLn h "...closed" + ; hClose h + } + + +-- | Wraps a stream with logging I\/O, the first +-- argument is a filename which is opened in AppendMode. +debugStream :: (Stream a) => String -> a -> IO (Debug a) +debugStream file stm = + do { h <- openFile file AppendMode + ; hPutStrLn h "File opened for appending." + ; return (Dbg h stm) + } diff --git a/Network/TCP.hs b/Network/TCP.hs new file mode 100644 --- /dev/null +++ b/Network/TCP.hs @@ -0,0 +1,194 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.TCP +-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004 +-- License : BSD +-- +-- Maintainer : bjorn@bringert.net +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An easy access TCP library. Makes the use of TCP in Haskell much easier. +-- This was originally part of Gray's\/Bringert's HTTP module. +-- +-- * Changes by Simon Foster: +-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules +-- +----------------------------------------------------------------------------- +module Network.TCP ( + -- ** Connections + Conn(..), + Connection(..), + openTCP, + openTCPPort, + isConnectedTo +) where + +import Control.Exception as Exception + +-- Networking +import Network (withSocketsDo) +import Network.BSD +import Network.URI +import Network.Socket +import Network.Stream + +import Data.List (isPrefixOf,partition,elemIndex) +import Data.Char +import Data.IORef +import Control.Monad (when,liftM,guard) +import System.IO + +----------------------------------------------------------------- +------------------ TCP Connections ------------------------------ +----------------------------------------------------------------- + +-- | The 'Connection' newtype is a wrapper that allows us to make +-- connections an instance of the StreamIn\/Out classes, 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} + + +-- | The 'Conn' object allows input buffering, and maintenance of +-- some admin-type data. +data Conn = MkConn { connSock :: ! Socket + , connAddr :: ! SockAddr + , connBffr :: ! String + , connHost :: String + } + | ConnClosed + deriving(Eq) + + +-- | Open a connection to port 80 on a remote host. +openTCP :: String -> IO Connection +openTCP host = openTCPPort host 80 + + +-- | 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 = + do { s <- socket AF_INET Stream 6 + ; setSocketOption s KeepAlive 1 + ; host <- Exception.catch (inet_addr uri) -- handles ascii IP numbers + (\_ -> getHostByName uri >>= \host -> + case hostAddresses host of + [] -> return (error "no addresses in host entry") + (h:_) -> return h) + ; let a = SockAddrInet (toEnum port) host + ; Exception.catch (connect s a) (\e -> sClose s >> throw e) + ; v <- newIORef (MkConn s a [] uri) + ; return (ConnRef v) + } + +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) + } + + -- 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'])) + } + + + + -- 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) + + + -- Closes a Connection. Connection will no longer + -- allow any of the other Stream functions. Notice that a Connection may close + -- at any time before a call to this function. This function is idempotent. + -- (I think the behaviour here is TCP specific) + close ref = + do { c <- readIORef (getRef ref) + ; closeConn c `Exception.catch` (\_ -> return ()) + ; writeIORef (getRef ref) ConnClosed + } + where + -- Be kind to peer & close gracefully. + closeConn (ConnClosed) = return () + closeConn (MkConn sk addr [] _) = + do { shutdown sk ShutdownSend + ; suck ref + ; shutdown sk ShutdownReceive + ; sClose sk + } + + suck :: Connection -> IO () + suck cn = readLine cn >>= + either (\_ -> return ()) -- catch errors & ignore + (\x -> if null x then return () else suck cn) + +-- | 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 + } + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain