Network/HTTP/Lucu/DefaultPage.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , RecordWildCards
   4   , TypeOperators
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.DefaultPage
   8     ( defaultPageContentType
   9     , defaultPageForResponse
  10     , defaultPageWithMessage
  11     )
  12     where
  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
  17 import Data.Maybe
  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
  27 import Text.Blaze
  28 import Text.Blaze.Html5 hiding (hr)
  29 import Text.Blaze.Html5.Attributes hiding (title)
  30 import Text.Blaze.Renderer.Utf8
  31
  32 defaultPageContentType ∷ Ascii
  33 {-# INLINE defaultPageContentType #-}
  34 defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""
  35
  36 defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
  37 {-# INLINEABLE defaultPageForResponse #-}
  38 defaultPageForResponse conf req res
  39     = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
  40
  41 defaultPageWithMessage ∷ StatusCode sc ⇒ Config → sc → Html → Builder
  42 {-# INLINEABLE defaultPageWithMessage #-}
  43 defaultPageWithMessage (Config {..}) sc msg
  44     = renderHtmlBuilder $
  45       do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
  46          docType
  47          html ! xmlns "http://www.w3.org/1999/xhtml" $
  48              do let status = toHtml ∘ A.toText ∘ A.fromAsciiBuilder $ printStatusCode sc
  49                 head $ title status
  50                 body $ do h1 status
  51                           p msg
  52                           hr
  53                           address $ do toHtml $ A.toText cnfServerSoftware
  54                                        unsafeByteString " at "
  55                                        toHtml $ CI.original cnfServerHost
  56
  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.
  62     -- 3xx:
  63     | resStatus ≈ MovedPermanently
  64         = do unsafeByteString "The resource at "
  65              path
  66              unsafeByteString " has been moved to "
  67              a ! href (toValue loc) $ toHtml loc
  68              unsafeByteString " permanently."
  69
  70     | resStatus ≈ Found
  71         = do unsafeByteString "The resource at "
  72              path
  73              unsafeByteString " is currently located at "
  74              a ! href (toValue loc) $ toHtml loc
  75              unsafeByteString ". This is not a permanent relocation."
  76
  77     | resStatus ≈ SeeOther
  78         = do unsafeByteString "The resource at "
  79              path
  80              unsafeByteString " can be found at "
  81              a ! href (toValue loc) $ toHtml loc
  82              unsafeByteString "."
  83
  84     | resStatus ≈ TemporaryRedirect
  85         = do unsafeByteString "The resource at "
  86              path
  87              unsafeByteString " is temporarily located at "
  88              a ! href (toValue loc) $ toHtml loc
  89              unsafeByteString "."
  90
  91       -- 4xx:
  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 "
 100              path
 101              unsafeByteString " was not found on this server."
 102     | resStatus ≈ Gone
 103         = do unsafeByteString "The resource at "
 104              path
 105              unsafeByteString " was here in past times, but has gone permanently."
 106     | resStatus ≈ RequestEntityTooLarge
 107         = do unsafeByteString "The request entity you sent for "
 108              path
 109              unsafeByteString " was too large to accept."
 110     | resStatus ≈ RequestURITooLarge
 111         = unsafeByteString "The request URI you sent was too large to accept."
 112
 113       -- 5xx:
 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."
 118
 119     | otherwise
 120         = (∅)
 121     where
 122       path ∷ Html
 123       path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
 124
 125       loc ∷ Text
 126       loc = A.toText ∘ fromJust $ getHeader "Location" res
 127
 128 hr ∷ Html
 129 {-# INLINE hr #-}
 130 hr = unsafeByteString "<hr/>"