forked from alsonkemp/turbinado
/
StandardResponse.hs
89 lines (74 loc) · 3.29 KB
/
StandardResponse.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
-----------------------------------------------------------------------------
-- |
-- 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 Network.HTTP
import Network.HTTP.Headers
import System.Locale
import System.Time
import Turbinado.Environment.Types
import Turbinado.Environment.Response
import Turbinado.Controller.Monad
-- import HSP.Data
instance Eq Header where
(==) (Header hn1 _) (Header hn2 _) = hn1 == hn2
fileNotFoundResponse :: FilePath -> Controller ()
fileNotFoundResponse fp =
do t <- doIO $ getClockTime
setResponse (Response (4,0,0)
"File Not Found"
(buildHeaders (Just $ length body) t [])
(body))
where body = "<html><body>\n <p><big>404 File Not Found</big></p>\n <p>Requested resource: "++ fp ++ "</p>\n </body></html>"
cachedContentResponse :: Int -> String -> String -> Controller ()
cachedContentResponse age ct body =
do t <- doIO $ getClockTime
pageResponse (buildHeaders
Nothing t
[Header HdrCacheControl $ "max-age=" ++ (show age) ++ ", public"
, Header HdrContentType ct])
body
pageResponse :: [Header] -> String -> Controller ()
pageResponse hds body =
do t <- doIO $ getClockTime
setResponse (Response stSuccess "OK"
(buildHeaders (Just $ length body) t hds) (body))
redirectResponse :: String -> Controller ()
redirectResponse l =
do t <- doIO $ getClockTime
setResponse (Response (3,0,2) "OK" (buildHeaders Nothing t [Header HdrLocation l]) "")
errorResponse :: String -> Controller ()
errorResponse err =
do t <- doIO $ getClockTime
setResponse (Response stError "Internal Server Error"
(buildHeaders (Just $ length body) t []) (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 :: Controller ()
badReqResponse =
do t <- doIO $ getClockTime
setResponse (Response stBadReq "Bad Request"
(buildHeaders (Just $ length body) t []) body)
where body = "<html><body>\n <p><big>400 Bad Request</big></p>\n </body></html>"
buildHeaders :: Maybe Int -> ClockTime -> [Header] -> [Header]
buildHeaders Nothing t hdrs = union hdrs ( startingHeaders t)
buildHeaders (Just l) t hdrs = union hdrs ((startingHeaders t) ++
[Header HdrContentLength $ show l])
startingHeaders t = [ Header HdrServer "Turbinado www.turbinado.org"
, Header HdrContentType "text/html; charset=UTF-8"
, Header HdrDate $ formatCalendarTime defaultTimeLocale rfc822DateFormat $ toUTCTime t
]
stSuccess, stFNF :: ResponseCode
stSuccess = (2,0,0)
stFNF = (4,0,4)
stError = (5,0,0)
stBadReq = (4,0,0)