Implemented makeDraft and others

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

diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs
index 599086b949b742c4b2df22b14d56d7f393178523..3c0bd7a6a1ab4ae1dd4740d08fc672c01c10d34c 100644 (file)
--- a/Rakka/Resource/Render.hs
+++ b/Rakka/Resource/Render.hs
@@ -6,18 +6,14 @@ module Rakka.Resource.Render
 import           Control.Arrow
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowIf
-import           Control.Arrow.ArrowList
 import           Data.Char
-import qualified Data.Map as M
 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
@@ -81,6 +77,7 @@ handleRedirect env
         isTheme="no"        -- text/css の場合のみ存在
         isFeed="no"         -- text/x-rakka の場合のみ存在
         isLocked="no"
+        isBinary="no"
         revision="112">     -- デフォルトでない場合のみ存在
         lastModified="2000-01-01T00:00:00">
 
@@ -113,83 +110,7 @@ handleRedirect env
 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
 handleGetEntity env
     = proc page
-    -> do SiteName   siteName <- getSysConfA sysConf -< ()
-          BaseURI    baseURI  <- getSysConfA sysConf -< ()
-          StyleSheet cssName  <- getSysConfA sysConf -< ()
-
-          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 pageLanguage page of
-                                Just x -> sattr "lang" x
-                                _      -> none
-                            )
-                         += ( 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
-                            )
-
-                         += ( if M.null (pageOtherLang page) then
-                                  none
-                              else
-                                  selem "otherLang"
-                                            [ eelem "link"
-                                              += sattr "lang" lang
-                                              += sattr "page" page
-                                                  | (lang, page) <- M.toList (pageOtherLang page) ]
-                            )
-                         += ( 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 の場合は、内容が動的に生成され
@@ -199,13 +120,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
@@ -291,50 +209,9 @@ entityToXHTML
 handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ())
 handlePageNotFound env
     = proc name
-    -> do SiteName   siteName <- getSysConfA sysConf -< ()
-          BaseURI    baseURI  <- getSysConfA sysConf -< ()
-          StyleSheet cssName  <- getSysConfA sysConf -< ()
-
-          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