X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=bb4ba2824e979582db1ca79fc841f2221328e2d2;hb=46f1b85674e45e823f5b6c7a1f87b1faf8172b85;hp=8c30315e1d316a98f40642302453c7a4fbb07121;hpb=a9e9f50818285bf66cd64e5a248175eecb8e1fea;p=Lucu.git

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 8c30315..bb4ba28 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,6 +1,8 @@
+-- #hide, prune
 module Network.HTTP.Lucu.DefaultPage
-    ( getDefaultPage   -- Maybe Request -> Response -> String
-    , writeDefaultPage -- Interaction -> STM ()
+    ( getDefaultPage
+    , writeDefaultPage
+    , mkDefaultPage
     )
     where
 
@@ -11,10 +13,13 @@ import           Control.Monad
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Data.Maybe
+import           Network
+import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
+import           Network.URI
 import           System.IO.Unsafe
 import           Text.Printf
 import           Text.XML.HXT.Arrow.WriteDocument
@@ -24,12 +29,12 @@ import           Text.XML.HXT.DOM.TypeDefs
 import           Text.XML.HXT.DOM.XmlKeywords
 
 
-getDefaultPage :: Maybe Request -> Response -> String
-getDefaultPage req res
+getDefaultPage :: Config -> Maybe Request -> Response -> String
+getDefaultPage conf req res
     = let msgA = getMsg req res
       in
         unsafePerformIO $
-        do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA
+        do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
                               >>>
                               writeDocumentToString [ (a_indent, v_1) ]
                             )
@@ -40,30 +45,29 @@ writeDefaultPage :: Interaction -> STM ()
 writeDefaultPage itr
     = do wroteHeader <- readTVar (itrWroteHeader itr)
 
-         -- ヘッダが出力濟だったら意味が無い。
-         when wroteHeader
-                  $ fail "writeDefaultPage: the header has already been written"
+         -- Content-Type が正しくなければ補完できない。
+         res <- readItr itr itrResponse id
+         when (getHeader "Content-Type" res == Just defaultPageContentType)
+                  $ do reqM <- readItr itr itrRequest id
 
-         resM <- readTVar (itrResponse itr)
+                       let conf = itrConfig itr
+                           page = B.pack $ getDefaultPage conf reqM res
 
-         -- Response が不明ならばページ書込も不可
-         when (resM == Nothing)
-                  $ fail "writeDefaultPage: response was Nothing"
+                       writeTVar (itrBodyToSend itr)
+                                     $ page
 
-         let reqM = itrRequest itr
-             res  = fromJust resM
-             page = B.pack $ getDefaultPage reqM res
 
-         writeTVar (itrResponse itr)
-                       $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
-
-         writeTVar (itrBodyToSend itr)
-                       $ page
-
-
-mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree
-mkDefaultPage status msgA
+mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
+mkDefaultPage conf status msgA
     = let (sCode, sMsg) = statusCode status
+          sig           = cnfServerSoftware conf
+                          ++ " at "
+                          ++ cnfServerHost conf
+                          ++ ( case cnfServerPort conf of
+                                 Service    serv -> ", service " ++ serv
+                                 PortNumber num  -> ", port " ++ show num
+                                 UnixSocket path -> ", unix socket " ++ show path
+                             )
       in ( eelem "/"
            += ( eelem "html"
                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
@@ -75,14 +79,87 @@ mkDefaultPage status msgA
                      += ( eelem "h1"
                           += txt sMsg
                         )
-                     += ( msgA
-                          >>>
-                          eelem "p" += ( this
-                                         >>>
-                                         mkText
-                                       )))))
+                     += ( eelem "p" += msgA )
+                     += eelem "hr"
+                     += ( eelem "address" += txt sig ))))
 
 
-getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String
+getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
 getMsg req res
-    = constA "FIXME: NOT IMPL"
+    = case resStatus res of
+        -- 1xx は body を持たない
+        -- 2xx の body は補完しない
+
+        -- 3xx
+        MovedPermanently
+            -> txt (printf "The resource at %s has been moved to " path)
+               <+>
+               eelem "a" += sattr "href" loc
+                         += txt loc
+               <+>
+               txt " permanently."
+
+        Found
+            -> txt (printf "The resource at %s is currently located at " path)
+               <+>
+               eelem "a" += sattr "href" loc
+                         += txt loc
+               <+>
+               txt ". This is not a permanent relocation."
+
+        SeeOther
+            -> txt (printf "The resource at %s can be found at " path)
+               <+>
+               eelem "a" += sattr "href" loc
+                         += txt loc
+               <+>
+               txt "."
+
+        TemporaryRedirect
+            -> txt (printf "The resource at %s is temporarily located at " path)
+               <+>
+               eelem "a" += sattr "href" loc
+                         += txt loc
+               <+>
+               txt "."
+
+        -- 4xx
+        BadRequest
+            -> txt "The server could not understand the request you sent."
+
+        Unauthorized
+            -> txt (printf "You need a valid authentication to access %s" path)
+
+        Forbidden
+            -> txt (printf "You don't have permission to access %s" path)
+
+        NotFound
+            -> txt (printf "The requested URL %s was not found on this server." path)
+
+        Gone
+            -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
+
+        RequestEntityTooLarge
+            -> txt (printf "The request entity you sent for %s was too big to accept." path)
+
+        RequestURITooLarge
+            -> txt "The request URI you sent was too big to accept."
+
+        -- 5xx
+        InternalServerError
+            -> txt (printf "An internal server error has occured during the process of your request to %s" path)
+
+        ServiceUnavailable
+            -> txt "The service is temporarily unavailable. Try later."
+
+        _  -> none
+
+                            
+    where
+      path :: String
+      path = let uri = reqURI $ fromJust req
+             in
+               uriPath uri
+
+      loc :: String
+      loc = fromJust $ getHeader "Location" res