diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/Browser.hs b/Network/Browser.hs new file mode 100644 --- /dev/null +++ b/Network/Browser.hs @@ -0,0 +1,1061 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, FlexibleContexts, ScopedTypeVariables #-} +{- | + +Module : Network.Browser +Copyright : See LICENSE file +License : BSD + +Maintainer : Krasimir Angelov +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 . +-- +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 diff --git a/Network/FastCGI.hs b/Network/FastCGI.hs new file mode 100644 --- /dev/null +++ b/Network/FastCGI.hs @@ -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] + } diff --git a/Network/HTTP.hs b/Network/HTTP.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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). diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Auth.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Auth +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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==':')) diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Base.hs @@ -0,0 +1,727 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Base +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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: +-- > +-- > //:@:/ +-- > Some or all of the parts ":@", ":", +-- > ":", and "/" 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 + }) diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Base64.hs @@ -0,0 +1,282 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Binary.Base64 +-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : Krasimir Angelov +-- Stability : experimental +-- Portability : portable +-- +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See +-- and . +-- +----------------------------------------------------------------------------- + +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 diff --git a/Network/HTTP/Cookie.hs b/Network/HTTP/Cookie.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Cookie.hs @@ -0,0 +1,228 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Cookie +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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==':')) diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/HandleStream.hs @@ -0,0 +1,312 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.HandleStream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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) diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Headers.hs @@ -0,0 +1,429 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Headers +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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 diff --git a/Network/HTTP/MD5.hs b/Network/HTTP/MD5.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/MD5.hs @@ -0,0 +1,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 diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Proxy.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Proxy +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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 diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Utils.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Utils +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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_)) diff --git a/Network/TCP.hs b/Network/TCP.hs new file mode 100644 --- /dev/null +++ b/Network/TCP.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.TCP +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Krasimir Angelov +-- 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/http-slim.cabal b/http-slim.cabal new file mode 100644 --- /dev/null +++ b/http-slim.cabal @@ -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 +Maintainer: Krasimir Angelov +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