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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 360a268..c5ae6f5 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,160 +1,135 @@
 {-# LANGUAGE
-    BangPatterns
-  , OverloadedStrings
-  , UnboxedTuples
+    OverloadedStrings
+  , RecordWildCards
+  , ScopedTypeVariables
+  , TypeOperators
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.DefaultPage
-    ( getDefaultPage
-    , writeDefaultPage
-    , mkDefaultPage
+    ( defaultPageContentType
+    , defaultPageForResponse
+    , defaultPageWithMessage
     )
     where
-import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
-import Control.Arrow
-import Control.Arrow.ArrowList
-import Control.Arrow.ListArrow
-import Control.Arrow.Unicode
-import Control.Concurrent.STM
-import Control.Monad
-import qualified Data.Ascii as A
+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 qualified Data.Text as T
-import qualified Data.Text.Lazy as Lazy
+import Data.Monoid.Unicode
+import Data.Text (Text)
 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 hiding (path)
+import Prelude hiding (head)
 import Prelude.Unicode
-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlState
-import Text.XML.HXT.DOM.TypeDefs
-
-getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text
-{-# INLINEABLE getDefaultPage #-}
-getDefaultPage !conf !req !res
-    = let msgA     = getMsg req res
-          [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
-                             ⋙ 
-                             writeDocumentToString [ withIndent True ]
-                           ) ()
-      in
-        Lazy.pack xmlStr
-
-writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage !itr
-    -- Content-Type が正しくなければ補完できない。
-    = do res ← readItr itrResponse id itr
-         when (getHeader "Content-Type" res == Just defaultPageContentType)
-                  $ do reqM ← readItr itrRequest id itr
-
-                       let conf = itrConfig itr
-                           page = getDefaultPage conf reqM res
-
-                       putTMVar (itrBodyToSend itr) (BB.fromLazyText page)
-
-mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
-{-# INLINEABLE mkDefaultPage #-}
-mkDefaultPage !conf !status !msgA
-    = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
-          sig  = concat [ A.toString (cnfServerSoftware conf)
-                        , " at "
-                        , T.unpack (cnfServerHost conf)
-                        ]
-      in ( eelem "/"
-           += ( eelem "html"
-                += sattr "xmlns" "http://www.w3.org/1999/xhtml"
-                += ( eelem "head"
-                     += ( eelem "title"
-                          += txt sStr
-                        ))
-                += ( eelem "body"
-                     += ( eelem "h1"
-                          += txt sStr
-                        )
-                     += ( eelem "p" += msgA )
-                     += eelem "hr"
-                     += ( eelem "address" += txt sig ))))
-
-getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
-{-# INLINEABLE getMsg #-}
-getMsg !req !res
-    = case resStatus res of
-        -- 1xx は body を持たない
-        -- 2xx の body は補完しない
-
-        -- 3xx
-        MovedPermanently
-            → txt ("The resource at " ⧺ path ⧺ " has been moved to ")
-               <+>
-               eelem "a" += sattr "href" loc
-                         += txt loc
-               <+>
-               txt " permanently."
-
-        Found
-            → txt ("The resource at " ⧺ path ⧺ " is currently located at ")
-               <+>
-               eelem "a" += sattr "href" loc
-                         += txt loc
-               <+>
-               txt ". This is not a permanent relocation."
-
-        SeeOther
-            → txt ("The resource at " ⧺ path ⧺ " can be found at ")
-               <+>
-               eelem "a" += sattr "href" loc
-                         += txt loc
-               <+>
-               txt "."
-
-        TemporaryRedirect
-            → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
-               <+>
-               eelem "a" += sattr "href" loc
-                         += txt loc
-               <+>
-               txt "."
-
-        -- 4xx
-        BadRequest
-            → txt "The server could not understand the request you sent."
-
-        Unauthorized
-            → txt ("You need a valid authentication to access " ⧺ path)
-
-        Forbidden
-            → txt ("You don't have permission to access " ⧺ path)
-
-        NotFound
-            → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
-
-        Gone
-            → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
-
-        RequestEntityTooLarge
-            → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
-
-        RequestURITooLarge
-            → txt "The request URI you sent was too large to accept."
-
-        -- 5xx
-        InternalServerError
-            → txt ("An internal server error has occured during the process of your request to " ⧺ path)
-
-        ServiceUnavailable
-            → txt "The service is temporarily unavailable. Try later."
-
-        _  → none
-
+import Text.Blaze
+import Text.Blaze.Html5 hiding (hr)
+import Text.Blaze.Html5.Attributes hiding (title)
+import Text.Blaze.Renderer.Utf8
+
+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
+
+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
-      path ∷ String
-      path = let uri = reqURI $ fromJust req
-             in
-               uriPath uri
+      scText ∷ sc → Text
+      scText = convertSuccessVia ((⊥) ∷ Ascii) ∘ fromStatusCode
+
+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."
+
+    | 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."
+
+    | resStatus ≈ SeeOther
+        = do unsafeByteString "The resource at "
+             path
+             unsafeByteString " can be found at "
+             a ! href (toValue loc) $ toHtml loc
+             unsafeByteString "."
+
+    | resStatus ≈ TemporaryRedirect
+        = do unsafeByteString "The resource at "
+             path
+             unsafeByteString " is temporarily located at "
+             a ! href (toValue loc) $ toHtml loc
+             unsafeByteString "."
+
+      -- 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."
+
+    | otherwise
+        = (∅)
+    where
+      path ∷ Html
+      path = toHtml ∘ uriPath ∘ reqURI $ fromJust req
+
+      loc ∷ Text
+      loc = cs ∘ fromJust $ getHeader "Location" res
 
-      loc ∷ String
-      loc = A.toString $ fromJust $ getHeader "Location" res
+hr ∷ Html
+{-# INLINE hr #-}
+hr = unsafeByteString "<hr/>"