HTTP 3001.1.5 → 4000.0.0

raw patch · 15 files changed

+2140/−1325 lines, 15 filesdep +bytestringdep ~basedep ~networknew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring

Dependency ranges changed: base, network

API changes (from Hackage documentation)

Files

• HTTP.cabal +32/−18
• Network/Browser.hs +344/−366
• Network/BufferType.hs +132/−0
• Network/HTTP.hs +17/−626
• Network/HTTP/Base.hs +552/−0
• Network/HTTP/HandleStream.hs +214/−0
• Network/HTTP/Headers.hs +118/−136
• Network/HTTP/MD5.hs +3/−3
• Network/HTTP/MD5Aux.hs +14/−10
• Network/HTTP/Stream.hs +307/−0
• Network/HTTP/Utils.hs +67/−0
• Network/Stream.hs +6/−6
• Network/StreamDebugger.hs +25/−0
• Network/StreamSocket.hs +40/−35
• Network/TCP.hs +269/−125

@@ -1,11 +1,10 @@-Name:               HTTP-Version:            3001.1.5-Cabal-Version:      >= 1.2-Build-type:         Simple-License:            BSD3-License-file:       LICENSE-Category:           Network-Copyright:+Name: HTTP+Version: 4000.0.0+Cabal-Version: >= 1.2+Build-type: Simple+License: BSD3+License-file: LICENSE+Copyright:    Copyright (c) 2002, Warrick Gray   Copyright (c) 2002-2005, Ian Lynagh   Copyright (c) 2003-2006, Bjorn Bringert@@ -13,34 +12,49 @@   Copyright (c) 2004, Ganesh Sittampalam   Copyright (c) 2004-2005, Dominic Steinitz   Copyright 2007 Robin Bate Boerop-Author:             Warrick Gray <warrick.gray@hotmail.com>-Maintainer:         Bjorn Bringert <bjorn@bringert.net>-Homepage:           http://www.haskell.org/http/-Description:        A library for client-side HTTP-Synopsis:           A library for client-side HTTP +Author: Warrick Gray <warrick.gray@hotmail.com>+Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+Homepage: http://www.haskell.org/http/+Description:  + A library for client-side HTTP, version 2. Rewrite of existing HTTP+ package to allow overloaded representation of HTTP request bodies+ and responses. Provides three such instances: lazy and strict 'ByteString',+ along with the good old @String@.+++ Inspired in part by Jonas Aadahl et al's work on ByteString'ifying HTTP+ a couple of years ago.+++ Git repository available at <http://code.galois.com/HTTPbis.git>+ Flag old-base   description: Old, monolithic base   default: False  Library   Exposed-modules: +                 Network.BufferType,                  Network.Stream,                  Network.StreamDebugger,                  Network.StreamSocket,                  Network.TCP,                                  Network.HTTP,                  Network.HTTP.Headers,+                 Network.HTTP.Base,+                 Network.HTTP.Stream,+                 Network.HTTP.HandleStream,                  Network.Browser   Other-modules:                  Network.HTTP.Base64,                  Network.HTTP.MD5,-                 Network.HTTP.MD5Aux-  GHC-options: -fwarn-missing-signatures-  Extensions: DeriveDataTypeable-  Build-depends: network, parsec+                 Network.HTTP.MD5Aux,+                 Network.HTTP.Utils+  GHC-options: -fwarn-missing-signatures -Wall+  Build-depends: network, parsec, bytestring    if flag(old-base)     Build-depends: base < 3   else-    Build-depends: base >= 3 && < 4, array+    Build-depends: base >= 3, array

@@ -31,7 +31,7 @@ module Network.Browser (     BrowserState,     BrowserAction,      -- browser monad, effectively a state monad.-    Cookie(..),+    Cookie,     Form(..),     Proxy(..),     @@ -76,17 +76,20 @@  import Network.URI    ( URI(uriAuthority, uriScheme, uriPath, uriQuery)-   , URIAuth(URIAuth, uriUserInfo, uriPort, uriRegName)+   , URIAuth(..)    , parseURI, parseURIReference, relativeTo    )-import Network.StreamDebugger (debugStream)-import Network.TCP (Connection, isConnectedTo)+import Network.StreamDebugger (debugByteStream) import Network.HTTP import qualified Network.HTTP.MD5 as MD5 (hash) import qualified Network.HTTP.Base64 as Base64 (encode)+import Network.Stream ( ConnError(..) )+import Network.BufferType +import Network.HTTP.Utils ( trim, splitBy )+ import Data.Char (toLower,isAlphaNum,isSpace)-import Data.List (isPrefixOf,isSuffixOf,elemIndex,elemIndices)+import Data.List (isPrefixOf,isSuffixOf) import Data.Maybe (fromMaybe, listToMaybe, catMaybes, fromJust, isJust) import Control.Monad (foldM, filterM, liftM, when) import Text.ParserCombinators.Parsec@@ -108,7 +111,7 @@  word, quotedstring :: Parser String quotedstring =-    do { char '"'+    do { char '"' -- "        ; str <- many (satisfy $ not . (=='"'))        ; char '"'        ; return str@@ -116,31 +119,7 @@  word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) --- misc string fns-trim :: String -> String-trim = let dropspace = dropWhile isSpace in-       reverse . dropspace . reverse . dropspace ---- | Splits a list into two parts, the delimiter occurs--- at the head of the second list.  Nothing is returned--- when no occurance of the delimiter is found.-split :: Eq a => a -> [a] -> Maybe ([a],[a])-split delim list = case delim `elemIndex` list of-    Nothing -> Nothing-    Just x  -> Just $ splitAt x list-    ----- | Removes delimiters.-splitMany :: Eq a => a -> [a] -> [[a]]-splitMany delim str = fn str ixs-    where-        ixs = elemIndices delim str-        fn _ [] = []-        fn ls (h:t) = let (a,b) = splitAt h ls in a : fn b t-- -- | Returns a URI that is consistent with the first -- argument uri when read in the context of a second. -- If second argument is not sufficient context for@@ -181,7 +160,7 @@   defaultCookieFilter :: URI -> Cookie -> IO Bool-defaultCookieFilter url cky = return True+defaultCookieFilter _url _cky = return True  userCookieFilter :: URI -> Cookie -> IO Bool userCookieFilter url cky =@@ -230,59 +209,62 @@         cookie :: Parser Cookie         cookie =             do { name <- word-               ; spaces+               ; spaces_l                ; char '='-               ; spaces-               ; val <- cvalue+               ; spaces_l+               ; val1 <- cvalue                ; args <- cdetail-               ; return $ mkCookie name val args+               ; return $ mkCookie name val1 args                }          cvalue :: Parser String         -        spaces = many (satisfy isSpace)+        spaces_l = many (satisfy isSpace) -        cvalue = quotedstring <|> many (satisfy $ not . (==';'))+        cvalue = quotedstring <|> many1 (satisfy $ not . (==';'))                 -- all keys in the result list MUST be in lower case         cdetail :: Parser [(String,String)]         cdetail = many $-            try (do { spaces+            try (do { spaces_l                ; char ';'-               ; spaces+               ; spaces_l                ; s1 <- word-               ; spaces-               ; s2 <- option "" (do { char '=' ; spaces ; v <- cvalue ; return v })+               ; spaces_l+               ; s2 <- option "" (do { char '=' ; spaces_l ; v <- cvalue ; return v })                ; return (map toLower s1,s2)                })          mkCookie :: String -> String -> [(String,String)] -> Cookie-        mkCookie nm val more = MkCookie { ckName=nm-                                        , ckValue=val-                                        , ckDomain=map toLower (fromMaybe dom (lookup "domain" more))-                                        , ckPath=lookup "path" more-                                        , ckVersion=lookup "version" more-                                        , ckComment=lookup "comment" more-                                        }+        mkCookie nm cval more = +	  MkCookie { ckName    = nm+                   , ckValue   = cval+                   , ckDomain  = map toLower (fromMaybe dom (lookup "domain" more))+                   , ckPath    = lookup "path" more+                   , ckVersion = lookup "version" more+                   , ckComment = lookup "comment" more+                   } +headerToCookies _ _ = []+         -- | Adds a cookie to the browser state, removing duplicates.-addCookie :: Cookie -> BrowserAction ()+addCookie :: Cookie -> BrowserAction t () addCookie c = alterBS (\b -> b { bsCookies=c : fn (bsCookies b) })     where         fn = filter (not . (==c)) -setCookies :: [Cookie] -> BrowserAction ()+setCookies :: [Cookie] -> BrowserAction t () setCookies cs = alterBS (\b -> b { bsCookies=cs }) -getCookies :: BrowserAction [Cookie]+getCookies :: BrowserAction t [Cookie] getCookies = getBS bsCookies  -- ...get domain specific cookies... -- ... this needs changing for consistency with rfc2109... -- ... currently too broad.-getCookiesFor :: String -> String -> BrowserAction [Cookie]+getCookiesFor :: String -> String -> BrowserAction t [Cookie] getCookiesFor dom path =     do cks <- getCookies        return (filter cookiematch cks)@@ -294,10 +276,10 @@                              Just p  -> p `isPrefixOf` path        -setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction ()+setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f }) -getCookieFilter :: BrowserAction (URI -> Cookie -> IO Bool)+getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) getCookieFilter = getBS bsCookieFilter  ------------------------------------------------------------------@@ -312,8 +294,8 @@   3) pick a challenge to respond to, usually the strongest      challenge understood by the client, using "pickChallenge"   4) generate a username/password combination using the browsers-     "bsAuthorityGen" function (the default behaviour is to do nothing-     which means to not retry with a new username/password combination)+     "bsAuthorityGen" function (the default behaviour is to ask+     the user)   5) build an Authority object based upon the challenge and user      data, store this new Authority in the browser state   6) convert the Authority to a request header and add this@@ -370,7 +352,7 @@ headerToChallenge :: URI -> Header -> Maybe Challenge headerToChallenge baseURI (Header _ str) =     case parse challenge "" str of-        Left e -> Nothing+        Left{} -> Nothing         Right (name,props) -> case name of             "basic"  -> mkBasic props             "digest" -> mkDigest props@@ -395,13 +377,6 @@                ; return (map toLower nm,val)                } -        quotedstring =-            do { char '"'-               ; str <- many (satisfy (not.(=='"')))-               ; char '"'-               ; return str-               }        -                 mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge          mkBasic params = fmap ChalBasic (lookup "realm" params)@@ -431,14 +406,14 @@          -- Change These:         readQop :: String -> [Qop]-        readQop = catMaybes . (map strToQop) . (splitMany ',')+        readQop = catMaybes . (map strToQop) . (splitBy ',') -        strToQop str = case map toLower (trim str) of+        strToQop qs = case map toLower (trim qs) of             "auth"     -> Just QopAuth             "auth-int" -> Just QopAuthInt             _          -> Nothing -        readAlgorithm str = case map toLower (trim str) of+        readAlgorithm astr = case map toLower (trim astr) of             "md5"      -> Just AlgMD5             "md5-sess" -> Just AlgMD5sess             _          -> Nothing@@ -462,7 +437,7 @@  -- | Return authorities for a given domain and path. -- Assumes "dom" is lower case-getAuthFor :: String -> String -> BrowserAction [Authority]+getAuthFor :: String -> String -> BrowserAction t [Authority] getAuthFor dom pth =     do { list <- getAuthorities        ; return (filter match list)@@ -477,22 +452,22 @@       -- | Interacting with browser state:-getAuthorities :: BrowserAction [Authority]+getAuthorities :: BrowserAction t [Authority] getAuthorities = getBS bsAuthorities -setAuthorities :: [Authority] -> BrowserAction ()+setAuthorities :: [Authority] -> BrowserAction t () setAuthorities as = alterBS (\b -> b { bsAuthorities=as }) -addAuthority :: Authority -> BrowserAction ()+addAuthority :: Authority -> BrowserAction t () addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b }) -getAuthorityGen :: BrowserAction (URI -> String -> IO (Maybe (String,String)))+getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) getAuthorityGen = getBS bsAuthorityGen -setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction ()+setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f }) -setAllowBasicAuth :: Bool -> BrowserAction ()+setAllowBasicAuth :: Bool -> BrowserAction t () setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba })  @@ -505,7 +480,7 @@   -- | Retrieve a likely looking authority for a Request.-anticipateChallenge :: Request -> BrowserAction (Maybe Authority)+anticipateChallenge :: HTTPRequest ty -> BrowserAction t (Maybe Authority) anticipateChallenge rq =     let uri = rqURI rq in     do { authlist <- getAuthFor (uriToAuthorityString uri) (uriPath uri)@@ -514,7 +489,7 @@   -- | Asking the user to respond to a challenge-challengeToAuthority :: URI -> Challenge -> BrowserAction (Maybe Authority)+challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) challengeToAuthority uri ch =     -- prompt user for authority     if answerable ch then@@ -528,7 +503,7 @@     where         answerable :: Challenge -> Bool         answerable (ChalBasic _) = True-        answerable ch            = (chAlgorithm ch) == Just AlgMD5+        answerable chall         = (chAlgorithm chall) == Just AlgMD5          buildAuth :: Challenge -> String -> String -> Authority         buildAuth (ChalBasic r) u p = @@ -541,7 +516,7 @@          -- note to self: this is a pretty stupid operation          -- to perform isn't it? ChalX and AuthX are so very          -- similar.-        buildAuth (ChalDigest r d n o s a q) u p =+        buildAuth (ChalDigest r d n o _stale a q) u p =             AuthDigest { auRealm=r                        , auUsername=u                        , auPassword=p@@ -557,12 +532,11 @@ -- the context of a specific request.  If a client nonce -- was to be used then this function might need to -- be of type ... -> BrowserAction String-withAuthority :: Authority -> Request -> String+withAuthority :: Authority -> HTTPRequest ty -> String withAuthority a rq = case a of-        AuthBasic _ _ user pass ->-	    "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a)-        AuthDigest _ _ _ _ _ _ _ _ ->-            "Digest username=\"" ++ auUsername a +        AuthBasic{}  -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a)+        AuthDigest{} ->+            "Digest username=\"" ++ auUsername a -- "               ++ "\",realm=\"" ++ auRealm a               ++ "\",nonce=\"" ++ auNonce a               ++ "\",uri=\"" ++ digesturi@@ -577,19 +551,6 @@                  ++ map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2))                  ++ "\"" -        -- FIXME: these probably only work right for latin-1 strings-	stringToOctets :: String -> [Octet]-	stringToOctets = map (fromIntegral . fromEnum)-	octetsToString :: [Octet] -> String-	octetsToString = map (toEnum . fromIntegral)-	base64encode :: String -> String-	base64encode = Base64.encode . stringToOctets-	md5 :: String -> String-	md5 = octetsToString . MD5.hash . stringToOctets--        kd :: String -> String -> String-        kd a b = md5 (a ++ ":" ++ b)-         a1, a2 :: String         a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a         @@ -605,7 +566,23 @@         digesturi = show (rqURI rq)         noncevalue = auNonce a +-- FIXME: these probably only work right for latin-1 strings+stringToOctets :: String -> [Octet]+stringToOctets = map (fromIntegral . fromEnum) +octetsToString :: [Octet] -> String+octetsToString = map (toEnum . fromIntegral)++base64encode :: String -> String+base64encode = Base64.encode . stringToOctets++md5 :: String -> String+md5 = octetsToString . MD5.hash . stringToOctets++kd :: String -> String -> String+kd a b = md5 (a ++ ":" ++ b)++ ------------------------------------------------------------------ ------------------ Proxy Stuff ----------------------------------- ------------------------------------------------------------------@@ -620,368 +597,370 @@ ------------------------------------------------------------------  -data BrowserState = BS { bsErr, bsOut     :: String -> IO ()-                       , bsCookies        :: [Cookie]-                       , bsCookieFilter   :: URI -> Cookie -> IO Bool-                       , bsAuthorityGen   :: URI -> String -> IO (Maybe (String,String))-                       , bsAuthorities    :: [Authority]-                       , bsAllowRedirects :: Bool-                       , bsAllowBasicAuth :: Bool-                       , bsConnectionPool :: [Connection]-                       , bsProxy          :: Proxy-                       , bsDebug          :: Maybe String-                       }+data BrowserState connection+ = BS { bsErr, bsOut     :: String -> IO ()+      , bsCookies        :: [Cookie]+      , bsCookieFilter   :: URI -> Cookie -> IO Bool+      , bsAuthorityGen   :: URI -> String -> IO (Maybe (String,String))+      , bsAuthorities    :: [Authority]+      , bsAllowRedirects :: Bool+      , bsAllowBasicAuth :: Bool+      , bsConnectionPool :: [connection]+      , bsProxy          :: Proxy+      , bsDebug          :: Maybe String+      } -instance Show BrowserState where+instance Show (BrowserState t) where     show bs =  "BrowserState { " -            ++ show (bsCookies bs)  ++ "\n"+            ++ shows (bsCookies bs) ("\n"            {- ++ show (bsAuthorities bs) ++ "\n"-}-            ++ "AllowRedirects: " ++ show (bsAllowRedirects bs)-            ++ "} "+            ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ")   -- Simple DIY stateful behaviour, with IO-data BrowserAction a = BA { lift :: (BrowserState -> IO (BrowserState,a)) }+data BrowserAction conn a + = BA { lift :: BrowserState conn -> IO (BrowserState conn,a) } -instance Monad BrowserAction where+instance Monad (BrowserAction conn) where     a >>= f  =  BA (\b -> do { (nb,v) <- lift a b ; lift (f v) nb})     return x =  BA (\b -> return (b,x)) -instance Functor BrowserAction where+instance Functor (BrowserAction conn) where     fmap f   = liftM f - -- | Apply a browser action to a state.-browse :: BrowserAction a -> IO a-browse act = do (bs, x) <- lift act defaultBrowserState-                closePooledConnections bs-                return x-    where-        defaultBrowserState :: BrowserState-        defaultBrowserState = -            BS { bsErr              = putStrLn-               , bsOut              = putStrLn-               , bsCookies          = []-               , bsCookieFilter     = defaultCookieFilter-               , bsAuthorityGen     = \_ _ -> return Nothing-               , bsAuthorities      = []-               , bsAllowRedirects   = True-               , bsAllowBasicAuth   = False-               , bsConnectionPool   = []-               , bsProxy            = NoProxy-               , bsDebug            = Nothing -               }+browse :: BrowserAction conn a -> IO a+browse act = do x <- lift act defaultBrowserState+                return (snd x) --- |--- Close all connections that are in bs' connection pool.--- This should have some sort of exception handling, soldier on until--- all the connections have been closed.  Not sure about portability--- issues.-closePooledConnections :: BrowserState -> IO ()-closePooledConnections = mapM_ close . bsConnectionPool+defaultBrowserState :: BrowserState t+defaultBrowserState = +  BS { bsErr              = putStrLn+     , bsOut              = putStrLn+     , bsCookies          = []+     , bsCookieFilter     = defaultCookieFilter+     , bsAuthorityGen     = (error "bsAuthGen wanted")+     , bsAuthorities      = []+     , bsAllowRedirects   = True+     , bsAllowBasicAuth   = False+     , bsConnectionPool   = []+     , bsProxy            = NoProxy+     , bsDebug            = Nothing +     }  -- | Alter browser state-alterBS :: (BrowserState -> BrowserState) -> BrowserAction ()+alterBS :: (BrowserState t -> BrowserState t) -> BrowserAction t () alterBS f = BA (\b -> return (f b,())) -getBS :: (BrowserState -> a) -> BrowserAction a+getBS :: (BrowserState t -> a) -> BrowserAction t a getBS f = BA (\b -> return (b,f b))  -- | Do an io action-ioAction :: IO a -> BrowserAction a+ioAction :: IO a -> BrowserAction t a ioAction a = BA (\b -> a >>= \v -> return (b,v)) - -- Stream handlers-setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction ()+setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction t () setErrHandler h = alterBS (\b -> b { bsErr=h }) setOutHandler h = alterBS (\b -> b { bsOut=h }) -out, err :: String -> BrowserAction ()+out, err :: String -> BrowserAction t () out s = do { f <- getBS bsOut ; ioAction $ f s } err s = do { f <- getBS bsErr ; ioAction $ f s }  -- Redirects-setAllowRedirects :: Bool -> BrowserAction ()+setAllowRedirects :: Bool -> BrowserAction t () setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl}) -getAllowRedirects :: BrowserAction Bool+getAllowRedirects :: BrowserAction t Bool getAllowRedirects = getBS bsAllowRedirects   -- Proxy-setProxy :: Proxy -> BrowserAction ()+setProxy :: Proxy -> BrowserAction t () setProxy p = alterBS (\b -> b {bsProxy = p}) -getProxy :: BrowserAction Proxy+getProxy :: BrowserAction t Proxy getProxy = getBS bsProxy   -- Debug-setDebugLog :: Maybe String -> BrowserAction ()+setDebugLog :: Maybe String -> BrowserAction t () setDebugLog v = alterBS (\b -> b {bsDebug=v})   -- Page control-type RequestState = ( Int    -- number of 401 responses so far-                    , Int    -- number of redirects so far-                    , Int    -- number of retrys so far-                    , Bool   -- whether to pre-empt 401 response-                    )-+data RequestState +  = RequestState+      { reqDenies     :: Int   -- ^ number of 401 responses so far+      , reqRedirects  :: Int   -- ^ number of redirects so far+      , reqRetries    :: Int   -- ^ number of retrys so far+      , reqStopOnDeny :: Bool  -- ^ whether to pre-empt 401 response+      } +nullRequestState :: RequestState+nullRequestState = RequestState+      { reqDenies     = 0+      , reqRedirects  = 0+      , reqRetries    = 0+      , reqStopOnDeny = True+      } --- Surely the most important bit:-request :: Request -> BrowserAction (URI,Response)-request = request' initialState-    where-        initialState = (0,0,0,True)+-- limits we are willing to not go beyond for method retries and number of auth deny responses.+maxRetries :: Int+maxRetries = 4 +maxDenies :: Int+maxDenies = 2 -request' :: RequestState -> Request -> BrowserAction (URI,Response)-request' (denycount,redirectcount,retrycount,preempt) rq =-    do -- add cookies to request-       let uri = rqURI rq-       cookies <- getCookiesFor (uriToAuthorityString uri) (uriPath uri)-       -       when (not $ null cookies) -            (out $ "Adding cookies to request.  Cookie names: " -                 ++ foldl spaceappend "" (map ckName cookies))-       -       -- add credentials to request-       rq' <- if not preempt then return rq else-              do { auth <- anticipateChallenge rq-                 ; case auth of-                     Just x  -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)-                     Nothing -> return rq-                 }-               -       let rq'' = insertHeaders (map cookieToHeader cookies) rq'+-- Surely the most important bit:+request :: HStream ty+        => HTTPRequest ty+	-> BrowserAction (HandleStream ty) (URI,HTTPResponse ty)+request req = request' nullVal initialState req+  where+   initialState = nullRequestState+   nullVal      = buf_empty bufferOps -       p <- getProxy+request' :: HStream ty+         => ty+	 -> RequestState+	 -> HTTPRequest ty+	 -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty)+request' nullVal rqState rq = do+     -- add cookies to request+   let uri = rqURI rq+   cookies <- getCookiesFor (uriToAuthorityString uri) (uriPath uri)+   when (not $ null cookies) +        (out $ "Adding cookies to request.  Cookie names: "  +++               foldl spaceappend "" (map ckName cookies))+    -- add credentials to request+   rq' <- +    if not (reqStopOnDeny rqState) +     then return rq +     else do +       auth <- anticipateChallenge rq+       case auth of+         Nothing -> return rq+         Just x  -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)+   let rq'' = insertHeaders (map cookieToHeader cookies) rq'+   p <- getProxy -       out ("Sending:\n" ++ show rq'') -       e_rsp <- case p of-            NoProxy -> dorequest (uriAuth $ rqURI rq'') rq''-            Proxy str ath ->-                let rq''' = case ath of -                                Nothing -> rq''-                                Just x  -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq''-                    -- Proxy can take multiple forms - look for http://host:port first,-                    -- then host:port. Fall back to just the string given (probably a host name).-                    proxyURIAuth =-                      maybe notURI-                            (\parsed -> maybe notURI-                                         id (uriAuthority parsed))-                            (parseURI str)-                    notURI =-                      -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it!-                      let (host, port) = span (':'/=) str-                      in-                        if null port || null host-                          then URIAuth "" str ""-                          else URIAuth "" host port -                in-                  do-                    out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth-                    dorequest proxyURIAuth rq'''-       case e_rsp of-           Left v -> if (retrycount < 4) && (v == ErrorReset || v == ErrorClosed)-               then request' (denycount,redirectcount,retrycount+1,preempt) rq-               else error ("Exception raised in request: " ++ show v)-           Right rsp -> do -               out ("Received:\n" ++ show rsp)+   out ("Sending:\n" ++ show rq'') +   e_rsp <- +     case p of+       NoProxy       -> dorequest (uriAuth $ rqURI rq'') rq''+       Proxy str ath -> do+          let rq''' = maybe rq'' +	                   (\x -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq'')+		           ath+          let notURI +	       | null pt || null hst = +	         URIAuth{ uriUserInfo = ""+	                , uriRegName  = str+			, uriPort     = ""+			}+	       | otherwise = +	         URIAuth{ uriUserInfo = ""+	                , uriRegName  = hst+			, uriPort     = pt+			}+                  -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it!+                 where (hst, pt) = span (':'/=) str+           -- Proxy can take multiple forms - look for http://host:port first,+           -- then host:port. Fall back to just the string given (probably a host name).+          let proxyURIAuth =+                maybe notURI+                      (\parsed -> maybe notURI id (uriAuthority parsed))+                      (parseURI str) -               -- add new cookies to browser state-               let cookieheaders = retrieveHeaders HdrSetCookie rsp-               let newcookies = concat (map (headerToCookies $ uriToAuthorityString uri) cookieheaders)+          out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth+          dorequest proxyURIAuth rq'''+   case e_rsp of+    Left v +     | (reqRetries rqState < maxRetries) && (v == ErrorReset || v == ErrorClosed) ->+       request' nullVal rqState{reqRetries=reqRetries rqState + 1} rq+     | otherwise -> error ("Exception raised in request: " ++ show v)+    Right rsp -> do +     out ("Received:\n" ++ show rsp)+      -- add new cookies to browser state+     let cookieheaders = retrieveHeaders HdrSetCookie rsp+     let newcookies = concat (map (headerToCookies $ uriToAuthorityString uri) cookieheaders) -               when (not $ null newcookies)-                    (out $ foldl (\x y -> x ++ "\n  " ++ show y) "Cookies received:" newcookies)+     when (not $ null newcookies)+          (out $ foldl (\x y -> x ++ "\n  " ++ show y) "Cookies received:" newcookies)                -               filterfn <- getCookieFilter-               newcookies' <- ioAction (filterM (filterfn uri) newcookies)-               foldM (\_ -> addCookie) () newcookies'+     filterfn <- getCookieFilter+     newcookies' <- ioAction (filterM (filterfn uri) newcookies)+     foldM (\_ -> addCookie) () newcookies' -               when (not $ null newcookies)-                    (out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies'))+     when (not $ null newcookies)+          (out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies'))        -               case rspCode rsp of-                   (4,0,1) ->  -- Credentials not sent or refused.-                       out "401 - credentials not sent or refused" >>-                       if denycount > 2 then return (uri,rsp) else-                       do { let hdrs = retrieveHeaders HdrWWWAuthenticate rsp-                          ; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of-                                Just x  ->-                                    do { au <- challengeToAuthority uri x-                                       ; case au of-                                            Just au' ->-                                                out "Retrying request with new credentials" >>-                                                request' (denycount+1,redirectcount,retrycount,False)-                                                         (insertHeader HdrAuthorization (withAuthority au' rq) rq)-                                            Nothing  -> return (uri,rsp)   {- do nothing -}-                                       }-                                          -                                Nothing -> return (uri,rsp)   {- do nothing -}-                          }-                   --                   (4,0,7) ->  -- Proxy Authentication required-                       out "407 - proxy authentication required" >>-                       if denycount > 2 then return (uri,rsp) else-                       do { let hdrs = retrieveHeaders HdrProxyAuthenticate rsp-                          ; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of-                                Just x  ->-                                    do { au <- challengeToAuthority uri x-                                       ; case au of-                                            Just au' ->-                                                do { pxy <- getBS bsProxy-                                                   ; case pxy of-                                                        NoProxy ->-                                                            do { err "Proxy authentication required without proxy!"-                                                               ; return (uri,rsp)-                                                               }-                                                        Proxy x y ->-                                                            do { out "Retrying with proxy authentication"-                                                               ; setProxy (Proxy x $ Just au')-                                                               ; request' (denycount+1,redirectcount,retrycount,False) rq-                                                               }-                                                   }                                                      -                                            Nothing  -> return (uri,rsp)   {- do nothing -}-                                       }-                                          -                                Nothing -> return (uri,rsp)   {- do nothing -}-                          }+     case rspCode rsp of+      (4,0,1) -- Credentials not sent or refused.+        | reqDenies rqState > maxDenies -> do+          out "401 - credentials again refused; exceeded retry count (2)"+	  return (uri,rsp)+	| otherwise -> do+          out "401 - credentials not supplied or refused; retrying.."+          let hdrs = retrieveHeaders HdrWWWAuthenticate rsp+          case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of+            Nothing -> return (uri,rsp)   {- do nothing -}+            Just x  -> do+              au <- challengeToAuthority uri x+              case au of+                Nothing  -> return (uri,rsp)   {- do nothing -}+                Just au' -> do+                  out "Retrying request with new credentials"+		  request' nullVal+			   rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False}+                           (insertHeader HdrAuthorization (withAuthority au' rq) rq) +      (4,0,7)  -- Proxy Authentication required+        | reqDenies rqState > maxDenies -> do+          out "407 - proxy authentication required; max deny count exceeeded (2)"+          return (uri,rsp)+        | otherwise -> do+          out "407 - proxy authentication required"+          let hdrs = retrieveHeaders HdrProxyAuthenticate rsp+          case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of+            Nothing -> return (uri,rsp)   {- do nothing -}+            Just x  -> do+              au <- challengeToAuthority uri x+              case au of+               Nothing  -> return (uri,rsp)   {- do nothing -}+               Just au' -> do+                 pxy <- getBS bsProxy+                 case pxy of+                   NoProxy -> do+                     err "Proxy authentication required without proxy!"+                     return (uri,rsp)+                   Proxy px _ -> do+                     out "Retrying with proxy authentication"+                     setProxy (Proxy px (Just au'))+                     request' nullVal+			      rqState{reqDenies=reqDenies rqState + 1, reqStopOnDeny=False}+			      rq -                   (3,0,3) ->  -- Redirect using GET request method.-                       do { out "303 - redirect using GET"-                          ; rd <- getAllowRedirects-                          ; if not rd || redirectcount > 4 then return (uri,rsp) else-                            case retrieveHeaders HdrLocation rsp of-                                (Header _ u:_) -> case parseURIReference u of-                                    Just newuri ->-                                        let newuri' = case newuri `relativeTo` uri of-                                                        Nothing -> newuri-                                                        Just x  -> x-                                        in do { out ("Redirecting to " ++ show newuri' ++ " ...") -                                              ; let rq = rq { rqMethod=GET, rqURI=newuri', rqBody="" }-                                              ; request' (0,redirectcount+1,retrycount,True)-                                                         (replaceHeader HdrContentLength "0" rq) -                                              }-                                    Nothing ->-                                        do { err ("Parse of Location header in a redirect response failed: " ++ u)-                                           ; return (uri,rsp)-                                           }-                                [] -> do { err "No Location header in redirect response"-                                         ; return (uri,rsp)-                                         }-                          }-                        -                   (3,0,5) ->-                        case retrieveHeaders HdrLocation rsp of-                            (Header _ u:_) -> case parseURIReference u of-                                Just newuri ->-                                    do { out ("Retrying with proxy " ++ show newuri ++ "...")-                                       ; setProxy (Proxy (uriToAuthorityString newuri) Nothing)-                                       ; request' (0,0,retrycount+1,True) rq-                                       }-                                Nothing ->-                                    do { err ("Parse of Location header in a proxy redirect response failed: " ++ u)-                                       ; return (uri,rsp)-                                       }-                            [] -> do { err "No Location header in proxy redirect response."-                                     ; return (uri,rsp)-                                     }-                   +      (3,0,x) | x == 3 || x == 2 ->  do -- Redirect using GET request method.+        out ("30" ++ show x ++  " - redirect using GET")+        rd <- getAllowRedirects+        if not rd || reqRedirects rqState > maxRetries +	 then return (uri,rsp)+	 else +          case retrieveHeaders HdrLocation rsp of+           [] -> do +	     err "No Location header in redirect response"+             return (uri,rsp)+           (Header _ u:_) -> +	     case parseURIReference u of+               Nothing -> do+                 err ("Parse of Location header in a redirect response failed: " ++ u)+                 return (uri,rsp)+               Just newuri -> do+	         out ("Redirecting to " ++ show newuri' ++ " ...") +		 let rq1 = rq { rqMethod=GET, rqURI=newuri', rqBody=nullVal }+                 request' nullVal+			  rqState{reqDenies=0, reqRedirects=reqRedirects rqState + 1, reqStopOnDeny=True}+                          (replaceHeader HdrContentLength "0" rq1)+                where+                  newuri' = maybe newuri id (newuri `relativeTo` uri) -                   (3,_,_) ->  redirect uri rsp-                   _       -> return (uri,rsp)+      (3,0,5) ->+        case retrieveHeaders HdrLocation rsp of+         [] -> do +	   err "No Location header in proxy redirect response."+           return (uri,rsp)+         (Header _ u:_) -> +	   case parseURIReference u of+            Nothing -> do+             err ("Parse of Location header in a proxy redirect response failed: " ++ u)+             return (uri,rsp)+            Just newuri -> do+             out ("Retrying with proxy " ++ show newuri ++ "...")+             setProxy (Proxy (uriToAuthorityString newuri) Nothing)+             request' nullVal rqState{ reqDenies=0+	                             , reqRedirects=0+				     , reqRetries=reqRetries rqState + 1+				     , reqStopOnDeny=True+				     }+				     rq+      (3,_,_) ->  redirect uri rsp+      _       -> return (uri,rsp) -    where      -        spaceappend :: String -> String -> String-        spaceappend x y = x ++ ' ' : y+   where      +     redirect uri rsp = do+       rd <- getAllowRedirects+       if not rd || reqRedirects rqState > maxRetries+        then return (uri,rsp) +	else do+         case retrieveHeaders HdrLocation rsp of+          [] -> do +	    err "No Location header in redirect response."+            return (uri,rsp)+          (Header _ u:_) -> +	    case parseURIReference u of+              Just newuri -> do+                let newuri' = maybe newuri id (newuri `relativeTo` uri)+                out ("Redirecting to " ++ show newuri' ++ " ...") +                request' nullVal+		         rqState{reqDenies=0, reqRedirects=reqRedirects rqState + 1, reqStopOnDeny=True}+		         rq{rqURI=newuri'}+              Nothing -> do+                err ("Parse of Location header in a redirect response failed: " ++ u)+                return (uri,rsp) -        redirect uri rsp = do-            rd <- getAllowRedirects-            if not rd || redirectcount > 4 then return (uri,rsp) else do-            case retrieveHeaders HdrLocation rsp of-              (Header _ u:_) -> case parseURIReference u of-                                  Just newuri -> do-                                      let newuri' = case newuri `relativeTo` uri of-                                                      Nothing -> newuri-                                                      Just x  -> x-                                      out ("Redirecting to " ++ show newuri' ++ " ...") -                                      request' (0,redirectcount+1,retrycount,True) (rq { rqURI=newuri' }) -                                  Nothing -> do-                                      err ("Parse of Location header in a redirect response failed: " ++ u)-                                      return (uri,rsp)-              [] -> do err "No Location header in redirect response."-                       return (uri,rsp)+spaceappend :: String -> String -> String+spaceappend x y = x ++ ' ' : y  -        dorequest :: URIAuth -> Request -> BrowserAction (Either ConnError Response)-        dorequest hst rqst = +dorequest :: (HStream ty)+          => URIAuth -> HTTPRequest ty -> BrowserAction (HandleStream ty) (Either ConnError (HTTPResponse ty))+dorequest hst rqst =              do { pool <- getBS bsConnectionPool-               ; conn <- ioAction $ filterM (\c -> c `isConnectedTo` uriAuthToString hst) pool+               ; conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool                ; rsp <- case conn of                     [] -> do { out ("Creating new connection to " ++ uriAuthToString hst)-                             ; let port = case uriPort hst of+                             ; let aport = case uriPort hst of                                             (':':s) -> read s                                             _       -> 80-                             ; c <- ioAction $ openTCPPort (uriRegName hst) port+                             ; c <- ioAction $ openStream (uriRegName hst) aport                              ; let pool' = if length pool > 5                                            then init pool                                            else pool                              ; when (length pool > 5)                                     (ioAction $ close (last pool))                              ; alterBS (\b -> b { bsConnectionPool=c:pool' })-                             ; dorequest2 hst c rqst+                             ; dorequest2 c rqst                              }                     (c:_) ->                         do { out ("Recovering connection to " ++ uriAuthToString hst)-                           ; dorequest2 hst c rqst+                           ; dorequest2 c rqst                            }                ;                 ; return rsp                }--        dorequest2 hst c r =-            do { dbg <- getBS bsDebug-               ; ioAction $ case dbg of-                 Nothing -> sendHTTP c r-                 Just f  ->-                    debugStream (f++'-': uriAuthToString hst) c -                    >>= \c' -> sendHTTP c' r  -               }+  where+   dorequest2 c r = do+     dbg <- getBS bsDebug+     ioAction $ +       case dbg of+         Nothing -> sendHTTP c r+         Just f  -> do+	   c' <- debugByteStream (f++'-': uriAuthToString hst) c+	   sendHTTP c' r  -- uriAuth :: URI -> URIAuth uriAuth x = case uriAuthority x of               Just ua -> ua               _       -> error ("No uri authority for: "++show x) -uriAuthToString :: URIAuth -> String-uriAuthToString URIAuth { uriUserInfo = uinfo-                        , uriRegName  = regname-                        , uriPort     = port-                        } =-                    ((if null uinfo then id else (uinfo++))-                     . (regname++)-                     . (port++)) "" --- This function duplicates old Network.URI.authority behaviour.-uriToAuthorityString :: URI -> String-uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u)--- ------------------------------------------------------------------ ------------------ Request Building ------------------------------ ------------------------------------------------------------------ - libUA :: String libUA = "haskell-libwww/0.1" @@ -995,8 +974,6 @@             , rqMethod=GET             } -- -- This form junk is completely untested...  type FormVar = (String,String)@@ -1019,3 +996,4 @@                         , rqBody=enc                         , rqURI=u                         }+        _ -> error ("unexpected request: " ++ show m)

@@ -0,0 +1,132 @@+{-# LANGUAGE TypeSynonymInstances #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Network.BufferType
+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne
+-- License     :  BSD
+--
+-- Maintainer  :  Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable (not tested)
+--
+-- Operations over wire-transmitted values.
+-- 
+-----------------------------------------------------------------------------
+module Network.BufferType
+       ( 
+         BufferType(..)
+
+       , BufferOp(..)
+       , strictBufferOp
+       , lazyBufferOp
+       , stringBufferOp
+       ) where
+
+
+import qualified Data.ByteString       as Strict hiding ( unpack, pack, span )
+import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span )
+import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span )
+import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span )
+import System.IO ( Handle )
+import Data.Word ( Word8 )
+
+-- | The @BufferType@ class encodes, in a mixed-mode way, the interface
+-- that the library requires to operate over data embedded in HTTP
+-- requests and responses. That is, we use explicit dictionaries
+-- for the operations, but overload the name of these dicts.
+-- 
+class BufferType bufType where
+   bufferOps :: BufferOp bufType
+
+instance BufferType Lazy.ByteString where
+   bufferOps = lazyBufferOp
+
+instance BufferType Strict.ByteString where
+   bufferOps = strictBufferOp
+
+instance BufferType String where
+   bufferOps = stringBufferOp
+
+-- Encode the I/O operations of the underlying buffer over a Handle 
+-- in an (explicit) dictionary type. May not be needed, but gives
+-- us flexibility in explicit overriding and wrapping up of these methods.
+data BufferOp a
+ = BufferOp
+     { buf_hGet         :: Handle -> Int -> IO a
+     , buf_hGetContents :: Handle -> IO a
+     , buf_hPut         :: Handle -> a   -> IO ()
+     , buf_hGetLine     :: Handle -> IO a
+     , buf_empty        :: a
+     , buf_append       :: a -> a -> a
+     , buf_fromStr      :: String -> a
+     , buf_toStr        :: a -> String
+     , buf_snoc         :: a -> Word8 -> a
+     , buf_splitAt      :: Int -> a -> (a,a)
+     , buf_span         :: (Char  -> Bool) -> a -> (a,a)
+     , buf_isLineTerm   :: a -> Bool
+     , buf_isEmpty      :: a -> Bool
+     }
+
+instance Eq (BufferOp a) where
+  _ == _ = False
+
+strictBufferOp :: BufferOp Strict.ByteString
+strictBufferOp = 
+    BufferOp 
+      { buf_hGet         = Strict.hGet
+      , buf_hGetContents = Strict.hGetContents
+      , buf_hPut         = Strict.hPut
+      , buf_hGetLine     = Strict.hGetLine
+      , buf_append       = Strict.append
+      , buf_fromStr      = Strict.pack
+      , buf_toStr        = Strict.unpack
+      , buf_snoc         = Strict.snoc
+      , buf_splitAt      = Strict.splitAt
+      , buf_span         = Strict.span
+      , buf_empty        = Strict.empty
+      , buf_isLineTerm   = \ b -> Strict.length b == 2 && crlf == b
+      , buf_isEmpty      = Strict.null 
+      }
+   where
+    crlf = Strict.pack "\r\n"
+
+lazyBufferOp :: BufferOp Lazy.ByteString
+lazyBufferOp = 
+    BufferOp 
+      { buf_hGet         = Lazy.hGet
+      , buf_hGetContents = Lazy.hGetContents
+      , buf_hPut         = Lazy.hPut
+      , buf_hGetLine     = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l])
+      , buf_append       = Lazy.append
+      , buf_fromStr      = Lazy.pack
+      , buf_toStr        = Lazy.unpack
+      , buf_snoc         = Lazy.snoc
+      , buf_splitAt      = \ i x -> Lazy.splitAt (fromIntegral i) x
+      , buf_span         = Lazy.span
+      , buf_empty        = Lazy.empty
+      , buf_isLineTerm   = \ b -> Lazy.length b == 2 && crlf == b
+      , buf_isEmpty      = Lazy.null 
+      }
+   where
+    crlf = Lazy.pack "\r\n"
+
+stringBufferOp :: BufferOp String
+stringBufferOp =BufferOp 
+      { buf_hGet         = \ h n -> Strict.hGet h n >>= return . Strict.unpack
+      , buf_hGetContents = \ h -> Strict.hGetContents h >>= return . Strict.unpack
+      , buf_hPut         = \ h s -> Strict.hPut h (Strict.pack s)
+      , buf_hGetLine     = \ h   -> Strict.hGetLine h >>= return . Strict.unpack
+      , buf_append       = (++)
+      , buf_fromStr      = id
+      , buf_toStr        = id
+      , buf_snoc         = \ a x -> a ++ [toEnum (fromIntegral x)]
+      , buf_splitAt      = splitAt
+      , buf_span         = \ p a -> 
+                             case Strict.span p (Strict.pack a) of
+			       (x,y) -> (Strict.unpack x, Strict.unpack y)
+      , buf_empty        = []
+      , buf_isLineTerm   = \ b -> b == crlf
+      , buf_isEmpty      = null 
+      }
+   where
+    crlf = "\r\n"

@@ -93,640 +93,31 @@ --             had been added (in which case 417 response is returned). -- ------------------------------------------------------------------------------module Network.HTTP (-    module Network.Stream,-    module Network.TCP,--    -- ** Constants-    httpVersion,-    -    -- ** HTTP -    Request(..),-    RequestData,-    Response(..),-    RequestMethod(..),-    ResponseCode,-    simpleHTTP, simpleHTTP_,-    sendHTTP,-    receiveHTTP,-    processRequest,-    getRequestHead,-    respondHTTP,--    -- ** Header Functions-    module Network.HTTP.Headers,--    -- ** URL Encoding-    urlEncode,-    urlDecode,-    urlEncodeVars,+module Network.HTTP +       ( module Network.HTTP.HandleStream+       , module Network.HTTP.Base+       , module Network.HTTP.Headers -    -- ** URI authority parsing-    URIAuthority(..),-    getAuth,-    parseURIAuthority-) where+{-+       , simpleHTTP     -- :: Request -> IO (Result Response)+       , simpleHTTP_    -- :: Stream s => s -> Request -> IO (Result Response)+       , sendHTTP       -- :: Stream s => s -> Request -> IO (Result Response)+       , receiveHTTP    -- :: Stream s => s -> IO (Result Request)+       , respondHTTP    -- :: Stream s => s -> Response -> IO ()+-}+       , module Network.TCP +       ) where  ----------------------------------------------------------------- ------------------ Imports -------------------------------------- ----------------------------------------------------------------- -import Network.URI-   ( URI(URI, uriScheme, uriAuthority, uriPath)-   , URIAuth(uriUserInfo, uriRegName, uriPort)-   , parseURIReference-   , unEscapeString, escapeURIString, isUnescapedInURI-   ) import Network.HTTP.Headers-import Network.Stream-import Network.StreamDebugger (debugStream)-import Network.TCP (openTCPPort)--import Control.Exception as Exception (catch, throw)-import Data.Bits ((.&.))-import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower)-import Data.List (partition, intersperse)-import Data.Maybe (listToMaybe, fromMaybe)-import Control.Monad (when, guard)-import Numeric (readHex)-import Text.Read.Lex (readDecP)-import Text.ParserCombinators.ReadP-   ( ReadP, readP_to_S, char, (<++), look, munch )-import Data.Typeable---- Turn on to enable HTTP traffic logging-debug :: Bool-debug = False---- File that HTTP traffic logs go to-httpLogFile :: String-httpLogFile = "http-debug.log"-------------------------------------------------------------------------------------- Misc --------------------------------------------------------------------------------------------------------------- remove leading and trailing whitespace.-trim :: String -> String-trim = let dropspace = dropWhile isSpace in-       reverse . dropspace . reverse . dropspace---crlf, sp :: String-crlf = "\r\n"-sp   = " "-------------------------------------------------------------------------------------- URI Authority parsing --------------------------------------------------------------------------------------------data URIAuthority = URIAuthority { user :: Maybe String, -				   password :: Maybe String,-				   host :: String,-				   port :: Maybe Int-				 } deriving (Eq,Show)---- | Parse the authority part of a URL.------ > RFC 1738, section 3.1:--- >--- >       //<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-------------------------------------------------------------------------------------- HTTP Messages ------------------------------------------------------------------------------------------------------- Protocol version-httpVersion :: String-httpVersion = "HTTP/1.1"----- | The HTTP request method, to be used in the 'Request' object.--- We are missing a few of the stranger methods, but these are--- not really necessary until we add full TLS.-data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | Custom String-    deriving(Show,Eq)--rqMethodMap :: [(String, RequestMethod)]-rqMethodMap = [("HEAD",    HEAD),-	       ("PUT",     PUT),-	       ("GET",     GET),-	       ("POST",    POST),-               ("DELETE",  DELETE),-	       ("OPTIONS", OPTIONS),-	       ("TRACE",   TRACE)]---- | An HTTP Request.--- The 'Show' instance of this type is used for message serialisation,--- which means no body data is output.-data Request =-     Request { rqURI       :: URI   -- ^ might need changing in future-                                    --  1) to support '*' uri in OPTIONS request-                                    --  2) transparent support for both relative-                                    --     & absolute uris, although this should-                                    --     already work (leave scheme & host parts empty).-             , rqMethod    :: RequestMethod             -             , rqHeaders   :: [Header]-             , rqBody      :: String-             } deriving (Typeable)+import Network.HTTP.Base+--import Network.HTTP.Stream+import Network.HTTP.HandleStream+import Network.TCP   --- Notice that request body is not included,--- this show function is used to serialise--- a request for the transport link, we send--- the body separately where possible.-instance Show Request where-    show (Request u m h _) =-        show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf-        ++ foldr (++) [] (map show h) ++ crlf-        where-            alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' -                        then u { uriPath = '/' : uriPath u } -                        else u--instance HasHeaders Request where-    getHeaders = rqHeaders-    setHeaders rq hdrs = rq { rqHeaders=hdrs }--type ResponseCode  = (Int,Int,Int)-type ResponseData  = (ResponseCode,String,[Header])-type RequestData   = (RequestMethod,URI,[Header])---- | An HTTP Response.--- The 'Show' instance of this type is used for message serialisation,--- which means no body data is output, additionally the output will--- show an HTTP version of 1.1 instead of the actual version returned--- by a server.-data Response =-    Response { rspCode     :: ResponseCode-             , rspReason   :: String-             , rspHeaders  :: [Header]-             , rspBody     :: String-             } deriving (Typeable)-                   --- This is an invalid representation of a received response, --- since we have made the assumption that all responses are HTTP/1.1-instance Show Response where-    show (Response (a,b,c) reason headers _) =-        httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf-        ++ foldr (++) [] (map show headers) ++ crlf--instance HasHeaders Response where-    getHeaders = rspHeaders-    setHeaders rsp hdrs = rsp { rspHeaders=hdrs }-------------------------------------------------------------------------------------- Parsing ------------------------------------------------------------------------------------------------------------ Parsing a request-parseRequestHead :: [String] -> Result RequestData-parseRequestHead [] = Left ErrorClosed-parseRequestHead (com:hdrs) =-    requestCommand com `bindE` \(version,rqm,uri) ->-    parseHeaders hdrs `bindE` \hdrs' ->-    Right (rqm,uri,hdrs')-    where-        requestCommand line-	    =  case words line of-                yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of-					  (Just u, Just r) -> Right (version,r,u)-					  _                -> Left (ErrorParse $ "Request command line parse failure: " ++ line)-		no -> if null line-			       then Left ErrorClosed-			       else Left (ErrorParse $ "Request command line parse failure: " ++ line)  ---- Parsing a response-parseResponseHead :: [String] -> Result ResponseData-parseResponseHead [] = Left ErrorClosed-parseResponseHead (sts:hdrs) = -    responseStatus sts `bindE` \(version,code,reason) ->-    parseHeaders hdrs `bindE` \hdrs' ->-    Right (code,reason,hdrs')-    where--        responseStatus line-            =  case words line of-                yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason)-                no -> if null line -                    then Left ErrorClosed  -- an assumption-                    else Left (ErrorParse $ "Response status line parse failure: " ++ line)---        match [a,b,c] = (digitToInt a,-                         digitToInt b,-                         digitToInt c)-        match _ = (-1,-1,-1)  -- will create appropriate behaviour---        -------------------------------------------------------------------------------------- HTTP Send / Recv ------------------------------------------------------------------------------------------------------data Behaviour = Continue-               | Retry-               | Done-               | ExpectEntity-               | DieHorribly String--matchResponse :: RequestMethod -> ResponseCode -> Behaviour-matchResponse rqst rsp =-    case rsp of-        (1,0,0) -> Continue-        (1,0,1) -> Done        -- upgrade to TLS-        (1,_,_) -> Continue    -- default-        (2,0,4) -> Done-        (2,0,5) -> Done-        (2,_,_) -> ans-        (3,0,4) -> Done-        (3,0,5) -> Done-        (3,_,_) -> ans-        (4,1,7) -> Retry       -- Expectation failed-        (4,_,_) -> ans-        (5,_,_) -> ans-        (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")-    where-        ans | rqst == HEAD = Done-            | otherwise    = ExpectEntity-        ---- | Simple way to get a resource across a non-persistant connection.--- Headers that may be altered:---  Host        Altered only if no Host header is supplied, HTTP\/1.1---              requires a Host header.---  Connection  Where no allowance is made for persistant connections---              the Connection header will be set to "close"-simpleHTTP :: Request -> IO (Result Response)-simpleHTTP r = -    do -       auth <- getAuth r-       c <- openTCPPort (host auth) (fromMaybe 80 (port auth))-       simpleHTTP_ c r---- | Like 'simpleHTTP', but acting on an already opened stream.-simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)-simpleHTTP_ s r =-    do -       auth <- getAuth r-       let r' = fixReq auth r -       rsp <- if debug then do-	        s' <- debugStream httpLogFile s-	        sendHTTP s' r'-	       else-	        sendHTTP s r'-       -- already done by sendHTTP because of "Connection: close" header-       --; close s -       return rsp-       where-  {- RFC 2616, section 5.1.2:-     "The most common form of Request-URI is that used to identify a-      resource on an origin server or gateway. In this case the absolute-      path of the URI MUST be transmitted (see section 3.2.1, abs_path) as-      the Request-URI, and the network location of the URI (authority) MUST-      be transmitted in a Host header field." -}-  -- we assume that this is the case, so we take the host name from-  -- the Host header if there is one, otherwise from the request-URI.-  -- Then we make the request-URI an abs_path and make sure that there-  -- is a Host header.-             fixReq :: URIAuthority -> Request -> Request-	     fixReq URIAuthority{host=h,port=p} r = -		 let h' = h ++ maybe "" ((':':) . show) p in-		 replaceHeader HdrConnection "close" $-		 insertHeaderIfMissing HdrHost h' $-		 r { rqURI = (rqURI r){ uriScheme = "", -					uriAuthority = Nothing } }	       --getAuth :: Monad m => Request -> m URIAuthority-getAuth r = case parseURIAuthority auth of-			 Just x -> return x -			 Nothing -> fail $ "Error parsing URI authority '"-				           ++ auth ++ "'"-		 where auth = case findHeader HdrHost r of-			      Just h -> h-			      Nothing -> uriToAuthorityString (rqURI r)--sendHTTP :: Stream s => s -> Request -> IO (Result Response)-sendHTTP conn rq = -    do { let a_rq = fixHostHeader rq-       ; rsp <- Exception.catch (main a_rq)-                      (\e -> do { close conn; throw e })-       ; let fn list = when (or $ map findConnClose list)-                            (close conn)-       ; either (\_ -> fn [rqHeaders rq])-                (\r -> fn [rqHeaders rq,rspHeaders r])-                rsp-       ; return rsp-       }-    where       --- From RFC 2616, section 8.2.3:--- 'Because of the presence of older implementations, the protocol allows--- ambiguous situations in which a client may send "Expect: 100---- continue" without receiving either a 417 (Expectation Failed) status--- or a 100 (Continue) status. Therefore, when a client sends this--- header field to an origin server (possibly via a proxy) from which it--- has never seen a 100 (Continue) status, the client SHOULD NOT wait--- for an indefinite period before sending the request body.'------ Since we would wait forever, I have disabled use of 100-continue for now.-        main :: Request -> IO (Result Response)-        main rqst =-            do -	       --let str = if null (rqBody rqst)-               --              then show rqst-               --              else show (insertHeader HdrExpect "100-continue" rqst)-               writeBlock conn (show rqst)-	       -- write body immediately, don't wait for 100 CONTINUE-	       writeBlock conn (rqBody rqst)-               rsp <- getResponseHead               -               switchResponse True False rsp rqst-        -        -- reads and parses headers-        getResponseHead :: IO (Result ResponseData)-        getResponseHead =-            do { lor <- readTillEmpty1 conn-               ; return $ lor `bindE` parseResponseHead-               }--        -- Hmmm, this could go bad if we keep getting "100 Continue"-        -- responses...  Except this should never happen according-        -- to the RFC.-        switchResponse :: Bool {- allow retry? -}-                       -> Bool {- is body sent? -}-                       -> Result ResponseData-                       -> Request-                       -> IO (Result Response)-            -        switchResponse _ _ (Left e) _ = return (Left e)-                -- retry on connreset?-                -- if we attempt to use the same socket then there is an excellent-                -- chance that the socket is not in a completely closed state.--        switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =-            case matchResponse (rqMethod rqst) cd of-                Continue-                    | not bdy_sent -> {- Time to send the body -}-                        do { val <- writeBlock conn (rqBody rqst)-                           ; case val of-                                Left e -> return (Left e)-                                Right _ ->-                                    do { rsp <- getResponseHead-                                       ; switchResponse allow_retry True rsp rqst-                                       }-                           }-                    | otherwise -> {- keep waiting -}-                        do { rsp <- getResponseHead-                           ; switchResponse allow_retry bdy_sent rsp rqst                           -                           }--                Retry -> {- Request with "Expect" header failed.-                                Trouble is the request contains Expects-                                other than "100-Continue" -}-                    do { writeBlock conn (show rqst ++ rqBody rqst)-                       ; rsp <- getResponseHead-                       ; switchResponse False bdy_sent rsp rqst-                       }   -                     -                Done ->-                    return (Right $ Response cd rn hdrs "")--                DieHorribly str ->-                    return $ Left $ ErrorParse ("Invalid response: " ++ str)--                ExpectEntity ->-                    let tc = lookupHeader HdrTransferEncoding hdrs-                        cl = lookupHeader HdrContentLength hdrs-                    in-                    do { rslt <- case tc of-                          Nothing -> -                              case cl of-                                  Just x  -> linearTransferStrLen conn x-                                  Nothing -> hopefulTransfer conn ""-                          Just x  -> -                              case map toLower (trim x) of-                                  "chunked" -> chunkedTransfer conn-                                  _         -> uglyDeathTransfer conn-                       ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) -                       }--        -        -- Adds a Host header if one is NOT ALREADY PRESENT-        fixHostHeader :: Request -> Request-        fixHostHeader rq =-            let uri = rqURI rq-                host = uriToAuthorityString uri-            in insertHeaderIfMissing HdrHost host rq-                                     -        -- Looks for a "Connection" header with the value "close".-        -- Returns True when this is found.-        findConnClose :: [Header] -> Bool-        findConnClose hdrs =-            case lookupHeader HdrConnection hdrs of-                Nothing -> False-                Just x  -> map toLower (trim x) == "close"---- This function duplicates old Network.URI.authority behaviour.-uriToAuthorityString :: URI -> String-uriToAuthorityString URI{uriAuthority=Nothing} = ""-uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua ++-                                                 uriRegName ua ++-                                                 uriPort ua---- | Receive and parse a HTTP request from the given Stream. Should be used---   for server side interactions.-receiveHTTP :: Stream s => s -> IO (Result Request)-receiveHTTP conn = do rq <- getRequestHead conn-                      case rq of-                        Left e  -> return (Left e)-                        Right r -> processRequest conn r---- | Reads and parses request headers.-getRequestHead :: Stream s => s -> IO (Result RequestData)-getRequestHead conn =-    do { lor <- readTillEmpty1 conn-       ; return $ lor `bindE` parseRequestHead-       }---- | Process request body (called after successful getRequestHead)-processRequest :: Stream s => s -> RequestData -> IO (Result Request)-processRequest conn (rm,uri,hdrs) =-    do -- FIXME : Also handle 100-continue.-       let tc = lookupHeader HdrTransferEncoding hdrs-           cl = lookupHeader HdrContentLength hdrs-       rslt <- case tc of-                  Nothing ->-                      case cl of-                          Just x  -> linearTransferStrLen conn x-                          Nothing -> return (Right ([], "")) -- hopefulTransfer ""-                  Just x  ->-                      case map toLower (trim x) of-                          "chunked" -> chunkedTransfer conn-                          _         -> uglyDeathTransfer conn--       return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)----- | Very simple function, send a HTTP response over the given stream. This ---   could be improved on to use different transfer types.-respondHTTP :: Stream s => s -> Response -> IO ()-respondHTTP conn rsp = do writeBlock conn (show rsp)-                          -- write body immediately, don't wait for 100 CONTINUE-                          writeBlock conn (rspBody rsp)-			  return ()---- The following functions were in the where clause of sendHTTP, they have--- been moved to global scope so other functions can access them.		       --linearTransferStrLen :: Stream s => s -> String -> IO (Result ([Header],String))-linearTransferStrLen conn ns =-   case reads ns of-      [(n,"")] -> linearTransfer conn n-      _ -> return $ Left $ ErrorParse $ "Content-Length header contains not a number: " ++ show ns---- | Used when we know exactly how many bytes to expect.-linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))-linearTransfer conn n-    = do info <- readBlock conn n-         return $ info `bindE` \str -> Right ([],str)---- | Used when nothing about data is known,---   Unfortunately waiting for a socket closure---   causes bad behaviour.  Here we just---   take data once and give up the rest.-hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String))-hopefulTransfer conn str-    = readLine conn >>= -      either (\v -> return $ Left v)-             (\more -> if null more -                         then return (Right ([],str)) -                         else hopefulTransfer conn (str++more))--- | A necessary feature of HTTP\/1.1---   Also the only transfer variety likely to---   return any footers.-chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))-chunkedTransfer conn-    =  chunkedTransferC conn 0 >>= \v ->-       return $ v `bindE` \(ftrs,count,info) ->-                let myftrs = Header HdrContentLength (show count) : ftrs              -                in Right (myftrs,info)--chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))-chunkedTransferC conn n-    =  readLine conn >>= \v -> case v of-                  Left e -> return (Left e)-                  Right line ->-                      let size = ( if null line-                                     then 0-                                     else case readHex line of-                                        (n,_):_ -> n-                                        _       -> 0-                                     )-                      in if size == 0-                           then do { rs <- readTillEmpty2 conn []-                                   ; return $-                                        rs `bindE` \strs ->-                                        parseHeaders strs `bindE` \ftrs ->-                                        Right (ftrs,n,"")-                                   }-                           else do { some <- readBlock conn size-                                   ; readLine conn-                                   ; more <- chunkedTransferC conn (n+size)-                                   ; return $ -                                        some `bindE` \cdata ->-                                        more `bindE` \(ftrs,m,mdata) -> -                                        Right (ftrs,m,cdata++mdata) -                                   }                   ---- | Maybe in the future we will have a sensible thing---   to do here, at that time we might want to change---   the name.-uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))-uglyDeathTransfer conn-    = return $ Left $ ErrorParse "Unknown Transfer-Encoding"---- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)-readTillEmpty1 :: Stream s => s -> IO (Result [String])-readTillEmpty1 conn =-    do { line <- readLine conn-       ; case line of-           Left e -> return $ Left e-           Right s ->-               if s == crlf-                 then readTillEmpty1 conn-                 else readTillEmpty2 conn [s]-       }---- | Read lines until an empty line (CRLF),---   also accepts a connection close as end of---   input, which is not an HTTP\/1.1 compliant---   thing to do - so probably indicates an---   error condition.-readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])-readTillEmpty2 conn list =-    do { line <- readLine conn-       ; case line of-           Left e -> return $ Left e-           Right s ->-               if s == crlf || null s-                 then return (Right $ reverse (s:list))-                 else readTillEmpty2 conn (s:list)-       }--        ------------------------------------------------------------------------------------- A little friendly funtionality ------------------------------------------------------------------------------------- | Formats name-value pairs as application\/x-www-form-urlencoded.-urlEncodeVars :: [(String,String)] -> String-urlEncodeVars xs = -    concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs]---- | Converts a single value to the application\/x-www-form-urlencoded encoding.-urlEncode :: String -> String-urlEncode = replace ' ' '+' . escapeURIString okChar-  where okChar c = c == ' ' || -                   (isUnescapedInURI c && c `notElem` "&=+")---- | Converts a single value from the ---   application\/x-www-form-urlencoded encoding.-urlDecode :: String -> String-urlDecode = unEscapeString . replace '+' ' '---- | Replaces all instances of a value in a list by another value.-replace :: Eq a =>-           a   -- ^ Value to look for-        -> a   -- ^ Value to replace it with-        -> [a] -- ^ Input list-        -> [a] -- ^ Output list-replace x y = map (\z -> if z == x then y else z)

@@ -0,0 +1,552 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Network.HTTP.Base
+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne
+-- License     :  BSD
+-- 
+-- Maintainer  :  Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable (not tested)
+--
+-- An easy HTTP interface; base types.
+--
+-----------------------------------------------------------------------------
+module Network.HTTP.Base
+       (
+          -- ** Constants
+         httpVersion
+
+          -- ** HTTP
+       , Request
+       , Response
+       , RequestMethod(..)
+       
+       , HTTPRequest(..)
+       , HTTPResponse(..)
+       
+          -- ** URL Encoding
+       , urlEncode
+       , urlDecode
+       , urlEncodeVars
+
+          -- ** URI authority parsing
+       , URIAuthority(..)
+       , parseURIAuthority
+       
+          -- internal
+       , crlf
+       , sp
+       , uriToAuthorityString   -- :: URI    -> String
+       , uriAuthToString        -- :: URIAuth -> String
+       , parseResponseHead
+       , parseRequestHead
+       , ResponseNextStep(..)
+       , matchResponse
+       , ResponseData
+       , ResponseCode
+       , RequestData
+       
+       , getAuth
+       , normalizeRequestURI
+       , normalizeHostHeader
+       , findConnClose
+
+         -- internal export (for the use by Network.HTTP.{Stream,ByteStream} )
+       , linearTransfer
+       , hopefulTransfer
+       , chunkedTransfer
+       , uglyDeathTransfer
+       , readTillEmpty1
+       , readTillEmpty2
+       
+       , catchIO
+       , catchIO_
+       ) where
+
+import Network.URI
+   ( URI(uriAuthority, uriPath, uriScheme)
+   , URIAuth(uriUserInfo, uriRegName, uriPort)
+   , parseURIReference
+   )
+
+import Control.Monad ( guard )
+import Data.Char     ( ord, digitToInt, intToDigit, toLower )
+import Data.List     ( partition )
+import Data.Maybe    ( listToMaybe )
+import Numeric       ( showHex, readHex )
+
+import Network.Stream
+import Network.BufferType ( BufferOp(..) )
+import Network.HTTP.Headers
+import Network.HTTP.Utils ( trim )
+
+import Text.Read.Lex (readDecP)
+import Text.ParserCombinators.ReadP
+   ( ReadP, readP_to_S, char, (<++), look, munch )
+
+import Control.Exception as Exception (IOException)
+
+-----------------------------------------------------------------
+------------------ URI Authority parsing ------------------------
+-----------------------------------------------------------------
+
+data URIAuthority = URIAuthority { user :: Maybe String, 
+				   password :: Maybe String,
+				   host :: String,
+				   port :: Maybe Int
+				 } deriving (Eq,Show)
+
+-- | Parse the authority part of a URL.
+--
+-- > RFC 1732, section 3.1:
+-- >
+-- >       //<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
+
+-- This function duplicates old Network.URI.authority behaviour.
+uriToAuthorityString :: URI -> String
+uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u)
+
+uriAuthToString :: URIAuth -> String
+uriAuthToString ua = 
+  concat [ uriUserInfo ua 
+         , uriRegName ua
+	 , uriPort ua
+	 ]
+
+-----------------------------------------------------------------
+------------------ HTTP Messages --------------------------------
+-----------------------------------------------------------------
+
+
+-- Protocol version
+httpVersion :: String
+httpVersion = "HTTP/1.1"
+
+
+-- | The HTTP request method, to be used in the 'Request' object.
+-- We are missing a few of the stranger methods, but these are
+-- not really necessary until we add full TLS.
+data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE
+    deriving(Show,Eq)
+
+rqMethodMap :: [(String, RequestMethod)]
+rqMethodMap = [("HEAD",    HEAD),
+	       ("PUT",     PUT),
+	       ("GET",     GET),
+	       ("POST",    POST),
+               ("DELETE",  DELETE),
+	       ("OPTIONS", OPTIONS),
+	       ("TRACE",   TRACE)]
+
+type Request  = HTTPRequest  String
+type Response = HTTPResponse String
+
+-- | An HTTP Request.
+-- The 'Show' instance of this type is used for message serialisation,
+-- which means no body data is output.
+data HTTPRequest a =
+     Request { rqURI       :: URI   -- ^ might need changing in future
+                                    --  1) to support '*' uri in OPTIONS request
+                                    --  2) transparent support for both relative
+                                    --     & absolute uris, although this should
+                                    --     already work (leave scheme & host parts empty).
+             , rqMethod    :: RequestMethod             
+             , rqHeaders   :: [Header]
+             , rqBody      :: a
+             }
+
+
+
+crlf, sp :: String
+crlf = "\r\n"
+sp   = " "
+
+-- Notice that request body is not included,
+-- this show function is used to serialise
+-- a request for the transport link, we send
+-- the body separately where possible.
+instance Show (HTTPRequest a) where
+    show (Request u m h _) =
+        show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf
+        ++ foldr (++) [] (map show h) ++ crlf
+        where
+            alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' 
+                        then u { uriPath = '/' : uriPath u } 
+                        else u
+
+instance HasHeaders (HTTPRequest a) where
+    getHeaders = rqHeaders
+    setHeaders rq hdrs = rq { rqHeaders=hdrs }
+
+-- | For easy pattern matching, HTTP response codes @xyz@ are
+-- represented as @(x,y,z)@.
+type ResponseCode  = (Int,Int,Int)
+
+-- | @ResponseData@ contains the head of a response payload;
+-- HTTP response code, accompanying text description + header
+-- fields.
+type ResponseData  = (ResponseCode,String,[Header])
+
+-- | @RequestData@ contains the head of a HTTP request; method,
+-- its URL along with the auxillary/supporting header data.
+type RequestData   = (RequestMethod,URI,[Header])
+
+-- | An HTTP Response.
+-- The 'Show' instance of this type is used for message serialisation,
+-- which means no body data is output, additionally the output will
+-- show an HTTP version of 1.1 instead of the actual version returned
+-- by a server.
+data HTTPResponse a =
+    Response { rspCode     :: ResponseCode
+             , rspReason   :: String
+             , rspHeaders  :: [Header]
+             , rspBody     :: a
+             }
+                   
+-- This is an invalid representation of a received response, 
+-- since we have made the assumption that all responses are HTTP/1.1
+instance Show (HTTPResponse a) where
+    show (Response (a,b,c) reason headers _) =
+        httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf
+        ++ foldr (++) [] (map show headers) ++ crlf
+
+instance HasHeaders (HTTPResponse a) where
+    getHeaders = rspHeaders
+    setHeaders rsp hdrs = rsp { rspHeaders=hdrs }
+
+-----------------------------------------------------------------
+------------------ Parsing --------------------------------------
+-----------------------------------------------------------------
+
+-- Parsing a request
+parseRequestHead :: [String] -> Result RequestData
+parseRequestHead [] = Left ErrorClosed
+parseRequestHead (com:hdrs) =
+    requestCommand com `bindE` \(_version,rqm,uri) ->
+    parseHeaders hdrs `bindE` \hdrs' ->
+    Right (rqm,uri,hdrs')
+    where
+        requestCommand line =
+	  case words line of
+            _yes@(rqm:uri:version) -> 
+	     case (parseURIReference uri, lookup rqm rqMethodMap) of
+  	       (Just u, Just r) -> Right (version,r,u)
+	       _                -> Left parse_err
+	    _no 
+	     | null line -> Left ErrorClosed
+	     | otherwise -> Left parse_err
+          where
+	   parse_err = ErrorParse ("Request command line parse failure: " ++ line)
+
+-- Parsing a response
+parseResponseHead :: [String] -> Result ResponseData
+parseResponseHead [] = Left ErrorClosed
+parseResponseHead (sts:hdrs) = 
+    responseStatus sts `bindE` \(_version,code,reason) ->
+    parseHeaders hdrs `bindE` \hdrs' ->
+    Right (code,reason,hdrs')
+    where
+        responseStatus line =
+          case words line of
+            _yes@(version:code:reason) -> 
+	     Right (version,match code,concatMap (++" ") reason)
+            _no
+	     | null line -> Left ErrorClosed  -- an assumption
+	     | otherwise -> Left parse_err
+          where
+	   parse_err = (ErrorParse $ "Response status line parse failure: " ++ line)
+
+        match [a,b,c] = (digitToInt a,
+                         digitToInt b,
+                         digitToInt c)
+        match _ = (-1,-1,-1)  -- will create appropriate behaviour
+
+
+        
+
+-----------------------------------------------------------------
+------------------ HTTP Send / Recv ----------------------------------
+-----------------------------------------------------------------
+
+data ResponseNextStep
+ = Continue
+ | Retry
+ | Done
+ | ExpectEntity
+ | DieHorribly String
+
+matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep
+matchResponse rqst rsp =
+    case rsp of
+        (1,0,0) -> Continue
+        (1,0,1) -> Done        -- upgrade to TLS
+        (1,_,_) -> Continue    -- default
+        (2,0,4) -> Done
+        (2,0,5) -> Done
+        (2,_,_) -> ans
+        (3,0,4) -> Done
+        (3,0,5) -> Done
+        (3,_,_) -> ans
+        (4,1,7) -> Retry       -- Expectation failed
+        (4,_,_) -> ans
+        (5,_,_) -> ans
+        (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")
+    where
+        ans | rqst == HEAD = Done
+            | otherwise    = ExpectEntity
+        
+
+        
+-----------------------------------------------------------------
+------------------ A little friendly funtionality ---------------
+-----------------------------------------------------------------
+
+
+{-
+    I had a quick look around but couldn't find any RFC about
+    the encoding of data on the query string.  I did find an
+    IETF memo, however, so this is how I justify the urlEncode
+    and urlDecode methods.
+
+    Doc name: draft-tiwari-appl-wxxx-forms-01.txt  (look on www.ietf.org)
+
+    Reserved chars:  ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.
+    Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"
+    URI delims: "<" | ">" | "#" | "%" | <">
+    Unallowed ASCII: <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) = toEnum (16 * digitToInt a + digitToInt b)
+                         : urlDecode rest
+urlDecode (h:t) = h : urlDecode t
+urlDecode [] = []
+
+urlEncode (h:t) =
+    let str = if reserved (ord h) then escape h else [h]
+    in str ++ urlEncode t
+    where
+        reserved x
+            | x >= ord 'a' && x <= ord 'z' = False
+            | x >= ord 'A' && x <= ord 'Z' = False
+            | x >= ord '0' && x <= ord '9' = False
+            | x <= 0x20 || x >= 0x7F = True
+            | otherwise = x `elem` map ord [';','/','?',':','@','&'
+                                           ,'=','+',',','$','{','}'
+                                           ,'|','\\','^','[',']','`'
+                                           ,'<','>','#','%','"']
+        -- wouldn't it be nice if the compiler
+        -- optimised the above for us?
+
+        escape x = '%':showHex (ord x) ""
+
+urlEncode [] = []
+            
+
+
+-- Encode form variables, useable in either the
+-- query part of a URI, or the body of a POST request.
+-- I have no source for this information except experience,
+-- this sort of encoding worked fine in CGI programming.
+urlEncodeVars :: [(String,String)] -> String
+urlEncodeVars ((n,v):t) =
+    let (same,diff) = partition ((==n) . fst) t
+    in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)
+       ++ urlEncodeRest diff
+       where urlEncodeRest [] = []
+             urlEncodeRest diff = '&' : urlEncodeVars diff
+urlEncodeVars [] = []
+
+-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@
+-- header.
+getAuth :: Monad m => HTTPRequest ty -> m URIAuthority
+getAuth r = 
+   -- ToDo: verify that Network.URI functionality doesn't take care of this (now.)
+  case parseURIAuthority auth of
+    Just x -> return x 
+    Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'"
+ where 
+   auth = 
+    case findHeader HdrHost r of
+      Just h  -> h
+      Nothing -> uriToAuthorityString (rqURI r)
+
+  {- RFC 2616, section 5.1.2:
+     "The most common form of Request-URI is that used to identify a
+      resource on an origin server or gateway. In this case the absolute
+      path of the URI MUST be transmitted (see section 3.2.1, abs_path) as
+      the Request-URI, and the network location of the URI (authority) MUST
+      be transmitted in a Host header field." -}
+  -- we assume that this is the case, so we take the host name from
+  -- the Host header if there is one, otherwise from the request-URI.
+  -- Then we make the request-URI an abs_path and make sure that there
+  -- is a Host header.
+normalizeRequestURI :: URIAuthority -> HTTPRequest ty -> HTTPRequest ty
+normalizeRequestURI URIAuthority{host=h} r = 
+  replaceHeader HdrConnection "close" $
+  insertHeaderIfMissing HdrHost h $
+    r { rqURI = (rqURI r){ uriScheme = ""
+                         , uriAuthority = Nothing
+			 }}
+
+-- Adds a Host header if one is NOT ALREADY PRESENT
+normalizeHostHeader :: HTTPRequest ty -> HTTPRequest ty
+normalizeHostHeader rq = 
+  insertHeaderIfMissing HdrHost
+                        (uriToAuthorityString $ rqURI rq)
+			rq
+                                     
+-- Looks for a "Connection" header with the value "close".
+-- Returns True when this is found.
+findConnClose :: [Header] -> Bool
+findConnClose hdrs =
+  maybe False
+        (\ x -> map toLower (trim x) == "close")
+	(lookupHeader HdrConnection hdrs)
+
+
+-- | Used when we know exactly how many bytes to expect.
+linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))
+linearTransfer readBlk n
+    = do info <- readBlk n
+         return $ info `bindE` \str -> Right ([],str)
+
+-- | Used when nothing about data is known,
+--   Unfortunately waiting for a socket closure
+--   causes bad behaviour.  Here we just
+--   take data once and give up the rest.
+hopefulTransfer :: BufferOp a
+                -> IO (Result a)
+		-> [a]
+		-> IO (Result ([Header],a))
+hopefulTransfer bufOps readL strs 
+    = readL >>= 
+      either (\v -> return $ Left v)
+             (\more -> if (buf_isEmpty bufOps more)
+                         then return (Right ([],foldr (flip (buf_append bufOps)) (buf_empty bufOps) strs))
+                         else hopefulTransfer bufOps readL (more:strs))
+
+-- | A necessary feature of HTTP\/1.1
+--   Also the only transfer variety likely to
+--   return any footers.
+chunkedTransfer :: BufferOp a
+		-> IO (Result a)
+                -> (Int -> IO (Result a))
+                -> IO (Result ([Header], a))
+chunkedTransfer bufOps readL readBlk = do
+    v <- chunkedTransferC bufOps readL readBlk 0
+    return $ v `bindE` \(ftrs,count,info) ->
+             let myftrs = Header HdrContentLength (show count) : ftrs              
+             in Right (myftrs,info)
+
+chunkedTransferC :: BufferOp a
+                 -> IO (Result a)
+                 -> (Int -> IO (Result a))
+		 -> Int
+		 -> IO (Result ([Header],Int,a))
+chunkedTransferC bufOps readL readBlk n = do
+  v <- readL
+  case v of
+    Left e -> return (Left e)
+    Right line 
+     | size == 0 -> do
+         rs <- readTillEmpty2 bufOps readL []
+         return $
+           rs `bindE` \strs ->
+           parseHeaders (map (buf_toStr bufOps) strs) `bindE` \ftrs ->
+           Right (ftrs,n,buf_empty bufOps)
+     | otherwise -> do
+         some <- readBlk size
+         readL
+         more <- chunkedTransferC bufOps {-nullVal isNull isLineEnd toStr append -} readL readBlk (n+size)
+         return $ 
+           some `bindE` \cdata ->
+           more `bindE` \(ftrs,m,mdata) -> 
+           Right (ftrs,m,buf_append bufOps cdata mdata) 
+     where
+      size 
+       | buf_isEmpty bufOps line = 0
+       | otherwise = 
+	 case readHex (buf_toStr bufOps line) of
+          (hx,_):_ -> hx
+          _        -> 0
+
+-- | Maybe in the future we will have a sensible thing
+--   to do here, at that time we might want to change
+--   the name.
+uglyDeathTransfer :: IO (Result ([Header],a))
+uglyDeathTransfer 
+    = return $ Left $ ErrorParse "Unknown Transfer-Encoding"
+
+-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)
+readTillEmpty1 :: BufferOp a
+	       -> IO (Result a)
+               -> IO (Result [a])
+readTillEmpty1 bufOps readL =
+  readL >>=
+    either (return . Left)
+           (\ s -> 
+	       if buf_isLineTerm bufOps s
+                then readTillEmpty1 bufOps readL
+                else readTillEmpty2 bufOps readL [s])
+
+-- | Read lines until an empty line (CRLF),
+--   also accepts a connection close as end of
+--   input, which is not an HTTP\/1.1 compliant
+--   thing to do - so probably indicates an
+--   error condition.
+readTillEmpty2 :: BufferOp a
+	       -> IO (Result a)
+	       -> [a]
+	       -> IO (Result [a])
+readTillEmpty2 bufOps readL list =
+    readL >>=
+      either (return . Left)
+             (\ s ->
+	        if buf_isLineTerm bufOps s || buf_isEmpty bufOps s
+                 then return (Right $ reverse (s:list))
+                 else readTillEmpty2 bufOps readL (s:list))
+
+--
+-- Misc
+--
+
+-- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific
+-- tweaks better go here.
+catchIO :: IO a -> (IOException -> IO a) -> IO a
+catchIO a h = Prelude.catch a h
+
+catchIO_ :: IO a -> IO a -> IO a
+catchIO_ a h = Prelude.catch a (const h)
+

@@ -0,0 +1,214 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.HandleStream+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne+-- License     :  BSD+-- +-- Maintainer  :  Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- A HandleStream version of Network.HTTP.Stream's public offerings.+--+-----------------------------------------------------------------------------+module Network.HTTP.HandleStream +       ( simpleHTTP     -- :: HTTPRequest ty -> IO (Result (HTTPResponse ty))+       , simpleHTTP_    -- :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+       , sendHTTP       -- :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTResponse ty))+       , receiveHTTP    -- :: HStream ty => HandleStream ty -> IO (Result (HTTPRequest ty))+       , respondHTTP    -- :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO ()+       +       , simpleHTTP_debug -- :: FilePath -> HTTPRequest DebugString -> IO (HTTPResponse DebugString)+       ) where++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Network.BufferType+import Network.Stream ( ConnError(..), bindE, Result )+import Network.StreamDebugger ( debugByteStream )+import Network.TCP (HStream(..), HandleStream )++import Network.HTTP.Base+import Network.HTTP.Headers+import Network.HTTP.Utils ( trim )++import Data.Char (toLower)+import Data.Maybe (fromMaybe)+import Control.Monad (when)++-----------------------------------------------------------------+------------------ Misc -----------------------------------------+-----------------------------------------------------------------++-- | Simple way to get a resource across a non-persistant connection.+-- Headers that may be altered:+--  Host        Altered only if no Host header is supplied, HTTP\/1.1+--              requires a Host header.+--  Connection  Where no allowance is made for persistant connections+--              the Connection header will be set to "close"+simpleHTTP :: HStream ty => HTTPRequest ty -> IO (Result (HTTPResponse ty))+simpleHTTP r = do +  auth <- getAuth r+  c <- openStream (host auth) (fromMaybe 80 (port auth))+  simpleHTTP_ c r++simpleHTTP_debug :: HStream ty => FilePath -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+simpleHTTP_debug httpLogFile r = do +  auth <- getAuth r+  c0 <- openStream (host auth) (fromMaybe 80 (port auth))+  c <- debugByteStream httpLogFile c0+  simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+simpleHTTP_ s r = do +  auth <- getAuth r+  let r' = normalizeRequestURI auth r +  rsp <- sendHTTP s r'+  return rsp++sendHTTP :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+sendHTTP conn rq = do+  let a_rq = normalizeHostHeader rq+  rsp <- catchIO (sendMain conn a_rq)+                 (\e -> do { close conn; ioError e })+  let fn list = when (or $ map findConnClose list)+                     (close conn)+  either (\_ -> fn [rqHeaders rq])+         (\r -> fn [rqHeaders rq,rspHeaders r])+         rsp+  return rsp++-- From RFC 2616, section 8.2.3:+-- 'Because of the presence of older implementations, the protocol allows+-- ambiguous situations in which a client may send "Expect: 100-+-- continue" without receiving either a 417 (Expectation Failed) status+-- or a 100 (Continue) status. Therefore, when a client sends this+-- header field to an origin server (possibly via a proxy) from which it+-- has never seen a 100 (Continue) status, the client SHOULD NOT wait+-- for an indefinite period before sending the request body.'+--+-- Since we would wait forever, I have disabled use of 100-continue for now.+sendMain :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))+sendMain conn rqst = do+      --let str = if null (rqBody rqst)+      --              then show rqst+      --              else show (insertHeader HdrExpect "100-continue" rqst)+  writeBlock conn (buf_fromStr bufferOps $ show rqst)+    -- write body immediately, don't wait for 100 CONTINUE+  writeBlock conn (rqBody rqst)+  rsp <- getResponseHead conn+  switchResponse conn True False rsp rqst++   -- Hmmm, this could go bad if we keep getting "100 Continue"+   -- responses...  Except this should never happen according+   -- to the RFC.++switchResponse :: HStream ty+               => HandleStream ty+	       -> Bool {- allow retry? -}+               -> Bool {- is body sent? -}+               -> Result ResponseData+               -> HTTPRequest ty+               -> IO (Result (HTTPResponse ty))+switchResponse _ _ _ (Left e) _ = return (Left e)+                -- retry on connreset?+                -- if we attempt to use the same socket then there is an excellent+                -- chance that the socket is not in a completely closed state.++switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = +   case matchResponse (rqMethod rqst) cd of+     Continue+      | not bdy_sent -> do {- Time to send the body -}+        writeBlock conn (rqBody rqst) >>= either (return . Left)+	   (\ _ -> do+              rsp <- getResponseHead conn+              switchResponse conn allow_retry True rsp rqst)+      | otherwise    -> do {- keep waiting -}+        rsp <- getResponseHead conn+        switchResponse conn allow_retry bdy_sent rsp rqst++     Retry -> do {- Request with "Expect" header failed.+                    Trouble is the request contains Expects+                    other than "100-Continue" -}+        writeBlock conn ((buf_append bufferOps)+		                     (buf_fromStr bufferOps (show rqst))+			             (rqBody rqst))+        rsp <- getResponseHead conn+        switchResponse conn False bdy_sent rsp rqst+                     +     Done -> return (Right $ Response cd rn hdrs (buf_empty bufferOps))++     DieHorribly str -> return $ Left $ ErrorParse ("Invalid response: " ++ str)++     ExpectEntity -> do+       rslt <- +        case tc of+          Nothing -> +            case cl of+              Nothing -> hopefulTransfer bo (readLine conn) []+              Just x  -> +	        case reads x of+		  ((v,_):_) ->  linearTransfer (readBlock conn) v+		  _ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x)))+          Just x  -> +            case map toLower (trim x) of+              "chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn)+              _         -> uglyDeathTransfer+       return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)++      where+       tc = lookupHeader HdrTransferEncoding hdrs+       cl = lookupHeader HdrContentLength hdrs+       bo = bufferOps+                    +-- reads and parses headers+getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData)+getResponseHead conn = do+   lor <- readTillEmpty1 bufferOps (readLine conn)+   return $ lor `bindE` \es -> parseResponseHead (map (buf_toStr bufferOps) es)++-- | Receive and parse a HTTP request from the given Stream. Should be used +--   for server side interactions.+receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (HTTPRequest bufTy))+receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest+    where+        -- reads and parses headers+        getRequestHead :: IO (Result RequestData)+        getRequestHead =+            do { lor <- readTillEmpty1 bufferOps (readLine conn)+               ; return $ lor `bindE` \es -> parseRequestHead (map (buf_toStr bufferOps) es)+               }+	+	processRequest (rm,uri,hdrs) = do+           rslt <- +	     case tc of+               Nothing ->+                 case cl of+                   Nothing -> return (Right ([], buf_empty bo)) -- hopefulTransfer ""+                   Just x  -> +		     case reads x of+		       ((v,_):_) -> linearTransfer (readBlock conn) v+		       _ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x)))+               Just x  ->+                 case map toLower (trim x) of+                   "chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn)+                   _         -> uglyDeathTransfer+               +           return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)+	  where+	     -- FIXME : Also handle 100-continue.+            tc = lookupHeader HdrTransferEncoding hdrs+            cl = lookupHeader HdrContentLength hdrs+	    bo = bufferOps++-- | Very simple function, send a HTTP response over the given stream. This +--   could be improved on to use different transfer types.+respondHTTP :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO ()+respondHTTP conn rsp = do +  writeBlock conn (buf_fromStr bufferOps $ show rsp)+   -- write body immediately, don't wait for 100 CONTINUE+  writeBlock conn (rspBody rsp)+  return ()

@@ -47,6 +47,7 @@    ( HasHeaders(..)    , Header(..)    , HeaderName(..)+    , insertHeader    , insertHeaderIfMissing    , insertHeaders@@ -55,31 +56,14 @@    , findHeader    , lookupHeader    , parseHeaders-   , parseHeader-   , headerMap+    ) where -import Data.Char (isSpace, toLower)-import Data.List (elemIndex)+import Data.Char (toLower) import Network.Stream (Result, ConnError(ErrorParse))---- remove leading and trailing whitespace.-trim :: String -> String-trim = let dropspace = dropWhile isSpace in-       reverse . dropspace . reverse . dropspace---- Split a list into two parts, the delimiter occurs--- at the head of the second list.  Nothing is returned--- when no occurance of the delimiter is found.-split :: Eq a => a -> [a] -> Maybe ([a],[a])-split delim list = case delim `elemIndex` list of-    Nothing -> Nothing-    Just x  -> Just $ splitAt x list--crlf :: String-crlf = "\r\n"+import Network.HTTP.Utils ( trim, split, crlf ) --- | The Header data type pairs header names & values.+-- | The @Header@ data type pairs header names & values. data Header = Header HeaderName String  instance Show Header where@@ -95,123 +79,122 @@ --   1) makes customising header names laborious --   2) increases code volume. ---data HeaderName = -                 -- Generic Headers ---                  HdrCacheControl-                | HdrConnection-                | HdrDate-                | HdrPragma-                | HdrTransferEncoding        -                | HdrUpgrade                -                | HdrVia--                -- Request Headers ---                | HdrAccept-                | HdrAcceptCharset-                | HdrAcceptEncoding-                | HdrAcceptLanguage-                | HdrAuthorization-                | HdrCookie-                | HdrExpect-                | HdrFrom-                | HdrHost-                | HdrIfModifiedSince-                | HdrIfMatch-                | HdrIfNoneMatch-                | HdrIfRange-                | HdrIfUnmodifiedSince-                | HdrMaxForwards-                | HdrProxyAuthorization-                | HdrRange-                | HdrReferer-                | HdrUserAgent--                -- Response Headers-                | HdrAge-                | HdrLocation-                | HdrProxyAuthenticate-                | HdrPublic-                | HdrRetryAfter-                | HdrServer-                | HdrSetCookie-                | HdrVary-                | HdrWarning-                | HdrWWWAuthenticate--                -- Entity Headers-                | HdrAllow-                | HdrContentBase-                | HdrContentEncoding-                | HdrContentLanguage-                | HdrContentLength-                | HdrContentLocation-                | HdrContentMD5-                | HdrContentRange-                | HdrContentType-                | HdrETag-                | HdrExpires-                | HdrLastModified--                -- Mime entity headers (for sub-parts)-                | HdrContentTransferEncoding--                -- | Allows for unrecognised or experimental headers.-                | HdrCustom String -- not in header map below.+-- Long discussions can be had on this topic!+-- +data HeaderName +    -- Generic Headers --+ = HdrCacheControl+ | HdrConnection+ | HdrDate+ | HdrPragma+ | HdrTransferEncoding        + | HdrUpgrade                + | HdrVia+    -- Request Headers --+ | HdrAccept+ | HdrAcceptCharset+ | HdrAcceptEncoding+ | HdrAcceptLanguage+ | HdrAuthorization+ | HdrCookie+ | HdrExpect+ | HdrFrom+ | HdrHost+ | HdrIfModifiedSince+ | HdrIfMatch+ | HdrIfNoneMatch+ | HdrIfRange+ | HdrIfUnmodifiedSince+ | HdrMaxForwards+ | HdrProxyAuthorization+ | HdrRange+ | HdrReferer+ | HdrUserAgent+    -- Response Headers+ | HdrAge+ | HdrLocation+ | HdrProxyAuthenticate+ | HdrPublic+ | HdrRetryAfter+ | HdrServer+ | HdrSetCookie+ | HdrVary+ | HdrWarning+ | HdrWWWAuthenticate+    -- Entity Headers+ | HdrAllow+ | HdrContentBase+ | HdrContentEncoding+ | HdrContentLanguage+ | HdrContentLength+ | HdrContentLocation+ | HdrContentMD5+ | HdrContentRange+ | HdrContentType+ | HdrETag+ | HdrExpires+ | HdrLastModified+    -- | MIME entity headers (for sub-parts)+ | HdrContentTransferEncoding+    -- | Allows for unrecognised or experimental headers.+ | HdrCustom String -- not in header map below.     deriving(Eq)  -- Translation between header names and values, -- good candidate for improvement. headerMap :: [ (String,HeaderName) ]-headerMap - = [  ("Cache-Control"        ,HdrCacheControl      )-	, ("Connection"           ,HdrConnection        )-	, ("Date"                 ,HdrDate              )    -	, ("Pragma"               ,HdrPragma            )-	, ("Transfer-Encoding"    ,HdrTransferEncoding  )        -	, ("Upgrade"              ,HdrUpgrade           )                -	, ("Via"                  ,HdrVia               )-	, ("Accept"               ,HdrAccept            )-	, ("Accept-Charset"       ,HdrAcceptCharset     )-	, ("Accept-Encoding"      ,HdrAcceptEncoding    )-	, ("Accept-Language"      ,HdrAcceptLanguage    )-	, ("Authorization"        ,HdrAuthorization     )-	, ("From"                 ,HdrFrom              )-	, ("Host"                 ,HdrHost              )-	, ("If-Modified-Since"    ,HdrIfModifiedSince   )-	, ("If-Match"             ,HdrIfMatch           )-	, ("If-None-Match"        ,HdrIfNoneMatch       )-	, ("If-Range"             ,HdrIfRange           ) -	, ("If-Unmodified-Since"  ,HdrIfUnmodifiedSince )-	, ("Max-Forwards"         ,HdrMaxForwards       )-	, ("Proxy-Authorization"  ,HdrProxyAuthorization)-	, ("Range"                ,HdrRange             )   -	, ("Referer"              ,HdrReferer           )-	, ("User-Agent"           ,HdrUserAgent         )-	, ("Age"                  ,HdrAge               )-	, ("Location"             ,HdrLocation          )-	, ("Proxy-Authenticate"   ,HdrProxyAuthenticate )-	, ("Public"               ,HdrPublic            )-	, ("Retry-After"          ,HdrRetryAfter        )-	, ("Server"               ,HdrServer            )-	, ("Vary"                 ,HdrVary              )-	, ("Warning"              ,HdrWarning           )-	, ("WWW-Authenticate"     ,HdrWWWAuthenticate   )-	, ("Allow"                ,HdrAllow             )-	, ("Content-Base"         ,HdrContentBase       )-	, ("Content-Encoding"     ,HdrContentEncoding   )-	, ("Content-Language"     ,HdrContentLanguage   )-	, ("Content-Length"       ,HdrContentLength     )-	, ("Content-Location"     ,HdrContentLocation   )-	, ("Content-MD5"          ,HdrContentMD5        )-	, ("Content-Range"        ,HdrContentRange      )-	, ("Content-Type"         ,HdrContentType       )-	, ("ETag"                 ,HdrETag              )-	, ("Expires"              ,HdrExpires           )-	, ("Last-Modified"        ,HdrLastModified      )-   	, ("Set-Cookie"           ,HdrSetCookie         )-	, ("Cookie"               ,HdrCookie            )-    , ("Expect"               ,HdrExpect            ) ]-+headerMap =+   [ p "Cache-Control"        HdrCacheControl+   , p "Connection"           HdrConnection+   , p "Date"                 HdrDate+   , p "Pragma"               HdrPragma+   , p "Transfer-Encoding"    HdrTransferEncoding+   , p "Upgrade"              HdrUpgrade+   , p "Via"                  HdrVia+   , p "Accept"               HdrAccept+   , p "Accept-Charset"       HdrAcceptCharset+   , p "Accept-Encoding"      HdrAcceptEncoding+   , p "Accept-Language"      HdrAcceptLanguage+   , p "Authorization"        HdrAuthorization+   , p "From"                 HdrFrom+   , p "Host"                 HdrHost+   , p "If-Modified-Since"    HdrIfModifiedSince+   , p "If-Match"             HdrIfMatch+   , p "If-None-Match"        HdrIfNoneMatch+   , p "If-Range"             HdrIfRange+   , p "If-Unmodified-Since"  HdrIfUnmodifiedSince+   , p "Max-Forwards"         HdrMaxForwards+   , p "Proxy-Authorization"  HdrProxyAuthorization+   , p "Range"                HdrRange+   , p "Referer"              HdrReferer+   , p "User-Agent"           HdrUserAgent+   , p "Age"                  HdrAge+   , p "Location"             HdrLocation+   , p "Proxy-Authenticate"   HdrProxyAuthenticate+   , p "Public"               HdrPublic+   , p "Retry-After"          HdrRetryAfter+   , p "Server"               HdrServer+   , p "Vary"                 HdrVary+   , p "Warning"              HdrWarning+   , p "WWW-Authenticate"     HdrWWWAuthenticate+   , p "Allow"                HdrAllow+   , p "Content-Base"         HdrContentBase+   , p "Content-Encoding"     HdrContentEncoding+   , p "Content-Language"     HdrContentLanguage+   , p "Content-Length"       HdrContentLength+   , p "Content-Location"     HdrContentLocation+   , p "Content-MD5"          HdrContentMD5+   , p "Content-Range"        HdrContentRange+   , p "Content-Type"         HdrContentType+   , p "ETag"                 HdrETag+   , p "Expires"              HdrExpires+   , p "Last-Modified"        HdrLastModified+   , p "Set-Cookie"           HdrSetCookie+   , p "Cookie"               HdrCookie+   , p "Expect"               HdrExpect+   ]+ where+  p a b = (a,b)  instance Show HeaderName where     show (HdrCustom s) = s@@ -229,7 +212,6 @@ insertHeader, replaceHeader, insertHeaderIfMissing     :: HasHeaders a => HeaderName -> String -> a -> a - -- | Inserts a header with the given name and value. -- Allows duplicate header names. insertHeader name value x = setHeaders x newHeaders@@ -246,9 +228,9 @@         newHeaders [] = [Header name value]  -- | Removes old headers with duplicate name.-replaceHeader name value x = setHeaders x newHeaders+replaceHeader name value h = setHeaders h newHeaders     where-        newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]+        newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ]            -- | Inserts multiple headers. insertHeaders :: HasHeaders a => [Header] -> a -> a

@@ -21,7 +21,6 @@    , Octet    ) where -import Data.Char (chr) import Data.List (unfoldr) import Data.Word (Word8) import Numeric (readHex)@@ -36,8 +35,9 @@  hash :: [Octet] -> [Octet] hash xs = -   unfoldr f $ md5s $ Str $ map (chr . fromIntegral) xs+   unfoldr f $ md5s $ Str $ map (toEnum . fromIntegral) xs       where f :: String -> Maybe (Octet,String)             f []       = Nothing-            f (x:y:zs) = Just (fromIntegral a,zs)+	    f [x]      = f ['0',x]+            f (x:y:zs) = Just (a,zs)                          where [(a,_)] = readHex (x:y:[])

@@ -4,11 +4,12 @@     Zord64, Str(..), BoolList(..), WordList(..)) where  import Data.Char (ord, chr)-import Data.Bits (Bits, rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement)+import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) import Data.Word (Word32, Word64) -rotL :: Bits a => a -> Int -> a+rotL :: Word32 -> Int -> Word32 rotL x = rotateL x+ type Zord64 = Word64  -- ===================== TYPES AND CLASS DEFINTIONS ========================@@ -19,7 +20,7 @@ newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) newtype Str = Str String newtype BoolList = BoolList [Bool]-newtype WordList = WordList ([Word32], Zord64)+newtype WordList = WordList ([Word32], Word64)  -- Anything we want to work out the MD5 of must be an instance of class MD5 @@ -28,7 +29,7 @@  --                     \      \   \------ the rest of the input  --                      \      \--------- the number of bits returned  --                       \--------------- the bits returned in 32bit words- len_pad :: Zord64 -> a -> a         -- append the padding and length+ len_pad :: Word64 -> a -> a         -- append the padding and length  finished :: a -> Bool               -- Have we run out of input yet?  @@ -87,10 +88,13 @@  finished (WordList (_, z)) = z == 0  -add :: ABCD -> ABCD -> ABCD-ABCD (a1, b1, c1, d1) `add` ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2)-+instance Num ABCD where+ ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + (*)         = error "(*){ABCD}: no instance method defined"+ signum      = error "signum{ABCD}: no instance method defined"+ fromInteger = error "fromInteger{ABCD}: no instance method defined"+ abs         = error "abs{ABCD}: no instance method defined" -- ===================== EXPORTED FUNCTIONS ========================  @@ -122,14 +126,14 @@  md5_main :: (MD5 a) =>             Bool   -- Have we added padding yet?-         -> Zord64 -- The length so far mod 2^64+         -> Word64 -- The length so far mod 2^64          -> ABCD   -- The initial state          -> a      -- The non-processed portion of the message          -> ABCD   -- The resulting state md5_main padded ilen abcd m  = if finished m && padded    then abcd-   else md5_main padded' (ilen + 512) (abcd `add` abcd') m''+   else md5_main padded' (ilen + 512) (abcd + abcd') m''  where (m16, l, m') = get_next m        len' = ilen + fromIntegral l        ((m16', _, m''), padded') = if not padded && l < 512@@ -331,7 +335,7 @@ -- Convert the size into a list of characters used by the len_pad function -- for strings -length_to_chars :: Int -> Zord64 -> String+length_to_chars :: Int -> Word64 -> String length_to_chars 0 _ = [] length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8)          where this = chr $ fromIntegral $ n .&. 255

@@ -0,0 +1,307 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop+-- License     :  BSD+-- +-- Maintainer  :  bjorn@bringert.net+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- An easy HTTP interface enjoy.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Made dependencies explicit in import statements.+--      - Removed false dependencies in import statements.+--      - Added missing type signatures.+--      - Moved Header-related code to Network.HTTP.Headers module.+--+-- * Changes by Simon Foster:+--      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+--      - Created functions receiveHTTP and responseHTTP to allow server side interactions+--        (although 100-continue is unsupported and I haven't checked for standard compliancy).+--      - Pulled the transfer functions from sendHTTP to global scope to allow access by+--        above functions.+--+-- * Changes by Graham Klyne:+--      - export httpVersion+--      - use new URI module (similar to old, but uses revised URI datatype)+--+-- * Changes by Bjorn Bringert:+--+--      - handle URIs with a port number+--      - added debugging toggle+--      - disabled 100-continue transfers to get HTTP\/1.0 compatibility+--      - change 'ioError' to 'throw'+--      - Added simpleHTTP_, which takes a stream argument.+--+-- * Changes from 0.1+--      - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class.+--      - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses.+--      - reworking of the use of Stream, including alterations to make 'sendHTTP' generic+--        and the addition of a debugging stream.+--      - simplified error handling.+-- +-- * TODO+--     - request pipelining+--     - https upgrade (includes full TLS, i.e. SSL, implementation)+--         - use of Stream classes will pay off+--         - consider C implementation of encryption\/decryption+--     - comm timeouts+--     - MIME & entity stuff (happening in separate module)+--     - support \"*\" uri-request-string for OPTIONS request method+-- +-- +-- * Header notes:+--+--     [@Host@]+--                  Required by HTTP\/1.1, if not supplied as part+--                  of a request a default Host value is extracted+--                  from the request-uri.+-- +--     [@Connection@] +--                  If this header is present in any request or+--                  response, and it's value is "close", then+--                  the current request\/response is the last +--                  to be allowed on that connection.+-- +--     [@Expect@]+--                  Should a request contain a body, an Expect+--                  header will be added to the request.  The added+--                  header has the value \"100-continue\".  After+--                  a 417 \"Expectation Failed\" response the request+--                  is attempted again without this added Expect+--                  header.+--                  +--     [@TransferEncoding,ContentLength,...@]+--                  if request is inconsistent with any of these+--                  header values then you may not receive any response+--                  or will generate an error response (probably 4xx).+--+--+-- * Response code notes+-- Some response codes induce special behaviour:+--+--   [@1xx@]   \"100 Continue\" will cause any unsent request body to be sent.+--             \"101 Upgrade\" will be returned.+--             Other 1xx responses are ignored.+-- +--   [@417@]   The reason for this code is \"Expectation failed\", indicating+--             that the server did not like the Expect \"100-continue\" header+--             added to a request.  Receipt of 417 will induce another+--             request attempt (without Expect header), unless no Expect header+--             had been added (in which case 417 response is returned).+--+-----------------------------------------------------------------------------+module Network.HTTP.Stream +       ( module Network.Stream++       , simpleHTTP     -- :: Request -> IO (Result Response)+       , simpleHTTP_    -- :: Stream s => s -> Request -> IO (Result Response)+       , sendHTTP       -- :: Stream s => s -> Request -> IO (Result Response)+       , receiveHTTP    -- :: Stream s => s -> IO (Result Request)+       , respondHTTP    -- :: Stream s => s -> Response -> IO ()+       +       ) where++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Network.Stream+import Network.StreamDebugger (debugStream)+import Network.TCP (openTCPPort)+import Network.BufferType ( stringBufferOp )++import Network.HTTP.Base+import Network.HTTP.Headers+import Network.HTTP.Utils ( trim )++import Data.Char     (toLower)+import Data.Maybe    (fromMaybe)+import Control.Monad (when)+++-- Turn on to enable HTTP traffic logging+debug :: Bool+debug = False++-- File that HTTP traffic logs go to+httpLogFile :: String+httpLogFile = "http-debug.log"++-----------------------------------------------------------------+------------------ Misc -----------------------------------------+-----------------------------------------------------------------+++-- | Simple way to get a resource across a non-persistant connection.+-- Headers that may be altered:+--  Host        Altered only if no Host header is supplied, HTTP\/1.1+--              requires a Host header.+--  Connection  Where no allowance is made for persistant connections+--              the Connection header will be set to "close"+simpleHTTP :: Request -> IO (Result Response)+simpleHTTP r = +    do +       auth <- getAuth r+       c <- openTCPPort (host auth) (fromMaybe 80 (port auth))+       simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)+simpleHTTP_ s r =+    do +       auth <- getAuth r+       let r' = normalizeRequestURI auth r +       rsp <- if debug then do+	        s' <- debugStream httpLogFile s+	        sendHTTP s' r'+	       else+	        sendHTTP s r'+       -- already done by sendHTTP because of "Connection: close" header+       --; close s +       return rsp++sendHTTP :: Stream s => s -> Request -> IO (Result Response)+sendHTTP conn rq = +    do { let a_rq = normalizeHostHeader rq+       ; rsp <- catchIO (main a_rq)+                        (\e -> do { close conn; ioError e })+       ; let fn list = when (or $ map findConnClose list)+                            (close conn)+       ; either (\_ -> fn [rqHeaders rq])+                (\r -> fn [rqHeaders rq,rspHeaders r])+                rsp+       ; return rsp+       }+    where       +-- From RFC 2616, section 8.2.3:+-- 'Because of the presence of older implementations, the protocol allows+-- ambiguous situations in which a client may send "Expect: 100-+-- continue" without receiving either a 417 (Expectation Failed) status+-- or a 100 (Continue) status. Therefore, when a client sends this+-- header field to an origin server (possibly via a proxy) from which it+-- has never seen a 100 (Continue) status, the client SHOULD NOT wait+-- for an indefinite period before sending the request body.'+--+-- Since we would wait forever, I have disabled use of 100-continue for now.+        main :: Request -> IO (Result Response)+        main rqst =+            do +	       --let str = if null (rqBody rqst)+               --              then show rqst+               --              else show (insertHeader HdrExpect "100-continue" rqst)+               writeBlock conn (show rqst)+	       -- write body immediately, don't wait for 100 CONTINUE+	       writeBlock conn (rqBody rqst)+               rsp <- getResponseHead               +               switchResponse True False rsp rqst+        +        -- reads and parses headers+        getResponseHead :: IO (Result ResponseData)+        getResponseHead =+            do { lor <- readTillEmpty1 stringBufferOp (readLine conn)+               ; return $ lor `bindE` parseResponseHead+               }++        -- Hmmm, this could go bad if we keep getting "100 Continue"+        -- responses...  Except this should never happen according+        -- to the RFC.+        switchResponse :: Bool {- allow retry? -}+                       -> Bool {- is body sent? -}+                       -> Result ResponseData+                       -> Request+                       -> IO (Result Response)+            +        switchResponse _ _ (Left e) _ = return (Left e)+                -- retry on connreset?+                -- if we attempt to use the same socket then there is an excellent+                -- chance that the socket is not in a completely closed state.++        switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =+            case matchResponse (rqMethod rqst) cd of+                Continue+                    | not bdy_sent -> {- Time to send the body -}+                        do { val <- writeBlock conn (rqBody rqst)+                           ; case val of+                                Left e -> return (Left e)+                                Right _ ->+                                    do { rsp <- getResponseHead+                                       ; switchResponse allow_retry True rsp rqst+                                       }+                           }+                    | otherwise -> {- keep waiting -}+                        do { rsp <- getResponseHead+                           ; switchResponse allow_retry bdy_sent rsp rqst                           +                           }++                Retry -> {- Request with "Expect" header failed.+                                Trouble is the request contains Expects+                                other than "100-Continue" -}+                    do { writeBlock conn (show rqst ++ rqBody rqst)+                       ; rsp <- getResponseHead+                       ; switchResponse False bdy_sent rsp rqst+                       }   +                     +                Done ->+                    return (Right $ Response cd rn hdrs "")++                DieHorribly str ->+                    return $ Left $ ErrorParse ("Invalid response: " ++ str)++                ExpectEntity ->+                    let tc = lookupHeader HdrTransferEncoding hdrs+                        cl = lookupHeader HdrContentLength hdrs+                    in+                    do { rslt <- case tc of+                          Nothing -> +                              case cl of+                                  Just x  -> linearTransfer (readBlock conn) (read x :: Int)+                                  Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) []+                          Just x  -> +                              case map toLower (trim x) of+                                  "chunked" -> chunkedTransfer stringBufferOp+				                               (readLine conn) (readBlock conn)+                                  _         -> uglyDeathTransfer+                       ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) +                       }++-- | Receive and parse a HTTP request from the given Stream. Should be used +--   for server side interactions.+receiveHTTP :: Stream s => s -> IO (Result Request)+receiveHTTP conn = getRequestHead >>= processRequest+    where+        -- reads and parses headers+        getRequestHead :: IO (Result RequestData)+        getRequestHead =+            do { lor <- readTillEmpty1 stringBufferOp (readLine conn)+               ; return $ lor `bindE` parseRequestHead+               }+	+        processRequest (Left e) = return $ Left e+	processRequest (Right (rm,uri,hdrs)) = +	    do -- FIXME : Also handle 100-continue.+               let tc = lookupHeader HdrTransferEncoding hdrs+                   cl = lookupHeader HdrContentLength hdrs+	       rslt <- case tc of+                          Nothing ->+                              case cl of+                                  Just x  -> linearTransfer (readBlock conn) (read x :: Int)+                                  Nothing -> return (Right ([], "")) -- hopefulTransfer ""+                          Just x  ->+                              case map toLower (trim x) of+                                  "chunked" -> chunkedTransfer stringBufferOp+				                               (readLine conn) (readBlock conn)+                                  _         -> uglyDeathTransfer+               +               return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)+++-- | Very simple function, send a HTTP response over the given stream. This +--   could be improved on to use different transfer types.+respondHTTP :: Stream s => s -> Response -> IO ()+respondHTTP conn rsp = do writeBlock conn (show rsp)+                          -- write body immediately, don't wait for 100 CONTINUE+                          writeBlock conn (rspBody rsp)+			  return ()

@@ -0,0 +1,67 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Network.HTTP.Utils
+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop, 2008 Sigbjorn Finne
+-- License     :  BSD
+--
+-- Maintainer  :  Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable (not tested)
+--
+-- Set of utility functions and definitions used by package modules.
+--
+module Network.HTTP.Utils
+       ( trim    -- :: String -> String
+       , trimL   -- :: String -> String
+       , trimR   -- :: String -> String
+       
+       , crlf    -- :: String
+
+       , split   -- :: Eq a => a -> [a] -> Maybe ([a],[a])
+       , splitBy -- :: Eq a => a -> [a] -> [[a]]
+       
+       ) where
+       
+import Data.Char
+import Data.List ( elemIndex )
+import Data.Maybe ( fromMaybe )
+
+-- | @crlf@ is our beloved two-char line terminator.
+crlf :: String
+crlf = "\r\n"
+
+-- | @split delim ls@ splits a list into two parts, the @delim@ occurring
+-- at the head of the second list.  If @delim@ isn't in @ls@, @Nothing@ is
+-- returned.
+split :: Eq a => a -> [a] -> Maybe ([a],[a])
+split delim list = case delim `elemIndex` list of
+    Nothing -> Nothing
+    Just x  -> Just $ splitAt x list
+
+-- | @trim str@ removes leading and trailing whitespace from @str@.
+trim :: String -> String
+trim xs = trimR (trimL xs)
+   
+-- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace')
+-- from @str@.
+trimL :: String -> String
+trimL xs = dropWhile isSpace xs
+
+-- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace')
+-- from @str@.
+trimR :: String -> String
+trimR str = fromMaybe "" $ foldr trimIt Nothing str
+ where
+  trimIt x (Just xs) = Just (x:xs)
+  trimIt x Nothing   
+   | isSpace x = Nothing
+   | otherwise = Just [x]
+
+-- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@.
+splitBy :: Eq a => a -> [a] -> [[a]]
+splitBy _ [] = []
+splitBy c xs = 
+    case break (==c) xs of
+      (_,[]) -> [xs]
+      (as,_:bs) -> as : splitBy c bs
+

@@ -27,11 +27,12 @@    , bindE    ) where -data ConnError = ErrorReset -               | ErrorClosed-               | ErrorParse String-               | ErrorMisc String-    deriving(Show,Eq)+data ConnError + = ErrorReset + | ErrorClosed+ | ErrorParse String+ | ErrorMisc String+   deriving(Show,Eq)  bindE :: Result a -> (a -> Result b) -> Result b bindE (Left e)  _ = Left e@@ -55,4 +56,3 @@     readBlock  :: x -> Int -> IO (Result String)     writeBlock :: x -> String -> IO (Result ())     close      :: x -> IO ()-

@@ -18,12 +18,14 @@ module Network.StreamDebugger    ( StreamDebugger    , debugStream+   , debugByteStream    ) where  import Network.Stream (Stream(..)) import System.IO    ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile    )+import Network.TCP ( HandleStream, StreamHooks(..), HStream, setStreamHooks )  -- | Allows stream logging.  Refer to 'debugStream' below. data StreamDebugger x@@ -57,3 +59,26 @@        hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")        return (Dbg h stream) +debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty)+debugByteStream file stream = +    do h <- openFile file AppendMode+       hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")+       setStreamHooks stream (debugStreamHooks h)+       return stream++debugStreamHooks :: HStream ty => Handle -> StreamHooks ty+debugStreamHooks h = +  StreamHooks+    { hook_readBlock = \ toStr n val -> do+       let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}+       hPutStrLn h ("readBlock " ++ show n ++ ' ' : show eval)+    , hook_readLine = \ toStr val -> do+	   let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}+           hPutStrLn h ("readLine " ++ show eval)+    , hook_writeBlock = \ toStr str val -> do+           hPutStrLn h ("writeBlock " ++ show val ++ ' ' : toStr str)+    , hook_close = do+           hPutStrLn h "closing..."+           hFlush h+           hClose h+    }

@@ -32,53 +32,58 @@    , ShutdownCmd(ShutdownBoth), SocketOption(SoError)    ) +import Network.HTTP.Base ( catchIO ) import Control.Monad (liftM)-import Control.Exception as Exception (Exception, catch, throw)+import Control.Exception as Exception (IOException) import System.IO.Error (catch, isEOFError)  -- | Exception handler for socket operations.-handleSocketError :: Socket -> Exception -> IO (Result a)+handleSocketError :: Socket -> IOException -> IO (Result a) handleSocketError sk e =     do se <- getSocketOption sk SoError        case se of-          0     -> throw e+          0     -> ioError e           10054 -> return $ Left ErrorReset  -- reset           _     -> return $ Left $ ErrorMisc $ show se -instance Stream Socket where-    readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)-        where-            fn x = do { str <- myrecv sk x-                      ; let len = length str-                      ; if len < x-                          then ( fn (x-len) >>= \more -> return (str++more) )                        -                          else return str-                      }--    -- Use of the following function is discouraged.-    -- The function reads in one character at a time, -    -- which causes many calls to the kernel recv()-    -- hence causes many context switches.-    readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)-            where-                fn str =-                    do { c <- myrecv sk 1 -- like eating through a straw.-                       ; if null c || c == "\n"-                           then return (reverse str++c)-                           else fn (head c:str)-                       }-    -    writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)-        where-            fn [] = return ()-            fn x  = send sk x >>= \i -> fn (drop i x)--    -- This slams closed the connection (which is considered rude for TCP\/IP)-    close sk = shutdown sk ShutdownBoth >> sClose sk- myrecv :: Socket -> Int -> IO String-myrecv _ 0 = return "" myrecv sock len =     let handler e = if isEOFError e then return [] else ioError e         in System.IO.Error.catch (recv sock len) handler++instance Stream Socket where+    readBlock sk n    = readBlockSocket sk n+    readLine sk       = readLineSocket sk+    writeBlock sk str = writeBlockSocket sk str+    close sk          = shutdown sk ShutdownBoth >> sClose sk+      -- This slams closed the connection (which is considered rude for TCP\/IP)++readBlockSocket :: Socket -> Int -> IO (Result String)+readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk)+  where+   fn x = do { str <- myrecv sk x+             ; let len = length str+             ; if len < x+                then ( fn (x-len) >>= \more -> return (str++more) )+                else return str+             }++-- Use of the following function is discouraged.+-- The function reads in one character at a time, +-- which causes many calls to the kernel recv()+-- hence causes many context switches.+readLineSocket :: Socket -> IO (Result String)+readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk)+  where+   fn str = do+     c <- myrecv sk 1 -- like eating through a straw.+     if null c || c == "\n"+      then return (reverse str++c)+      else fn (head c:str)+    +writeBlockSocket :: Socket -> String -> IO (Result ())+writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk)+  where+   fn [] = return ()+   fn x  = send sk x >>= \i -> fn (drop i x) 

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  Network.TCP@@ -17,176 +18,319 @@ --      - Removed unused exported functions. -- -- * Changes by Simon Foster:---      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+--      - Split module up into to separate Network.[Stream,TCP,HTTP] modules --       ----------------------------------------------------------------------------- module Network.TCP    ( Connection    , openTCPPort    , isConnectedTo++   , openTCPConnection+   , isTCPConnectedTo+   +   , HandleStream+   , HStream(..)+   +   , StreamHooks(..)+   , nullHooks+   , setStreamHooks    ) where  import Network.BSD (getHostByName, hostAddresses) import Network.Socket-   ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive, SoError)-   , SocketType(Stream), inet_addr, connect, sendTo+   ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive)+   , SocketType(Stream), inet_addr, connect    , shutdown, ShutdownCmd(ShutdownSend, ShutdownReceive)-   , sClose, sIsConnected, setSocketOption, getSocketOption+   , sClose, sIsConnected, setSocketOption    , socket, Family(AF_INET)    )+import qualified Network.Stream as Stream+   ( Stream(readBlock, readLine, writeBlock, close) ) import Network.Stream-   ( Stream(readBlock, readLine, writeBlock, close)-   , ConnError(ErrorMisc, ErrorReset, ErrorClosed)-   , bindE+   ( ConnError(..)+   , Result    )-import Network.StreamSocket (myrecv, handleSocketError)+import Network.BufferType -import Control.Exception as Exception (catch, catchJust, finally, ioErrors, throw)-import Data.List (elemIndex)-import Data.Char (toLower)-import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Network.HTTP.Base ( catchIO )+import Network.Socket ( socketToHandle ) +import Data.Char  ( toLower )+import Data.Maybe ( fromMaybe )+import Data.Word  ( Word8 )+import Control.Concurrent+import Control.Monad ( liftM )+import System.IO ( Handle, hFlush, IOMode(..), hClose )+import System.IO.Error ( isEOFError )++import qualified Data.ByteString      as Strict+import qualified Data.ByteString.Lazy as Lazy+ ----------------------------------------------------------------- ------------------ TCP Connections ------------------------------ -----------------------------------------------------------------  -- | The 'Connection' newtype is a wrapper that allows us to make--- connections an instance of the StreamIn\/Out classes, without ghc extensions.+-- connections an instance of the Stream class, without ghc extensions. -- While this looks sort of like a generic reference to the transport -- layer it is actually TCP specific, which can be seen in the -- implementation of the 'Stream Connection' instance.-newtype Connection = ConnRef {getRef :: IORef Conn}+newtype Connection = Connection (HandleStream String) -data Conn = MkConn { connSock :: ! Socket-                   , connAddr :: ! SockAddr -                   , connBffr :: ! String -                   , connHost :: String-                   }-          | ConnClosed-    deriving(Eq)+newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} +data Conn a + = MkConn { connSock     :: ! Socket+	  , connHandle   :: Handle+          , connBuffer   :: BufferOp a+	  , connInput    :: Maybe a+          , connHost     :: String+	  , connHooks    :: Maybe (StreamHooks a)+          }+ | ConnClosed+   deriving(Eq)++connHooks' :: Conn a -> Maybe (StreamHooks a)+connHooks' ConnClosed{} = Nothing+connHooks' x = connHooks x++-- all of these are post-op hooks+data StreamHooks ty+ = StreamHooks+     { hook_readLine   :: (ty -> String) -> Result ty -> IO ()+     , hook_readBlock  :: (ty -> String) -> Int -> Result ty -> IO ()+     , hook_writeBlock :: (ty -> String) -> ty  -> Result () -> IO ()+     , hook_close      :: IO ()+     }++instance Eq ty => Eq (StreamHooks ty) where+  (==) _ _ = True++nullHooks :: StreamHooks ty+nullHooks = StreamHooks +     { hook_readLine  = \ _ _ -> return ()+     , hook_readBlock = \ _ _ _ -> return ()+     , hook_writeBlock = \ _ _ _ -> return ()+     , hook_close = return ()+     }++setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO ()+setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh})++class BufferType bufType => HStream bufType where+  openStream :: String -> Int -> IO (HandleStream bufType)+  readLine   :: HandleStream bufType -> IO (Result bufType)+  readBlock  :: HandleStream bufType -> Int -> IO (Result bufType)+  writeBlock :: HandleStream bufType -> bufType -> IO (Result ())+  close      :: HandleStream bufType -> IO ()+  +instance HStream Strict.ByteString where+  openStream       = openTCPConnection+  readBlock c n    = readBlockBS c n+  readLine c       = readLineBS c+  writeBlock c str = writeBlockBS c str+  close c          = closeIt c Strict.null++instance HStream Lazy.ByteString where+    openStream       = \ a b -> openTCPConnection_ a b True+    readBlock c n    = readBlockBS c n+    readLine c       = readLineBS c+    writeBlock c str = writeBlockBS c str+    close c          = closeIt c Lazy.null++instance Stream.Stream Connection where+  readBlock (Connection c)  = Network.TCP.readBlock c+  readLine (Connection c)   = Network.TCP.readLine c+  writeBlock (Connection c) = Network.TCP.writeBlock c +  close (Connection c)      = Network.TCP.close c+  +instance HStream String where+    openStream      = openTCPConnection+    readBlock ref n = readBlockBS ref n++    -- This function uses a buffer, at this time the buffer is just 1000 characters.+    -- (however many bytes this is is left to the user to decypher)+    readLine ref = readLineBS ref+    -- The 'Connection' object allows no outward buffering, +    -- since in general messages are serialised in their entirety.+    writeBlock ref str = writeBlockBS ref str -- (stringToBuf str)++    -- Closes a Connection.  Connection will no longer+    -- allow any of the other Stream functions.  Notice that a Connection may close+    -- at any time before a call to this function.  This function is idempotent.+    -- (I think the behaviour here is TCP specific)+    close c = closeIt c null+     -- | This function establishes a connection to a remote -- host, it uses "getHostByName" which interrogates the -- DNS system, hence may trigger a network connection. ----- Add a "persistant" option?  Current persistant is default.--- Use "Result" type for synchronous exception reporting? openTCPPort :: String -> Int -> IO Connection-openTCPPort uri port = +openTCPPort uri port = openTCPConnection uri port >>= return.Connection++-- Add a "persistent" option?  Current persistent is default.+-- Use "Result" type for synchronous exception reporting?+openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty)+openTCPConnection uri port = openTCPConnection_ uri port False+openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty)+openTCPConnection_ uri port stashInput =      do { s <- socket AF_INET Stream 6        ; setSocketOption s KeepAlive 1-       ; host <- Exception.catch (inet_addr uri)    -- handles ascii IP numbers-                       (\_ -> getHostByName uri >>= \host ->+       ; host <- catchIO (inet_addr uri)    -- handles ascii IP numbers+                       (\ _ -> getHostByName uri >>= \host ->                             case hostAddresses host of                                 [] -> return (error "no addresses in host entry")                                 (h:_) -> return h)        ; let a = SockAddrInet (toEnum port) host-       ; Exception.catch (connect s a) (\e -> sClose s >> throw e)-       ; v <- newIORef (MkConn s a [] uri)-       ; return (ConnRef v)+       ; catchIO (connect s a) (\e -> sClose s >> ioError e)+       ; h <- socketToHandle s ReadWriteMode+       ; mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing }+       ; let conn = +                 (MkConn { connSock   = s+			 , connHandle = h+			 , connBuffer = bufferOps+			 , connInput  = mb+			 , connHost   = uri+			 , connHooks  = Nothing+			 })+       ; v <- newMVar conn+       ; return (HandleStream v)        } -instance Stream Connection where-    readBlock ref n = -        readIORef (getRef ref) >>= \conn -> case conn of-            ConnClosed -> return (Left ErrorClosed)-            (MkConn sk addr bfr hst)-                | length bfr >= n ->-                    do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) })-                       ; return (Right $ take n bfr)-                       }-                | otherwise ->-                    do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })-                       ; more <- readBlock sk (n - length bfr)-                       ; return $ case more of-                            Left _ -> more-                            Right s -> (Right $ bfr ++ s)-                       }+closeConnection :: HandleStream a -> IO Bool -> IO ()+closeConnection ref readL = do+    -- won't hold onto the lock for the duration+    -- we are draining it...ToDo: have Connection+    -- into a shutting-down state so that other+    -- threads will simply back off if/when attempting+    -- to also close it.+  c <- readMVar (getRef ref)+  closeConn c `catchIO` (\_ -> return ())+  modifyMVar_ (getRef ref) (\ _ -> return ConnClosed)+ where+   -- Be kind to peer & close gracefully.+  closeConn ConnClosed = return ()+  closeConn conn = do+    let sk = connSock conn+    shutdown sk ShutdownSend+    suck readL+    hClose (connHandle conn)+    shutdown sk ShutdownReceive+    sClose sk -    -- This function uses a buffer, at this time the buffer is just 1000 characters.-    -- (however many bytes this is is left to the user to decypher)-    readLine ref =-        readIORef (getRef ref) >>= \conn -> case conn of-             ConnClosed -> return (Left ErrorClosed)-             (MkConn sk addr bfr _)-                 | null bfr ->  {- read in buffer -}-                      do { str <- myrecv sk 1000  -- DON'T use "readBlock sk 1000" !!-                                                -- ... since that call will loop.-                         ; let len = length str-                         ; if len == 0   {- indicates a closed connection -}-                              then return (Right "")-                              else modifyIORef (getRef ref) (\c -> c { connBffr=str })-                                   >> readLine ref  -- recursion-                         }-                 | otherwise ->-                      case elemIndex '\n' bfr of-                          Nothing -> {- need recursion to finish line -}-                              do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })-                                 ; more <- readLine ref -- contains extra recursion                      -                                 ; return $ more `bindE` \str -> Right (bfr++str)-                                 }-                          Just i ->    {- end of line found -}-                              let (bgn,end) = splitAt i bfr in-                              do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) })-                                 ; return (Right (bgn++['\n']))-                                 }+  suck :: IO Bool -> IO ()+  suck rd = do+    f <- rd+    if f then return () else suck rd +-- | Checks both that the underlying Socket is connected+-- and that the connection peer matches the given+-- host name (which is recorded locally).+isConnectedTo :: Connection -> String -> IO Bool+isConnectedTo (Connection conn) name = do+   v <- readMVar (getRef conn)+   case v of+     ConnClosed -> return False+     _ +      | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v)+      | otherwise -> return False +isTCPConnectedTo :: HandleStream ty -> String -> IO Bool+isTCPConnectedTo conn name = do+   v <- readMVar (getRef conn)+   case v of+     ConnClosed -> return False+     _ +      | map toLower (connHost v) == map toLower name -> sIsConnected (connSock v)+      | otherwise -> return False -    -- The 'Connection' object allows no outward buffering, -    -- since in general messages are serialised in their entirety.-    writeBlock ref str =-        readIORef (getRef ref) >>= \conn -> case conn of-            ConnClosed -> return (Left ErrorClosed)-            (MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk)-        where-            fn sk addr s-                | null s    = return (Right ())  -- done-                | otherwise =-                    getSocketOption sk SoError >>= \se ->-                    if se == 0-                        then sendTo sk s addr >>= \i -> fn sk addr (drop i s)-                        else writeIORef (getRef ref) ConnClosed >>-                             if se == 10054-                                 then return (Left ErrorReset)-                                 else return (Left $ ErrorMisc $ show se) +readBlockBS :: HandleStream a -> Int -> IO (Result a)+readBlockBS ref n = do+   conn <- readMVar (getRef ref)+   x <- +    case conn of+     ConnClosed -> return (Left ErrorClosed)+     MkConn{}   -> bufferGetBlock ref n -- (connBuffer conn) (connInput conn) (connHandle conn) n+   fromMaybe (return ()) (fmap (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) (connHooks' conn))+   return x -    -- Closes a Connection.  Connection will no longer-    -- allow any of the other Stream functions.  Notice that a Connection may close-    -- at any time before a call to this function.  This function is idempotent.-    -- (I think the behaviour here is TCP specific)-    close ref = -        do { c <- readIORef (getRef ref)-           ; Exception.catchJust Exception.ioErrors (closeConn c) (\_ -> return ())-           ; writeIORef (getRef ref) ConnClosed-           }-        where-          -- Be kind to peer & close gracefully.-          closeConn (ConnClosed) = return ()-          closeConn (MkConn sk addr [] _) =-              (`Exception.finally` sClose sk) $-              do { shutdown sk ShutdownSend-                 ; suck ref-                 ; shutdown sk ShutdownReceive-                 }-          -          suck :: Connection -> IO ()-          suck cn = readLine cn >>= -                    either (\_ -> return ()) -- catch errors & ignore-                           (\x -> if null x then return () else suck cn)+-- This function uses a buffer, at this time the buffer is just 1000 characters.+-- (however many bytes this is is left to the user to decypher)+readLineBS :: HandleStream a -> IO (Result a)+readLineBS ref = do+   conn <- readMVar (getRef ref)+   x <- +    case conn of+     ConnClosed -> return (Left ErrorClosed)+     MkConn{}   -> bufferReadLine ref -- (connBuffer conn) (connHandle conn) (connInput conn)+   fromMaybe (return ()) (fmap (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) (connHooks' conn))+   return x --- | Checks both that the underlying Socket is connected--- and that the connection peer matches the given--- host name (which is recorded locally).-isConnectedTo :: Connection -> String -> IO Bool-isConnectedTo conn name =-    do { v <- readIORef (getRef conn)-       ; case v of-            ConnClosed -> return False-            (MkConn sk _ _ h) ->-                if (map toLower h == map toLower name)-                then sIsConnected sk-                else return False-       }+-- The 'Connection' object allows no outward buffering, +-- since in general messages are serialised in their entirety.+writeBlockBS :: HandleStream a -> a -> IO (Result ())+writeBlockBS ref b = do+  conn <- readMVar (getRef ref)+  x    <- +   case conn of+    ConnClosed -> return (Left ErrorClosed)+    MkConn{} -> bufferPutBlock (connBuffer conn) (connHandle conn) b+  fromMaybe (return ()) (fmap (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x) (connHooks' conn))+  return x +closeIt :: HandleStream ty -> (ty -> Bool) -> IO ()+closeIt c p = do+  closeConnection c (readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True})+  conn <- readMVar (getRef c)+  fromMaybe (return ()) (fmap (\ h -> hook_close h) (connHooks' conn))+++bufferGetBlock :: HandleStream a -> Int -> IO (Result a)+bufferGetBlock ref n = do+   conn <- readMVar (getRef ref)+   case conn of+     ConnClosed -> return (Left ErrorClosed)+     MkConn{} -> do+       case connInput conn of+         Just c -> do+	   let (a,b) = buf_splitAt (connBuffer conn) n c+	   modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b})+	   return (Right a)+         _ -> do+	   Prelude.catch (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.Right)+                         (\ e -> if isEOFError e +			          then return (Right (buf_empty (connBuffer conn)))+				  else return (Left (ErrorMisc (show e))))++bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ())+bufferPutBlock ops h b = +  Prelude.catch (buf_hPut ops h b >> hFlush h >> return (Right ()))+                (\ e -> return (Left (ErrorMisc (show e))))++bufferReadLine :: HandleStream a -> IO (Result a) -- BufferOp a -> Handle -> IO (Result a)+bufferReadLine ref = do+  conn <- readMVar (getRef ref)+  case conn of+    ConnClosed -> return (Left ErrorClosed)+    MkConn{} -> do+      case connInput conn of+        Just c -> do+	  let (a,b0)  = buf_span (connBuffer conn) (/='\n') c+	  let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0+	  modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1})+	  return (Right (buf_append (connBuffer conn) a newl))+	_ -> Prelude.catch +              (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . Right . appendNL (connBuffer conn))+              (\ e -> +                 if isEOFError e+                  then return (Right (buf_empty (connBuffer conn)))+                  else return (Left (ErrorMisc (show e))))+ where+   -- yes, this s**ks.. _may_ have to be addressed if perf+   -- suggests worthiness.+  appendNL ops b = buf_snoc ops b nl+  +  nl :: Word8+  nl = fromIntegral (fromEnum '\n')