6 module Network.HTTP.Lucu.DefaultPage
14 import Control.Arrow.ArrowList
15 import Control.Concurrent.STM
17 import qualified Data.ByteString.Char8 as C8
18 import qualified Data.ByteString.Lazy.Char8 as L8
20 import Network.HTTP.Lucu.Config
21 import Network.HTTP.Lucu.Format
22 import Network.HTTP.Lucu.Headers
23 import Network.HTTP.Lucu.Interaction
24 import Network.HTTP.Lucu.Request
25 import Network.HTTP.Lucu.Response
26 import Network.URI hiding (path)
27 import System.IO.Unsafe
28 import Text.XML.HXT.Arrow.WriteDocument
29 import Text.XML.HXT.Arrow.XmlArrow
30 import Text.XML.HXT.Arrow.XmlState
31 import Text.XML.HXT.DOM.TypeDefs
34 getDefaultPage :: Config -> Maybe Request -> Response -> String
35 getDefaultPage !conf !req !res
36 = let msgA = getMsg req res
39 do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
41 writeDocumentToString [ withIndent True ]
46 writeDefaultPage :: Interaction -> STM ()
48 -- Content-Type が正しくなければ補完できない。
49 = do res <- readItr itr itrResponse id
50 when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
51 $ do reqM <- readItr itr itrRequest id
53 let conf = itrConfig itr
54 page = L8.pack $ getDefaultPage conf reqM res
56 writeTVar (itrBodyToSend itr)
60 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
61 mkDefaultPage !conf !status !msgA
62 = let (# sCode, sMsg #) = statusCode status
63 sig = C8.unpack (cnfServerSoftware conf)
65 ++ C8.unpack (cnfServerHost conf)
68 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
71 += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)
75 += txt (C8.unpack sMsg)
77 += ( eelem "p" += msgA )
79 += ( eelem "address" += txt sig ))))
80 {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
82 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
84 = case resStatus res of
90 -> txt ("The resource at " ++ path ++ " has been moved to ")
92 eelem "a" += sattr "href" loc
98 -> txt ("The resource at " ++ path ++ " is currently located at ")
100 eelem "a" += sattr "href" loc
103 txt ". This is not a permanent relocation."
106 -> txt ("The resource at " ++ path ++ " can be found at ")
108 eelem "a" += sattr "href" loc
114 -> txt ("The resource at " ++ path ++ " is temporarily located at ")
116 eelem "a" += sattr "href" loc
123 -> txt "The server could not understand the request you sent."
126 -> txt ("You need a valid authentication to access " ++ path)
129 -> txt ("You don't have permission to access " ++ path)
132 -> txt ("The requested URL " ++ path ++ " was not found on this server.")
135 -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
137 RequestEntityTooLarge
138 -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
141 -> txt "The request URI you sent was too big to accept."
145 -> txt ("An internal server error has occured during the process of your request to " ++ path)
148 -> txt "The service is temporarily unavailable. Try later."
155 path = let uri = reqURI $! fromJust req
160 loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res
162 {-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}