7 module Network.HTTP.Lucu.DefaultPage
9 , defaultPageContentType
13 import Blaze.ByteString.Builder (Builder)
14 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
16 import Control.Arrow.ArrowList
17 import Control.Arrow.ListArrow
18 import Control.Arrow.Unicode
19 import Data.Ascii (Ascii)
20 import qualified Data.Ascii as A
22 import qualified Data.Text as T
23 import Network.HTTP.Lucu.Config
24 import Network.HTTP.Lucu.Headers
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
27 import Network.URI hiding (path)
28 import Prelude.Unicode
29 import Text.XML.HXT.Arrow.WriteDocument
30 import Text.XML.HXT.Arrow.XmlArrow
31 import Text.XML.HXT.Arrow.XmlState
32 import Text.XML.HXT.DOM.TypeDefs
34 getDefaultPage ∷ Config → Maybe Request → Response → Builder
35 {-# INLINEABLE getDefaultPage #-}
36 getDefaultPage conf req res
37 = let msgA = getMsg req res
38 [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
40 writeDocumentToString [ withIndent True ]
45 defaultPageContentType ∷ Ascii
46 {-# INLINE defaultPageContentType #-}
47 defaultPageContentType = "application/xhtml+xml"
49 mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc)
54 {-# INLINEABLE mkDefaultPage #-}
55 mkDefaultPage conf status msgA
56 = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
57 sig = concat [ A.toString (cnfServerSoftware conf)
59 , T.unpack (cnfServerHost conf)
63 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
72 += ( eelem "p" += msgA )
74 += ( eelem "address" += txt sig ))))
76 getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree
77 {-# INLINEABLE getMsg #-}
78 getMsg req res@(Response {..})
79 -- 1xx responses don't have a body.
80 -- 2xx responses don't need a body to be completed.
82 | resStatus ≈ MovedPermanently
83 = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
85 eelem "a" += sattr "href" loc
91 = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
93 eelem "a" += sattr "href" loc
96 txt ". This is not a permanent relocation."
98 | resStatus ≈ SeeOther
99 = txt ("The resource at " ⧺ path ⧺ " can be found at ")
101 eelem "a" += sattr "href" loc
106 | resStatus ≈ TemporaryRedirect
107 = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
109 eelem "a" += sattr "href" loc
115 | resStatus ≈ BadRequest
116 = txt "The server could not understand the request you sent."
117 | resStatus ≈ Unauthorized
118 = txt ("You need a valid authentication to access " ⧺ path)
119 | resStatus ≈ Forbidden
120 = txt ("You don't have permission to access " ⧺ path)
121 | resStatus ≈ NotFound
122 = 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.")
125 | resStatus ≈ RequestEntityTooLarge
126 = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
127 | resStatus ≈ RequestURITooLarge
128 = txt "The request URI you sent was too large to accept."
131 | resStatus ≈ InternalServerError
132 = txt ("An internal server error has occured during the process of your request to " ⧺ path)
133 | resStatus ≈ ServiceUnavailable
134 = txt "The service is temporarily unavailable. Try later."
140 path = uriPath $ reqURI $ fromJust req
143 loc = A.toString $ fromJust $ getHeader "Location" res