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.Types
18 import Subversion.Types
19 import System.Directory
20 import System.FilePath
22 import System.Log.Logger
23 import System.Posix.Files
24 import System.Posix.Types
25 import System.Posix.IO
26 import Subversion.FileSystem
27 import Subversion.Repository
28 import Text.HyperEstraier hiding (WriteLock)
30 logger = "Rakka.Storage"
33 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
34 getPage' repos name rev
35 = loadDefaultPage name -- FIXME
38 findAllPages :: Repository -> RevNum -> IO (Set PageName)
39 findAllPages _ 0 = findAllDefaultPages
40 findAllPages repos rev
41 = findAllDefaultPages -- FIXME
44 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
45 findChangedPages repos 0 newRev = findAllPages repos newRev
46 findChangedPages repos oldRev newRev
47 = fail "FIXME: not impl"
50 getCurrentRevNum :: Repository -> IO RevNum
51 getCurrentRevNum repos
52 = getRepositoryFS repos >>= getYoungestRev
55 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
56 startIndexManager lsdir repos mkDraft
57 = do chan <- newTChanIO
58 index <- openIndex indexDir revFile
59 forkIO (loop chan index)
62 indexDir = lsdir </> "index"
63 revFile = lsdir </> "indexRev"
65 loop :: TChan IndexReq -> Database -> IO ()
67 = do req <- atomically $ readTChan chan
70 -> syncIndex' index revFile repos mkDraft
72 -> do result <- searchIndex index cond
73 atomically $ putTMVar var result
77 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
78 -- indexDir と revFile を削除してから casket を R/W モードで開く。
79 openIndex :: FilePath -> FilePath -> IO Database
80 openIndex indexDir revFile
81 = do ret <- openDatabase indexDir (Writer [])
84 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
88 -> do warningM logger ("Failed to open an H.E. index on "
89 ++ indexDir ++ ": " ++ show err)
91 indexExists <- doesDirectoryExist indexDir
93 $ removeDirectoryRecursive indexDir
95 revFileExists <- doesFileExist revFile
99 Right index <- openDatabase indexDir (Writer [Create []])
100 addAttrIndex index "@uri" SeqIndex
101 addAttrIndex index "rakka:revision" SeqIndex
102 noticeM logger ("Created an H.E. index on " ++ indexDir)
107 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
108 syncIndex' index revFile repos mkDraft
109 = updateIndexRev revFile $ \ oldRev ->
110 do debugM logger ("The index revision is currently " ++ show oldRev)
112 newRev <- getCurrentRevNum repos
113 debugM logger ("The repository revision is currently " ++ show newRev)
115 when (newRev /= oldRev) (syncIndex'' oldRev newRev)
118 syncIndex'' :: RevNum -> RevNum -> IO ()
119 syncIndex'' oldRev newRev
120 = do pages <- findChangedPages repos oldRev newRev
121 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
124 searchIndex :: Database -> Condition -> IO [(PageName, RevNum)]
125 searchIndex index cond
126 = searchDatabase index cond >>= mapM fromId
128 fromId :: DocumentID -> IO (PageName, RevNum)
130 = do uri <- getDocURI index docId
131 rev <- getDocAttr index docId "rakka:revision"
132 >>= return . read . fromJust
133 return (decodePageName $ uriPath uri, rev)
136 updateIndex :: Database
138 -> (Page -> IO Document)
142 updateIndex index repos mkDraft rev name
143 = do pageM <- getPage' repos name (Just rev)
147 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
150 Just docId -> do removeDocument index docId [CleaningRemove]
151 infoM logger ("Removed page " ++ name ++ " from the index")
153 -> do draft <- mkDraft page
154 putDocument index draft [CleaningPut]
155 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
158 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
159 updateIndexRev revFile f = bracket acquireLock releaseLock update
163 = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags
164 waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
167 releaseLock :: Fd -> IO ()
169 = setLock fd (Unlock, AbsoluteSeek, 0, 0)
171 update :: Fd -> IO ()
173 = do fdSeek fd AbsoluteSeek 0
174 size <- return . fromIntegral . fileSize =<< getFdStatus fd
175 (revStr, gotSize) <- fdRead fd size
176 when (size /= gotSize) $ fail ("read " ++ show gotSize ++
177 " bytes but expected " ++ show size ++ " bytes")
179 let rev = case revStr of
185 let revStr' = show rev' ++ "\n"
186 size' = fromIntegral $ length revStr'
188 fdSeek fd AbsoluteSeek 0
190 wroteSize <- fdWrite fd revStr'
191 when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
192 " bytes but expected " ++ show size' ++ " bytes")