hws-1.1.0.1: src/Response.hs
-- -----------------------------------------------------------------------------
-- Copyright 2002, Simon Marlow.
-- 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 Util
import IO
import Time
import Control.Monad
import Control.Exception
import Data.Array.MArray
import Data.Array.IO
import Text.Html
import Control.Monad.ST (stToIO)
--import PrelHandle
-----------------------------------------------------------------------------
-- Responses
data ResponseBody
= NoBody
| FileBody Integer{-size-} FilePath
| HereItIs String
data Response
= Response {
respCode :: Int,
respHeaders :: [String],
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 _ (Response s hs _ _ _)
= foldr (\s r -> s . r) id (shows s : (' ':) : showString (responseDescription s) : map (showString . ('\n':)) hs)
. showChar '\n'
response :: Config
-> Handle
-> Response
-> IO ()
response _conf h (Response { respCode = code,
respHeaders = headers,
respCoding = tes,
respBody = body,
respSendBody = send_body }) = do
hPutStrCrLf h (statusLine code)
hPutStrCrLf h serverHeader
-- Date Header: required on all messages
date <- dateHeader
hPutStrCrLf h date
mapM_ (hPutStrCrLf h) headers
-- Output a Content-Length when the message body isn't
-- encoded. If it *is* encoded, then the last transfer
-- coding must be "chunked", according to RFC2616 sec 3.6. This
-- allows the client to determine the message-length.
let content_length = contentLength body
when (content_length /= 0 && null tes)
(hPutStrCrLf h (contentLengthHeader content_length))
mapM_ (hPutStrCrLf h . transferCodingHeader) tes
hPutStr h crlf
-- ToDo: implement transfer codings
if send_body
then sendBody h body
else return ()
contentLength :: ResponseBody -> Integer
contentLength NoBody = 0
contentLength (HereItIs stuff) = toInteger (length stuff)
contentLength (FileBody size _) = size
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) = hPutStr h stuff
sendBody h (FileBody _size filename)
= Control.Exception.bracket
(openFile filename ReadMode)
(\handle -> hClose handle)
(\handle -> squirt handle h >> hFlush h)
bufsize = 4 * 1024 :: Int
-- squirt data from 'rd' into 'wr' as fast as possible. We use a 4k
-- single buffer.
squirt rd wr = do
arr <- newArray_ (0, bufsize-1)
let loop = do r <- hGetArray rd arr bufsize
if (r < bufsize)
then if (r == 0)
then return ()
else hPutArray wr arr r
else hPutArray wr arr bufsize >> loop
loop
statusLine :: Int{-Response-} -> String
statusLine code = httpVersion ++
' ': show code ++
' ': responseDescription code
httpVersion = "HTTP/1.1"
data TransferCoding
= ChunkedTransferCoding
| GzipTransferCoding
| CompressTransferCoding
| DeflateTransferCoding
deriving Eq
transferCodingStr :: TransferCoding -> String
transferCodingStr ChunkedTransferCoding = "chunked"
transferCodingStr GzipTransferCoding = "gzip"
transferCodingStr CompressTransferCoding = "compress"
transferCodingStr DeflateTransferCoding = "deflate"
validTransferCoding :: [TransferCoding] -> Bool
validTransferCoding codings
| null codings
|| last codings == ChunkedTransferCoding
&& ChunkedTransferCoding `notElem` init codings = True
| otherwise = False
-----------------------------------------------------------------------------
-- Response Headers
dateHeader :: IO String
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 ("Date: " ++ time_str)
serverHeader :: String
serverHeader = "Server: " ++ serverSoftware ++ '/':serverVersion
contentLengthHeader :: Integer -> String
contentLengthHeader i = "Content-Length: " ++ show i
contentTypeHeader :: String -> String
contentTypeHeader t = "Content-Type: " ++ t
lastModifiedHeader :: ClockTime -> String
lastModifiedHeader t = "Last-Modified: " ++ formatTimeSensibly (toUTCTime t)
locationHeader :: String -> String
locationHeader l = "Location: " ++ (urlEncode l)
locationBody :: String -> ResponseBody
locationBody l = HereItIs ("<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n<html><head>\n<title>301 Moved Permanently</title>\n</head><body>\n<h1>Moved Permanently</h1>\n<p>The document has moved <a href=\"" ++ (urlEncode l) ++ "\">here</a>.</p>\n</body></html>\n")
transferCodingHeader :: TransferCoding -> String
transferCodingHeader te = "Transfer-Coding: " ++ transferCodingStr te
-----------------------------------------------------------------------------
-- Response codes
contResponse = error_resp 100
switchingProtocolsResponse = error_resp 101
okResponse = body_resp 200
createdResponse = error_resp 201
acceptedResponse = error_resp 202
nonAuthoritiveInformationResponse = error_resp 203
noContentResponse = error_resp 204
resetContentResponse = error_resp 205
partialContentResponse = error_resp 206
multipleChoicesResponse = error_resp 300
movedPermanentlyResponse = redir_resp 301
foundResponse = error_resp 302
seeOtherResponse = error_resp 303
notModifiedResponse = error_resp 304
useProxyResponse = error_resp 305
temporaryRedirectResponse = error_resp 307
badRequestResponse = error_resp 400
unauthorizedResponse = error_resp 401
paymentRequiredResponse = error_resp 402
forbiddenResponse = error_resp 403
notFoundResponse = error_resp 404
methodNotAllowedResponse = error_resp 405
notAcceptableResponse = error_resp 406
proxyAuthenticationRequiredResponse = error_resp 407
requestTimeOutResponse = error_resp 408
conflictResponse = error_resp 409
goneResponse = error_resp 410
lengthRequiredResponse = error_resp 411
preconditionFailedResponse = error_resp 412
requestEntityTooLargeResponse = error_resp 413
requestURITooLargeResponse = error_resp 414
unsupportedMediaTypeResponse = error_resp 415
requestedRangeNotSatisfiableResponse = error_resp 416
expectationFailedResponse = error_resp 417
internalServerErrorResponse = error_resp 500
notImplementedResponse = error_resp 501
badGatewayResponse = error_resp 502
serviceUnavailableResponse = error_resp 503
gatewayTimeOutResponse = error_resp 504
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 code conf
= Response code [contentTypeHeader "text/html"] []
(generateErrorPage code conf) True
body_resp code _conf body headers = Response code headers [] body
redir_resp code conf url = Response code [locationHeader url] [] (locationBody url) True
-----------------------------------------------------------------------------
-- Error pages
-- We generate some html for the client to display on an error.
generateErrorPage :: Int -> Config -> ResponseBody
generateErrorPage code conf
= HereItIs (renderHtml (genErrorHtml code conf))
genErrorHtml :: Int -> Config -> Html
genErrorHtml code 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 code
response = show code +++ ' ' +++ descr