X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage.hs;h=d26f713d8f88140a361c13ea98d1e95ba9d38131;hb=e85b652169f502cffe1f6f7f927d8990e9c11499;hp=6b0e098e883eedad9908154edea5205308912e38;hpb=602cb8599101da778f6cbb043451cfa458dff89c;p=Rakka.git diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 6b0e098..d26f713 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -5,62 +5,47 @@ module Rakka.Storage , getPage , putPage + , deletePage , getPageA , putPageA + , deletePageA + + , getAttachment + , putAttachment + + , getDirContents + , getDirContentsA + + , searchPages + + , rebuildIndex ) where import Control.Arrow.ArrowIO import Control.Concurrent.STM -import Control.Exception import Control.Monad import Control.Monad.Trans -import Data.Set (Set) -import qualified Data.Set as S +import Data.Maybe +import Network.HTTP.Lucu +import Rakka.Attachment import Rakka.Page -import Rakka.Storage.DefaultPage +import Rakka.Storage.Impl +import Rakka.Storage.Types import Subversion.Types -import System.Directory -import System.FilePath import System.IO -import System.Log.Logger -import System.Posix.Files -import System.Posix.Types -import System.Posix.IO -import Subversion.FileSystem import Subversion.Repository import Text.HyperEstraier hiding (WriteLock) -logger = "Rakka.Storage" - - -data Storage - = Storage { - stoIndexRevLocked :: !(TVar Bool) - , stoIndexRevFile :: !FilePath - , stoIndexDB :: !Database - , stoRepository :: !Repository - , stoMakeDraft :: !(Page -> IO Document) - } - mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage mkStorage lsdir repos mkDraft - = do let indexDir = lsdir "index" - revFile = lsdir "indexRev" - - revLocked <- newTVarIO False - indexDB <- openIndex indexDir revFile - + = do chan <- startIndexManager lsdir repos mkDraft let sto = Storage { - stoIndexRevLocked = revLocked - , stoIndexRevFile = revFile - , stoIndexDB = indexDB - , stoRepository = repos - , stoMakeDraft = mkDraft + stoRepository = repos + , stoIndexChan = chan } - syncIndex sto return sto @@ -69,141 +54,73 @@ getPage :: MonadIO m => Storage -> PageName -> Maybe RevNum -> m (Maybe Page) getPage = ((liftIO .) .) . getPage' . stoRepository -getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page) -getPage' repos name rev - = loadDefaultPage name -- FIXME +putPage :: MonadIO m => Storage -> Maybe String -> Page -> m StatusCode +putPage sto userID page + = liftIO $ do st <- putPage' (stoRepository sto) userID page + syncIndex sto + return st -putPage :: MonadIO m => Storage -> Page -> RevNum -> m () -putPage sto page oldRev - = error "FIXME: not implemented" +deletePage :: MonadIO m => Storage -> Maybe String -> PageName -> m StatusCode +deletePage sto userID name + = liftIO $ do st <- deletePage' (stoRepository sto) userID name + 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 :: ArrowIO a => Storage -> a (Maybe String, Page) StatusCode putPageA = arrIO2 . putPage -findAllPages :: Storage -> RevNum -> IO (Set PageName) -findAllPages _ 0 = findAllDefaultPages -findAllPages sto rev - = findAllDefaultPages -- FIXME - - -findChangedPages :: Storage -> RevNum -> RevNum -> IO (Set PageName) -findChangedPages sto 0 newRev = findAllPages sto newRev -findChangedPages sto oldRev newRev - = fail "FIXME: not impl" +deletePageA :: ArrowIO a => Storage -> a (Maybe String, PageName) StatusCode +deletePageA = arrIO2 . deletePage -getCurrentRevNum :: Storage -> IO RevNum -getCurrentRevNum sto - = getRepositoryFS (stoRepository sto) >>= getYoungestRev +getDirContents :: MonadIO m => Storage -> PageName -> Maybe RevNum -> m [PageName] +getDirContents = ((liftIO .) .) . getDirContents' . stoRepository --- casket を R/W モードで開く。成功したらそのまま返し、失敗したら --- indexDir と revFile を削除してから casket を R/W モードで開く。 -openIndex :: FilePath -> FilePath -> IO Database -openIndex indexDir revFile - = do ret <- openDatabase indexDir (Writer []) - case ret of - Right db - -> do debugM logger ("Opened an H.E. database on " ++ indexDir) - return db +getDirContentsA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) [PageName] +getDirContentsA = arrIO2 . getDirContents - Left err - -> do warningM logger ("Failed to open an H.E. database on " - ++ indexDir ++ ": " ++ show err) - indexExists <- doesDirectoryExist indexDir - when indexExists - $ removeDirectoryRecursive indexDir +searchPages :: MonadIO m => Storage -> Condition -> m [(PageName, RevNum)] +searchPages sto cond + = liftIO $ + do var <- newEmptyTMVarIO + atomically $ writeTChan (stoIndexChan sto) (SearchIndex cond var) + atomically $ takeTMVar var - revFileExists <- doesFileExist revFile - when revFileExists - $ removeFile revFile - Right db <- openDatabase indexDir (Writer [Create []]) - noticeM logger ("Created an H.E. database on " ++ indexDir) - - return db +rebuildIndex :: MonadIO m => Storage -> m () +rebuildIndex sto + = liftIO $ atomically $ writeTChan (stoIndexChan sto) RebuildIndex syncIndex :: Storage -> IO () syncIndex sto - = updateIndexRev sto $ \ oldRev -> - do debugM logger ("The index revision is currently " ++ show oldRev) - - newRev <- getCurrentRevNum sto - debugM logger ("The repository revision is currently " ++ show newRev) - - when (newRev /= oldRev) (syncIndex' oldRev newRev) - return newRev - where - syncIndex' :: RevNum -> RevNum -> IO () - syncIndex' oldRev newRev - = do pages <- findChangedPages sto oldRev newRev - mapM_ (updateIndex sto newRev) (S.toList pages) - - -updateIndex :: Storage -> RevNum -> PageName -> IO () -updateIndex sto rev name - = do pageM <- getPage sto name (Just rev) - case pageM of - -- ページが削除された - Nothing - -> do docIdM <- getDocIdByURI (stoIndexDB sto) (mkRakkaURI name) - case docIdM of - Nothing -> return () - Just docId -> do removeDocument (stoIndexDB sto) docId [CleaningRemove] - infoM logger ("Removed page " ++ name ++ " from the index") - Just page - -> do draft <- stoMakeDraft sto page - putDocument (stoIndexDB sto) draft [CleaningPut] - infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page)) - - -updateIndexRev :: Storage -> (RevNum -> IO RevNum) -> IO () -updateIndexRev sto f = bracket acquireLock releaseLock update - where - acquireLock :: IO Fd - acquireLock - = do atomically $ do revLocked <- readTVar (stoIndexRevLocked sto) - if revLocked then - retry - else - writeTVar (stoIndexRevLocked sto) True - fd <- openFd (stoIndexRevFile sto) ReadWrite (Just stdFileMode) defaultFileFlags - waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0) - return fd - - releaseLock :: Fd -> IO () - releaseLock fd - = do setLock fd (Unlock, AbsoluteSeek, 0, 0) - atomically $ writeTVar (stoIndexRevLocked sto) False - - update :: Fd -> IO () - update fd - = do fdSeek fd AbsoluteSeek 0 - size <- return . fromIntegral . fileSize =<< getFdStatus fd - (revStr, gotSize) <- fdRead fd size - when (size /= gotSize) $ fail ("read " ++ show gotSize ++ - " bytes but expected " ++ show size ++ " bytes") - - let rev = case revStr of - "" -> 0 - _ -> read revStr - - rev' <- f rev - - let revStr' = show rev' ++ "\n" - size' = fromIntegral $ length revStr' - - fdSeek fd AbsoluteSeek 0 - setFdSize fd 0 - wroteSize <- fdWrite fd revStr' - when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++ - " bytes but expected " ++ show size' ++ " bytes") \ No newline at end of file + = atomically $ writeTChan (stoIndexChan sto) SyncIndex + + +getAttachment :: (Attachment a, MonadIO m) => + Storage + -> PageName + -> String + -> Maybe RevNum + -> m (Maybe a) +getAttachment = (((liftIO .) .) .) . getAttachment' . stoRepository + + +putAttachment :: (Attachment a, MonadIO m) => + Storage + -> Maybe String + -> Maybe RevNum + -> PageName + -> String + -> a + -> m StatusCode +putAttachment = (((((liftIO .) .) .) .) .) . putAttachment' . stoRepository