1 module Rakka.Storage.Impl
7 import Control.Concurrent
8 import Control.Concurrent.STM
9 import Control.Exception
13 import qualified Data.Set as S
16 import Rakka.Storage.DefaultPage
17 import Rakka.Storage.Repos
18 import Rakka.Storage.Types
19 import Subversion.Types
20 import Subversion.FileSystem
21 import Subversion.Repository
22 import System.Directory
23 import System.FilePath
25 import System.Log.Logger
26 import System.Posix.Files
27 import System.Posix.Types
28 import System.Posix.IO
29 import Text.HyperEstraier hiding (WriteLock)
33 logger = "Rakka.Storage"
36 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
37 getPage' repos name rev
38 = do page <- loadPageInRepository repos name rev
40 Nothing -> loadDefaultPage name
44 findAllPages :: Repository -> RevNum -> IO (Set PageName)
45 findAllPages _ 0 = findAllDefaultPages
46 findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev
47 defaultPages <- findAllDefaultPages
48 return (reposPages `S.union` defaultPages)
51 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
52 findChangedPages repos 0 newRev = findAllPages repos newRev
53 findChangedPages repos oldRev newRev
54 = findAllPages repos newRev -- FIXME
57 getCurrentRevNum :: Repository -> IO RevNum
58 getCurrentRevNum repos
59 = getRepositoryFS repos >>= getYoungestRev
62 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
63 startIndexManager lsdir repos mkDraft
64 = do chan <- newTChanIO
65 index <- openIndex indexDir revFile
66 forkIO (loop chan index)
69 indexDir = lsdir </> "index"
70 revFile = lsdir </> "indexRev"
72 loop :: TChan IndexReq -> Database -> IO ()
74 = do req <- atomically $ readTChan chan
77 -> do noticeM logger "Rebuilding the H.E. index..."
79 removeDirectoryRecursive indexDir
80 index' <- openIndex indexDir revFile
81 syncIndex' index' revFile repos mkDraft
85 -> do syncIndex' index revFile repos mkDraft
89 -> do result <- searchIndex index cond
90 atomically $ putTMVar var result
94 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
95 -- indexDir と revFile を削除してから casket を R/W モードで開く。
96 openIndex :: FilePath -> FilePath -> IO Database
97 openIndex indexDir revFile
98 = do ret <- openDatabase indexDir (Writer [])
101 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
105 -> do noticeM logger ("Failed to open an H.E. index on "
106 ++ indexDir ++ ": " ++ show err)
108 indexExists <- doesDirectoryExist indexDir
110 $ removeDirectoryRecursive indexDir
112 revFileExists <- doesFileExist revFile
116 Right index <- openDatabase indexDir (Writer [Create []])
117 addAttrIndex index "@uri" SeqIndex
118 addAttrIndex index "rakka:revision" SeqIndex
119 noticeM logger ("Created an H.E. index on " ++ indexDir)
124 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
125 syncIndex' index revFile repos mkDraft
126 = updateIndexRev revFile $ \ oldRev ->
127 do debugM logger ("The index revision is currently " ++ show oldRev)
129 newRev <- getCurrentRevNum repos
130 debugM logger ("The repository revision is currently " ++ show newRev)
132 when (oldRev == 0 || newRev /= oldRev)
133 $ syncIndex'' oldRev newRev
136 syncIndex'' :: RevNum -> RevNum -> IO ()
137 syncIndex'' oldRev newRev
138 = do pages <- findChangedPages repos oldRev newRev
139 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
142 searchIndex :: Database -> Condition -> IO [(PageName, RevNum)]
143 searchIndex index cond
144 = searchDatabase index cond >>= mapM fromId
146 fromId :: DocumentID -> IO (PageName, RevNum)
148 = do uri <- getDocURI index docId
149 rev <- getDocAttr index docId "rakka:revision"
150 >>= return . read . fromJust
151 return (decodePageName $ uriPath uri, rev)
154 updateIndex :: Database
156 -> (Page -> IO Document)
160 updateIndex index repos mkDraft rev name
161 = do pageM <- getPage' repos name (Just rev)
165 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
168 Just docId -> do removeDocument index docId [CleaningRemove]
169 infoM logger ("Removed page " ++ name ++ " from the index")
171 -> do draft <- mkDraft page
172 putDocument index draft [CleaningPut]
173 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
176 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
177 updateIndexRev revFile f = bracket acquireLock releaseLock update
181 = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags
182 waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
185 releaseLock :: Fd -> IO ()
187 = setLock fd (Unlock, AbsoluteSeek, 0, 0)
189 update :: Fd -> IO ()
191 = do fdSeek fd AbsoluteSeek 0
192 size <- return . fromIntegral . fileSize =<< getFdStatus fd
193 (revStr, gotSize) <- fdRead fd size
194 when (size /= gotSize) $ fail ("read " ++ show gotSize ++
195 " bytes but expected " ++ show size ++ " bytes")
197 let rev = case revStr of
203 let revStr' = show rev' ++ "\n"
204 size' = fromIntegral $ length revStr'
206 fdSeek fd AbsoluteSeek 0
208 wroteSize <- fdWrite fd revStr'
209 when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
210 " bytes but expected " ++ show size' ++ " bytes")