HTTP (empty) → 3000.0.0
raw patch · 10 files changed
+3150/−0 lines, 10 filesdep +basedep +networkdep +parsecbuild-type:Customsetup-changed
Dependencies added: base, network, parsec
Files
- HTTP.cabal +26/−0
- LICENSE +36/−0
- Network/Browser.hs +976/−0
- Network/HTTP.hs +1052/−0
- Network/HTTP/Base64.hs +284/−0
- Network/HTTP/MD5.hs +44/−0
- Network/HTTP/MD5Aux.hs +355/−0
- Network/Stream.hs +175/−0
- Network/TCP.hs +194/−0
- Setup.lhs +8/−0
+ HTTP.cabal view
@@ -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 <warrick.gray@hotmail.com>+Maintainer: Bjorn Bringert <bjorn@bringert.net>+Homepage: http://www.haskell.org/http/+Description: A library for client-side HTTP+Build-depends: base, network, parsec+Exposed-modules: + 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
+ LICENSE view
@@ -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.
+ Network/Browser.hs view
@@ -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+ }
+ Network/HTTP.hs view
@@ -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:+-- >+-- > //<user>:<password>@<host>:<port>/<url-path>+-- > Some or all of the parts "<user>:<password>@", ":<password>",+-- > ":<port>", and "/<url-path>" may be excluded.+parseURIAuthority :: String -> Maybe URIAuthority+parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))+++pURIAuthority :: ReadP URIAuthority+pURIAuthority = do+ (u,pw) <- (pUserInfo `before` char '@') + <++ return (Nothing, Nothing)+ h <- munch (/=':')+ p <- orNothing (char ':' >> readDecP)+ look >>= guard . null + return URIAuthority{ user=u, password=pw, host=h, port=p }++pUserInfo :: ReadP (Maybe String, Maybe String)+pUserInfo = do+ u <- orNothing (munch (`notElem` ":@"))+ p <- orNothing (char ':' >> munch (/='@'))+ return (u,p)++before :: Monad m => m a -> m b -> m a+before a b = a >>= \x -> b >> return x++orNothing :: ReadP a -> ReadP (Maybe a)+orNothing p = fmap Just p <++ return Nothing++-----------------------------------------------------------------+------------------ Header Data ----------------------------------+-----------------------------------------------------------------+++-- | The Header data type pairs header names & values.+data Header = Header HeaderName String+++instance Show Header where+ show (Header key value) = show key ++ ": " ++ value ++ crlf+++-- | HTTP Header Name type:+-- Why include this at all? I have some reasons+-- 1) prevent spelling errors of header names,+-- 2) remind everyone of what headers are available,+-- 3) might speed up searches for specific headers.+--+-- Arguments against:+-- 1) makes customising header names laborious+-- 2) increases code volume.+--+data HeaderName = + -- Generic Headers --+ HdrCacheControl+ | HdrConnection+ | HdrDate+ | HdrPragma+ | HdrTransferEncoding + | HdrUpgrade + | HdrVia++ -- Request Headers --+ | HdrAccept+ | HdrAcceptCharset+ | HdrAcceptEncoding+ | HdrAcceptLanguage+ | HdrAuthorization+ | HdrCookie+ | HdrExpect+ | HdrFrom+ | HdrHost+ | HdrIfModifiedSince+ | HdrIfMatch+ | HdrIfNoneMatch+ | HdrIfRange+ | HdrIfUnmodifiedSince+ | HdrMaxForwards+ | HdrProxyAuthorization+ | HdrRange+ | HdrReferer+ | HdrUserAgent++ -- Response Headers+ | HdrAge+ | HdrLocation+ | HdrProxyAuthenticate+ | HdrPublic+ | HdrRetryAfter+ | HdrServer+ | HdrSetCookie+ | HdrVary+ | HdrWarning+ | HdrWWWAuthenticate++ -- Entity Headers+ | HdrAllow+ | HdrContentBase+ | HdrContentEncoding+ | HdrContentLanguage+ | HdrContentLength+ | HdrContentLocation+ | HdrContentMD5+ | HdrContentRange+ | HdrContentType+ | HdrETag+ | HdrExpires+ | HdrLastModified++ -- Mime entity headers (for sub-parts)+ | HdrContentTransferEncoding++ -- | Allows for unrecognised or experimental headers.+ | HdrCustom String -- not in header map below.+ deriving(Eq)+++-- Translation between header names and values,+-- good candidate for improvement.+headerMap :: [ (String,HeaderName) ]+headerMap + = [ ("Cache-Control" ,HdrCacheControl )+ , ("Connection" ,HdrConnection )+ , ("Date" ,HdrDate ) + , ("Pragma" ,HdrPragma )+ , ("Transfer-Encoding" ,HdrTransferEncoding ) + , ("Upgrade" ,HdrUpgrade ) + , ("Via" ,HdrVia )+ , ("Accept" ,HdrAccept )+ , ("Accept-Charset" ,HdrAcceptCharset )+ , ("Accept-Encoding" ,HdrAcceptEncoding )+ , ("Accept-Language" ,HdrAcceptLanguage )+ , ("Authorization" ,HdrAuthorization )+ , ("From" ,HdrFrom )+ , ("Host" ,HdrHost )+ , ("If-Modified-Since" ,HdrIfModifiedSince )+ , ("If-Match" ,HdrIfMatch )+ , ("If-None-Match" ,HdrIfNoneMatch )+ , ("If-Range" ,HdrIfRange ) + , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince )+ , ("Max-Forwards" ,HdrMaxForwards )+ , ("Proxy-Authorization" ,HdrProxyAuthorization)+ , ("Range" ,HdrRange ) + , ("Referer" ,HdrReferer )+ , ("User-Agent" ,HdrUserAgent )+ , ("Age" ,HdrAge )+ , ("Location" ,HdrLocation )+ , ("Proxy-Authenticate" ,HdrProxyAuthenticate )+ , ("Public" ,HdrPublic )+ , ("Retry-After" ,HdrRetryAfter )+ , ("Server" ,HdrServer )+ , ("Vary" ,HdrVary )+ , ("Warning" ,HdrWarning )+ , ("WWW-Authenticate" ,HdrWWWAuthenticate )+ , ("Allow" ,HdrAllow )+ , ("Content-Base" ,HdrContentBase )+ , ("Content-Encoding" ,HdrContentEncoding )+ , ("Content-Language" ,HdrContentLanguage )+ , ("Content-Length" ,HdrContentLength )+ , ("Content-Location" ,HdrContentLocation )+ , ("Content-MD5" ,HdrContentMD5 )+ , ("Content-Range" ,HdrContentRange )+ , ("Content-Type" ,HdrContentType )+ , ("ETag" ,HdrETag )+ , ("Expires" ,HdrExpires )+ , ("Last-Modified" ,HdrLastModified )+ , ("Set-Cookie" ,HdrSetCookie )+ , ("Cookie" ,HdrCookie )+ , ("Expect" ,HdrExpect ) ]+++instance Show HeaderName where+ show (HdrCustom s) = s+ show x = case filter ((==x).snd) headerMap of+ [] -> error "headerMap incomplete"+ (h:_) -> fst h++++++-- | This class allows us to write generic header manipulation functions+-- for both 'Request' and 'Response' data types.+class HasHeaders x where+ getHeaders :: x -> [Header]+ setHeaders :: x -> [Header] -> x++++-- Header manipulation functions+insertHeader, replaceHeader, insertHeaderIfMissing+ :: HasHeaders a => HeaderName -> String -> a -> a+++-- | Inserts a header with the given name and value.+-- Allows duplicate header names.+insertHeader name value x = setHeaders x newHeaders+ where+ newHeaders = (Header name value) : getHeaders x+++-- | Adds the new header only if no previous header shares+-- the same name.+insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)+ where+ newHeaders list@(h@(Header n _): rest)+ | n == name = list+ | otherwise = h : newHeaders rest+ newHeaders [] = [Header name value]++ ++-- | Removes old headers with duplicate name.+replaceHeader name value x = setHeaders x newHeaders+ where+ newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]+ ++-- | Inserts multiple headers.+insertHeaders :: HasHeaders a => [Header] -> a -> a+insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)+++-- | Gets a list of headers with a particular 'HeaderName'.+retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]+retrieveHeaders name x = filter matchname (getHeaders x)+ where+ matchname (Header n _) | n == name = True+ matchname _ = False+++-- | Lookup presence of specific HeaderName in a list of Headers+-- Returns the value from the first matching header.+findHeader :: HasHeaders a => HeaderName -> a -> Maybe String+findHeader n x = lookupHeader n (getHeaders x)++-- An anomally really:+lookupHeader :: HeaderName -> [Header] -> Maybe String+lookupHeader v (Header n s:t) | v == n = Just s+ | otherwise = lookupHeader v t+lookupHeader _ _ = Nothing+++++{-+instance HasHeaders [Header]+...requires -fglasgow-exts, and is not really necessary anyway...+-}++++-----------------------------------------------------------------+------------------ HTTP Messages --------------------------------+-----------------------------------------------------------------+++-- Protocol version+httpVersion :: String+httpVersion = "HTTP/1.1"+++-- | The HTTP request method, to be used in the 'Request' object.+-- We are missing a few of the stranger methods, but these are+-- not really necessary until we add full TLS.+data RequestMethod = HEAD | PUT | GET | POST | OPTIONS | TRACE+ deriving(Show,Eq)++rqMethodMap = [("HEAD", HEAD),+ ("PUT", PUT),+ ("GET", GET),+ ("POST", POST),+ ("OPTIONS", OPTIONS),+ ("TRACE", TRACE)]++-- | An HTTP Request.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output.+data Request =+ Request { rqURI :: URI -- ^ might need changing in future+ -- 1) to support '*' uri in OPTIONS request+ -- 2) transparent support for both relative+ -- & absolute uris, although this should+ -- already work (leave scheme & host parts empty).+ , rqMethod :: RequestMethod + , rqHeaders :: [Header]+ , rqBody :: String+ }+++++-- Notice that request body is not included,+-- this show function is used to serialise+-- a request for the transport link, we send+-- the body separately where possible.+instance Show Request where+ show (Request u m h _) =+ show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf+ ++ foldr (++) [] (map show h) ++ crlf+ where+ alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' + then u { uriPath = '/' : uriPath u } + else u+++instance HasHeaders Request where+ getHeaders = rqHeaders+ setHeaders rq hdrs = rq { rqHeaders=hdrs }+++++++type ResponseCode = (Int,Int,Int)+type ResponseData = (ResponseCode,String,[Header])+type RequestData = (RequestMethod,URI,[Header])++-- | An HTTP Response.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output, additionally the output will+-- show an HTTP version of 1.1 instead of the actual version returned+-- by a server.+data Response =+ Response { rspCode :: ResponseCode+ , rspReason :: String+ , rspHeaders :: [Header]+ , rspBody :: String+ }+ +++-- This is an invalid representation of a received response, +-- since we have made the assumption that all responses are HTTP/1.1+instance Show Response where+ show (Response (a,b,c) reason headers _) =+ httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf+ ++ foldr (++) [] (map show headers) ++ crlf++++instance HasHeaders Response where+ getHeaders = rspHeaders+ setHeaders rsp hdrs = rsp { rspHeaders=hdrs }++-----------------------------------------------------------------+------------------ Parsing --------------------------------------+-----------------------------------------------------------------++parseHeader :: String -> Result Header+parseHeader str =+ case split ':' str of+ Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)+ Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v)+ where+ fn k = case map snd $ filter (match k . fst) headerMap of+ [] -> (HdrCustom k)+ (h:_) -> h++ match :: String -> String -> Bool+ match s1 s2 = map toLower s1 == map toLower s2+ ++parseHeaders :: [String] -> Result [Header]+parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended ""+ where+ -- Joins consecutive lines where the second line+ -- begins with ' ' or '\t'.+ joinExtended old (h : t)+ | not (null h) && (head h == ' ' || head h == '\t')+ = joinExtended (old ++ ' ' : tail h) t+ | otherwise = old : joinExtended h t+ joinExtended old [] = [old]++ clean [] = []+ clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t+ | otherwise = h : clean t++ -- tollerant of errors? should parse+ -- errors here be reported or ignored?+ -- currently ignored.+ catRslts :: [a] -> [Result a] -> Result [a]+ catRslts list (h:t) = + case h of+ Left _ -> catRslts list t+ Right v -> catRslts (v:list) t+ catRslts list [] = Right $ reverse list + ++-- Parsing a request+parseRequestHead :: [String] -> Result RequestData+parseRequestHead [] = Left ErrorClosed+parseRequestHead (com:hdrs) =+ requestCommand com `bindE` \(version,rqm,uri) ->+ parseHeaders hdrs `bindE` \hdrs' ->+ Right (rqm,uri,hdrs')+ where+ requestCommand line+ = case words line of+ yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of+ (Just u, Just r) -> Right (version,r,u)+ _ -> Left (ErrorParse $ "Request command line parse failure: " ++ line)+ no -> if null line+ then Left ErrorClosed+ else Left (ErrorParse $ "Request command line parse failure: " ++ line) ++-- Parsing a response+parseResponseHead :: [String] -> Result ResponseData+parseResponseHead [] = Left ErrorClosed+parseResponseHead (sts:hdrs) = + responseStatus sts `bindE` \(version,code,reason) ->+ parseHeaders hdrs `bindE` \hdrs' ->+ Right (code,reason,hdrs')+ where++ responseStatus line+ = case words line of+ yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason)+ no -> if null line + then Left ErrorClosed -- an assumption+ else Left (ErrorParse $ "Response status line parse failure: " ++ line)+++ match [a,b,c] = (digitToInt a,+ digitToInt b,+ digitToInt c)+ match _ = (-1,-1,-1) -- will create appropriate behaviour+++ ++-----------------------------------------------------------------+------------------ HTTP Send / Recv ----------------------------------+-----------------------------------------------------------------++data Behaviour = Continue+ | Retry+ | Done+ | ExpectEntity+ | DieHorribly String++++++matchResponse :: RequestMethod -> ResponseCode -> Behaviour+matchResponse rqst rsp =+ case rsp of+ (1,0,0) -> Continue+ (1,0,1) -> Done -- upgrade to TLS+ (1,_,_) -> Continue -- default+ (2,0,4) -> Done+ (2,0,5) -> Done+ (2,_,_) -> ans+ (3,0,4) -> Done+ (3,0,5) -> Done+ (3,_,_) -> ans+ (4,1,7) -> Retry -- Expectation failed+ (4,_,_) -> ans+ (5,_,_) -> ans+ (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")+ where+ ans | rqst == HEAD = Done+ | otherwise = ExpectEntity+ ++-- | Simple way to get a resource across a non-persistant connection.+-- Headers that may be altered:+-- Host Altered only if no Host header is supplied, HTTP\/1.1+-- requires a Host header.+-- Connection Where no allowance is made for persistant connections+-- the Connection header will be set to "close"+simpleHTTP :: Request -> IO (Result Response)+simpleHTTP r = + do + auth <- getAuth r+ c <- openTCPPort (host auth) (fromMaybe 80 (port auth))+ simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)+simpleHTTP_ s r =+ do + auth <- getAuth r+ let r' = fixReq auth r + rsp <- if debug then do+ s' <- debugStream httpLogFile s+ sendHTTP s' r'+ else+ sendHTTP s r'+ -- already done by sendHTTP because of "Connection: close" header+ --; close s + return rsp+ where+ {- RFC 2616, section 5.1.2:+ "The most common form of Request-URI is that used to identify a+ resource on an origin server or gateway. In this case the absolute+ path of the URI MUST be transmitted (see section 3.2.1, abs_path) as+ the Request-URI, and the network location of the URI (authority) MUST+ be transmitted in a Host header field." -}+ -- we assume that this is the case, so we take the host name from+ -- the Host header if there is one, otherwise from the request-URI.+ -- Then we make the request-URI an abs_path and make sure that there+ -- is a Host header.+ fixReq :: URIAuthority -> Request -> Request+ fixReq URIAuthority{host=h} r = + replaceHeader HdrConnection "close" $+ insertHeaderIfMissing HdrHost h $+ r { rqURI = (rqURI r){ uriScheme = "", + uriAuthority = Nothing } } ++getAuth :: Monad m => Request -> m URIAuthority+getAuth r = case parseURIAuthority auth of+ Just x -> return x + Nothing -> fail $ "Error parsing URI authority '"+ ++ auth ++ "'"+ where auth = case findHeader HdrHost r of+ Just h -> h+ Nothing -> uriToAuthorityString (rqURI r)++sendHTTP :: Stream s => s -> Request -> IO (Result Response)+sendHTTP conn rq = + do { let a_rq = fixHostHeader rq+ ; rsp <- Exception.catch (main a_rq)+ (\e -> do { close conn; throw e })+ ; let fn list = when (or $ map findConnClose list)+ (close conn)+ ; either (\_ -> fn [rqHeaders rq])+ (\r -> fn [rqHeaders rq,rspHeaders r])+ rsp+ ; return rsp+ }+ where +-- From RFC 2616, section 8.2.3:+-- 'Because of the presence of older implementations, the protocol allows+-- ambiguous situations in which a client may send "Expect: 100-+-- continue" without receiving either a 417 (Expectation Failed) status+-- or a 100 (Continue) status. Therefore, when a client sends this+-- header field to an origin server (possibly via a proxy) from which it+-- has never seen a 100 (Continue) status, the client SHOULD NOT wait+-- for an indefinite period before sending the request body.'+--+-- Since we would wait forever, I have disabled use of 100-continue for now.+ main :: Request -> IO (Result Response)+ main rqst =+ do + --let str = if null (rqBody rqst)+ -- then show rqst+ -- else show (insertHeader HdrExpect "100-continue" rqst)+ writeBlock conn (show rqst)+ -- write body immediately, don't wait for 100 CONTINUE+ writeBlock conn (rqBody rqst)+ rsp <- getResponseHead + switchResponse True False rsp rqst+ + -- reads and parses headers+ getResponseHead :: IO (Result ResponseData)+ getResponseHead =+ do { lor <- readTillEmpty1 conn+ ; return $ lor `bindE` parseResponseHead+ }++ -- Hmmm, this could go bad if we keep getting "100 Continue"+ -- responses... Except this should never happen according+ -- to the RFC.+ switchResponse :: Bool {- allow retry? -}+ -> Bool {- is body sent? -}+ -> Result ResponseData+ -> Request+ -> IO (Result Response)+ + switchResponse _ _ (Left e) _ = return (Left e)+ -- retry on connreset?+ -- if we attempt to use the same socket then there is an excellent+ -- chance that the socket is not in a completely closed state.++ switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =+ case matchResponse (rqMethod rqst) cd of+ Continue+ | not bdy_sent -> {- Time to send the body -}+ do { val <- writeBlock conn (rqBody rqst)+ ; case val of+ Left e -> return (Left e)+ Right _ ->+ do { rsp <- getResponseHead+ ; switchResponse allow_retry True rsp rqst+ }+ }+ | otherwise -> {- keep waiting -}+ do { rsp <- getResponseHead+ ; switchResponse allow_retry bdy_sent rsp rqst + }++ Retry -> {- Request with "Expect" header failed.+ Trouble is the request contains Expects+ other than "100-Continue" -}+ do { writeBlock conn (show rqst ++ rqBody rqst)+ ; rsp <- getResponseHead+ ; switchResponse False bdy_sent rsp rqst+ } + + Done ->+ return (Right $ Response cd rn hdrs "")++ DieHorribly str ->+ return $ Left $ ErrorParse ("Invalid response: " ++ str)++ ExpectEntity ->+ let tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs+ in+ do { rslt <- case tc of+ Nothing -> + case cl of+ Just x -> linearTransfer conn (read x :: Int)+ Nothing -> hopefulTransfer conn ""+ Just x -> + case map toLower (trim x) of+ "chunked" -> chunkedTransfer conn+ _ -> uglyDeathTransfer conn+ ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) + }++ + -- Adds a Host header if one is NOT ALREADY PRESENT+ fixHostHeader :: Request -> Request+ fixHostHeader rq =+ let uri = rqURI rq+ host = uriToAuthorityString uri+ in insertHeaderIfMissing HdrHost host rq+ + -- Looks for a "Connection" header with the value "close".+ -- Returns True when this is found.+ findConnClose :: [Header] -> Bool+ findConnClose hdrs =+ case lookupHeader HdrConnection hdrs of+ Nothing -> False+ Just x -> map toLower (trim x) == "close"++-- This function duplicates old Network.URI.authority behaviour.+uriToAuthorityString :: URI -> String+uriToAuthorityString URI{uriAuthority=Nothing} = ""+uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua +++ uriRegName ua +++ uriPort ua++-- | Receive and parse a HTTP request from the given Stream. Should be used +-- for server side interactions.+receiveHTTP :: Stream s => s -> IO (Result Request)+receiveHTTP conn = do rq <- getRequestHead+ processRequest rq + where+ -- reads and parses headers+ getRequestHead :: IO (Result RequestData)+ getRequestHead =+ do { lor <- readTillEmpty1 conn+ ; return $ lor `bindE` parseRequestHead+ }+ + processRequest (Left e) = return $ Left e+ processRequest (Right (rm,uri,hdrs)) = + do -- FIXME : Also handle 100-continue.+ let tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs+ rslt <- case tc of+ Nothing ->+ case cl of+ Just x -> linearTransfer conn (read x :: Int)+ Nothing -> return (Right ([], "")) -- hopefulTransfer ""+ Just x ->+ case map toLower (trim x) of+ "chunked" -> chunkedTransfer conn+ _ -> uglyDeathTransfer conn+ + return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)+++-- | Very simple function, send a HTTP response over the given stream. This +-- could be improved on to use different transfer types.+respondHTTP :: Stream s => s -> Response -> IO ()+respondHTTP conn rsp = do writeBlock conn (show rsp)+ -- write body immediately, don't wait for 100 CONTINUE+ writeBlock conn (rspBody rsp)+ return ()++-- The following functions were in the where clause of sendHTTP, they have+-- been moved to global scope so other functions can access them. ++-- | Used when we know exactly how many bytes to expect.+linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))+linearTransfer conn n+ = do info <- readBlock conn n+ return $ info `bindE` \str -> Right ([],str)++-- | Used when nothing about data is known,+-- Unfortunately waiting for a socket closure+-- causes bad behaviour. Here we just+-- take data once and give up the rest.+hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String))+hopefulTransfer conn str+ = readLine conn >>= + either (\v -> return $ Left v)+ (\more -> if null more + then return (Right ([],str)) + else hopefulTransfer conn (str++more))+-- | A necessary feature of HTTP\/1.1+-- Also the only transfer variety likely to+-- return any footers.+chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))+chunkedTransfer conn+ = chunkedTransferC conn 0 >>= \v ->+ return $ v `bindE` \(ftrs,count,info) ->+ let myftrs = Header HdrContentLength (show count) : ftrs + in Right (myftrs,info)++chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))+chunkedTransferC conn n+ = readLine conn >>= \v -> case v of+ Left e -> return (Left e)+ Right line ->+ let size = ( if null line || (head line) == '0'+ then 0+ else case readHex line of+ (n,_):_ -> n+ _ -> 0+ )+ in if size == 0+ then do { rs <- readTillEmpty2 conn []+ ; return $+ rs `bindE` \strs ->+ parseHeaders strs `bindE` \ftrs ->+ Right (ftrs,n,"")+ }+ else do { some <- readBlock conn size+ ; readLine conn+ ; more <- chunkedTransferC conn (n+size)+ ; return $ + some `bindE` \cdata ->+ more `bindE` \(ftrs,m,mdata) -> + Right (ftrs,m,cdata++mdata) + } ++-- | Maybe in the future we will have a sensible thing+-- to do here, at that time we might want to change+-- the name.+uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))+uglyDeathTransfer conn+ = return $ Left $ ErrorParse "Unknown Transfer-Encoding"++-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)+readTillEmpty1 :: Stream s => s -> IO (Result [String])+readTillEmpty1 conn =+ do { line <- readLine conn+ ; case line of+ Left e -> return $ Left e+ Right s ->+ if s == crlf+ then readTillEmpty1 conn+ else readTillEmpty2 conn [s]+ }++-- | Read lines until an empty line (CRLF),+-- also accepts a connection close as end of+-- input, which is not an HTTP\/1.1 compliant+-- thing to do - so probably indicates an+-- error condition.+readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])+readTillEmpty2 conn list =+ do { line <- readLine conn+ ; case line of+ Left e -> return $ Left e+ Right s ->+ if s == crlf || null s+ then return (Right $ reverse (s:list))+ else readTillEmpty2 conn (s:list)+ }++ +-----------------------------------------------------------------+------------------ A little friendly funtionality ---------------+-----------------------------------------------------------------+++{-+ I had a quick look around but couldn't find any RFC about+ the encoding of data on the query string. I did find an+ IETF memo, however, so this is how I justify the urlEncode+ and urlDecode methods.++ Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org)++ Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.+ Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"+ URI delims: "<" | ">" | "#" | "%" | <">+ Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>+ <US-ASCII coded character 20 hexadecimal>+ Also unallowed: any non-us-ascii character++ Escape method: char -> '%' a b where a, b :: Hex digits+-}++urlEncode, urlDecode :: String -> String++urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)+ : urlDecode rest+urlDecode (h:t) = h : urlDecode t+urlDecode [] = []++urlEncode (h:t) =+ let str = if reserved (ord h) then escape h else [h]+ in str ++ urlEncode t+ where+ reserved x+ | x >= ord 'a' && x <= ord 'z' = False+ | x >= ord 'A' && x <= ord 'Z' = False+ | x >= ord '0' && x <= ord '9' = False+ | x <= 0x20 || x >= 0x7F = True+ | otherwise = x `elem` map ord [';','/','?',':','@','&'+ ,'=','+',',','$','{','}'+ ,'|','\\','^','[',']','`'+ ,'<','>','#','%','"']+ -- wouldn't it be nice if the compiler+ -- optimised the above for us?++ escape x = + let y = ord x + in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]++urlEncode [] = []+ +++-- Encode form variables, useable in either the+-- query part of a URI, or the body of a POST request.+-- I have no source for this information except experience,+-- this sort of encoding worked fine in CGI programming.+urlEncodeVars :: [(String,String)] -> String+urlEncodeVars ((n,v):t) =+ let (same,diff) = partition ((==n) . fst) t+ in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)+ ++ urlEncodeRest diff+ where urlEncodeRest [] = []+ urlEncodeRest diff = '&' : urlEncodeVars diff+urlEncodeVars [] = []
+ Network/HTTP/Base64.hs view
@@ -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 <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- and <http://www.faqs.org/rfcs/rfc2045.html>.+--+-----------------------------------------------------------------------------++module Network.HTTP.Base64 (+ encode,+ decode,+ chop72+) where++++{------------------------------------------------------------------------+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
+ Network/HTTP/MD5.hs view
@@ -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 <http://web.comlab.ox.ac.uk/oucl/work/ian.lynagh/>+-- and <http://www.ietf.org/rfc/rfc1321.txt>.+--+-----------------------------------------------------------------------------++module Network.HTTP.MD5 (+ -- * Function Types+ hash) where++import Data.Char(chr)+import Data.List(unfoldr)+import Numeric(readHex)++import Network.HTTP.MD5Aux+import Data.Word (Word8)++type Octet = Word8++-- | Take [Octet] and return [Octet] according to the standard.+-- The length of the result is always 16 octets or 128 bits as required+-- by the standard.++hash :: [Octet] -> [Octet]+hash xs = + unfoldr f $ md5s $ Str $ map (chr . fromIntegral) xs+ where f :: String -> Maybe (Octet,String)+ f [] = + Nothing+ f (x:y:zs) = + Just (fromIntegral a,zs)+ where [(a,_)] = readHex (x:y:[])
+ Network/HTTP/MD5Aux.hs view
@@ -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+
+ Network/Stream.hs view
@@ -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)+ }
+ Network/TCP.hs view
@@ -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+ }+
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runghc++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain