wrote more code...

[Rakka.git] / Rakka / Resource / Render.hs

diff --git a/Rakka/Resource/Page/Get.hs b/Rakka/Resource/Render.hs
similarity index 84%
rename from Rakka/Resource/Page/Get.hs
rename to Rakka/Resource/Render.hs
index 30da9b97f9b9dbf626f049d4f595ff9d28e1cfd1..668d814b4394c0c35a11902d0a48b3b4213dbb07 100644 (file)
--- a/Rakka/Resource/Page/Get.hs
+++ b/Rakka/Resource/Render.hs
@@ -1,5 +1,5 @@
-module Rakka.Resource.Page.Get
-    ( handleGet
+module Rakka.Resource.Render
+    ( fallbackRender
     )
     where
 
@@ -7,9 +7,9 @@ import           Control.Arrow
 import           Control.Arrow.ArrowIf
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowList
-import           Data.Encoding
-import           Data.Encoding.UTF8
+import           Data.Char
 import           Network.HTTP.Lucu
+import           Network.HTTP.Lucu.Utils
 import           Network.URI
 import           Rakka.Environment
 import           Rakka.Page
@@ -17,12 +17,35 @@ import           Rakka.Resource
 import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Utils
+import           Rakka.Wiki.Engine
+import           System.FilePath
 import           System.Time
+import           Text.XML.HXT.Arrow.Namespace
 import           Text.XML.HXT.Arrow.XmlArrow
 import           Text.XML.HXT.Arrow.XmlNodeSet
 import           Text.XML.HXT.DOM.TypeDefs
 
 
+fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef)
+fallbackRender env path
+    | null path                        = return Nothing
+    | null $ head path                 = return Nothing
+    | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。
+    | otherwise
+        = return $ Just $ ResourceDef {
+            resUsesNativeThread = False
+          , resIsGreedy         = True
+          , resGet              = Just $ handleGet env (toPageName path)
+          , resHead             = Nothing
+          , resPost             = Nothing
+          , resPut              = Nothing
+          , resDelete           = Nothing
+          }
+    where
+      toPageName :: [String] -> PageName
+      toPageName = decodePageName . dropExtension . joinWith "/"
+
+
 handleGet :: Environment -> PageName -> Resource ()
 handleGet env name
     = runIdempotentA $ proc ()
@@ -39,7 +62,7 @@ handleGet env name
 
 {-
   HTTP/1.1 302 Found
-  Location: http://example.org/Destination?from=Source&revision=112
+  Location: http://example.org/Destination?from=Source
 -}
 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
 handleRedirect env
@@ -80,7 +103,7 @@ handleRedirect env
   
   <object data="/object/Foo/Bar" /> -- data 屬性に URI
 -}
-handleGetEntity :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
+handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 handleGetEntity env
     = let sysConf = envSysConf env
       in
@@ -129,11 +152,13 @@ handleGetEntity env
                                                   
                                += ( case pageIsBinary page of
                                       False -> eelem "content"
-                                               += txt (decodeLazy UTF8 $ pageContent page)
+                                               += (constA page >>> formatPage)
 
                                       True  -> eelem "object"
                                                += sattr "data" (uriToString id (mkObjectURI baseURI $ pageName page) "")
                                   )
+                               >>>
+                               uniqueNamespacesFromDeclAndQNames
                              )
                         ) -<< ()
 
@@ -188,10 +213,7 @@ entityToXHTML
                         )
                      += ( eelem "div"
                           += sattr "class" "body"
-                          += ( getXPathTreesInDoc "/page/content"
-                               `guards`
-                               getXPathTreesInDoc "/page/content/text()" -- FIXME
-                             )
+                          += getXPathTreesInDoc "/page/content/*"
                           += ( getXPathTreesInDoc "/page/object"
                                `guards`
                                eelem "object"
@@ -216,4 +238,6 @@ entityToXHTML
                         )
                    )
               )
+           >>>
+           uniqueNamespacesFromDeclAndQNames
          )