mohws-0.1: src/Response.hs
-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- Copyright 2006, Bjorn Bringert.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- * Redistributions of source code must retain the above copyright notice,
-- this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in the
-- documentation and/or other materials provided with the distribution.
--
-- * Neither the name of the copyright holder(s) nor the names of
-- contributors may be used to endorse or promote products derived from
-- this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- -----------------------------------------------------------------------------
module Response where
import Config
import Headers
import Parse
import Util
import Control.Monad
import Control.Exception as Exception
import Data.List (genericLength)
import System.IO
import System.Time
import Text.Html
-----------------------------------------------------------------------------
-- Responses
data ResponseBody
= NoBody
| FileBody Integer{-size-} FilePath
| HereItIs String
data Response
= Response {
respCode :: Int,
respDesc :: String,
respHeaders :: Headers,
respCoding :: [TransferCoding], -- either empty or terminated with
-- ChunkedTransferEncoding
-- (RFC2616, sec 3.6)
respBody :: ResponseBody, -- filename of body
respSendBody :: Bool -- actually send the body?
-- (False for HEAD requests)
}
instance Show Response where
showsPrec _ r
= showString (showResponseLine r) . showString crLf
. shows (respHeaders r)
instance HasHeaders Response where
getHeaders = respHeaders
setHeaders resp hs = resp { respHeaders = hs}
showResponseLine :: Response -> String
showResponseLine (Response s desc _ _ _ _) = show s ++ " " ++ desc
responseBodyLength :: ResponseBody -> Integer
responseBodyLength bdy =
case bdy of
NoBody -> 0
HereItIs stuff -> genericLength stuff
FileBody sze _ -> sze
hasBody :: ResponseBody -> Bool
hasBody NoBody = False
hasBody _ = True
getFileName :: ResponseBody -> String
getFileName (NoBody) = "<no file>"
getFileName (FileBody _size filename) = filename
getFileName (HereItIs _) = "<generated content>"
sendBody :: Handle -> ResponseBody -> IO ()
sendBody _ NoBody = return ()
sendBody h (HereItIs stuff) = do hPutStr h stuff
hFlush h
sendBody h (FileBody _size filename)
= Exception.bracket
(openFile filename ReadMode)
(\hndle -> hClose hndle)
(\hndle -> squirt hndle h >> hFlush h)
statusLine :: Int -> String -> String
statusLine cde desc = httpVersion ++ ' ': show cde ++ ' ': desc
httpVersion :: String
httpVersion = "HTTP/1.1"
-----------------------------------------------------------------------------
-- Response Headers
dateHeader :: IO Header
dateHeader = do
-- Dates in HTTP/1.1 have to be GMT, which is equivalent to UTC
clock_time <- getClockTime
let utc = toUTCTime clock_time
let time_str = formatTimeSensibly utc
return $ Header HdrDate time_str
serverHeader :: Header
serverHeader = Header HdrServer (serverSoftware ++ '/':serverVersion)
-----------------------------------------------------------------------------
-- Response codes
contResponse :: Config -> Response
contResponse = error_resp 100
switchingProtocolsResponse :: Config -> Response
switchingProtocolsResponse = error_resp 101
okResponse :: t -> ResponseBody -> Headers -> Bool -> Response
okResponse = body_resp 200
createdResponse :: Config -> Response
createdResponse = error_resp 201
acceptedResponse :: Config -> Response
acceptedResponse = error_resp 202
nonAuthoritiveInformationResponse :: Config
-> Response
nonAuthoritiveInformationResponse = error_resp 203
noContentResponse :: Config -> Response
noContentResponse = error_resp 204
resetContentResponse :: Config -> Response
resetContentResponse = error_resp 205
partialContentResponse :: Config -> Response
partialContentResponse = error_resp 206
multipleChoicesResponse :: Config -> Response
multipleChoicesResponse = error_resp 300
movedPermanentlyResponse :: Config -> Response
movedPermanentlyResponse = error_resp 301
foundResponse :: Config -> Response
foundResponse = error_resp 302
seeOtherResponse :: Config -> Response
seeOtherResponse = error_resp 303
notModifiedResponse :: Config -> Response
notModifiedResponse = error_resp 304
useProxyResponse :: Config -> Response
useProxyResponse = error_resp 305
temporaryRedirectResponse :: Config -> Response
temporaryRedirectResponse = error_resp 307
badRequestResponse :: Config -> Response
badRequestResponse = error_resp 400
unauthorizedResponse :: Config -> Response
unauthorizedResponse = error_resp 401
paymentRequiredResponse :: Config -> Response
paymentRequiredResponse = error_resp 402
forbiddenResponse :: Config -> Response
forbiddenResponse = error_resp 403
notFoundResponse :: Config -> Response
notFoundResponse = error_resp 404
methodNotAllowedResponse :: Config -> Response
methodNotAllowedResponse = error_resp 405
notAcceptableResponse :: Config -> Response
notAcceptableResponse = error_resp 406
proxyAuthenticationRequiredResponse :: Config
-> Response
proxyAuthenticationRequiredResponse = error_resp 407
requestTimeOutResponse :: Config -> Response
requestTimeOutResponse = error_resp 408
conflictResponse :: Config -> Response
conflictResponse = error_resp 409
goneResponse :: Config -> Response
goneResponse = error_resp 410
lengthRequiredResponse :: Config -> Response
lengthRequiredResponse = error_resp 411
preconditionFailedResponse :: Config -> Response
preconditionFailedResponse = error_resp 412
requestEntityTooLargeResponse :: Config -> Response
requestEntityTooLargeResponse = error_resp 413
requestURITooLargeResponse :: Config -> Response
requestURITooLargeResponse = error_resp 414
unsupportedMediaTypeResponse :: Config -> Response
unsupportedMediaTypeResponse = error_resp 415
requestedRangeNotSatisfiableResponse :: Config
-> Response
requestedRangeNotSatisfiableResponse = error_resp 416
expectationFailedResponse :: Config -> Response
expectationFailedResponse = error_resp 417
internalServerErrorResponse :: Config -> Response
internalServerErrorResponse = error_resp 500
notImplementedResponse :: Config -> Response
notImplementedResponse = error_resp 501
badGatewayResponse :: Config -> Response
badGatewayResponse = error_resp 502
serviceUnavailableResponse :: Config -> Response
serviceUnavailableResponse = error_resp 503
gatewayTimeOutResponse :: Config -> Response
gatewayTimeOutResponse = error_resp 504
versionNotSupportedResponse :: Config -> Response
versionNotSupportedResponse = error_resp 505
responseDescription :: Int -> String
responseDescription 100 = "Continue"
responseDescription 101 = "Switching Protocols"
responseDescription 200 = "OK"
responseDescription 201 = "Created"
responseDescription 202 = "Accepted"
responseDescription 203 = "Non-Authoritative Information"
responseDescription 204 = "No Content"
responseDescription 205 = "Reset Content"
responseDescription 206 = "Partial Content"
responseDescription 300 = "Multiple Choices"
responseDescription 301 = "Moved Permanently"
responseDescription 302 = "Found"
responseDescription 303 = "See Other"
responseDescription 304 = "Not Modified"
responseDescription 305 = "Use Proxy"
responseDescription 307 = "Temporary Redirect"
responseDescription 400 = "Bad Request"
responseDescription 401 = "Unauthorized"
responseDescription 402 = "Payment Required"
responseDescription 403 = "Forbidden"
responseDescription 404 = "Not Found"
responseDescription 405 = "Method Not Allowed"
responseDescription 406 = "Not Acceptable"
responseDescription 407 = "Proxy Authentication Required"
responseDescription 408 = "Request Time-out"
responseDescription 409 = "Conflict"
responseDescription 410 = "Gone"
responseDescription 411 = "Length Required"
responseDescription 412 = "Precondition Failed"
responseDescription 413 = "Request Entity Too Large"
responseDescription 414 = "Request-URI Too Large"
responseDescription 415 = "Unsupported Media Type"
responseDescription 416 = "Requested range not satisfiable"
responseDescription 417 = "Expectation Failed"
responseDescription 500 = "Internal Server Error"
responseDescription 501 = "Not Implemented"
responseDescription 502 = "Bad Gateway"
responseDescription 503 = "Service Unavailable"
responseDescription 504 = "Gateway Time-out"
responseDescription 505 = "HTTP Version not supported"
responseDescription _ = "Unknown response"
error_resp :: Int -> Config -> Response
error_resp cde conf
= Response cde (responseDescription cde) hs []
(generateErrorPage cde conf) True
where hs = mkHeaders [contentTypeHeader "text/html"]
body_resp :: Int -> t -> ResponseBody -> Headers -> Bool -> Response
body_resp cde _conf bdy headers sendbody =
Response cde (responseDescription cde) headers [] bdy sendbody
-----------------------------------------------------------------------------
-- Error pages
-- We generate some html for the client to display on an error.
generateErrorPage :: Int -> Config -> ResponseBody
generateErrorPage cde conf
= HereItIs (renderHtml (genErrorHtml cde conf))
genErrorHtml :: Int -> Config -> Html
genErrorHtml cde conf
= header << thetitle << response
+++ body <<
(h1 << response
+++ hr
+++ serverSoftware +++ '/' +++ serverVersion
-- ToDo: use real hostname if we don't have a serverName
+++ case serverName conf of
"" -> noHtml
me -> " on " +++ me +++ br
+++ case serverAdmin conf of
"" -> noHtml
her -> "Server Admin: " +++
hotlink ("mailto:"++her) [toHtml her]
)
where
descr = responseDescription cde
response = show cde +++ ' ' +++ descr