1 module Network.HTTP.Lucu.DefaultPage
9 import Control.Arrow.ArrowList
10 import Control.Concurrent.STM
12 import qualified Data.ByteString.Char8 as C8
13 import qualified Data.ByteString.Lazy.Char8 as L8
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
21 import Network.URI hiding (path)
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.XmlState
26 import Text.XML.HXT.DOM.TypeDefs
29 getDefaultPage :: Config -> Maybe Request -> Response -> String
30 getDefaultPage !conf !req !res
31 = let msgA = getMsg req res
34 do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
36 writeDocumentToString [ withIndent True ]
41 writeDefaultPage :: Interaction -> STM ()
43 -- Content-Type が正しくなければ補完できない。
44 = do res <- readItr itr itrResponse id
45 when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
46 $ do reqM <- readItr itr itrRequest id
48 let conf = itrConfig itr
49 page = L8.pack $ getDefaultPage conf reqM res
51 writeTVar (itrBodyToSend itr)
55 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
56 mkDefaultPage !conf !status !msgA
57 = let (# sCode, sMsg #) = statusCode status
58 sig = C8.unpack (cnfServerSoftware conf)
60 ++ C8.unpack (cnfServerHost conf)
63 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
66 += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)
70 += txt (C8.unpack sMsg)
72 += ( eelem "p" += msgA )
74 += ( eelem "address" += txt sig ))))
75 {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
77 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
79 = case resStatus res of
85 -> txt ("The resource at " ++ path ++ " has been moved to ")
87 eelem "a" += sattr "href" loc
93 -> txt ("The resource at " ++ path ++ " is currently located at ")
95 eelem "a" += sattr "href" loc
98 txt ". This is not a permanent relocation."
101 -> txt ("The resource at " ++ path ++ " can be found at ")
103 eelem "a" += sattr "href" loc
109 -> txt ("The resource at " ++ path ++ " is temporarily located at ")
111 eelem "a" += sattr "href" loc
118 -> txt "The server could not understand the request you sent."
121 -> txt ("You need a valid authentication to access " ++ path)
124 -> txt ("You don't have permission to access " ++ path)
127 -> txt ("The requested URL " ++ path ++ " was not found on this server.")
130 -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
132 RequestEntityTooLarge
133 -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
136 -> txt "The request URI you sent was too big to accept."
140 -> txt ("An internal server error has occured during the process of your request to " ++ path)
143 -> txt "The service is temporarily unavailable. Try later."
150 path = let uri = reqURI $! fromJust req
155 loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res
157 {-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}