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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 8c30315..c5ae6f5 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,88 +1,135 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , RecordWildCards
+  , ScopedTypeVariables
+  , TypeOperators
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.DefaultPage
-    ( getDefaultPage   -- Maybe Request -> Response -> String
-    , writeDefaultPage -- Interaction -> STM ()
+    ( defaultPageContentType
+    , defaultPageForResponse
+    , defaultPageWithMessage
     )
     where
+import Blaze.ByteString.Builder (Builder)
+import Data.Ascii (Ascii)
+import qualified Data.CaseInsensitive as CI
+import Data.Convertible.Base
+import Data.Convertible.Utils
+import Data.Maybe
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.URI hiding (path)
+import Prelude hiding (head)
+import Prelude.Unicode
+import Text.Blaze
+import Text.Blaze.Html5 hiding (hr)
+import Text.Blaze.Html5.Attributes hiding (title)
+import Text.Blaze.Renderer.Utf8
 
-import           Control.Arrow
-import           Control.Arrow.ArrowList
-import           Control.Concurrent.STM
-import           Control.Monad
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
-import           Data.Maybe
-import           Network.HTTP.Lucu.Headers
-import           Network.HTTP.Lucu.Interaction
-import           Network.HTTP.Lucu.Request
-import           Network.HTTP.Lucu.Response
-import           System.IO.Unsafe
-import           Text.Printf
-import           Text.XML.HXT.Arrow.WriteDocument
-import           Text.XML.HXT.Arrow.XmlArrow
-import           Text.XML.HXT.Arrow.XmlIOStateArrow
-import           Text.XML.HXT.DOM.TypeDefs
-import           Text.XML.HXT.DOM.XmlKeywords
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml; charset=\"UTF-8\""
 
+defaultPageForResponse ∷ Config → Maybe Request → Response → Builder
+{-# INLINEABLE defaultPageForResponse #-}
+defaultPageForResponse conf req res
+    = defaultPageWithMessage conf (resStatus res) $ defaultMessage req res
 
-getDefaultPage :: Maybe Request -> Response -> String
-getDefaultPage req res
-    = let msgA = getMsg req res
-      in
-        unsafePerformIO $
-        do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA
-                              >>>
-                              writeDocumentToString [ (a_indent, v_1) ]
-                            )
-           return xmlStr
-
-
-writeDefaultPage :: Interaction -> STM ()
-writeDefaultPage itr
-    = do wroteHeader <- readTVar (itrWroteHeader itr)
-
-         -- ヘッダが出力濟だったら意味が無い。
-         when wroteHeader
-                  $ fail "writeDefaultPage: the header has already been written"
+defaultPageWithMessage ∷ ∀sc. StatusCode sc ⇒ Config → sc → Html → Builder
+{-# INLINEABLE defaultPageWithMessage #-}
+defaultPageWithMessage (Config {..}) sc msg
+    = renderHtmlBuilder $
+      do unsafeByteString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+         docType
+         html ! xmlns "http://www.w3.org/1999/xhtml" $
+             do let status = toHtml $ scText sc
+                head $ title status
+                body $ do h1 status
+                          p msg
+                          hr
+                          address $ do toHtml (cs cnfServerSoftware ∷ Text)
+                                       unsafeByteString " at "
+                                       toHtml $ CI.original cnfServerHost
+    where
+      scText ∷ sc → Text
+      scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode
 
-         resM <- readTVar (itrResponse itr)
+defaultMessage ∷ Maybe Request → Response → Html
+{-# INLINEABLE defaultMessage #-}
+defaultMessage req res@(Response {..})
+    -- 1xx responses don't have a body.
+    -- 2xx responses don't need a body to be completed.
+    -- 3xx:
+    | resStatus ≈ MovedPermanently
+        = do unsafeByteString "The resource at "
+             path
+             unsafeByteString " has been moved to "
+             a ! href (toValue loc) $ toHtml loc
+             unsafeByteString " permanently."
 
-         -- Response が不明ならばページ書込も不可
-         when (resM == Nothing)
-                  $ fail "writeDefaultPage: response was Nothing"
+    | resStatus ≈ Found
+        = do unsafeByteString "The resource at "
+             path
+             unsafeByteString " is currently located at "
+             a ! href (toValue loc) $ toHtml loc
+             unsafeByteString ". This is not a permanent relocation."
 
-         let reqM = itrRequest itr
-             res  = fromJust resM
-             page = B.pack $ getDefaultPage reqM res
+    | resStatus ≈ SeeOther
+        = do unsafeByteString "The resource at "
+             path
+             unsafeByteString " can be found at "
+             a ! href (toValue loc) $ toHtml loc
+             unsafeByteString "."
 
-         writeTVar (itrResponse itr)
-                       $ Just $ setHeader "Content-Type" "application/xhtml+xml" res
+    | resStatus ≈ TemporaryRedirect
+        = do unsafeByteString "The resource at "
+             path
+             unsafeByteString " is temporarily located at "
+             a ! href (toValue loc) $ toHtml loc
+             unsafeByteString "."
 
-         writeTVar (itrBodyToSend itr)
-                       $ page
+      -- 4xx:
+    | resStatus ≈ BadRequest
+        = unsafeByteString "The server could not understand the request you sent."
+    | resStatus ≈ Unauthorized
+        = unsafeByteString "You need a valid authentication to access " ⊕ path
+    | resStatus ≈ Forbidden
+        = unsafeByteString "You don't have permission to access " ⊕ path
+    | resStatus ≈ NotFound
+        = do unsafeByteString "The requested URL "
+             path
+             unsafeByteString " was not found on this server."
+    | resStatus ≈ Gone
+        = do unsafeByteString "The resource at "
+             path
+             unsafeByteString " was here in past times, but has gone permanently."
+    | resStatus ≈ RequestEntityTooLarge
+        = do unsafeByteString "The request entity you sent for "
+             path
+             unsafeByteString " was too large to accept."
+    | resStatus ≈ RequestURITooLarge
+        = unsafeByteString "The request URI you sent was too large to accept."
 
+      -- 5xx:
+    | resStatus ≈ InternalServerError
+        = unsafeByteString "An internal server error has occured during the process of your request to " ⊕ path
+    | resStatus ≈ ServiceUnavailable
+        = unsafeByteString "The service is temporarily unavailable. Try later."
 
-mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree
-mkDefaultPage status msgA
-    = let (sCode, sMsg) = statusCode status
-      in ( eelem "/"
-           += ( eelem "html"
-                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
-                += ( eelem "head"
-                     += ( eelem "title"
-                          += txt (printf "%03d %s" sCode sMsg)
-                        ))
-                += ( eelem "body"
-                     += ( eelem "h1"
-                          += txt sMsg
-                        )
-                     += ( msgA
-                          >>>
-                          eelem "p" += ( this
-                                         >>>
-                                         mkText
-                                       )))))
+    | otherwise
+        = (∅)
+    where
+      path ∷ Html
+      path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
 
+      loc ∷ Text
+      loc = cs ∘ fromJust $ getHeader "Location" res
 
-getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String
-getMsg req res
-    = constA "FIXME: NOT IMPL"
+hr ∷ Html
+{-# INLINE hr #-}
+hr = unsafeByteString "<hr/>"