import Control.Arrow.ArrowList
import Control.Concurrent.STM
import Control.Monad
-import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Maybe
-import Network
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
+import Network.URI hiding (path)
import System.IO.Unsafe
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlIOStateArrow
+import Text.XML.HXT.Arrow.XmlState
import Text.XML.HXT.DOM.TypeDefs
-import Text.XML.HXT.DOM.XmlKeywords
getDefaultPage :: Config -> Maybe Request -> Response -> String
-getDefaultPage conf req res
- = conf `seq` req `seq` res `seq`
- let msgA = getMsg req res
+getDefaultPage !conf !req !res
+ = let msgA = getMsg req res
in
unsafePerformIO $
do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
>>>
- writeDocumentToString [ (a_indent, v_1) ]
+ writeDocumentToString [ withIndent True ]
)
return xmlStr
writeDefaultPage :: Interaction -> STM ()
-writeDefaultPage itr
- = itr `seq`
- do wroteHeader <- readTVar (itrWroteHeader itr)
-
- -- Content-Type が正しくなければ補完できない。
- res <- readItr itr itrResponse id
- when (getHeader "Content-Type" res == Just defaultPageContentType)
+writeDefaultPage !itr
+ -- Content-Type が正しくなければ補完できない。
+ = do res <- readItr itr itrResponse id
+ when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
$ do reqM <- readItr itr itrRequest id
let conf = itrConfig itr
- page = B.pack $ getDefaultPage conf reqM res
+ page = L8.pack $ getDefaultPage conf reqM res
writeTVar (itrBodyToSend itr)
$ page
mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
-mkDefaultPage conf status msgA
- = conf `seq` status `seq` msgA `seq`
- let (sCode, sMsg) = statusCode status
- sig = cnfServerSoftware conf
- ++ " at "
- ++ cnfServerHost conf
- ++ ( case cnfServerPort conf of
- Service serv -> ", service " ++ serv
- PortNumber num -> ", port " ++ show num
- UnixSocket path -> ", unix socket " ++ show path
- )
+mkDefaultPage !conf !status !msgA
+ = let (# sCode, sMsg #) = statusCode status
+ sig = C8.unpack (cnfServerSoftware conf)
+ ++ " at "
+ ++ C8.unpack (cnfServerHost conf)
in ( eelem "/"
+= ( eelem "html"
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
- += txt (fmtDec 3 sCode ++ " " ++ sMsg)
+ += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)
))
+= ( eelem "body"
+= ( eelem "h1"
- += txt sMsg
+ += txt (C8.unpack sMsg)
)
+= ( eelem "p" += msgA )
+= eelem "hr"
{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
-getMsg req res
- = req `seq` res `seq`
- case resStatus res of
+getMsg !req !res
+ = case resStatus res of
-- 1xx は body を持たない
-- 2xx の body は補完しない
uriPath uri
loc :: String
- loc = fromJust $! getHeader "Location" res
+ loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res
{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file