Many many changes

[Lucu.git] / Network / HTTP / Lucu / DefaultPage.hs

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 1cc46387f0c112c017df9e54704be70774e8e7b1..19a72936e2718608034e22c15885fb9ea2fbe747 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,82 +1,67 @@
 {-# LANGUAGE
-    BangPatterns
-  , OverloadedStrings
-  , UnboxedTuples
+    OverloadedStrings
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.DefaultPage
     ( getDefaultPage
-    , writeDefaultPage
+    , defaultPageContentType
     , mkDefaultPage
     )
     where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Arrow
 import Control.Arrow.ArrowList
+import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
-import Control.Concurrent.STM
-import Control.Monad
+import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
-import qualified Data.ByteString.Char8 as C8
 import Data.Maybe
-import qualified Data.Sequence as S
 import qualified Data.Text as T
-import Data.Text.Encoding
 import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Format
 import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.URI hiding (path)
-import System.IO.Unsafe
 import Prelude.Unicode
 import Text.XML.HXT.Arrow.WriteDocument
 import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
 import Text.XML.HXT.DOM.TypeDefs
 
-getDefaultPage ∷ Config → Maybe Request → Response → String
-getDefaultPage !conf !req !res
-    = let msgA = getMsg req res
-      in
-        unsafePerformIO $
-        do [xmlStr] ← runX ( mkDefaultPage conf (resStatus res) msgA
+getDefaultPage ∷ Config → Maybe Request → Response → Builder
+{-# INLINEABLE getDefaultPage #-}
+getDefaultPage conf req res
+    = let msgA     = getMsg req res
+          [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
                              ⋙ 
                              writeDocumentToString [ withIndent True ]
-                           )
-           return xmlStr
-
-writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage !itr
-    -- Content-Type が正しくなければ補完できない。
-    = do res ← readItr itr itrResponse id
-         when (getHeader "Content-Type" res == Just defaultPageContentType)
-                  $ do reqM ← readItr itr itrRequest id
-
-                       let conf = itrConfig itr
-                           page = T.pack $ getDefaultPage conf reqM res
+                           ) ()
+      in
+        BB.fromString xmlStr
 
-                       writeTVar (itrBodyToSend itr)
-                                 (S.singleton (encodeUtf8 page))
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml"
 
 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
 {-# INLINEABLE mkDefaultPage #-}
-mkDefaultPage !conf !status !msgA
-    = let (# sCode, sMsg #) = statusCode status
-          sig               = concat [ C8.unpack (cnfServerSoftware conf)
-                                     , " at "
-                                     , C8.unpack (cnfServerHost conf)
-                                     ]
+mkDefaultPage conf status msgA
+    = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
+          sig  = concat [ A.toString (cnfServerSoftware conf)
+                        , " at "
+                        , T.unpack (cnfServerHost conf)
+                        ]
       in ( eelem "/"
            += ( eelem "html"
                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
                 += ( eelem "head"
                      += ( eelem "title"
-                          += txt (fmtDec 3 sCode ⧺ " " ⧺ C8.unpack sMsg)
+                          += txt sStr
                         ))
                 += ( eelem "body"
                      += ( eelem "h1"
-                          += txt (C8.unpack sMsg)
+                          += txt sStr
                         )
                      += ( eelem "p" += msgA )
                      += eelem "hr"
@@ -84,7 +69,7 @@ mkDefaultPage !conf !status !msgA
 
 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
 {-# INLINEABLE getMsg #-}
-getMsg !req !res
+getMsg req res
     = case resStatus res of
         -- 1xx は body を持たない
         -- 2xx の body は補完しない