module Network.HTTP (
HTTP,
HTTPState,
MonadHTTP(..),
HTTPServerParameters(..),
HTTPListenSocketParameters(..),
acceptLoop,
httpLog,
httpFork,
HTTPException(..),
Header(..),
getRequestHeader,
getAllRequestHeaders,
Cookie(..),
getCookie,
getAllCookies,
getCookieValue,
getRemoteAddress,
getRequestMethod,
getRequestURI,
getServerAddress,
getContentLength,
getContentType,
httpGet,
httpGetNonBlocking,
httpGetContents,
httpIsReadable,
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.Concurrent.MSem (MSem)
import qualified Control.Concurrent.MSem as MSem
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 Numeric
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
data HTTPState = HTTPState {
httpStateAccessLogMaybeHandleMVar :: MVar (Maybe Handle),
httpStateErrorLogMaybeHandleMVar :: MVar (Maybe Handle),
httpStateForkPrimitive :: IO () -> IO ThreadId,
httpStateThreadSetMVar :: MVar (Set ThreadId),
httpStateThreadTerminationMSem :: MSem Word,
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 Int
data ResponseContentParameters
= ResponseContentUninitialized
| ResponseContentClosed
| ResponseContentBufferedIdentity
| ResponseContentUnbufferedIdentity Int
| ResponseContentChunked
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."
type HTTP = ReaderT HTTPState IO
class (MonadBaseControl IO m) => MonadHTTP m where
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
httpFork :: (MonadHTTP m) => m () -> m ThreadId
httpFork action = do
state <- getHTTPState
let mvar = httpStateThreadSetMVar state
msem = httpStateThreadTerminationMSem 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'
liftBase $ MSem.signal msem)
let threadSet' = Set.insert childThread threadSet
putMVar mvar threadSet'
return childThread
data HTTPServerParameters = HTTPServerParameters {
serverParametersAccessLogPath :: Maybe FilePath,
serverParametersErrorLogPath :: Maybe FilePath,
serverParametersDaemonize :: Bool,
serverParametersUserToChangeTo :: Maybe String,
serverParametersGroupToChangeTo :: Maybe String,
serverParametersForkPrimitive :: IO () -> IO ThreadId,
serverParametersListenSockets :: [HTTPListenSocketParameters]
}
data HTTPListenSocketParameters = HTTPListenSocketParameters {
listenSocketParametersAddress :: Network.SockAddr,
listenSocketParametersSecure :: Bool
}
acceptLoop
:: HTTPServerParameters
-> (HTTP ())
-> IO ()
acceptLoop parameters handler = do
if serverParametersDaemonize parameters
then daemonize (defaultDaemonOptions {
daemonUserToChangeTo =
serverParametersUserToChangeTo parameters,
daemonGroupToChangeTo =
serverParametersGroupToChangeTo parameters
})
(initialize)
(\bootstrap -> acceptLoop' bootstrap)
else do
bootstrap <- initialize
acceptLoop' bootstrap
where initialize = do
accessLogMaybeHandle
<- case serverParametersAccessLogPath parameters of
Nothing -> return Nothing
Just path -> liftBase $ openBinaryFile path AppendMode
>>= return . Just
errorLogMaybeHandle
<- case serverParametersErrorLogPath parameters of
Nothing -> if serverParametersDaemonize parameters
then return Nothing
else return $ Just stdout
Just path -> liftBase $ openBinaryFile path AppendMode
>>= return . Just
listenSockets <-
catch (mapM createListenSocket
(serverParametersListenSockets parameters))
(\e -> do
case errorLogMaybeHandle of
Nothing -> return ()
Just errorLogHandle -> do
hPutStrLn errorLogHandle $
"Failed to start: " ++ (show (e :: SomeException))
liftBase $ exitFailure)
return (listenSockets, accessLogMaybeHandle, errorLogMaybeHandle)
acceptLoop' (listenSockets,
accessLogMaybeHandle,
errorLogMaybeHandle) = do
accessLogMaybeHandleMVar <- newMVar accessLogMaybeHandle
errorLogMaybeHandleMVar <- newMVar errorLogMaybeHandle
let forkPrimitive = serverParametersForkPrimitive parameters
threadSetMVar <- newMVar Set.empty
threadTerminationMSem <- MSem.new 0
let state = HTTPState {
httpStateAccessLogMaybeHandleMVar =
accessLogMaybeHandleMVar,
httpStateErrorLogMaybeHandleMVar =
errorLogMaybeHandleMVar,
httpStateForkPrimitive = forkPrimitive,
httpStateThreadSetMVar = threadSetMVar,
httpStateThreadTerminationMSem = threadTerminationMSem,
httpStateMaybeConnection = Nothing
}
flip runReaderT state $ do
httpLog $ "Server started."
threadIDs <-
mapM (\listenSocket -> httpFork $ acceptLoop'' listenSocket)
listenSockets
threadWaitLoop
acceptLoop'' :: Network.Socket -> HTTP ()
acceptLoop'' listenSocket = do
(socket, peer) <- liftBase $ Network.accept listenSocket
httpFork $ requestLoop socket peer handler
acceptLoop'' listenSocket
threadWaitLoop = do
state <- getHTTPState
let mvar = httpStateThreadSetMVar state
msem = httpStateThreadTerminationMSem state
threadSet <- readMVar mvar
if Set.null threadSet
then liftBase exitSuccess
else do
liftBase $ MSem.wait msem
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 <- liftBase $ Network.socket addressFamily
Network.Stream
Network.defaultProtocol
liftBase $ Network.bind listenSocket address
liftBase $ 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)
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]
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
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)
data Header
= HttpAccept
| HttpAcceptCharset
| HttpAcceptEncoding
| HttpAcceptLanguage
| HttpAuthorization
| HttpExpect
| HttpFrom
| HttpHost
| HttpIfMatch
| HttpIfModifiedSince
| HttpIfNoneMatch
| HttpIfRange
| HttpIfUnmodifiedSince
| HttpMaxForwards
| HttpProxyAuthorization
| HttpRange
| HttpReferrer
| HttpTE
| HttpUserAgent
| HttpAcceptRanges
| HttpAge
| HttpETag
| HttpLocation
| HttpProxyAuthenticate
| HttpRetryAfter
| HttpServer
| HttpVary
| HttpWWWAuthenticate
| HttpAllow
| HttpContentEncoding
| HttpContentLanguage
| HttpContentLength
| HttpContentLocation
| HttpContentMD5
| HttpContentRange
| HttpContentType
| HttpExpires
| HttpLastModified
| HttpExtensionHeader ByteString
| HttpCacheControl
| HttpConnection
| HttpDate
| HttpPragma
| HttpTrailer
| HttpTransferEncoding
| HttpUpgrade
| HttpVia
| HttpWarning
| 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 _) = GeneralHeader
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
getRequestHeader
:: (MonadHTTP m)
=> Header
-> m (Maybe String)
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"
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
getCookie
:: (MonadHTTP m)
=> String
-> m (Maybe Cookie)
getCookie name = do
cookieMap <- getRequestCookieMap
return $ Map.lookup name cookieMap
getAllCookies :: (MonadHTTP m) => m [Cookie]
getAllCookies = do
cookieMap <- getRequestCookieMap
return $ Map.elems cookieMap
getCookieValue
:: (MonadHTTP m)
=> String
-> m (Maybe String)
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
getRemoteAddress :: (MonadHTTP m) => m Network.SockAddr
getRemoteAddress = do
connection <- getHTTPConnection
return $ httpConnectionPeer connection
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
getRequestMethod :: (MonadHTTP m) => m String
getRequestMethod = do
connection <- getHTTPConnection
readMVar (httpConnectionRequestMethod connection)
getRequestURI :: (MonadHTTP m) => m String
getRequestURI = do
connection <- getHTTPConnection
readMVar (httpConnectionRequestURI connection)
getRequestProtocol :: (MonadHTTP m) => m String
getRequestProtocol = do
connection <- getHTTPConnection
readMVar (httpConnectionRequestProtocol connection)
getServerAddress :: (MonadHTTP m) => m Network.SockAddr
getServerAddress = do
connection <- getHTTPConnection
return $ httpConnectionServerAddress connection
getServerSecure :: (MonadHTTP m) => m Bool
getServerSecure = do
return False
getContentLength :: (MonadHTTP m) => m (Maybe Int)
getContentLength = do
maybeString <- getRequestHeader HttpContentLength
case maybeString of
Nothing -> return Nothing
Just string -> return $ parseInt string
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
httpGet :: (MonadHTTP m) => Int -> m BS.ByteString
httpGet size = httpGet' (Just size) True False
httpGetNonBlocking :: (MonadHTTP m) => Int -> m BS.ByteString
httpGetNonBlocking size = httpGet' (Just size) False False
httpGetContents :: (MonadHTTP m) => m BS.ByteString
httpGetContents = httpGet' Nothing True False
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 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
HTTPConnection { httpConnectionInputBufferMVar = lowLevelBufferMVar }
<- getHTTPConnection
lowLevelBuffer <- takeMVar lowLevelBufferMVar
(highLevelBuffer, lowLevelBuffer, parameters)
<- loop highLevelBuffer lowLevelBuffer parameters
putMVar lowLevelBufferMVar lowLevelBuffer
return (highLevelBuffer, parameters)
setResponseStatus
:: (MonadHTTP m)
=> Int
-> m ()
setResponseStatus status = do
requireResponseHeadersNotYetSent
requireResponseHeadersModifiable
HTTPConnection { httpConnectionResponseStatus = mvar } <- getHTTPConnection
swapMVar mvar status
return ()
getResponseStatus
:: (MonadHTTP m)
=> m Int
getResponseStatus = do
HTTPConnection { httpConnectionResponseStatus = mvar } <- getHTTPConnection
readMVar mvar
setResponseHeader
:: (MonadHTTP m)
=> Header
-> String
-> 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
unsetResponseHeader
:: (MonadHTTP m)
=> 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
getResponseHeader
:: (MonadHTTP m)
=> Header
-> m (Maybe String)
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
setCookie
:: (MonadHTTP m)
=> Cookie
-> 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'
unsetCookie
:: (MonadHTTP m)
=> String
-> 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'
mkSimpleCookie
:: String
-> String
-> Cookie
mkSimpleCookie name value = Cookie {
cookieName = name,
cookieValue = value,
cookieVersion = 1,
cookiePath = Nothing,
cookieDomain = Nothing,
cookieMaxAge = Nothing,
cookieSecure = False,
cookieComment = Nothing
}
mkCookie
:: String
-> String
-> (Maybe String)
-> (Maybe String)
-> (Maybe Int)
-> Bool
-> Cookie
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)
data HTTPException
= ResponseHeadersAlreadySent
| ResponseHeadersNotModifiable
| OutputAlreadyClosed
| OutputIncomplete
| NotAResponseHeader Header
| CookieNameInvalid String
| NoConnection
deriving (Show, Typeable)
instance Exception HTTPException
permanentRedirect
:: (MonadHTTP m)
=> String
-> m ()
permanentRedirect url = do
setResponseStatus 301
setResponseHeader HttpLocation url
seeOtherRedirect
:: (MonadHTTP m)
=> String
-> m ()
seeOtherRedirect url = do
setResponseStatus 303
setResponseHeader HttpLocation url
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"
responseHeadersSent :: (MonadHTTP m) => m Bool
responseHeadersSent = do
connection <- getHTTPConnection
readMVar (httpConnectionResponseHeadersSent connection)
responseHeadersModifiable :: (MonadHTTP m) => m Bool
responseHeadersModifiable = do
connection <- getHTTPConnection
readMVar (httpConnectionResponseHeadersModifiable connection)
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
alreadySent <- takeMVar alreadySentMVar
if alreadySent
then return ()
else do
headersBuffer <- getHeadersBuffer
send headersBuffer
putMVar alreadySentMVar True
if BS.length bytestring > 0
then do
let lengthBuffer =
UTF8.fromString $ showHex (BS.length bytestring) "" ++ "\r\n"
crlfBuffer = UTF8.fromString "\r\n"
send $ BS.concat [lengthBuffer, bytestring, crlfBuffer]
else return ()
return (buffer, parameters)
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
let emptyChunkBuffer = UTF8.fromString $ "0\r\n\r\n\r\n"
send emptyChunkBuffer
putMVar parametersMVar parameters
putMVar bufferMVar buffer
putMVar parametersMVar ResponseContentClosed
putMVar bufferMVar BS.empty
send :: (MonadHTTP m) => ByteString -> m ()
send bytestring = do
HTTPConnection { httpConnectionSocket = socket } <- getHTTPConnection
liftBase $ Network.sendAll socket bytestring
httpPutStr :: (MonadHTTP m) => String -> m ()
httpPutStr string = httpPut $ UTF8.fromString string
httpCloseOutput :: (MonadHTTP m) => m ()
httpCloseOutput = do
requireOutputNotYetClosed
sendResponseHeaders
flushResponseContent
httpGet' Nothing True True
return ()
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 ()