Skip to content
Browse files

initial import of HTTPbis

  • Loading branch information...
0 parents commit c4765e822eb92196fec95560f8f640018d18737f Sigbjorn Finne committed
48 HTTP.cabal
@@ -0,0 +1,48 @@
+Name: HTTP
+Version: 3010.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
+ Copyright (c) 2004, Andre Furtado
+ Copyright (c) 2004, Ganesh Sittampalam
+ Copyright (c) 2004-2005, Dominic Steinitz
+ Copyright 2007 Robin Bate Boerop
+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
+
+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,
+ 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, array
36 LICENSE
@@ -0,0 +1,36 @@
+Copyright (c) 2002, Warrick Gray
+Copyright (c) 2002-2005, Ian Lynagh
+Copyright (c) 2003-2006, Bjorn Bringert
+Copyright (c) 2004, Andre Furtado
+Copyright (c) 2004, Ganesh Sittampalam
+Copyright (c) 2004-2005, Dominic Steinitz
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * The names of contributors may not be used to endorse or promote
+ products derived from this software without specific prior
+ written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35 Makefile
@@ -0,0 +1,35 @@
+HADDOCK = haddock
+
+TODAY = $(shell date +%Y%m%d)
+DIST_NAME = http-$(TODAY)
+
+HADDOCK_FILES = Network/HTTP.hs Network/Browser.hs
+
+.PHONY: all configure build install dist haddock clean
+
+default all: configure build
+
+configure:
+ ./Setup.lhs configure
+
+build:
+ ./Setup.lhs build
+
+install:
+ ./Setup.lhs install
+
+dist:
+ darcs dist --dist-name=$(DIST_NAME)
+
+haddock: $(HADDOCK_FILES)
+ mkdir -p haddock
+ $(HADDOCK) -o haddock -h $^
+
+clean:
+ -./Setup.lhs clean
+ -rm -rf haddock
+ -rm -rf dist
+ $(MAKE) -C test clean
+
+setup: Setup.lhs
+ ghc --make -package Cabal -o setup Setup.lhs
988 Network/Browser.hs
@@ -0,0 +1,988 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Network.Browser
+-- Copyright : (c) Warrick Gray 2002
+-- License : BSD
+--
+-- Maintainer : bjorn@bringert.net
+-- Stability : experimental
+-- Portability : non-portable (not tested)
+--
+-- An HTTP\/1.1 compatible wrapper for the HTTP module.
+-----------------------------------------------------------------------------
+
+{-
+ Changes by Robin Bate Boerop <robin@bateboerop.name>:
+ - Made dependencies explicit in import statements.
+ - Added type signatures.
+ - Imported new StreamDebugger module.
+
+ Change Log:
+ - altered 'closeTCP' to 'close', for consistency with altered HTTP
+ - added debugging settings to browser.
+
+ To Do:
+ - testing!!!
+ - remove BrowserAction type? Possibly replace with IORef?
+ - (more todo's in the HTTP mod)
+
+-}
+
+module Network.Browser (
+ BrowserState,
+ BrowserAction, -- browser monad, effectively a state monad.
+ Cookie,
+ Form(..),
+ Proxy(..),
+
+ browse, -- BrowserAction a -> IO a
+ request, -- Request -> BrowserAction Response
+
+ setAllowRedirects,
+ getAllowRedirects,
+
+ Authority(..),
+ getAuthorities,
+ setAuthorities,
+ addAuthority,
+ getAuthorityGen,
+ setAuthorityGen,
+ setAllowBasicAuth,
+
+ setCookieFilter,
+ defaultCookieFilter,
+ userCookieFilter,
+
+ getCookies,
+ setCookies,
+ addCookie,
+
+ setErrHandler,
+ setOutHandler,
+
+ setProxy,
+
+ setDebugLog,
+
+ out,
+ err,
+ ioAction, -- :: IO a -> BrowserAction a
+
+ defaultGETRequest,
+ formToRequest,
+ uriDefaultTo,
+ uriTrimHost
+) where
+
+import Network.URI
+ ( URI(uriAuthority, uriScheme, uriPath, uriQuery)
+ , URIAuth(URIAuth, uriPort, uriRegName)
+ , parseURI, parseURIReference, relativeTo
+ )
+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)
+import Data.Maybe (fromMaybe, listToMaybe, catMaybes, fromJust, isJust)
+import Control.Monad (foldM, filterM, liftM, when)
+import Text.ParserCombinators.Parsec
+ ( Parser, char, many, many1, satisfy, parse, option, try
+ , (<|>), spaces, sepBy1
+ )
+import qualified System.IO
+ ( hSetBuffering, hPutStr, stdout, stdin, hGetChar
+ , BufferMode(NoBuffering, LineBuffering)
+ )
+import Data.Word (Word8)
+
+
+type Octet = Word8
+
+------------------------------------------------------------------
+----------------------- Miscellaneous ----------------------------
+------------------------------------------------------------------
+
+word, quotedstring :: Parser String
+quotedstring =
+ do { char '"'
+ ; str <- many (satisfy $ not . (=='"'))
+ ; char '"'
+ ; return str
+ }
+
+word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))
+
+
+-- | Returns a URI that is consistent with the first
+-- argument uri when read in the context of a second.
+-- If second argument is not sufficient context for
+-- determining a full URI then anarchy reins.
+uriDefaultTo :: URI -> URI -> URI
+uriDefaultTo a b =
+ case a `relativeTo` b of
+ Nothing -> a
+ Just x -> x
+
+
+uriTrimHost :: URI -> URI
+uriTrimHost uri = uri { uriScheme="", uriAuthority=Nothing }
+
+
+------------------------------------------------------------------
+----------------------- Cookie Stuff -----------------------------
+------------------------------------------------------------------
+
+-- Some conventions:
+-- assume ckDomain is lowercase
+--
+data Cookie = MkCookie { ckDomain
+ , ckName
+ , ckValue :: String
+ , ckPath
+ , ckComment
+ , ckVersion :: Maybe String
+ }
+ deriving(Show,Read)
+
+
+instance Eq Cookie where
+ a == b = ckDomain a == ckDomain b
+ && ckName a == ckName b
+ && ckPath a == ckPath b
+
+
+
+defaultCookieFilter :: URI -> Cookie -> IO Bool
+defaultCookieFilter _url _cky = return True
+
+userCookieFilter :: URI -> Cookie -> IO Bool
+userCookieFilter url cky =
+ do putStrLn ("Set-Cookie received when requesting: " ++ show url)
+ case ckComment cky of
+ Nothing -> return ()
+ Just x -> putStrLn ("Cookie Comment:\n" ++ x)
+ putStrLn ("Domain/Path: " ++ ckDomain cky ++
+ case ckPath cky of
+ Nothing -> ""
+ Just x -> "/" ++ x)
+ putStrLn (ckName cky ++ '=' : ckValue cky)
+ System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering
+ System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering
+ System.IO.hPutStr System.IO.stdout "Accept [y/n]? "
+ x <- System.IO.hGetChar System.IO.stdin
+ System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering
+ System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering
+ return (toLower x == 'y')
+
+
+
+-- | Serialise a Cookie for inclusion in a request.
+cookieToHeader :: Cookie -> Header
+cookieToHeader ck = Header HdrCookie text
+ where
+ text = "$Version=" ++ fromMaybe "0" (ckVersion ck)
+ ++ ';' : ckName ck ++ "=" ++ ckValue ck
+ ++ (case ckPath ck of
+ Nothing -> ""
+ Just x -> ";$Path=" ++ x)
+ ++ ";$Domain=" ++ ckDomain ck
+
+
+
+{- replace "error" call with [] in final version? -}
+headerToCookies :: String -> Header -> [Cookie]
+headerToCookies dom (Header HdrSetCookie val) =
+ case parse cookies "" val of
+ Left e -> error ("Cookie parse failure on: " ++ val ++ " " ++ show e)
+ Right x -> x
+ where
+ cookies :: Parser [Cookie]
+ cookies = sepBy1 cookie (char ',')
+
+ cookie :: Parser Cookie
+ cookie =
+ do { name <- word
+ ; spaces_l
+ ; char '='
+ ; spaces_l
+ ; val1 <- cvalue
+ ; args <- cdetail
+ ; return $ mkCookie name val1 args
+ }
+
+ cvalue :: Parser String
+
+ spaces_l = many (satisfy isSpace)
+
+ cvalue = quotedstring <|> many1 (satisfy $ not . (==';'))
+
+ -- all keys in the result list MUST be in lower case
+ cdetail :: Parser [(String,String)]
+ cdetail = many $
+ try (do { spaces_l
+ ; char ';'
+ ; spaces_l
+ ; s1 <- word
+ ; spaces_l
+ ; s2 <- option "" (do { char '=' ; spaces_l ; v <- cvalue ; return v })
+ ; return (map toLower s1,s2)
+ })
+
+ mkCookie :: String -> String -> [(String,String)] -> Cookie
+ mkCookie nm cval more =
+ MkCookie { ckName = nm
+ , ckValue = cval
+ , ckDomain = map toLower (fromMaybe dom (lookup "domain" more))
+ , ckPath = lookup "path" more
+ , ckVersion = lookup "version" more
+ , ckComment = lookup "comment" more
+ }
+
+headerToCookies _ _ = []
+
+
+
+-- | Adds a cookie to the browser state, removing duplicates.
+addCookie :: Cookie -> BrowserAction t ()
+addCookie c = alterBS (\b -> b { bsCookies=c : fn (bsCookies b) })
+ where
+ fn = filter (not . (==c))
+
+setCookies :: [Cookie] -> BrowserAction t ()
+setCookies cs = alterBS (\b -> b { bsCookies=cs })
+
+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 t [Cookie]
+getCookiesFor dom path =
+ do cks <- getCookies
+ return (filter cookiematch cks)
+ where
+ cookiematch :: Cookie -> Bool
+ cookiematch ck = ckDomain ck `isSuffixOf` dom
+ && case ckPath ck of
+ Nothing -> True
+ Just p -> p `isPrefixOf` path
+
+
+setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t ()
+setCookieFilter f = alterBS (\b -> b { bsCookieFilter=f })
+
+getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool)
+getCookieFilter = getBS bsCookieFilter
+
+------------------------------------------------------------------
+----------------------- Authorisation Stuff ----------------------
+------------------------------------------------------------------
+
+{-
+
+The browser handles 401 responses in the following manner:
+ 1) extract all WWW-Authenticate headers from a 401 response
+ 2) rewrite each as a Challenge object, using "headerToChallenge"
+ 3) pick a challenge to respond to, usually the strongest
+ challenge understood by the client, using "pickChallenge"
+ 4) generate a username/password combination using the browsers
+ "bsAuthorityGen" function (the default behaviour is to ask
+ the user)
+ 5) build an Authority object based upon the challenge and user
+ data, store this new Authority in the browser state
+ 6) convert the Authority to a request header and add this
+ to a request using "withAuthority"
+ 7) send the amended request
+
+Note that by default requests are annotated with authority headers
+before the first sending, based upon previously generated Authority
+objects (which contain domain information). Once a specific authority
+is added to a rejected request this predictive annotation is suppressed.
+
+407 responses are handled in a similar manner, except
+ a) Authorities are not collected, only a single proxy authority
+ is kept by the browser
+ b) If the proxy used by the browser (type Proxy) is NoProxy, then
+ a 407 response will generate output on the "err" stream and
+ the response will be returned.
+
+
+Notes:
+ - digest authentication so far ignores qop, so fails to authenticate
+ properly with qop=auth-int challenges
+ - calculates a1 more than necessary
+ - doesn't reverse authenticate
+ - doesn't properly receive AuthenticationInfo headers, so fails
+ to use next-nonce etc
+
+-}
+
+
+data Algorithm = AlgMD5 | AlgMD5sess
+ deriving(Eq)
+
+instance Show Algorithm where
+ show AlgMD5 = "md5"
+ show AlgMD5sess = "md5-sess"
+
+
+data Qop = QopAuth | QopAuthInt
+ deriving(Eq,Show)
+
+
+data Challenge = ChalBasic { chRealm :: String }
+ | ChalDigest { chRealm :: String
+ , chDomain :: [URI]
+ , chNonce :: String
+ , chOpaque :: Maybe String
+ , chStale :: Bool
+ , chAlgorithm ::Maybe Algorithm
+ , chQop :: [Qop]
+ }
+
+-- | Convert WWW-Authenticate header into a Challenge object
+headerToChallenge :: URI -> Header -> Maybe Challenge
+headerToChallenge baseURI (Header _ str) =
+ case parse challenge "" str of
+ Left{} -> Nothing
+ Right (name,props) -> case name of
+ "basic" -> mkBasic props
+ "digest" -> mkDigest props
+ _ -> Nothing
+ where
+ challenge :: Parser (String,[(String,String)])
+ challenge =
+ do { nme <- word
+ ; spaces
+ ; pps <- cprops
+ ; return (map toLower nme,pps)
+ }
+
+ cprops = sepBy1 cprop comma
+
+ comma = do { spaces ; char ',' ; spaces }
+
+ cprop =
+ do { nm <- word
+ ; char '='
+ ; val <- quotedstring
+ ; return (map toLower nm,val)
+ }
+
+ mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge
+
+ mkBasic params = fmap ChalBasic (lookup "realm" params)
+
+ mkDigest params =
+ -- with Maybe monad
+ do { r <- lookup "realm" params
+ ; n <- lookup "nonce" params
+ ; return $
+ ChalDigest { chRealm = r
+ , chDomain = (annotateURIs
+ $ map parseURI
+ $ words
+ $ fromMaybe []
+ $ lookup "domain" params)
+ , chNonce = n
+ , chOpaque = lookup "opaque" params
+ , chStale = "true" == (map toLower
+ $ fromMaybe "" (lookup "stale" params))
+ , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params)
+ , chQop = readQop (fromMaybe "" $ lookup "qop" params)
+ }
+ }
+
+ annotateURIs :: [Maybe URI] -> [URI]
+ annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes
+
+ -- Change These:
+ readQop :: String -> [Qop]
+ readQop = catMaybes . (map strToQop) . (splitBy ',')
+
+ strToQop qs = case map toLower (trim qs) of
+ "auth" -> Just QopAuth
+ "auth-int" -> Just QopAuthInt
+ _ -> Nothing
+
+ readAlgorithm astr = case map toLower (trim astr) of
+ "md5" -> Just AlgMD5
+ "md5-sess" -> Just AlgMD5sess
+ _ -> Nothing
+
+
+data Authority = AuthBasic { auRealm :: String
+ , auUsername :: String
+ , auPassword :: String
+ , auSite :: URI
+ }
+ | AuthDigest { auRealm :: String
+ , auUsername :: String
+ , auPassword :: String
+ , auNonce :: String
+ , auAlgorithm :: Maybe Algorithm
+ , auDomain :: [URI]
+ , auOpaque :: Maybe String
+ , auQop :: [Qop]
+ }
+
+
+-- | Return authorities for a given domain and path.
+-- Assumes "dom" is lower case
+getAuthFor :: String -> String -> BrowserAction t [Authority]
+getAuthFor dom pth =
+ do { list <- getAuthorities
+ ; return (filter match list)
+ }
+ where
+ match :: Authority -> Bool
+ match (AuthBasic _ _ _ s) = matchURI s
+ match (AuthDigest _ _ _ _ _ ds _ _) = or (map matchURI ds)
+
+ matchURI :: URI -> Bool
+ matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth)
+
+
+-- | Interacting with browser state:
+getAuthorities :: BrowserAction t [Authority]
+getAuthorities = getBS bsAuthorities
+
+setAuthorities :: [Authority] -> BrowserAction t ()
+setAuthorities as = alterBS (\b -> b { bsAuthorities=as })
+
+addAuthority :: Authority -> BrowserAction t ()
+addAuthority a = alterBS (\b -> b { bsAuthorities=a:bsAuthorities b })
+
+getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String)))
+getAuthorityGen = getBS bsAuthorityGen
+
+setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t ()
+setAuthorityGen f = alterBS (\b -> b { bsAuthorityGen=f })
+
+setAllowBasicAuth :: Bool -> BrowserAction t ()
+setAllowBasicAuth ba = alterBS (\b -> b { bsAllowBasicAuth=ba })
+
+
+
+
+-- TO BE CHANGED!!!
+pickChallenge :: [Challenge] -> Maybe Challenge
+pickChallenge = listToMaybe
+
+
+
+-- | Retrieve a likely looking authority for a Request.
+anticipateChallenge :: HTTPRequest ty -> BrowserAction t (Maybe Authority)
+anticipateChallenge rq =
+ let uri = rqURI rq in
+ do { authlist <- getAuthFor (uriToAuthorityString uri) (uriPath uri)
+ ; return (listToMaybe authlist)
+ }
+
+
+-- | Asking the user to respond to a challenge
+challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority)
+challengeToAuthority uri ch =
+ -- prompt user for authority
+ if answerable ch then
+ do { prompt <- getAuthorityGen
+ ; userdetails <- ioAction $ prompt uri (chRealm ch)
+ ; case userdetails of
+ Nothing -> return Nothing
+ Just (u,p) -> return (Just $ buildAuth ch u p)
+ }
+ else return Nothing
+ where
+ answerable :: Challenge -> Bool
+ answerable (ChalBasic _) = True
+ answerable chall = (chAlgorithm chall) == Just AlgMD5
+
+ buildAuth :: Challenge -> String -> String -> Authority
+ buildAuth (ChalBasic r) u p =
+ AuthBasic { auSite=uri
+ , auRealm=r
+ , auUsername=u
+ , auPassword=p
+ }
+
+ -- note to self: this is a pretty stupid operation
+ -- to perform isn't it? ChalX and AuthX are so very
+ -- similar.
+ buildAuth (ChalDigest r d n o _stale a q) u p =
+ AuthDigest { auRealm=r
+ , auUsername=u
+ , auPassword=p
+ , auDomain=d
+ , auNonce=n
+ , auOpaque=o
+ , auAlgorithm=a
+ , auQop=q
+ }
+
+
+-- | Generating a credentials value from an Authority, in
+-- the context of a specific request. If a client nonce
+-- was to be used then this function might need to
+-- be of type ... -> BrowserAction String
+withAuthority :: Authority -> HTTPRequest ty -> String
+withAuthority a rq = case a of
+ AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a)
+ AuthDigest{} ->
+ "Digest username=\"" ++ auUsername a
+ ++ "\",realm=\"" ++ auRealm a
+ ++ "\",nonce=\"" ++ auNonce a
+ ++ "\",uri=\"" ++ digesturi
+ ++ ",response=\"" ++ rspdigest
+ ++ "\""
+ -- plus optional stuff:
+ ++ ( if isJust (auAlgorithm a) then "" else ",algorithm=\"" ++ show (fromJust $ auAlgorithm a) ++ "\"" )
+ ++ ( if isJust (auOpaque a) then "" else ",opaque=\"" ++ (fromJust $ auOpaque a) ++ "\"" )
+ ++ ( if null (auQop a) then "" else ",qop=auth" )
+ where
+ rspdigest = "\""
+ ++ map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2))
+ ++ "\""
+
+ a1, a2 :: String
+ a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a
+
+ {-
+ If the "qop" directive's value is "auth" or is unspecified, then A2
+ is:
+ A2 = Method ":" digest-uri-value
+ If the "qop" value is "auth-int", then A2 is:
+ A2 = Method ":" digest-uri-value ":" H(entity-body)
+ -}
+ a2 = show (rqMethod rq) ++ ":" ++ digesturi
+
+ digesturi = show (rqURI rq)
+ noncevalue = auNonce a
+
+-- 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 -----------------------------------
+------------------------------------------------------------------
+
+-- | Specifies if a proxy should be used for the request.
+data Proxy = NoProxy -- ^ Don't use a proxy.
+ | Proxy String (Maybe Authority) -- ^ Use the proxy given. Should be of the form "http:\/\/host:port", "host", "host:port", or "http:\/\/host"
+
+
+------------------------------------------------------------------
+------------------ Browser State Actions -------------------------
+------------------------------------------------------------------
+
+
+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 t) where
+ show bs = "BrowserState { "
+ ++ shows (bsCookies bs) ("\n"
+ {- ++ show (bsAuthorities bs) ++ "\n"-}
+ ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ")
+
+
+-- Simple DIY stateful behaviour, with IO
+data BrowserAction conn a
+ = BA { lift :: BrowserState conn -> IO (BrowserState conn,a) }
+
+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 conn) where
+ fmap f = liftM f
+
+-- | Apply a browser action to a state.
+browse :: BrowserAction conn a -> IO a
+browse act = do x <- lift act defaultBrowserState
+ return (snd x)
+
+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 t -> BrowserState t) -> BrowserAction t ()
+alterBS f = BA (\b -> return (f b,()))
+
+getBS :: (BrowserState t -> a) -> BrowserAction t a
+getBS f = BA (\b -> return (b,f b))
+
+-- | Do an io action
+ioAction :: IO a -> BrowserAction t a
+ioAction a = BA (\b -> a >>= \v -> return (b,v))
+
+-- Stream handlers
+setErrHandler, setOutHandler :: (String -> IO ()) -> BrowserAction t ()
+setErrHandler h = alterBS (\b -> b { bsErr=h })
+setOutHandler h = alterBS (\b -> b { bsOut=h })
+
+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 t ()
+setAllowRedirects bl = alterBS (\b -> b {bsAllowRedirects=bl})
+
+getAllowRedirects :: BrowserAction t Bool
+getAllowRedirects = getBS bsAllowRedirects
+
+
+-- Proxy
+setProxy :: Proxy -> BrowserAction t ()
+setProxy p = alterBS (\b -> b {bsProxy = p})
+
+getProxy :: BrowserAction t Proxy
+getProxy = getBS bsProxy
+
+
+-- Debug
+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
+ )
+
+
+
+-- Surely the most important bit:
+request :: HStream ty
+ => HTTPRequest ty
+ -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty)
+request req = res
+ where
+ res = request' nullVal initialState req
+
+ initialState = (0,0,0,True)
+ nullVal = buf_empty bufferOps
+
+-- type hacking accomplice..
+--toTy :: ByteStream (TCPConnection ty) ty => BrowserAction (TCPConnection ty) a -> TCPConnection ty
+--toTy = undefined
+
+request' :: HStream ty
+ => ty
+ -> RequestState
+ -> HTTPRequest ty
+ -> BrowserAction (HandleStream ty) (URI,HTTPResponse ty)
+request' nullVal (denycount,redirectcount,retrycount,preempt) rq =
+ do -- add cookies to request
+ let uri = rqURI rq
+ cookies <- getCookiesFor (uriToAuthorityString uri) (uriPath uri)
+
+ when (not $ null cookies)
+ (out $ "Adding cookies to request. Cookie names: "
+ ++ foldl spaceappend "" (map ckName cookies))
+
+ -- add credentials to request
+ rq' <- if not preempt then return rq else
+ do { auth <- anticipateChallenge rq
+ ; case auth of
+ Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq)
+ Nothing -> return rq
+ }
+
+ let rq'' = insertHeaders (map cookieToHeader cookies) rq'
+
+ p <- getProxy
+
+ out ("Sending:\n" ++ show rq'')
+ e_rsp <- case p of
+ NoProxy -> dorequest (uriAuth $ rqURI rq'') rq''
+ Proxy str ath ->
+ let rq''' = case ath of
+ Nothing -> rq''
+ Just x -> insertHeader HdrProxyAuthorization (withAuthority x rq'') rq''
+ -- 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 (hst, pt) = span (':'/=) str
+ in
+ if null pt || null hst
+ then URIAuth "" str ""
+ else URIAuth "" hst pt
+ 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' nullVal (denycount,redirectcount,retrycount+1,preempt) rq
+ else error ("Exception raised in request: " ++ show v)
+ Right rsp -> do
+ out ("Received:\n" ++ show rsp)
+
+ -- add new cookies to browser state
+ let cookieheaders = retrieveHeaders HdrSetCookie rsp
+ let newcookies = concat (map (headerToCookies $ uriToAuthorityString uri) cookieheaders)
+
+ when (not $ null newcookies)
+ (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newcookies)
+
+ filterfn <- getCookieFilter
+ newcookies' <- ioAction (filterM (filterfn uri) newcookies)
+ foldM (\_ -> addCookie) () newcookies'
+
+ when (not $ null newcookies)
+ (out $ "Accepting cookies with names: " ++ foldl spaceappend "" (map ckName newcookies'))
+
+ case rspCode rsp of
+ (4,0,1) -> -- Credentials not sent or refused.
+ out "401 - credentials not sent or refused" >>
+ if denycount > 2 then return (uri,rsp) else
+ do { let hdrs = retrieveHeaders HdrWWWAuthenticate rsp
+ ; case pickChallenge (catMaybes $ map (headerToChallenge uri) hdrs) of
+ Just x ->
+ do { au <- challengeToAuthority uri x
+ ; case au of
+ Just au' ->
+ out "Retrying request with new credentials" >>
+ request' nullVal
+ (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 px _ ->
+ do { out "Retrying with proxy authentication"
+ ; setProxy (Proxy px (Just au'))
+ ; request' nullVal
+ (denycount+1,redirectcount,retrycount,False)
+ rq
+ }
+ }
+ Nothing -> return (uri,rsp) {- do nothing -}
+ }
+
+ Nothing -> return (uri,rsp) {- do nothing -}
+ }
+
+
+ (3,0,3) -> -- Redirect using GET request method.
+ do { out "303 - redirect using GET"
+ ; rd <- getAllowRedirects
+ ; if not rd || redirectcount > 4 then return (uri,rsp) else
+ case retrieveHeaders HdrLocation rsp of
+ (Header _ u:_) -> case parseURIReference u of
+ Just newuri ->
+ let newuri' = case newuri `relativeTo` uri of
+ Nothing -> newuri
+ Just x -> x
+ in do { out ("Redirecting to " ++ show newuri' ++ " ...")
+ ; let rq1 = rq { rqMethod=GET, rqURI=newuri', rqBody=nullVal }
+ ; request' nullVal
+ (0,redirectcount+1,retrycount,True)
+ (replaceHeader HdrContentLength "0" rq1)
+ }
+ 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' nullVal (0,0,retrycount+1,True) rq
+ }
+ Nothing ->
+ do { err ("Parse of Location header in a proxy redirect response failed: " ++ u)
+ ; return (uri,rsp)
+ }
+ [] -> do { err "No Location header in proxy redirect response."
+ ; return (uri,rsp)
+ }
+
+
+ (3,_,_) -> redirect uri rsp
+ _ -> return (uri,rsp)
+
+ where
+ spaceappend :: String -> String -> String
+ spaceappend x y = x ++ ' ' : y
+
+ redirect uri rsp = do
+ rd <- getAllowRedirects
+ if not rd || redirectcount > 4 then return (uri,rsp) else do
+ case retrieveHeaders HdrLocation rsp of
+ (Header _ u:_) -> case parseURIReference u of
+ Just newuri -> do
+ let newuri' = case newuri `relativeTo` uri of
+ Nothing -> newuri
+ Just x -> x
+ out ("Redirecting to " ++ show newuri' ++ " ...")
+ request' nullVal (0,redirectcount+1,retrycount,True) (rq { rqURI=newuri' })
+ Nothing -> do
+ err ("Parse of Location header in a redirect response failed: " ++ u)
+ return (uri,rsp)
+ [] -> do err "No Location header in redirect response."
+ return (uri,rsp)
+
+
+dorequest :: (HStream ty)
+ => URIAuth -> HTTPRequest ty -> BrowserAction (HandleStream ty) (Either ConnError (HTTPResponse ty))
+dorequest hst rqst =
+ do { pool <- getBS bsConnectionPool
+ ; conn <- ioAction $ filterM (\c -> c `isTCPConnectedTo` uriAuthToString hst) pool
+ ; rsp <- case conn of
+ [] -> do { out ("Creating new connection to " ++ uriAuthToString hst)
+ ; let aport = case uriPort hst of
+ (':':s) -> read s
+ _ -> 80
+ ; 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 c rqst
+ }
+ (c:_) ->
+ do { out ("Recovering connection to " ++ uriAuthToString hst)
+ ; dorequest2 c rqst
+ }
+ ;
+ ; return rsp
+ }
+ 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)
+
+
+------------------------------------------------------------------
+------------------ Request Building ------------------------------
+------------------------------------------------------------------
+
+
+libUA :: String
+libUA = "haskell-libwww/0.1"
+
+defaultGETRequest :: URI -> Request
+defaultGETRequest uri =
+ Request { rqURI=uri
+ , rqBody=""
+ , rqHeaders=[ Header HdrContentLength "0"
+ , Header HdrUserAgent libUA
+ ]
+ , rqMethod=GET
+ }
+
+-- This form junk is completely untested...
+
+type FormVar = (String,String)
+
+data Form = Form RequestMethod URI [FormVar]
+
+
+formToRequest :: Form -> Request
+formToRequest (Form m u vs) =
+ let enc = urlEncodeVars vs
+ in case m of
+ GET -> Request { rqMethod=GET
+ , rqHeaders=[ Header HdrContentLength "0" ]
+ , rqBody=""
+ , rqURI=u { uriQuery= '?' : enc } -- What about old query?
+ }
+ POST -> Request { rqMethod=POST
+ , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded",
+ Header HdrContentLength (show $ length enc) ]
+ , rqBody=enc
+ , rqURI=u
+ }
+ _ -> error ("unexpected request: " ++ show m)
127 Network/BufferType.hs
@@ -0,0 +1,127 @@
+{-# 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)
+--
+-- Abstract representation of 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 )
+
+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
+ (a,b) -> (Strict.unpack a, Strict.unpack b)
+ , buf_empty = []
+ , buf_isLineTerm = \ b -> b == crlf
+ , buf_isEmpty = null
+ }
+ where
+ crlf = "\r\n"
123 Network/HTTP.hs
@@ -0,0 +1,123 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+ ( module Network.HTTP.HandleStream
+ , module Network.HTTP.Base
+ , module Network.HTTP.Headers
+
+{-
+ , 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.HTTP.Headers
+import Network.HTTP.Base
+--import Network.HTTP.Stream
+import Network.HTTP.HandleStream
+import Network.TCP
+
+
+
525 Network/HTTP/Base.hs
@@ -0,0 +1,525 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+ , RequestData
+
+ , getAuth
+ , normalizeRequestURI
+ , normalizeHostHeader
+ , findConnClose
+
+ -- internal export (for the use by Network.HTTP.{Stream,ByteStream} )
+ , linearTransfer
+ , hopefulTransfer
+ , chunkedTransfer
+ , uglyDeathTransfer
+ , readTillEmpty1
+ , readTillEmpty2
+ ) 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 )
+
+
+-----------------------------------------------------------------
+------------------ 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 }
+
+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 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))
279 Network/HTTP/Base64.hs
@@ -0,0 +1,279 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Codec.Binary.Base64
+-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002
+-- License : BSD-style (see the file ReadMe.tex)
+--
+-- Maintainer : dominic.steinitz@blueyonder.co.uk
+-- Stability : experimental
+-- Portability : portable
+--
+-- Base64 encoding and decoding functions provided by Warwick Gray.
+-- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64>
+-- and <http://www.faqs.org/rfcs/rfc2045.html>.
+--
+-----------------------------------------------------------------------------
+
+module Network.HTTP.Base64
+ ( encode
+ , decode
+ , chop72
+ , Octet
+ ) where
+
+{------------------------------------------------------------------------
+This is what RFC2045 had to say:
+
+6.8. Base64 Content-Transfer-Encoding
+
+ The Base64 Content-Transfer-Encoding is designed to represent
+ arbitrary sequences of octets in a form that need not be humanly
+ readable. The encoding and decoding algorithms are simple, but the
+ encoded data are consistently only about 33 percent larger than the
+ unencoded data. This encoding is virtually identical to the one used
+ in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421.
+
+ A 65-character subset of US-ASCII is used, enabling 6 bits to be
+ represented per printable character. (The extra 65th character, "=",
+ is used to signify a special processing function.)
+
+ NOTE: This subset has the important property that it is represented
+ identically in all versions of ISO 646, including US-ASCII, and all
+ characters in the subset are also represented identically in all
+ versions of EBCDIC. Other popular encodings, such as the encoding
+ used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and
+ the base85 encoding specified as part of Level 2 PostScript, do not
+ share these properties, and thus do not fulfill the portability
+ requirements a binary transport encoding for mail must meet.
+
+ The encoding process represents 24-bit groups of input bits as output
+ strings of 4 encoded characters. Proceeding from left to right, a
+ 24-bit input group is formed by concatenating 3 8bit input groups.
+ These 24 bits are then treated as 4 concatenated 6-bit groups, each
+ of which is translated into a single digit in the base64 alphabet.
+ When encoding a bit stream via the base64 encoding, the bit stream
+ must be presumed to be ordered with the most-significant-bit first.
+ That is, the first bit in the stream will be the high-order bit in
+ the first 8bit byte, and the eighth bit will be the low-order bit in
+ the first 8bit byte, and so on.
+
+ Each 6-bit group is used as an index into an array of 64 printable
+ characters. The character referenced by the index is placed in the
+ output string. These characters, identified in Table 1, below, are
+ selected so as to be universally representable, and the set excludes
+ characters with particular significance to SMTP (e.g., ".", CR, LF)
+ and to the multipart boundary delimiters defined in RFC 2046 (e.g.,
+ "-").
+
+
+
+ Table 1: The Base64 Alphabet
+
+ Value Encoding Value Encoding Value Encoding Value Encoding
+ 0 A 17 R 34 i 51 z
+ 1 B 18 S 35 j 52 0
+ 2 C 19 T 36 k 53 1
+ 3 D 20 U 37 l 54 2
+ 4 E 21 V 38 m 55 3
+ 5 F 22 W 39 n 56 4
+ 6 G 23 X 40 o 57 5
+ 7 H 24 Y 41 p 58 6
+ 8 I 25 Z 42 q 59 7
+ 9 J 26 a 43 r 60 8
+ 10 K 27 b 44 s 61 9
+ 11 L 28 c 45 t 62 +
+ 12 M 29 d 46 u 63 /
+ 13 N 30 e 47 v
+ 14 O 31 f 48 w (pad) =
+ 15 P 32 g 49 x
+ 16 Q 33 h 50 y
+
+ The encoded output stream must be represented in lines of no more
+ than 76 characters each. All line breaks or other characters not
+ found in Table 1 must be ignored by decoding software. In base64
+ data, characters other than those in Table 1, line breaks, and other
+ white space probably indicate a transmission error, about which a
+ warning message or even a message rejection might be appropriate
+ under some circumstances.
+
+ Special processing is performed if fewer than 24 bits are available
+ at the end of the data being encoded. A full encoding quantum is
+ always completed at the end of a body. When fewer than 24 input bits
+ are available in an input group, zero bits are added (on the right)
+ to form an integral number of 6-bit groups. Padding at the end of
+ the data is performed using the "=" character. Since all base64
+ input is an integral number of octets, only the following cases can
+ arise: (1) the final quantum of encoding input is an integral
+ multiple of 24 bits; here, the final unit of encoded output will be
+ an integral multiple of 4 characters with no "=" padding, (2) the
+ final quantum of encoding input is exactly 8 bits; here, the final
+ unit of encoded output will be two characters followed by two "="
+ padding characters, or (3) the final quantum of encoding input is
+ exactly 16 bits; here, the final unit of encoded output will be three
+ characters followed by one "=" padding character.
+
+ Because it is used only for padding at the end of the data, the
+ occurrence of any "=" characters may be taken as evidence that the
+ end of the data has been reached (without truncation in transit). No
+ such assurance is possible, however, when the number of octets
+ transmitted was a multiple of three and no "=" characters are
+ present.
+
+ Any characters outside of the base64 alphabet are to be ignored in
+ base64-encoded data.
+
+ Care must be taken to use the proper octets for line breaks if base64
+ encoding is applied directly to text material that has not been
+ converted to canonical form. In particular, text line breaks must be
+ converted into CRLF sequences prior to base64 encoding. The
+ important thing to note is that this may be done directly by the
+ encoder rather than in a prior canonicalization step in some
+ implementations.
+
+ NOTE: There is no need to worry about quoting potential boundary
+ delimiters within base64-encoded bodies within multipart entities
+ because no hyphen characters are used in the base64 encoding.
+
+----------------------------------------------------------------------------}
+
+{-
+
+The following properties should hold:
+
+ decode . encode = id
+ decode . chop72 . encode = id
+
+I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input,
+the second variation corresponds better with the RFC above, but outside of
+MIME applications might be undesireable.
+
+
+But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only
+ 8 significant bits, which is more than enough for US-ASCII.
+-}
+
+
+import Data.Array (Array, array, (!))
+import Data.Bits (shiftL, shiftR, (.&.), (.|.))
+import Data.Char (chr, ord)
+import Data.Word (Word8)
+
+type Octet = Word8
+
+encodeArray :: Array Int Char
+encodeArray = array (0,64)
+ [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F')
+ , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L')
+ , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R')
+ , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X')
+ , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')
+ , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j')
+ , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p')
+ , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v')
+ , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1')
+ , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7')
+ , (60,'8'), (61,'9'), (62,'+'), (63,'/') ]
+
+
+-- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits)
+-- clearly the upmost/leftmost 8 bits of the answer are 0.
+-- Hack Alert: In the last entry of the answer, the upper 8 bits encode
+-- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3.
+-- 0 represents a 4 :(
+int4_char3 :: [Int] -> [Char]
+int4_char3 (a:b:c:d:t) =
+ let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d)
+ in (chr (n `shiftR` 16 .&. 0xff))
+ : (chr (n `shiftR` 8 .&. 0xff))
+ : (chr (n .&. 0xff)) : int4_char3 t
+
+int4_char3 [a,b,c] =
+ let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6)
+ in [ (chr (n `shiftR` 16 .&. 0xff))
+ , (chr (n `shiftR` 8 .&. 0xff)) ]
+
+int4_char3 [a,b] =
+ let n = (a `shiftL` 18 .|. b `shiftL` 12)
+ in [ (chr (n `shiftR` 16 .&. 0xff)) ]
+
+int4_char3 [] = []
+
+
+
+
+-- Convert triplets of characters to
+-- 4 base64 integers. The last entries
+-- in the list may not produce 4 integers,
+-- a trailing 2 character group gives 3 integers,
+-- while a trailing single character gives 2 integers.
+char3_int4 :: [Char] -> [Int]
+char3_int4 (a:b:c:t)
+ = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c)
+ in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t
+
+char3_int4 [a,b]
+ = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8)
+ in [ (n `shiftR` 18 .&. 0x3f)
+ , (n `shiftR` 12 .&. 0x3f)
+ , (n `shiftR` 6 .&. 0x3f) ]
+
+char3_int4 [a]
+ = let n = (ord a `shiftL` 16)
+ in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]
+
+char3_int4 [] = []
+
+
+-- Retrieve base64 char, given an array index integer in the range [0..63]
+enc1 :: Int -> Char
+enc1 ch = encodeArray!ch
+
+
+-- | Cut up a string into 72 char lines, each line terminated by CRLF.
+
+chop72 :: String -> String
+chop72 str = let (bgn,end) = splitAt 70 str
+ in if null end then bgn else "\r\n" ++ chop72 end
+
+
+-- Pads a base64 code to a multiple of 4 characters, using the special
+-- '=' character.
+quadruplets :: [Char] -> [Char]
+quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t
+quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit
+quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit
+quadruplets [] = [] -- 24bit tail unit
+
+
+enc :: [Int] -> [Char]
+enc = quadruplets . map enc1
+
+
+dcd :: String -> [Int]
+dcd [] = []
+dcd (h:t)
+ | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t
+ | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t
+ | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t
+ | h == '+' = 62 : dcd t
+ | h == '/' = 63 : dcd t
+ | h == '=' = [] -- terminate data stream
+ | otherwise = dcd t
+
+
+-- Principal encoding and decoding functions.
+
+encode :: [Octet] -> String
+encode = enc . char3_int4 . (map (chr .fromIntegral))
+
+{-
+prop_base64 os =
+ os == (f . g . h) os
+ where types = (os :: [Word8])
+ f = map (fromIntegral. ord)
+ g = decode . encode
+ h = map (chr . fromIntegral)
+-}
+
+decode :: String -> [Octet]
+decode = (map (fromIntegral . ord)) . int4_char3 . dcd
218 Network/HTTP/HandleStream.hs
@@ -0,0 +1,218 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 Control.Exception as Exception (catch, throw, IOException)
+import Data.Char (toLower)
+import Data.Maybe (fromMaybe)
+import Control.Monad (when)
+
+catchIO :: IO a -> (IOException -> IO a) -> IO a
+catchIO = Exception.catch
+
+-----------------------------------------------------------------
+------------------ 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; 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
+
+-- 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