, mkDefaultPage
)
where
+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 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 qualified Data.Text.Lazy as Lazy
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 ∷ Config → Maybe Request → Response → Lazy.Text
+{-# INLINEABLE getDefaultPage #-}
getDefaultPage !conf !req !res
- = let msgA = getMsg req res
- in
- unsafePerformIO $
- do [xmlStr] ← runX ( mkDefaultPage conf (resStatus res) msgA
+ = let msgA = getMsg req res
+ [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
⋙
writeDocumentToString [ withIndent True ]
- )
- return xmlStr
+ ) ()
+ in
+ Lazy.pack xmlStr
writeDefaultPage ∷ Interaction → STM ()
writeDefaultPage !itr
-- Content-Type が正しくなければ補完できない。
- = do res ← readItr itr itrResponse id
+ = do res ← readItr itrResponse id itr
when (getHeader "Content-Type" res == Just defaultPageContentType)
- $ do reqM ← readItr itr itrRequest id
+ $ do reqM ← readItr itrRequest id itr
let conf = itrConfig itr
- page = T.pack $ getDefaultPage conf reqM res
+ page = getDefaultPage conf reqM res
- writeTVar (itrBodyToSend itr)
- (S.singleton (encodeUtf8 page))
+ putTMVar (itrBodyToSend itr) (BB.fromLazyText page)
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)
- ]
+ = 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"