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
21 import qualified Data.CaseInsensitive as CI
23 import qualified Data.Text as T
24 import Network.HTTP.Lucu.Config
25 import Network.HTTP.Lucu.Headers
26 import Network.HTTP.Lucu.Request
27 import Network.HTTP.Lucu.Response
28 import Network.URI hiding (path)
29 import Prelude.Unicode
30 import Text.XML.HXT.Arrow.WriteDocument
31 import Text.XML.HXT.Arrow.XmlArrow
32 import Text.XML.HXT.Arrow.XmlState
33 import Text.XML.HXT.DOM.TypeDefs
35 getDefaultPage ∷ Config → Maybe Request → Response → Builder
36 {-# INLINEABLE getDefaultPage #-}
37 getDefaultPage conf req res
38 = let msgA = getMsg req res
39 [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
41 writeDocumentToString [ withIndent True ]
46 defaultPageContentType ∷ Ascii
47 {-# INLINE defaultPageContentType #-}
48 defaultPageContentType = "application/xhtml+xml"
50 mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc)
55 {-# INLINEABLE mkDefaultPage #-}
56 mkDefaultPage conf status msgA
57 = let sStr = A.toString ∘ A.fromAsciiBuilder $ printStatusCode status
58 sig = concat [ A.toString (cnfServerSoftware conf)
60 , T.unpack ∘ CI.original $ cnfServerHost conf
64 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
73 += ( eelem "p" += msgA )
75 += ( eelem "address" += txt sig ))))
77 getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree
78 {-# INLINEABLE getMsg #-}
79 getMsg req res@(Response {..})
80 -- 1xx responses don't have a body.
81 -- 2xx responses don't need a body to be completed.
83 | resStatus ≈ MovedPermanently
84 = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
86 eelem "a" += sattr "href" loc
92 = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
94 eelem "a" += sattr "href" loc
97 txt ". This is not a permanent relocation."
99 | resStatus ≈ SeeOther
100 = txt ("The resource at " ⧺ path ⧺ " can be found at ")
102 eelem "a" += sattr "href" loc
107 | resStatus ≈ TemporaryRedirect
108 = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
110 eelem "a" += sattr "href" loc
116 | resStatus ≈ BadRequest
117 = txt "The server could not understand the request you sent."
118 | resStatus ≈ Unauthorized
119 = txt ("You need a valid authentication to access " ⧺ path)
120 | resStatus ≈ Forbidden
121 = txt ("You don't have permission to access " ⧺ path)
122 | resStatus ≈ NotFound
123 = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
125 = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
126 | resStatus ≈ RequestEntityTooLarge
127 = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
128 | resStatus ≈ RequestURITooLarge
129 = txt "The request URI you sent was too large to accept."
132 | resStatus ≈ InternalServerError
133 = txt ("An internal server error has occured during the process of your request to " ⧺ path)
134 | resStatus ≈ ServiceUnavailable
135 = txt "The service is temporarily unavailable. Try later."
141 path = uriPath ∘ reqURI $ fromJust req
144 loc = A.toString ∘ fromJust $ getHeader "Location" res