X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FRender.hs;h=cb01bcd35f3aa5abca2c7da7f97a9b6d47944261;hb=859d4378c2e2a1ccc8028821a37eeaa43aaa23fb;hp=698e789e7467c1ce86fc6b6a0f4c99686f9095c0;hpb=3c5211253dc61c31196a47486c538b64c32d8c5e;p=Rakka.git

diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs
index 698e789..cb01bcd 100644
--- a/Rakka/Resource/Render.hs
+++ b/Rakka/Resource/Render.hs
@@ -5,17 +5,15 @@ module Rakka.Resource.Render
 
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
-import           Control.Arrow.ArrowList
+import           Control.Arrow.ArrowIf
 import           Data.Char
 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu.Utils
-import           Network.URI
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource
 import           Rakka.Storage
 import           Rakka.SystemConfig
-import           Rakka.Utils
 import           Rakka.Wiki.Engine
 import           System.FilePath
 import           System.Time
@@ -27,9 +25,9 @@ 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 のような形式でない。
+    | null path                  = return Nothing
+    | null $ head path           = return Nothing
+    | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない
     | otherwise
         = return $ Just $ ResourceDef {
             resUsesNativeThread = False
@@ -48,7 +46,7 @@ fallbackRender env path
 handleGet :: Environment -> PageName -> Resource ()
 handleGet env name
     = runIdempotentA $ proc ()
-    -> do pageM <- getPageA (envStorage env) -< name
+    -> do pageM <- getPageA (envStorage env) -< (name, Nothing)
           case pageM of
             Nothing
                 -> handlePageNotFound env -< name
@@ -56,7 +54,7 @@ handleGet env name
             Just redir@(Redirection _ _ _ _)
                 -> handleRedirect env -< redir
 
-            Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _)
+            Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
                 -> handleGetEntity env -< entity
 
 {-
@@ -66,21 +64,31 @@ handleGet env name
 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
 handleRedirect env
     = proc redir
-    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+    -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
           returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME
 
 
 {-
   <page site="CieloNegro"
-        styleSheet="http://example.org/object/StyleSheet/Default"
         name="Foo/Bar"
         type="text/x-rakka"
-        isTheme="no"        -- text/css の場合のみ存在
-        isFeed="no"         -- text/x-rakka の場合のみ存在
+        lang="ja"            -- 存在しない場合もある
+        fileName="bar.rakka" -- 存在しない場合もある
+        isTheme="no"         -- text/css の場合のみ存在
+        isFeed="no"          -- text/x-rakka の場合のみ存在
         isLocked="no"
-        revision="112">     -- デフォルトでない場合のみ存在
+        isBinary="no"
+        revision="112">      -- デフォルトでない場合のみ存在
         lastModified="2000-01-01T00:00:00">
 
+    <styleSheets>
+      <styleSheet src="http://example.org/object/StyleSheet/Default" />
+    </styleSheets>
+
+    <scripts>
+      <script src="http://example.org/js" />
+    </scripts>
+
     <summary>
         blah blah...
     </summary> -- 存在しない場合もある
@@ -110,78 +118,7 @@ handleRedirect env
 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 handleGetEntity env
     = proc page
-    -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
-          BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
-          StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()
-
-          Just pageTitle    <- getPageA (envStorage env) -< "PageTitle"
-          Just leftSideBar  <- getPageA (envStorage env) -< "SideBar/Left"
-          Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
-
-          tree <- ( eelem "/"
-                    += ( eelem "page"
-                         += sattr "site"       siteName
-                         += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
-                         += sattr "name"       (pageName page)
-                         += sattr "type"       (show $ pageType page)
-                         += ( case pageType page of
-                                MIMEType "text" "css" _
-                                    -> sattr "isTheme" (yesOrNo $ pageIsTheme page)
-                                _   -> none
-                            )
-                         += ( case pageType page of
-                                MIMEType "text" "x-rakka" _
-                                    -> sattr "isFeed" (yesOrNo $ pageIsFeed page)
-                                _   -> none
-                            )
-                         += sattr "isLocked" (yesOrNo $ pageIsLocked page)
-                         += ( case pageRevision page of
-                                Nothing  -> none
-                                Just rev -> sattr "revision" (show rev)
-                            )
-                         += sattr "lastModified" (formatW3CDateTime $ pageLastMod page)
-
-                         += ( case pageSummary page of
-                                Nothing -> none
-                                Just s  -> eelem "summary" += txt s
-                            )
-
-                         += ( case pageOtherLang page of
-                                [] -> none
-                                xs -> selem "otherLang"
-                                      [ eelem "link"
-                                        += sattr "lang" lang
-                                        += sattr "page" page
-                                            | (lang, page) <- xs ]
-                            )
-                         += ( eelem "pageTitle"
-                              += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle)
-                                   >>>
-                                   formatSubPage env
-                                 )
-                            )
-                         += ( eelem "sideBar"
-                              += ( eelem "left"
-                                   += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar)
-                                        >>>
-                                        formatSubPage env
-                                      )
-                                 )
-                              += ( eelem "right"
-                                   += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar)
-                                        >>>
-                                        formatSubPage env
-                                      )
-                                 )
-                            )
-                         += ( eelem "body"
-                              += (constA page >>> formatPage env)
-                            )
-                         >>>
-                         uniqueNamespacesFromDeclAndQNames
-                       )
-                  ) -<< ()
-
+    -> do tree <- formatEntirePage (envStorage env) (envSysConf env) (envInterpTable env) -< page
           returnA -< do let lastMod = toClockTime $ pageLastMod page
                               
                         -- text/x-rakka の場合は、内容が動的に生成され
@@ -191,13 +128,10 @@ handleGetEntity env
                           MIMEType "text" "x-rakka" _
                               -> return ()
                           _   -> case pageRevision page of
-                                   Nothing  -> foundTimeStamp lastMod
-                                   Just rev -> foundEntity (strongETag $ show rev) lastMod
+                                   0   -> foundTimeStamp lastMod -- 0 はデフォルトページ
+                                   rev -> foundEntity (strongETag $ show rev) lastMod
 
                         outputXmlPage tree entityToXHTML
-    where
-      sysConf :: SystemConfig
-      sysConf = envSysConf env
 
 
 entityToXHTML :: ArrowXml a => a XmlTree XmlTree
@@ -205,17 +139,31 @@ entityToXHTML
     = eelem "/"
       += ( eelem "html"
            += sattr "xmlns" "http://www.w3.org/1999/xhtml"
+           += ( getXPathTreesInDoc "/page/@lang"
+                `guards`
+                qattr (QN "xml" "lang" "")
+                          ( getXPathTreesInDoc "/page/@lang/text()" )
+              )
            += ( eelem "head"
                 += ( eelem "title"
                      += getXPathTreesInDoc "/page/@site/text()"
                      += txt " - "
                      += getXPathTreesInDoc "/page/@name/text()"
                    )
-                += ( eelem "link"
+                += ( getXPathTreesInDoc "/page/styleSheets/styleSheet"
+                     >>>
+                     eelem "link"
                      += sattr "rel"  "stylesheet"
                      += sattr "type" "text/css"
                      += attr "href"
-                            ( getXPathTreesInDoc "/page/@styleSheet/text()" )
+                            ( getXPathTrees "/styleSheet/@src/text()" )
+                   )
+                += ( getXPathTreesInDoc "/page/scripts/script"
+                     >>>
+                     eelem "script"
+                     += sattr "type" "text/javascript"
+                     += attr "src"
+                            ( getXPathTrees "/script/@src/text()" )
                    )
               )
            += ( eelem "body"
@@ -278,50 +226,9 @@ entityToXHTML
 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 handlePageNotFound env
     = proc name
-    -> do SiteName   siteName <- getSysConfA sysConf (SiteName   undefined) -< ()
-          BaseURI    baseURI  <- getSysConfA sysConf (BaseURI    undefined) -< ()
-          StyleSheet cssName  <- getSysConfA sysConf (StyleSheet undefined) -< ()
-
-          Just pageTitle    <- getPageA (envStorage env) -< "PageTitle"
-          Just leftSideBar  <- getPageA (envStorage env) -< "SideBar/Left"
-          Just rightSideBar <- getPageA (envStorage env) -< "SideBar/Right"
-
-          tree <- ( eelem "/"
-                    += ( eelem "pageNotFound"
-                         += sattr "site"       siteName
-                         += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "")
-                         += sattr "name"       name
-                         
-                         += ( eelem "pageTitle"
-                              += ( (constA name &&& constA Nothing &&& constA pageTitle)
-                                   >>>
-                                   formatSubPage env
-                                 )
-                            )
-                         += ( eelem "sideBar"
-                              += ( eelem "left"
-                                   += ( (constA name &&& constA Nothing &&& constA leftSideBar)
-                                        >>>
-                                        formatSubPage env
-                                      )
-                                 )
-                              += ( eelem "right"
-                                   += ( (constA name &&& constA Nothing &&& constA rightSideBar)
-                                        >>>
-                                        formatSubPage env
-                                      )
-                                 )
-                            )
-                         >>>
-                         uniqueNamespacesFromDeclAndQNames
-                       )
-                  ) -<< ()
-
+    -> do tree <- formatUnexistentPage (envStorage env) (envSysConf env) (envInterpTable env) -< name
           returnA -< do setStatus NotFound
                         outputXmlPage tree notFoundToXHTML
-    where
-      sysConf :: SystemConfig
-      sysConf = envSysConf env
 
 
 notFoundToXHTML :: ArrowXml a => a XmlTree XmlTree