http-slim (empty) → 1.0
raw patch · 16 files changed
+5410/−0 lines, 16 filesdep +HsOpenSSLdep +Win32dep +arraysetup-changed
Dependencies added: HsOpenSSL, Win32, array, base, bytestring, containers, mtl, network, network-bsd, network-uri, parsec, time, transformers
Files
- LICENSE +29/−0
- Network/Browser.hs +1061/−0
- Network/FastCGI.hs +589/−0
- Network/HTTP.hs +369/−0
- Network/HTTP/Auth.hs +219/−0
- Network/HTTP/Base.hs +727/−0
- Network/HTTP/Base64.hs +282/−0
- Network/HTTP/Cookie.hs +228/−0
- Network/HTTP/HandleStream.hs +312/−0
- Network/HTTP/Headers.hs +429/−0
- Network/HTTP/MD5.hs +264/−0
- Network/HTTP/Proxy.hs +226/−0
- Network/HTTP/Utils.hs +189/−0
- Network/TCP.hs +399/−0
- Setup.hs +3/−0
- http-slim.cabal +84/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2022, Krasimir Angelov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+ contributors may 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 HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/Browser.hs view
@@ -0,0 +1,1061 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, FlexibleContexts, ScopedTypeVariables #-}+{- |++Module : Network.Browser+Copyright : See LICENSE file+License : BSD++Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+Stability : experimental+Portability : non-portable (not tested)++Session-level interactions over HTTP.++The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in+providing support for more involved, and real, request/response interactions over+HTTP. Additional features supported are:++* HTTP Authentication handling++* Transparent handling of redirects++* Cookie stores + transmission.++* Transaction logging++* Proxy-mediated connections.++Example use:++> do+> (_, rsp)+> <- Network.Browser.browse $ do+> setAllowRedirects True -- handle HTTP redirects+> request $ getRequest "http://www.haskell.org/"+> return (take 100 (rspBody rsp))++-}+module Network.Browser+ ( BrowserState+ , BrowserAction -- browser monad, effectively a state monad.+ , Proxy(..)++ , browse -- :: BrowserAction a -> IO a+ , request -- :: Request -> BrowserAction Response++ , getBrowserState -- :: BrowserAction (BrowserState t)+ , withBrowserState -- :: BrowserState t -> BrowserAction a -> BrowserAction a++ , setAllowRedirects -- :: Bool -> BrowserAction ()+ , getAllowRedirects -- :: BrowserAction Bool++ , setMaxRedirects -- :: Int -> BrowserAction ()+ , getMaxRedirects -- :: BrowserAction (Maybe Int)++ , Authority(..)+ , getAuthorities+ , setAuthorities+ , addAuthority+ , Challenge(..)+ , Qop(..)+ , Algorithm(..)++ , getAuthorityGen+ , setAuthorityGen+ , setAllowBasicAuth+ , getAllowBasicAuth++ , setMaxErrorRetries -- :: Maybe Int -> BrowserAction ()+ , getMaxErrorRetries -- :: BrowserAction (Maybe Int)++ , setMaxPoolSize -- :: Int -> BrowserAction ()+ , getMaxPoolSize -- :: BrowserAction (Maybe Int)++ , setMaxAuthAttempts -- :: Maybe Int -> BrowserAction ()+ , getMaxAuthAttempts -- :: BrowserAction (Maybe Int)++ , setCookieFilter -- :: (URI -> Cookie -> IO Bool) -> BrowserAction ()+ , getCookieFilter -- :: BrowserAction (URI -> Cookie -> IO Bool)+ , defaultCookieFilter -- :: URI -> Cookie -> IO Bool+ , userCookieFilter -- :: URI -> Cookie -> IO Bool++ , Cookie(..)+ , getCookies -- :: BrowserAction [Cookie]+ , setCookies -- :: [Cookie] -> BrowserAction ()+ , addCookie -- :: Cookie -> BrowserAction ()++ , setErrHandler -- :: (String -> IO ()) -> BrowserAction ()+ , setOutHandler -- :: (String -> IO ()) -> BrowserAction ()++ , setEventHandler -- :: (BrowserEvent -> BrowserAction ()) -> BrowserAction ()++ , BrowserEvent(..)+ , BrowserEventType(..)+ , RequestID++ , setProxy -- :: Proxy -> BrowserAction ()+ , getProxy -- :: BrowserAction Proxy++ , setCheckForProxy -- :: Bool -> BrowserAction ()+ , getCheckForProxy -- :: BrowserAction Bool++ , getUserAgent -- :: BrowserAction String+ , setUserAgent -- :: String -> BrowserAction ()++ , out -- :: String -> BrowserAction ()+ , err -- :: String -> BrowserAction ()++ , defaultGETRequest++ , formToRequest+ , uriDefaultTo++ -- old and half-baked; don't use:+ , Form(..)+ , FormVar+ ) where++import Network.URI+ ( URI(..)+ , URIAuth(..)+ , parseURI, parseURIReference, relativeTo+ , escapeURIString, isUnescapedInURI+ )+import Network.HTTP hiding ( sendHTTP_notify, getCookies, setCookies )+import Network.HTTP.HandleStream ( sendHTTP_notify )+import Network.HTTP.Auth+import Network.HTTP.Cookie+import Network.HTTP.Proxy+import Network.HTTP.Utils ( HttpError(..) )+#if MIN_VERSION_network_uri(2,6,2)+import Network.URI ( uriAuthToString )+#endif++#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,13,0))+import Control.Monad.Fail+#endif++import Data.Char (toLower)+import Data.List (partition, isPrefixOf)+import Data.Maybe (fromMaybe, listToMaybe, catMaybes )+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>))+#endif+import Control.Exception ( Exception(..), SomeException, catch, throwIO )+import Control.Monad (filterM, forM_, when)+import Control.Monad.IO.Class+ ( MonadIO (..) )+import Control.Monad.State+ ( MonadState(..), gets, modify, StateT (..), evalStateT, withStateT )++import qualified System.IO+ ( hSetBuffering, hPutStr, stdout, stdin, hGetChar+ , BufferMode(NoBuffering, LineBuffering)+ )+import Data.Time.Clock ( UTCTime, getCurrentTime )+++------------------------------------------------------------------+----------------------- Cookie Stuff -----------------------------+------------------------------------------------------------------++-- | @defaultCookieFilter@ is the initial cookie acceptance filter.+-- It welcomes them all into the store @:-)@+defaultCookieFilter :: URI -> Cookie -> IO Bool+defaultCookieFilter _url _cky = return True++-- | @userCookieFilter@ is a handy acceptance filter, asking the+-- user if he/she is willing to accept an incoming cookie before+-- adding it to the store.+userCookieFilter :: URI -> Cookie -> IO Bool+userCookieFilter url cky = do+ do putStrLn ("Set-Cookie received when requesting: " ++ show url)+ case ckComment cky of+ Nothing -> return ()+ Just x -> putStrLn ("Cookie Comment:\n" ++ x)+ let pth = maybe "" ('/':) (ckPath cky)+ putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth)+ 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')++-- | @addCookie c@ adds a cookie to the browser state, removing duplicates.+addCookie :: Cookie -> BrowserAction ()+addCookie c = modify (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) })++-- | @setCookies cookies@ replaces the set of cookies known to+-- the browser to @cookies@. Useful when wanting to restore cookies+-- used across 'browse' invocations.+setCookies :: [Cookie] -> BrowserAction ()+setCookies cs = modify (\b -> b { bsCookies=cs })++-- | @getCookies@ returns the current set of cookies known to+-- the browser.+getCookies :: BrowserAction [Cookie]+getCookies = gets bsCookies++-- ...get domain specific cookies...+-- ... this needs changing for consistency with rfc2109...+-- ... currently too broad.+getCookiesFor :: String -> String -> BrowserAction [Cookie]+getCookiesFor dom path =+ do cks <- getCookies+ return (filter cookiematch cks)+ where+ cookiematch :: Cookie -> Bool+ cookiematch = cookieMatch (dom,path)+++-- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@.+setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction ()+setCookieFilter f = modify (\b -> b { bsCookieFilter=f })++-- | @getCookieFilter@ returns the current cookie acceptance filter.+getCookieFilter :: BrowserAction (URI -> Cookie -> IO Bool)+getCookieFilter = gets 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++-}++-- | Return authorities for a given domain and path.+-- Assumes "dom" is lower case+getAuthFor :: String -> String -> BrowserAction [Authority]+getAuthFor dom pth = getAuthorities >>= return . (filter match)+ where+ match :: Authority -> Bool+ match au@AuthBasic{} = matchURI (auSite au)+ match au@AuthDigest{} = or (map matchURI (auDomain au))++ matchURI :: URI -> Bool+ matchURI uri = (uriAuthToString id (uriAuthority uri) "" == dom) && (uriPath uri `isPrefixOf` pth)+++-- | @getAuthorities@ return the current set of @Authority@s known+-- to the browser.+getAuthorities :: BrowserAction [Authority]+getAuthorities = gets bsAuthorities++-- @setAuthorities as@ replaces the Browser's known set+-- of 'Authority's to @as@.+setAuthorities :: [Authority] -> BrowserAction ()+setAuthorities as = modify (\b -> b { bsAuthorities=as })++-- @addAuthority a@ adds 'Authority' @a@ to the Browser's+-- set of known authorities.+addAuthority :: Authority -> BrowserAction ()+addAuthority a = modify (\b -> b { bsAuthorities=a:bsAuthorities b })++-- | @getAuthorityGen@ returns the current authority generator+getAuthorityGen :: BrowserAction (URI -> String -> IO (Maybe (String,String)))+getAuthorityGen = gets bsAuthorityGen++-- | @setAuthorityGen genAct@ sets the auth generator to @genAct@.+setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction ()+setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f })++-- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication.+setAllowBasicAuth :: Bool -> BrowserAction ()+setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba })++getAllowBasicAuth :: BrowserAction Bool+getAllowBasicAuth = gets bsAllowBasicAuth++-- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts+-- to do. If @Nothing@, revert to default max.+setMaxAuthAttempts :: Maybe Int -> BrowserAction ()+setMaxAuthAttempts mb+ | fromMaybe 0 mb < 0 = return ()+ | otherwise = modify (\ b -> b{bsMaxAuthAttempts=mb})++-- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@,+-- the browser's default is used.+getMaxAuthAttempts :: BrowserAction (Maybe Int)+getMaxAuthAttempts = gets bsMaxAuthAttempts++-- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at+-- transmitting a request. If @Nothing@, rever to default max.+setMaxErrorRetries :: Maybe Int -> BrowserAction ()+setMaxErrorRetries mb+ | fromMaybe 0 mb < 0 = return ()+ | otherwise = modify (\ b -> b{bsMaxErrorRetries=mb})++-- | @getMaxErrorRetries@ returns the current max number of error retries.+getMaxErrorRetries :: BrowserAction (Maybe Int)+getMaxErrorRetries = gets bsMaxErrorRetries++-- TO BE CHANGED!!!+pickChallenge :: Bool -> [Challenge] -> Maybe Challenge+pickChallenge allowBasic []+ | allowBasic = Just (ChalBasic "/") -- manufacture a challenge if one missing; more robust.+pickChallenge _ ls = listToMaybe ls++-- | Retrieve a likely looking authority for a Request.+anticipateChallenge :: Request -> BrowserAction (Maybe Authority)+anticipateChallenge rq = do+ let uri = rqURI rq+ auth <- getAuth rq+ authlist <- getAuthFor (uriAuthToString id (Just auth) "") (uriPath uri)+ return (listToMaybe authlist)++-- | Asking the user to respond to a challenge+challengeToAuthority :: URI -> Challenge -> BrowserAction (Maybe Authority)+challengeToAuthority uri ch+ | not (answerable ch) = return Nothing+ | otherwise = do+ -- prompt user for authority+ prompt <- getAuthorityGen+ userdetails <- liftIO $ prompt uri (chRealm ch)+ case userdetails of+ Nothing -> return Nothing+ Just (u,p) -> return (Just $ buildAuth ch u p)+ 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+ }+++------------------------------------------------------------------+------------------ Browser State Actions -------------------------+------------------------------------------------------------------+++-- | @BrowserState@ is the (large) record type tracking the current+-- settings of the browser.+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+ , bsMaxRedirects :: Maybe Int+ , bsMaxErrorRetries :: Maybe Int+ , bsMaxAuthAttempts :: Maybe Int+ , bsMaxPoolSize :: Maybe Int+ , bsConnectionPool :: [Connection]+ , bsCheckProxy :: Bool+ , bsProxy :: Proxy+ , bsEvent :: Maybe (BrowserEvent -> BrowserAction ())+ , bsRequestID :: RequestID+ , bsUserAgent :: Maybe String+ }++instance Show BrowserState where+ show bs = "BrowserState { "+ ++ shows (bsCookies bs) ("\n"+ {- ++ show (bsAuthorities bs) ++ "\n"-}+ ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ")++-- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'.+newtype BrowserAction a+ = BA { unBA :: StateT BrowserState IO a }+ deriving+ ( Functor, Applicative, Monad, MonadIO, MonadState BrowserState+#if MIN_VERSION_base(4,9,0)+ , MonadFail+#endif+ )++runBA :: BrowserState -> BrowserAction a -> IO a+runBA bs = flip evalStateT bs . unBA++-- | @browse act@ is the toplevel action to perform a 'BrowserAction'.+-- Example use: @browse (request (getRequest yourURL))@.+browse :: BrowserAction a -> IO a+browse = runBA defaultBrowserState++-- | The default browser state has the settings+defaultBrowserState :: BrowserState+defaultBrowserState = BS+ { bsErr = putStrLn+ , bsOut = putStrLn+ , bsCookies = []+ , bsCookieFilter = defaultCookieFilter+ , bsAuthorityGen = \ _uri _realm -> do+ putStrLn "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing"+ return Nothing+ , bsAuthorities = []+ , bsAllowRedirects = True+ , bsAllowBasicAuth = False+ , bsMaxRedirects = Nothing+ , bsMaxErrorRetries = Nothing+ , bsMaxAuthAttempts = Nothing+ , bsMaxPoolSize = Nothing+ , bsConnectionPool = []+ , bsCheckProxy = defaultAutoProxyDetect+ , bsProxy = noProxy+ , bsEvent = Nothing+ , bsRequestID = 0+ , bsUserAgent = Nothing+ }++{-# DEPRECATED getBrowserState "Use Control.Monad.State.get instead." #-}+-- | @getBrowserState@ returns the current browser config. Useful+-- for restoring state across 'BrowserAction's.+getBrowserState :: BrowserAction BrowserState+getBrowserState = get++-- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@.+withBrowserState :: BrowserState -> BrowserAction a -> BrowserAction a+withBrowserState bs = BA . withStateT (const bs) . unBA++-- | @nextRequest act@ performs the browser action @act@ as+-- the next request, i.e., setting up a new request context+-- before doing so.+nextRequest :: BrowserAction a -> BrowserAction a+nextRequest act = do+ let updReqID st =+ let+ rid = succ (bsRequestID st)+ in+ rid `seq` st{bsRequestID=rid}+ modify updReqID+ act++catchBrowseException :: Exception e => BrowserAction a -> (e -> BrowserAction a) -> BrowserAction a+catchBrowseException f g = + BA (StateT (\st -> catch (runStateT (unBA f) st) (\e -> runStateT (unBA (g e)) st)))++-- | @setErrHandler@ sets the IO action to call when+-- the browser reports running errors. To disable any+-- such, set it to @const (return ())@.+setErrHandler :: (String -> IO ()) -> BrowserAction ()+setErrHandler h = modify (\b -> b { bsErr=h })++-- | @setOutHandler@ sets the IO action to call when+-- the browser chatters info on its running. To disable any+-- such, set it to @const (return ())@.+setOutHandler :: (String -> IO ()) -> BrowserAction ()+setOutHandler h = modify (\b -> b { bsOut=h })++out, err :: String -> BrowserAction ()+out s = do { f <- gets bsOut ; liftIO $ f s }+err s = do { f <- gets bsErr ; liftIO $ f s }++-- | @setAllowRedirects onOff@ toggles the willingness to+-- follow redirects (HTTP responses with 3xx status codes).+setAllowRedirects :: Bool -> BrowserAction ()+setAllowRedirects bl = modify (\b -> b {bsAllowRedirects=bl})++-- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag.+getAllowRedirects :: BrowserAction Bool+getAllowRedirects = gets bsAllowRedirects++-- | @setMaxRedirects maxCount@ sets the maximum number of forwarding hops+-- we are willing to jump through. A no-op if the count is negative; if zero,+-- the max is set to whatever default applies. Notice that setting the max+-- redirects count does /not/ enable following of redirects itself; use+-- 'setAllowRedirects' to do so.+setMaxRedirects :: Maybe Int -> BrowserAction ()+setMaxRedirects c+ | fromMaybe 0 c < 0 = return ()+ | otherwise = modify (\b -> b{bsMaxRedirects=c})++-- | @getMaxRedirects@ returns the current setting for the max-redirect count.+-- If @Nothing@, the "Network.Browser"'s default is used.+getMaxRedirects :: BrowserAction (Maybe Int)+getMaxRedirects = gets bsMaxRedirects++-- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool+-- that is used to cache connections between requests+setMaxPoolSize :: Maybe Int -> BrowserAction ()+setMaxPoolSize c = modify (\b -> b{bsMaxPoolSize=c})++-- | @getMaxPoolSize@ gets the maximum size of the connection pool+-- that is used to cache connections between requests.+-- If @Nothing@, the "Network.Browser"'s default is used.+getMaxPoolSize :: BrowserAction (Maybe Int)+getMaxPoolSize = gets bsMaxPoolSize++-- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@.+-- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted+-- as the URL of the proxy to use, possibly authenticating via+-- 'Authority' information in @mbAuth@.+setProxy :: Proxy -> BrowserAction ()+setProxy p =+ -- Note: if user _explicitly_ sets the proxy, we turn+ -- off any auto-detection of proxies.+ modify (\b -> b {bsProxy = p, bsCheckProxy=False})++-- | @getProxy@ returns the current proxy settings. If+-- the auto-proxy flag is set to @True@, @getProxy@ will+-- perform the necessary+getProxy :: BrowserAction Proxy+getProxy = do+ p <- gets bsProxy+ case p of+ -- Note: if there is a proxy, no need to perform any auto-detect.+ -- Presumably this is the user's explicit and preferred proxy server.+ Proxy{} -> return p+ NoProxy{} -> do+ flg <- gets bsCheckProxy+ if not flg+ then return p+ else do+ np <- liftIO $ fetchProxy True{-issue warning on stderr if ill-formed...-}+ -- note: this resets the check-proxy flag; a one-off affair.+ setProxy np+ return np++-- | @setCheckForProxy flg@ sets the one-time check for proxy+-- flag to @flg@. If @True@, the session will try to determine+-- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy'+-- for details of how this done.+setCheckForProxy :: Bool -> BrowserAction ()+setCheckForProxy flg = modify (\ b -> b{bsCheckProxy=flg})++-- | @getCheckForProxy@ returns the current check-proxy setting.+-- Notice that this may not be equal to @True@ if the session has+-- set it to that via 'setCheckForProxy' and subsequently performed+-- some HTTP protocol interactions. i.e., the flag return represents+-- whether a proxy will be checked for again before any future protocol+-- interactions.+getCheckForProxy :: BrowserAction Bool+getCheckForProxy = gets bsCheckProxy++-- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It+-- will be used if no explicit user agent header is found in subsequent requests.+--+-- A common form of user agent string is @\"name\/version (details)\"@. For+-- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version+-- of this HTTP package can be helpful if you ever need to track down HTTP+-- compatibility quirks. This version is available via 'httpPackageVersion'.+-- For more info see <http://en.wikipedia.org/wiki/User_agent>.+--+setUserAgent :: String -> BrowserAction ()+setUserAgent ua = modify (\b -> b{bsUserAgent=Just ua})++-- | @getUserAgent@ returns the current @User-Agent:@ default string.+getUserAgent :: BrowserAction (Maybe String)+getUserAgent = gets bsUserAgent++-- | @RequestState@ is an internal tallying type keeping track of various+-- per-connection counters, like the number of authorization attempts and+-- forwards we've gone through.+data RequestState+ = RequestState+ { reqDenies :: Int -- ^ number of 401 responses so far+ , reqRedirects :: Int -- ^ number of redirects so far+ , reqRetries :: Int -- ^ number of retries so far+ , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response+ }++type RequestID = Int -- yeah, it will wrap around.++nullRequestState :: RequestState+nullRequestState = RequestState+ { reqDenies = 0+ , reqRedirects = 0+ , reqRetries = 0+ , reqStopOnDeny = True+ }++-- | @BrowserEvent@ is the event record type that a user-defined handler, set+-- via 'setEventHandler', will be passed. It indicates various state changes+-- encountered in the processing of a given 'RequestID', along with timestamps+-- at which they occurred.+data BrowserEvent+ = BrowserEvent+ { browserTimestamp :: UTCTime+ , browserRequestID :: RequestID+ , browserRequestURI :: {-URI-}String+ , browserEventType :: BrowserEventType+ }++-- | 'BrowserEventType' is the enumerated list of events that the browser+-- internals will report to a user-defined event handler.+data BrowserEventType+ = OpenConnection+ | ReuseConnection+ | RequestSent+ | ResponseEnd ResponseData+ | ResponseFinish+{- not yet, you will have to determine these via the ResponseEnd event.+ | Redirect+ | AuthChallenge+ | AuthResponse+-}++-- | @setEventHandler onBrowserEvent@ configures event handling.+-- If @onBrowserEvent@ is @Nothing@, event handling is turned off;+-- setting it to @Just onEv@ causes the @onEv@ IO action to be+-- notified of browser events during the processing of a request+-- by the Browser pipeline.+setEventHandler :: Maybe (BrowserEvent -> BrowserAction ()) -> BrowserAction ()+setEventHandler mbH = modify (\b -> b { bsEvent=mbH})++buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent+buildBrowserEvent bt uri reqID = do+ ct <- getCurrentTime+ return BrowserEvent+ { browserTimestamp = ct+ , browserRequestID = reqID+ , browserRequestURI = uri+ , browserEventType = bt+ }++reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction ()+reportEvent bt uri = do+ st <- get+ case bsEvent st of+ Nothing -> return ()+ Just evH -> do+ evt <- liftIO $ buildBrowserEvent bt uri (bsRequestID st)+ evH evt -- if it fails, we fail.++-- | The default number of hops we are willing not to go beyond for+-- request forwardings.+defaultMaxRetries :: Int+defaultMaxRetries = 4++-- | The default number of error retries we are willing to perform.+defaultMaxErrorRetries :: Int+defaultMaxErrorRetries = 4++-- | The default maximum HTTP Authentication attempts we will make for+-- a single request.+defaultMaxAuthAttempts :: Int+defaultMaxAuthAttempts = 2++-- | The default setting for auto-proxy detection.+-- You may change this within a session via 'setAutoProxyDetect'.+-- To avoid initial backwards compatibility issues, leave this as @False@.+defaultAutoProxyDetect :: Bool+defaultAutoProxyDetect = False++-- | @request httpRequest@ tries to submit the 'Request' @httpRequest@+-- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.)+-- Upon successful delivery, the URL where the response was fetched from+-- is returned along with the 'Response' itself.+request :: Request+ -> BrowserAction (URI,Response)+request req = nextRequest $+ catchBrowseException+ (do res <- request' [] initialState req+ reportEvent ResponseFinish (show (rqURI req))+ return res)+ (\(e :: SomeException) -> do+ let errStr = "Network.Browser.request: Error raised " ++ show e+ err errStr+ Prelude.fail errStr)+ where+ initialState = nullRequestState++-- | Internal helper function, explicitly carrying along per-request+-- counts.+request' :: String+ -> RequestState+ -> Request+ -> BrowserAction (URI,Response)+request' nullVal rqState rq = do+ let uri = rqURI rq+ uria <- getAuth rq+ -- add cookies to request+ cookies <- getCookiesFor (uriAuthToString id (Just uria) "") (uriPath uri)+ when (not $ null cookies)+ (out $ "Adding cookies to request. Cookie names: " ++ unwords (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'' = if not $ null cookies then replaceHeader HdrCookie (renderCookie cookies) rq' else rq'+ p <- getProxy+ def_ua <- gets bsUserAgent+ let defaultOpts =+ case p of+ NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua}+ Proxy _ ath ->+ defaultNormalizeRequestOptions+ { normForProxy = True+ , normUserAgent = def_ua+ , normCustoms =+ maybe []+ (\authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])+ ath+ }+ let final_req = normalizeRequest defaultOpts rq''+ out ("Sending:\n" ++ show final_req)+ catchBrowseException+ (do rsp <- case p of+ NoProxy -> do auth <- getAuth rq''+ dorequest auth final_req+ Proxy str _ath -> do+ 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)++ out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth+ dorequest proxyURIAuth final_req+ + out ("Received:\n" ++ show rsp)+ -- add new cookies to browser state+ auth <- getAuth rq+ handleCookies uri (uriAuthToString id (Just auth) "")+ (retrieveHeaders HdrSetCookie rsp)+ -- Deal with "Connection: close" in response.+ handleConnectionClose auth (retrieveHeaders HdrConnection rsp)+ mbMxAuths <- getMaxAuthAttempts+ case rspCode rsp of+ 401 -- Credentials not sent or refused.+ | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> 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+ flg <- getAllowBasicAuth+ case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of+ Nothing -> do+ out "no challenge"+ return (uri,rsp) {- do nothing -}+ Just x -> do+ au <- challengeToAuthority uri x+ case au of+ Nothing -> do+ out "no auth"+ return (uri,rsp) {- do nothing -}+ Just au' -> do+ out "Retrying request with new credentials"+ request' nullVal+ rqState{ reqDenies = succ(reqDenies rqState)+ , reqStopOnDeny = False+ }+ (insertHeader HdrAuthorization (withAuthority au' rq) rq)++ 407 -- Proxy Authentication required+ | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> 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+ flg <- getAllowBasicAuth+ case pickChallenge flg (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 <- gets 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 = succ(reqDenies rqState)+ , reqStopOnDeny = False+ }+ rq++ code | code `elem` [301,302,303,307] -> do+ out (show code ++ " - redirect")+ allow_redirs <- allowRedirect rqState+ case allow_redirs of+ False -> return (uri,rsp)+ _ -> do+ 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+ | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do+ err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs)+ return (uri, rsp)+ | otherwise -> do+ out ("Redirecting to " ++ show newURI_abs ++ " ...")++ -- Redirect using GET request method, depending on+ -- response code.+ let toGet = code `elem` [302,303]+ method = if toGet then GET else rqMethod rq+ rq1 = rq { rqMethod=method, rqURI=newURI_abs }+ rq2 = if toGet then replaceHeader HdrContentLength "0" (rq1 {rqBody = nullVal}) else rq1++ request' nullVal+ rqState{ reqDenies = 0+ , reqRedirects = succ(reqRedirects rqState)+ , reqStopOnDeny = True+ }+ rq2+ where+ newURI_abs = uriDefaultTo newURI uri++ 305 ->+ 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 (uriAuthToString id (uriAuthority newuri) "") Nothing)+ request' nullVal+ rqState{ reqDenies = 0+ , reqRedirects = 0+ , reqRetries = succ (reqRetries rqState)+ , reqStopOnDeny = True+ }+ rq+ _ -> return (uri,rsp))+ (\e -> do+ mbMx <- getMaxErrorRetries+ if (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) &&+ (e == ErrorReset || e == ErrorClosed)+ then do --empty connnection pool in case connection has become invalid+ modify (\b -> b { bsConnectionPool=[] })+ request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq+ else liftIO (throwIO e))++-- | The internal request handling state machine.+dorequest :: URIAuth+ -> Request+ -> BrowserAction Response+dorequest auth rqst = do+ pool <- gets bsConnectionPool+ conn <- liftIO $ filterM (\c -> isTCPConnectedTo c (uriRegName auth) (uriAuthPort Nothing auth)) pool+ rsp <-+ case conn of+ [] -> do+ out ("Creating new connection to " ++ uriAuthToString id (Just auth) "")+ reportEvent OpenConnection (show (rqURI rqst))+ c <- liftIO $ openTCPConnection Nothing (uriRegName auth) (uriAuthPort Nothing auth)+ updateConnectionPool c+ dorequest2 c rqst+ (c:_) -> do+ out ("Recovering connection to " ++ uriAuthToString id (Just auth) "")+ reportEvent ReuseConnection (show (rqURI rqst))+ dorequest2 c rqst+ case rsp of+ Response a b c _ ->+ reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst))+ return rsp+ where+ dorequest2 c r = do+ st <- get+ let+ onSendComplete =+ maybe (return ())+ (\evh -> do+ x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)+ runBA st (evh x)+ return ())+ (bsEvent st)+ liftIO $ sendHTTP_notify c r onSendComplete++updateConnectionPool :: Connection -> BrowserAction ()+updateConnectionPool c = do+ pool <- gets bsConnectionPool+ let len_pool = length pool+ maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize+ when (len_pool > maxPoolSize)+ (liftIO $ close (last pool))+ let pool'+ | len_pool > maxPoolSize = init pool+ | otherwise = pool+ when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' })+ return ()++-- | Default maximum number of open connections we are willing to have active.+defaultMaxPoolSize :: Int+defaultMaxPoolSize = 5++cleanConnectionPool :: URIAuth -> BrowserAction ()+cleanConnectionPool auth = do+ pool <- gets bsConnectionPool+ bad <- liftIO $ mapM (\c -> isTCPConnectedTo c (uriRegName auth) (uriAuthPort Nothing auth)) pool+ let tmp = zip bad pool+ newpool = map snd $ filter (not . fst) tmp+ toclose = map snd $ filter fst tmp+ liftIO $ forM_ toclose close+ modify (\b -> b { bsConnectionPool = newpool })++handleCookies :: URI -> String -> [Header] -> BrowserAction ()+handleCookies _ _ [] = return () -- cut short the silliness.+handleCookies uri dom cookieHeaders = do+ when (not $ null errs)+ (err $ unlines ("Errors parsing these cookie values: ":errs))+ when (not $ null newCookies)+ (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies)+ filterfn <- getCookieFilter+ newCookies' <- liftIO (filterM (filterfn uri) newCookies)+ when (not $ null newCookies')+ (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies'))+ mapM_ addCookie newCookies'+ where+ (errs, newCookies) = processSetCookies cookieHeaders++handleConnectionClose :: URIAuth -> [Header] -> BrowserAction ()+handleConnectionClose _ [] = return ()+handleConnectionClose uri headers = do+ let doClose = any (== "close") $ map headerToConnType headers+ when doClose $ cleanConnectionPool uri+ where headerToConnType (Header _ t) = map toLower t++------------------------------------------------------------------+----------------------- Miscellaneous ----------------------------+------------------------------------------------------------------++allowRedirect :: RequestState -> BrowserAction Bool+allowRedirect rqState = do+ rd <- getAllowRedirects+ mbMxRetries <- getMaxRedirects+ return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries))++-- | Return @True@ iff the package is able to handle requests and responses+-- over it.+supportedScheme :: URI -> Bool+supportedScheme u = uriScheme u == "http:"++-- | @uriDefaultTo a b@ returns a URI that is consistent with the first+-- argument URI @a@ when read in the context of the second URI @b@.+-- If the second argument is not sufficient context for determining+-- a full URI then anarchy reins.+uriDefaultTo :: URI -> URI -> URI+#if MIN_VERSION_network(2,4,0)+uriDefaultTo a b = a `relativeTo` b+#else+uriDefaultTo a b = maybe a id (a `relativeTo` b)+#endif+++-- 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)+++-- 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+ urlEncode = escapeURIString isUnescapedInURI+urlEncodeVars [] = []++++#if MIN_VERSION_network_uri(2,6,2)+#else+#endif
+ Network/FastCGI.hs view
@@ -0,0 +1,589 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, ScopedTypeVariables, CPP #-}+module Network.FastCGI+ ( module Network.HTTP.Base,+ module Network.HTTP.Headers,++ -- * Accepting requests+ simpleFastCGI,++ -- * Environment+ Env,+ getDocumentRoot,+ getGatewayInterface,+ getPathInfo,+ getPathTranslated,+ getQueryString,+ getRedirectStatus,+ getRedirectURI,+ getRemoteAddress,+ getRemotePort,+ getRemoteHost,+ getRemoteIdent,+ getRemoteUser,+ getScriptFilename,+ getScriptName,+ getServerAddress,+ getServerName,+ getServerPort,+ getServerProtocol,+ getServerSoftware,+ getAuthenticationType,++ -- * Low-level API+ Connection,+ fastCGI,+ writeResponse,+ writeHeaders,+ writeString,+ writeByteString,+ close+ ) where++import Control.Concurrent+import Control.Exception ( bracket, catch )+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Char8 as BSC (unpack, pack)+import Data.Char+import Data.Maybe ( fromMaybe )+import qualified Data.Map as Map+import qualified Network.Socket as Socket hiding (recv)+import qualified Network.Socket.ByteString as Socket+import Network.URI ( URI(..), URIAuth(..)+#if MIN_VERSION_network_uri(2,6,2)+ , nullURI, nullURIAuth+#endif+ , parseURIReference )+import Network.HTTP.Base+import Network.HTTP.Headers+import Network.HTTP.Utils ( parseInt, trim, encodeString, decodeString )+import System.IO ( TextEncoding, latin1 )++-- | An opaque type representing the state of a single connection from the web server.+data FastCGIState = FastCGIState {+ fcgiSocket :: Socket.Socket,+ fcgiPeer :: Socket.SockAddr,+ fcgiRequests :: Map.Map Int PartialRequest+ }+ +type Env = [(String,String)]++data PartialRequest = PartialRequest {+ prqEnv :: Env,+ prqParamsBuf :: BS.ByteString,+ prqEncoding :: TextEncoding,+ prqBody :: [String],+ prqReq :: Request+ }++data Record = Record {+ recordType :: RecordType,+ recordRequestID :: Int,+ recordContent :: BS.ByteString+ } deriving (Show)++data RecordType = BeginRequestRecord+ | AbortRequestRecord+ | EndRequestRecord+ | ParamsRecord+ | StdinRecord+ | StdoutRecord+ | StderrRecord+ | DataRecord+ | GetValuesRecord+ | GetValuesResultRecord+ | UnknownTypeRecord+ | OtherRecord Int+ deriving (Eq, Show)++instance Enum RecordType where+ toEnum 1 = BeginRequestRecord+ toEnum 2 = AbortRequestRecord+ toEnum 3 = EndRequestRecord+ toEnum 4 = ParamsRecord+ toEnum 5 = StdinRecord+ toEnum 6 = StdoutRecord+ toEnum 7 = StderrRecord+ toEnum 8 = DataRecord+ toEnum 9 = GetValuesRecord+ toEnum 10 = GetValuesResultRecord+ toEnum 11 = UnknownTypeRecord+ toEnum code = OtherRecord code++ fromEnum BeginRequestRecord = 1+ fromEnum AbortRequestRecord = 2+ fromEnum EndRequestRecord = 3+ fromEnum ParamsRecord = 4+ fromEnum StdinRecord = 5+ fromEnum StdoutRecord = 6+ fromEnum StderrRecord = 7+ fromEnum DataRecord = 8+ fromEnum GetValuesRecord = 9+ fromEnum GetValuesResultRecord = 10+ fromEnum UnknownTypeRecord = 11+ fromEnum (OtherRecord code) = code+++-- | Takes a handler, and concurrently accepts requests from the web server+-- by calling the handler.+simpleFastCGI+ :: (Env -> Request -> IO Response)+ -- ^ A handler which is invoked once for each incoming connection.+ -> IO ()+ -- ^ Never actually returns.+simpleFastCGI handler = do+ fastCGI $ \env rq conn -> do+ rsp <- handleErrors (fLog conn)+ (handler env rq)+ writeResponse conn rsp++-- | Takes a handler, and concurrently accepts requests from the web server+-- by calling the handler.+fastCGI+ :: (Env -> Request -> Connection -> IO ())+ -- ^ A handler which is invoked once for each incoming connection.+ -> IO ()+ -- ^ Never actually returns.+fastCGI handler = do+#if MIN_VERSION_network(3,0,0)+ listenSocket <- Socket.mkSocket 0+#else+ listenSocket <- Socket.mkSocket 0 Socket.AF_INET Socket.Stream Socket.defaultProtocol Socket.Listening+#endif+ let acceptLoop' = do+ (socket, peer) <- Socket.accept listenSocket+ let state = FastCGIState {+ fcgiSocket = socket,+ fcgiPeer = peer,+ fcgiRequests = Map.empty+ }+ requestLoop state handler+ acceptLoop'+ acceptLoop'++data Connection = Connection FastCGIState Int++requestLoop :: FastCGIState -> (Env -> Request -> Connection -> IO ()) -> IO ()+requestLoop state handler = do+ maybeRecord <- recvRecord state+ case maybeRecord of+ Nothing -> do+ Socket.close (fcgiSocket state)+ Just record -> do+ let conn = Connection state (recordRequestID record)+ case recordType record of+ BeginRequestRecord -> do+ let req = Request { rqURI=nullURI+ , rqMethod = GET+ , rqHeaders = []+ , rqBody = ""+ }+ prq = PartialRequest { prqEnv = []+ , prqParamsBuf = BS.empty+ , prqEncoding = latin1+ , prqBody = []+ , prqReq = req+ }+ state' = state{fcgiRequests=Map.insert + (recordRequestID record)+ prq+ (fcgiRequests state)+ }+ requestLoop state' handler+ GetValuesRecord -> do+ fLog conn ("Get values record: " ++ show record)+ requestLoop state handler+ ParamsRecord -> do+ let requestID = recordRequestID record+ case Map.lookup requestID (fcgiRequests state) of+ Nothing -> fLog conn ("Ignoring record for unknown request ID " ++ show requestID)+ Just prq+ | BS.length (recordContent record) == 0 -> do+ enc <- getEncoding (rqHeaders (prqReq prq))+ let state' = state{fcgiRequests=Map.insert + requestID+ prq{prqEncoding=enc}+ (fcgiRequests state)}+ requestLoop state' handler+ | otherwise -> do+ let takeUntilEmpty prq bufferTail =+ case takeNameValuePair bufferTail of+ Nothing -> return prq{prqParamsBuf=bufferTail}+ Just ((name, value), bufferTail) -> do+ let name' = BSC.unpack name+ value' = BSC.unpack value+ prq' = processRequestVariable name' value' prq+ takeUntilEmpty prq' bufferTail+ prq <- takeUntilEmpty+ prq+ (BS.append (prqParamsBuf prq)+ (recordContent record))+ let state' = state{fcgiRequests=Map.insert + requestID+ prq+ (fcgiRequests state)}+ requestLoop state' handler+ StdinRecord -> do+ let requestID = recordRequestID record+ case Map.lookup requestID (fcgiRequests state) of+ Nothing -> + fLog conn ("Ignoring record for unknown request ID " ++ show requestID)+ Just prq+ | BS.length (recordContent record) == 0 -> do+ forkIO $+ handler (prqEnv prq)+ (prqReq prq){rqBody=concat (reverse (prqBody prq))}+ conn+ let state' = state{fcgiRequests=Map.delete+ requestID+ (fcgiRequests state)}+ requestLoop state' handler+ | otherwise -> do+ s <- decodeString (prqEncoding prq)+ (recordContent record)+ let prq' = prq{prqBody=s:prqBody prq}+ state' = state{fcgiRequests=Map.insert requestID+ prq'+ (fcgiRequests state)}+ requestLoop state' handler+ OtherRecord unknownCode -> do+ sendRecord state $ Record {+ recordType = UnknownTypeRecord,+ recordRequestID = 0,+ recordContent = BS.pack [fromIntegral unknownCode,+ 0, 0, 0, 0, 0, 0, 0]+ }+ _ -> fLog conn ("Ignoring record of unexpected type "++show (recordType record))++{-+ sendRecord state $ Record {+ recordType = EndRequestRecord,+ recordRequestID = requestID,+ recordContent = BS.pack [0, 0, 0, 0, 0, 0, 0, 0]+ }+-}++#if MIN_VERSION_network_uri(2,6,2)+#else+-- |Blank URI+nullURI :: URI+nullURI = URI+ { uriScheme = ""+ , uriAuthority = Nothing+ , uriPath = ""+ , uriQuery = ""+ , uriFragment = ""+ }++-- |Blank URIAuth.+nullURIAuth :: URIAuth+nullURIAuth = URIAuth+ { uriUserInfo = ""+ , uriRegName = ""+ , uriPort = ""+ }+#endif++processRequestVariable :: String -> String -> PartialRequest -> PartialRequest+processRequestVariable "REQUEST_METHOD" value prq =+ prq{prqReq=(prqReq prq){rqMethod=parseRequestMethod value}}+processRequestVariable "REQUEST_URI" value prq =+ let rq = prqReq prq+ uri = rqURI rq+ sch = uriScheme uri+ auth = uriAuthority uri+ in case parseURIReference value of+ Just uri -> prq{prqReq=rq{rqURI=uri{uriScheme=sch,uriAuthority=auth}}}+ Nothing -> prq+processRequestVariable "SERVER_NAME" value prq =+ let rq = prqReq prq+ uri = rqURI rq+ auth = fromMaybe nullURIAuth (uriAuthority uri)+ in prq{prqReq=rq{rqURI=uri{uriAuthority=Just auth{uriRegName=value}}}}+processRequestVariable "SERVER_PORT" value prq =+ let rq = prqReq prq+ uri = rqURI rq+ auth = fromMaybe nullURIAuth (uriAuthority uri)+ in case value of+ "80" -> prq{prqReq=rq{rqURI=uri{uriScheme="http:"}}}+ "443" -> prq{prqReq=rq{rqURI=uri{uriScheme="https:"}}}+ _ -> prq{prqReq=rq{rqURI=uri{uriAuthority=Just auth{uriPort=':':value}}}}+processRequestVariable "QUERY_STRING" value prq =+ prq+processRequestVariable name value prq =+ case variableToHeaderName name of+ Nothing -> prq{prqEnv=(name,value) : prqEnv prq}+ Just header -> prq{prqReq=insertHeader header value (prqReq prq)}++recvRecord :: FastCGIState -> IO (Maybe Record)+recvRecord state = do+ byteString <- recvAll (fcgiSocket state) 8+ case BS.length byteString of+ 8 -> do+ let recordVersion = BS.index byteString 0+ recordTypeCode = fromIntegral $ BS.index byteString 1+ recordRequestIDB1 = BS.index byteString 2+ recordRequestIDB0 = BS.index byteString 3+ recordRequestID = (fromIntegral recordRequestIDB1) * 256+ + (fromIntegral recordRequestIDB0)+ recordContentLengthB1 = BS.index byteString 4+ recordContentLengthB0 = BS.index byteString 5+ recordContentLength = (fromIntegral recordContentLengthB1) * 256+ + (fromIntegral recordContentLengthB0)+ recordPaddingLength = BS.index byteString 6+ if recordVersion /= 1+ then return Nothing+ else do+ let recordType = toEnum recordTypeCode+ recordContent <- recvAll (fcgiSocket state) recordContentLength+ recvAll (fcgiSocket state) (fromIntegral recordPaddingLength)+ return (Just (Record {+ recordType = recordType,+ recordRequestID = recordRequestID,+ recordContent = recordContent+ }))+ _ -> return Nothing+++sendRecord :: FastCGIState -> Record -> IO ()+sendRecord state record = do+ let recordRequestIDB0 = fromIntegral $ recordRequestID record `mod` 256+ recordRequestIDB1 = fromIntegral $ (recordRequestID record `div` 256) `mod` 256+ recordContentLength = BS.length $ recordContent record+ recordContentLengthB0 = fromIntegral $ recordContentLength `mod` 256+ recordContentLengthB1 = fromIntegral $ (recordContentLength `div` 256) `mod` 256+ headerByteString = BS.pack [1,+ fromIntegral $ fromEnum $ recordType record,+ recordRequestIDB1,+ recordRequestIDB0,+ recordContentLengthB1,+ recordContentLengthB0,+ 0,+ 0]+ byteString = BS.append headerByteString $ recordContent record+ Socket.sendAll (fcgiSocket state) byteString++recvAll :: Socket.Socket -> Int -> IO BS.ByteString+recvAll socket totalSize = do+ if totalSize == 0+ then return BS.empty+ else do+ byteString <- Socket.recv socket totalSize+ case BS.length byteString of+ 0 -> return byteString+ receivedSize | receivedSize == totalSize -> return byteString+ | otherwise -> do+ restByteString+ <- recvAll socket (totalSize - receivedSize)+ return (BS.append byteString restByteString)+++takeLength :: BS.ByteString -> Maybe (Int, BS.ByteString)+takeLength byteString+ = if BS.length byteString < 1+ then Nothing+ else let firstByte = BS.index byteString 0+ threeMoreComing = (firstByte .&. 0x80) == 0x80+ in if threeMoreComing+ then if BS.length byteString < 4+ then Nothing+ else let secondByte = BS.index byteString 1+ thirdByte = BS.index byteString 2+ fourthByte = BS.index byteString 3+ decoded = ((fromIntegral $ firstByte .&. 0x7F)+ `shiftL` 24)+ + (fromIntegral secondByte `shiftL` 16)+ + (fromIntegral thirdByte `shiftL` 8)+ + (fromIntegral fourthByte)+ in Just (decoded, BS.drop 4 byteString)+ else Just (fromIntegral firstByte, BS.drop 1 byteString)++takeNameValuePair :: BS.ByteString+ -> Maybe ((BS.ByteString, BS.ByteString), BS.ByteString)+takeNameValuePair byteString+ = let maybeNameLength = takeLength byteString+ in case maybeNameLength of+ Nothing -> Nothing+ Just (nameLength, byteString')+ -> let maybeValueLength = takeLength byteString'+ in case maybeValueLength of+ Nothing -> Nothing+ Just (valueLength, byteString'')+ -> let name = BS.take nameLength byteString''+ byteString''' = BS.drop nameLength byteString''+ value = BS.take valueLength byteString'''+ byteString'''' = BS.drop valueLength byteString'''+ in Just ((name, value), byteString'''')++-- | Logs a message using the web server's logging facility.+fLog :: Connection -> String -> IO ()+fLog (Connection state requestID) message+ | length message > 0 =+ sendRecord state $ Record {+ recordType = StderrRecord,+ recordRequestID = requestID,+ recordContent = BSC.pack message+ }+ | otherwise = return ()+++-- | Return the document root, as provided by the web server, if it was provided.+getDocumentRoot :: Env -> Maybe String+getDocumentRoot = lookup "DOCUMENT_ROOT"+++-- | Return the gateway interface, as provided by the web server, if it was provided.+getGatewayInterface :: Env -> Maybe String+getGatewayInterface = lookup "GATEWAY_INTERFACE"+++-- | Return the path info, as provided by the web server, if it was provided.+getPathInfo :: Env -> Maybe String+getPathInfo = lookup "PATH_INFO"++-- | Return the path-translated value, as provided by the web server, if it was provided.+getPathTranslated :: Env -> Maybe String+getPathTranslated = lookup "PATH_TRANSLATED"+++-- | Return the query string, as provided by the web server, if it was provided.+getQueryString :: Env -> Maybe String+getQueryString = lookup "QUERY_STRING"+++-- | Return the redirect status, as provided by the web server, if it was provided.+getRedirectStatus :: Env -> Maybe Int+getRedirectStatus env = lookup "REDIRECT_STATUS" env >>= parseInt+++-- | Return the redirect URI, as provided by the web server, if it was provided.+getRedirectURI :: Env -> Maybe String+getRedirectURI = lookup "REDIRECT_URI"+++-- | Return the remote address, as provided by the web server, if it was provided.+getRemoteAddress :: Env -> Maybe String+getRemoteAddress = lookup "REMOTE_ADDR"+++-- | Return the remote port, as provided by the web server, if it was provided.+getRemotePort :: Env -> Maybe Int+getRemotePort env = lookup "REMOTE_PORT" env >>= parseInt+++-- | Return the remote hostname, as provided by the web server, if it was provided.+getRemoteHost :: Env -> Maybe String+getRemoteHost = lookup "REMOTE_HOST"+++-- | Return the remote ident value, as provided by the web server, if it was provided.+getRemoteIdent :: Env -> Maybe String+getRemoteIdent = lookup "REMOTE_IDENT"+++-- | Return the remote user name, as provided by the web server, if it was provided.+getRemoteUser :: Env -> Maybe String+getRemoteUser = lookup "REMOTE_USER"+++-- | Return the script filename, as provided by the web server, if it was provided.+getScriptFilename :: Env -> Maybe String+getScriptFilename = lookup "SCRIPT_FILENAME"+++-- | Return the script name, as provided by the web server, if it was provided.+getScriptName :: Env -> Maybe String+getScriptName = lookup "SCRIPT_NAME"+++-- | Return the server address, as provided by the web server, if it was provided.+getServerAddress :: Env -> Maybe String+getServerAddress = lookup "SERVER_ADDR"+++-- | Return the server name, as provided by the web server, if it was provided.+getServerName :: Env -> Maybe String+getServerName = lookup "SERVER_NAME"+++-- | Return the server port, as provided by the web server, if it was provided.+getServerPort :: Env -> Maybe Int+getServerPort env = lookup "SERVER_PORT" env >>= parseInt+++-- | Return the server protocol, as provided by the web server, if it was provided.+getServerProtocol :: Env -> Maybe String+getServerProtocol = lookup "SERVER_PROTOCOL"+++-- | Return the server software name and version, as provided by the web server, if+-- it was provided.+getServerSoftware :: Env -> Maybe String+getServerSoftware = lookup "SERVER_SOFTWARE"+++-- | Return the authentication type, as provided by the web server, if it was provided.+getAuthenticationType :: Env -> Maybe String+getAuthenticationType = lookup "AUTH_TYPE"+++sendBuffer :: FastCGIState -> Int -> BS.ByteString -> IO ()+sendBuffer state requestID buffer = do+ let len = BS.length buffer+ lengthThisRecord = min len 0xFFFF+ bufferThisRecord = BS.take lengthThisRecord buffer+ bufferRemaining = BS.drop lengthThisRecord buffer+ if lengthThisRecord > 0+ then sendRecord state $ Record {+ recordType = StdoutRecord,+ recordRequestID = requestID,+ recordContent = bufferThisRecord+ }+ else return ()+ if len > lengthThisRecord+ then sendBuffer state requestID bufferRemaining+ else return ()++writeResponse :: Connection -> Response -> IO ()+writeResponse conn rsp = do+ enc <- getEncoding (rspHeaders rsp)+ lbs <- encodeString enc (rspBody rsp)+ let rsp' = normalizeResponse (Just (LBS.length lbs)) rsp+ writeHeaders conn rsp'+ mapM_ (writeByteString conn) (LBS.toChunks lbs)++writeHeaders :: Connection -> Response -> IO ()+writeHeaders (Connection state requestID) rsp = do+ let status = show (rspCode rsp)+ headers = rspHeaders rsp+ nameValuePairs = ("Status", status) :+ map (\(Header hdr val) -> (show hdr,val))+ headers+ bytestrings+ = map (\(name, value) -> BSC.pack $ name ++ ": " ++ value ++ "\r\n")+ nameValuePairs+ ++ [BSC.pack "\r\n"]+ buffer = foldl BS.append BS.empty bytestrings+ sendBuffer state requestID buffer++writeString :: Connection -> TextEncoding -> String -> IO ()+writeString conn enc s = do + lbs <- encodeString enc s+ mapM_ (writeByteString conn) (LBS.toChunks lbs)++writeByteString :: Connection -> BS.ByteString -> IO ()+writeByteString (Connection state requestID) bs =+ sendRecord state $ Record {+ recordType = StdoutRecord,+ recordRequestID = requestID,+ recordContent = bs+ }++close :: Connection -> IO ()+close (Connection state requestID) = do+ sendRecord state $ Record {+ recordType = EndRequestRecord,+ recordRequestID = requestID,+ recordContent = BS.pack [0, 0, 0, 0, 0, 0, 0, 0]+ }
+ Network/HTTP.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- The 'Network.HTTP' module provides a simple interface for sending and+-- receiving content over HTTP in Haskell. Here's how to fetch a document from+-- a URL and return it as a String:+--+-- >+-- > do rsp <- simpleHTTP (getRequest "http://www.haskell.org/")+-- > return (rspBody rsp)+-- > -- fetch document and return it (as a 'String'.)+--+-- Other functions let you control the submission and transfer of HTTP+-- 'Request's and 'Response's more carefully, letting you integrate the use+-- of 'Network.HTTP' functionality into your application.+--+-- The module also exports the main types of the package, 'Request' and 'Response',+-- along with 'Header' and functions for working with these.+--+-- The actual functionality is implemented by modules in the @Network.HTTP.*@+-- namespace, letting you either use the default implementation here+-- by importing @Network.HTTP@ or, for more specific uses, selectively+-- import the modules in @Network.HTTP.*@. To wit, more than one kind of+-- representation of the bulk data that flows across a HTTP connection is+-- supported. (see "Network.HTTP.Connection".)+--+-- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission.+-- Normalization such as having the request path be in the expected form and, possibly,+-- introduce a default @Host:@ header if one isn't already present.+-- Normalization also takes the @"user:pass\@"@ portion out of the the URI,+-- if it was supplied, and converts it into @Authorization: Basic@ header.+-- If you do not+-- want the requests tampered with, but sent as-is, please import and use the+-- the "Network.HTTP.Connection" module instead. They+-- export the same functions, but leaves construction and any normalization of+-- @Request@s to the user.+-----------------------------------------------------------------------------+module Network.HTTP+ ( module Network.HTTP.Base+ , module Network.HTTP.Headers++ -- ** High-level API+ , simpleHTTP -- :: Request -> IO Response+ , simpleHTTP_ -- :: Connection -> Request -> IO Response+ , simpleServer -- :: SockAddr -> (Request -> IO Response) -> IO ()+ , simpleServerBind -- :: Int -> HostAddress -> (Request -> IO Response) -> IO ()++ , outputChunked+ , outputHTML+ , outputText+ , httpError++ -- ** Create requests+ , getRequest -- :: String -> Request+ , headRequest -- :: String -> Request+ , postRequest -- :: String -> Request++ -- ** Low-level API+ , Connection+ , openTCPConnection -- :: Maybe a0 -> String -> Int -> IO Connection+ , isTCPConnectedTo -- :: Connection -> String -> Int -> IO Bool+ , sendHTTP -- :: Connection -> Request -> IO Response+ , sendHTTP_notify -- :: Connection -> Request -> IO () -> IO Response+ , S.receiveHTTP -- :: Connection -> IO Request+ , S.respondHTTP -- :: Connection -> Response -> IO ()+ , S.writeHeaders -- :: Connection -> Response -> IO ()+ , writeAscii -- :: Connection -> String -> IO ()+ , writeBytes -- :: Connection -> Ptr Word8 -> Int -> IO ()+ , server -- :: Maybe Int -> Maybe (Int,FilePath,FilePath) -> (Connection -> IO ()) -> IO ()+ , serverBind -- :: Maybe Int -> Maybe (Int,FilePath,FilePath) -> HostAddress -> (Connection -> IO ()) -> IO ()+ , close -- :: Connection -> IO ()+ ) where++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Network.HTTP.Headers+import Network.HTTP.Base+import Network.HTTP.Utils ( crlf )+import qualified Network.HTTP.HandleStream as S ( sendHTTP, sendHTTP_notify,+ receiveHTTP, respondHTTP,+ writeHeaders )+import Network.TCP+import Network.URI ( parseURI, uriRegName )+import qualified Network.Socket as Socket+import Network.BSD (getProtocolNumber)+#if MIN_VERSION_network(3,0,0)+#else+import Network.Socket (iNADDR_ANY)+#endif+import Network.Socket (+ Socket, SockAddr(SockAddrInet),+ setSocketOption, socket)++import qualified OpenSSL.Session as SSL++import Control.Concurrent (forkIO)+import Control.Exception (finally,bracket,catch,throwIO)++import Numeric (showHex)+import Data.Maybe (isJust)++#if MIN_VERSION_network(3,0,0)+iNADDR_ANY :: Socket.HostAddress+iNADDR_ANY = Socket.tupleToHostAddress (0,0,0,0)+#endif+++-- | @simpleHTTP req@ transmits the 'Request' @req@ by opening a /direct/, non-persistent+-- connection to the HTTP server that @req@ is destined for, followed by transmitting+-- it and gathering up the 'Response'. Prior to sending the request,+-- it is normalized (via 'normalizeRequest'). If you have to mediate the request+-- via an HTTP proxy, you will have to normalize the request yourself. Or switch to+-- using 'Network.Browser' instead.+--+-- Examples:+--+-- > simpleHTTP (getRequest "http://hackage.haskell.org/")+-- > simpleHTTP (getRequest "http://hackage.haskell.org:8012/")++simpleHTTP :: Request -> IO Response+simpleHTTP r = do+ auth <- getAuth r+ ctxt <- getSSLContext (rqURI r)+ let host = uriRegName auth+ port = uriAuthPort (Just (rqURI r)) auth+ c <- openTCPConnection ctxt host port+ let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r+ S.sendHTTP c norm_r++-- | Identical to 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: Connection -> Request -> IO Response+simpleHTTP_ c r = do+ let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r+ S.sendHTTP c norm_r++-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ (after normalization) over+-- @hStream@, but does not alter the status of the connection, nor request it to be+-- closed upon receiving the response.+sendHTTP :: Connection -> Request -> IO Response+sendHTTP conn rq = do+ let norm_r = normalizeRequest defaultNormalizeRequestOptions rq+ S.sendHTTP conn norm_r++-- | @sendHTTP_notify conn httpRequest action@ behaves like 'sendHTTP', but+-- lets you supply an IO @action@ to execute once the request has been successfully+-- transmitted over the connection. Useful when you want to set up tracing of+-- request transmission and its performance.+sendHTTP_notify :: Connection+ -> Request+ -> IO ()+ -> IO Response+sendHTTP_notify conn rq onSendComplete = do+ let norm_r = normalizeRequest defaultNormalizeRequestOptions rq+ S.sendHTTP_notify conn norm_r onSendComplete++-- | A convenience constructor for a GET 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+getRequest+ :: String -- ^URL to fetch+ -> Request -- ^The constructed request+getRequest urlString =+ case parseURI urlString of+ Nothing -> error ("getRequest: Not a valid URL - " ++ urlString)+ Just u -> mkRequest GET u++-- | A convenience constructor for a HEAD 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+headRequest+ :: String -- ^URL to fetch+ -> Request -- ^The constructed request+headRequest urlString =+ case parseURI urlString of+ Nothing -> error ("headRequest: Not a valid URL - " ++ urlString)+ Just u -> mkRequest HEAD u++-- | A convenience constructor for a POST 'Request'.+--+-- If the URL isn\'t syntactically valid, the function raises an error.+postRequest+ :: String -- ^URL to POST to+ -> Request -- ^The constructed request+postRequest urlString =+ case parseURI urlString of+ Nothing -> error ("postRequest: Not a valid URL - " ++ urlString)+ Just u -> mkRequest POST u++simpleServer+ :: Maybe Int -- ^ http port+ -> Maybe (Int,FilePath,FilePath) -- ^ https port,private and public keys+ -> (Request -> IO Response) -- ^ The functionality of the Server+ -> IO ()+simpleServer mb_http_port mb_https_port callOut =+ simpleServerBind mb_http_port mb_https_port iNADDR_ANY callOut++simpleServerBind+ :: Maybe Int -- ^ http port+ -> Maybe (Int,FilePath,FilePath) -- ^ https port,private and public keys+ -> Socket.HostAddress -- ^ The host address+ -> (Request -> IO Response) -- ^ The functionality of the Server+ -> IO ()+simpleServerBind mb_http_port mb_https_port addr callOut = + serverBind mb_http_port mb_https_port addr + (\stream -> handleErrors putStrLn+ (S.receiveHTTP stream >>= callOut) >>=+ S.respondHTTP stream)++server+ :: Maybe Int -- ^ http port+ -> Maybe (Int,FilePath,FilePath) -- ^ https port,private and public keys+ -> (Connection -> IO ()) -- ^ The functionality of the Server+ -> IO ()+server mb_http_port mb_https_port callOut =+ serverBind mb_http_port mb_https_port iNADDR_ANY callOut++serverBind+ :: Maybe Int -- ^ http port+ -> Maybe (Int,FilePath,FilePath) -- ^ https port,private and public keys+ -> Socket.HostAddress -- ^ The host address+ -> (Connection -> IO ()) -- ^ The functionality of the Server+ -> IO ()+serverBind mb_http_port mb_https_port addr callOut = do+ case mb_https_port of+ Just (port,priv_key,cert_key)+ -> do ctxt <- SSL.context+ SSL.contextSetPrivateKeyFile ctxt priv_key+ SSL.contextSetCertificateFile ctxt cert_key++ let fork | isJust mb_http_port = \f -> forkIO f >> return ()+ | otherwise = id++ mkSSL sock = do+ ssl <- SSL.connection ctxt sock+ SSL.accept ssl+ return (Just ssl)++ fork (serverMain (SockAddrInet (fromIntegral port) addr) mkSSL callOut)+ Nothing -> return ()+ case mb_http_port of+ Just port -> do let noSSL sock = return Nothing+ serverMain (SockAddrInet (fromIntegral port) addr) noSSL callOut+ Nothing -> return ()++serverMain+ :: SockAddr+ -> (Socket -> IO (Maybe SSL.SSL))+ -> (Connection -> IO ())+ -> IO ()+serverMain sockaddr mkSSL callOut = do+ num <- getProtocolNumber "tcp"+ sock <- socket Socket.AF_INET Socket.Stream num+ setSocketOption sock Socket.ReuseAddr 1+ Socket.bind sock sockaddr+ Socket.listen sock Socket.maxListenQueue++ loopIO (do (acceptedSock,_) <- Socket.accept sock+ mb_ssl <- mkSSL acceptedSock++ forkIO $+ bracket (socketConnection "localhost" (fromIntegral num) acceptedSock mb_ssl)+ close+ callOut+ ) `finally` (Socket.close sock)+ where+ loopIO m = m >> loopIO m++outputChunked :: Int -> Response -> IO Response+outputChunked chunkSize resp@(Response{rspBody=body}) =+ return resp{rspHeaders = rspHeaders resp ++ [chunkedHdr]+ ,rspBody = foldr ($) "" $+ map (\str ->+ showHex (length str) . showString crlf .+ showString str . showString crlf)+ (slice chunkSize body) +++ -- terminating chunk+ showString "0" . showString crlf :+ -- terminating trailer+ showString crlf :+ []+ }+ where+ chunkedHdr = Header HdrTransferEncoding "chunked"++ slice :: Int -> [a] -> [[a]]+ slice n = map (take n) . takeWhile (not . null) . iterate (drop n)++outputHTML :: String -> IO Response+outputHTML html =+ return (Response+ { rspCode = 200+ , rspReason = "OK"+ , rspHeaders = [Header HdrContentType "text/html"]+ , rspBody = html+ })++outputText :: String -> IO Response+outputText text =+ return (Response+ { rspCode = 200+ , rspReason = "OK"+ , rspHeaders = [Header HdrContentType "text/plain; charset=UTF8"]+ , rspBody = text+ })++httpError :: ResponseCode -> String -> String -> IO a+httpError code reason body = throwIO (ErrorMisc code reason body)++--+-- * 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).
+ Network/HTTP/Auth.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Auth+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Representing HTTP Auth values in Haskell.+-- Right now, it contains mostly functionality needed by 'Network.Browser'.+--+-----------------------------------------------------------------------------+module Network.HTTP.Auth+ ( Authority(..)+ , Algorithm(..)+ , Challenge(..)+ , Qop(..)++ , headerToChallenge -- :: URI -> Header -> Maybe Challenge+ , withAuthority -- :: Authority -> Request ty -> String+ ) where++import Network.URI+import Network.HTTP.Base+import Network.HTTP.Utils+import Network.HTTP.Headers ( Header(..) )+import Network.HTTP.MD5 (md5ss)+import qualified Network.HTTP.Base64 as Base64 (encode)+import Text.ParserCombinators.Parsec+ ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 )+import System.IO ( utf8 )++import Data.Char+import Data.Maybe+import Data.Word ( Word8 )++-- | @Authority@ specifies the HTTP Authentication method to use for+-- a given domain/realm; @Basic@ or @Digest@.+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]+ }+++data Challenge+ = ChalBasic { chRealm :: String }+ | ChalDigest { chRealm :: String+ , chDomain :: [URI]+ , chNonce :: String+ , chOpaque :: Maybe String+ , chStale :: Bool+ , chAlgorithm ::Maybe Algorithm+ , chQop :: [Qop]+ }++-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@.+data Algorithm = AlgMD5 | AlgMD5sess+ deriving(Eq)++instance Show Algorithm where+ show AlgMD5 = "md5"+ show AlgMD5sess = "md5-sess"++-- |+data Qop = QopAuth | QopAuthInt+ deriving(Eq,Show)++-- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority',+-- in the context of the given request.+--+-- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String+withAuthority :: Authority -> Request -> String+withAuthority a rq = case a of+ AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a)+ AuthDigest{} ->+ "Digest " +++ concat [ "username=" ++ quo (auUsername a)+ , ",realm=" ++ quo (auRealm a)+ , ",nonce=" ++ quo (auNonce a)+ , ",uri=" ++ quo digesturi+ , ",response=" ++ quo rspdigest+ -- plus optional stuff:+ , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))+ , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a))+ , if null (auQop a) then "" else ",qop=auth"+ ]+ where+ quo s = '"':s ++ "\""++ rspdigest = map toLower (kd (md5ss utf8 a1) (noncevalue ++ ":" ++ md5ss utf8 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++type Octet = Word8++-- FIXME: these probably only work right for latin-1 strings+stringToOctets :: String -> [Octet]+stringToOctets = map (fromIntegral . fromEnum)++base64encode :: String -> String+base64encode = Base64.encode . stringToOctets++kd :: String -> String -> String+kd a b = md5ss utf8 (a ++ ":" ++ b)+++++-- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header+-- @www_auth@ into a 'Challenge' value.+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]+#if MIN_VERSION_network(2,4,0)+ annotateURIs = map (`relativeTo` baseURI) . catMaybes+#else+ annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes+#endif++ -- 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++word, quotedstring :: Parser String+quotedstring =+ do { _ <- char '"' -- "+ ; str <- many (satisfy $ not . (=='"'))+ ; _ <- char '"'+ ; return str+ }++word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))
+ Network/HTTP/Base.hs view
@@ -0,0 +1,727 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Base+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Definitions of @Request@ and @Response@ types along with functions+-- for normalizing them. It is assumed to be an internal module; user+-- code should, if possible, import @Network.HTTP@ to access the functionality+-- that this module provides.+--+-- Additionally, the module exports internal functions for working with URLs,+-- and for handling the processing of requests and responses coming back.+--+-----------------------------------------------------------------------------+module Network.HTTP.Base+ (+ -- ** Constants+ httpVersion -- :: String++ -- ** HTTP+ , Request(..)+ , Response(..)+ , RequestMethod(..)++ , parseResponseHead+ , parseRequestHead+ , parseRequestMethod+ + , HttpError(..)++ , ResponseNextStep(..)+ , matchResponse+ , ResponseData+ , ResponseCode+ , RequestData++ , NormalizeRequestOptions(..)+ , defaultNormalizeRequestOptions+ , RequestNormalizer++ , normalizeRequest+ , normalizeResponse++ , splitRequestURI++ , getAuth+ , uriAuthPort+ , findConnClose++ , rqQuery, Query(..)++ , defaultGETRequest+ , mkRequest++ , httpPackageVersion++ , getRequestVersion+ , getResponseVersion+ , setRequestVersion+ , setResponseVersion++ , getSSLContext+ + , handleErrors++#if MIN_VERSION_network_uri(2,6,2)+#else+ , uriAuthToString+#endif+ ) where++import Network.URI+ ( URI(uriAuthority, uriPath, uriScheme)+ , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort)+ , parseURIReference+#if MIN_VERSION_network_uri(2,6,2)+ , uriAuthToString+#endif+ )++import Control.Monad ( guard, mplus )+import Control.Exception ( SomeException, catch )++import Data.Word ( Word8 )+import Data.Int ( Int64 )+import Data.Char ( chr, digitToInt, intToDigit, toLower, isDigit, isHexDigit )+import Data.List ( find )+import Data.Maybe ( listToMaybe, fromMaybe )+import Data.Bits++import Network.URI ( uriQuery )+import Network.HTTP.Headers+import Network.HTTP.Cookie ( renderSetCookie, renderCookie )+import Network.HTTP.Utils ( trim, crlf, sp, + HttpError(..), readsOne )+import qualified Network.HTTP.Base64 as Base64 (encode)++import Text.Read.Lex (readDecP)+import Text.ParserCombinators.ReadP+ ( ReadP, readP_to_S, char, (<++), look, munch, munch1, sepBy )++import qualified Paths_http_slim as Self (version)+import Data.Version (showVersion)++import qualified OpenSSL.Session as SSL++-----------------------------------------------------------------+------------------ URI Authority parsing ------------------------+-----------------------------------------------------------------++-- | 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 URIAuth+parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))+++pURIAuthority :: ReadP URIAuth+pURIAuthority = do+ u <- pUserInfo `before` char '@'+ h <- rfc2732host <++ munch (/=':')+ p <- (char ':' >> fmap (\(p :: Int) -> ':':show p) readDecP) <++ return ""+ look >>= guard . null+ return URIAuth{ uriUserInfo=u, uriRegName=h, uriPort=p }++-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL+rfc2732host :: ReadP String+rfc2732host = do+ _ <- char '['+ res <- munch1 (/=']')+ _ <- char ']'+ return res++pUserInfo :: ReadP String+pUserInfo = munch (/='@')++before :: Monad m => m a -> m b -> m a+before a b = a >>= \x -> b >> return x++-----------------------------------------------------------------+------------------ 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 | CONNECT | Custom String+ deriving(Eq)++instance Show RequestMethod where+ show x =+ case x of+ HEAD -> "HEAD"+ PUT -> "PUT"+ GET -> "GET"+ POST -> "POST"+ DELETE -> "DELETE"+ OPTIONS -> "OPTIONS"+ TRACE -> "TRACE"+ CONNECT -> "CONNECT"+ Custom c -> c++parseRequestMethod :: String -> RequestMethod+parseRequestMethod s = fromMaybe (Custom s) (lookup s rqMethodMap)++rqMethodMap :: [(String, RequestMethod)]+rqMethodMap = [("HEAD", HEAD),+ ("PUT", PUT),+ ("GET", GET),+ ("POST", POST),+ ("DELETE", DELETE),+ ("OPTIONS", OPTIONS),+ ("TRACE", TRACE),+ ("CONNECT", CONNECT)]++-- | An HTTP Request.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output.+data Request =+ Request { rqURI :: URI -- ^ might need changing in future+ -- 1) to support '*' uri in OPTIONS request+ -- 2) transparent support for both relative+ -- & absolute uris, although this should+ -- already work (leave scheme & host parts empty).+ , rqMethod :: RequestMethod+ , rqHeaders :: [Header]+ , rqBody :: String+ }++-- Notice that request body is not included,+-- this show function is used to serialise+-- a request for the transport link, we send+-- the body separately where possible.+instance Show Request where+ show req@(Request u m h _) =+ show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf+ ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf+ where+ ver = fromMaybe httpVersion (getRequestVersion req)+ 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 }++ getCookies rq = fromMaybe [] (processCookie "" (rqHeaders rq))+ where+ path = uriPath (rqURI rq)+ dom = if null path || head path /= '/'+ then '/' : path+ else path+ setCookies rq cookies = replaceHeader HdrCookie (renderCookie cookies) rq++-- | For easy pattern matching, HTTP response codes @xyz@ are+-- represented as @(x,y,z)@.+type ResponseCode = 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 auxiliary/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 Response =+ Response { rspCode :: ResponseCode+ , rspReason :: String+ , rspHeaders :: [Header]+ , rspBody :: String+ }++-- This is an invalid representation of a received response,+-- since we have made the assumption that all responses are HTTP/1.1+instance Show Response where+ show rsp@(Response code reason headers _) =+ ver ++ ' ' : show code ++ ' ' : reason ++ crlf +++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf+ where+ ver = fromMaybe httpVersion (getResponseVersion rsp)++instance HasHeaders Response where+ getHeaders = rspHeaders+ setHeaders rsp hdrs = rsp { rspHeaders=hdrs }++ getCookies rsp = snd (processSetCookies (rspHeaders rsp))+ setCookies rsp cookies = replaceHeaders HdrSetCookie [renderSetCookie cookie | cookie <- cookies] rsp+++------------------------------------------------------------------+------------------ Request Building ------------------------------+------------------------------------------------------------------++-- | A default user agent string. The string is @\"haskell-http-slim/$version\"@+-- where @$version@ is the version of this HTTP package.+--+defaultUserAgent :: String+defaultUserAgent = "haskell-http-slim/" ++ httpPackageVersion++-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This+-- may be useful to include in a user agent string so that you can determine+-- from server logs what version of this package HTTP clients are using.+-- This can be useful for tracking down HTTP compatibility quirks.+--+httpPackageVersion :: String+httpPackageVersion = showVersion Self.version++defaultGETRequest :: URI -> Request+defaultGETRequest uri = mkRequest GET uri++-- | 'mkRequest method uri' constructs a well formed+-- request for the given HTTP method and URI. It does not+-- normalize the URI for the request _nor_ add the required+-- Host: header. That is done either explicitly by the user+-- or when requests are normalized prior to transmission.+mkRequest :: RequestMethod -> URI -> Request+mkRequest meth uri = req+ where+ req =+ Request { rqURI = uri+ , rqBody = ""+ , rqHeaders = [Header HdrUserAgent defaultUserAgent]+ , rqMethod = meth+ }++type Query = [(String,String)]++-- | Decode application/x-www-form-urlencoded+rqQuery :: Request -> Query+rqQuery rq =+ case [q | (q,"") <- qparse] of+ [q] -> q+ _ -> []+ where+ qparse =+ case findHeader HdrContentType rq of+ Just "application/x-www-form-urlencoded" -> readP_to_S pQuery (rqBody rq)+ _ -> readP_to_S (char '?' >> pQuery) (uriQuery (rqURI rq))++ pQuery = sepBy param (char '&')+ param = do+ var <- munch (\c -> c /= '=' && c /= '&')+ (do char '='+ val <- munch (\c -> c /= '&')+ return (decode var,decode val)+ `mplus`+ do return (decode var,""))++ -- | Decode "+" and hexadecimal escapes+ decode [] = []+ decode ('%':'u':d1:d2:d3:d4:cs)+ | all isHexDigit [d1,d2,d3,d4] = chr(fromhex4 d1 d2 d3 d4):decode cs+ decode ('%':d1:d2:cs)+ | all isHexDigit [d1,d2] = utf8_decode len u cs+ where+ d = fromhex2 d1 d2+ len | d < 0x80 = 0+ | d < 0xe0 = 1+ | d < 0xf0 = 2+ | d < 0xf8 = 3+ | d < 0xfc = 4+ | otherwise = 5++ mask = 0x0103070F1f7f;+ u = d .&. (mask `shiftR` (len * 8))+ decode ('+':cs) = ' ':decode cs+ decode (c:cs) = c:decode cs++ utf8_decode 0 u cs = chr u : decode cs+ utf8_decode len u ('%':d1:d2:cs) = utf8_decode (len-1) u' cs+ where+ d = fromhex2 d1 d2+ u' = (u `shiftL` 6) .|. (d .&. 0x3f)+ utf8_decode _ u cs = decode cs -- character ignored ++ fromhex4 d1 d2 d3 d4 = 256*fromhex2 d1 d2+fromhex2 d3 d4+ fromhex2 d1 d2 = 16*digitToInt d1+digitToInt d2++-----------------------------------------------------------------+------------------ Parsing --------------------------------------+-----------------------------------------------------------------++-- Parsing a request+parseRequestHead :: [String] -> Either HttpError RequestData+parseRequestHead [] = Left ErrorClosed+parseRequestHead (s:ss) = do+ (version,rqm,uri) <- parseCommand s (words s)+ hdrs <- parseHeaders ss+ return (rqm,uri,withVersion version hdrs)+ where+ parseCommand l (rqm:uri:version:_) =+ case (parseURIReference uri, lookup rqm rqMethodMap) of+ (Just u, Just r ) -> return (version,r,u)+ (Just u, Nothing) -> return (version,Custom rqm,u)+ _ -> parse_err l+ parseCommand l _+ | null l = Left ErrorClosed+ | otherwise = parse_err l++ parse_err l = Left (ErrorParse ("Request command line parse failure: " ++ l))+++-- Parsing a response+parseResponseHead :: [String] -> Either HttpError ResponseData+parseResponseHead [] = Left ErrorClosed+parseResponseHead (sts:hdrs) = do+ (version,code,reason) <- responseStatus sts (words sts)+ hdrs' <- parseHeaders hdrs+ return (code,reason,withVersion version hdrs')+ where+ responseStatus _l _yes@(version:code:reason) =+ return (version,match code,concatMap (++" ") reason)+ responseStatus l _no+ | null l = Left ErrorClosed -- an assumption+ | otherwise = parse_err l++ parse_err l = Left (ErrorParse ("Response status line parse failure: " ++ l))++ match s =+ case reads s of+ [(code,"")] -> code+ _ -> -1 -- will create appropriate behaviour++-- To avoid changing the @RequestData@ and @ResponseData@ types+-- just for this (and the upstream backwards compat. woes that+-- will result in), encode version info as a custom header.+-- Used by 'parseResponseData' and 'parseRequestData'.+--+-- Note: the Request and Response types do not currently represent+-- the version info explicitly in their record types. You have to use+-- {get,set}{Request,Response}Version for that.+withVersion :: String -> [Header] -> [Header]+withVersion v hs+ | v == httpVersion = hs -- don't bother adding it if the default.+ | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs++-- | @getRequestVersion req@ returns the HTTP protocol version of+-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed.+getRequestVersion :: Request -> Maybe String+getRequestVersion r = getHttpVersion r++-- | @setRequestVersion v req@ returns a new request, identical to+-- @req@, but with its HTTP version set to @v@.+setRequestVersion :: String -> Request -> Request+setRequestVersion s r = setHttpVersion r s+++-- | @getResponseVersion rsp@ returns the HTTP protocol version of+-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be+-- assumed.+getResponseVersion :: Response -> Maybe String+getResponseVersion r = getHttpVersion r++-- | @setResponseVersion v rsp@ returns a new response, identical to+-- @rsp@, but with its HTTP version set to @v@.+setResponseVersion :: String -> Response -> Response+setResponseVersion s r = setHttpVersion r s++-- internal functions for accessing HTTP-version info in+-- requests and responses. Not exported as it exposes ho+-- version info is represented internally.++getHttpVersion :: HasHeaders a => a -> Maybe String+getHttpVersion r =+ fmap toVersion $+ find isHttpVersion $+ getHeaders r+ where+ toVersion (Header _ x) = x++setHttpVersion :: HasHeaders a => a -> String -> a+setHttpVersion r v =+ setHeaders r $+ withVersion v $+ dropHttpVersion $+ getHeaders r++dropHttpVersion :: [Header] -> [Header]+dropHttpVersion hs = filter (not.isHttpVersion) hs++isHttpVersion :: Header -> Bool+isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True+isHttpVersion _ = False++-----------------------------------------------------------------+------------------ HTTP Send / Recv ----------------------------------+-----------------------------------------------------------------++data ResponseNextStep+ = Continue+ | Retry+ | Done+ | ExpectEntity+ | DieHorribly String++matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep+matchResponse rqst code =+ case code of+ 100 -> Continue+ 101 -> Done -- upgrade to TLS+ _ | code > 101 && code < 200 -> Continue -- default+ 204 -> Done+ 205 -> Done+ 304 -> Done+ 305 -> Done+ 417 -> Retry -- Expectation failed+ _ | code >= 200 && code < 600 -> ans+ _ -> DieHorribly ("Response code " ++ show code ++ " not recognised")+ where+ ans | rqst == HEAD = Done+ | otherwise = ExpectEntity+++-----------------------------------------------------------------+------------------ A little friendly funtionality ---------------+-----------------------------------------------------------------++-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@+-- header.+#if MIN_VERSION_base(4,13,0)+getAuth :: MonadFail m => Request -> m URIAuth+#else+getAuth :: Monad m => Request -> m URIAuth+#endif+getAuth r = + case findHeader HdrHost r of+ Just val -> case parseURIAuthority val of+ Just x -> return x+ Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ val ++ "'"+ Nothing -> case uriAuthority (rqURI r) of+ Just auth -> return auth+ Nothing -> fail $ "Network.HTTP.Base.getAuth: No authority"++-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options+-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option+data NormalizeRequestOptions+ = NormalizeRequestOptions+ { normDoClose :: Bool+ , normForProxy :: Bool+ , normUserAgent :: Maybe String+ , normCustoms :: [RequestNormalizer]+ }++-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites+-- a request into some normalized form.+type RequestNormalizer = NormalizeRequestOptions -> Request -> Request++defaultNormalizeRequestOptions :: NormalizeRequestOptions+defaultNormalizeRequestOptions = NormalizeRequestOptions+ { normDoClose = False+ , normForProxy = False+ , normUserAgent = Just defaultUserAgent+ , normCustoms = []+ }++-- | @normalizeRequest opts req@ is the entry point to use to normalize your+-- request prior to transmission (or other use.) Normalization is controlled+-- via the @NormalizeRequestOptions@ record.+normalizeRequest :: NormalizeRequestOptions+ -> Request+ -> Request+normalizeRequest opts req = foldr (\ f -> f opts) req normalizers+ where+ --normalizers :: [RequestNormalizer ty]+ normalizers =+ ( normalizeHostURI+ : normalizeBasicAuth+ : normalizeConnectionClose+ : normalizeUserAgent+ : normCustoms opts+ )++-- | @normalizeUserAgent ua x req@ augments the request @req@ with+-- a @User-Agent: ua@ header if @req@ doesn't already have a+-- a @User-Agent:@ set.+normalizeUserAgent :: RequestNormalizer+normalizeUserAgent opts req =+ case normUserAgent opts of+ Nothing -> req+ Just ua ->+ case findHeader HdrUserAgent req of+ Just u | u /= defaultUserAgent -> req+ _ -> replaceHeader HdrUserAgent ua req++-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@+-- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then+-- _replaces_ any an existing @Connection:@ header in @req@.+normalizeConnectionClose :: RequestNormalizer+normalizeConnectionClose opts req+ | normDoClose opts = replaceHeader HdrConnection "close" req+ | otherwise = req++-- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@+-- if the "user:pass@" part is present in the "http://user:pass@host/path"+-- of the URI. If Authorization header was present already it is not replaced.+normalizeBasicAuth :: RequestNormalizer+normalizeBasicAuth _ req =+ case getAuth req of+ Just uriauth ->+ case uriUserInfo uriauth of+ "" -> req+ u ->+ insertHeaderIfMissing HdrAuthorization astr req+ where+ astr = "Basic " ++ base64encode u+ base64encode = Base64.encode . stringToOctets :: String -> String+ stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8]+ Nothing ->req++-- | @normalizeHostURI forProxy req@ rewrites your request to have it+-- follow the expected formats by the receiving party (proxy or server.)+--+normalizeHostURI :: RequestNormalizer+normalizeHostURI opts req =+ case splitRequestURI uri of+ ("",_uri_abs)+ | forProxy ->+ case findHeader HdrHost req of+ Nothing -> req -- no host/authority in sight..not much we can do.+ Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}+ , uriScheme=if null (uriScheme uri) then "http" else uriScheme uri+ }}+ where+ hst = case span (/='@') user_hst of+ (as,'@':bs) ->+ case span (/=':') as of+ (_,_:_) -> bs+ _ -> user_hst+ _ -> user_hst++ (user_hst, pNum) =+ case span isDigit (reverse h) of+ (ds,':':bs) -> (reverse bs, ':':reverse ds)+ _ -> (h,"")+ | otherwise ->+ case findHeader HdrHost req of+ Nothing -> req -- no host/authority in sight..not much we can do...complain?+ Just{} -> req+ (h,uri_abs)+ | forProxy -> insertHeaderIfMissing HdrHost h req+ | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass+ where+ uri0 = rqURI req+ -- stub out the user:pass+ uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)}++ forProxy = normForProxy opts++{- Comments re: above rewriting:+ 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.+-}++normalizeResponse :: Maybe Int64 -- ^ Content length+ -> Response+ -> Response+normalizeResponse mb_len =+ maybe id (insertHeader HdrContentLength . show) mb_len .+ insertHeaderIfMissing HdrServer defaultServer++splitRequestURI :: URI -> ({-authority-}String, URI)+splitRequestURI uri = (drop 2 (uriAuthToString id (uriAuthority uri) ""), uri{uriScheme="", uriAuthority=Nothing})++#if MIN_VERSION_network_uri(2,6,2)+#else+uriAuthToString :: (String->String) -> (Maybe URIAuth) -> ShowS+uriAuthToString _ Nothing = id -- shows ""+uriAuthToString userinfomap+ (Just URIAuth { uriUserInfo = myuinfo+ , uriRegName = myregname+ , uriPort = myport+ } ) =+ ("//"++) . (if null myuinfo then id else ((userinfomap myuinfo)++))+ . (myregname++)+ . (myport++)+#endif++-- 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)++uriAuthPort :: Maybe URI -> URIAuth -> Int+uriAuthPort mbURI auth =+ case uriPort auth of+ (':':s) -> readsOne id (default_port mbURI) s+ _ -> default_port mbURI+ where+ default_port Nothing = default_http+ default_port (Just url) =+ case map toLower $ uriScheme url of+ "http:" -> default_http+ "https:" -> default_https+ -- todo: refine+ _ -> default_http++ default_http = 80+ default_https = 443++getSSLContext :: URI -> IO (Maybe SSL.SSLContext)+getSSLContext uri =+ case map toLower $ uriScheme uri of+ "http:" -> return Nothing+ "https:" -> do ctxt <- SSL.context+ SSL.contextSetCiphers ctxt "DEFAULT"+ SSL.contextSetVerificationMode ctxt SSL.VerifyNone+ return (Just ctxt)+ _ -> return Nothing++-- | A default server string. The string is @\"haskell-http-slim/$version\"@+-- where @$version@ is the version of this HTTP package.+--+defaultServer :: String+defaultServer = "haskell-http-slim/" ++ httpPackageVersion++handleErrors :: (String -> IO ()) -> IO Response -> IO Response+handleErrors logIt f = + f `catch` (\e -> case e of+ ErrorReset -> outputError 400 "Bad Request" ""+ ErrorClosed -> outputError 400 "Bad Request" ""+ ErrorParse msg -> outputError 400 "Bad Request" msg+ ErrorMisc code reason body -> outputError code reason body)+ `catch` (\(e :: SomeException) -> do logIt (show e)+ outputError 500 "Internal Server Error" "")+ where+ outputError code reason body =+ return (Response+ { rspCode = code+ , rspReason = reason+ , rspHeaders = []+ , rspBody = body+ })
+ Network/HTTP/Base64.hs view
@@ -0,0 +1,282 @@+-----------------------------------------------------------------------------+-- |+-- Module : Codec.Binary.Base64+-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002+-- License : BSD-style (see the file ReadMe.tex)+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- 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 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints."++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 [_] = error "Network.HTTP.Base64.quadruplets: impossible number of characters."+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
+ Network/HTTP/Cookie.hs view
@@ -0,0 +1,228 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Cookie+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- This module provides the data types and functions for working with HTTP cookies.+-- Right now, it contains mostly functionality needed by 'Network.Browser'.+--+-----------------------------------------------------------------------------+module Network.HTTP.Cookie+ ( Cookie(..)+ , mkSimpleCookie, mkCookie+ , cookieMatch -- :: (String,String) -> Cookie -> Bool++ -- functions for translating cookies and headers.+ , renderSetCookie, renderCookie+ , parseSetCookie, parseCookie+ ) where++import Data.Char+import Data.List+import Data.Maybe++import Text.ParserCombinators.Parsec+ ( Parser, char, many, many1, satisfy, parse, option, try+ , (<|>), sepBy1+ )+import Network.HTTP.Utils ( parseInt )++------------------------------------------------------------------+----------------------- Cookie Stuff -----------------------------+------------------------------------------------------------------++-- | @Cookie@ is the Haskell representation of HTTP cookie values.+-- See its relevant specs for authoritative details.+data Cookie+ = MkCookie+ { ckDomain :: String -- Maybe String+ , ckName :: String+ , ckValue :: String+ , ckPath :: Maybe String+ , ckComment :: Maybe String+ , ckVersion :: Maybe String+ , ckMaxAge :: Maybe Int+ , ckSecure :: Bool+ }+ deriving(Show,Read)++-- | Constructs a cookie with the given name and value. Version is set to 1;+-- path, domain, and maximum age are set to @Nothing@; and the secure flag is+-- set to @False@. Constructing the cookie does not cause it to be set; to do+-- that, call 'setCookie' on it.+mkSimpleCookie+ :: String -- ^ The name of the cookie to construct.+ -> String -- ^ The value of the cookie to construct.+ -> Cookie -- ^ A cookie with the given name and value.+mkSimpleCookie name value = MkCookie {+ ckName = name,+ ckValue = value,+ ckVersion = Just "1",+ ckPath = Nothing,+ ckDomain = "",+ ckMaxAge = Nothing,+ ckSecure = False,+ ckComment = Nothing+ }+++-- | Constructs a cookie with the given parameters. Version is set to 1.+-- Constructing the cookie does not cause it to be set; to do that, call 'setCookie'+-- on it.+mkCookie+ :: String -- ^ The name of the cookie to construct.+ -> String -- ^ The value of the cookie to construct.+ -> (Maybe String) -- ^ The path of the cookie to construct.+ -> String -- ^ The domain of the cookie to construct.+ -> (Maybe Int) -- ^ The maximum age of the cookie to construct, in seconds.+ -> Bool -- ^ Whether to flag the cookie to construct as secure.+ -> Cookie -- ^ A cookie with the given parameters.+mkCookie name value maybePath domain maybeMaxAge secure+ = MkCookie {+ ckName = name,+ ckValue = value,+ ckVersion = Just "1",+ ckPath = maybePath,+ ckDomain = domain,+ ckMaxAge = maybeMaxAge,+ ckSecure = secure,+ ckComment = Nothing+ }++instance Eq Cookie where+ a == b = ckDomain a == ckDomain b+ && ckName a == ckName b+ && ckPath a == ckPath b++-- | Turn a list of cookies into a key=value pair list, separated by+-- commas.+renderSetCookie :: Cookie -> String+renderSetCookie = intercalate ";" . map printNameValuePair . nameValuePairs+ where+ printNameValuePair (name, Nothing ) = name+ printNameValuePair (name, Just value) = name ++ "=" ++ value+ + nameValuePairs cookie = [(ckName cookie, Just (ckValue cookie))]+ ++ (case ckComment cookie of+ Nothing -> []+ Just comment -> [("Comment", Just comment)])+ ++ (case ckDomain cookie of+ "" -> []+ domain -> [("Domain", Just domain)])+ ++ (case ckMaxAge cookie of+ Nothing -> []+ Just maxAge -> [("Max-Age", Just (show maxAge))])+ ++ (case ckPath cookie of+ Nothing -> []+ Just path -> [("Path", Just path)])+ ++ (case ckSecure cookie of+ False -> []+ True -> [("Secure", Nothing)])+ ++ (case ckVersion cookie of+ Nothing -> []+ Just version -> [("Version", Just version)])++-- | Turn a list of cookies into a key=value pair list, separated by+-- commas.+renderCookie :: [Cookie] -> String+renderCookie = intercalate ";" . map printNameValuePair+ where+ printNameValuePair cookie = ckName cookie ++ "=" ++ ckValue cookie++-- | @cookieMatch (domain,path) ck@ performs the standard cookie+-- match wrt the given domain and path.+cookieMatch :: (String, String) -> Cookie -> Bool+cookieMatch (dom,path) ck =+ ckDomain ck `isSuffixOf` dom &&+ case ckPath ck of+ Nothing -> True+ Just p -> p `isPrefixOf` path+++-- | parse a SetCookie header into a list of cookies and errors+parseSetCookie :: String -> ([String], [Cookie]) -> ([String], [Cookie])+parseSetCookie val (accErr, accCookie) =+ case parse cookie "" val of+ Left{} -> (val:accErr, accCookie)+ Right x -> (accErr, x : accCookie)+ where+ cookie :: Parser Cookie+ cookie =+ do name <- word+ _ <- spaces_l+ _ <- char '='+ _ <- spaces_l+ val1 <- cvalue+ args <- cdetail+ return (MkCookie+ { ckName = name+ , ckValue = val1+ , ckDomain = map toLower (fromMaybe "" (lookup "domain" args))+ , ckPath = lookup "path" args+ , ckVersion = lookup "version" args+ , ckComment = lookup "comment" args+ , ckMaxAge = case lookup "max-age" args of+ Nothing -> Nothing+ Just s -> parseInt s+ , ckSecure = isJust (lookup "secure" args)+ })++ -- 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 "" (char '=' >> spaces_l >> cvalue)+ return (map toLower s1,s2)+ )++-- | parse a Cookie header into a cookie+parseCookie :: String -> String -> Maybe [Cookie]+parseCookie dom val =+ case parse cookies "" val of+ Left{} -> Nothing+ Right x -> Just x+ where+ cookies :: Parser [Cookie]+ cookies = sepBy1 cookie (char ';')++ cookie :: Parser Cookie+ cookie =+ do name <- word+ _ <- spaces_l+ _ <- char '='+ _ <- spaces_l+ val1 <- cvalue+ return (MkCookie+ { ckName = name+ , ckValue = val1+ , ckDomain = dom+ , ckPath = Nothing+ , ckVersion = Nothing+ , ckComment = Nothing+ , ckMaxAge = Nothing+ , ckSecure = False+ })++cvalue :: Parser String+cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return ""++spaces_l :: Parser String+spaces_l = many (satisfy isSpace)++word, quotedstring :: Parser String+quotedstring =+ do _ <- char '"' -- "+ str <- many (satisfy $ not . (=='"'))+ _ <- char '"'+ return str++word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))
+ Network/HTTP/HandleStream.hs view
@@ -0,0 +1,312 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.HandleStream+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- For more detailed information about what the individual exports do, please consult+-- the documentation for "Network.HTTP". /Notice/ however that the functions here do+-- not perform any kind of normalization prior to transmission (or receipt); you are+-- responsible for doing any such yourself, or, if you prefer, just switch to using+-- "Network.HTTP" function instead.+--+-----------------------------------------------------------------------------+module Network.HTTP.HandleStream+ ( simpleHTTP -- :: Request -> IO Response+ , simpleHTTP_ -- :: Connection -> Request -> IO Response+ , sendHTTP -- :: Connection -> Request -> IO Response+ , sendHTTP_notify -- :: Connection -> Request -> IO () -> IO Response+ , receiveHTTP -- :: Connection -> IO Request+ , respondHTTP -- :: Connection -> Response -> IO ()+ , writeHeaders+ ) where++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Network.URI ( uriRegName )+import Network.TCP ( Connection, openTCPConnection, close, closeOnEnd,+ readBlock, readLine, writeAscii, writeByteString )++import Network.HTTP.Base+import Network.HTTP.Headers+import Network.HTTP.Utils ( trim, readsOne, crlf, lf, HttpError(..), encodeString )++import Data.Char (toLower)+import Control.Exception (onException, throwIO, bracket)+import Control.Monad (when)+import Numeric ( readHex )+import System.IO ( TextEncoding, latin1 )+import qualified Data.ByteString.Lazy as LBS++-----------------------------------------------------------------+------------------ Misc -----------------------------------------+-----------------------------------------------------------------++-- | @simpleHTTP@ transmits a resource across a non-persistent connection.+simpleHTTP :: Request -> IO Response+simpleHTTP r = do+ auth <- getAuth r+ ctxt <- getSSLContext (rqURI r)+ let host = uriRegName auth+ port = uriAuthPort (Just (rqURI r)) auth+ c <- openTCPConnection ctxt host port+ simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: Connection -> Request -> IO Response+simpleHTTP_ s r = sendHTTP s r++-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over+-- @hStream@, but does not alter the status of the connection, nor request it to be+-- closed upon receiving the response.+sendHTTP :: Connection -> Request -> IO Response+sendHTTP conn rq = sendHTTP_notify conn rq (return ())++-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but+-- lets you supply an IO @action@ to execute once the request has been successfully+-- transmitted over the connection. Useful when you want to set up tracing of+-- request transmission and its performance.+sendHTTP_notify :: Connection+ -> Request+ -> IO ()+ -> IO Response+sendHTTP_notify conn rq onSendComplete = do+ when providedClose $ (closeOnEnd conn True)+ onException (sendMain conn rq onSendComplete)+ (close conn)+ where+ providedClose = findConnClose (rqHeaders rq)++-- 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 :: Connection+ -> Request+ -> (IO ())+ -> IO Response+sendMain conn rqst onSendComplete = do+ enc <- getEncoding (rqHeaders rqst)+ lbs <- encodeString enc (rqBody rqst)+ let rqst' = insertHeader HdrContentLength (show (LBS.length lbs)) rqst+ _ <- writeAscii conn (show rqst')+ _ <- writeByteString conn lbs+ onSendComplete+ 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 :: Connection+ -> Bool {- allow retry? -}+ -> Bool {- is body sent? -}+ -> ResponseData+ -> Request+ -> IO Response+switchResponse conn allow_retry bdy_sent (cd,rn,hdrs) rqst =+ case matchResponse (rqMethod rqst) cd of+ Continue+ | not bdy_sent -> do {- Time to send the body -}+ writeAscii conn (rqBody rqst) >>=+ (\ _ -> 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" -}+ -- TODO review throwing away of result+ _ <- writeAscii conn (show rqst ++ rqBody rqst)+ rsp <- getResponseHead conn+ switchResponse conn False bdy_sent rsp rqst++ Done -> do+ when (findConnClose hdrs)+ (closeOnEnd conn True)+ return (Response cd rn hdrs "")++ DieHorribly str -> do+ close conn+ throwIO (ErrorParse str)+ ExpectEntity -> do+ enc <- getEncoding hdrs+ (ftrs,bdy) <- + onException+ (maybe (maybe (hopefulTransfer conn enc [])+ (\x -> readsOne (linearTransfer conn enc)+ (throwIO (ErrorParse ("unrecognized content-length value"++x)))+ x)+ cl)+ (ifChunked (chunkedTransfer conn enc)+ (uglyDeathTransfer "sendHTTP"))+ tc)+ (close conn)+ let hs = hdrs++ftrs+ rsp = Response cd rn hs bdy+ when (findConnClose hs)+ (closeOnEnd conn True)+ return rsp+ where+ tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs++-- reads and parses headers+getResponseHead :: Connection -> IO ResponseData+getResponseHead conn = do+ strs <- readTillEmpty1 conn latin1+ case parseResponseHead strs of+ Left err -> throwIO err+ Right rd -> return rd++-- | @receiveHTTP conn@ reads a 'Request' from the 'Connection' @conn@+receiveHTTP :: Connection -> IO Request+receiveHTTP conn = getRequestHead >>= processRequest+ where+ -- reads and parses headers+ getRequestHead :: IO RequestData+ getRequestHead = do+ strs <- readTillEmpty1 conn latin1+ case parseRequestHead strs of+ Left err -> throwIO err+ Right rq -> return rq++ processRequest (rm,uri,hdrs) = do+ enc <- getEncoding hdrs+ (ftrs,bdy) <- maybe+ (maybe (return ([], ""))+ (\x -> readsOne (linearTransfer conn enc)+ (throwIO (ErrorParse ("unrecognized Content-Length value"++x)))+ x)+ cl)+ (ifChunked (chunkedTransfer conn enc)+ (uglyDeathTransfer "receiveHTTP"))+ tc+ return (Request uri rm (hdrs++ftrs) bdy)+ where+ -- FIXME : Also handle 100-continue.+ tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs++-- | @respondHTTP conn httpResponse@ transmits an HTTP 'Response' over+-- the 'Connection' @conn@. It could be used to implement simple web+-- server interactions, performing the dual role to 'sendHTTP'.+respondHTTP :: Connection -> Response -> IO ()+respondHTTP conn rsp = do+ enc <- getEncoding (rspHeaders rsp)+ bs <- encodeString enc (rspBody rsp)+ let rsp' = normalizeResponse (Just (LBS.length bs)) rsp+ _ <- writeAscii conn (show rsp')+ writeByteString conn bs++-- | @writeHeaders conn httpResponse@ transmits only the headers of +-- response. This is useful if you want to trasmit the body separately+-- perhaps in a specific way.+writeHeaders :: Connection -> Response -> IO ()+writeHeaders conn rsp = do+ let rsp' = normalizeResponse Nothing rsp+ _ <- writeAscii conn (show rsp')+ return ()++------------------------------------------------------------------------------++ifChunked :: a -> a -> String -> a+ifChunked a b s =+ case map toLower (trim s) of+ "chunked" -> a+ _ -> b++-- | Used when we know exactly how many bytes to expect.+linearTransfer :: Connection -> TextEncoding -> Int -> IO ([Header],String)+linearTransfer conn enc n = do+ str <- readBlock conn enc n+ return ([],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 :: Connection+ -> TextEncoding+ -> [String]+ -> IO ([Header],String)+hopefulTransfer conn enc strs = do+ more <- readLine conn enc+ if null more+ then return ([], concat $ reverse strs)+ else hopefulTransfer conn enc (more:strs)++-- | A necessary feature of HTTP\/1.1+-- Also the only transfer variety likely to+-- return any footers.+chunkedTransfer :: Connection+ -> TextEncoding+ -> IO ([Header], String)+chunkedTransfer conn enc = chunkedTransferC conn enc [] 0++chunkedTransferC :: Connection+ -> TextEncoding+ -> [String]+ -> Int+ -> IO ([Header], String)+chunkedTransferC conn enc acc n = do+ line <- readLine conn latin1+ size <- case readHex line of+ [(hx,_)] -> return hx+ _ -> throwIO (ErrorParse ("Cannot parse length in chunked encoding: "++line))+ if size == 0+ then do strs <- readTillEmpty2 conn enc []+ case parseHeaders strs of+ Left err -> throwIO err+ Right ftrs -> do -- insert (computed) Content-Length header.+ let ftrs' = Header HdrContentLength (show n) : ftrs+ return (ftrs',concat (reverse acc))+ else do cdata <- readBlock conn enc size+ _ <- readLine conn latin1+ chunkedTransferC conn enc (cdata:acc) (n+size)++-- | Maybe in the future we will have a sensible thing+-- to do here, at that time we might want to change+-- the name.+uglyDeathTransfer :: String -> IO ([Header],a)+uglyDeathTransfer loc = throwIO (ErrorParse ("Unknown Transfer-Encoding in "++loc))+++-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)+readTillEmpty1 :: Connection -> TextEncoding -> IO [String]+readTillEmpty1 conn enc = do+ s <- readLine conn enc+ if s == crlf || s == lf+ then readTillEmpty1 conn enc+ else readTillEmpty2 conn enc [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 :: Connection+ -> TextEncoding+ -> [String]+ -> IO [String]+readTillEmpty2 conn enc list = do+ s <- readLine conn enc+ if s == crlf || s == lf || null s+ then return (reverse list)+ else readTillEmpty2 conn enc (s:list)
+ Network/HTTP/Headers.hs view
@@ -0,0 +1,429 @@+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Headers+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- This module provides the data types for representing HTTP headers, and+-- operations for looking up header values and working with sequences of+-- header values in 'Request's and 'Response's. To avoid having to provide+-- separate set of operations for doing so, we introduce a type class 'HasHeaders'+-- to facilitate writing such processing using overloading instead.+--+-----------------------------------------------------------------------------+module Network.HTTP.Headers+ ( HasHeaders(..) -- type class++ , Header(..)+ , mkHeader -- :: HeaderName -> String -> Header+ , hdrName -- :: Header -> HeaderName+ , hdrValue -- :: Header -> String++ , HeaderName(..)++ , insertHeader -- :: HasHeaders a => HeaderName -> String -> a -> a+ , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a+ , insertHeaders -- :: HasHeaders a => [Header] -> a -> a+ , retrieveHeaders -- :: HasHeaders a => HeaderName -> a -> [Header]+ , replaceHeader -- :: HasHeaders a => HeaderName -> String -> a -> a+ , replaceHeaders+ , findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String+ , lookupHeader -- :: HeaderName -> [Header] -> Maybe String++ , parseHeader -- :: parseHeader :: String -> Result Header+ , parseHeaders -- :: [String] -> Result [Header]+ , variableToHeaderName++ , Cookie(..), processCookie, processSetCookies+ + , getEncoding+ ) where++import Data.Char (toLower,toUpper)+import Network.HTTP.Cookie+import Network.HTTP.Utils (trim, split, crlf, HttpError(..))+import System.IO++-- | The @Header@ data type pairs header names & values.+data Header = Header HeaderName String++hdrName :: Header -> HeaderName+hdrName (Header h _) = h++hdrValue :: Header -> String+hdrValue (Header _ v) = v++-- | Header constructor as a function, hiding above rep.+mkHeader :: HeaderName -> String -> Header+mkHeader = Header++instance Show Header where+ show (Header key value) = shows key (':':' ':value ++ crlf)++-- | HTTP @HeaderName@ type, a Haskell data constructor for each+-- specification-defined header, prefixed with @Hdr@ and CamelCased,+-- (i.e., eliding the @-@ in the process.) Should you require using+-- a custom header, there's the @HdrCustom@ constructor which takes+-- a @String@ argument.+--+-- Encoding HTTP header names differently, as Strings perhaps, is an+-- equally fine choice..no decidedly clear winner, but let's stick+-- with data constructors here.+--+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+ | HdrAcceptRanges+ | HdrAge+ | HdrLocation+ | HdrProxyAuthenticate+ | HdrPublic+ | HdrRetryAfter+ | HdrServer+ | HdrSetCookie+ | HdrTE+ | HdrTrailer+ | HdrVary+ | HdrWarning+ | HdrWWWAuthenticate+ | HdrAccessControlAllowOrigin+ -- Entity Headers+ | HdrAllow+ | HdrContentBase+ | HdrContentEncoding+ | HdrContentLanguage+ | HdrContentLength+ | HdrContentLocation+ | HdrContentMD5+ | HdrContentRange+ | HdrContentType+ | HdrETag+ | HdrExpires+ | HdrLastModified+ | HdrContentDisposition+ -- | MIME entity headers (for sub-parts)+ | HdrContentTransferEncoding+ -- | Allows for unrecognised or experimental headers.+ | HdrCustom String -- not in header map below.+ | HdrExtensionHeader++instance Eq HeaderName where+ HdrCustom a == HdrCustom b = map toLower a == map toLower b+ HdrCacheControl == HdrCacheControl = True+ HdrConnection == HdrConnection = True+ HdrDate == HdrDate = True+ HdrPragma == HdrPragma = True+ HdrTransferEncoding == HdrTransferEncoding = True+ HdrUpgrade == HdrUpgrade = True+ HdrVia == HdrVia = True+ HdrAccept == HdrAccept = True+ HdrAcceptCharset == HdrAcceptCharset = True+ HdrAcceptEncoding == HdrAcceptEncoding = True+ HdrAcceptLanguage == HdrAcceptLanguage = True+ HdrAuthorization == HdrAuthorization = True+ HdrCookie == HdrCookie = True+ HdrExpect == HdrExpect = True+ HdrFrom == HdrFrom = True+ HdrHost == HdrHost = True+ HdrIfModifiedSince == HdrIfModifiedSince = True+ HdrIfMatch == HdrIfMatch = True+ HdrIfNoneMatch == HdrIfNoneMatch = True+ HdrIfRange == HdrIfRange = True+ HdrIfUnmodifiedSince == HdrIfUnmodifiedSince = True+ HdrMaxForwards == HdrMaxForwards = True+ HdrProxyAuthorization == HdrProxyAuthorization = True+ HdrRange == HdrRange = True+ HdrReferer == HdrReferer = True+ HdrUserAgent == HdrUserAgent = True+ HdrAcceptRanges == HdrAcceptRanges = True+ HdrAge == HdrAge = True+ HdrLocation == HdrLocation = True+ HdrProxyAuthenticate == HdrProxyAuthenticate = True+ HdrPublic == HdrPublic = True+ HdrRetryAfter == HdrRetryAfter = True+ HdrServer == HdrServer = True+ HdrSetCookie == HdrSetCookie = True+ HdrTE == HdrTE = True+ HdrTrailer == HdrTrailer = True+ HdrVary == HdrVary = True+ HdrWarning == HdrWarning = True+ HdrWWWAuthenticate == HdrWWWAuthenticate = True+ HdrAccessControlAllowOrigin== HdrAccessControlAllowOrigin= True+ HdrAllow == HdrAllow = True+ HdrContentBase == HdrContentBase = True+ HdrContentEncoding == HdrContentEncoding = True+ HdrContentLanguage == HdrContentLanguage = True+ HdrContentLength == HdrContentLength = True+ HdrContentLocation == HdrContentLocation = True+ HdrContentMD5 == HdrContentMD5 = True+ HdrContentRange == HdrContentRange = True+ HdrContentType == HdrContentType = True+ HdrETag == HdrETag = True+ HdrExpires == HdrExpires = True+ HdrLastModified == HdrLastModified = True+ HdrContentTransferEncoding == HdrContentTransferEncoding = True+ HdrContentDisposition == HdrContentDisposition = True + _ == _ = False+++-- | @headerMap@ is a straight assoc list for translating between +-- header names, variable names and Haskell values.+headerMap :: [(String,String,HeaderName)]+headerMap =+ [ p "Cache-Control" "HTTP_CACHE_CONTROL" HdrCacheControl+ , p "Connection" "HTTP_CONNECTION" HdrConnection+ , p "Date" "HTTP_DATE" HdrDate+ , p "Pragma" "HTTP_PRAGMA" HdrPragma+ , p "Transfer-Encoding" "HTTP_TRANSFER_ENCODING" HdrTransferEncoding+ , p "Upgrade" "HTTP_UPGRADE" HdrUpgrade+ , p "Via" "HTTP_VIA" HdrVia+ , p "Accept" "HTTP_ACCEPT" HdrAccept+ , p "Accept-Charset" "HTTP_ACCEPT_CHARSET" HdrAcceptCharset+ , p "Accept-Encoding" "HTTP_ACCEPT_ENCODING" HdrAcceptEncoding+ , p "Accept-Language" "HTTP_ACCEPT_LANGUAGE" HdrAcceptLanguage+ , p "Authorization" "HTTP_AUTHORIZATION" HdrAuthorization+ , p "Cookie" "HTTP_COOKIE" HdrCookie+ , p "Expect" "HTTP_EXPECT" HdrExpect+ , p "From" "HTTP_FROM" HdrFrom+ , p "Host" "HTTP_HOST" HdrHost+ , p "If-Modified-Since" "HTTP_IF_MODIFIED_SINCE" HdrIfModifiedSince+ , p "If-Match" "HTTP_IF_MATCH" HdrIfMatch+ , p "If-None-Match" "HTTP_IF_NONE_MATCH" HdrIfNoneMatch+ , p "If-Range" "HTTP_IF_RANGE" HdrIfRange+ , p "If-Unmodified-Since" "HTTP_IF_UNMODIFIED_SINCE" HdrIfUnmodifiedSince+ , p "Max-Forwards" "HTTP_MAX_FORWARDS" HdrMaxForwards+ , p "Proxy-Authorization" "HTTP_PROXY_AUTHORIZATION" HdrProxyAuthorization+ , p "Range" "HTTP_RANGE" HdrRange+ , p "Referer" "HTTP_REFERER" HdrReferer+ , p "TE" "HTTP_TE" HdrTE+ , p "User-Agent" "HTTP_USER_AGENT" HdrUserAgent+ , p "Accept-Ranges" "HTTP_ACCEPT_RANGES" HdrAcceptRanges+ , p "Age" "HTTP_AGE" HdrAge+ , p "ETag" "HTTP_ETAG" HdrETag+ , p "Location" "HTTP_LOCATION" HdrLocation+ , p "Proxy-Authenticate" "HTTP_PROXY_AUTHENTICATE" HdrProxyAuthenticate+ , p "Public" "HTTP_PUBLIC" HdrPublic+ , p "Retry-After" "HTTP_RETRY_AFTER" HdrRetryAfter+ , p "Server" "HTTP_SERVER" HdrServer+ , p "Set-Cookie" "HTTP_SET_COOKIE" HdrSetCookie+ , p "Trailer" "HTTP_TRAILER" HdrTrailer+ , p "Vary" "HTTP_VARY" HdrVary+ , p "Warning" "HTTP_WARNING" HdrWarning+ , p "WWW-Authenticate" "HTTP_WWW_AUTHENTICATE" HdrWWWAuthenticate+ , p "Access-Control-Allow-Origin" "HTTP_ACCESS_CONTROL_ALLOW_ORIGIN" HdrAccessControlAllowOrigin+ , p "Allow" "HTTP_ALLOW" HdrAllow+ , p "Content-Base" "HTTP_CONTENT_BASE" HdrContentBase+ , p "Content-Encoding" "HTTP_CONTENT_ENCODING" HdrContentEncoding+ , p "Content-Language" "HTTP_CONTENT_LANGUAGE" HdrContentLanguage+ , p "Content-Length" "CONTENT_LENGTH" HdrContentLength+ , p "Content-Location" "HTTP_CONTENT_LOCATION" HdrContentLocation+ , p "Content-MD5" "HTTP_CONTENT_MD5" HdrContentMD5+ , p "Content-Range" "HTTP_CONTENT_RANGE" HdrContentRange+ , p "Content-Type" "CONTENT_TYPE" HdrContentType+ , p "Expires" "HTTP_EXPIRES" HdrExpires+ , p "Last-Modified" "HTTP_LAST_MODIFIED" HdrLastModified+ , p "Content-Transfer-Encoding" "HTTP_CONTENT_TRANSFER_ENCODING" HdrContentTransferEncoding+ , p "Content-Disposition" "HTTP_CONTENT_DISPOSITION" HdrContentDisposition+ ]+ where+ p a b c = (a,b,c)++instance Show HeaderName where+ show (HdrCustom s) = s+ show x = case filter (\(_,_,y)->x==y) headerMap of+ [] -> error "headerMap incomplete"+ ((h,_,_):_) -> h++-- | @HasHeaders@ is a type class for types containing HTTP headers, allowing+-- you to write overloaded header manipulation functions+-- for both 'Request' and 'Response' data types, for instance.+class HasHeaders x where+ getHeaders :: x -> [Header]+ setHeaders :: x -> [Header] -> x++ getCookies :: x -> [Cookie]+ setCookies :: x -> [Cookie] -> x+++-- | @insertHeader hdr x@ inserts a header. Does not check for +-- existing headers with same name, allowing duplicates to be+-- introduced (use 'replaceHeader' if you want to avoid this.)+insertHeader :: HasHeaders a => HeaderName -> String -> a -> a+insertHeader name value x = setHeaders x (Header name value : getHeaders x)++-- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous+-- header with name @hdr@ exists in @x@.+insertHeaderIfMissing :: HasHeaders a => HeaderName -> String -> a -> a+insertHeaderIfMissing name value x = setHeaders x (update (getHeaders x))+ where+ update [] = [Header name value]+ update list@(h@(Header n _) : rest)+ | n == name = list+ | otherwise = h : update rest++-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the+-- value @val@, dropping any existing+replaceHeader :: HasHeaders a => HeaderName -> String -> a -> a+replaceHeader name value x = setHeaders x (update (getHeaders x))+ where+ update [] = [Header name value]+ update (h@(Header n _) : rest)+ | n == name = update rest+ | otherwise = h : update rest++-- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing+-- set.+insertHeaders :: HasHeaders a => [Header] -> a -> a+insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)++-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the+-- value @val@, dropping any existing+replaceHeaders :: HasHeaders a => HeaderName -> [String] -> a -> a+replaceHeaders name values x = setHeaders x (update (getHeaders x))+ where+ update [] = [Header name value | value <- values]+ update (h@(Header n _) : rest)+ | n == name = update rest+ | otherwise = h : update rest++-- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@.+retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]+retrieveHeaders name x = filter matchname (getHeaders x)+ where+ matchname (Header n _) = n == name++-- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first+-- header that matches, if any.+findHeader :: HasHeaders a => HeaderName -> a -> Maybe String+findHeader n x = lookupHeader n (getHeaders x)++-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the+-- list @hdrs@.+lookupHeader :: HeaderName -> [Header] -> Maybe String+lookupHeader _ [] = Nothing+lookupHeader v (Header n s:t)+ | v == n = Just s+ | otherwise = lookupHeader v t++-- | @parseHeader headerNameAndValueString@ tries to unscramble a+-- @header: value@ pairing and returning it as a 'Header'.+parseHeader :: String -> Maybe Header+parseHeader str =+ case split ':' str of+ Nothing -> Nothing+ Just (k,v) -> Just $ Header (fn k) (trim $ drop 1 v)+ where+ fn x = case filter (\(y,_,_) -> match x y) headerMap of+ [] -> HdrCustom x+ ((_,_,h):_) -> h++ match :: String -> String -> Bool+ match s1 s2 = map toLower s1 == map toLower s2+ +variableToHeaderName :: String -> Maybe HeaderName+variableToHeaderName x =+ case filter (\(_,y,_) -> x==y) headerMap of+ [] -> variableToHeader x+ ((_,_,h):_) -> Just h+ where+ variableToHeader ('H':'T':'T':'P':'_':cs)+ | null cs = Nothing+ | otherwise = Just (HdrCustom (translate cs))+ variableToHeader _ = Nothing++ translate [] = []+ translate cs = case break (=='_') cs of+ (first, '_':rest) -> titleCase first++'-':translate rest+ _ -> cs++ titleCase [] = []+ titleCase (c:cs) = toUpper c : map toLower cs+++-- | @parseHeaders hdrs@ takes a sequence of strings holding header+-- information and parses them into a set of headers (preserving their+-- order in the input argument.) Handles header values split up over+-- multiple lines.+parseHeaders :: [String] -> Either HttpError [Header]+parseHeaders = parseLines [] . joinExtended ""+ where+ -- Joins consecutive lines where the second line+ -- begins with ' ' or '\t'.+ joinExtended old [] = [old | not (null old)]+ joinExtended old (h : t)+ | isLineExtension h = joinExtended (old ++ ' ' : tail h) t+ | null old = joinExtended h t+ | otherwise = old : joinExtended h t++ isLineExtension (x:_) = x == ' ' || x == '\t'+ isLineExtension _ = False++ clean [] = []+ clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t+ | otherwise = h : clean t++ parseLines :: [Header] -> [String] -> Either HttpError [Header]+ parseLines hdrs [] = Right (reverse hdrs)+ parseLines hdrs (l:ls) =+ case (parseHeader . clean) l of+ Just hdr -> parseLines (hdr:hdrs) ls+ Nothing -> Left (ErrorParse ("Unable to parse header: " ++ l))++-- | process SetCookie headers and extract the cookies and the errors+processSetCookies :: [Header] -> ([String], [Cookie])+processSetCookies hdrs =+ foldr (\(Header hdr val) st ->+ if hdr == HdrSetCookie+ then parseSetCookie val st+ else st)+ ([],[])+ hdrs++-- | @processCookieHeaders dom hdrs@+processCookie :: String -> [Header] -> Maybe [Cookie]+processCookie dom hdrs =+ lookupHeader HdrCookie hdrs >>= parseCookie dom+++getEncoding :: [Header] -> IO TextEncoding+getEncoding hdrs =+ case lookupHeader HdrContentType hdrs of+ Just val -> case dropWhile (/=';') val of+ (';':cs) -> case break (=='=') cs of+ (xs,'=':ys) | trim (map toLower xs) == "charset" ->+ do enc <- mkTextEncoding (trim ys++"//IGNORE")+ return enc+ _ -> return latin1+ _ -> return latin1+ Nothing -> return latin1
+ Network/HTTP/MD5.hs view
@@ -0,0 +1,264 @@+module Network.HTTP.MD5+ (md5ss, md5si, md5bs, md5bi) where++import Data.Char (ord, chr)+import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement)+import Data.Word (Word32, Word64)+import qualified Data.ByteString.Lazy as BS+import GHC.Show+import System.IO+import System.IO.Unsafe ( unsafePerformIO )+import Network.HTTP.Utils++-- ===================== TYPES AND CLASS DEFINTIONS ========================+++type Rotation = Int+data XYZ = XYZ {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+data ABCD = ABCD {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ {-# UNPACK #-} !Word32+ deriving (Eq, Show)++addABCD :: ABCD -> ABCD -> ABCD+addABCD (ABCD a1 b1 c1 d1) (ABCD a2 b2 c2 d2) = ABCD (a1 + a2) (b1 + b2) (c1 + c2) (d1 + d2)++-- ===================== EXPORTED FUNCTIONS ========================++md5 :: BS.ByteString -> ABCD+md5 m = md5_main 0 magic_numbers m++-- | Encodes a string given the encoding and returns an MD5 hex number+-- à la md5sum program+md5ss :: TextEncoding -> String -> String+md5ss enc s = (abcd_to_string . md5) (unsafePerformIO (encodeString enc s))++-- | Returns an MD5 hex number of a byte string à la md5sum program+md5bs :: BS.ByteString -> String+md5bs = abcd_to_string . md5++-- | Encodes a string given the encoding and returns an MD5 hex number+-- à la md5sum program+md5si :: TextEncoding -> String -> Integer+md5si enc s = (abcd_to_integer . md5) (unsafePerformIO (encodeString enc s))++-- | Returns an MD5 hex number of a byte string à la md5sum program+md5bi :: BS.ByteString -> Integer+md5bi = abcd_to_integer . md5+++-- ===================== THE CORE ALGORITHM ========================+++-- Decides what to do. The first argument indicates if padding has been+-- added. The second is the length mod 2^64 so far. Then we have the+-- starting state, the rest of the string and the final state.++md5_main :: Word64 -- The length so far mod 2^64+ -> ABCD -- The initial state+ -> BS.ByteString -- The non-processed portion of the message+ -> ABCD -- The resulting state+md5_main ilen abcd bs+ | BS.null bs = abcd+ | otherwise = md5_main (ilen + 512) (addABCD abcd abcd') bs'+ where+ (m16, bs') = get_next 16 bs+ abcd' = md5_do_block abcd m16++ get_next 0 bs = ([],bs)+ get_next n bs+ | len == 4 =+ let (ws,bs'') = get_next (n-1) bs'+ in (w:ws,bs'')+ | zeros < 14 =+ let ws = replicate (fromIntegral zeros) 0++size+ in (w1:ws,BS.empty)+ | otherwise =+ let ws = replicate (fromIntegral n-1) 0+ bs = BS.append (BS.replicate 56 0) (length_to_bytes 8 c64)+ in (w1:ws, bs)+ where+ (s, bs') = BS.splitAt 4 bs+ len = fromIntegral (BS.length s)+ w = BS.foldr (\c w -> shiftL w 8 + fromIntegral c) 0 s+ w1 = shiftL 0x80 (len * 8) + w++ c64 = ilen + 32 * (16 - n) + 8 * fromIntegral len+ c64' = ilen + 32 * (16 - n) + 32++ zeros = shiftR ((448 - c64') .&. 511) 5++ size = [ fromIntegral (c64 .&. 0xFFFFFFFF)+ , fromIntegral (shiftR c64 32)+ ]++ length_to_bytes 0 _ = BS.empty+ length_to_bytes p n = BS.cons this (length_to_bytes (p-1) (shiftR n 8))+ where+ this = fromIntegral (n .&. 255)++-- md5_do_block processes a 512 bit block by calling md5_round 4 times to+-- apply each round with the correct constants and permutations of the+-- block++md5_do_block :: ABCD -- Initial state+ -> [Word32] -- The block to be processed - 16 32bit words+ -> ABCD -- Resulting state+md5_do_block abcd0 w = abcd4+ where+ (r1, r2, r3, r4) = rounds++ perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] =+ [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12]+ perm5 _ = error "broke at perm5"++ perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] =+ [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2]+ perm3 _ = error "broke at perm3"++ perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] =+ [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9]+ perm7 _ = error "broke at perm7"++ abcd1 = md5_round md5_f abcd0 w r1+ abcd2 = md5_round md5_g abcd1 (perm5 w) r2+ abcd3 = md5_round md5_h abcd2 (perm3 w) r3+ abcd4 = md5_round md5_i abcd3 (perm7 w) r4+++-- md5_round does one of the rounds. It takes an auxiliary function and foldls+-- (md5_inner_function f) to repeatedly apply it to the initial state with the+-- correct constants++md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I+ -- for those of you with a copy of+ -- the prayer book^W^WRFC)+ -> ABCD -- Initial state+ -> [Word32] -- The 16 32bit words of input+ -> [(Rotation, Word32)] -- The list of 16 rotations and+ -- additive constants+ -> ABCD -- Resulting state+md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns'+ where+ ns' = zipWith (\x (y, z) -> (y, x + z)) s ns+++-- Apply one of the functions md5_[fghi] and put the new ABCD together++md5_inner_function :: (XYZ -> Word32) -- Auxiliary function+ -> ABCD -- Initial state+ -> (Rotation, Word32) -- The rotation and additive+ -- constant (X[i] + T[j])+ -> ABCD -- Resulting state+md5_inner_function f (ABCD a b c d) (s, ki) = ABCD d a' b c+ where+ mid_a = a + f (XYZ b c d) + ki+ rot_a = rotateL mid_a s+ a' = b + rot_a+++-- The 4 auxiliary functions++md5_f :: XYZ -> Word32+md5_f (XYZ x y z) = z `xor` (x .&. (y `xor` z))+{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -}++md5_g :: XYZ -> Word32+md5_g (XYZ x y z) = md5_f (XYZ z x y)+{- was: (x .&. z) .|. (y .&. (complement z)) -}++md5_h :: XYZ -> Word32+md5_h (XYZ x y z) = x `xor` y `xor` z++md5_i :: XYZ -> Word32+md5_i (XYZ x y z) = y `xor` (x .|. (complement z))+++-- The magic numbers from the RFC.++magic_numbers :: ABCD+magic_numbers = ABCD 0x67452301 0xefcdab89 0x98badcfe 0x10325476+++-- The 4 lists of (rotation, additive constant) tuples, one for each round++rounds :: ([(Rotation, Word32)],+ [(Rotation, Word32)],+ [(Rotation, Word32)],+ [(Rotation, Word32)])+rounds = (r1, r2, r3, r4)+ where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db),+ (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a),+ (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8),+ (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be),+ (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e),+ (s14, 0x49b40821)]+ r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51),+ (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453),+ (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6),+ (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed),+ (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9),+ (s24, 0x8d2a4c8a)]+ r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122),+ (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9),+ (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6),+ (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05),+ (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8),+ (s34, 0xc4ac5665)]+ r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7),+ (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92),+ (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f),+ (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1),+ (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb),+ (s44, 0xeb86d391)]+ s11 = 7+ s12 = 12+ s13 = 17+ s14 = 22+ s21 = 5+ s22 = 9+ s23 = 14+ s24 = 20+ s31 = 4+ s32 = 11+ s33 = 16+ s34 = 23+ s41 = 6+ s42 = 10+ s43 = 15+ s44 = 21++-- Turn the 4 32 bit words into a string representing the hex number they+-- represent.++abcd_to_string :: ABCD -> String+abcd_to_string (ABCD a b c d) =+ (show_hex a . show_hex b . show_hex c . show_hex d) ""+ where+ show_hex w = showIt (rev_num w) 8+ where+ showIt _ 0 r = r+ showIt n i r = c `seq` showIt n' (i-1) (c : r)+ where+ (n',d) = quotRem n 16+ c = intToDigit (fromIntegral d)++-- Convert to an integer, performing endianness magic as we go++abcd_to_integer :: ABCD -> Integer+abcd_to_integer (ABCD a b c d)+ = toInteger (rev_num a) * 2^(96 :: Int)+ + toInteger (rev_num b) * 2^(64 :: Int)+ + toInteger (rev_num c) * 2^(32 :: Int)+ + toInteger (rev_num d)++rev_num :: Word32 -> Word32+rev_num i = j+ where+ j = shiftL (i .&. 0x000000FF) 24 .|.+ shiftL (i .&. 0x0000FF00) 8 .|.+ shiftR (i .&. 0x00FF0000) 8 .|.+ shiftR (i .&. 0xFF000000) 24
+ Network/HTTP/Proxy.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Proxy+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Handling proxy server settings and their resolution.+--+-----------------------------------------------------------------------------+module Network.HTTP.Proxy+ ( Proxy(..)+ , noProxy -- :: Proxy+ , fetchProxy -- :: Bool -> IO Proxy+ , parseProxy -- :: String -> Maybe Proxy+ ) where++{-+#if !defined(WIN32) && defined(mingw32_HOST_OS)+#define WIN32 1+#endif+-}++import Control.Monad ( when, mplus, join, liftM2 )++#if defined(WIN32)+import Network.HTTP.Base ( catchIO )+import Control.Monad ( liftM )+import Data.List ( isPrefixOf )+#endif+import Network.HTTP.Utils ( dropWhileTail, chopAtDelim )+import Network.HTTP.Auth+import Network.URI+ ( URI(..), URIAuth(..), parseAbsoluteURI, unEscapeString )+import System.IO ( hPutStrLn, stderr )+import System.Environment++{-+#if !defined(WIN32) && defined(mingw32_HOST_OS)+#define WIN32 1+#endif+-}++#if defined(WIN32)+import System.Win32.Types ( DWORD, HKEY )+import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValueEx )+import Control.Exception ( bracket )+import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca )++#if MIN_VERSION_Win32(2,8,0)+import System.Win32.Registry( regQueryDefaultValue )+#else+import System.Win32.Registry( regQueryValue )+#endif+#endif++-- | HTTP proxies (or not) are represented via 'Proxy', specifying if a+-- proxy should be used for the request (see 'Network.Browser.setProxy')+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".+ -- Additionally, an optional 'Authority' for authentication with the proxy.+++noProxy :: Proxy+noProxy = NoProxy++-- | @envProxyString@ locates proxy server settings by looking+-- up env variable @HTTP_PROXY@ (or its lower-case equivalent.)+-- If no mapping found, returns @Nothing@.+envProxyString :: IO (Maybe String)+envProxyString = do+ env <- getEnvironment+ return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)++-- | @proxyString@ tries to locate the user's proxy server setting.+-- Consults environment variable, and in case of Windows, by querying+-- the Registry (cf. @registryProxyString@.)+proxyString :: IO (Maybe String)+proxyString = liftM2 mplus envProxyString windowsProxyString++windowsProxyString :: IO (Maybe String)+#if !defined(WIN32)+windowsProxyString = return Nothing+#else+windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString++registryProxyLoc :: (HKEY,String)+registryProxyLoc = (hive, path)+ where+ -- some sources say proxy settings should be at+ -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows+ -- \CurrentVersion\Internet Settings\ProxyServer+ -- but if the user sets them with IE connection panel they seem to+ -- end up in the following place:+ hive = hKEY_CURRENT_USER+ path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"++-- read proxy settings from the windows registry; this is just a best+-- effort and may not work on all setups.+registryProxyString :: IO (Maybe String)+registryProxyString = catchIO+ (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do+ enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"+ if enable+#if MIN_VERSION_Win32(2,8,0)+ then fmap Just $ regQueryDefaultValue hkey "ProxyServer"+#elif MIN_VERSION_Win32(2,6,0)+ then fmap Just $ regQueryValue hkey "ProxyServer"+#else+ then fmap Just $ regQueryValue hkey (Just "ProxyServer")+#endif+ else return Nothing)+ (\_ -> return Nothing)++-- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..."+-- even though the following article indicates otherwise+-- https://support.microsoft.com/en-us/kb/819961+--+-- to be sure, parse strings where each entry in the ';'-separated list above is+-- either in the format "protocol=..." or "protocol://..."+--+-- only return the first "http" of them, if it exists+parseWindowsProxy :: String -> Maybe String+parseWindowsProxy s =+ case proxies of+ x:_ -> Just x+ _ -> Nothing+ where+ parts = split ';' s+ pr x = case break (== '=') x of+ (p, []) -> p -- might be in format http://+ (p, u) -> p ++ "://" ++ drop 1 u++ proxies = filter (isPrefixOf "http://") . map pr $ parts++ split :: Eq a => a -> [a] -> [[a]]+ split _ [] = []+ split a xs = case break (a ==) xs of+ (ys, []) -> [ys]+ (ys, _:zs) -> ys:split a zs++#endif++-- | @fetchProxy flg@ gets the local proxy settings and parse the string+-- into a @Proxy@ value. If you want to be informed of ill-formed proxy+-- configuration strings, supply @True@ for @flg@.+-- Proxy settings are sourced from the @HTTP_PROXY@ environment variable,+-- and in the case of Windows platforms, by consulting IE/WinInet's proxy+-- setting in the Registry.+fetchProxy :: Bool -> IO Proxy+fetchProxy warnIfIllformed = do+ mstr <- proxyString+ case mstr of+ Nothing -> return NoProxy+ Just str -> case parseProxy str of+ Just p -> return p+ Nothing -> do+ when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines+ [ "invalid http proxy uri: " ++ show str+ , "proxy uri must be http with a hostname"+ , "ignoring http proxy, trying a direct connection"+ ]+ return NoProxy++-- | @parseProxy str@ translates a proxy server string into a @Proxy@ value;+-- returns @Nothing@ if not well-formed.+parseProxy :: String -> Maybe Proxy+parseProxy "" = Nothing+parseProxy str = join+ . fmap uri2proxy+ $ parseHttpURI str+ `mplus` parseHttpURI ("http://" ++ str)+ where+ parseHttpURI str' =+ case parseAbsoluteURI str' of+ Just uri@URI{uriAuthority = Just{}} -> Just (fixUserInfo uri)+ _ -> Nothing++ -- Note: we need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@+ -- which lack the @\"http://\"@ URI scheme. The problem is that+ -- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme+ -- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.+ --+ -- So our strategy is to try parsing as normal uri first and if it lacks the+ -- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.+ --++-- | tidy up user portion, don't want the trailing "\@".+fixUserInfo :: URI -> URI+fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }+ where+ f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s}++--+uri2proxy :: URI -> Maybe Proxy+uri2proxy uri@URI{ uriScheme = "http:"+ , uriAuthority = Just (URIAuth auth' hst prt)+ } =+ Just (Proxy (hst ++ prt) auth)+ where+ auth =+ case auth' of+ [] -> Nothing+ as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri)+ where+ (usr,pwd) = chopAtDelim ':' as++uri2proxy _ = Nothing++-- utilities+#if defined(WIN32)+regQueryValueDWORD :: HKEY -> String -> IO DWORD+regQueryValueDWORD hkey name = alloca $ \ptr -> do+ -- TODO: this throws away the key type returned by regQueryValueEx+ -- we should check it's what we expect instead+ _ <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+ peek ptr++#endif
+ Network/HTTP/Utils.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.HTTP.Utils+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@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+ , parseInt++ , crlf -- :: String+ , lf -- :: String+ , sp -- :: String++ , split -- :: Eq a => a -> [a] -> Maybe ([a],[a])+ , splitBy -- :: Eq a => a -> [a] -> [[a]]++ , readsOne -- :: Read a => (a -> b) -> b -> String -> b++ , dropWhileTail -- :: (a -> Bool) -> [a] -> [a]+ , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a])++ , decodeString+ , encodeString++ , HttpError(..)+ ) where++import Data.Char+import Data.List ( elemIndex )+import Data.Maybe ( fromMaybe )+import Control.Exception+import GHC.IO.Buffer+import GHC.IO.Encoding ( TextEncoding(..), latin1, mkTextEncoding, encode )+import qualified GHC.IO.Encoding as Enc+import qualified Data.ByteString.Internal as BS ( ByteString(..) )+import qualified Data.ByteString.Lazy as LBS+import Foreign ( peekArray, pokeElemOff )++-- | @crlf@ is our beloved two-char line terminator.+crlf :: String+crlf = "\r\n"++-- | @lf@ is a tolerated line terminator, per RFC 2616 section 19.3.+lf :: String+lf = "\n"++-- | @sp@ lets you save typing one character.+sp :: String+sp = " "++-- | @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++-- | @readsOne f def str@ tries to 'read' @str@, taking+-- the first result and passing it to @f@. If the 'read'+-- doesn't succeed, return @def@.+readsOne :: Read a => (a -> b) -> b -> String -> b+readsOne f n str =+ case reads str of+ ((v,_):_) -> f v+ _ -> n+++-- | @dropWhileTail p ls@ chops off trailing elements from @ls@+-- until @p@ returns @False@.+dropWhileTail :: (a -> Bool) -> [a] -> [a]+dropWhileTail f ls =+ case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] }+ where+ chop x (Just xs) = Just (x:xs)+ chop x _+ | f x = Nothing+ | otherwise = Just [x]++-- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence+-- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second+-- list is empty and the first is equal to @ls@.+chopAtDelim :: Eq a => a -> [a] -> ([a],[a])+chopAtDelim elt xs =+ case break (==elt) xs of+ (_,[]) -> (xs,[])+ (as,_:bs) -> (as,bs)++data HttpError+ = ErrorReset+ | ErrorClosed+ | ErrorParse String+ | ErrorMisc Int String String+ deriving(Show,Eq)++instance Exception HttpError++parseInt :: String -> Maybe Int+parseInt string =+ case reads string of+ [(n,"")] -> Just n+ _ -> Nothing+++encodeString :: TextEncoding -> String -> IO LBS.ByteString+encodeString enc s = do+ cbuf <- newCharBuffer max_len ReadBuffer+ case enc of+ TextEncoding{mkTextEncoder=mkEncoder} ->+ bracket mkEncoder Enc.close $ \encoder -> do+ bss <- convert encoder cbuf s []+ return (LBS.fromChunks (reverse bss))+ where+ max_len = 256++ convert encoder cbuf cs bss+ | isEmptyBuffer cbuf && null cs = return bss+ | otherwise = do (cbuf,cs) <- pokeElems cbuf cs+ bbuf <- newByteBuffer max_len WriteBuffer+ (_,cbuf',bbuf') <- encode encoder cbuf bbuf+ let bs = BS.PS (bufRaw bbuf')+ (bufL bbuf')+ (bufferElems bbuf')+ convert encoder cbuf' cs (bs:bss)+ where+ pokeElems cbuf cs+ | null cs || isFullCharBuffer cbuf = return (cbuf,cs)+ pokeElems cbuf (c:cs) = do+ withBuffer cbuf $ \ptr ->+ pokeElemOff ptr (bufR cbuf) c+ pokeElems (bufferAdd 1 cbuf) cs ++decodeString :: TextEncoding -> BS.ByteString -> IO String+decodeString enc bs = + case bs of+ BS.PS fptr offs len -> do+ let bbuf = Buffer {+ bufRaw = fptr,+ bufState = ReadBuffer,+ bufSize = offs+len,+#if MIN_VERSION_base(4,15,0)+ bufOffset= 0,+#endif+ bufL = offs,+ bufR = offs+len+ }+ cbuf <- newCharBuffer len WriteBuffer+ case enc of+ TextEncoding{mkTextDecoder=mkDecoder} ->+ bracket mkDecoder Enc.close $ \decoder -> do+ (_,bbuf_,cbuf_) <- encode decoder bbuf cbuf+ withBuffer cbuf_ (peekArray (bufferElems cbuf_))
+ Network/TCP.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module : Network.TCP+-- Copyright : See LICENSE file+-- License : BSD+--+-- Maintainer : Krasimir Angelov <kr.angelov@gmail.com>+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- Some utility functions for working with the Haskell @network@ package. Mostly+-- for internal use by the @Network.HTTP@ code.+--+-----------------------------------------------------------------------------+module Network.TCP+ ( Connection+ , openTCPConnection+ , socketConnection+ , isTCPConnectedTo+ , readBlock+ , readLine+ , writeAscii+ , writeByteString+ , writeBytes+ , close, closeOnEnd+ ) where++import Network.Socket+ ( Socket, SocketOption(KeepAlive)+ , SocketType(Stream), connect+ , shutdown, ShutdownCmd(..)+ , setSocketOption, getPeerName+ , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo+ , defaultHints, addrFamily, withSocketsDo+ , addrSocketType, addrAddress+ )+import qualified Network.Socket as Socket ( sendBuf, recvBuf, close )+import Network.HTTP.Utils ( HttpError(..) )++import qualified OpenSSL.Session as SSL++import Control.Concurrent+import Control.Exception ( IOException, bracketOnError,+ try, catch, bracket, throwIO )+import Control.Monad ( when )+import Data.Char ( ord, toLower )+import Foreign+import Foreign.C.Types+import System.IO.Error ( isEOFError )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS ( ByteString(..), c2w )+import qualified Data.ByteString.Lazy as LBS+import GHC.IO.Buffer+import GHC.IO.Encoding hiding ( close )+import qualified GHC.IO.Encoding as Enc++-----------------------------------------------------------------+------------------ TCP Connections ------------------------------+-----------------------------------------------------------------++newtype Connection = Connection {getRef :: MVar Conn}++data Conn+ = MkConn { connSock :: !Socket+ , connSSL :: Maybe SSL.SSL+ , connByteBuf :: Buffer Word8+ , connCharBuf :: Buffer Char+ , connChunkBits :: !Int+ , connHost :: String+ , connPort :: !Int+ , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream.+ }+ | ConnClosed++readBlock :: Connection -> TextEncoding -> Int -> IO String+readBlock ref enc n =+ onNonClosedDo ref $ \conn ->+ catch (case enc of+ TextEncoding{mkTextDecoder=mkDecoder} -> do+ bracket mkDecoder Enc.close $ \decoder ->+ fetch decoder conn n)+ (\e -> if isEOFError e+ then do+ when (connCloseEOF conn) $ catch (closeQuick ref) (\(_ :: IOException) -> return ())+ return (conn,"")+ else throwIO e)+ where+ fetch decoder conn n+ | n > 0 = do+ bbuf <- if size > 0+ then withBuffer bbuf $ \buf_ptr -> do+ let ptr = buf_ptr `plusPtr` bufR bbuf+ num <- case connSSL conn of+ Just ssl -> SSL.readPtr ssl ptr size+ Nothing -> Socket.recvBuf (connSock conn) ptr size+ return (bufferAdd num bbuf)+ else return bbuf+ let bbufN = bbuf{bufR=bufL bbuf+min (n+connChunkBits conn) (bufferElems bbuf)}+ (progress,bbuf_,cbuf_) <- encode decoder bbufN cbuf++ (bbuf_,cbuf_,n_,b) <-+ let count = bufferElems bbufN-connChunkBits conn+ in case progress of+ InputUnderflow -> return (bbuf_,cbuf_,n-count,bufferElems bbuf_)+ OutputUnderflow -> return (bbuf_,cbuf_,n-(count-bufferElems bbuf_),0)+ InvalidSequence -> do (bbuf_,cbuf_) <- recover decoder bbuf_ cbuf_+ return (bbuf_,cbuf_,n-(count-bufferElems bbuf_),0)+ let len = bufferElems cbuf_+ cbuf' = bufferRemove len cbuf_+ s1 <- withBuffer cbuf_ (peekArray len)+ bbuf' <- if bufL bbuf_ == bufR bbuf_+ then if bufR bbufN == bufR bbuf+ then return bbuf{bufL=0,bufR=0}+ else slideContents (bbuf{bufL=bufR bbufN})+ else slideContents (bbuf{bufL=bufL bbuf_})+ let conn' = conn{connByteBuf=bbuf'+ ,connCharBuf=cbuf'+ ,connChunkBits=b+ }+ (conn,s2) <- fetch decoder conn' n_+ return (conn,s1++s2)+ | otherwise = return (conn,[])+ where+ bbuf = connByteBuf conn+ cbuf = connCharBuf conn+ size = min (n-bufferElems bbuf+connChunkBits conn) (bufferAvailable bbuf)+++readLine :: Connection -> TextEncoding -> IO String+readLine ref enc =+ onNonClosedDo ref $ \conn ->+ catch (case enc of+ TextEncoding{mkTextDecoder=mkDecoder} -> do+ bracket mkDecoder Enc.close $ \decoder ->+ fetch decoder conn)+ (\e ->+ if isEOFError e+ then do+ when (connCloseEOF conn) $ catch (closeQuick ref) (\(_ :: IOException) -> return ())+ return (conn,"")+ else throwIO e)+ where+ fetch decoder conn = do+ let bbuf = connByteBuf conn+ cbuf = connCharBuf conn+ size = bufferAvailable bbuf+ bbuf <- if bufferElems bbuf == 0+ then withBuffer bbuf $ \buf_ptr -> do+ let ptr = buf_ptr `plusPtr` bufR bbuf+ num <- case connSSL conn of+ Just ssl -> SSL.readPtr ssl ptr size+ Nothing -> Socket.recvBuf (connSock conn) ptr size+ return (bufferAdd num bbuf)+ else return bbuf+ if bufferElems bbuf == connChunkBits conn+ then return (conn, [])+ else do let start = bufL bbuf+connChunkBits conn+ (bbufNL,nl) <- scanNL start bbuf{bufL=start}+ (progress,bbuf_,cbuf_) <- encode decoder bbufNL cbuf+ (bbuf_,cbuf_) <- case progress of+ InvalidSequence -> recover decoder bbuf_ cbuf_+ _ -> return (bbuf_,cbuf_)+ let len = bufferElems cbuf_+ cbuf' = bufferRemove len cbuf_+ s1 <- withBuffer cbuf_ (peekArray len)+ bbuf' <- if connChunkBits conn+(bufR bbuf-bufR bbufNL)+bufferElems bbuf_ <= 0+ then return bbuf_{bufL=0,bufR=0}+ else slideContents' start (bufR bbufNL-bufferElems bbuf_) bbuf+ let conn' = conn{connByteBuf=bbuf'+ ,connCharBuf=cbuf'+ }+ if nl && bufferElems bbuf_ == 0+ then return (conn', s1)+ else do (conn,s2) <- fetch decoder conn'+ return (conn,s1++s2)++ scanNL i bbuf+ | i >= bufR bbuf =+ return (bbuf, False)+ | otherwise = do+ c <- withBuffer bbuf $ \ptr ->+ peekElemOff ptr i+ if c == fromIntegral (ord '\n')+ then return (bbuf{bufR=i+1}, True)+ else scanNL (i+1) bbuf++slideContents' :: Int -> Int -> Buffer Word8 -> IO (Buffer Word8)+slideContents' start end buf@Buffer{ bufR=r, bufRaw=raw } = do+ let elems = r - end+ withRawBuffer raw $ \p ->+ do _ <- memmove (p `plusPtr` start) (p `plusPtr` end) (fromIntegral elems)+ return ()+ return buf{ bufR=start+elems }++foreign import ccall unsafe "memmove"+ memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)++writeAscii :: Connection -> String -> IO ()+writeAscii ref s =+ onNonClosedDo ref $ \conn ->+ send conn s+ where+ send conn cs =+ let bbuf = connByteBuf conn+ in if null cs+ then return (conn,())+ else do (bbuf_,cs) <- pokeElems bbuf cs+ let n = bufferElems bbuf_+ withBuffer bbuf_ $ \ptr -> do+ case connSSL conn of+ Just ssl -> SSL.writePtr ssl ptr n+ Nothing -> writeSocketPtr (connSock conn) ptr n+ let bbuf' = bufferRemove n bbuf_+ conn' = conn{connByteBuf=bbuf'}+ send conn' cs+ where+ pokeElems bbuf cs+ | null cs || isFullCharBuffer bbuf = return (bbuf,cs)+ pokeElems bbuf (c:cs) = do+ withBuffer bbuf $ \ptr ->+ pokeElemOff ptr (bufR bbuf) (BS.c2w c)+ pokeElems (bufferAdd 1 bbuf) cs ++writeByteString :: Connection -> LBS.ByteString -> IO ()+writeByteString ref lbs =+ onNonClosedDo ref $ \conn -> do+ mapM_ (send conn) (LBS.toChunks lbs)+ return (conn,())+ where+ send conn (BS.PS fptr offs len) =+ withForeignPtr fptr $ \ptr ->+ case connSSL conn of+ Just ssl -> SSL.writePtr ssl (ptr `plusPtr` offs) len+ Nothing -> writeSocketPtr (connSock conn) (ptr `plusPtr` offs) len++writeBytes :: Connection -> Ptr Word8 -> Int -> IO ()+writeBytes ref ptr len = do+ onNonClosedDo ref $ \conn -> do+ case connSSL conn of+ Just ssl -> SSL.writePtr ssl ptr len+ Nothing -> writeSocketPtr (connSock conn) ptr len+ return (conn,())++writeSocketPtr :: Socket -> Ptr Word8 -> Int -> IO ()+writeSocketPtr conn ptr 0 = return ()+writeSocketPtr conn ptr len = do+ n <- Socket.sendBuf conn ptr len+ writeSocketPtr conn (ptr `plusPtr` n) (len-n)++-- Closes a Connection. Connection will no longer+-- allow any of the other 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 :: Connection -> IO ()+close c = closeIt c null True++-- Closes a Connection without munching the rest of the stream.+closeQuick :: Connection -> IO ()+closeQuick c = closeIt c null False++closeOnEnd :: Connection -> Bool -> IO ()+closeOnEnd c f = closeEOF c f++-- Add a "persistent" option? Current persistent is default.+-- Use "Result" type for synchronous exception reporting?+openTCPConnection :: Maybe SSL.SSLContext -> String -> Int -> IO Connection+openTCPConnection mb_ctx host port = do+ -- HACK: uri is sometimes obtained by calling Network.URI.uriRegName, and this includes+ -- the surrounding square brackets for an RFC 2732 host like [::1]. It's not clear whether+ -- it should, or whether all call sites should be using something different instead, but+ -- the simplest short-term fix is to strip any surrounding square brackets here.+ -- It shouldn't affect any as this is the only situation they can occur - see RFC 3986.+ let fixedHost =+ case host of+ '[':(rest@(c:_)) | last rest == ']'+ -> if c == 'v' || c == 'V'+ then error $ "Unsupported post-IPv6 address " ++ host+ else init rest+ '/':'/':host' -> host'+ _ -> host++ -- use withSocketsDo here in case the caller hasn't used it, which would make getAddrInfo fail on Windows+ -- although withSocketsDo is supposed to wrap the entire program, in practice it is safe to use it locally+ -- like this as it just does a once-only installation of a shutdown handler to run at program exit,+ -- rather than actually shutting down after the action+ addrinfos <- withSocketsDo $ getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) (Just fixedHost) (Just . show $ port)++ let+ connectAddrInfo a = bracketOnError+ (socket (addrFamily a) Stream defaultProtocol) -- acquire+ Socket.close -- release+ (\s -> do+ setSocketOption s KeepAlive 1+ connect s (addrAddress a)+ mb_ssl <- case mb_ctx of+ Nothing -> return Nothing+ Just ctxt -> do ssl <- SSL.connection ctxt s+ SSL.connect ssl+ return (Just ssl)+ socketConnection fixedHost port s mb_ssl)++ -- try multiple addresses; return Just connected socket or Nothing+ tryAddrInfos [] = return Nothing+ tryAddrInfos (h:t) =+ let next = \(_ :: IOException) -> tryAddrInfos t+ in try (connectAddrInfo h) >>= either next (return . Just)++ case addrinfos of+ [] -> fail "openTCPConnection: getAddrInfo returned no address information"++ -- single AddrInfo; call connectAddrInfo directly so that specific+ -- exception is thrown in event of failure+ [ai] -> connectAddrInfo ai `catch` (\e -> fail $+ "openTCPConnection: failed to connect to "+ ++ show (addrAddress ai) ++ ": " ++ show (e :: IOException))++ -- multiple AddrInfos; try each until we get a connection, or run out+ ais ->+ let+ err = fail $ "openTCPConnection: failed to connect; tried addresses: "+ ++ show (fmap addrAddress ais)+ in tryAddrInfos ais >>= maybe err return++-- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'.+socketConnection :: String+ -> Int+ -> Socket+ -> Maybe SSL.SSL+ -> IO Connection+socketConnection host port sock mb_ssl = do+ bbuf <- newByteBuffer 256 ReadBuffer+ cbuf <- newCharBuffer 256 WriteBuffer+ let conn = MkConn+ { connSock = sock+ , connSSL = mb_ssl+ , connByteBuf = bbuf+ , connCharBuf = cbuf+ , connChunkBits= 0+ , connHost = host+ , connPort = port+ , connCloseEOF = False+ }+ v <- newMVar conn+ return (Connection v)++closeConnection :: Connection -> 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+ modifyMVar_ (getRef ref) (\ _ -> return ConnClosed)+ where+ -- Be kind to peer & close gracefully.+ closeConn ConnClosed = return ()+ closeConn conn = do+ catch (do case connSSL conn of+ Just ssl -> SSL.shutdown ssl SSL.Unidirectional+ Nothing -> return ()+ shutdown (connSock conn) ShutdownSend+ suck readL+ shutdown (connSock conn) ShutdownReceive)+ (\(_ :: IOException) -> return ())+ Socket.close (connSock conn)++ suck :: IO Bool -> IO ()+ suck rd = do+ f <- rd+ if f then return () else suck rd++isTCPConnectedTo :: Connection -> String -> Int -> IO Bool+isTCPConnectedTo conn host port = do+ v <- readMVar (getRef conn)+ case v of+ ConnClosed -> return False+ _+ | map toLower (connHost v) == map toLower host &&+ connPort v == port ->+ catch (getPeerName (connSock v) >> return True) (\(_ :: IOException) -> return False)+ | otherwise -> return False++closeIt :: Connection -> (String -> Bool) -> Bool -> IO ()+closeIt c p b = do+ closeConnection c (if b+ then catch (fmap p (readLine c latin1)) (\(e :: HttpError) -> return True)+ else return True)++closeEOF :: Connection -> Bool -> IO ()+closeEOF c flg = modifyMVar_ (getRef c) (\co -> return co{connCloseEOF=flg})++onNonClosedDo :: Connection -> (Conn -> IO (Conn, b)) -> IO b+onNonClosedDo c act = modifyMVar (getRef c) $ \conn -> do+ case conn of+ ConnClosed -> throwIO ErrorClosed+ _ -> act conn
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ http-slim.cabal view
@@ -0,0 +1,84 @@+Cabal-Version: >= 1.10+Name: http-slim+Version: 1.0+Build-type: Simple+License: BSD3+License-file: LICENSE+Author: Krasimir Angelov <kr.angelov@gmail.com>+Maintainer: Krasimir Angelov <kr.angelov@gmail.com>+Homepage: https://github.com/krangelov/http-slim+Category: Network+Synopsis: A library for client/server HTTP with TLS support+Description:+ A simple HTTP client/server package with minimal dependencies+ to other packages. Most of the code is derived from + the older HTTP package. FastCGI interface is included as well.++tested-with:+ GHC==9.2.1, GHC==9.0.1,+ GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2,+ GHC==7.10.3, GHC==7.8.4, GHC==7.6.3++Source-Repository head+ type: git+ location: https://github.com/krangelov/http-slim.git++flag network-uri+ description: Get Network.URI from the network-uri package+ default: True++flag network-bsd+ description: Get Network.BSD from the network-bsd package+ default: True++Library+ Exposed-modules:+ Network.TCP,+ Network.HTTP,+ Network.HTTP.Headers,+ Network.HTTP.Base,+ Network.HTTP.Auth,+ Network.HTTP.Cookie,+ Network.HTTP.Proxy,+ Network.HTTP.HandleStream,+ Network.HTTP.MD5,+ Network.Browser,+ Network.FastCGI+ Other-modules:+ Network.HTTP.Base64,+ Network.HTTP.Utils+ Paths_http_slim+ GHC-options: -fwarn-missing-signatures++ -- note the test harness constraints should be kept in sync with these+ -- where dependencies are shared+ build-depends:+ base >= 4.6.0.0 && < 4.17+ , array >= 0.3.0.2 && < 0.6+ , parsec >= 2.0 && < 3.2+ , time >= 1.1.2.3 && < 1.13+ , transformers >= 0.2.0.0 && < 0.7+ -- transformers-0.2.0.0 is the first to have Control.Monad.IO.Class+ -- The following dependencies are refined by flags, but they should+ -- still be mentioned here on the top-level.+ , mtl >= 2.0.0.0 && < 2.4+ , network >= 2.4 && < 3.2+ , HsOpenSSL+ , bytestring+ , containers++ default-language: Haskell98+ default-extensions: FlexibleInstances++ if flag(network-uri)+ Build-depends: network-uri == 2.6.*, network >= 2.6+ else+ Build-depends: network < 2.6+ if flag(network-bsd)+ build-depends: network-bsd >= 2.7 && < 2.9,+ network >= 2.7+ else+ build-depends: network < 2.7++ if os(windows)+ Build-depends: Win32 >= 2.2.0.0 && < 2.14