direct-http (empty) → 0.5
raw patch · 4 files changed
+2364/−0 lines, 4 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, direct-daemonize, lifted-base, monad-control, mtl, network, old-locale, time, transformers-base, unix, utf8-string
Files
- LICENSE +22/−0
- Network/HTTP.hs +2291/−0
- Setup.hs +5/−0
- direct-http.cabal +46/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2009 Dan Knapp++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Network/HTTP.hs view
@@ -0,0 +1,2291 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts,+ DeriveDataTypeable #-}+module Network.HTTP (+ -- * The monad+ HTTP,+ HTTPState,+ MonadHTTP(..),+ + -- * Accepting requests+ HTTPServerParameters(..),+ HTTPListenSocketParameters(..),+ acceptLoop,+ + -- * Logging+ httpLog,+ + -- * Concurrency+ httpFork,+ + -- * Exceptions+ HTTPException(..),+ + -- * Request information+ -- | It is common practice for web servers to make their own+ -- extensions to the CGI/1.1 set of defined variables. For+ -- example, @REMOTE_PORT@ is not defined by the specification,+ -- but often seen in the wild. Furthermore, it is also common+ -- for user agents to make their own extensions to the HTTP/1.1+ -- set of defined headers. One might therefore expect to see+ -- functions defined here allowing direct interrogation of+ -- variables and headers by name. This is not done, because it+ -- is not the primary goal of direct-http to be a CGI/FastCGI+ -- host, and that functionality is trivial for any user code+ -- implementing such a host to provide. It would actually be+ -- rather more difficult for direct-http to provide many of the+ -- common values, because it does not implement the facilities+ -- they are supposed to give information about. Even as simple+ -- a concept as "what server address is this" must take into+ -- account name-canonicalization and virtual-host policies,+ -- which are left to user code. As for document root, it is+ -- possible to implement a server with no capacity to serve+ -- files, in which case the concept is nonsensical. Enough+ -- important values are necessarily absent for reasons such as+ -- these that there is little reason to provide the remaining+ -- ones either.+ -- + -- Too long, didn't read? Instead of providing access to+ -- CGI-like variables, direct-http provides higher-level calls+ -- which give convenient names and types to the same+ -- information. It does provide access to headers, however.+ -- + -- Cookies may also be manipulated through HTTP headers+ -- directly; the functions here are provided only as a+ -- convenience.+ Header(..),+ getRequestHeader,+ getAllRequestHeaders,+ Cookie(..),+ getCookie,+ getAllCookies,+ getCookieValue,+ getRemoteAddress,+ getRequestMethod,+ getRequestURI,+ getServerAddress,+ getContentLength,+ getContentType,+ + -- * Request content data+ -- | At the moment the handler is invoked, all request headers+ -- have been received, but content data has not necessarily+ -- been. Requests to read content data block the handler (but+ -- not other concurrent handlers) until there is enough data in+ -- the buffer to satisfy them, or until timeout where+ -- applicable.+ httpGet,+ httpGetNonBlocking,+ httpGetContents,+ httpIsReadable,+ + -- * Response information and content data+ -- | When the handler is first invoked, neither response headers+ -- nor content data have been sent to the client. Setting of+ -- response headers is lazy, merely setting internal variables,+ -- until something forces them to be output. For example,+ -- attempting to send content data will force response headers+ -- to be output first. It is not necessary to close the output+ -- stream explicitly, but it may be desirable, for example to+ -- continue processing after returning results to the user.+ -- + -- There is no reason that client scripts cannot use any+ -- encoding they wish, including the chunked encoding, if they+ -- have set appropriate headers. This package, however, does+ -- not explicitly support that, because client scripts can+ -- easily implement it for themselves.+ -- + -- At the start of each request, the response status is set to+ -- @200 OK@ and the only response header set is+ -- @Content-Type: text/html@. These may be overridden by later+ -- calls, at any time before headers have been sent.+ -- + -- Cookies may also be manipulated through HTTP headers+ -- directly; the functions here are provided only as a+ -- convenience.+ setResponseStatus,+ getResponseStatus,+ setResponseHeader,+ unsetResponseHeader,+ getResponseHeader,+ setCookie,+ unsetCookie,+ mkSimpleCookie,+ mkCookie,+ permanentRedirect,+ seeOtherRedirect,+ sendResponseHeaders,+ responseHeadersSent,+ responseHeadersModifiable,+ httpPut,+ httpPutStr,+ httpCloseOutput,+ httpIsWritable+ )+ where++import Control.Concurrent.Lifted+import Control.Exception.Lifted+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as UTF8+import Data.Char+import Data.List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Time+import Data.Time.Clock.POSIX+import Data.Typeable+import Data.Word+import Foreign.C.Error+import GHC.IO.Exception (IOErrorType(..))+import qualified Network.Socket as Network hiding (send, sendTo, recv, recvFrom)+import qualified Network.Socket.ByteString as Network+import Prelude hiding (catch)+import System.Daemonize+import System.Environment+import System.Exit+import System.IO+import System.IO.Error (ioeGetErrorType)+import qualified System.IO.Error as System+import System.Locale (defaultTimeLocale)+import qualified System.Posix as POSIX+++-- | An opaque type representing the state of the HTTP server during a single+-- connection from a client.+data HTTPState = HTTPState {+ httpStateAccessLogMaybeHandleMVar :: MVar (Maybe Handle),+ httpStateErrorLogMaybeHandleMVar :: MVar (Maybe Handle),+ httpStateForkPrimitive :: IO () -> IO ThreadId,+ httpStateThreadSetMVar :: MVar (Set ThreadId),+ httpStateThreadTerminationQSem :: QSem,+ httpStateMaybeConnection :: Maybe HTTPConnection+ }+++data HTTPConnection = HTTPConnection {+ httpConnectionServerAddress :: Network.SockAddr,+ httpConnectionSocket :: Network.Socket,+ httpConnectionPeer :: Network.SockAddr,+ httpConnectionInputBufferMVar :: MVar ByteString,+ httpConnectionTimestamp :: MVar POSIXTime,+ httpConnectionRemoteHostname :: MVar (Maybe (Maybe String)),+ httpConnectionRequestMethod :: MVar String,+ httpConnectionRequestURI :: MVar String,+ httpConnectionRequestProtocol :: MVar String,+ httpConnectionRequestHeaderMap :: MVar (Map Header ByteString),+ httpConnectionRequestCookieMap :: MVar (Maybe (Map String Cookie)),+ httpConnectionRequestContentBuffer :: MVar ByteString,+ httpConnectionRequestContentParameters :: MVar RequestContentParameters,+ httpConnectionResponseHeadersSent :: MVar Bool,+ httpConnectionResponseHeadersModifiable :: MVar Bool,+ httpConnectionResponseStatus :: MVar Int,+ httpConnectionResponseHeaderMap :: MVar (Map Header ByteString),+ httpConnectionResponseCookieMap :: MVar (Map String Cookie),+ httpConnectionResponseContentBuffer :: MVar ByteString,+ httpConnectionResponseContentParameters :: MVar ResponseContentParameters+ }+++data RequestContentParameters+ = RequestContentUninitialized+ | RequestContentNone+ | RequestContentClosed+ | RequestContentIdentity Int+ | RequestContentChunked Bool Int++data ResponseContentParameters+ = ResponseContentUninitialized+ | ResponseContentClosed+ | ResponseContentBufferedIdentity+ | ResponseContentUnbufferedIdentity Int+ | ResponseContentChunked+++-- | An object representing a cookie (a small piece of information, mostly+-- metadata, stored by a user-agent on behalf of the server), either one+-- received as part of the request or one to be sent as part of the+-- response.+data Cookie = Cookie {+ cookieName :: String,+ cookieValue :: String,+ cookieVersion :: Int,+ cookiePath :: Maybe String,+ cookieDomain :: Maybe String,+ cookieMaxAge :: Maybe Int,+ cookieSecure :: Bool,+ cookieComment :: Maybe String+ } deriving (Show)+++data ConnectionTerminatingError = UnexpectedEndOfInput+ deriving (Typeable)+++instance Exception ConnectionTerminatingError+++instance Show ConnectionTerminatingError where+ show UnexpectedEndOfInput = "Unexpected end of input."+++-- | The monad within which each single request from a client is handled.+-- +-- Note that there is an instance 'MonadBaseControl' 'IO' 'HTTP', so that+-- exceptions can be thrown, caught, and otherwise manipulated with the+-- lifted primitives from lifted-base's 'Control.Exception.Lifted'.+type HTTP = ReaderT HTTPState IO+++-- | The class of monads within which the HTTP calls are valid. You may wish+-- to create your own monad implementing this class. Note that the+-- prerequisite is 'MonadBaseControl' 'IO' m, which is similar to+-- 'MonadIO' m, but with, among other things, more capability for+-- exception handling.+class (MonadBaseControl IO m) => MonadHTTP m where+ -- | Returns the opaque 'HTTPState' object representing the state of+ -- the HTTP server.+ -- Should not be called directly by user code, except implementations of+ -- 'MonadHTTP'; exported so that+ -- user monads can implement the interface.+ getHTTPState :: m HTTPState+++instance MonadHTTP HTTP where+ getHTTPState = ask+++getHTTPConnection :: (MonadHTTP m) => m HTTPConnection+getHTTPConnection = do+ state <- getHTTPState+ case httpStateMaybeConnection state of+ Nothing -> throwIO NoConnection+ Just connection -> return connection+++-- | Forks a thread to run the given action, using the forking primitive that+-- was passed in the configuration to 'acceptLoop', and additionally+-- registers that thread with the main server thread, which has the sole+-- effect and purpose of causing the server to not exit until and unless the+-- child thread does. All of the listener-socket and connection threads+-- created by the server go through this function.+httpFork :: (MonadHTTP m) => m () -> m ThreadId+httpFork action = do+ state <- getHTTPState+ let mvar = httpStateThreadSetMVar state+ qsem = httpStateThreadTerminationQSem state+ threadSet <- takeMVar mvar+ childThread <- liftBaseDiscard (httpStateForkPrimitive state)+ $ finally action+ (do+ threadSet <- takeMVar mvar+ self <- myThreadId+ let threadSet' = Set.delete self threadSet'+ putMVar mvar threadSet'+ signalQSem qsem)+ let threadSet' = Set.insert childThread threadSet+ putMVar mvar threadSet'+ return childThread+++-- | A record used to configure the server. Broken informally into the four+-- categories of logging, job-control, concurrency, and networking. For+-- logging, the configuration contains optional paths to files for the+-- access and error logs (if these are omitted, logging is not done). For+-- job-control, it contains a flag indicating whether to run as a daemon,+-- and optionally the names of a Unix user and/or group to switch to in the+-- process of daemonization. For concurrency, it contains a forking+-- primitive such as 'forkIO' or 'forkOS'. Finally, for networking, it+-- contains a list of parameters for ports to listen on, each of which has+-- its own sub-configuration record.+-- +-- Notice that checking the value of the Host: header, and implementing+-- virtual-host policies, is not done by direct-http but rather is up to the+-- user of the library; hence, there is no information in the configuration+-- about the hostnames to accept from the user-agent.+-- +-- If the access logfile path is not Nothing, 'acceptLoop' opens this+-- logfile in append mode and uses it to log all accesses; otherwise, access+-- is not logged.+-- +-- If the error logfile path is not Nothing, 'acceptLoop' opens this logfile+-- in append mode and uses it to log all errors; otherwise, if not+-- daemonizing, errors are logged to standard output; if daemonizing, errors+-- are not logged.+-- +-- If the daemonize flag is True, 'acceptLoop' closes the standard IO+-- streams and moves the process into the background, doing all the usual+-- Unix things to make it run as a daemon henceforth. This is optional+-- because it might be useful to turn it off for debugging purposes.+-- +-- The forking primitive is typically either 'forkIO' or 'forkOS', and is+-- used by 'acceptLoop' both to create listener threads, and to create+-- connection threads. It is valid to use a custom primitive, such as one+-- that attempts to pool OS threads, but it must actually provide+-- concurrency - otherwise there will be a deadlock. There is no support for+-- single-threaded operation.+-- +-- Notice that we take the forking primitive in terms of 'IO', even though+-- we actually lift it (with 'liftBaseDiscard'). This is because+-- lifted-base, as of this writing and its version 0.1.1, only supports+-- 'forkIO' and not 'forkOS'.+-- +-- The loop never returns, but will terminate the program with status 0 if+-- and when it ever has no child threads alive; child threads for this+-- purpose are those created through 'httpFork', which means all+-- listener-socket and connection threads created by 'acceptLoop', as well+-- as any threads created by client code through 'httpFork', but not threads+-- created by client code through other mechanisms.+-- +-- The author of direct-http has made no effort to implement custom+-- thread-pooling forking primitives, but has attempted not to preclude+-- them. If anyone attempts to implement such a thing, feedback is hereby+-- solicited.+data HTTPServerParameters = HTTPServerParameters {+ serverParametersAccessLogPath :: Maybe FilePath,+ serverParametersErrorLogPath :: Maybe FilePath,+ serverParametersDaemonize :: Bool,+ serverParametersUserToChangeTo :: Maybe String,+ serverParametersGroupToChangeTo :: Maybe String,+ serverParametersForkPrimitive :: IO () -> IO ThreadId,+ serverParametersListenSockets :: [HTTPListenSocketParameters]+ }+++-- | A record used to configure an individual port listener and its socket as+-- part of the general server configuration. Consists of a host address and+-- port number to bind the socket to, and a flag indicating whether the+-- listener should use the secure version of the protocol.+data HTTPListenSocketParameters = HTTPListenSocketParameters {+ listenSocketParametersAddress :: Network.SockAddr,+ listenSocketParametersSecure :: Bool+ }+++-- | Takes a server parameters record and a handler, and concurrently accepts+-- requests from user agents, forking with the primitive specified by the+-- parameters and invoking the handler in the forked thread inside the+-- 'HTTP' monad for each request.+-- +-- Note that although there is no mechanism to substitute another type of+-- monad for HTTP, you can enter your own monad within the handler, much as+-- you would enter your own monad within IO. You simply have to implement+-- the 'MonadHTTP' class.+-- +-- Any exceptions not caught within the handler are caught by+-- 'acceptLoop', and cause the termination of that handler, but not+-- of the connection or the accept loop.+acceptLoop+ :: HTTPServerParameters+ -- ^ Parameters describing the behavior of the server to run.+ -> (HTTP ())+ -- ^ A handler which is invoked once for each incoming connection.+ -> IO ()+ -- ^ Never actually returns.+acceptLoop parameters handler = do+ (listenSockets, accessLogMaybeHandle, errorLogMaybeHandle)+ <- catch+ (do+ listenSockets <-+ mapM createListenSocket (serverParametersListenSockets parameters)+ accessLogMaybeHandle+ <- case serverParametersAccessLogPath parameters of+ Nothing -> return Nothing+ Just path -> openBinaryFile path AppendMode+ >>= return . Just+ errorLogMaybeHandle+ <- case serverParametersErrorLogPath parameters of+ Nothing -> if serverParametersDaemonize parameters+ then return Nothing+ else return $ Just stdout+ Just path -> openBinaryFile path AppendMode+ >>= return . Just+ return (listenSockets, accessLogMaybeHandle, errorLogMaybeHandle))+ (\e -> do+ hPutStrLn stderr+ $ "Failed to start: "+ ++ (show (e :: SomeException))+ exitFailure)+ accessLogMaybeHandleMVar <- newMVar accessLogMaybeHandle+ errorLogMaybeHandleMVar <- newMVar errorLogMaybeHandle+ let forkPrimitive = serverParametersForkPrimitive parameters+ threadSetMVar <- newMVar Set.empty+ threadTerminationQSem <- newQSem 0+ let state = HTTPState {+ httpStateAccessLogMaybeHandleMVar = accessLogMaybeHandleMVar,+ httpStateErrorLogMaybeHandleMVar = errorLogMaybeHandleMVar,+ httpStateForkPrimitive = forkPrimitive,+ httpStateThreadSetMVar = threadSetMVar,+ httpStateThreadTerminationQSem = threadTerminationQSem,+ httpStateMaybeConnection = Nothing+ }+ if serverParametersDaemonize parameters+ then daemonize (defaultDaemonOptions {+ daemonUserToChangeTo =+ serverParametersUserToChangeTo parameters,+ daemonGroupToChangeTo =+ serverParametersGroupToChangeTo parameters+ })+ $ acceptLoop' state listenSockets+ else acceptLoop' state listenSockets+ where acceptLoop' state listenSockets = do+ let acceptLoop'' :: Network.Socket -> HTTP ()+ acceptLoop'' listenSocket = do+ (socket, peer) <- liftBase $ Network.accept listenSocket+ httpFork $ requestLoop socket peer handler+ acceptLoop'' listenSocket+ flip runReaderT state $ do+ httpLog $ "Server started."+ threadIDs <-+ mapM (\listenSocket -> httpFork $ acceptLoop'' listenSocket)+ listenSockets+ threadWaitLoop+ threadWaitLoop = do+ state <- getHTTPState+ let mvar = httpStateThreadSetMVar state+ qsem = httpStateThreadTerminationQSem state+ threadSet <- readMVar mvar+ if Set.null threadSet+ then liftBase exitSuccess+ else do+ waitQSem qsem+ threadWaitLoop+++createListenSocket+ :: HTTPListenSocketParameters -> IO Network.Socket+createListenSocket parameters = do+ let address = listenSocketParametersAddress parameters+ addressFamily =+ case address of+ Network.SockAddrInet _ _ -> Network.AF_INET+ Network.SockAddrInet6 _ _ _ _ -> Network.AF_INET6+ Network.SockAddrUnix _ -> Network.AF_UNIX+ listenSocket <- Network.socket addressFamily+ Network.Stream+ Network.defaultProtocol+ Network.bindSocket listenSocket address+ Network.listen listenSocket 1024+ return listenSocket+++requestLoop :: Network.Socket+ -> Network.SockAddr+ -> HTTP ()+ -> HTTP ()+requestLoop socket peer handler = do+ serverAddress <- liftBase $ Network.getSocketName socket+ inputBufferMVar <- newMVar $ BS.empty+ timestampMVar <- newEmptyMVar+ remoteHostnameMVar <- newMVar Nothing+ requestMethodMVar <- newEmptyMVar+ requestURIMVar <- newEmptyMVar+ requestProtocolMVar <- newEmptyMVar+ requestHeaderMapMVar <- newEmptyMVar+ requestCookieMapMVar <- newEmptyMVar+ requestContentBufferMVar <- newEmptyMVar+ requestContentParametersMVar <- newEmptyMVar+ responseHeadersSentMVar <- newEmptyMVar+ responseHeadersModifiableMVar <- newEmptyMVar+ responseStatusMVar <- newEmptyMVar+ responseHeaderMapMVar <- newEmptyMVar+ responseCookieMapMVar <- newEmptyMVar+ responseContentBufferMVar <- newEmptyMVar+ responseContentParametersMVar <- newEmptyMVar+ let connection = HTTPConnection {+ httpConnectionServerAddress = serverAddress,+ httpConnectionSocket = socket,+ httpConnectionPeer = peer,+ httpConnectionInputBufferMVar = inputBufferMVar,+ httpConnectionTimestamp = timestampMVar,+ httpConnectionRemoteHostname = remoteHostnameMVar,+ httpConnectionRequestMethod = requestMethodMVar,+ httpConnectionRequestURI = requestURIMVar,+ httpConnectionRequestProtocol = requestProtocolMVar,+ httpConnectionRequestHeaderMap = requestHeaderMapMVar,+ httpConnectionRequestCookieMap = requestCookieMapMVar,+ httpConnectionRequestContentBuffer+ = requestContentBufferMVar,+ httpConnectionRequestContentParameters+ = requestContentParametersMVar,+ httpConnectionResponseHeadersSent+ = responseHeadersSentMVar,+ httpConnectionResponseHeadersModifiable+ = responseHeadersModifiableMVar,+ httpConnectionResponseStatus = responseStatusMVar,+ httpConnectionResponseHeaderMap = responseHeaderMapMVar,+ httpConnectionResponseCookieMap = responseCookieMapMVar,+ httpConnectionResponseContentBuffer+ = responseContentBufferMVar,+ httpConnectionResponseContentParameters+ = responseContentParametersMVar+ }+ requestLoop1 :: HTTP ()+ requestLoop1 = do+ finally requestLoop2+ (catch (liftBase $ Network.sClose socket)+ (\error -> do+ return (error :: IOException)+ return ()))+ requestLoop2 :: HTTP ()+ requestLoop2 = do+ catch requestLoop3+ (\error -> do+ httpLog $ "Internal uncaught exception: "+ ++ (show (error :: SomeException)))+ requestLoop3 :: HTTP ()+ requestLoop3 = do+ catch requestLoop4+ (\error -> do+ connection <- getHTTPConnection+ httpLog $ "Connection from "+ ++ (show $ httpConnectionPeer connection)+ ++ " terminated due to error: "+ ++ (show (error :: ConnectionTerminatingError)))+ requestLoop4 :: HTTP ()+ requestLoop4 = do+ maybeRequestInfo <- recvHeaders+ case maybeRequestInfo of+ Nothing -> return ()+ Just (method, url, protocol, headers) -> do+ timestamp <- liftBase getPOSIXTime+ putMVar timestampMVar timestamp+ putMVar requestMethodMVar $ UTF8.toString method+ putMVar requestURIMVar $ UTF8.toString url+ putMVar requestProtocolMVar $ UTF8.toString protocol+ putMVar requestHeaderMapMVar headers+ putMVar requestCookieMapMVar Nothing+ putMVar requestContentBufferMVar BS.empty+ putMVar requestContentParametersMVar RequestContentUninitialized+ putMVar responseHeadersSentMVar False+ putMVar responseHeadersModifiableMVar True+ putMVar responseStatusMVar 200+ putMVar responseHeaderMapMVar Map.empty+ putMVar responseCookieMapMVar Map.empty+ putMVar responseContentBufferMVar BS.empty+ putMVar responseContentParametersMVar ResponseContentUninitialized+ catch+ (do+ valid <- getRequestValid+ if valid+ then do+ prepareResponse+ handler+ else do+ setResponseStatus 400)+ (\error -> do+ httpLog $ "Uncaught exception: "+ ++ (show (error :: SomeException))+ alreadySent <- responseHeadersSent+ if alreadySent+ then return ()+ else setResponseStatus 500)+ logAccess+ isWritable <- httpIsWritable+ if isWritable+ then httpCloseOutput+ else return ()+ connectionShouldStayAlive <- getConnectionShouldStayAlive+ if connectionShouldStayAlive+ then do+ takeMVar timestampMVar+ takeMVar requestMethodMVar+ takeMVar requestURIMVar+ takeMVar requestProtocolMVar+ takeMVar requestHeaderMapMVar+ takeMVar requestCookieMapMVar+ takeMVar requestContentBufferMVar+ takeMVar requestContentParametersMVar+ takeMVar responseHeadersSentMVar+ takeMVar responseHeadersModifiableMVar+ takeMVar responseStatusMVar+ takeMVar responseHeaderMapMVar+ takeMVar responseCookieMapMVar+ takeMVar responseContentBufferMVar+ takeMVar responseContentParametersMVar+ requestLoop4+ else return ()+ state <- ask+ lift $ flip runReaderT+ (state { httpStateMaybeConnection = Just connection })+ requestLoop1+++getRequestValid :: (MonadHTTP m) => m Bool+getRequestValid = do+ hasContent <- getRequestHasContent+ let getHeadersValid = do+ connection <- getHTTPConnection+ headerMap <- readMVar $ httpConnectionRequestHeaderMap connection+ return $ all (\header -> (isValidInRequest header)+ && (hasContent+ || (not $ isValidOnlyWithEntity header)))+ $ Map.keys headerMap+ getContentValid = do+ contentAllowed <- getRequestContentAllowed+ return $ contentAllowed || not hasContent+ httpVersion <- getRequestProtocol+ case httpVersion of+ "HTTP/1.0" -> do+ headersValid <- getHeadersValid+ contentValid <- getContentValid+ return $ and [headersValid, contentValid]+ "HTTP/1.1" -> do+ headersValid <- getHeadersValid+ contentValid <- getContentValid+ mandatoryHeadersIncluded <- do+ maybeHost <- getRequestHeader HttpHost+ case maybeHost of+ Nothing -> return False+ Just host -> return True+ return $ and [headersValid, mandatoryHeadersIncluded, contentValid]+ _ -> return False+++getConnectionShouldStayAlive :: (MonadHTTP m) => m Bool+getConnectionShouldStayAlive = do+ httpVersion <- getRequestProtocol+ case httpVersion of+ "HTTP/1.0" -> return False+ "HTTP/1.1" -> do+ maybeConnection <- getRequestHeader HttpConnection+ case maybeConnection of+ Nothing -> return True+ Just connectionValue -> do+ let connectionWords = computeWords connectionValue+ computeWords input =+ let (before, after) = break (\c -> c == ' ') input+ in if null after+ then [before]+ else let rest = computeWords $ drop 1 after+ in before : rest+ connectionTokens = map (map toLower) connectionWords+ closeSpecified = elem "close" connectionTokens+ return $ not closeSpecified+ _ -> return False+++prepareResponse :: (MonadHTTP m) => m ()+prepareResponse = do+ HTTPConnection { httpConnectionTimestamp = mvar } <- getHTTPConnection+ timestamp <- readMVar mvar+ let dateString = formatTime defaultTimeLocale+ "%a, %d %b %Y %H:%M:%S Z"+ $ posixSecondsToUTCTime timestamp+ setResponseHeader HttpDate dateString+ setResponseHeader HttpContentType "text/html; charset=UTF8"+++logAccess :: (MonadHTTP m) => m ()+logAccess = do+ remoteHost <- getRemoteHost+ identString <- return "-"+ usernameString <- return "-"+ connection <- getHTTPConnection+ timestamp <- readMVar (httpConnectionTimestamp connection)+ let timestampString = formatTime defaultTimeLocale+ "%-d/%b/%Y:%H:%M:%S %z"+ $ posixSecondsToUTCTime timestamp+ methodString <- getRequestMethod+ urlString <- getRequestURI+ protocolString <- getRequestProtocol+ responseStatusString <- getResponseStatus >>= return . show+ maybeResponseSize <- return (Nothing :: Maybe Int) -- TODO+ responseSizeString+ <- case maybeResponseSize of+ Nothing -> return "-"+ Just responseSize -> return $ show responseSize+ maybeReferrerString <- getRequestHeader HttpReferrer+ referrerString <- case maybeReferrerString of+ Nothing -> return "-"+ Just referrerString -> return referrerString+ maybeUserAgentString <- getRequestHeader HttpUserAgent+ userAgentString <- case maybeUserAgentString of+ Nothing -> return "-"+ Just userAgentString -> return userAgentString+ httpAccessLog $ remoteHost+ ++ " "+ ++ identString+ ++ " "+ ++ usernameString+ ++ " ["+ ++ timestampString+ ++ "] \""+ ++ methodString+ ++ " "+ ++ urlString+ ++ " "+ ++ protocolString+ ++ "\" "+ ++ responseStatusString+ ++ " "+ ++ responseSizeString+ ++ " \""+ ++ referrerString+ ++ "\" \""+ ++ userAgentString+ ++ "\""+++parseCookies :: String -> [Cookie]+parseCookies value =+ let findSeparator string+ = let quotePoint = if (length string > 0) && (string !! 0 == '"')+ then 1 + (findBalancingQuote $ drop 1 string)+ else 0+ maybeSemicolonPoint+ = case (findIndex (\c -> (c == ';') || (c == ','))+ $ drop quotePoint string)+ of Nothing -> Nothing+ Just index -> Just $ index + quotePoint+ in maybeSemicolonPoint+ findBalancingQuote string+ = let consume accumulator ('\\' : c : rest) = consume (accumulator + 2) rest+ consume accumulator ('"' : rest) = accumulator+ consume accumulator (c : rest) = consume (accumulator + 1) rest+ consume accumulator "" = accumulator+ in consume 0 string+ split [] = []+ split string = case findSeparator string of+ Nothing -> [string]+ Just index ->+ let (first, rest) = splitAt index string+ in first : (split $ drop 1 rest)+ splitNameValuePair string = case elemIndex '=' (filterNameValuePair string) of+ Nothing -> (string, "")+ Just index -> let (first, rest)+ = splitAt index+ (filterNameValuePair+ string)+ in (first, filterValue (drop 1 rest))+ filterNameValuePair string+ = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace string+ filterValue string = if (length string > 0) && ((string !! 0) == '"')+ then take (findBalancingQuote $ drop 1 string)+ $ drop 1 string+ else string+ pairs = map splitNameValuePair $ split value+ (version, pairs') = case pairs of+ ("$Version", versionString) : rest+ -> case parseInt versionString of+ Nothing -> (0, rest)+ Just version -> (version, rest)+ _ -> (0, pairs)+ takeCookie pairs = case pairs of+ (name, value) : pairs'+ | (length name > 0) && (take 1 name /= "$")+ -> let (maybePath, maybeDomain, pairs'')+ = takePathAndDomain pairs'+ in (Cookie {+ cookieName = name,+ cookieValue = value,+ cookieVersion = version,+ cookiePath = maybePath,+ cookieDomain = maybeDomain,+ cookieMaxAge = Nothing,+ cookieSecure = False,+ cookieComment = Nothing+ }+ : takeCookie pairs'')+ _ : pairs' -> takeCookie pairs'+ [] -> []+ takePathAndDomain pairs = let (maybePath, pairs')+ = case pairs of ("$Path", path) : rest+ -> (Just path, rest)+ _ -> (Nothing, pairs)+ (maybeDomain, pairs'')+ = case pairs' of ("$Domain", domain) : rest+ -> (Just domain, rest)+ _ -> (Nothing, pairs')+ in (maybePath, maybeDomain, pairs'')+ in takeCookie pairs'+++printCookies :: [Cookie] -> ByteString+printCookies cookies =+ let printCookie cookie+ = BS.intercalate (UTF8.fromString ";")+ $ map printNameValuePair $ nameValuePairs cookie+ printNameValuePair (name, Nothing) = UTF8.fromString name+ printNameValuePair (name, Just value)+ = BS.concat [UTF8.fromString name,+ UTF8.fromString "=",+ UTF8.fromString value]+ {- Safari doesn't like this.+ = if isValidCookieToken value+ then name ++ "=" ++ value+ else name ++ "=\"" ++ escape value ++ "\""+ escape "" = ""+ escape ('\\':rest) = "\\\\" ++ escape rest+ escape ('\"':rest) = "\\\"" ++ escape rest+ escape (c:rest) = [c] ++ escape rest+ -}+ nameValuePairs cookie = [(cookieName cookie, Just $ cookieValue cookie)]+ ++ (case cookieComment cookie of+ Nothing -> []+ Just comment -> [("Comment", Just comment)])+ ++ (case cookieDomain cookie of+ Nothing -> []+ Just domain -> [("Domain", Just domain)])+ ++ (case cookieMaxAge cookie of+ Nothing -> []+ Just maxAge -> [("Max-Age", Just $ show maxAge)])+ ++ (case cookiePath cookie of+ Nothing -> []+ Just path -> [("Path", Just $ path)])+ ++ (case cookieSecure cookie of+ False -> []+ True -> [("Secure", Nothing)])+ ++ [("Version", Just $ show $ cookieVersion cookie)]+ in BS.intercalate (UTF8.fromString ",") $ map printCookie cookies+++parseInt :: String -> Maybe Int+parseInt string =+ if (not $ null string) && (all isDigit string)+ then Just $ let accumulate "" accumulator = accumulator+ accumulate (n:rest) accumulator+ = accumulate rest $ accumulator * 10 + digitToInt n+ in accumulate string 0+ else Nothing+++recvHeaders :: (MonadHTTP m)+ => m (Maybe (ByteString,+ ByteString,+ ByteString,+ Map Header ByteString))+recvHeaders = do+ HTTPConnection { httpConnectionInputBufferMVar = inputBufferMVar }+ <- getHTTPConnection+ inputBuffer <- takeMVar inputBufferMVar+ (inputBuffer, maybeLine) <- recvLine inputBuffer+ (inputBuffer, result) <- case maybeLine of+ Nothing -> return (inputBuffer, Nothing)+ Just line -> do+ let computeWords input =+ let (before, after) = BS.breakSubstring (UTF8.fromString " ") input+ in if BS.null after+ then [before]+ else let rest = computeWords $ BS.drop 1 after+ in before : rest+ words = computeWords line+ case words of+ [method, url, protocol]+ | (isValidMethod method)+ && (isValidURL url)+ && (isValidProtocol protocol)+ -> do+ let loop inputBuffer headersSoFar = do+ (inputBuffer, maybeLine) <- recvLine inputBuffer+ case maybeLine of+ Nothing -> return (inputBuffer, Nothing)+ Just line+ | BS.null line -> do+ return (inputBuffer,+ Just (method, url, protocol, headersSoFar))+ | otherwise -> do+ case parseHeader line of+ Nothing -> do+ logInvalidRequest+ return (inputBuffer, Nothing)+ Just (header, value) -> do+ let headersSoFar'+ = case Map.lookup header headersSoFar of+ Nothing -> Map.insert header+ value+ headersSoFar+ Just oldValue+ -> Map.insert+ header+ (BS.concat [oldValue,+ (UTF8.fromString ","),+ value])+ headersSoFar+ loop inputBuffer headersSoFar'+ loop inputBuffer Map.empty+ _ -> do+ logInvalidRequest+ return (inputBuffer, Nothing)+ putMVar inputBufferMVar inputBuffer+ return result+++parseHeader :: ByteString -> Maybe (Header, ByteString)+parseHeader line = do+ case BS.breakSubstring (UTF8.fromString ":") line of+ (_, bytestring) | bytestring == BS.empty -> Nothing+ (name, delimitedValue) -> Just (toHeader name, BS.drop 1 delimitedValue)+++logInvalidRequest :: MonadHTTP m => m ()+logInvalidRequest = do+ connection <- getHTTPConnection+ httpLog $ "Invalid request from "+ ++ (show $ httpConnectionPeer connection)+ ++ "; closing its connection."+++isValidMethod :: ByteString -> Bool+isValidMethod bytestring+ | bytestring == UTF8.fromString "OPTIONS" = True+ | bytestring == UTF8.fromString "GET" = True+ | bytestring == UTF8.fromString "HEAD" = True+ | bytestring == UTF8.fromString "POST" = True+ | bytestring == UTF8.fromString "PUT" = True+ | bytestring == UTF8.fromString "DELETE" = True+ | bytestring == UTF8.fromString "TRACE" = True+ | bytestring == UTF8.fromString "CONNECT" = True+ | otherwise = False+++isValidURL :: ByteString -> Bool+isValidURL _ = True+++isValidProtocol :: ByteString -> Bool+isValidProtocol bytestring+ | bytestring == UTF8.fromString "HTTP/1.0" = True+ | bytestring == UTF8.fromString "HTTP/1.1" = True+ | otherwise = False+++recvLine :: (MonadHTTP m) => ByteString -> m (ByteString, Maybe ByteString)+recvLine inputBuffer = do+ let loop inputBuffer length firstIteration = do+ let blocking = not firstIteration+ (inputBuffer, endOfInput)+ <- extendInputBuffer inputBuffer length blocking+ let (before, after)+ = BS.breakSubstring (UTF8.fromString "\r\n") inputBuffer+ if BS.null after+ then if endOfInput+ then return (inputBuffer, Nothing)+ else loop inputBuffer (length + 80) False+ else return (BS.drop 2 after, Just before)+ let (before, after)+ = BS.breakSubstring (UTF8.fromString "\r\n") inputBuffer+ if BS.null after+ then loop inputBuffer 80 True+ else return (BS.drop 2 after, Just before)+++recvBlock :: (MonadHTTP m) => Int -> m ByteString+recvBlock length = do+ HTTPConnection { httpConnectionInputBufferMVar = inputBufferMVar } <- getHTTPConnection+ inputBuffer <- takeMVar inputBufferMVar+ (inputBuffer, endOfInput)+ <- extendInputBuffer inputBuffer length True+ (result, inputBuffer) <- return $ BS.splitAt length inputBuffer+ putMVar inputBufferMVar inputBuffer+ return result+++extendInputBuffer :: (MonadHTTP m)+ => ByteString -> Int -> Bool -> m (ByteString, Bool)+extendInputBuffer inputBuffer length blocking = do+ HTTPConnection { httpConnectionSocket = socket } <- getHTTPConnection+ let loop inputBuffer = do+ if BS.length inputBuffer < length+ then do+ newInput <- liftBase $ Network.recv socket 4096+ if BS.null newInput+ then return (inputBuffer, True)+ else if blocking+ then loop $ BS.append inputBuffer newInput+ else return (BS.append inputBuffer newInput, False)+ else return (inputBuffer, False)+ loop inputBuffer+++-- | Logs a message using the web server's logging facility, prefixed with a+-- timestamp.+httpLog :: (MonadHTTP m) => String -> m ()+httpLog message = do+ HTTPState { httpStateErrorLogMaybeHandleMVar = logMVar } <- getHTTPState+ bracket (takeMVar logMVar)+ (\maybeHandle -> putMVar logMVar maybeHandle)+ (\maybeHandle -> do+ case maybeHandle of+ Nothing -> return ()+ Just handle -> do+ timestamp <- liftBase $ getPOSIXTime+ let timestampString =+ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"+ $ posixSecondsToUTCTime timestamp+ liftBase $ hPutStrLn handle+ $ timestampString ++ " " ++ message+ liftBase $ hFlush handle)+++httpAccessLog :: (MonadHTTP m) => String -> m ()+httpAccessLog message = do+ HTTPState { httpStateAccessLogMaybeHandleMVar = logMVar } <- getHTTPState+ withMVar logMVar+ (\maybeHandle -> case maybeHandle of+ Nothing -> return ()+ Just handle -> do+ liftBase $ hPutStrLn handle message+ liftBase $ hFlush handle)+++-- | Headers are classified by HTTP/1.1 as request headers, response headers,+-- entity headers, or general headers.+data Header+ -- | Request headers+ = HttpAccept+ | HttpAcceptCharset+ | HttpAcceptEncoding+ | HttpAcceptLanguage+ | HttpAuthorization+ | HttpExpect+ | HttpFrom+ | HttpHost+ | HttpIfMatch+ | HttpIfModifiedSince+ | HttpIfNoneMatch+ | HttpIfRange+ | HttpIfUnmodifiedSince+ | HttpMaxForwards+ | HttpProxyAuthorization+ | HttpRange+ | HttpReferrer+ | HttpTE+ | HttpUserAgent+ -- | Response headers+ | HttpAcceptRanges+ | HttpAge+ | HttpETag+ | HttpLocation+ | HttpProxyAuthenticate+ | HttpRetryAfter+ | HttpServer+ | HttpVary+ | HttpWWWAuthenticate+ -- | Entity headers+ | HttpAllow+ | HttpContentEncoding+ | HttpContentLanguage+ | HttpContentLength+ | HttpContentLocation+ | HttpContentMD5+ | HttpContentRange+ | HttpContentType+ | HttpExpires+ | HttpLastModified+ | HttpExtensionHeader ByteString+ -- | General headers+ | HttpCacheControl+ | HttpConnection+ | HttpDate+ | HttpPragma+ | HttpTrailer+ | HttpTransferEncoding+ | HttpUpgrade+ | HttpVia+ | HttpWarning+ -- | Nonstandard headers+ | HttpCookie+ | HttpSetCookie+ deriving (Eq, Ord)+++instance Show Header where + show header = UTF8.toString $ fromHeader header+++data HeaderType = RequestHeader+ | ResponseHeader+ | EntityHeader+ | GeneralHeader+ deriving (Eq, Show)+++headerType :: Header -> HeaderType+headerType HttpAccept = RequestHeader+headerType HttpAcceptCharset = RequestHeader+headerType HttpAcceptEncoding = RequestHeader+headerType HttpAcceptLanguage = RequestHeader+headerType HttpAuthorization = RequestHeader+headerType HttpExpect = RequestHeader+headerType HttpFrom = RequestHeader+headerType HttpHost = RequestHeader+headerType HttpIfMatch = RequestHeader+headerType HttpIfModifiedSince = RequestHeader+headerType HttpIfNoneMatch = RequestHeader+headerType HttpIfRange = RequestHeader+headerType HttpIfUnmodifiedSince = RequestHeader+headerType HttpMaxForwards = RequestHeader+headerType HttpProxyAuthorization = RequestHeader+headerType HttpRange = RequestHeader+headerType HttpReferrer = RequestHeader+headerType HttpTE = RequestHeader+headerType HttpUserAgent = RequestHeader+headerType HttpAcceptRanges = ResponseHeader+headerType HttpAge = ResponseHeader+headerType HttpETag = ResponseHeader+headerType HttpLocation = ResponseHeader+headerType HttpProxyAuthenticate = ResponseHeader+headerType HttpRetryAfter = ResponseHeader+headerType HttpServer = ResponseHeader+headerType HttpVary = ResponseHeader+headerType HttpWWWAuthenticate = ResponseHeader+headerType HttpAllow = EntityHeader+headerType HttpContentEncoding = EntityHeader+headerType HttpContentLanguage = EntityHeader+headerType HttpContentLength = EntityHeader+headerType HttpContentLocation = EntityHeader+headerType HttpContentMD5 = EntityHeader+headerType HttpContentRange = EntityHeader+headerType HttpContentType = EntityHeader+headerType HttpExpires = EntityHeader+headerType HttpLastModified = EntityHeader+headerType (HttpExtensionHeader _) = EntityHeader+headerType HttpCacheControl = GeneralHeader+headerType HttpConnection = GeneralHeader+headerType HttpDate = GeneralHeader+headerType HttpPragma = GeneralHeader+headerType HttpTrailer = GeneralHeader+headerType HttpTransferEncoding = GeneralHeader+headerType HttpUpgrade = GeneralHeader+headerType HttpVia = GeneralHeader+headerType HttpWarning = GeneralHeader+headerType HttpCookie = RequestHeader+headerType HttpSetCookie = ResponseHeader+++fromHeader :: Header -> ByteString+fromHeader HttpAccept = UTF8.fromString "Accept"+fromHeader HttpAcceptCharset = UTF8.fromString "Accept-Charset"+fromHeader HttpAcceptEncoding = UTF8.fromString "Accept-Encoding"+fromHeader HttpAcceptLanguage = UTF8.fromString "Accept-Language"+fromHeader HttpAuthorization = UTF8.fromString "Authorization"+fromHeader HttpExpect = UTF8.fromString "Expect"+fromHeader HttpFrom = UTF8.fromString "From"+fromHeader HttpHost = UTF8.fromString "Host"+fromHeader HttpIfMatch = UTF8.fromString "If-Match"+fromHeader HttpIfModifiedSince = UTF8.fromString "If-Modified-Since"+fromHeader HttpIfNoneMatch = UTF8.fromString "If-None-Match"+fromHeader HttpIfRange = UTF8.fromString "If-Range"+fromHeader HttpIfUnmodifiedSince = UTF8.fromString "If-Unmodified-Since"+fromHeader HttpMaxForwards = UTF8.fromString "Max-Forwards"+fromHeader HttpProxyAuthorization = UTF8.fromString "Proxy-Authorization"+fromHeader HttpRange = UTF8.fromString "Range"+fromHeader HttpReferrer = UTF8.fromString "Referer"+fromHeader HttpTE = UTF8.fromString "TE"+fromHeader HttpUserAgent = UTF8.fromString "User-Agent"+fromHeader HttpAcceptRanges = UTF8.fromString "Accept-Ranges"+fromHeader HttpAge = UTF8.fromString "Age"+fromHeader HttpETag = UTF8.fromString "ETag"+fromHeader HttpLocation = UTF8.fromString "Location"+fromHeader HttpProxyAuthenticate = UTF8.fromString "Proxy-Authenticate"+fromHeader HttpRetryAfter = UTF8.fromString "Retry-After"+fromHeader HttpServer = UTF8.fromString "Server"+fromHeader HttpVary = UTF8.fromString "Vary"+fromHeader HttpWWWAuthenticate = UTF8.fromString "WWW-Authenticate"+fromHeader HttpAllow = UTF8.fromString "Allow"+fromHeader HttpContentEncoding = UTF8.fromString "Content-Encoding"+fromHeader HttpContentLanguage = UTF8.fromString "Content-Language"+fromHeader HttpContentLength = UTF8.fromString "Content-Length"+fromHeader HttpContentLocation = UTF8.fromString "Content-Location"+fromHeader HttpContentMD5 = UTF8.fromString "Content-MD5"+fromHeader HttpContentRange = UTF8.fromString "Content-Range"+fromHeader HttpContentType = UTF8.fromString "Content-Type"+fromHeader HttpExpires = UTF8.fromString "Expires"+fromHeader HttpLastModified = UTF8.fromString "Last-Modified"+fromHeader (HttpExtensionHeader name) = name+fromHeader HttpCacheControl = UTF8.fromString "Cache-Control"+fromHeader HttpConnection = UTF8.fromString "Connection"+fromHeader HttpDate = UTF8.fromString "Date"+fromHeader HttpPragma = UTF8.fromString "Pragma"+fromHeader HttpTrailer = UTF8.fromString "Trailer"+fromHeader HttpTransferEncoding = UTF8.fromString "Transfer-Encoding"+fromHeader HttpUpgrade = UTF8.fromString "Upgrade"+fromHeader HttpVia = UTF8.fromString "Via"+fromHeader HttpWarning = UTF8.fromString "Warning"+fromHeader HttpCookie = UTF8.fromString "Cookie"+fromHeader HttpSetCookie = UTF8.fromString "Set-Cookie"+++toHeader :: ByteString -> Header+toHeader bytestring+ | bytestring == UTF8.fromString "Accept" = HttpAccept+ | bytestring == UTF8.fromString "Accept-Charset" = HttpAcceptCharset+ | bytestring == UTF8.fromString "Accept-Encoding" = HttpAcceptEncoding+ | bytestring == UTF8.fromString "Accept-Language" = HttpAcceptLanguage+ | bytestring == UTF8.fromString "Authorization" = HttpAuthorization+ | bytestring == UTF8.fromString "Expect" = HttpExpect+ | bytestring == UTF8.fromString "From" = HttpFrom+ | bytestring == UTF8.fromString "Host" = HttpHost+ | bytestring == UTF8.fromString "If-Match" = HttpIfMatch+ | bytestring == UTF8.fromString "If-Modified-Since" = HttpIfModifiedSince+ | bytestring == UTF8.fromString "If-None-Match" = HttpIfNoneMatch+ | bytestring == UTF8.fromString "If-Range" = HttpIfRange+ | bytestring == UTF8.fromString "If-Unmodified-Since" = HttpIfUnmodifiedSince+ | bytestring == UTF8.fromString "Max-Forwards" = HttpMaxForwards+ | bytestring == UTF8.fromString "Proxy-Authorization" = HttpProxyAuthorization+ | bytestring == UTF8.fromString "Range" = HttpRange+ | bytestring == UTF8.fromString "Referer" = HttpReferrer+ | bytestring == UTF8.fromString "TE" = HttpTE+ | bytestring == UTF8.fromString "User-Agent" = HttpUserAgent+ | bytestring == UTF8.fromString "Accept-Ranges" = HttpAcceptRanges+ | bytestring == UTF8.fromString "Age" = HttpAge+ | bytestring == UTF8.fromString "ETag" = HttpETag+ | bytestring == UTF8.fromString "Location" = HttpLocation+ | bytestring == UTF8.fromString "Proxy-Authenticate" = HttpProxyAuthenticate+ | bytestring == UTF8.fromString "Retry-After" = HttpRetryAfter+ | bytestring == UTF8.fromString "Server" = HttpServer+ | bytestring == UTF8.fromString "Vary" = HttpVary+ | bytestring == UTF8.fromString "WWW-Authenticate" = HttpWWWAuthenticate+ | bytestring == UTF8.fromString "Allow" = HttpAllow+ | bytestring == UTF8.fromString "Content-Encoding" = HttpContentEncoding+ | bytestring == UTF8.fromString "Content-Language" = HttpContentLanguage+ | bytestring == UTF8.fromString "Content-Length" = HttpContentLength+ | bytestring == UTF8.fromString "Content-Location" = HttpContentLocation+ | bytestring == UTF8.fromString "Content-MD5" = HttpContentMD5+ | bytestring == UTF8.fromString "Content-Range" = HttpContentRange+ | bytestring == UTF8.fromString "Content-Type" = HttpContentType+ | bytestring == UTF8.fromString "Expires" = HttpExpires+ | bytestring == UTF8.fromString "Last-Modified" = HttpLastModified+ | bytestring == UTF8.fromString "Cache-Control" = HttpCacheControl+ | bytestring == UTF8.fromString "Connection" = HttpConnection+ | bytestring == UTF8.fromString "Date" = HttpDate+ | bytestring == UTF8.fromString "Pragma" = HttpPragma+ | bytestring == UTF8.fromString "Trailer" = HttpTrailer+ | bytestring == UTF8.fromString "Transfer-Encoding" = HttpTransferEncoding+ | bytestring == UTF8.fromString "Upgrade" = HttpUpgrade+ | bytestring == UTF8.fromString "Via" = HttpVia+ | bytestring == UTF8.fromString "Warning" = HttpWarning+ | bytestring == UTF8.fromString "Cookie" = HttpCookie+ | bytestring == UTF8.fromString "Set-Cookie" = HttpSetCookie+ | otherwise = HttpExtensionHeader bytestring+++isValidInRequest :: Header -> Bool+isValidInRequest header = (headerType header == RequestHeader)+ || (headerType header == EntityHeader)+ || (headerType header == GeneralHeader)+++isValidInResponse :: Header -> Bool+isValidInResponse header = (headerType header == ResponseHeader)+ || (headerType header == EntityHeader)+ || (headerType header == GeneralHeader)+++isValidOnlyWithEntity :: Header -> Bool+isValidOnlyWithEntity header = headerType header == EntityHeader+++-- | Queries the value from the user agent of the given HTTP/1.1 header. If+-- the header is to be provided after the content as specified by the+-- Trailer header, this is potentially time-consuming.+getRequestHeader+ :: (MonadHTTP m)+ => Header+ -- ^ The header to query. Must be a request or entity header.+ -> m (Maybe String)+ -- ^ The value of the header, if the user agent provided one.+getRequestHeader header = do+ connection <- getHTTPConnection+ headerMap <- readMVar $ httpConnectionRequestHeaderMap connection+ return $ fmap (stripHeaderValueWhitespace . UTF8.toString)+ $ Map.lookup header headerMap+++stripHeaderValueWhitespace :: String -> String+stripHeaderValueWhitespace input =+ let input' = reverse $ dropWhile isHeaderValueWhitespace+ $ reverse $ dropWhile isHeaderValueWhitespace input+ computeWords input = case break isHeaderValueWhitespace input of+ (all, "") -> [all]+ (before, after)+ -> [before]+ ++ (computeWords+ $ dropWhile isHeaderValueWhitespace after)+ words = computeWords input'+ output = intercalate " " words+ in output+++isHeaderValueWhitespace :: Char -> Bool+isHeaderValueWhitespace char = elem char " \t\r\n"+++-- | Returns an association list of name-value pairs of all the HTTP/1.1 request+-- or entity headers from the user agent. If some of these headers are to be+-- provided after the content as specified by the Trailer header, this is+-- potentially time-consuming.+getAllRequestHeaders :: (MonadHTTP m) => m [(Header, String)]+getAllRequestHeaders = do+ connection <- getHTTPConnection+ headerMap <- readMVar $ httpConnectionRequestHeaderMap connection+ return $ map (\(header, bytestring) -> (header, UTF8.toString bytestring))+ $ Map.toList headerMap+++-- | Returns a 'Cookie' object for the given name, if the user agent provided one+-- in accordance with RFC 2109.+getCookie+ :: (MonadHTTP m)+ => String -- ^ The name of the cookie to look for.+ -> m (Maybe Cookie) -- ^ The cookie, if the user agent provided it.+getCookie name = do+ cookieMap <- getRequestCookieMap+ return $ Map.lookup name cookieMap+++-- | Returns all 'Cookie' objects provided by the user agent in accordance +-- RFC 2109.+getAllCookies :: (MonadHTTP m) => m [Cookie]+getAllCookies = do+ cookieMap <- getRequestCookieMap+ return $ Map.elems cookieMap+++-- | A convenience method; as 'getCookie', but returns only the value of the+-- cookie rather than a 'Cookie' object.+getCookieValue+ :: (MonadHTTP m)+ => String+ -- ^ The name of the cookie to look for.+ -> m (Maybe String)+ -- ^ The value of the cookie, if the user agent provided it.+getCookieValue name = do+ cookieMap <- getRequestCookieMap+ return $ fmap cookieValue $ Map.lookup name cookieMap+++getRequestCookieMap :: (MonadHTTP m) => m (Map String Cookie)+getRequestCookieMap = do+ connection <- getHTTPConnection+ let mvar = httpConnectionRequestCookieMap connection+ maybeCookieMap <- takeMVar mvar+ case maybeCookieMap of+ Just cookieMap -> do+ putMVar mvar maybeCookieMap+ return cookieMap+ Nothing -> do+ maybeCookieString <- getRequestHeader HttpCookie+ let cookieMap =+ case maybeCookieString of+ Nothing -> Map.empty+ Just cookieString ->+ Map.fromList (map (\cookie -> (cookieName cookie, cookie))+ (parseCookies cookieString))+ putMVar mvar (Just cookieMap)+ return cookieMap+++-- | Return the remote address, which includes both host and port information.+-- They are provided in the aggregate like this because it is the most+-- internet-protocol-agnostic representation.+getRemoteAddress :: (MonadHTTP m) => m Network.SockAddr+getRemoteAddress = do+ connection <- getHTTPConnection+ return $ httpConnectionPeer connection+++-- | Return the remote hostname, as determined by the web server. If it has+-- not yet been looked up, performs the lookup. This is potentially+-- time-consuming.+getRemoteHost :: (MonadHTTP m) => m String+getRemoteHost = do+ connection <- getHTTPConnection+ let mvar = httpConnectionRemoteHostname connection+ maybeMaybeHostname <- readMVar mvar+ case maybeMaybeHostname of+ Nothing -> do+ catch (do+ (maybeHostname, _) <-+ liftBase $ Network.getNameInfo [] True False+ (httpConnectionPeer connection)+ swapMVar mvar $ Just maybeHostname+ case maybeHostname of+ Nothing -> return $ show (httpConnectionPeer connection)+ Just hostname -> return hostname)+ (\exception -> do+ return (exception :: SomeException)+ return $ show (httpConnectionPeer connection))+ Just Nothing -> return $ show (httpConnectionPeer connection)+ Just (Just hostname) -> return hostname+++-- | Return the request method.+getRequestMethod :: (MonadHTTP m) => m String+getRequestMethod = do+ connection <- getHTTPConnection+ readMVar (httpConnectionRequestMethod connection)+++-- | Return the request URI.+getRequestURI :: (MonadHTTP m) => m String+getRequestURI = do+ connection <- getHTTPConnection+ readMVar (httpConnectionRequestURI connection)+++getRequestProtocol :: (MonadHTTP m) => m String+getRequestProtocol = do+ connection <- getHTTPConnection+ readMVar (httpConnectionRequestProtocol connection)+++-- | Return the server address and port, as a 'Network.SockAddr'. Useful+-- for implementing virtual-hosting policies.+getServerAddress :: (MonadHTTP m) => m Network.SockAddr+getServerAddress = do+ connection <- getHTTPConnection+ return $ httpConnectionServerAddress connection+++-- | Return whether the connection is via the secure version of the+-- protocol. Useful for implementing virtual-hosting policies.+getServerSecure :: (MonadHTTP m) => m Bool+getServerSecure = do+ return False+++-- | Return the request content length, if this is knowable without actually+-- receiving the content - in particular, if the Content-Length header was+-- used. Otherwise, returns Nothing.+getContentLength :: (MonadHTTP m) => m (Maybe Int)+getContentLength = do+ maybeString <- getRequestHeader HttpContentLength+ case maybeString of+ Nothing -> return Nothing+ Just string -> return $ parseInt string+++-- | Return the request content type, as provided by the user agent.+getContentType :: (MonadHTTP m) => m (Maybe String)+getContentType = do+ getRequestHeader HttpContentType+++getRequestHasContent :: (MonadHTTP m) => m Bool+getRequestHasContent = do+ HTTPConnection { httpConnectionRequestContentParameters = parametersMVar }+ <- getHTTPConnection+ parameters <- takeMVar parametersMVar+ parameters <- ensureRequestContentParametersInitialized parameters+ putMVar parametersMVar parameters+ return $ case parameters of+ RequestContentNone -> False+ _ -> True+++getRequestContentAllowed :: (MonadHTTP m) => m Bool+getRequestContentAllowed = do+ method <- getRequestMethod+ case method of+ _ | method == "OPTIONS" -> return True+ | method == "GET" -> return False+ | method == "HEAD" -> return False+ | method == "POST" -> return True+ | method == "PUT" -> return True+ | method == "DELETE" -> return False+ | method == "TRACE" -> return False+ | method == "CONNECT" -> return True+ | otherwise -> return True+++-- | Reads up to a specified amount of data from the content of the HTTP+-- request, if any, and interprets it as binary data. If input has been+-- closed, returns an empty bytestring. If no input is immediately+-- available, blocks until there is some. If output has been closed, causes+-- an 'OutputAlreadyClosed' exception.+httpGet :: (MonadHTTP m) => Int -> m BS.ByteString+httpGet size = httpGet' (Just size) True False+++-- | Reads up to a specified amount of data from the content of the HTTP+-- request, if any, and interprets it as binary data. If input has been+-- closed, returns an empty bytestring. If insufficient input is available,+-- returns any input which is immediately available, or an empty bytestring+-- if there is none, never blocking. If output has been closed, causes an+-- 'OutputAlreadyClosed' exception.+httpGetNonBlocking :: (MonadHTTP m) => Int -> m BS.ByteString+httpGetNonBlocking size = httpGet' (Just size) False False+++-- | Reads all remaining data from the content of the HTTP request, if any,+-- and interprets it as binary data. Blocks until all input has been+-- read. If input has been closed, returns an empty bytestring. If output+-- has been closed, causes an 'OutputAlreadyClosed' exception.+httpGetContents :: (MonadHTTP m) => m BS.ByteString+httpGetContents = httpGet' Nothing True False+++-- | Returns whether the content of the HTTP request potentially has data+-- remaining, either in the buffer or yet to be read.+httpIsReadable :: (MonadHTTP m) => m Bool+httpIsReadable = do+ HTTPConnection { httpConnectionRequestContentParameters = parametersMVar }+ <- getHTTPConnection+ parameters <- takeMVar parametersMVar+ parameters <- ensureRequestContentParametersInitialized parameters+ putMVar parametersMVar parameters+ return $ case parameters of+ RequestContentNone -> False+ RequestContentClosed -> False+ _ -> True+++httpGet' :: (MonadHTTP m) => (Maybe Int) -> Bool -> Bool -> m BS.ByteString+httpGet' maybeSize blocking discarding = do+ if not discarding+ then requireOutputNotYetClosed+ else return ()+ HTTPConnection {+ httpConnectionRequestContentBuffer = bufferMVar,+ httpConnectionRequestContentParameters = parametersMVar+ } <- getHTTPConnection+ buffer <- takeMVar bufferMVar+ parameters <- takeMVar parametersMVar+ parameters <- ensureRequestContentParametersInitialized parameters+ (buffer, parameters)+ <- extendRequestContentBuffer buffer parameters maybeSize blocking+ (result, buffer) <- return $ case maybeSize of+ Nothing -> (buffer, BS.empty)+ Just size -> BS.splitAt size buffer+ putMVar parametersMVar parameters+ putMVar bufferMVar buffer+ return result+++ensureRequestContentParametersInitialized+ :: (MonadHTTP m)+ => RequestContentParameters+ -> m RequestContentParameters+ensureRequestContentParametersInitialized RequestContentUninitialized = do+ maybeLength <- getContentLength+ maybeTransferEncodingString <- getRequestHeader HttpTransferEncoding+ let (hasContent, chunked)+ = case (maybeLength, maybeTransferEncodingString) of+ (Nothing, Nothing) -> (False, False)+ (Just length, Nothing) -> (True, False)+ (Just length, Just encoding)+ | map toLower encoding == "identity" -> (True, False)+ | otherwise -> (True, True)+ (_, Just _) -> (True, True)+ if hasContent+ then if chunked+ then return $ RequestContentChunked False 0+ else case maybeLength of+ Nothing -> return $ RequestContentNone+ Just length -> return $ RequestContentIdentity length+ else return RequestContentNone+ensureRequestContentParametersInitialized parameters = return parameters+++extendRequestContentBuffer+ :: (MonadHTTP m)+ => BS.ByteString+ -> RequestContentParameters+ -> (Maybe Int)+ -> Bool+ -> m (BS.ByteString, RequestContentParameters)+extendRequestContentBuffer highLevelBuffer+ parameters+ maybeTargetLength+ blocking = do+ let isAtLeastTargetLength buffer =+ case maybeTargetLength of+ Nothing -> False+ Just targetLength -> BS.length buffer >= targetLength+ loop highLevelBuffer lowLevelBuffer parameters = do+ if isAtLeastTargetLength highLevelBuffer+ then return (highLevelBuffer, lowLevelBuffer, parameters)+ else do+ case parameters of+ RequestContentNone+ -> return (highLevelBuffer, lowLevelBuffer, parameters)+ RequestContentClosed+ -> return (highLevelBuffer, lowLevelBuffer, parameters)+ RequestContentIdentity lengthRemaining -> do+ (lowLevelBuffer, endOfInput)+ <- extendInputBuffer lowLevelBuffer lengthRemaining blocking+ if endOfInput+ then throwIO UnexpectedEndOfInput+ else return ()+ let (toHighLevelBuffer, lowLevelBuffer')+ = BS.splitAt lengthRemaining lowLevelBuffer+ lengthRead = BS.length toHighLevelBuffer+ highLevelBuffer'+ = BS.append highLevelBuffer toHighLevelBuffer+ lengthRemaining' = if lengthRemaining > lengthRead+ then lengthRemaining - lengthRead+ else 0+ parameters' = if lengthRemaining' > 0+ then RequestContentIdentity lengthRemaining'+ else RequestContentClosed+ if not blocking || isAtLeastTargetLength highLevelBuffer+ then return (highLevelBuffer', lowLevelBuffer', parameters')+ else loop highLevelBuffer' lowLevelBuffer' parameters'+ RequestContentChunked _ _ -> do+ httpLog $ "Don't understand chunked."+ throwIO UnexpectedEndOfInput+ -- TODO+ HTTPConnection { httpConnectionInputBufferMVar = lowLevelBufferMVar }+ <- getHTTPConnection+ lowLevelBuffer <- takeMVar lowLevelBufferMVar+ (highLevelBuffer, lowLevelBuffer, parameters)+ <- loop highLevelBuffer lowLevelBuffer parameters+ putMVar lowLevelBufferMVar lowLevelBuffer+ return (highLevelBuffer, parameters)+++-- | Sets the response status which will be sent with the response headers. If+-- the response headers have already been sent, or are no longer modifiable+-- (because of a call to 'httpPut' or similar), causes a+-- 'ResponseHeadersAlreadySent' or 'ResponseHeadersNotModifiable' exception.+setResponseStatus+ :: (MonadHTTP m)+ => Int -- ^ The HTTP/1.1 status code to set.+ -> m ()+setResponseStatus status = do+ requireResponseHeadersNotYetSent+ requireResponseHeadersModifiable+ HTTPConnection { httpConnectionResponseStatus = mvar } <- getHTTPConnection+ swapMVar mvar status+ return ()+ +++-- | Returns the response status which will be or has been sent with the response+-- headers.+getResponseStatus+ :: (MonadHTTP m)+ => m Int -- ^ The HTTP/1.1 status code.+getResponseStatus = do+ HTTPConnection { httpConnectionResponseStatus = mvar } <- getHTTPConnection+ readMVar mvar+++-- | Sets the given response header to the given string value, overriding any+-- value which has previously been set. If the response headers have+-- already been sent, or are no longer modifiable (because of a call to+-- 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or+-- 'ResponseHeadersNotModifiable' exception. If the header is not an+-- HTTP/1.1 or extension response, entity, or general header, ie, is not+-- valid as part of a response, causes a 'NotAResponseHeader' exception.+-- +-- If a value is set for the 'HttpSetCookie' header, this overrides all+-- cookies set for this request with 'setCookie'.+setResponseHeader+ :: (MonadHTTP m)+ => Header -- ^ The header to set. Must be a response header or an entity header.+ -> String -- ^ The value to set.+ -> m ()+setResponseHeader header value = do+ requireResponseHeadersModifiable+ requireResponseHeadersNotYetSent+ setResponseHeader' header value+++setResponseHeader'+ :: (MonadHTTP m)+ => Header+ -> String+ -> m ()+setResponseHeader' header value = do+ if isValidInResponse header+ then do+ connection <- getHTTPConnection+ let mvar = httpConnectionResponseHeaderMap connection+ headerMap <- takeMVar mvar+ let headerMap' = Map.insert header (UTF8.fromString value) headerMap+ putMVar mvar headerMap'+ else throwIO $ NotAResponseHeader header+++-- | Causes the given 'Header' response header not to be sent, overriding+-- any value which has previously been set. If the response headers have+-- already been sent, or are no longer modifiable (because of a call to+-- 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or+-- 'ResponseHeadersNotModifiable' exception. If+-- the header is not an HTTP/1.1 or extension response or entity header, ie,+-- is not valid as part of a response, causes a 'NotAResponseHeader'+-- exception.+-- +-- Does not prevent the 'HttpSetCookie' header from being sent if cookies+-- have been set for this request with 'setCookie'.+unsetResponseHeader+ :: (MonadHTTP m)+ => Header -- ^ The header to unset. Must be a response header or an entity header.+ -> m ()+unsetResponseHeader header = do+ requireResponseHeadersNotYetSent+ requireResponseHeadersModifiable+ if isValidInResponse header+ then do+ HTTPConnection { httpConnectionResponseHeaderMap = mvar } <- getHTTPConnection+ headerMap <- takeMVar mvar+ headerMap <- return $ Map.delete header headerMap+ putMVar mvar headerMap+ else throwIO $ NotAResponseHeader header+++-- | Returns the value of the given header which will be or has been sent with+-- the response headers. If the header is not an HTTP/1.1 or extension+-- response, entity, or general header, ie, is not valid as part of a+-- response, causes a 'NotAResponseHeader' exception.+getResponseHeader+ :: (MonadHTTP m)+ => Header -- ^ The header to query. Must be a response header or an entity+ -- header.+ -> m (Maybe String) -- ^ The value of the queried header.+getResponseHeader header = do+ if isValidInResponse header+ then do+ HTTPConnection { httpConnectionResponseHeaderMap = mvar } <- getHTTPConnection+ headerMap <- readMVar mvar+ return $ fmap UTF8.toString $ Map.lookup header headerMap+ else throwIO $ NotAResponseHeader header+++-- | Causes the user agent to record the given cookie and send it back with+-- future loads of this page. Does not take effect instantly, but rather+-- when headers are sent. Cookies are set in accordance with RFC 2109.+-- If an 'HttpCookie' header is set for this request by a call to+-- 'setResponseHeader', this function has no effect. If the response headers+-- have already been sent, or are no longer modifiable (because of a call to+-- 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or+-- 'ResponseHeadersNotModifiable' exception.+-- If the name is not a possible name for a cookie, causes a 'CookieNameInvalid'+-- exception.+setCookie+ :: (MonadHTTP m)+ => Cookie -- ^ The cookie to set.+ -> m ()+setCookie cookie = do+ requireResponseHeadersNotYetSent+ requireResponseHeadersModifiable+ requireValidCookieName $ cookieName cookie+ connection <- getHTTPConnection+ let mvar = httpConnectionResponseCookieMap connection+ responseCookieMap <- takeMVar mvar+ let responseCookieMap' =+ Map.insert (cookieName cookie) cookie responseCookieMap+ putMVar mvar responseCookieMap'+++-- | Causes the user agent to unset any cookie applicable to this page with the+-- given name. Does not take effect instantly, but rather when headers are+-- sent. If an 'HttpCookie' header is set for this request by a call to+-- 'setResponseHeader', this function has no effect. If the response headers+-- have already been sent, or are no longer modifiable (because of a call to+-- 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or+-- 'ResponseHeadersNotModifiable' exception.+-- If the name is not a possible name for a cookie, causes a+-- 'CookieNameInvalid' exception.+unsetCookie+ :: (MonadHTTP m)+ => String -- ^ The name of the cookie to unset.+ -> m ()+unsetCookie name = do+ requireResponseHeadersNotYetSent+ requireResponseHeadersModifiable+ requireValidCookieName name+ connection <- getHTTPConnection+ let mvar = httpConnectionResponseCookieMap connection+ responseCookieMap <- takeMVar mvar+ let responseCookieMap' =+ Map.insert name (mkUnsetCookie name) responseCookieMap+ putMVar mvar responseCookieMap'+++-- | 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 = Cookie {+ cookieName = name,+ cookieValue = value,+ cookieVersion = 1,+ cookiePath = Nothing,+ cookieDomain = Nothing,+ cookieMaxAge = Nothing,+ cookieSecure = False,+ cookieComment = 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.+ -> (Maybe 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 maybeDomain maybeMaxAge secure+ = Cookie {+ cookieName = name,+ cookieValue = value,+ cookieVersion = 1,+ cookiePath = maybePath,+ cookieDomain = maybeDomain,+ cookieMaxAge = maybeMaxAge,+ cookieSecure = secure,+ cookieComment = Nothing+ }+++mkUnsetCookie :: String -> Cookie+mkUnsetCookie name = Cookie {+ cookieName = name,+ cookieValue = "",+ cookieVersion = 1,+ cookiePath = Nothing,+ cookieDomain = Nothing,+ cookieMaxAge = Just 0,+ cookieSecure = False,+ cookieComment = Nothing+ }+++requireValidCookieName :: (MonadHTTP m) => String -> m ()+requireValidCookieName name = do+ if not $ isValidCookieToken name+ then throwIO $ CookieNameInvalid name+ else return ()+++isValidCookieToken :: String -> Bool+isValidCookieToken token =+ let validCharacter c = (ord c > 0) && (ord c < 128)+ && (not $ elem c "()<>@,;:\\\"/[]?={} \t")+ in (length token > 0) && (all validCharacter token)+++-- | An exception originating within the HTTP infrastructure or the web server.+data HTTPException+ = ResponseHeadersAlreadySent+ -- ^ An exception thrown by operations which require the response headers not+ -- to have been sent yet.+ | ResponseHeadersNotModifiable+ -- ^ An exception thrown by operations which require the response headers+ -- to still be modifiable.+ | OutputAlreadyClosed+ -- ^ An exception thrown by operations which produce output when output has+ -- been closed, as by 'httpCloseOutput'.+ | OutputIncomplete+ -- ^ An exception thrown when output is closed, as by 'httpCloseOutput',+ -- when the response headers imply that there will be a certain amount+ -- of data and there is not.+ | NotAResponseHeader Header+ -- ^ An exception thrown by operations which are given a header that does not+ -- meet their requirement of being valid in a response.+ | CookieNameInvalid String+ -- ^ An exception thrown by operations which are given cookie names that do not+ -- meet the appropriate syntax requirements.+ | NoConnection+ -- ^ An exception thrown by operations which expect a connection to+ -- exist (as it always does within a handler), when none does.+ deriving (Show, Typeable)+++instance Exception HTTPException+++-- | Sets the HTTP/1.1 return status to 301 and sets the 'HttpLocation' header+-- to the provided URL. This has the effect of issuing a permanent redirect+-- to the user agent. Permanent redirects, as opposed to temporary redirects,+-- may cause bookmarks or incoming links to be updated. If the response+-- headers have already been sent, or are no longer modifiable (because of a+-- call to 'httpPut' or similar), causes a 'ResponseHeadersAlreadySent' or+-- 'ResponseHeadersNotModifiable' exception.+permanentRedirect+ :: (MonadHTTP m)+ => String -- ^ The URL to redirect to, as a string.+ -> m ()+permanentRedirect url = do+ setResponseStatus 301+ setResponseHeader HttpLocation url+++-- | Sets the HTTP/1.1 return status to 303 and sets the 'HttpLocation' header+-- to the provided URL. This has the effect of issuing a see-other or+-- "temporary" redirect to the user agent. Temporary redirects, as opposed to+-- permanent redirects, do not cause bookmarks or incoming links to be+-- updated. If the response headers have already been sent, or are no longer+-- modifiable (because of a call to 'httpPut' or similar), causes a+-- 'ResponseHeadersAlreadySent' or 'ResponseHeadersNotModifiable' exception.+seeOtherRedirect+ :: (MonadHTTP m)+ => String -- ^ The URL to redirect to, as a string.+ -> m ()+seeOtherRedirect url = do+ setResponseStatus 303+ setResponseHeader HttpLocation url+++-- | Ensures that the response headers have been sent. If they are already+-- sent, does nothing. If output has already been closed, causes an+-- 'OutputAlreadyClosed' exception. Note that if the buffered identity+-- output mode (the first mode of operation described for 'httpPut') is+-- to be used, this function implies that there is no additional content+-- beyond what has already been sent.+sendResponseHeaders :: (MonadHTTP m) => m ()+sendResponseHeaders = do+ requireOutputNotYetClosed+ connection <- getHTTPConnection+ let socket = httpConnectionSocket connection+ alreadySentMVar = httpConnectionResponseHeadersSent connection+ modifiableMVar = httpConnectionResponseHeadersModifiable connection+ parametersMVar = httpConnectionResponseContentParameters connection+ bufferMVar = httpConnectionResponseContentBuffer connection+ parameters <- takeMVar parametersMVar+ parameters <- ensureResponseContentParametersInitialized parameters+ putMVar parametersMVar parameters+ alreadySent <- takeMVar alreadySentMVar+ if not alreadySent+ then do+ _ <- swapMVar modifiableMVar False+ case parameters of+ ResponseContentBufferedIdentity -> do+ buffer <- readMVar bufferMVar+ setResponseHeader' HttpContentLength (show $ BS.length buffer)+ _ -> do+ headersBuffer <- getHeadersBuffer+ send headersBuffer+ else return ()+ putMVar alreadySentMVar True+++getHeadersBuffer :: (MonadHTTP m) => m ByteString+getHeadersBuffer = do+ connection <- getHTTPConnection+ responseStatus <- readMVar (httpConnectionResponseStatus connection)+ responseHeaderMap <- readMVar (httpConnectionResponseHeaderMap connection)+ responseCookieMap <- readMVar (httpConnectionResponseCookieMap connection)+ let statusLine = BS.concat [UTF8.fromString "HTTP/1.1 ",+ UTF8.fromString $ show responseStatus,+ UTF8.fromString " ",+ reasonPhrase responseStatus,+ UTF8.fromString "\r\n"]+ nameValuePairs+ = concat [map (\(header, value) -> (fromHeader header, value))+ $ Map.toList responseHeaderMap,+ if (isNothing $ Map.lookup HttpSetCookie responseHeaderMap)+ && (not $ Map.null responseCookieMap)+ then [(UTF8.fromString "Set-Cookie", setCookieValue)]+ else []]+ setCookieValue = printCookies $ Map.elems responseCookieMap+ delimiterLine = UTF8.fromString "\r\n"+ buffer = BS.concat $ [statusLine]+ ++ (concat+ $ map (\(name, value)+ -> [name, UTF8.fromString ": ",+ value, UTF8.fromString "\r\n"])+ nameValuePairs)+ ++ [delimiterLine]+ return buffer+++markResponseHeadersUnmodifiable :: (MonadHTTP m) => m ()+markResponseHeadersUnmodifiable = do+ HTTPConnection { httpConnectionResponseHeadersModifiable = modifiableMVar }+ <- getHTTPConnection+ swapMVar modifiableMVar False+ return ()+++reasonPhrase :: Int -> ByteString+reasonPhrase status =+ UTF8.fromString $ case status of+ 100 -> "Continue"+ 101 -> "Switching Protocols"+ 200 -> "OK"+ 201 -> "Created"+ 202 -> "Accepted"+ 203 -> "Non-Authoritative Information"+ 204 -> "No Content"+ 205 -> "Reset Content"+ 206 -> "Partial Content"+ 300 -> "Multiple Choices"+ 301 -> "Moved Permanently"+ 302 -> "Found"+ 303 -> "See Other"+ 304 -> "Not Modified"+ 305 -> "Use Proxy"+ 307 -> "Temporary Redirect"+ 400 -> "Bad Request"+ 401 -> "Unauthorized"+ 402 -> "Payment Required"+ 403 -> "Forbidden"+ 404 -> "Not Found"+ 405 -> "Method Not Allowed"+ 406 -> "Not Acceptable"+ 407 -> "Proxy Authentication Required"+ 408 -> "Request Time-out"+ 409 -> "Conflict"+ 410 -> "Gone"+ 411 -> "Length Required"+ 412 -> "Precondition Failed"+ 413 -> "Request Entity Too Large"+ 414 -> "Request-URI Too Large"+ 415 -> "Unsupported Media Type"+ 416 -> "Requested range not satisfiable"+ 417 -> "Expectation Failed"+ 500 -> "Internal Server Error"+ 501 -> "Not Implemented"+ 502 -> "Bad Gateway"+ 503 -> "Service Unavailable"+ 504 -> "Gateway Time-out"+ 505 -> "HTTP Version not supported"+ _ -> "Extension"+++-- | Returns whether the response headers have been sent, regardless of whether+-- they are modifiable (they might not be because of a call to 'httpPut' or+-- similar).+responseHeadersSent :: (MonadHTTP m) => m Bool+responseHeadersSent = do+ connection <- getHTTPConnection+ readMVar (httpConnectionResponseHeadersSent connection)+++-- | Returns whether the response headers are modifiable, a prerequisite of+-- which is that they have not already been sent. (They might not be+-- modifiable because of a call to 'httpPut' or similar.)+responseHeadersModifiable :: (MonadHTTP m) => m Bool+responseHeadersModifiable = do+ connection <- getHTTPConnection+ readMVar (httpConnectionResponseHeadersModifiable connection)+++-- | Appends data, interpreted as binary, to the content of the HTTP response.+-- Makes the response headers no longer modifiable, effective immediately.+-- If output has already been closed, causes an 'OutputAlreadyClosed'+-- exception. If the response Transfer-Encoding as set in the response+-- headers is "identity" or omitted, and the response Content-Length is+-- omitted, data is buffered until output is closed, then sent all at once+-- with an appropriate Content-Length header. Otherwise - that is, if there+-- is a Transfer-Encoding other than "identity" set, or if Content-Length is+-- set - data is sent immediately. If Content-Length is set, and the+-- provided data would cause the cumulative data sent to exceed that length,+-- causes an 'OutputAlreadyClosed' exception. At the time that data is+-- actually sent, if the response headers have not been sent, first sends+-- them.+-- +-- In other words, there are effectively three modes of operation for output.+-- The first, simplest mode is used if the handler does nothing special. In+-- this mode output is buffered and sent all at once; headers are not sent+-- until this time. In this mode 'httpCloseOutput' may be useful to force+-- output to be sent before the handler returns, perhaps so that additional+-- time-consuming processing can be done. This mode is easiest to use, in the+-- sense that it requires no support on the handler's part, but probably the+-- second mode should always be used instead.+-- +-- The second mode is used if the handler sets a Transfer-Encoding, for+-- example "chunked", and no Content-Length. In this case headers are sent+-- immediately upon the first 'httpPut' or 'httpPutStr', and output is sent+-- as it is provided. Output in this mode is transformed by 'httpPut' into+-- the appropriate transfer encoding. Thus handler code need only specify a+-- transfer encoding, not actually implement that encoding itself. This mode+-- is advantageous to allow user agents to begin displaying partial content as+-- it is received, and particularly useful when the content is quite large+-- or takes significant time to generate. If you are unsure which mode to+-- use, it should probably be this one.+-- +-- The third mode is used if the handler sets a Content-Length and no+-- Transfer-Encoding. In this case headers are again sent immediately upon+-- the first 'httpPut' or 'httpPutStr', and output is again sent as it is+-- provided. Output in this mode is not transformed. This may be more+-- efficient than the second mode if output is generated in many small pieces,+-- as it avoids computing and sending the length tags of the "chunked"+-- encoding. However, it requires the content length to be known in advance+-- of actually sending any content. It may be useful if you wish to have+-- direct-http validate that the handler is well-behaved in sending a binary+-- object of known size with no "garbage" inserted by spurious additional+-- puts.+httpPut :: (MonadHTTP m) => BS.ByteString -> m ()+httpPut bytestring = do+ requireOutputNotYetClosed+ markResponseHeadersUnmodifiable+ connection <- getHTTPConnection+ let bufferMVar = httpConnectionResponseContentBuffer connection+ parametersMVar = httpConnectionResponseContentParameters connection+ alreadySentMVar = httpConnectionResponseHeadersSent connection+ buffer <- takeMVar bufferMVar+ parameters <- takeMVar parametersMVar+ parameters <- ensureResponseContentParametersInitialized parameters+ (buffer, parameters) <- case parameters of+ ResponseContentClosed -> throwIO OutputAlreadyClosed+ ResponseContentBufferedIdentity -> do+ return (BS.append buffer bytestring, ResponseContentBufferedIdentity)+ ResponseContentUnbufferedIdentity lengthRemaining -> do+ alreadySent <- takeMVar alreadySentMVar+ if alreadySent+ then return ()+ else do+ headersBuffer <- getHeadersBuffer+ send headersBuffer+ putMVar alreadySentMVar True+ let lengthThisPut = BS.length bytestring+ if lengthThisPut > lengthRemaining+ then do+ putMVar parametersMVar ResponseContentClosed+ putMVar bufferMVar BS.empty+ throwIO OutputAlreadyClosed+ else do+ let parameters' = ResponseContentUnbufferedIdentity+ $ lengthRemaining - lengthThisPut+ send bytestring+ return (buffer, parameters')+ ResponseContentChunked -> do+ httpLog $ "Chunked not implemented."+ putMVar parametersMVar parameters+ putMVar bufferMVar buffer+ throwIO UnexpectedEndOfInput+ -- TODO+ putMVar parametersMVar parameters+ putMVar bufferMVar buffer+++ensureResponseContentParametersInitialized+ :: (MonadHTTP m)+ => ResponseContentParameters+ -> m ResponseContentParameters+ensureResponseContentParametersInitialized ResponseContentUninitialized = do+ maybeLengthString <- getResponseHeader HttpContentLength+ let maybeLength = case maybeLengthString of+ Nothing -> Nothing+ Just lengthString -> parseInt lengthString+ maybeTransferEncodingString <- getResponseHeader HttpTransferEncoding+ let (hasContent, chunked)+ = case (maybeLengthString, maybeTransferEncodingString) of+ (Nothing, Nothing) -> (False, False)+ (Just length, Nothing) -> (True, False)+ (Just length, Just encoding)+ | map toLower encoding == "identity" -> (True, False)+ | otherwise -> (True, True)+ (_, Just _) -> (True, True)+ if hasContent+ then if chunked+ then return $ ResponseContentChunked+ else case maybeLength of+ Nothing -> return ResponseContentBufferedIdentity+ Just length ->+ return $ ResponseContentUnbufferedIdentity length+ else return ResponseContentBufferedIdentity+ensureResponseContentParametersInitialized parameters = return parameters+++flushResponseContent :: (MonadHTTP m) => m ()+flushResponseContent = do+ connection <- getHTTPConnection+ let bufferMVar = httpConnectionResponseContentBuffer connection+ parametersMVar = httpConnectionResponseContentParameters connection+ buffer <- takeMVar bufferMVar+ parameters <- takeMVar parametersMVar+ parameters <- ensureResponseContentParametersInitialized parameters+ case parameters of+ ResponseContentClosed -> throwIO OutputAlreadyClosed+ ResponseContentBufferedIdentity -> do+ headersBuffer <- getHeadersBuffer+ send $ BS.concat [headersBuffer, buffer]+ return ()+ ResponseContentUnbufferedIdentity lengthRemaining -> do+ if lengthRemaining > 0+ then do+ putMVar parametersMVar ResponseContentClosed+ putMVar bufferMVar BS.empty+ throwIO OutputIncomplete+ else return ()+ ResponseContentChunked -> do+ httpLog $ "Chunked not implemented."+ putMVar parametersMVar parameters+ putMVar bufferMVar buffer+ throwIO UnexpectedEndOfInput+ -- TODO+ putMVar parametersMVar ResponseContentClosed+ putMVar bufferMVar BS.empty+++send :: (MonadHTTP m) => ByteString -> m ()+send bytestring = do+ HTTPConnection { httpConnectionSocket = socket } <- getHTTPConnection+ liftBase $ Network.sendAll socket bytestring+++-- | Appends text, encoded as UTF8, to the content of the HTTP response. In+-- all respects this behaves as 'httpPut', but for the fact that it takes+-- text rather than binary data.+httpPutStr :: (MonadHTTP m) => String -> m ()+httpPutStr string = httpPut $ UTF8.fromString string+++-- | Informs the web server and the user agent that the request has completed.+-- As side-effects, the response headers are sent if they have not yet been,+-- any unread input is discarded and no more can be read, and any unsent+-- output is sent. This is implicitly called, if it has not already been,+-- after the handler returns; it may be useful within a handler if the+-- handler wishes to return results and then perform time-consuming+-- computations before exiting. If output has already been closed, causes an+-- 'OutputAlreadyClosed' exception. If the response headers imply that there+-- will be a certain amount of data and there is not, causes an+-- 'OutputIncomplete' exception.+httpCloseOutput :: (MonadHTTP m) => m ()+httpCloseOutput = do+ requireOutputNotYetClosed+ sendResponseHeaders+ flushResponseContent+ httpGet' Nothing True True+ return ()+++-- | Returns whether it is possible to write more data; ie, whether output has+-- not yet been closed as by 'httpCloseOutput'.+httpIsWritable :: (MonadHTTP m) => m Bool+httpIsWritable = do+ connection <- getHTTPConnection+ let parametersMVar = httpConnectionResponseContentParameters connection+ parameters <- takeMVar parametersMVar+ parameters <- ensureResponseContentParametersInitialized parameters+ putMVar parametersMVar parameters+ return $ case parameters of+ ResponseContentClosed -> False+ _ -> True+++requireResponseHeadersNotYetSent :: (MonadHTTP m) => m ()+requireResponseHeadersNotYetSent = do+ alreadySent <- responseHeadersSent+ if alreadySent+ then throwIO ResponseHeadersAlreadySent+ else return ()+++requireResponseHeadersModifiable :: (MonadHTTP m) => m ()+requireResponseHeadersModifiable = do+ modifiable <- responseHeadersModifiable+ if modifiable+ then return ()+ else throwIO ResponseHeadersNotModifiable+++requireOutputNotYetClosed :: (MonadHTTP m) => m ()+requireOutputNotYetClosed = do+ isWritable <- httpIsWritable+ case isWritable of+ False -> throwIO OutputAlreadyClosed+ True -> return ()+
+ Setup.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain
+ direct-http.cabal view
@@ -0,0 +1,46 @@+name: direct-http+version: 0.5+cabal-version: >= 1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Copyright (c) 2012 Irene Knapp+author: Irene Knapp+maintainer: "Irene Knapp" <ireney.knapp@gmail.com>+homepage: http://ireneknapp.com/software/+bug-reports: http://ireneknapp.com/issues/create/+category: Network+synopsis: Native webserver that acts as a library.+description:+ This package is a native implementation of the HTTP and HTTPS protocols.+ It lives as a library, exporting an interface reminiscent of CGI or FastCGI.+ Thus policy on how namespace is mapped to files and/or scripts is entirely up+ to the client application.+ .+ This package is partially compatible with direct-fastcgi by the same+ author, but is intended more by way of a replacement for it than a companion+ to it, and makes several design decisions differently. The biggest is the+ use of MonadControlBase for exceptions.+ .+ Version 0.5: This preliminary release is a preview to gauge community+ interest. Not even all major features are implemented; things that exist+ only as stubs include encryption, compression, chunking, and reading back+ cookies. Nonetheless it may be useful if run behind a reverse proxy that+ provides the missing features transparently, such as Apache.++Library+ exposed-modules: Network.HTTP+ build-depends: base >= 4.5 && < 5,+ bytestring >= 0.9.2.1 && < 1,+ containers >= 0.4.2.1 && < 1,+ mtl >= 2.0.1.0 && < 3,+ network >= 2.3.0.11 && < 3,+ utf8-string >= 0.3.7 && < 1,+ time >= 1.4 && < 2,+ old-locale >= 1.0.0.4 && < 2,+ unix >= 2.5.1.0 && < 3,+ direct-daemonize >= 3.0 && < 4,+ transformers-base >= 0.4.1 && < 1,+ lifted-base >= 0.1.1 && < 2,+ monad-control >= 0.3.1.3 && < 1+ default-language: Haskell2010