7 module Network.HTTP.Lucu.DefaultPage
13 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
15 import Control.Arrow.ArrowList
16 import Control.Arrow.ListArrow
17 import Control.Arrow.Unicode
18 import Control.Concurrent.STM
20 import qualified Data.Ascii as A
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
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
42 writeDocumentToString [ withIndent True ]
47 writeDefaultPage ∷ Interaction → STM ()
48 writeDefaultPage (Interaction {..})
49 -- Content-Type が正しくなければ補完できない。
50 = do res ← readTVar itrResponse
51 when (getHeader "Content-Type" res ≡ Just defaultPageContentType)
52 $ do let page = getDefaultPage itrConfig itrRequest res
53 putTMVar itrBodyToSend (BB.fromLazyText page)
55 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
56 {-# INLINEABLE mkDefaultPage #-}
57 mkDefaultPage conf status msgA
58 = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
59 sig = concat [ A.toString (cnfServerSoftware conf)
61 , T.unpack (cnfServerHost conf)
65 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
74 += ( eelem "p" += msgA )
76 += ( eelem "address" += txt sig ))))
78 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
79 {-# INLINEABLE getMsg #-}
81 = case resStatus res of
87 → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
89 eelem "a" += sattr "href" loc
95 → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
97 eelem "a" += sattr "href" loc
100 txt ". This is not a permanent relocation."
103 → txt ("The resource at " ⧺ path ⧺ " can be found at ")
105 eelem "a" += sattr "href" loc
111 → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
113 eelem "a" += sattr "href" loc
120 → txt "The server could not understand the request you sent."
123 → txt ("You need a valid authentication to access " ⧺ path)
126 → txt ("You don't have permission to access " ⧺ path)
129 → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
132 → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
134 RequestEntityTooLarge
135 → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
138 → txt "The request URI you sent was too large to accept."
142 → txt ("An internal server error has occured during the process of your request to " ⧺ path)
145 → txt "The service is temporarily unavailable. Try later."
151 path = let uri = reqURI $ fromJust req
156 loc = A.toString $ fromJust $ getHeader "Location" res