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
21 import qualified Data.Sequence as S
22 import Data.Text (Text)
23 import qualified Data.Text as T
24 import Data.Text.Encoding
25 import Network.HTTP.Lucu.Config
26 import Network.HTTP.Lucu.Headers
27 import Network.HTTP.Lucu.Interaction
28 import Network.HTTP.Lucu.Request
29 import Network.HTTP.Lucu.Response
30 import Network.URI hiding (path)
31 import Prelude.Unicode
32 import Text.XML.HXT.Arrow.WriteDocument
33 import Text.XML.HXT.Arrow.XmlArrow
34 import Text.XML.HXT.Arrow.XmlState
35 import Text.XML.HXT.DOM.TypeDefs
37 getDefaultPage ∷ Config → Maybe Request → Response → Text
38 {-# INLINEABLE getDefaultPage #-}
39 getDefaultPage !conf !req !res
40 = let msgA = getMsg req res
41 [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
43 writeDocumentToString [ withIndent True ]
48 writeDefaultPage ∷ Interaction → STM ()
50 -- Content-Type が正しくなければ補完できない。
51 = do res ← readItr itr itrResponse id
52 when (getHeader "Content-Type" res == Just defaultPageContentType)
53 $ do reqM ← readItr itr itrRequest id
55 let conf = itrConfig itr
56 page = getDefaultPage conf reqM res
58 writeTVar (itrBodyToSend itr)
59 (S.singleton (encodeUtf8 page))
61 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
62 {-# INLINEABLE mkDefaultPage #-}
63 mkDefaultPage !conf !status !msgA
64 = let sStr = A.toString $ printStatusCode status
65 sig = concat [ A.toString (cnfServerSoftware conf)
67 , T.unpack (cnfServerHost conf)
71 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
80 += ( eelem "p" += msgA )
82 += ( eelem "address" += txt sig ))))
84 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
85 {-# INLINEABLE getMsg #-}
87 = case resStatus res of
93 → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
95 eelem "a" += sattr "href" loc
101 → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
103 eelem "a" += sattr "href" loc
106 txt ". This is not a permanent relocation."
109 → txt ("The resource at " ⧺ path ⧺ " can be found at ")
111 eelem "a" += sattr "href" loc
117 → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
119 eelem "a" += sattr "href" loc
126 → txt "The server could not understand the request you sent."
129 → txt ("You need a valid authentication to access " ⧺ path)
132 → txt ("You don't have permission to access " ⧺ path)
135 → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
138 → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
140 RequestEntityTooLarge
141 → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
144 → txt "The request URI you sent was too large to accept."
148 → txt ("An internal server error has occured during the process of your request to " ⧺ path)
151 → txt "The service is temporarily unavailable. Try later."
157 path = let uri = reqURI $ fromJust req
162 loc = A.toString $ fromJust $ getHeader "Location" res