Network/HTTP/Lucu/DefaultPage.hs

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