X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FRepos.hs;h=05759d9d4b70324307c1f236d0dc005084db692a;hb=HEAD;hp=81ab87611b68a51422aabb22e60fb7ea5fe30e83;hpb=b4a3d2cf3854b10d923cb4c546bf1fe32b021a68;p=Rakka.git diff --git a/Rakka/Storage/Repos.hs b/Rakka/Storage/Repos.hs index 81ab876..05759d9 100644 --- a/Rakka/Storage/Repos.hs +++ b/Rakka/Storage/Repos.hs @@ -1,36 +1,69 @@ +-- -*- coding: utf-8 -*- +{-# LANGUAGE + DoAndIfThenElse + , RecordWildCards + , ScopedTypeVariables + , UnicodeSyntax + #-} module Rakka.Storage.Repos ( findAllPagesInRevision + , getDirContentsInRevision , findChangedPagesAtRevision , loadPageInRepository , putPageIntoRepository + , deletePageFromRepository + , loadAttachmentInRepository + , putAttachmentIntoRepository ) where - +import Control.Applicative +import Codec.Binary.UTF8.String import Control.Monad +import Control.Monad.Unicode +import qualified Data.CaseInsensitive as CI import Data.List import qualified Data.Map as M import Data.Maybe +import Data.Monoid.Unicode import Data.Set (Set) import qualified Data.Set as S hiding (Set) +import qualified Data.Text as T import Data.Time +import qualified Data.Time.W3C as W3C import Network.HTTP.Lucu hiding (redirect) +import Prelude.Unicode +import Rakka.Attachment import Rakka.Page import Rakka.SystemConfig import Rakka.Utils -import Rakka.W3CDateTime -import Subversion.Types import Subversion.FileSystem import Subversion.FileSystem.DirEntry import Subversion.FileSystem.Revision import Subversion.FileSystem.Root import Subversion.FileSystem.Transaction import Subversion.Repository +import Subversion.Types import System.FilePath.Posix mkPagePath :: PageName -> FilePath mkPagePath name - = "pages" encodePageName name <.> "page" + = "/pages" encodePageName name <.> "page" + + +mkDirPath :: PageName -> FilePath +mkDirPath dir + = "/pages" encodePageName dir + + +mkAttachmentPath :: PageName -> String -> FilePath +mkAttachmentPath pName aName + = "/attachments" encodePageName pName <.> "page" aName + + +mkAttachmentDirPath :: PageName -> FilePath +mkAttachmentDirPath pName + = "/attachments" encodePageName pName <.> "page" findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName) @@ -48,7 +81,7 @@ findAllPagesInRevision repos rev traverse :: FilePath -> Rev (Set PageName) traverse dir - = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions + = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir)) traverse' :: FilePath -> DirEntry -> Rev (Set PageName) traverse' dir entry @@ -63,12 +96,33 @@ findAllPagesInRevision repos rev decodePath :: FilePath -> PageName 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' = liftM (map entToName) (getDirEntries path) + + entToName ∷ DirEntry → PageName + entToName = T.pack ∘ (T.unpack dir ) ∘ T.unpack ∘ decodePageName ∘ dropExtension ∘ entName findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName) findChangedPagesAtRevision repos rev = do fs <- getRepositoryFS repos withRevision fs rev - $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst + $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged where accumulatePages :: Set PageName -> FilePath -> Set PageName accumulatePages s path @@ -89,25 +143,25 @@ 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' fs + else + return Nothing where path :: FilePath path = mkPagePath name - loadPage' :: Rev Page - loadPage' = do redirect <- getNodeProp path "rakka:redirect" - case redirect of - Nothing - -> loadPageEntity - Just _ - -> loadPageRedirect + loadPage' :: FileSystem -> Rev Page + loadPage' fs + = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type") + case mType of + Just (MIMEType "application" "x-rakka-redirection" _) + -> loadPageRedirect fs + _ + -> loadPageEntity fs - loadPageEntity :: Rev Page - loadPageEntity + loadPageEntity :: FileSystem -> Rev Page + loadPageEntity fs = do props <- getNodePropList path hist <- getNodeHistory True path content <- getFileContentsLBS path @@ -117,18 +171,17 @@ loadPageInRepository repos name rev $ fromMaybe "text/x-rakka" $ fmap chomp (lookup "svn:mime-type" props) - lastMod <- getRevisionProp "svn:date" - >>= return . fromJust . parseW3CDateTime . chomp . fromJust + lastMod <- unsafeIOToFS $ + liftM (fromJust . W3C.parse . chomp . fromJust) + (getRevisionProp' fs pageRev "svn:date") return Entity { entityName = name , entityType = mimeType - , entityLanguage = fmap chomp (lookup "rakka:lang" props) - , entityFileName = fmap chomp (lookup "rakka:fileName" props) + , entityLanguage = CI.mk ∘ T.pack ∘ chomp <$> lookup "rakka:lang" 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 @@ -136,92 +189,275 @@ loadPageInRepository repos name rev -> 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 + , entitySummary = fmap decodeString (lookup "rakka:summary" props) + , entityOtherLang = maybe (∅) + (fromJust ∘ deserializeMap CI.mk id ∘ T.pack ∘ decodeString) + (lookup "rakka:otherLang" props) + , entityContent = content , entityUpdateInfo = undefined } - loadPageRedirect :: Rev Page - loadPageRedirect = fail "FIXME: loadPageRedirect: not implemented" + loadPageRedirect :: FileSystem -> Rev Page + loadPageRedirect fs + = do hist <- getNodeHistory True path + content <- getFileContents path + let pageRev = fst $ head hist + dest = T.pack ∘ chomp $ decodeString content -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 + lastMod <- unsafeIOToFS $ + liftM (fromJust . W3C.parse . chomp . fromJust) + (getRevisionProp' fs pageRev "svn:date") + + isLocked <- liftM isJust (getNodeProp path "rakka:isLocked") + + return Redirection { + redirName = name + , redirDest = dest + , redirIsLocked = isLocked + , redirRevision = pageRev + , redirLastMod = zonedTimeToUTC lastMod + , redirUpdateInfo = undefined + } + + +putPageIntoRepository ∷ Repository → Maybe String → Page → IO StatusCode +putPageIntoRepository repos userID page + = case pageUpdateInfo page of + Just ui + → do let oldRev = uiOldRevision ui + denied ← case uiOldName ui of + Nothing → shouldDeny oldRev name + Just oldName → shouldDeny oldRev oldName + if denied then + pure Forbidden + else + do rev ← if oldRev ≡ 0 then + getRepositoryFS repos ≫= getYoungestRev + else + return oldRev + ret ← doReposTxn repos + rev + author + (Just "Automatic commit by Rakka for page update") + $ do case uiOldName ui of + Nothing → return () + Just oldName → do exists ← isFile (mkPagePath oldName) + when exists + ( movePage (uiOldRevision ui) oldName name ≫ + moveAttachments (uiOldRevision ui) oldName name + ) + exists ← isFile (mkPagePath name) + unless exists + $ createPage name + updatePage name + case ret of + Left _ → return Conflict + Right _ → return Created + Nothing + → do fs ← getRepositoryFS repos + rev ← getYoungestRev fs + ret ← doReposTxn repos + rev + author + (Just "Automatic commit by Rakka for page creation") + $ (createPage 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 + name ∷ PageName + name = pageName page + + author ∷ String + author = fromMaybe "[Rakka]" userID + + shouldDeny ∷ RevNum → PageName → IO Bool + shouldDeny rev name' + = do fs ← getRepositoryFS repos + withRevision fs rev + $ do exists ← isFile (mkPagePath name') + if exists then + do prop ← getNodeProp (mkPagePath name') "rakka:isLocked" + case prop of + Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目 + Nothing -> return False + else + return False -- FIXME: 本當は defaultPage の locked 屬性をどうのこうの… + + movePage :: RevNum -> PageName -> PageName -> Txn () + movePage oldRev oldName newName + = do let oldPath = mkPagePath oldName + newPath = mkPagePath newName + createParentDirectories newPath + copyEntry oldRev oldPath newPath + deleteEntry oldPath + deleteEmptyParentDirectories oldPath + + moveAttachments :: RevNum -> PageName -> PageName -> Txn () + moveAttachments oldRev oldName newName + = do let oldPath = mkAttachmentDirPath oldName + newPath = mkAttachmentDirPath newName + createParentDirectories newPath + copyEntry oldRev oldPath newPath + deleteEntry oldPath + deleteEmptyParentDirectories oldPath + + createPage :: PageName -> Txn () + createPage name' + = do let path = mkPagePath name' + createParentDirectories path + makeFile path + + 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" + updatePageRedirect name' + = do let path = mkPagePath name' + setNodeProp path "svn:mime-type" (Just "application/x-rakka-redirection") + setNodeProp path "rakka:lang" Nothing + setNodeProp path "rakka:isTheme" Nothing + setNodeProp path "rakka:isFeed" Nothing + setNodeProp path "rakka:isLocked" (encodeFlag $ redirIsLocked page) + setNodeProp path "rakka:isBinary" Nothing + setNodeProp path "rakka:summary" Nothing + setNodeProp path "rakka:otherLang" Nothing + applyText path Nothing (encodeString (T.unpack $ redirDest page) ⊕ "\n") 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) + updatePageEntity name' + = do let path = mkPagePath name' + setNodeProp path "svn:mime-type" (Just ∘ show $ entityType page) + setNodeProp path "rakka:lang" (T.unpack ∘ CI.foldedCase <$> entityLanguage 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)) + setNodeProp path "rakka:summary" (encodeString <$> entitySummary page) + setNodeProp path "rakka:otherLang" ( if M.null (entityOtherLang page) then + Nothing + else + Just ∘ T.unpack ∘ serializeMap CI.foldedCase id + $ entityOtherLang page + ) applyTextLBS path Nothing (entityContent page) encodeFlag :: Bool -> Maybe String - encodeFlag True = Just "*\n" + encodeFlag True = Just "*" encodeFlag False = Nothing + + +createParentDirectories :: FilePath -> Txn () +createParentDirectories path + = do let parentPath = takeDirectory path + kind <- checkPath parentPath + case kind of + NoNode -> do createParentDirectories parentPath + makeDirectory parentPath + FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath) + DirNode -> return () + + +deletePageFromRepository :: Repository -> Maybe String -> PageName -> IO StatusCode +deletePageFromRepository repos userID name + = do let pagePath = mkPagePath name + attachmentPath = mkAttachmentDirPath name + fs <- getRepositoryFS repos + rev <- getYoungestRev fs + status <- withRevision fs rev + $ do exists <- isFile pagePath + if exists then + do prop <- getNodeProp pagePath "rakka:isLocked" + return $ case prop of + Just _ + -> if isNothing userID then + -- 施錠されてゐるので匿名では駄目 + Forbidden + else + NoContent + Nothing + -> NoContent + else + return NotFound + when (status == NoContent) + $ ( (doReposTxn repos + rev + "[Rakka]" + (Just "Automatic commit by Rakka for page deleting") + $ do deleteEntry pagePath + deleteEmptyParentDirectories pagePath + + attachmentExists <- isDirectory attachmentPath + when attachmentExists + $ do deleteEntry attachmentPath + deleteEmptyParentDirectories attachmentPath) + >> return () ) + return status + + +deleteEmptyParentDirectories :: FilePath -> Txn () +deleteEmptyParentDirectories path + = do let parentPath = takeDirectory path + contents <- getDirEntries parentPath + when (null contents) + $ do deleteEntry parentPath + deleteEmptyParentDirectories parentPath + + +loadAttachmentInRepository ∷ ∀α. Attachment α + ⇒ Repository + → PageName + → String + → Maybe RevNum + → IO (Maybe α) +loadAttachmentInRepository repos pName aName rev + = do fs <- getRepositoryFS repos + rev' <- case rev of + Nothing -> getYoungestRev fs + Just r -> return r + withRevision fs rev' + $ do exists <- isFile path + if exists then + return . Just =<< loadAttachment' + else + return Nothing + where + path ∷ FilePath + path = mkAttachmentPath pName aName + + loadAttachment' ∷ Rev α + loadAttachment' = (deserializeFromString ∘ decodeString) + `liftM` getFileContents path + +putAttachmentIntoRepository :: Attachment a => + Repository + -> Maybe String + -> Maybe RevNum + -> PageName + -> String + -> a + -> IO StatusCode +putAttachmentIntoRepository repos userID oldRev pName aName attachment + = do let author = fromMaybe "[Rakka]" userID + path = mkAttachmentPath pName aName + fs <- getRepositoryFS repos + oldRev' <- case oldRev of + Nothing -> getYoungestRev fs + Just r -> return r + ret <- doReposTxn + repos + oldRev' + author + (Just "Automatic commit by Rakka for putting attachment") + $ do exists <- isFile path + unless exists + $ do createParentDirectories path + makeFile path + applyText path Nothing (encodeString $ serializeToString attachment) + case ret of + Left _ -> return Conflict + Right _ -> return NoContent