8 module Network.HTTP.Lucu.DefaultPage
9 ( defaultPageContentType
10 , defaultPageForResponse
11 , defaultPageWithMessage
14 import Blaze.ByteString.Builder (Builder)
15 import Data.Ascii (Ascii)
16 import qualified Data.CaseInsensitive as CI
17 import Data.Convertible.Base
18 import Data.Convertible.Utils
20 import Data.Monoid.Unicode
21 import Data.Text (Text)
22 import Network.HTTP.Lucu.Config
23 import Network.HTTP.Lucu.Headers
24 import Network.HTTP.Lucu.Request
25 import Network.HTTP.Lucu.Response
26 import Network.HTTP.Lucu.Response.StatusCode
27 import Network.URI hiding (path)
28 import Prelude hiding (head)
29 import Prelude.Unicode
31 import Text.Blaze.Html5 hiding (hr)
32 import Text.Blaze.Html5.Attributes hiding (title)
33 import Text.Blaze.Renderer.Utf8
35 defaultPageContentType ∷ Ascii
36 {-# INLINE defaultPageContentType #-}
37 defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""
39 defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
40 {-# INLINEABLE defaultPageForResponse #-}
41 defaultPageForResponse conf req res
42 = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
44 defaultPageWithMessage ∷ ∀sc. StatusCode sc ⇒ Config → sc → Html → Builder
45 {-# INLINEABLE defaultPageWithMessage #-}
46 defaultPageWithMessage (Config {..}) sc msg
48 do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
50 html ! xmlns "http://www.w3.org/1999/xhtml" $
51 do let status = toHtml $ scText sc
56 address $ do toHtml (cs cnfServerSoftware ∷ Text)
57 unsafeByteString " at "
58 toHtml $ CI.original cnfServerHost
61 scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode
63 defaultMessage ∷ Maybe Request → Response → Html
64 {-# INLINEABLE defaultMessage #-}
65 defaultMessage req res@(Response {..})
66 -- 1xx responses don't have a body.
67 -- 2xx responses don't need a body to be completed.
69 | resStatus ≡ cs MovedPermanently
70 = do unsafeByteString "The resource at "
72 unsafeByteString " has been moved to "
73 a ! href (toValue loc) $ toHtml loc
74 unsafeByteString " permanently."
76 | resStatus ≡ cs Found
77 = do unsafeByteString "The resource at "
79 unsafeByteString " is currently located at "
80 a ! href (toValue loc) $ toHtml loc
81 unsafeByteString ". This is not a permanent relocation."
83 | resStatus ≡ cs SeeOther
84 = do unsafeByteString "The resource at "
86 unsafeByteString " can be found at "
87 a ! href (toValue loc) $ toHtml loc
90 | resStatus ≡ cs TemporaryRedirect
91 = do unsafeByteString "The resource at "
93 unsafeByteString " is temporarily located at "
94 a ! href (toValue loc) $ toHtml loc
98 | resStatus ≡ cs BadRequest
99 = unsafeByteString "The server could not understand the request you sent."
100 | resStatus ≡ cs Unauthorized
101 = unsafeByteString "You need a valid authentication to access " ⊕ path
102 | resStatus ≡ cs Forbidden
103 = unsafeByteString "You don't have permission to access " ⊕ path
104 | resStatus ≡ cs NotFound
105 = do unsafeByteString "The requested URL "
107 unsafeByteString " was not found on this server."
108 | resStatus ≡ cs Gone
109 = do unsafeByteString "The resource at "
111 unsafeByteString " was here in past times, but has gone permanently."
112 | resStatus ≡ cs RequestEntityTooLarge
113 = do unsafeByteString "The request entity you sent for "
115 unsafeByteString " was too large to accept."
116 | resStatus ≡ cs RequestURITooLarge
117 = unsafeByteString "The request URI you sent was too large to accept."
120 | resStatus ≡ cs InternalServerError
121 = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
122 | resStatus ≡ cs ServiceUnavailable
123 = unsafeByteString "The service is temporarily unavailable. Try later."
129 path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
132 loc = cs ∘ fromJust $ getHeader "Location" res
136 hr = unsafeByteString "<hr/>"