Network/HTTP/Lucu/DefaultPage.hs

   1 module Network.HTTP.Lucu.DefaultPage
   2     ( getDefaultPage   -- Maybe Request -> Response -> String
   3     , writeDefaultPage -- Interaction -> STM ()
   4     )
   5     where
   6
   7 import           Control.Arrow
   8 import           Control.Arrow.ArrowList
   9 import           Control.Concurrent.STM
  10 import           Control.Monad
  11 import qualified Data.ByteString.Lazy.Char8 as B
  12 import           Data.ByteString.Lazy.Char8 (ByteString)
  13 import           Data.Maybe
  14 import           Network.HTTP.Lucu.Headers
  15 import           Network.HTTP.Lucu.Interaction
  16 import           Network.HTTP.Lucu.Request
  17 import           Network.HTTP.Lucu.Response
  18 import           System.IO.Unsafe
  19 import           Text.Printf
  20 import           Text.XML.HXT.Arrow.WriteDocument
  21 import           Text.XML.HXT.Arrow.XmlArrow
  22 import           Text.XML.HXT.Arrow.XmlIOStateArrow
  23 import           Text.XML.HXT.DOM.TypeDefs
  24 import           Text.XML.HXT.DOM.XmlKeywords
  25
  26
  27 getDefaultPage :: Maybe Request -> Response -> String
  28 getDefaultPage req res
  29     = let msgA = getMsg req res
  30       in
  31         unsafePerformIO $
  32         do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA
  33                               >>>
  34                               writeDocumentToString [ (a_indent, v_1) ]
  35                             )
  36            return xmlStr
  37
  38
  39 writeDefaultPage :: Interaction -> STM ()
  40 writeDefaultPage itr
  41     = do wroteHeader <- readTVar (itrWroteHeader itr)
  42
  43          -- ヘッダが出力濟だったら意味が無い。
  44          when wroteHeader
  45                   $ fail "writeDefaultPage: the header has already been written"
  46
  47          resM <- readTVar (itrResponse itr)
  48
  49          -- Response が不明ならばページ書込も不可
  50          when (resM == Nothing)
  51                   $ fail "writeDefaultPage: response was Nothing"
  52
  53          let reqM = itrRequest itr
  54              res  = fromJust resM
  55              page = B.pack $ getDefaultPage reqM res
  56
  57          writeTVar (itrResponse itr)
  58                        $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
  59
  60          writeTVar (itrBodyToSend itr)
  61                        $ page
  62
  63
  64 mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree
  65 mkDefaultPage status msgA
  66     = let (sCode, sMsg) = statusCode status
  67       in ( eelem "/"
  68            += ( eelem "html"
  69                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
  70                 += ( eelem "head"
  71                      += ( eelem "title"
  72                           += txt (printf "%03d %s" sCode sMsg)
  73                         ))
  74                 += ( eelem "body"
  75                      += ( eelem "h1"
  76                           += txt sMsg
  77                         )
  78                      += ( msgA
  79                           >>>
  80                           eelem "p" += ( this
  81                                          >>>
  82                                          mkText
  83                                        )))))
  84
  85
  86 getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String
  87 getMsg req res
  88     = constA "FIXME: NOT IMPL"