X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FImpl.hs;h=79108927435d271904e66172aa2b8944ae4f0c76;hb=f57c5c5ae6c95e68b11400718e7ce5de4ea1317a;hp=dd8b7c4c504f8ad40195334b8dbd3caa7eec86bb;hpb=126e9f3faff19add1fb3dea792ec10dc57c30f03;p=Rakka.git diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index dd8b7c4..7910892 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -1,50 +1,74 @@ module Rakka.Storage.Impl ( getPage' + , putPage' + , deletePage' + , getDirContents' , startIndexManager ) where import Control.Concurrent import Control.Concurrent.STM -import Control.Exception import Control.Monad import Data.Maybe import Data.Set (Set) import qualified Data.Set as S +import Network.HTTP.Lucu import Network.URI import Rakka.Page import Rakka.Storage.DefaultPage +import Rakka.Storage.Repos import Rakka.Storage.Types import Subversion.Types +import Subversion.FileSystem +import Subversion.Repository 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 :: String logger = "Rakka.Storage" getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page) getPage' repos name rev - = loadDefaultPage name -- FIXME + = do page <- loadPageInRepository repos name rev + case page of + Nothing -> loadDefaultPage name + p -> return p + + +putPage' :: Repository -> Maybe String -> Page -> IO StatusCode +putPage' = putPageIntoRepository + + +deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode +deletePage' = deletePageFromRepository findAllPages :: Repository -> RevNum -> IO (Set PageName) findAllPages _ 0 = findAllDefaultPages -findAllPages repos rev - = findAllDefaultPages -- FIXME +findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev + defaultPages <- findAllDefaultPages + return (reposPages `S.union` defaultPages) findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName) findChangedPages repos 0 newRev = findAllPages repos newRev findChangedPages repos oldRev newRev - = fail "FIXME: not impl" + = mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev] + >>= + return . S.unions + + +getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName] +getDirContents' repos name rev + = do reposPages <- getDirContentsInRevision repos name rev + defaultPages <- getDefaultDirContents name + return $ S.toList (reposPages `S.union` defaultPages) getCurrentRevNum :: Repository -> IO RevNum @@ -66,12 +90,22 @@ startIndexManager lsdir repos mkDraft loop chan index = do req <- atomically $ readTChan chan case req of + RebuildIndex + -> do noticeM logger "Rebuilding the H.E. index..." + closeDatabase index + removeDirectoryRecursive indexDir + index' <- openIndex indexDir revFile + syncIndex' index' revFile repos mkDraft + loop chan index' + SyncIndex - -> syncIndex' index revFile repos mkDraft + -> do syncIndex' index revFile repos mkDraft + loop chan index + SearchIndex cond var -> do result <- searchIndex index cond atomically $ putTMVar var result - loop chan index + loop chan index -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら @@ -85,8 +119,8 @@ openIndex indexDir revFile return index Left err - -> do warningM logger ("Failed to open an H.E. index on " - ++ indexDir ++ ": " ++ show err) + -> do noticeM logger ("Failed to open an H.E. index on " + ++ indexDir ++ ": " ++ show err) indexExists <- doesDirectoryExist indexDir when indexExists @@ -97,8 +131,11 @@ openIndex indexDir revFile $ removeFile revFile Right index <- openDatabase indexDir (Writer [Create []]) + addAttrIndex index "@type" StrIndex addAttrIndex index "@uri" SeqIndex addAttrIndex index "rakka:revision" SeqIndex + addAttrIndex index "rakka:isTheme" StrIndex + addAttrIndex index "rakka:isFeed" StrIndex noticeM logger ("Created an H.E. index on " ++ indexDir) return index @@ -112,7 +149,8 @@ syncIndex' index revFile repos mkDraft newRev <- getCurrentRevNum repos debugM logger ("The repository revision is currently " ++ show newRev) - when (newRev /= oldRev) (syncIndex'' oldRev newRev) + when (oldRev == 0 || newRev /= oldRev) + $ syncIndex'' oldRev newRev return newRev where syncIndex'' :: RevNum -> RevNum -> IO () @@ -156,37 +194,15 @@ updateIndex index repos mkDraft rev name updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO () -updateIndexRev revFile f = bracket acquireLock releaseLock update +updateIndexRev revFile f = withFile revFile ReadWriteMode update where - acquireLock :: IO Fd - acquireLock - = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags - waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0) - return fd - - releaseLock :: Fd -> IO () - releaseLock fd - = setLock fd (Unlock, AbsoluteSeek, 0, 0) - - 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") + update :: Handle -> IO () + update h = do eof <- hIsEOF h + rev <- if eof then + return 0 + else + hGetLine h >>= return . read + rev' <- f rev + hSeek h AbsoluteSeek 0 + hSetFileSize h 0 + hPutStrLn h (show rev')