Many improvements

[Lucu.git] / Network / HTTP / Lucu / DefaultPage.hs

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 8c30315e1d316a98f40642302453c7a4fbb07121..f5cc4764366c62d65edbc165bfb8a0b7f73b5283 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,6 +1,7 @@
 module Network.HTTP.Lucu.DefaultPage
-    ( getDefaultPage   -- Maybe Request -> Response -> String
+    ( getDefaultPage   -- Config -> Maybe Request -> Response -> String
     , writeDefaultPage -- Interaction -> STM ()
+    , mkDefaultPage    --  (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
     )
     where
 
@@ -11,10 +12,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 +28,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) ]
                             )
@@ -52,7 +56,8 @@ writeDefaultPage itr
 
          let reqM = itrRequest itr
              res  = fromJust resM
-             page = B.pack $ getDefaultPage reqM res
+             conf = itrConfig itr
+             page = B.pack $ getDefaultPage conf reqM res
 
          writeTVar (itrResponse itr)
                        $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
@@ -61,9 +66,17 @@ writeDefaultPage 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 +88,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