From: pho Date: Sat, 15 Dec 2007 07:25:09 +0000 (+0900) Subject: partially implemented page updating X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=b4a3d2cf3854b10d923cb4c546bf1fe32b021a68 partially implemented page updating darcs-hash:20071215072509-62b54-1380af1226e8c111fac02b041535c749db702179.gz --- diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 50eb441..b293b1f 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -1,13 +1,20 @@ module Rakka.Page ( PageName , Page(..) + , UpdateInfo(..) , LanguageTag , LanguageName + , isRedirect + , isEntity + + , pageName + , pageUpdateInfo + , encodePageName , decodePageName - , pageFileName' + , entityFileName' , defaultFileName , mkPageURI @@ -53,30 +60,64 @@ type LanguageName = String -- i.e. "日本語" data Page = Redirection { - redirName :: !PageName - , redirDest :: !PageName - , redirRevision :: RevNum - , redirLastMod :: UTCTime + redirName :: !PageName + , redirDest :: !PageName + , redirRevision :: RevNum + , redirLastMod :: UTCTime + , redirUpdateInfo :: Maybe UpdateInfo } | Entity { - pageName :: !PageName - , pageType :: !MIMEType - , pageLanguage :: !(Maybe LanguageTag) - , pageFileName :: !(Maybe String) - , pageIsTheme :: !Bool -- text/css 以外では無意味 - , pageIsFeed :: !Bool -- text/x-rakka 以外では無意味 - , pageIsLocked :: !Bool - , pageIsBoring :: !Bool - , pageIsBinary :: !Bool - , pageRevision :: RevNum - , pageLastMod :: UTCTime - , pageSummary :: !(Maybe String) - , pageOtherLang :: !(Map LanguageTag PageName) - , pageContent :: !Lazy.ByteString + entityName :: !PageName + , entityType :: !MIMEType + , entityLanguage :: !(Maybe LanguageTag) + , entityFileName :: !(Maybe String) + , entityIsTheme :: !Bool -- text/css 以外では無意味 + , entityIsFeed :: !Bool -- text/x-rakka 以外では無意味 + , entityIsLocked :: !Bool + , entityIsBoring :: !Bool + , entityIsBinary :: !Bool + , entityRevision :: RevNum + , entityLastMod :: UTCTime + , entitySummary :: !(Maybe String) + , entityOtherLang :: !(Map LanguageTag PageName) + , entityContent :: !Lazy.ByteString + , entityUpdateInfo :: Maybe UpdateInfo + } + deriving (Show, Eq) + + +data UpdateInfo + = UpdateInfo { + uiOldRevision :: !RevNum + , uiOldName :: !(Maybe PageName) } deriving (Show, Eq) +isRedirect :: Page -> Bool +isRedirect (Redirection _ _ _ _ _) = True +isRedirect _ = False + + +isEntity :: Page -> Bool +isEntity (Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = True +isEntity _ = False + + +pageName :: Page -> PageName +pageName p + | isRedirect p = redirName p + | isEntity p = entityName p + | otherwise = fail "neither redirection nor entity" + + +pageUpdateInfo :: Page -> Maybe UpdateInfo +pageUpdateInfo p + | isRedirect p = redirUpdateInfo p + | isEntity p = entityUpdateInfo p + | otherwise = fail "neither redirection nor entity" + + -- UTF-8 に encode してから 0x20 - 0x7E の範圍を除いて URI escape する。 encodePageName :: PageName -> FilePath encodePageName = escapeURIString isSafeChar . encodeString . fixPageName @@ -102,9 +143,9 @@ encodeFragment :: String -> String encodeFragment = escapeURIString isSafeChar . encodeString -pageFileName' :: Page -> String -pageFileName' page - = fromMaybe (defaultFileName (pageType page) (pageName page)) (pageFileName page) +entityFileName' :: Page -> String +entityFileName' page + = fromMaybe (defaultFileName (entityType page) (entityName page)) (entityFileName page) defaultFileName :: MIMEType -> PageName -> String @@ -193,52 +234,52 @@ mkRakkaURI name = URI { xmlizePage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => a Page XmlTree xmlizePage = proc page - -> do lastMod <- arrIO (utcToLocalZonedTime . pageLastMod) -< page + -> do lastMod <- arrIO (utcToLocalZonedTime . entityLastMod) -< page ( eelem "/" += ( eelem "page" += sattr "name" (pageName page) - += sattr "type" (show $ pageType page) - += ( case pageLanguage page of + += sattr "type" (show $ entityType page) + += ( case entityLanguage page of Just x -> sattr "lang" x Nothing -> none ) - += ( case pageFileName page of + += ( case entityFileName page of Just x -> sattr "fileName" x Nothing -> none ) - += ( case pageType page of + += ( case entityType page of MIMEType "text" "css" _ - -> sattr "isTheme" (yesOrNo $ pageIsTheme page) + -> sattr "isTheme" (yesOrNo $ entityIsTheme page) MIMEType "text" "x-rakka" _ - -> sattr "isFeed" (yesOrNo $ pageIsFeed page) + -> sattr "isFeed" (yesOrNo $ entityIsFeed page) _ -> none ) - += sattr "isLocked" (yesOrNo $ pageIsLocked page) - += sattr "isBoring" (yesOrNo $ pageIsBoring page) - += sattr "isBinary" (yesOrNo $ pageIsBinary page) - += sattr "revision" (show $ pageRevision page) + += sattr "isLocked" (yesOrNo $ entityIsLocked page) + += sattr "isBoring" (yesOrNo $ entityIsBoring page) + += sattr "isBinary" (yesOrNo $ entityIsBinary page) + += sattr "revision" (show $ entityRevision page) += sattr "lastModified" (formatW3CDateTime lastMod) - += ( case pageSummary page of + += ( case entitySummary page of Just s -> eelem "summary" += txt s Nothing -> none ) - += ( if M.null (pageOtherLang page) then + += ( if M.null (entityOtherLang page) then none else selem "otherLang" [ eelem "link" += sattr "lang" lang += sattr "page" name - | (lang, name) <- M.toList (pageOtherLang page) ] + | (lang, name) <- M.toList (entityOtherLang page) ] ) - += ( if pageIsBinary page then + += ( if entityIsBinary page then ( eelem "binaryData" - += txt (B64.encode $ L.unpack $ pageContent page) + += txt (B64.encode $ L.unpack $ entityContent page) ) else ( eelem "textData" - += txt (decode $ L.unpack $ pageContent page) + += txt (decode $ L.unpack $ entityContent page) ) ) )) -<< () @@ -247,21 +288,25 @@ xmlizePage parseXmlizedPage :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page parseXmlizedPage = proc (name, tree) - -> do redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree + -> do updateInfo <- maybeA parseUpdateInfo -< tree + redirect <- maybeA (getXPathTreesInDoc "/page/@redirect/text()" >>> getText) -< tree case redirect of Nothing -> parseEntity -< (name, tree) Just dest -> returnA -< (Redirection { - redirName = name - , redirDest = dest - , redirRevision = undefined - , redirLastMod = undefined + redirName = name + , redirDest = dest + , redirRevision = undefined + , redirLastMod = undefined + , redirUpdateInfo = updateInfo }) parseEntity :: (ArrowXml a, ArrowChoice a) => a (PageName, XmlTree) Page parseEntity = proc (name, tree) - -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText + -> do updateInfo <- maybeA parseUpdateInfo -< tree + + mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read) -< tree lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree @@ -296,18 +341,33 @@ parseEntity _ -> error "one of textData or binaryData is required" returnA -< Entity { - pageName = name - , pageType = mimeType - , pageLanguage = lang - , pageFileName = fileName - , pageIsTheme = isTheme - , pageIsFeed = isFeed - , pageIsLocked = isLocked - , pageIsBoring = isBoring - , pageIsBinary = isBinary - , pageRevision = undefined - , pageLastMod = undefined - , pageSummary = summary - , pageOtherLang = M.fromList otherLang - , pageContent = content + entityName = name + , entityType = mimeType + , entityLanguage = lang + , entityFileName = fileName + , entityIsTheme = isTheme + , entityIsFeed = isFeed + , entityIsLocked = isLocked + , entityIsBoring = isBoring + , entityIsBinary = isBinary + , entityRevision = undefined + , entityLastMod = undefined + , entitySummary = summary + , entityOtherLang = M.fromList otherLang + , entityContent = content + , entityUpdateInfo = updateInfo } + + +parseUpdateInfo :: (ArrowXml a, ArrowChoice a) => a XmlTree UpdateInfo +parseUpdateInfo + = proc tree + -> do uInfo <- getXPathTreesInDoc "/*/updateInfo" -< tree + oldRev <- (getAttrValue0 "oldRevision" >>> arr read) -< uInfo + oldName <- maybeA (getXPathTrees "/move/@from/text()" >>> getText) -< uInfo + returnA -< UpdateInfo { + uiOldRevision = oldRev + , uiOldName = oldName + } + + \ No newline at end of file diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index cd2c364..00ebc28 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -37,10 +37,10 @@ handleGet env name Nothing -> foundNoEntity Nothing - Just redir@(Redirection _ _ _ _) + Just redir@(Redirection _ _ _ _ _) -> handleRedirect env redir - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) -> handleGetEntity entity @@ -62,11 +62,11 @@ handleRedirect env redir -} handleGetEntity :: Page -> Resource () handleGetEntity page - = do case pageRevision page of - 0 -> foundTimeStamp (pageLastMod page) -- 0 はデフォルトページ - rev -> foundEntity (strongETag $ show rev) (pageLastMod page) + = do case entityRevision page of + 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ + rev -> foundEntity (strongETag $ show rev) (entityLastMod page) - setContentType (pageType page) + setContentType (entityType page) setHeader (C8.pack "Content-Disposition") - (C8.pack $ "attachment; filename=" ++ quoteStr (pageFileName' page)) - outputLBS (pageContent page) + (C8.pack $ "attachment; filename=" ++ quoteStr (entityFileName' page)) + outputLBS (entityContent page) diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 4515a4d..37c2aa8 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -52,10 +52,10 @@ handleGet env name Nothing -> handlePageNotFound env -< name - Just redir@(Redirection _ _ _ _) + Just redir@(Redirection _ _ _ _ _) -> handleRedirect env -< redir - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _) + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) -> handleGetEntity env -< entity {- @@ -76,12 +76,12 @@ handleGetEntity env returnA -< do -- text/x-rakka の場合は、内容が動的に生成され -- てゐる可能性があるので、ETag も -- Last-Modified も返す事が出來ない。 - case pageType page of + case entityType page of MIMEType "text" "x-rakka" _ -> return () - _ -> case pageRevision page of - 0 -> foundTimeStamp (pageLastMod page) -- 0 はデフォルトページ - rev -> foundEntity (strongETag $ show rev) (pageLastMod page) + _ -> case entityRevision page of + 0 -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ + rev -> foundEntity (strongETag $ show rev) (entityLastMod page) outputXmlPage tree (entityToXHTML env) @@ -271,4 +271,6 @@ notFoundToXHTML env handlePut :: Environment -> PageName -> Resource () handlePut env name = runXmlA env "rakka-page-1.0.rng" $ proc tree - -> returnA -< do setStatus Created + -> do page <- parseXmlizedPage -< (name, tree) + status <- putPageA (envStorage env) -< page + returnA -< setStatus status diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 55037f0..63480de 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -20,6 +20,7 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans import Data.Maybe +import Network.HTTP.Lucu import Rakka.Page import Rakka.Storage.Impl import Rakka.Storage.Types @@ -44,17 +45,19 @@ getPage :: MonadIO m => Storage -> PageName -> Maybe RevNum -> m (Maybe Page) getPage = ((liftIO .) .) . getPage' . stoRepository -putPage :: MonadIO m => Storage -> Page -> RevNum -> m () -putPage sto page oldRev - = error "FIXME: not implemented" +putPage :: MonadIO m => Storage -> Page -> m StatusCode +putPage sto page + = liftIO $ do st <- putPage' (stoRepository sto) page + syncIndex sto + return st getPageA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) (Maybe Page) getPageA = arrIO2 . getPage -putPageA :: ArrowIO a => Storage -> a (Page, RevNum) () -putPageA = arrIO2 . putPage +putPageA :: ArrowIO a => Storage -> a Page StatusCode +putPageA = arrIO . putPage searchPages :: MonadIO m => Storage -> Condition -> m [(PageName, RevNum)] diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 2cc02c3..bba2279 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -89,14 +89,14 @@ loadPageFileA page <- parseXmlizedPage -< (name, tree) case page of - Redirection _ _ _ _ + Redirection _ _ _ _ _ -> returnA -< page { redirRevision = 0 , redirLastMod = lastMod } - Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ + Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> returnA -< page { - pageRevision = 0 - , pageLastMod = lastMod + entityRevision = 0 + , entityLastMod = lastMod } diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index 20208bf..515667a 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -1,5 +1,6 @@ module Rakka.Storage.Impl ( getPage' + , putPage' , startIndexManager ) where @@ -11,6 +12,7 @@ import Control.Monad import Data.Maybe import Data.Set (Set) import qualified Data.Set as S +import Network.HTTP.Lucu import Network.URI import Rakka.Page import Rakka.Storage.DefaultPage @@ -41,6 +43,10 @@ getPage' repos name rev p -> return p +putPage' :: Repository -> Page -> IO StatusCode +putPage' = putPageIntoRepository + + findAllPages :: Repository -> RevNum -> IO (Set PageName) findAllPages _ 0 = findAllDefaultPages findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev @@ -172,7 +178,7 @@ updateIndex index repos mkDraft rev name Just page -> do draft <- mkDraft page putDocument index draft [CleaningPut] - infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page)) + infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (entityRevision page)) updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO () diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index 55117ab..81ab876 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -2,6 +2,7 @@ module Rakka.Storage.Repos ( findAllPagesInRevision , findChangedPagesAtRevision , loadPageInRepository + , putPageIntoRepository ) where @@ -22,10 +23,16 @@ import Subversion.FileSystem import Subversion.FileSystem.DirEntry import Subversion.FileSystem.Revision import Subversion.FileSystem.Root +import Subversion.FileSystem.Transaction import Subversion.Repository import System.FilePath.Posix +mkPagePath :: PageName -> FilePath +mkPagePath name + = "pages" encodePageName name <.> "page" + + findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName) findAllPagesInRevision repos rev = do fs <- getRepositoryFS repos @@ -89,7 +96,7 @@ loadPageInRepository repos name rev -> return Nothing where path :: FilePath - path = "pages" encodePageName name <.> "page" + path = mkPagePath name loadPage' :: Rev Page loadPage' = do redirect <- getNodeProp path "rakka:redirect" @@ -114,28 +121,107 @@ loadPageInRepository repos name rev >>= return . fromJust . parseW3CDateTime . chomp . fromJust return Entity { - pageName = name - , pageType = mimeType - , pageLanguage = fmap chomp (lookup "rakka:lang" props) - , pageFileName = fmap chomp (lookup "rakka:fileName" props) - , pageIsTheme = any ((== "rakka:isTheme") . fst) props - , pageIsFeed = any ((== "rakka:isFeed") . fst) props - , pageIsLocked = any ((== "rakka:isLocked") . fst) props - , pageIsBoring = any ((== "rakka:isBoring") . fst) props - , pageIsBinary = case mimeType of - MIMEType "text" _ _ - -> any ((== "rakka:isBinary") . fst) props - _ - -> True - , pageRevision = pageRev - , pageLastMod = zonedTimeToUTC lastMod - , pageSummary = lookup "rakka:summary" props - , pageOtherLang = fromMaybe M.empty - $ fmap - (M.fromList . fromJust . deserializeStringPairs) - (lookup "rakka:otherLang" props) - , pageContent = content + entityName = name + , entityType = mimeType + , entityLanguage = fmap chomp (lookup "rakka:lang" props) + , entityFileName = fmap chomp (lookup "rakka:fileName" props) + , entityIsTheme = any ((== "rakka:isTheme") . fst) props + , entityIsFeed = any ((== "rakka:isFeed") . fst) props + , entityIsLocked = any ((== "rakka:isLocked") . fst) props + , entityIsBoring = any ((== "rakka:isBoring") . fst) props + , entityIsBinary = case mimeType of + MIMEType "text" _ _ + -> any ((== "rakka:isBinary") . fst) props + _ + -> True + , entityRevision = pageRev + , entityLastMod = zonedTimeToUTC lastMod + , entitySummary = lookup "rakka:summary" props + , entityOtherLang = fromMaybe M.empty + $ fmap + (M.fromList . fromJust . deserializeStringPairs) + (lookup "rakka:otherLang" props) + , entityContent = content + , entityUpdateInfo = undefined } loadPageRedirect :: Rev Page loadPageRedirect = fail "FIXME: loadPageRedirect: not implemented" + + +putPageIntoRepository :: Repository -> Page -> IO StatusCode +putPageIntoRepository repos page + = do let Just ui = pageUpdateInfo page + name = pageName page + ret <- doReposTxn + repos + (uiOldRevision ui) + "[Rakka]" + (Just "Automatic commit by Rakka for page updating") + $ do case uiOldName ui of + Nothing -> return () + Just oldName -> renamePage oldName name + createPageIfNeeded name + updatePage name + case ret of + Left _ -> + return Conflict + Right _ -> + return Created + where + renamePage :: PageName -> PageName -> Txn () + renamePage oldName newName + = fail "FIXME: renamePage: not implemented yet" + + createPageIfNeeded :: PageName -> Txn () + createPageIfNeeded name + = do let path = mkPagePath name + kind <- checkPath path + case kind of + NoNode -> do createParentDirectories path + makeFile path + FileNode -> return () + DirNode -> fail ("createPageIfNeeded: already exists a directory: " ++ path) + + createParentDirectories :: FilePath -> Txn () + createParentDirectories path + = do let parentPath = takeDirectory path + kind <- checkPath parentPath + case kind of + NoNode -> createParentDirectories parentPath + FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath) + DirNode -> return () + + updatePage :: PageName -> Txn () + updatePage name + | isRedirect page = updatePageRedirect name + | isEntity page = updatePageEntity name + | otherwise = fail "neither redirection nor page" + + updatePageRedirect :: PageName -> Txn () + updatePageRedirect name + = fail "FIXME: updatePageRedirect: not implemented yet" + + updatePageEntity :: PageName -> Txn () + updatePageEntity name + = do let path = mkPagePath name + setNodeProp path "svn:mime-type" ((Just . show . entityType) page) + setNodeProp path "rakka:lang" (entityLanguage page) + setNodeProp path "rakka:fileName" (entityFileName page) + setNodeProp path "rakka:isTheme" (encodeFlag $ entityIsTheme page) + setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page) + setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked page) + setNodeProp path "rakka:isBoring" (encodeFlag $ entityIsBoring page) + setNodeProp path "rakka:isBinary" (encodeFlag $ entityIsBinary page) + setNodeProp path "rakka:summary" (entitySummary page) + setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page + in + if M.null otherLang then + Nothing + else + Just (serializeStringPairs $ M.toList otherLang)) + applyTextLBS path Nothing (entityContent page) + + encodeFlag :: Bool -> Maybe String + encodeFlag True = Just "*\n" + encodeFlag False = Nothing diff --git a/Rakka/Wiki/Interpreter/PageList.hs b/Rakka/Wiki/Interpreter/PageList.hs index 234ce7d..1b433b8 100644 --- a/Rakka/Wiki/Interpreter/PageList.hs +++ b/Rakka/Wiki/Interpreter/PageList.hs @@ -61,7 +61,7 @@ recentUpdatesInterp mkListItem :: Page -> IO ListItem mkListItem page - = do lastMod <- utcToLocalZonedTime (pageLastMod page) + = do lastMod <- utcToLocalZonedTime (entityLastMod page) return ( [ Inline ( PageLink { linkPage = Just (pageName page) , linkFragment = Nothing @@ -73,7 +73,7 @@ recentUpdatesInterp ) ] ++ - case pageSummary page of + case entitySummary page of Just s -> [ Block (Paragraph [Text s]) ] Nothing -> [] )