Network/HTTP/Lucu/DefaultPage.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , RecordWildCards
   4   , ScopedTypeVariables
   5   , TypeOperators
   6   , UnicodeSyntax
   7   #-}
   8 module Network.HTTP.Lucu.DefaultPage
   9     ( defaultPageContentType
  10     , defaultPageForResponse
  11     , defaultPageWithMessage
  12     )
  13     where
  14 import Blaze.ByteString.Builder (Builder)
  15 import Data.Ascii (Ascii)
  16 import qualified Data.Ascii as A
  17 import qualified Data.CaseInsensitive as CI
  18 import Data.Convertible.Utils
  19 import Data.Maybe
  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.URI hiding (path)
  27 import Prelude hiding (head)
  28 import Prelude.Unicode
  29 import Text.Blaze
  30 import Text.Blaze.Html5 hiding (hr)
  31 import Text.Blaze.Html5.Attributes hiding (title)
  32 import Text.Blaze.Renderer.Utf8
  33
  34 defaultPageContentType ∷ Ascii
  35 {-# INLINE defaultPageContentType #-}
  36 defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""
  37
  38 defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
  39 {-# INLINEABLE defaultPageForResponse #-}
  40 defaultPageForResponse conf req res
  41     = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
  42
  43 defaultPageWithMessage ∷ ∀sc. StatusCode sc ⇒ Config → sc → Html → Builder
  44 {-# INLINEABLE defaultPageWithMessage #-}
  45 defaultPageWithMessage (Config {..}) sc msg
  46     = renderHtmlBuilder $
  47       do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
  48          docType
  49          html ! xmlns "http://www.w3.org/1999/xhtml" $
  50              do let status = toHtml $ scText sc
  51                 head $ title status
  52                 body $ do h1 status
  53                           p msg
  54                           hr
  55                           address $ do toHtml $ A.toText cnfServerSoftware
  56                                        unsafeByteString " at "
  57                                        toHtml $ CI.original cnfServerHost
  58     where
  59       scText ∷ sc → Text
  60       scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode
  61
  62 defaultMessage ∷ Maybe Request → Response → Html
  63 {-# INLINEABLE defaultMessage #-}
  64 defaultMessage req res@(Response {..})
  65     -- 1xx responses don't have a body.
  66     -- 2xx responses don't need a body to be completed.
  67     -- 3xx:
  68     | resStatus ≈ MovedPermanently
  69         = do unsafeByteString "The resource at "
  70              path
  71              unsafeByteString " has been moved to "
  72              a ! href (toValue loc) $ toHtml loc
  73              unsafeByteString " permanently."
  74
  75     | resStatus ≈ Found
  76         = do unsafeByteString "The resource at "
  77              path
  78              unsafeByteString " is currently located at "
  79              a ! href (toValue loc) $ toHtml loc
  80              unsafeByteString ". This is not a permanent relocation."
  81
  82     | resStatus ≈ SeeOther
  83         = do unsafeByteString "The resource at "
  84              path
  85              unsafeByteString " can be found at "
  86              a ! href (toValue loc) $ toHtml loc
  87              unsafeByteString "."
  88
  89     | resStatus ≈ TemporaryRedirect
  90         = do unsafeByteString "The resource at "
  91              path
  92              unsafeByteString " is temporarily located at "
  93              a ! href (toValue loc) $ toHtml loc
  94              unsafeByteString "."
  95
  96       -- 4xx:
  97     | resStatus ≈ BadRequest
  98         = unsafeByteString "The server could not understand the request you sent."
  99     | resStatus ≈ Unauthorized
 100         = unsafeByteString "You need a valid authentication to access " ⊕ path
 101     | resStatus ≈ Forbidden
 102         = unsafeByteString "You don't have permission to access " ⊕ path
 103     | resStatus ≈ NotFound
 104         = do unsafeByteString "The requested URL "
 105              path
 106              unsafeByteString " was not found on this server."
 107     | resStatus ≈ Gone
 108         = do unsafeByteString "The resource at "
 109              path
 110              unsafeByteString " was here in past times, but has gone permanently."
 111     | resStatus ≈ RequestEntityTooLarge
 112         = do unsafeByteString "The request entity you sent for "
 113              path
 114              unsafeByteString " was too large to accept."
 115     | resStatus ≈ RequestURITooLarge
 116         = unsafeByteString "The request URI you sent was too large to accept."
 117
 118       -- 5xx:
 119     | resStatus ≈ InternalServerError
 120         = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
 121     | resStatus ≈ ServiceUnavailable
 122         = unsafeByteString "The service is temporarily unavailable. Try later."
 123
 124     | otherwise
 125         = (∅)
 126     where
 127       path ∷ Html
 128       path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
 129
 130       loc ∷ Text
 131       loc = A.toText ∘ fromJust $ getHeader "Location" res
 132
 133 hr ∷ Html
 134 {-# INLINE hr #-}
 135 hr = unsafeByteString "<hr/>"