Network/HTTP/Lucu/DefaultPage.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , RecordWildCards
   4   , TypeOperators
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.DefaultPage
   8     ( getDefaultPage
   9     , defaultPageContentType
  10     , mkDefaultPage
  11     )
  12     where
  13 import Blaze.ByteString.Builder (Builder)
  14 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
  15 import Control.Arrow
  16 import Control.Arrow.ArrowList
  17 import Control.Arrow.ListArrow
  18 import Control.Arrow.Unicode
  19 import Data.Ascii (Ascii)
  20 import qualified Data.Ascii as A
  21 import Data.Maybe
  22 import qualified Data.Text as T
  23 import Network.HTTP.Lucu.Config
  24 import Network.HTTP.Lucu.Headers
  25 import Network.HTTP.Lucu.Request
  26 import Network.HTTP.Lucu.Response
  27 import Network.URI hiding (path)
  28 import Prelude.Unicode
  29 import Text.XML.HXT.Arrow.WriteDocument
  30 import Text.XML.HXT.Arrow.XmlArrow
  31 import Text.XML.HXT.Arrow.XmlState
  32 import Text.XML.HXT.DOM.TypeDefs
  33
  34 getDefaultPage ∷ Config → Maybe Request → Response → Builder
  35 {-# INLINEABLE getDefaultPage #-}
  36 getDefaultPage conf req res
  37     = let msgA     = getMsg req res
  38           [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
  39                              ⋙
  40                              writeDocumentToString [ withIndent True ]
  41                            ) ()
  42       in
  43         BB.fromString xmlStr
  44
  45 defaultPageContentType ∷ Ascii
  46 {-# INLINE defaultPageContentType #-}
  47 defaultPageContentType = "application/xhtml+xml"
  48
  49 mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc)
  50               ⇒ Config
  51               → sc
  52               → b ⇝ XmlTree
  53               → b ⇝ XmlTree
  54 {-# INLINEABLE mkDefaultPage #-}
  55 mkDefaultPage conf status msgA
  56     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
  57           sig  = concat [ A.toString (cnfServerSoftware conf)
  58                         , " at "
  59                         , T.unpack (cnfServerHost conf)
  60                         ]
  61       in ( eelem "/"
  62            += ( eelem "html"
  63                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
  64                 += ( eelem "head"
  65                      += ( eelem "title"
  66                           += txt sStr
  67                         ))
  68                 += ( eelem "body"
  69                      += ( eelem "h1"
  70                           += txt sStr
  71                         )
  72                      += ( eelem "p" += msgA )
  73                      += eelem "hr"
  74                      += ( eelem "address" += txt sig ))))
  75
  76 getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree
  77 {-# INLINEABLE getMsg #-}
  78 getMsg req res@(Response {..})
  79     -- 1xx responses don't have a body.
  80     -- 2xx responses don't need a body to be completed.
  81     -- 3xx:
  82     | resStatus ≈ MovedPermanently
  83         = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
  84           <+>
  85           eelem "a" += sattr "href" loc
  86                     += txt loc
  87           <+>
  88           txt " permanently."
  89
  90     | resStatus ≈ Found
  91         = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
  92           <+>
  93           eelem "a" += sattr "href" loc
  94                     += txt loc
  95           <+>
  96           txt ". This is not a permanent relocation."
  97
  98     | resStatus ≈ SeeOther
  99         = txt ("The resource at " ⧺ path ⧺ " can be found at ")
 100           <+>
 101           eelem "a" += sattr "href" loc
 102                     += txt loc
 103           <+>
 104           txt "."
 105
 106     | resStatus ≈ TemporaryRedirect
 107         = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
 108           <+>
 109           eelem "a" += sattr "href" loc
 110                     += txt loc
 111           <+>
 112           txt "."
 113
 114       -- 4xx:
 115     | resStatus ≈ BadRequest
 116         = txt "The server could not understand the request you sent."
 117     | resStatus ≈ Unauthorized
 118         = txt ("You need a valid authentication to access " ⧺ path)
 119     | resStatus ≈ Forbidden
 120         = txt ("You don't have permission to access " ⧺ path)
 121     | resStatus ≈ NotFound
 122         = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
 123     | resStatus ≈ Gone
 124         = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
 125     | resStatus ≈ RequestEntityTooLarge
 126         = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
 127     | resStatus ≈ RequestURITooLarge
 128         = txt "The request URI you sent was too large to accept."
 129
 130       -- 5xx:
 131     | resStatus ≈ InternalServerError
 132         = txt ("An internal server error has occured during the process of your request to " ⧺ path)
 133     | resStatus ≈ ServiceUnavailable
 134         = txt "The service is temporarily unavailable. Try later."
 135
 136     | otherwise
 137         = none
 138     where
 139       path ∷ String
 140       path = uriPath $ reqURI $ fromJust req
 141
 142       loc ∷ String
 143       loc = A.toString $ fromJust $ getHeader "Location" res