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.CaseInsensitive as CI
  17 import Data.Convertible.Base
  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.HTTP.Lucu.Response.StatusCode
  27 import Network.URI hiding (path)
  28 import Prelude hiding (head)
  29 import Prelude.Unicode
  30 import Text.Blaze
  31 import Text.Blaze.Html5 hiding (hr)
  32 import Text.Blaze.Html5.Attributes hiding (title)
  33 import Text.Blaze.Renderer.Utf8
  34
  35 defaultPageContentType ∷ Ascii
  36 {-# INLINE defaultPageContentType #-}
  37 defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""
  38
  39 defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
  40 {-# INLINEABLE defaultPageForResponse #-}
  41 defaultPageForResponse conf req res
  42     = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
  43
  44 defaultPageWithMessage ∷ ∀sc. StatusCode sc ⇒ Config → sc → Html → Builder
  45 {-# INLINEABLE defaultPageWithMessage #-}
  46 defaultPageWithMessage (Config {..}) sc msg
  47     = renderHtmlBuilder $
  48       do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
  49          docType
  50          html ! xmlns "http://www.w3.org/1999/xhtml" $
  51              do let status = toHtml $ scText sc
  52                 head $ title status
  53                 body $ do h1 status
  54                           p msg
  55                           hr
  56                           address $ do toHtml (cs cnfServerSoftware ∷ Text)
  57                                        unsafeByteString " at "
  58                                        toHtml $ CI.original cnfServerHost
  59     where
  60       scText ∷ sc → Text
  61       scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode
  62
  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.
  68     -- 3xx:
  69     | resStatus ≡ cs MovedPermanently
  70         = do unsafeByteString "The resource at "
  71              path
  72              unsafeByteString " has been moved to "
  73              a ! href (toValue loc) $ toHtml loc
  74              unsafeByteString " permanently."
  75
  76     | resStatus ≡ cs Found
  77         = do unsafeByteString "The resource at "
  78              path
  79              unsafeByteString " is currently located at "
  80              a ! href (toValue loc) $ toHtml loc
  81              unsafeByteString ". This is not a permanent relocation."
  82
  83     | resStatus ≡ cs SeeOther
  84         = do unsafeByteString "The resource at "
  85              path
  86              unsafeByteString " can be found at "
  87              a ! href (toValue loc) $ toHtml loc
  88              unsafeByteString "."
  89
  90     | resStatus ≡ cs TemporaryRedirect
  91         = do unsafeByteString "The resource at "
  92              path
  93              unsafeByteString " is temporarily located at "
  94              a ! href (toValue loc) $ toHtml loc
  95              unsafeByteString "."
  96
  97       -- 4xx:
  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 "
 106              path
 107              unsafeByteString " was not found on this server."
 108     | resStatus ≡ cs Gone
 109         = do unsafeByteString "The resource at "
 110              path
 111              unsafeByteString " was here in past times, but has gone permanently."
 112     | resStatus ≡ cs RequestEntityTooLarge
 113         = do unsafeByteString "The request entity you sent for "
 114              path
 115              unsafeByteString " was too large to accept."
 116     | resStatus ≡ cs RequestURITooLarge
 117         = unsafeByteString "The request URI you sent was too large to accept."
 118
 119       -- 5xx:
 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."
 124
 125     | otherwise
 126         = (∅)
 127     where
 128       path ∷ Html
 129       path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
 130
 131       loc ∷ Text
 132       loc = cs ∘ fromJust $ getHeader "Location" res
 133
 134 hr ∷ Html
 135 {-# INLINE hr #-}
 136 hr = unsafeByteString "<hr/>"