From: pho Date: Sun, 20 Jan 2008 06:24:46 +0000 (+0900) Subject: implemented page listing X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=b101c0a9aad609704eaa9157fe809be80d2aacf7;p=Rakka.git implemented page listing darcs-hash:20080120062446-62b54-0f3e73618ee4d6a6727b0febdc9c38437d4e3a4c.gz --- diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index dbef4d5..0b54594 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -55,11 +55,16 @@ handleGet env name = runIdempotentA $ proc () -> do pageM <- getPageA (envStorage env) -< (name, Nothing) case pageM of - Nothing -> handlePageNotFound env -< name - Just page -> if isEntity page then - handleGetEntity env -< page - else - handleRedirect env -< page + Nothing + -> do items <- getDirContentsA (envStorage env) -< (name, Nothing) + case items of + [] -> handlePageNotFound env -< name + _ -> handleGetPageListing env -< (name, items) + Just page + -> if isEntity page then + handleGetEntity env -< page + else + handleRedirect env -< page {- @@ -213,6 +218,126 @@ readSubPage env returnA -< subXHTML +{- + + + + +-} +handleGetPageListing :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a (PageName, [PageName]) (Resource ()) +handleGetPageListing env + = proc (dir, items) + -> do tree <- ( eelem "/" + += ( eelem "pageListing" + += attr "path" (arr fst >>> mkText) + += ( arrL snd + >>> + ( eelem "page" + += attr "name" (arr id >>> mkText) + ) + ) + ) + ) -< (dir, items) + returnA -< outputXmlPage tree (pageListingToXHTML env) + + +pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree +pageListingToXHTML env + = proc pageListing + -> do SiteName siteName <- getSysConfA (envSysConf env) -< () + BaseURI baseURI <- getSysConfA (envSysConf env) -< () + StyleSheet styleSheet <- getSysConfA (envSysConf env) -< () + GlobalLock isGLocked <- getSysConfA (envSysConf env) -< () + + name <- (getXPathTreesInDoc "/pageListing/@path/text()" >>> getText) -< pageListing + + let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] + scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] + + pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") + + ( eelem "/" + += ( eelem "html" + += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( eelem "head" + += ( eelem "title" + += txt siteName + += txt " - " + += getXPathTreesInDoc "/pageListing/@path/text()" + ) + += ( constL cssHref + >>> + eelem "link" + += sattr "rel" "stylesheet" + += sattr "type" "text/css" + += attr "href" (arr id >>> mkText) + ) + += ( constL scriptSrc + >>> + eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr id >>> mkText) + ) + += ( eelem "script" + += sattr "type" "text/javascript" + += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") + += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") + ) + ) + += ( eelem "body" + += ( eelem "div" + += sattr "class" "header" + ) + += ( eelem "div" + += sattr "class" "center" + += ( eelem "div" + += sattr "class" "title" + += constL pageTitle + ) + += ( eelem "div" + += sattr "class" "body" + += ( eelem "ul" + += ( getXPathTreesInDoc "/pageListing/page/@name/text()" + >>> + eelem "li" + += ( eelem "a" + += attr "href" ( getText + >>> + arr (\ x -> uriToString id (mkPageURI baseURI x) "") + >>> + mkText + ) + += this + ) + ) + ) + ) + ) + += ( eelem "div" + += sattr "class" "footer" + ) + += ( eelem "div" + += sattr "class" "left sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL leftSideBar + ) + ) + += ( eelem "div" + += sattr "class" "right sideBar" + += ( eelem "div" + += sattr "class" "content" + += constL rightSideBar + ) + ) + ) + >>> + uniqueNamespacesFromDeclAndQNames + ) ) -<< pageListing + + {- -} diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index a89a2af..9ab15be 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -11,6 +11,9 @@ module Rakka.Storage , putPageA , deletePageA + , getDirContents + , getDirContentsA + , searchPages , rebuildIndex @@ -73,6 +76,14 @@ deletePageA :: ArrowIO a => Storage -> a (Maybe String, PageName) StatusCode deletePageA = arrIO2 . deletePage +getDirContents :: MonadIO m => Storage -> PageName -> Maybe RevNum -> m [PageName] +getDirContents = ((liftIO .) .) . getDirContents' . stoRepository + + +getDirContentsA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) [PageName] +getDirContentsA = arrIO2 . getDirContents + + searchPages :: MonadIO m => Storage -> Condition -> m [(PageName, RevNum)] searchPages sto cond = liftIO $ diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 06b4036..c8efd4c 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -1,5 +1,6 @@ module Rakka.Storage.DefaultPage ( findAllDefaultPages + , getDefaultDirContents , loadDefaultPage ) where @@ -43,6 +44,32 @@ findAllDefaultPages return . S.fromList . map (decodePageName . makeRelative dirPath . dropExtension) +getDefaultDirContents :: PageName -> IO (Set PageName) +getDefaultDirContents dir + -- ./defaultPages が存在するなら、その中を探す。無ければ Cabal で + -- defaultPages を探す。 + = do localDirExists <- doesLocalDirExist + if localDirExists then + getDir' "defaultPages" + else + -- FIXME: この getDataFileName の使ひ方は undocumented + getDir' =<< getDataFileName "defaultPages" + where + getDir' :: FilePath -> IO (Set PageName) + getDir' dirPath + = getDirectoryContents (dirPath encodePageName dir) + >>= + return . S.fromList . map (m dirPath) . filter f + + m :: FilePath -> FilePath -> PageName + m dirPath = (dir ) . decodePageName . makeRelative dirPath . dropExtension + + f :: FilePath -> Bool + f "." = False + f ".." = False + f _ = True + + loadDefaultPage :: PageName -> IO (Maybe Page) loadDefaultPage name -- ./defaultPages が存在するなら、./defaultPages/Foo.xml を探す。無 diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index 2073155..1908b48 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -2,6 +2,7 @@ module Rakka.Storage.Impl ( getPage' , putPage' , deletePage' + , getDirContents' , startIndexManager ) where @@ -63,6 +64,13 @@ findChangedPages repos oldRev newRev return . S.unions +getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName] +getDirContents' repos name rev + = do reposPages <- getDirContentsInRevision repos name rev + defaultPages <- getDefaultDirContents name + return $ S.toList (reposPages `S.union` defaultPages) + + getCurrentRevNum :: Repository -> IO RevNum getCurrentRevNum repos = getRepositoryFS repos >>= getYoungestRev diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index e1f4b8e..01f64c7 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -1,5 +1,6 @@ module Rakka.Storage.Repos ( findAllPagesInRevision + , getDirContentsInRevision , findChangedPagesAtRevision , loadPageInRepository , putPageIntoRepository @@ -37,6 +38,11 @@ mkPagePath name = "/pages" encodePageName name <.> "page" +mkDirPath :: PageName -> FilePath +mkDirPath dir + = "/pages" encodePageName dir + + findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName) findAllPagesInRevision repos rev = do fs <- getRepositoryFS repos @@ -68,6 +74,29 @@ findAllPagesInRevision repos rev decodePath = decodePageName . makeRelative root . dropExtension +getDirContentsInRevision :: Repository -> PageName -> Maybe RevNum -> IO (Set PageName) +getDirContentsInRevision repos dir rev + = do fs <- getRepositoryFS repos + rev' <- case rev of + Nothing -> getYoungestRev fs + Just r -> return r + withRevision fs rev' + $ do exists <- isDirectory path + if exists then + return . S.fromList =<< getDir' + else + return S.empty + where + path :: FilePath + path = mkDirPath dir + + getDir' :: Rev [PageName] + getDir' = getDirEntries path >>= return . map entToName + + entToName :: DirEntry -> PageName + entToName = (dir ) . decodePageName . dropExtension . entName + + findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName) findChangedPagesAtRevision repos rev = do fs <- getRepositoryFS repos @@ -93,11 +122,10 @@ loadPageInRepository repos name rev Just r -> return r withRevision fs rev' $ do exists <- isFile path - case exists of - True - -> return . Just =<< loadPage' - False - -> return Nothing + if exists then + return . Just =<< loadPage' + else + return Nothing where path :: FilePath path = mkPagePath name diff --git a/js/editPage.js b/js/editPage.js index 4e5d255..5948d6d 100644 --- a/js/editPage.js +++ b/js/editPage.js @@ -15,24 +15,29 @@ url : Rakka.baseURI + pageName + ".xml", success: function (pageXml) { Rakka.hideWaitingMessage(); - - var $page = $(pageXml).find("page"); - var oldRevision = $page.attr("revision"); - var defaultType - = $page.attr("isBinary") == "yes" ? "binary" - : $page.attr("type") == "text/x-rakka" ? "rakka" - : $page.attr("type") == "text/css" ? "css" - : $page.attr("redirect") != null ? "redirect" - : "unknown" - ; - var isLocked = $page.attr("isLocked") == "yes"; - var source - = $page.attr("redirect") != null ? $page.attr("redirect") - : $page.find("textData").text() - ; - var summary = $page.find("summary").text(); + + if (pageXml.documentElement.tagName == "page") { + var $page = $(pageXml).find("page"); + var oldRevision = $page.attr("revision"); + var defaultType + = $page.attr("isBinary") == "yes" ? "binary" + : $page.attr("type") == "text/x-rakka" ? "rakka" + : $page.attr("type") == "text/css" ? "css" + : $page.attr("redirect") != null ? "redirect" + : "unknown" + ; + var isLocked = $page.attr("isLocked") == "yes"; + var source + = $page.attr("redirect") != null ? $page.attr("redirect") + : $page.find("textData").text() + ; + var summary = $page.find("summary").text(); - displayPageEditor(pageName, oldRevision, defaultType, isLocked, source, summary); + displayPageEditor(pageName, oldRevision, defaultType, isLocked, source, summary); + } + else { + displayPageEditor(pageName, null, "rakka", false, null, ""); + } }, error : function (req) { Rakka.hideWaitingMessage();