]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/DefaultPage.hs
DefaultExtensionMap is now generated with TH.
[Lucu.git] / Network / HTTP / Lucu / DefaultPage.hs
1 {-# LANGUAGE
2     OverloadedStrings
3   , UnicodeSyntax
4   #-}
5 module Network.HTTP.Lucu.DefaultPage
6     ( getDefaultPage
7     , defaultPageContentType
8     , mkDefaultPage
9     )
10     where
11 import Blaze.ByteString.Builder (Builder)
12 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
13 import Control.Arrow
14 import Control.Arrow.ArrowList
15 import Control.Arrow.ListArrow
16 import Control.Arrow.Unicode
17 import Data.Ascii (Ascii)
18 import qualified Data.Ascii as A
19 import Data.Maybe
20 import qualified Data.Text as T
21 import Network.HTTP.Lucu.Config
22 import Network.HTTP.Lucu.Headers
23 import Network.HTTP.Lucu.Request
24 import Network.HTTP.Lucu.Response
25 import Network.URI hiding (path)
26 import Prelude.Unicode
27 import Text.XML.HXT.Arrow.WriteDocument
28 import Text.XML.HXT.Arrow.XmlArrow
29 import Text.XML.HXT.Arrow.XmlState
30 import Text.XML.HXT.DOM.TypeDefs
31
32 getDefaultPage ∷ Config → Maybe Request → Response → Builder
33 {-# INLINEABLE getDefaultPage #-}
34 getDefaultPage conf req res
35     = let msgA     = getMsg req res
36           [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
37                              ⋙ 
38                              writeDocumentToString [ withIndent True ]
39                            ) ()
40       in
41         BB.fromString xmlStr
42
43 defaultPageContentType ∷ Ascii
44 {-# INLINE defaultPageContentType #-}
45 defaultPageContentType = "application/xhtml+xml"
46
47 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
48 {-# INLINEABLE mkDefaultPage #-}
49 mkDefaultPage conf status msgA
50     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
51           sig  = concat [ A.toString (cnfServerSoftware conf)
52                         , " at "
53                         , T.unpack (cnfServerHost conf)
54                         ]
55       in ( eelem "/"
56            += ( eelem "html"
57                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
58                 += ( eelem "head"
59                      += ( eelem "title"
60                           += txt sStr
61                         ))
62                 += ( eelem "body"
63                      += ( eelem "h1"
64                           += txt sStr
65                         )
66                      += ( eelem "p" += msgA )
67                      += eelem "hr"
68                      += ( eelem "address" += txt sig ))))
69
70 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
71 {-# INLINEABLE getMsg #-}
72 getMsg req res
73     = case resStatus res of
74         -- 1xx は body を持たない
75         -- 2xx の body は補完しない
76
77         -- 3xx
78         MovedPermanently
79             → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
80                <+>
81                eelem "a" += sattr "href" loc
82                          += txt loc
83                <+>
84                txt " permanently."
85
86         Found
87             → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
88                <+>
89                eelem "a" += sattr "href" loc
90                          += txt loc
91                <+>
92                txt ". This is not a permanent relocation."
93
94         SeeOther
95             → txt ("The resource at " ⧺ path ⧺ " can be found at ")
96                <+>
97                eelem "a" += sattr "href" loc
98                          += txt loc
99                <+>
100                txt "."
101
102         TemporaryRedirect
103             → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
104                <+>
105                eelem "a" += sattr "href" loc
106                          += txt loc
107                <+>
108                txt "."
109
110         -- 4xx
111         BadRequest
112             → txt "The server could not understand the request you sent."
113
114         Unauthorized
115             → txt ("You need a valid authentication to access " ⧺ path)
116
117         Forbidden
118             → txt ("You don't have permission to access " ⧺ path)
119
120         NotFound
121             → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
122
123         Gone
124             → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
125
126         RequestEntityTooLarge
127             → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
128
129         RequestURITooLarge
130             → txt "The request URI you sent was too large to accept."
131
132         -- 5xx
133         InternalServerError
134             → txt ("An internal server error has occured during the process of your request to " ⧺ path)
135
136         ServiceUnavailable
137             → txt "The service is temporarily unavailable. Try later."
138
139         _  → none
140
141     where
142       path ∷ String
143       path = let uri = reqURI $ fromJust req
144              in
145                uriPath uri
146
147       loc ∷ String
148       loc = A.toString $ fromJust $ getHeader "Location" res