Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 2a93e469db
Fetching contributors…

Cannot retrieve contributors at this time

executable file 96 lines (82 sloc) 3.896 kb
-----------------------------------------------------------------------------
-- |
-- Module : Turbinado.Server.StandardResponse
-- Copyright : (c) Alson Kemp 2008, Andreas Farre, Niklas Broberg, 2004
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Alson Kemp (Alson@AlsonKemp.com)
-- Stability : experimental
-- Portability : portable
--
-- A set of functions to create standard HTTP responses.
-----------------------------------------------------------------------------
module Turbinado.Server.StandardResponse where
import Data.List
import Data.Maybe
import Network.HTTP (Response(..), rspHeaders)
import Network.HTTP.Stream
import Network.HTTP.Headers
import System.Locale
import System.Time
import Turbinado.Environment.Types
import Turbinado.Environment.Response
import Turbinado.Controller.Monad
import Turbinado.Utility.Data
-- import HSP.Data
instance Eq Header where
(==) (Header hn1 _) (Header hn2 _) = hn1 == hn2
addEmptyResponse :: (HasEnvironment m) => m ()
addEmptyResponse =
do t <- liftIO $ getClockTime
setResponse (Response (0,0,0)
""
(startingHeaders t)
""
)
fileNotFoundResponse :: (HasEnvironment m) => FilePath -> m ()
fileNotFoundResponse fp =
do t <- liftIO $ getClockTime
setResponse (Response (4,0,4)
"File Not Found"
(startingHeaders t ++ [Header HdrContentLength $ show $ length body])
(body))
where body = "<html><body>\n <p><big>404 File Not Found</big></p>\n <p>Requested resource: "++ fp ++ "</p>\n </body></html>"
cachedContentResponse :: (HasEnvironment m) => Int -> String -> String -> m ()
cachedContentResponse age ct body =
do pageResponse [ Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
, Header HdrContentType ct]
body
pageResponse :: (HasEnvironment m) => [Header] -> String -> m ()
pageResponse hds body =
do t <- liftIO $ getClockTime
r <- getEnvironment >>= (return . fromJust' "StandardResponse : pageResponse" . getResponse)
setResponse $ foldl
(\rs (Header hn s) -> replaceHeader hn s rs)
(Response
(2,0,0)
"OK"
(rspHeaders r ++ [Header HdrContentLength $ show $ length body])
body
)
hds
redirectResponse :: (HasEnvironment m) => String -> m ()
redirectResponse l =
do t <- liftIO $ getClockTime
r <- getEnvironment >>= (return . fromJust' "StandardResponse : redirectResponse" . getResponse)
setResponse (Response (3,0,2) "OK" (rspHeaders r ++ [Header HdrLocation l]) "")
errorResponse :: (HasEnvironment m) => String -> m ()
errorResponse err =
do t <- liftIO $ getClockTime
setResponse (Response (5,0,0) "Internal Server Error"
(startingHeaders t ++ [Header HdrContentLength $ show $ length body]) body)
where body = "<html><body>\n <p><big>500 Internal Server Error</big></p>\n <p>Error specification:<br/>\n" ++ err ++ "</p>\n </body></html>"
badReqResponse :: (HasEnvironment m) => m ()
badReqResponse =
do t <- liftIO $ getClockTime
setResponse (Response (4,0,0) "Bad Request"
(startingHeaders t ++ [Header HdrContentLength $ show $ length body]) body)
where body = "<html><body>\n <p><big>400 Bad Request</big></p>\n </body></html>"
startingHeaders t = [ Header HdrServer "Turbinado www.turbinado.org"
, Header HdrContentType "text/html; charset=UTF-8"
, Header HdrDate $ formatCalendarTime defaultTimeLocale rfc822DateFormat $ toUTCTime t
]
Jump to Line
Something went wrong with that request. Please try again.