diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/HTTP.hs b/Network/HTTP.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP.hs @@ -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 () + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple + +main = defaultMain diff --git a/direct-http.cabal b/direct-http.cabal new file mode 100644 --- /dev/null +++ b/direct-http.cabal @@ -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" +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