-- ----------------------------------------------------------------------------- -- 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) = "" getFileName (FileBody _size filename) = filename getFileName (HereItIs _) = "" 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