X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage.hs;h=d67380855316e2bd655daf72c7161af8d57ae48d;hb=HEAD;hp=83bb07795c2a5230230403d4df910663af51975d;hpb=ddf0b4d7ab2f1e141edbc7ef75d39853c0846f8c;p=Rakka.git diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 83bb077..d673808 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -1,188 +1,128 @@ module Rakka.Storage ( Storage + -- re-export from Rakka.Storage.Types + , SearchResult(..) + , HitPage(..) + , SnippetFragment(..) + , mkStorage -- private , 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 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 -getPage :: MonadIO m => Storage -> PageName -> m (Maybe Page) -getPage sto name - = liftIO $ loadDefaultPage name -- FIXME +getPage :: MonadIO m => Storage -> PageName -> Maybe RevNum -> m (Maybe Page) +getPage = ((liftIO .) .) . getPage' . stoRepository -putPage :: MonadIO m => Storage -> Maybe RevNum -> Page -> m () -putPage sto oldRev page - = error "FIXME: not implemented" +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 -getPageA :: ArrowIO a => Storage -> a PageName (Maybe Page) -getPageA = arrIO . getPage +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 -putPageA :: ArrowIO a => Storage -> a (Maybe RevNum, Page) () -putPageA = arrIO2 . putPage - +getPageA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) (Maybe Page) +getPageA = arrIO2 . getPage -findAllPages :: Storage -> RevNum -> IO (Set PageName) -findAllPages sto revNum - = findAllDefaultPages -- FIXME +putPageA :: ArrowIO a => Storage -> a (Maybe String, Page) StatusCode +putPageA = arrIO2 . putPage -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 - Left err - -> do warningM logger ("Failed to open an H.E. database on " - ++ indexDir ++ ": " ++ show err) +getDirContentsA :: ArrowIO a => Storage -> a (PageName, Maybe RevNum) [PageName] +getDirContentsA = arrIO2 . getDirContents - indexExists <- doesDirectoryExist indexDir - when indexExists - $ removeDirectoryRecursive indexDir - revFileExists <- doesFileExist revFile - when revFileExists - $ removeFile revFile +searchPages :: MonadIO m => Storage -> Condition -> m SearchResult +searchPages sto cond + = liftIO $ + do var <- newEmptyTMVarIO + atomically $ writeTChan (stoIndexChan sto) (SearchIndex cond var) + atomically $ takeTMVar var - 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 oldRev -- FIXME - --return newRev - where - syncIndex' :: RevNum -> RevNum -> IO () - syncIndex' oldRev newRev - = do pages <- findChangedPages sto oldRev newRev - print pages -- FIXME - - -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