--- #hide, prune
module Network.HTTP.Lucu.DefaultPage
( getDefaultPage
, writeDefaultPage
import Control.Concurrent.STM
import Control.Monad
import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
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 System.IO.Unsafe
-import Text.Printf
import Text.XML.HXT.Arrow.WriteDocument
import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.XmlIOStateArrow
getDefaultPage :: Config -> Maybe Request -> Response -> String
getDefaultPage conf req res
- = let msgA = getMsg req res
+ = conf `seq` req `seq` res `seq`
+ let msgA = getMsg req res
in
unsafePerformIO $
do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
writeDefaultPage :: Interaction -> STM ()
writeDefaultPage itr
- = do wroteHeader <- readTVar (itrWroteHeader itr)
+ = itr `seq`
+ do wroteHeader <- readTVar (itrWroteHeader itr)
-- Content-Type が正しくなければ補完できない。
- res <- readTVar (itrResponse itr)
+ res <- readItr itr itrResponse id
when (getHeader "Content-Type" res == Just defaultPageContentType)
- $ do let reqM = itrRequest itr
- conf = itrConfig itr
+ $ do reqM <- readItr itr itrRequest id
+
+ let conf = itrConfig itr
page = B.pack $ getDefaultPage conf reqM res
writeTVar (itrBodyToSend itr)
mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
mkDefaultPage conf status msgA
- = let (sCode, sMsg) = statusCode status
+ = conf `seq` status `seq` msgA `seq`
+ let (sCode, sMsg) = statusCode status
sig = cnfServerSoftware conf
++ " at "
++ cnfServerHost conf
+= sattr "xmlns" "http://www.w3.org/1999/xhtml"
+= ( eelem "head"
+= ( eelem "title"
- += txt (printf "%03d %s" sCode sMsg)
+ += txt (fmtDec 3 sCode ++ " " ++ sMsg)
))
+= ( eelem "body"
+= ( eelem "h1"
+= ( eelem "p" += msgA )
+= eelem "hr"
+= ( eelem "address" += txt sig ))))
-
+{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
getMsg req res
- = case resStatus res of
+ = req `seq` res `seq`
+ case resStatus res of
-- 1xx は body を持たない
-- 2xx の body は補完しない
-- 3xx
MovedPermanently
- -> txt (printf "The resource at %s has been moved to " path)
+ -> txt ("The resource at " ++ path ++ " has been moved to ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
txt " permanently."
Found
- -> txt (printf "The resource at %s is currently located at " path)
+ -> txt ("The resource at " ++ path ++ " is currently located at ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
txt ". This is not a permanent relocation."
SeeOther
- -> txt (printf "The resource at %s can be found at " path)
+ -> txt ("The resource at " ++ path ++ " can be found at ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
txt "."
TemporaryRedirect
- -> txt (printf "The resource at %s is temporarily located at " path)
+ -> txt ("The resource at " ++ path ++ " is temporarily located at ")
<+>
eelem "a" += sattr "href" loc
+= txt loc
-> txt "The server could not understand the request you sent."
Unauthorized
- -> txt (printf "You need a valid authentication to access %s" path)
+ -> txt ("You need a valid authentication to access " ++ path)
Forbidden
- -> txt (printf "You don't have permission to access %s" path)
+ -> txt ("You don't have permission to access " ++ path)
NotFound
- -> txt (printf "The requested URL %s was not found on this server." path)
+ -> txt ("The requested URL " ++ path ++ " was not found on this server.")
Gone
- -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
+ -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
RequestEntityTooLarge
- -> txt (printf "The request entity you sent for %s was too big to accept." path)
+ -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
RequestURITooLarge
-> txt "The request URI you sent was too big to accept."
-- 5xx
InternalServerError
- -> txt (printf "An internal server error has occured during the process of your request to %s" path)
+ -> txt ("An internal server error has occured during the process of your request to " ++ path)
ServiceUnavailable
-> txt "The service is temporarily unavailable. Try later."
where
path :: String
- path = let uri = reqURI $ fromJust req
+ path = let uri = reqURI $! fromJust req
in
uriPath uri
loc :: String
- loc = fromJust $ getHeader "Location" res
+ loc = fromJust $! getHeader "Location" res
+
+{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file