X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=1ae5abd9589bd2f697f849b5f1189ecc6e0c3bcf;hp=6a980104d3dfe6a1f6d9b66202b9898aaa0ae1fd;hb=3318fe0;hpb=3d017dd65ddede9a11c5b7a34a91e04340e67bc4

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 6a98010..1ae5abd 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,168 +1,143 @@
+{-# LANGUAGE
+    OverloadedStrings
+  , RecordWildCards
+  , TypeOperators
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.DefaultPage
     ( getDefaultPage
-    , writeDefaultPage
+    , defaultPageContentType
     , mkDefaultPage
     )
     where
-
-import           Control.Arrow
-import           Control.Arrow.ArrowList
-import           Control.Concurrent.STM
-import           Control.Monad
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
-import           Data.Maybe
-import           Network
-import           Network.HTTP.Lucu.Config
-import           Network.HTTP.Lucu.Format
-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           System.IO.Unsafe
-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
-
-
-getDefaultPage :: Config -> Maybe Request -> Response -> String
+import Blaze.ByteString.Builder (Builder)
+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 Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Maybe
+import qualified Data.Text as T
+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.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 → Builder
+{-# INLINEABLE getDefaultPage #-}
 getDefaultPage conf req res
-    = conf `seq` req `seq` res `seq`
-      let msgA = getMsg req res
+    = let msgA     = getMsg req res
+          [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
+                             ⋙ 
+                             writeDocumentToString [ withIndent True ]
+                           ) ()
       in
-        unsafePerformIO $
-        do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
-                              >>>
-                              writeDocumentToString [ (a_indent, v_1) ]
-                            )
-           return xmlStr
-
-
-writeDefaultPage :: Interaction -> STM ()
-writeDefaultPage itr
-    = itr `seq`
-      -- Content-Type が正しくなければ補完できない。
-      do res <- readItr itr itrResponse id
-         when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
-                  $ do reqM <- readItr itr itrRequest id
-
-                       let conf = itrConfig itr
-                           page = L8.pack $ getDefaultPage conf reqM res
-
-                       writeTVar (itrBodyToSend itr)
-                                     $ page
-
-
-mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
+        BB.fromString xmlStr
+
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml"
+
+mkDefaultPage ∷ (ArrowXml (⇝), StatusCode sc)
+              ⇒ Config
+              → sc
+              → b ⇝ XmlTree
+              → b ⇝ XmlTree
+{-# INLINEABLE mkDefaultPage #-}
 mkDefaultPage conf status msgA
-    = conf `seq` status `seq` msgA `seq`
-      let (# sCode, sMsg #) = statusCode status
-          sig               = C8.unpack (cnfServerSoftware conf)
-                              ++ " at "
-                              ++ C8.unpack (cnfServerHost conf)
-                              ++ ( case cnfServerPort conf of
-                                     Service    serv -> ", service " ++ serv
-                                     PortNumber num  -> ", port " ++ show num
-                                     UnixSocket path -> ", unix socket " ++ show path
-                                 )
+    = 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 (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)
+                          += txt sStr
                         ))
                 += ( eelem "body"
                      += ( eelem "h1"
-                          += txt (C8.unpack sMsg)
+                          += txt sStr
                         )
                      += ( eelem "p" += msgA )
                      += eelem "hr"
                      += ( eelem "address" += txt sig ))))
-{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
-
-getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
-getMsg req res
-    = req `seq` res `seq`
-      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 big to accept.")
-
-        RequestURITooLarge
-            -> txt "The request URI you sent was too big 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
-
-                            
+getMsg ∷ (ArrowXml (⇝)) ⇒ Maybe Request → Response → b ⇝ XmlTree
+{-# INLINEABLE getMsg #-}
+getMsg req res@(Response {..})
+    -- 1xx responses don't have a body.
+    -- 2xx responses don't need a body to be completed.
+    -- 3xx:
+    | resStatus ≈ MovedPermanently
+        = txt ("The resource at " ⧺ path ⧺ " has been moved to ")
+          <+>
+          eelem "a" += sattr "href" loc
+                    += txt loc
+          <+>
+          txt " permanently."
+
+    | resStatus ≈ Found
+        = txt ("The resource at " ⧺ path ⧺ " is currently located at ")
+          <+>
+          eelem "a" += sattr "href" loc
+                    += txt loc
+          <+>
+          txt ". This is not a permanent relocation."
+
+    | resStatus ≈ SeeOther
+        = txt ("The resource at " ⧺ path ⧺ " can be found at ")
+          <+>
+          eelem "a" += sattr "href" loc
+                    += txt loc
+          <+>
+          txt "."
+
+    | resStatus ≈ TemporaryRedirect
+        = txt ("The resource at " ⧺ path ⧺ " is temporarily located at ")
+          <+>
+          eelem "a" += sattr "href" loc
+                    += txt loc
+          <+>
+          txt "."
+
+      -- 4xx:
+    | resStatus ≈ BadRequest
+        = txt "The server could not understand the request you sent."
+    | resStatus ≈ Unauthorized
+        = txt ("You need a valid authentication to access " ⧺ path)
+    | resStatus ≈ Forbidden
+        = txt ("You don't have permission to access " ⧺ path)
+    | resStatus ≈ NotFound
+        = txt ("The requested URL " ⧺ path ⧺ " was not found on this server.")
+    | resStatus ≈ Gone
+        = txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.")
+    | resStatus ≈ RequestEntityTooLarge
+        = txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.")
+    | resStatus ≈ RequestURITooLarge
+        = txt "The request URI you sent was too large to accept."
+
+      -- 5xx:
+    | resStatus ≈ InternalServerError
+        = txt ("An internal server error has occured during the process of your request to " ⧺ path)
+    | resStatus ≈ ServiceUnavailable
+        = txt "The service is temporarily unavailable. Try later."
+
+    | otherwise
+        = none
     where
-      path :: String
-      path = let uri = reqURI $! fromJust req
-             in
-               uriPath uri
-
-      loc :: String
-      loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res
+      path ∷ String
+      path = uriPath $ reqURI $ fromJust req
 
-{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file
+      loc ∷ String
+      loc = A.toString $ fromJust $ getHeader "Location" res