2 module Network.HTTP.Lucu.DefaultPage
10 import Control.Arrow.ArrowList
11 import Control.Concurrent.STM
13 import qualified Data.ByteString.Lazy.Char8 as B
16 import Network.HTTP.Lucu.Config
17 import Network.HTTP.Lucu.Format
18 import Network.HTTP.Lucu.Headers
19 import Network.HTTP.Lucu.Interaction
20 import Network.HTTP.Lucu.Request
21 import Network.HTTP.Lucu.Response
23 import System.IO.Unsafe
24 import Text.XML.HXT.Arrow.WriteDocument
25 import Text.XML.HXT.Arrow.XmlArrow
26 import Text.XML.HXT.Arrow.XmlIOStateArrow
27 import Text.XML.HXT.DOM.TypeDefs
28 import Text.XML.HXT.DOM.XmlKeywords
31 getDefaultPage :: Config -> Maybe Request -> Response -> String
32 getDefaultPage conf req res
33 = conf `seq` req `seq` res `seq`
34 let msgA = getMsg req res
37 do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
39 writeDocumentToString [ (a_indent, v_1) ]
44 writeDefaultPage :: Interaction -> STM ()
47 do wroteHeader <- readTVar (itrWroteHeader itr)
49 -- Content-Type が正しくなければ補完できない。
50 res <- readItr itr itrResponse id
51 when (getHeader "Content-Type" res == Just defaultPageContentType)
52 $ do reqM <- readItr itr itrRequest id
54 let conf = itrConfig itr
55 page = B.pack $ getDefaultPage conf reqM res
57 writeTVar (itrBodyToSend itr)
61 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
62 mkDefaultPage conf status msgA
63 = conf `seq` status `seq` msgA `seq`
64 let (sCode, sMsg) = statusCode status
65 sig = cnfServerSoftware conf
68 ++ ( case cnfServerPort conf of
69 Service serv -> ", service " ++ serv
70 PortNumber num -> ", port " ++ show num
71 UnixSocket path -> ", unix socket " ++ show path
75 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
78 += txt (fmtDec 3 sCode ++ " " ++ sMsg)
84 += ( eelem "p" += msgA )
86 += ( eelem "address" += txt sig ))))
87 {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
89 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
98 -> txt ("The resource at " ++ path ++ " has been moved to ")
100 eelem "a" += sattr "href" loc
106 -> txt ("The resource at " ++ path ++ " is currently located at ")
108 eelem "a" += sattr "href" loc
111 txt ". This is not a permanent relocation."
114 -> txt ("The resource at " ++ path ++ " can be found at ")
116 eelem "a" += sattr "href" loc
122 -> txt ("The resource at " ++ path ++ " is temporarily located at ")
124 eelem "a" += sattr "href" loc
131 -> txt "The server could not understand the request you sent."
134 -> txt ("You need a valid authentication to access " ++ path)
137 -> txt ("You don't have permission to access " ++ path)
140 -> txt ("The requested URL " ++ path ++ " was not found on this server.")
143 -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
145 RequestEntityTooLarge
146 -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
149 -> txt "The request URI you sent was too big to accept."
153 -> txt ("An internal server error has occured during the process of your request to " ++ path)
156 -> txt "The service is temporarily unavailable. Try later."
163 path = let uri = reqURI $! fromJust req
168 loc = fromJust $! getHeader "Location" res
170 {-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}