5 module Network.HTTP.Lucu.DefaultPage
7 , defaultPageContentType
11 import Blaze.ByteString.Builder (Builder)
12 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
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
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
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
38 writeDocumentToString [ withIndent True ]
43 defaultPageContentType ∷ Ascii
44 {-# INLINE defaultPageContentType #-}
45 defaultPageContentType = "application/xhtml+xml"
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)
53 , T.unpack (cnfServerHost conf)
57 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
66 += ( eelem "p" += msgA )
68 += ( eelem "address" += txt sig ))))
70 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
71 {-# INLINEABLE getMsg #-}
73 = case resStatus res of
79 → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
81 eelem "a" += sattr "href" loc
87 → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
89 eelem "a" += sattr "href" loc
92 txt ". This is not a permanent relocation."
95 → txt ("The resource at " ⧺ path ⧺ " can be found at ")
97 eelem "a" += sattr "href" loc
103 → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
105 eelem "a" += sattr "href" loc
112 → txt "The server could not understand the request you sent."
115 → txt ("You need a valid authentication to access " ⧺ path)
118 → txt ("You don't have permission to access " ⧺ path)
121 → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
124 → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
126 RequestEntityTooLarge
127 → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
130 → txt "The request URI you sent was too large to accept."
134 → txt ("An internal server error has occured during the process of your request to " ⧺ path)
137 → txt "The service is temporarily unavailable. Try later."
143 path = let uri = reqURI $ fromJust req
148 loc = A.toString $ fromJust $ getHeader "Location" res