Network/HTTP/Lucu/DefaultPage.hs

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