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.Headers
19 import Network.HTTP.Lucu.Interaction
20 import Network.HTTP.Lucu.Request
21 import Network.HTTP.Lucu.Response
23 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 = let msgA = getMsg req res
37 do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
39 writeDocumentToString [ (a_indent, v_1) ]
44 writeDefaultPage :: Interaction -> STM ()
46 = do wroteHeader <- readTVar (itrWroteHeader itr)
50 $ fail "writeDefaultPage: the header has already been written"
52 resM <- readTVar (itrResponse itr)
54 -- Response が不明ならばページ書込も不可
55 when (resM == Nothing)
56 $ fail "writeDefaultPage: response was Nothing"
58 let reqM = itrRequest itr
61 page = B.pack $ getDefaultPage conf reqM res
63 writeTVar (itrResponse itr)
64 $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
66 writeTVar (itrBodyToSend itr)
70 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
71 mkDefaultPage conf status msgA
72 = let (sCode, sMsg) = statusCode status
73 sig = cnfServerSoftware conf
76 ++ ( case cnfServerPort conf of
77 Service serv -> ", service " ++ serv
78 PortNumber num -> ", port " ++ show num
79 UnixSocket path -> ", unix socket " ++ show path
83 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
86 += txt (printf "%03d %s" sCode sMsg)
92 += ( eelem "p" += msgA )
94 += ( eelem "address" += txt sig ))))
97 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
99 = case resStatus res of
105 -> txt (printf "The resource at %s has been moved to " path)
107 eelem "a" += sattr "href" loc
113 -> txt (printf "The resource at %s is currently located at " path)
115 eelem "a" += sattr "href" loc
118 txt ". This is not a permanent relocation."
121 -> txt (printf "The resource at %s can be found at " path)
123 eelem "a" += sattr "href" loc
129 -> txt (printf "The resource at %s is temporarily located at " path)
131 eelem "a" += sattr "href" loc
138 -> txt "The server could not understand the request you sent."
141 -> txt (printf "You need a valid authentication to access %s" path)
144 -> txt (printf "You don't have permission to access %s" path)
147 -> txt (printf "The requested URL %s was not found on this server." path)
150 -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
152 RequestEntityTooLarge
153 -> txt (printf "The request entity you sent for %s was too big to accept." path)
156 -> txt "The request URI you sent was too big to accept."
160 -> txt (printf "An internal server error has occured during the process of your request to %s" path)
163 -> txt "The service is temporarily unavailable. Try later."
170 path = let uri = reqURI $ fromJust req
175 loc = fromJust $ getHeader "Location" res