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