1 module Network.HTTP.Lucu.DefaultPage
2 ( getDefaultPage -- Config -> Maybe Request -> Response -> String
3 , writeDefaultPage -- Interaction -> STM ()
4 , mkDefaultPage -- (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
9 import Control.Arrow.ArrowList
10 import Control.Concurrent.STM
12 import qualified Data.ByteString.Lazy.Char8 as B
13 import Data.ByteString.Lazy.Char8 (ByteString)
16 import Network.HTTP.Lucu.Config
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
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 = let msgA = getMsg req res
36 do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
38 writeDocumentToString [ (a_indent, v_1) ]
43 writeDefaultPage :: Interaction -> STM ()
45 = do wroteHeader <- readTVar (itrWroteHeader itr)
49 $ fail "writeDefaultPage: the header has already been written"
51 resM <- readTVar (itrResponse itr)
53 -- Response が不明ならばページ書込も不可
54 when (resM == Nothing)
55 $ fail "writeDefaultPage: response was Nothing"
57 let reqM = itrRequest itr
60 page = B.pack $ getDefaultPage conf reqM res
62 writeTVar (itrResponse itr)
63 $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
65 writeTVar (itrBodyToSend itr)
69 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
70 mkDefaultPage conf status msgA
71 = let (sCode, sMsg) = statusCode status
72 sig = cnfServerSoftware conf
75 ++ ( case cnfServerPort conf of
76 Service serv -> ", service " ++ serv
77 PortNumber num -> ", port " ++ show num
78 UnixSocket path -> ", unix socket " ++ show path
82 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
85 += txt (printf "%03d %s" sCode sMsg)
91 += ( eelem "p" += msgA )
93 += ( eelem "address" += txt sig ))))
96 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
98 = case resStatus res of
104 -> txt (printf "The resource at %s has been moved to " path)
106 eelem "a" += sattr "href" loc
112 -> txt (printf "The resource at %s is currently located at " path)
114 eelem "a" += sattr "href" loc
117 txt ". This is not a permanent relocation."
120 -> txt (printf "The resource at %s can be found at " path)
122 eelem "a" += sattr "href" loc
128 -> txt (printf "The resource at %s is temporarily located at " path)
130 eelem "a" += sattr "href" loc
137 -> txt "The server could not understand the request you sent."
140 -> txt (printf "You need a valid authentication to access %s" path)
143 -> txt (printf "You don't have permission to access %s" path)
146 -> txt (printf "The requested URL %s was not found on this server." path)
149 -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
151 RequestEntityTooLarge
152 -> txt (printf "The request entity you sent for %s was too big to accept." path)
155 -> txt "The request URI you sent was too big to accept."
159 -> txt (printf "An internal server error has occured during the process of your request to %s" path)
162 -> txt "The service is temporarily unavailable. Try later."
169 path = let uri = reqURI $ fromJust req
174 loc = fromJust $ getHeader "Location" res