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
47 = findAllDefaultPages -- FIXME
50 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
51 findChangedPages repos 0 newRev = findAllPages repos newRev
52 findChangedPages repos oldRev newRev
53 = findAllPages repos newRev -- FIXME
56 getCurrentRevNum :: Repository -> IO RevNum
57 getCurrentRevNum repos
58 = getRepositoryFS repos >>= getYoungestRev
61 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
62 startIndexManager lsdir repos mkDraft
63 = do chan <- newTChanIO
64 index <- openIndex indexDir revFile
65 forkIO (loop chan index)
68 indexDir = lsdir </> "index"
69 revFile = lsdir </> "indexRev"
71 loop :: TChan IndexReq -> Database -> IO ()
73 = do req <- atomically $ readTChan chan
76 -> do noticeM logger "Rebuilding the H.E. index..."
78 removeDirectoryRecursive indexDir
79 index' <- openIndex indexDir revFile
80 syncIndex' index' revFile repos mkDraft
84 -> do syncIndex' index revFile repos mkDraft
88 -> do result <- searchIndex index cond
89 atomically $ putTMVar var result
93 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
94 -- indexDir と revFile を削除してから casket を R/W モードで開く。
95 openIndex :: FilePath -> FilePath -> IO Database
96 openIndex indexDir revFile
97 = do ret <- openDatabase indexDir (Writer [])
100 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
104 -> do noticeM logger ("Failed to open an H.E. index on "
105 ++ indexDir ++ ": " ++ show err)
107 indexExists <- doesDirectoryExist indexDir
109 $ removeDirectoryRecursive indexDir
111 revFileExists <- doesFileExist revFile
115 Right index <- openDatabase indexDir (Writer [Create []])
116 addAttrIndex index "@uri" SeqIndex
117 addAttrIndex index "rakka:revision" SeqIndex
118 noticeM logger ("Created an H.E. index on " ++ indexDir)
123 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
124 syncIndex' index revFile repos mkDraft
125 = updateIndexRev revFile $ \ oldRev ->
126 do debugM logger ("The index revision is currently " ++ show oldRev)
128 newRev <- getCurrentRevNum repos
129 debugM logger ("The repository revision is currently " ++ show newRev)
131 when (oldRev == 0 || newRev /= oldRev)
132 $ syncIndex'' oldRev newRev
135 syncIndex'' :: RevNum -> RevNum -> IO ()
136 syncIndex'' oldRev newRev
137 = do pages <- findChangedPages repos oldRev newRev
138 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
141 searchIndex :: Database -> Condition -> IO [(PageName, RevNum)]
142 searchIndex index cond
143 = searchDatabase index cond >>= mapM fromId
145 fromId :: DocumentID -> IO (PageName, RevNum)
147 = do uri <- getDocURI index docId
148 rev <- getDocAttr index docId "rakka:revision"
149 >>= return . read . fromJust
150 return (decodePageName $ uriPath uri, rev)
153 updateIndex :: Database
155 -> (Page -> IO Document)
159 updateIndex index repos mkDraft rev name
160 = do pageM <- getPage' repos name (Just rev)
164 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
167 Just docId -> do removeDocument index docId [CleaningRemove]
168 infoM logger ("Removed page " ++ name ++ " from the index")
170 -> do draft <- mkDraft page
171 putDocument index draft [CleaningPut]
172 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
175 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
176 updateIndexRev revFile f = bracket acquireLock releaseLock update
180 = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags
181 waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
184 releaseLock :: Fd -> IO ()
186 = setLock fd (Unlock, AbsoluteSeek, 0, 0)
188 update :: Fd -> IO ()
190 = do fdSeek fd AbsoluteSeek 0
191 size <- return . fromIntegral . fileSize =<< getFdStatus fd
192 (revStr, gotSize) <- fdRead fd size
193 when (size /= gotSize) $ fail ("read " ++ show gotSize ++
194 " bytes but expected " ++ show size ++ " bytes")
196 let rev = case revStr of
202 let revStr' = show rev' ++ "\n"
203 size' = fromIntegral $ length revStr'
205 fdSeek fd AbsoluteSeek 0
207 wroteSize <- fdWrite fd revStr'
208 when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
209 " bytes but expected " ++ show size' ++ " bytes")