module Rakka.Storage.Repos ( findAllPagesInRevision , getDirContentsInRevision , findChangedPagesAtRevision , loadPageInRepository , putPageIntoRepository , deletePageFromRepository ) where import Codec.Binary.UTF8.String import Control.Exception import Control.Monad import Data.List import qualified Data.Map as M import Data.Maybe import Data.Set (Set) import qualified Data.Set as S hiding (Set) import Data.Time import Network.HTTP.Lucu hiding (redirect) import Rakka.Page import Rakka.SystemConfig import Rakka.Utils import Rakka.W3CDateTime import Subversion.Error 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" mkDirPath :: PageName -> FilePath mkDirPath dir = "/pages" encodePageName dir findAllPagesInRevision :: Repository -> RevNum -> IO (Set PageName) findAllPagesInRevision repos rev = do fs <- getRepositoryFS repos withRevision fs rev $ do exists <- isDirectory root if exists then traverse root else return S.empty where root :: FilePath root = "/pages" traverse :: FilePath -> Rev (Set PageName) traverse dir = getDirEntries dir >>= mapM (traverse' dir) >>= return . S.unions traverse' :: FilePath -> DirEntry -> Rev (Set PageName) traverse' dir entry = let path = dir entName entry in do kind <- checkPath path case kind of NoNode -> return S.empty FileNode -> return $ S.singleton (decodePath path) DirNode -> traverse path 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' = 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 withRevision fs rev $ getPathsChanged >>= return . foldl accumulatePages S.empty . map fst where accumulatePages :: Set PageName -> FilePath -> Set PageName accumulatePages s path | "/pages/" `isPrefixOf` path && ".page" `isSuffixOf` path = let encoded = makeRelative "/pages" $ dropExtension path name = decodePageName encoded in S.insert name s | otherwise = s loadPageInRepository :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page) loadPageInRepository repos name 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 =<< loadPage' else return Nothing where path :: FilePath path = mkPagePath name loadPage' :: Rev Page loadPage' = do mType <- liftM (fmap (read . chomp)) (getNodeProp path "svn:mime-type") case mType of Just (MIMEType "application" "x-rakka-redirection" _) -> loadPageRedirect _ -> loadPageEntity loadPageEntity :: Rev Page loadPageEntity = do props <- getNodePropList path hist <- getNodeHistory True path content <- getFileContentsLBS path let pageRev = fst $ head hist mimeType = read $ fromMaybe "text/x-rakka" $ fmap chomp (lookup "svn:mime-type" props) lastMod <- getRevisionProp "svn:date" >>= return . fromJust . parseW3CDateTime . chomp . fromJust return Entity { entityName = name , entityType = mimeType , entityLanguage = fmap chomp (lookup "rakka:lang" props) , entityIsTheme = any ((== "rakka:isTheme") . fst) props , entityIsFeed = any ((== "rakka:isFeed") . fst) props , entityIsLocked = any ((== "rakka:isLocked") . 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 = do hist <- getNodeHistory True path content <- getFileContents path let pageRev = fst $ head hist dest = chomp $ decodeString content lastMod <- getRevisionProp "svn:date" >>= return . fromJust . parseW3CDateTime . chomp . fromJust isLocked <- getRevisionProp "rakka:isLocked" >>= return . isJust 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 = filterSvnError $ do let name = pageName page author = fromMaybe "[Rakka]" userID case pageUpdateInfo page of Just ui -> do let oldRev = uiOldRevision ui denied <- case uiOldName ui of Nothing -> checkDenial oldRev name Just oldName -> checkDenial oldRev oldName if denied then return Forbidden else do ret <- doReposTxn repos (uiOldRevision ui) author (Just "Automatic commit by Rakka for page update") $ do case uiOldName ui of Nothing -> return () Just oldName -> renamePage (uiOldRevision ui) oldName 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") $ do createPage name updatePage name case ret of Left _ -> return Conflict Right _ -> return Created where checkDenial :: RevNum -> PageName -> IO Bool checkDenial rev name = do fs <- getRepositoryFS repos withRevision fs rev $ do prop <- getNodeProp (mkPagePath name) "rakka:isLocked" case prop of Just _ -> return (isNothing userID) -- 施錠されてゐるので匿名では駄目 Nothing -> return False renamePage :: RevNum -> PageName -> PageName -> Txn () renamePage oldRev oldName newName = do let oldPath = mkPagePath oldName newPath = mkPagePath 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 = 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 (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:isTheme" (encodeFlag $ entityIsTheme page) setNodeProp path "rakka:isFeed" (encodeFlag $ entityIsFeed page) setNodeProp path "rakka:isLocked" (encodeFlag $ entityIsLocked 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 "*" 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 = filterSvnError $ do let path = mkPagePath name fs <- getRepositoryFS repos rev <- getYoungestRev fs status <- withRevision fs rev $ do exists <- isFile path if exists then do prop <- getNodeProp path "rakka:isLocked" return $ case prop of Just _ -> if isNothing userID then -- 施錠されてゐるので匿名では駄目 Forbidden else NoContent Nothing -> NoContent else return NotFound when (status == NoContent) $ do doReposTxn repos rev "[Rakka]" (Just "Automatic commit by Rakka for page deleting") $ do deleteEntry path deleteEmptyParentDirectories path return () return status deleteEmptyParentDirectories :: FilePath -> Txn () deleteEmptyParentDirectories path = do let parentPath = takeDirectory path contents <- getDirEntries parentPath when (null contents) $ do deleteEntry parentPath deleteEmptyParentDirectories parentPath filterSvnError :: IO a -> IO a filterSvnError f = catchDyn f rethrow where rethrow :: SvnError -> IO a rethrow err = let code = svnErrCode err msg = svnErrMsg err in fail $ "SvnError: " ++ (show code) ++ ": " ++ msg