{-# 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 ()