7 module Network.HTTP.Lucu.DefaultPage
14 import Control.Arrow.ArrowList
15 import Control.Arrow.ListArrow
16 import Control.Arrow.Unicode
17 import Control.Concurrent.STM
19 import qualified Data.Ascii as A
20 import qualified Data.ByteString.Char8 as C8
22 import qualified Data.Sequence as S
23 import Data.Text (Text)
24 import qualified Data.Text as T
25 import Data.Text.Encoding
26 import Network.HTTP.Lucu.Config
27 import Network.HTTP.Lucu.Format
28 import Network.HTTP.Lucu.Headers
29 import Network.HTTP.Lucu.Interaction
30 import Network.HTTP.Lucu.Request
31 import Network.HTTP.Lucu.Response
32 import Network.URI hiding (path)
33 import Prelude.Unicode
34 import Text.XML.HXT.Arrow.WriteDocument
35 import Text.XML.HXT.Arrow.XmlArrow
36 import Text.XML.HXT.Arrow.XmlState
37 import Text.XML.HXT.DOM.TypeDefs
39 getDefaultPage ∷ Config → Maybe Request → Response → Text
40 {-# INLINEABLE getDefaultPage #-}
41 getDefaultPage !conf !req !res
42 = let msgA = getMsg req res
43 [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
45 writeDocumentToString [ withIndent True ]
50 writeDefaultPage ∷ Interaction → STM ()
52 -- Content-Type が正しくなければ補完できない。
53 = do res ← readItr itr itrResponse id
54 when (getHeader "Content-Type" res == Just defaultPageContentType)
55 $ do reqM ← readItr itr itrRequest id
57 let conf = itrConfig itr
58 page = getDefaultPage conf reqM res
60 writeTVar (itrBodyToSend itr)
61 (S.singleton (encodeUtf8 page))
63 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
64 {-# INLINEABLE mkDefaultPage #-}
65 mkDefaultPage !conf !status !msgA
66 = let (# sCode, sMsg #) = statusCode status
67 sig = concat [ C8.unpack (cnfServerSoftware conf)
69 , C8.unpack (cnfServerHost conf)
73 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
76 += txt (fmtDec 3 sCode ⧺ " " ⧺ C8.unpack sMsg)
80 += txt (C8.unpack sMsg)
82 += ( eelem "p" += msgA )
84 += ( eelem "address" += txt sig ))))
86 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
87 {-# INLINEABLE getMsg #-}
89 = case resStatus res of
95 → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
97 eelem "a" += sattr "href" loc
103 → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
105 eelem "a" += sattr "href" loc
108 txt ". This is not a permanent relocation."
111 → txt ("The resource at " ⧺ path ⧺ " can be found at ")
113 eelem "a" += sattr "href" loc
119 → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
121 eelem "a" += sattr "href" loc
128 → txt "The server could not understand the request you sent."
131 → txt ("You need a valid authentication to access " ⧺ path)
134 → txt ("You don't have permission to access " ⧺ path)
137 → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
140 → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
142 RequestEntityTooLarge
143 → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
146 → txt "The request URI you sent was too large to accept."
150 → txt ("An internal server error has occured during the process of your request to " ⧺ path)
153 → txt "The service is temporarily unavailable. Try later."
159 path = let uri = reqURI $ fromJust req
164 loc = A.toString $ fromJust $ getHeader "Location" res