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
14 import Data.ByteString.Lazy.Char8 (ByteString)
17 import Network.HTTP.Lucu.Config
18 import Network.HTTP.Lucu.Format
19 import Network.HTTP.Lucu.Headers
20 import Network.HTTP.Lucu.Interaction
21 import Network.HTTP.Lucu.Request
22 import Network.HTTP.Lucu.Response
24 import System.IO.Unsafe
25 import Text.XML.HXT.Arrow.WriteDocument
26 import Text.XML.HXT.Arrow.XmlArrow
27 import Text.XML.HXT.Arrow.XmlIOStateArrow
28 import Text.XML.HXT.DOM.TypeDefs
29 import Text.XML.HXT.DOM.XmlKeywords
32 getDefaultPage :: Config -> Maybe Request -> Response -> String
33 getDefaultPage conf req res
34 = conf `seq` req `seq` res `seq`
35 let msgA = getMsg req res
38 do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
40 writeDocumentToString [ (a_indent, v_1) ]
45 writeDefaultPage :: Interaction -> STM ()
48 do wroteHeader <- readTVar (itrWroteHeader itr)
50 -- Content-Type が正しくなければ補完できない。
51 res <- readItr itr itrResponse id
52 when (getHeader "Content-Type" res == Just defaultPageContentType)
53 $ do reqM <- readItr itr itrRequest id
55 let conf = itrConfig itr
56 page = B.pack $ getDefaultPage conf reqM res
58 writeTVar (itrBodyToSend itr)
62 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
63 mkDefaultPage conf status msgA
64 = conf `seq` status `seq` msgA `seq`
65 let (sCode, sMsg) = statusCode status
66 sig = cnfServerSoftware conf
69 ++ ( case cnfServerPort conf of
70 Service serv -> ", service " ++ serv
71 PortNumber num -> ", port " ++ show num
72 UnixSocket path -> ", unix socket " ++ show path
76 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
79 += txt (fmtDec 3 sCode ++ " " ++ sMsg)
85 += ( eelem "p" += msgA )
87 += ( eelem "address" += txt sig ))))
88 {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
90 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
99 -> txt ("The resource at " ++ path ++ " has been moved to ")
101 eelem "a" += sattr "href" loc
107 -> txt ("The resource at " ++ path ++ " is currently located at ")
109 eelem "a" += sattr "href" loc
112 txt ". This is not a permanent relocation."
115 -> txt ("The resource at " ++ path ++ " can be found at ")
117 eelem "a" += sattr "href" loc
123 -> txt ("The resource at " ++ path ++ " is temporarily located at ")
125 eelem "a" += sattr "href" loc
132 -> txt "The server could not understand the request you sent."
135 -> txt ("You need a valid authentication to access " ++ path)
138 -> txt ("You don't have permission to access " ++ path)
141 -> txt ("The requested URL " ++ path ++ " was not found on this server.")
144 -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
146 RequestEntityTooLarge
147 -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
150 -> txt "The request URI you sent was too big to accept."
154 -> txt ("An internal server error has occured during the process of your request to " ++ path)
157 -> txt "The service is temporarily unavailable. Try later."
164 path = let uri = reqURI $! fromJust req
169 loc = fromJust $! getHeader "Location" res
171 {-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}