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