From: pho Date: Fri, 26 Oct 2007 23:12:42 +0000 (+0900) Subject: The experiment has succeeded X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=126e9f3faff19add1fb3dea792ec10dc57c30f03;p=Rakka.git The experiment has succeeded darcs-hash:20071026231242-62b54-443a561407cc36917c3a7b87d5dd6e57934473ca.gz --- diff --git a/Rakka.cabal b/Rakka.cabal index 60b1ca8..2fe7ff5 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -49,6 +49,7 @@ Other-Modules: Rakka.Resource.Render Rakka.Storage Rakka.Storage.DefaultPage + Rakka.Storage.Impl Rakka.SystemConfig Rakka.Utils Rakka.Wiki diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs index e1166b4..ec14373 100644 --- a/Rakka/Resource.hs +++ b/Rakka/Resource.hs @@ -17,11 +17,11 @@ import Text.XML.HXT.DOM.TypeDefs import Text.XML.HXT.DOM.XmlKeywords --- / ==> / --- /foo ==> /foo.html --- /foo/ ==> /foo.html --- /foo.bar/ ==> /foo.bar --- /foo.bar ==> /foo.bar +-- "/" ==> "/" +-- "/foo" ==> "/foo.html" +-- "/foo/" ==> "/foo.html" +-- "/foo.bar/" ==> "/foo.bar" +-- "/foo.bar" ==> "/foo.bar" canonicalizeURI :: Resource () canonicalizeURI = do uri <- getRequestURI diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 213b075..66a1516 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -25,9 +25,9 @@ import Text.XML.HXT.DOM.TypeDefs fallbackRender :: Environment -> [String] -> IO (Maybe ResourceDef) fallbackRender env path - | null path = return Nothing - | null $ head path = return Nothing - | not $ isUpper $ head $ head path = return Nothing -- /Foo/bar のような形式でない。 + | null path = return Nothing + | null $ head path = return Nothing + | isLower $ head $ head path = return Nothing -- 先頭の文字が小文字であってはならない | otherwise = return $ Just $ ResourceDef { resUsesNativeThread = False diff --git a/Rakka/Storage.hs b/Rakka/Storage.hs index 078feda..56b42da 100644 --- a/Rakka/Storage.hs +++ b/Rakka/Storage.hs @@ -14,44 +14,21 @@ module Rakka.Storage where import Control.Arrow.ArrowIO -import Control.Concurrent import Control.Concurrent.STM -import Control.Exception import Control.Monad import Control.Monad.Trans import Data.Maybe -import Data.Set (Set) -import qualified Data.Set as S -import Network.URI 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 { - stoRepository :: !Repository - , stoIndexChan :: !(TChan IndexReq) - } - - -data IndexReq - = SyncIndex - | SearchIndex !Condition !(TMVar [(PageName, RevNum)]) - - mkStorage :: FilePath -> Repository -> (Page -> IO Document) -> IO Storage mkStorage lsdir repos mkDraft = do chan <- startIndexManager lsdir repos mkDraft @@ -67,11 +44,6 @@ 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 -> Page -> RevNum -> m () putPage sto page oldRev = error "FIXME: not implemented" @@ -97,159 +69,3 @@ syncIndex :: Storage -> IO () syncIndex sto = atomically $ writeTChan (stoIndexChan sto) SyncIndex - -findAllPages :: Repository -> RevNum -> IO (Set PageName) -findAllPages _ 0 = findAllDefaultPages -findAllPages repos rev - = findAllDefaultPages -- FIXME - - -findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName) -findChangedPages repos 0 newRev = findAllPages repos newRev -findChangedPages repos oldRev newRev - = fail "FIXME: not impl" - - -getCurrentRevNum :: Repository -> IO RevNum -getCurrentRevNum repos - = getRepositoryFS repos >>= getYoungestRev - - -startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq) -startIndexManager lsdir repos mkDraft - = do chan <- newTChanIO - index <- openIndex indexDir revFile - forkIO (loop chan index) - return chan - where - indexDir = lsdir "index" - revFile = lsdir "indexRev" - - loop :: TChan IndexReq -> Database -> IO () - loop chan index - = do req <- atomically $ readTChan chan - case req of - SyncIndex - -> syncIndex' index revFile repos mkDraft - SearchIndex cond var - -> do result <- searchIndex index cond - atomically $ putTMVar var result - loop chan index - - --- 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 index - -> do debugM logger ("Opened an H.E. index on " ++ indexDir) - return index - - Left err - -> do warningM logger ("Failed to open an H.E. index on " - ++ indexDir ++ ": " ++ show err) - - indexExists <- doesDirectoryExist indexDir - when indexExists - $ removeDirectoryRecursive indexDir - - revFileExists <- doesFileExist revFile - when revFileExists - $ removeFile revFile - - Right index <- openDatabase indexDir (Writer [Create []]) - addAttrIndex index "@uri" SeqIndex - addAttrIndex index "rakka:revision" SeqIndex - noticeM logger ("Created an H.E. index on " ++ indexDir) - - return index - - -syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO () -syncIndex' index revFile repos mkDraft - = updateIndexRev revFile $ \ oldRev -> - do debugM logger ("The index revision is currently " ++ show oldRev) - - newRev <- getCurrentRevNum repos - 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 repos oldRev newRev - mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages) - - -searchIndex :: Database -> Condition -> IO [(PageName, RevNum)] -searchIndex index cond - = searchDatabase index cond >>= mapM fromId - where - fromId :: DocumentID -> IO (PageName, RevNum) - fromId docId - = do uri <- getDocURI index docId - rev <- getDocAttr index docId "rakka:revision" - >>= return . read . fromJust - return (decodePageName $ uriPath uri, rev) - - -updateIndex :: Database - -> Repository - -> (Page -> IO Document) - -> RevNum - -> PageName - -> IO () -updateIndex index repos mkDraft rev name - = do pageM <- getPage' repos name (Just rev) - case pageM of - -- ページが削除された - Nothing - -> do docIdM <- getDocIdByURI index (mkRakkaURI name) - case docIdM of - Nothing -> return () - Just docId -> do removeDocument index docId [CleaningRemove] - infoM logger ("Removed page " ++ name ++ " from the index") - Just page - -> do draft <- mkDraft page - putDocument index draft [CleaningPut] - infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page)) - - -updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO () -updateIndexRev revFile f = bracket acquireLock releaseLock 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") \ No newline at end of file diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs new file mode 100644 index 0000000..dd8b7c4 --- /dev/null +++ b/Rakka/Storage/Impl.hs @@ -0,0 +1,192 @@ +module Rakka.Storage.Impl + ( getPage' + , 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.URI +import Rakka.Page +import Rakka.Storage.DefaultPage +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" + + +getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page) +getPage' repos name rev + = loadDefaultPage name -- FIXME + + +findAllPages :: Repository -> RevNum -> IO (Set PageName) +findAllPages _ 0 = findAllDefaultPages +findAllPages repos rev + = findAllDefaultPages -- FIXME + + +findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName) +findChangedPages repos 0 newRev = findAllPages repos newRev +findChangedPages repos oldRev newRev + = fail "FIXME: not impl" + + +getCurrentRevNum :: Repository -> IO RevNum +getCurrentRevNum repos + = getRepositoryFS repos >>= getYoungestRev + + +startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq) +startIndexManager lsdir repos mkDraft + = do chan <- newTChanIO + index <- openIndex indexDir revFile + forkIO (loop chan index) + return chan + where + indexDir = lsdir "index" + revFile = lsdir "indexRev" + + loop :: TChan IndexReq -> Database -> IO () + loop chan index + = do req <- atomically $ readTChan chan + case req of + SyncIndex + -> syncIndex' index revFile repos mkDraft + SearchIndex cond var + -> do result <- searchIndex index cond + atomically $ putTMVar var result + loop chan index + + +-- 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 index + -> do debugM logger ("Opened an H.E. index on " ++ indexDir) + return index + + Left err + -> do warningM logger ("Failed to open an H.E. index on " + ++ indexDir ++ ": " ++ show err) + + indexExists <- doesDirectoryExist indexDir + when indexExists + $ removeDirectoryRecursive indexDir + + revFileExists <- doesFileExist revFile + when revFileExists + $ removeFile revFile + + Right index <- openDatabase indexDir (Writer [Create []]) + addAttrIndex index "@uri" SeqIndex + addAttrIndex index "rakka:revision" SeqIndex + noticeM logger ("Created an H.E. index on " ++ indexDir) + + return index + + +syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO () +syncIndex' index revFile repos mkDraft + = updateIndexRev revFile $ \ oldRev -> + do debugM logger ("The index revision is currently " ++ show oldRev) + + newRev <- getCurrentRevNum repos + 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 repos oldRev newRev + mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages) + + +searchIndex :: Database -> Condition -> IO [(PageName, RevNum)] +searchIndex index cond + = searchDatabase index cond >>= mapM fromId + where + fromId :: DocumentID -> IO (PageName, RevNum) + fromId docId + = do uri <- getDocURI index docId + rev <- getDocAttr index docId "rakka:revision" + >>= return . read . fromJust + return (decodePageName $ uriPath uri, rev) + + +updateIndex :: Database + -> Repository + -> (Page -> IO Document) + -> RevNum + -> PageName + -> IO () +updateIndex index repos mkDraft rev name + = do pageM <- getPage' repos name (Just rev) + case pageM of + -- ページが削除された + Nothing + -> do docIdM <- getDocIdByURI index (mkRakkaURI name) + case docIdM of + Nothing -> return () + Just docId -> do removeDocument index docId [CleaningRemove] + infoM logger ("Removed page " ++ name ++ " from the index") + Just page + -> do draft <- mkDraft page + putDocument index draft [CleaningPut] + infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page)) + + +updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO () +updateIndexRev revFile f = bracket acquireLock releaseLock 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") diff --git a/Rakka/Storage/Types.hs b/Rakka/Storage/Types.hs new file mode 100644 index 0000000..8a19041 --- /dev/null +++ b/Rakka/Storage/Types.hs @@ -0,0 +1,23 @@ +module Rakka.Storage.Types + ( Storage(..) + , IndexReq(..) + ) + where + +import Control.Concurrent.STM +import Rakka.Page +import Subversion.Repository +import Subversion.Types +import Text.HyperEstraier hiding (WriteLock) + + +data Storage + = Storage { + stoRepository :: !Repository + , stoIndexChan :: !(TChan IndexReq) + } + + +data IndexReq + = SyncIndex + | SearchIndex !Condition !(TMVar [(PageName, RevNum)])