module Rakka.Storage.Repos ( findAllPagesInRevision , getDirContentsInRevision , findChangedPagesAtRevision , loadPageInRepository , putPageIntoRepository , deletePageFromRepository , loadAttachmentInRepository , putAttachmentIntoRepository ) where import Codec.Binary.UTF8.String 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.Attachment import Rakka.Page import Rakka.SystemConfig import Rakka.Utils import Rakka.W3CDateTime 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 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) 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 = liftM S.unions (getDirEntries dir >>= mapM (traverse' dir)) 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' = liftM (map entToName) (getDirEntries path) entToName :: DirEntry -> PageName entToName = (dir ) . decodePageName . dropExtension . entName findChangedPagesAtRevision :: Repository -> RevNum -> IO (Set PageName) findChangedPagesAtRevision repos rev = do fs <- getRepositoryFS repos withRevision fs rev $ liftM (foldl accumulatePages S.empty . map fst) getPathsChanged 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' fs else return Nothing where path :: FilePath path = mkPagePath name 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 :: FileSystem -> Rev Page loadPageEntity fs = 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 <- unsafeIOToFS $ liftM (fromJust . parseW3CDateTime . chomp . fromJust) (getRevisionProp' fs pageRev "svn:date") 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 = fmap decodeString (lookup "rakka:summary" props) , entityOtherLang = fromMaybe M.empty $ fmap (M.fromList . fromJust . deserializeStringPairs . decodeString) (lookup "rakka:otherLang" props) , entityContent = content , entityUpdateInfo = undefined } loadPageRedirect :: FileSystem -> Rev Page loadPageRedirect fs = do hist <- getNodeHistory True path content <- getFileContents path let pageRev = fst $ head hist dest = chomp $ decodeString content lastMod <- unsafeIOToFS $ liftM (fromJust . parseW3CDateTime . 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 = 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 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 $ do 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") $ 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 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 = 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" (fmap encodeString $ entitySummary page) setNodeProp path "rakka:otherLang" (let otherLang = entityOtherLang page in if M.null otherLang then Nothing else Just (encodeString $ 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 = 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) $ do 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 :: forall a. Attachment a => Repository -> PageName -> String -> Maybe RevNum -> IO (Maybe a) 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 a loadAttachment' = liftM (deserializeFromString . decodeString) (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 (serializeToString attachment) case ret of Left _ -> return Conflict Right _ -> return NoContent