7 module Network.HTTP.Lucu.DefaultPage
8 ( defaultPageContentType
9 , defaultPageForResponse
10 , defaultPageWithMessage
13 import Blaze.ByteString.Builder (Builder)
14 import Data.Ascii (Ascii)
15 import qualified Data.Ascii as A
16 import qualified Data.CaseInsensitive as CI
18 import Data.Monoid.Unicode
19 import Data.Text (Text)
20 import Network.HTTP.Lucu.Config
21 import Network.HTTP.Lucu.Headers
22 import Network.HTTP.Lucu.Request
23 import Network.HTTP.Lucu.Response
24 import Network.URI hiding (path)
25 import Prelude hiding (head)
26 import Prelude.Unicode
28 import Text.Blaze.Html5 hiding (hr)
29 import Text.Blaze.Html5.Attributes hiding (title)
30 import Text.Blaze.Renderer.Utf8
32 defaultPageContentType ∷ Ascii
33 {-# INLINE defaultPageContentType #-}
34 defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""
36 defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
37 {-# INLINEABLE defaultPageForResponse #-}
38 defaultPageForResponse conf req res
39 = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
41 defaultPageWithMessage ∷ StatusCode sc ⇒ Config → sc → Html → Builder
42 {-# INLINEABLE defaultPageWithMessage #-}
43 defaultPageWithMessage (Config {..}) sc msg
45 do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
47 html ! xmlns "http://www.w3.org/1999/xhtml" $
48 do let status = toHtml ∘ A.toText ∘ A.fromAsciiBuilder $ printStatusCode sc
53 address $ do toHtml $ A.toText cnfServerSoftware
54 unsafeByteString " at "
55 toHtml $ CI.original cnfServerHost
57 defaultMessage ∷ Maybe Request → Response → Html
58 {-# INLINEABLE defaultMessage #-}
59 defaultMessage req res@(Response {..})
60 -- 1xx responses don't have a body.
61 -- 2xx responses don't need a body to be completed.
63 | resStatus ≈ MovedPermanently
64 = do unsafeByteString "The resource at "
66 unsafeByteString " has been moved to "
67 a ! href (toValue loc) $ toHtml loc
68 unsafeByteString " permanently."
71 = do unsafeByteString "The resource at "
73 unsafeByteString " is currently located at "
74 a ! href (toValue loc) $ toHtml loc
75 unsafeByteString ". This is not a permanent relocation."
77 | resStatus ≈ SeeOther
78 = do unsafeByteString "The resource at "
80 unsafeByteString " can be found at "
81 a ! href (toValue loc) $ toHtml loc
84 | resStatus ≈ TemporaryRedirect
85 = do unsafeByteString "The resource at "
87 unsafeByteString " is temporarily located at "
88 a ! href (toValue loc) $ toHtml loc
92 | resStatus ≈ BadRequest
93 = unsafeByteString "The server could not understand the request you sent."
94 | resStatus ≈ Unauthorized
95 = unsafeByteString "You need a valid authentication to access " ⊕ path
96 | resStatus ≈ Forbidden
97 = unsafeByteString "You don't have permission to access " ⊕ path
98 | resStatus ≈ NotFound
99 = do unsafeByteString "The requested URL "
101 unsafeByteString " was not found on this server."
103 = do unsafeByteString "The resource at "
105 unsafeByteString " was here in past times, but has gone permanently."
106 | resStatus ≈ RequestEntityTooLarge
107 = do unsafeByteString "The request entity you sent for "
109 unsafeByteString " was too large to accept."
110 | resStatus ≈ RequestURITooLarge
111 = unsafeByteString "The request URI you sent was too large to accept."
114 | resStatus ≈ InternalServerError
115 = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
116 | resStatus ≈ ServiceUnavailable
117 = unsafeByteString "The service is temporarily unavailable. Try later."
123 path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
126 loc = A.toText ∘ fromJust $ getHeader "Location" res
130 hr = unsafeByteString "<hr/>"