-defaultPageContentType = "application/xhtml+xml"
-
-mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
-{-# INLINEABLE mkDefaultPage #-}
-mkDefaultPage conf status msgA
- = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
- sig = concat [ A.toString (cnfServerSoftware conf)
- , " at "
- , T.unpack (cnfServerHost conf)
- ]
- in ( eelem "/"
- += ( eelem "html"
- += sattr "xmlns" "http://www.w3.org/1999/xhtml"
- += ( eelem "head"
- += ( eelem "title"
- += txt sStr
- ))
- += ( eelem "body"
- += ( eelem "h1"
- += txt sStr
- )
- += ( eelem "p" += msgA )
- += eelem "hr"
- += ( eelem "address" += txt sig ))))
-
-getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
-{-# INLINEABLE getMsg #-}
-getMsg req res
- = case resStatus res of
- -- 1xx は body を持たない
- -- 2xx の body は補完しない
-
- -- 3xx
- MovedPermanently
- → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
- <+>
- eelem "a" += sattr "href" loc
- += txt loc
- <+>
- txt " permanently."
-
- Found
- → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
- <+>
- eelem "a" += sattr "href" loc
- += txt loc
- <+>
- txt ". This is not a permanent relocation."
-
- SeeOther
- → txt ("The resource at " ⧺ path ⧺ " can be found at ")
- <+>
- eelem "a" += sattr "href" loc
- += txt loc
- <+>
- txt "."
-
- TemporaryRedirect
- → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
- <+>
- eelem "a" += sattr "href" loc
- += txt loc
- <+>
- txt "."
-
- -- 4xx
- BadRequest
- → txt "The server could not understand the request you sent."
-
- Unauthorized
- → txt ("You need a valid authentication to access " ⧺ path)
-
- Forbidden
- → txt ("You don't have permission to access " ⧺ path)
-
- NotFound
- → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
-
- Gone
- → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
-
- RequestEntityTooLarge
- → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
-
- RequestURITooLarge
- → txt "The request URI you sent was too large to accept."
-
- -- 5xx
- InternalServerError
- → txt ("An internal server error has occured during the process of your request to " ⧺ path)
-
- ServiceUnavailable
- → txt "The service is temporarily unavailable. Try later."
-
- _ → none
-
+defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""
+
+defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
+{-# INLINEABLE defaultPageForResponse #-}
+defaultPageForResponse conf req res
+ = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
+
+defaultPageWithMessage ∷ StatusCode sc ⇒ Config → sc → Html → Builder
+{-# INLINEABLE defaultPageWithMessage #-}
+defaultPageWithMessage (Config {..}) sc msg
+ = renderHtmlBuilder $
+ do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+ docType
+ html ! xmlns "http://www.w3.org/1999/xhtml" $
+ do let status = toHtml ∘ A.toText ∘ A.fromAsciiBuilder $ printStatusCode sc
+ head $ title status
+ body $ do h1 status
+ p msg
+ hr
+ address $ do toHtml $ A.toText cnfServerSoftware
+ unsafeByteString " at "
+ toHtml $ CI.original cnfServerHost
+
+defaultMessage ∷ Maybe Request → Response → Html
+{-# INLINEABLE defaultMessage #-}
+defaultMessage req res@(Response {..})
+ -- 1xx responses don't have a body.
+ -- 2xx responses don't need a body to be completed.
+ -- 3xx:
+ | resStatus ≈ MovedPermanently
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " has been moved to "
+ a ! href (toValue loc) $ toHtml loc
+ unsafeByteString " permanently."
+
+ | resStatus ≈ Found
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " is currently located at "
+ a ! href (toValue loc) $ toHtml loc
+ unsafeByteString ". This is not a permanent relocation."
+
+ | resStatus ≈ SeeOther
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " can be found at "
+ a ! href (toValue loc) $ toHtml loc
+ unsafeByteString "."
+
+ | resStatus ≈ TemporaryRedirect
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " is temporarily located at "
+ a ! href (toValue loc) $ toHtml loc
+ unsafeByteString "."
+
+ -- 4xx:
+ | resStatus ≈ BadRequest
+ = unsafeByteString "The server could not understand the request you sent."
+ | resStatus ≈ Unauthorized
+ = unsafeByteString "You need a valid authentication to access " ⊕ path
+ | resStatus ≈ Forbidden
+ = unsafeByteString "You don't have permission to access " ⊕ path
+ | resStatus ≈ NotFound
+ = do unsafeByteString "The requested URL "
+ path
+ unsafeByteString " was not found on this server."
+ | resStatus ≈ Gone
+ = do unsafeByteString "The resource at "
+ path
+ unsafeByteString " was here in past times, but has gone permanently."
+ | resStatus ≈ RequestEntityTooLarge
+ = do unsafeByteString "The request entity you sent for "
+ path
+ unsafeByteString " was too large to accept."
+ | resStatus ≈ RequestURITooLarge
+ = unsafeByteString "The request URI you sent was too large to accept."
+
+ -- 5xx:
+ | resStatus ≈ InternalServerError
+ = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
+ | resStatus ≈ ServiceUnavailable
+ = unsafeByteString "The service is temporarily unavailable. Try later."
+
+ | otherwise
+ = (∅)