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