1 module Network.HTTP.Lucu.DefaultPage
9 import Control.Arrow.ArrowList
10 import Control.Concurrent.STM
12 import qualified Data.ByteString.Lazy.Char8 as B
15 import Network.HTTP.Lucu.Config
16 import Network.HTTP.Lucu.Format
17 import Network.HTTP.Lucu.Headers
18 import Network.HTTP.Lucu.Interaction
19 import Network.HTTP.Lucu.Request
20 import Network.HTTP.Lucu.Response
22 import System.IO.Unsafe
23 import Text.XML.HXT.Arrow.WriteDocument
24 import Text.XML.HXT.Arrow.XmlArrow
25 import Text.XML.HXT.Arrow.XmlIOStateArrow
26 import Text.XML.HXT.DOM.TypeDefs
27 import Text.XML.HXT.DOM.XmlKeywords
30 getDefaultPage :: Config -> Maybe Request -> Response -> String
31 getDefaultPage conf req res
32 = conf `seq` req `seq` res `seq`
33 let msgA = getMsg req res
36 do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
38 writeDocumentToString [ (a_indent, v_1) ]
43 writeDefaultPage :: Interaction -> STM ()
46 do wroteHeader <- readTVar (itrWroteHeader itr)
48 -- Content-Type が正しくなければ補完できない。
49 res <- readItr itr itrResponse id
50 when (getHeader "Content-Type" res == Just defaultPageContentType)
51 $ do reqM <- readItr itr itrRequest id
53 let conf = itrConfig itr
54 page = B.pack $ getDefaultPage conf reqM res
56 writeTVar (itrBodyToSend itr)
60 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
61 mkDefaultPage conf status msgA
62 = conf `seq` status `seq` msgA `seq`
63 let (sCode, sMsg) = statusCode status
64 sig = cnfServerSoftware conf
67 ++ ( case cnfServerPort conf of
68 Service serv -> ", service " ++ serv
69 PortNumber num -> ", port " ++ show num
70 UnixSocket path -> ", unix socket " ++ show path
74 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
77 += txt (fmtDec 3 sCode ++ " " ++ sMsg)
83 += ( eelem "p" += msgA )
85 += ( eelem "address" += txt sig ))))
86 {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
88 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
97 -> txt ("The resource at " ++ path ++ " has been moved to ")
99 eelem "a" += sattr "href" loc
105 -> txt ("The resource at " ++ path ++ " is currently located at ")
107 eelem "a" += sattr "href" loc
110 txt ". This is not a permanent relocation."
113 -> txt ("The resource at " ++ path ++ " can be found at ")
115 eelem "a" += sattr "href" loc
121 -> txt ("The resource at " ++ path ++ " is temporarily located at ")
123 eelem "a" += sattr "href" loc
130 -> txt "The server could not understand the request you sent."
133 -> txt ("You need a valid authentication to access " ++ path)
136 -> txt ("You don't have permission to access " ++ path)
139 -> txt ("The requested URL " ++ path ++ " was not found on this server.")
142 -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
144 RequestEntityTooLarge
145 -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
148 -> txt "The request URI you sent was too big to accept."
152 -> txt ("An internal server error has occured during the process of your request to " ++ path)
155 -> txt "The service is temporarily unavailable. Try later."
162 path = let uri = reqURI $! fromJust req
167 loc = fromJust $! getHeader "Location" res
169 {-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}