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