1 module Rakka.Storage.Impl
8 import Control.Concurrent
9 import Control.Concurrent.STM
10 import Control.Exception
14 import qualified Data.Set as S
15 import Network.HTTP.Lucu
18 import Rakka.Storage.DefaultPage
19 import Rakka.Storage.Repos
20 import Rakka.Storage.Types
21 import Subversion.Types
22 import Subversion.FileSystem
23 import Subversion.Repository
24 import System.Directory
25 import System.FilePath
27 import System.Log.Logger
28 import System.Posix.Files
29 import System.Posix.Types
30 import System.Posix.IO
31 import Text.HyperEstraier hiding (WriteLock)
35 logger = "Rakka.Storage"
38 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
39 getPage' repos name rev
40 = do page <- loadPageInRepository repos name rev
42 Nothing -> loadDefaultPage name
46 putPage' :: Repository -> Page -> IO StatusCode
47 putPage' = putPageIntoRepository
50 findAllPages :: Repository -> RevNum -> IO (Set PageName)
51 findAllPages _ 0 = findAllDefaultPages
52 findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev
53 defaultPages <- findAllDefaultPages
54 return (reposPages `S.union` defaultPages)
57 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
58 findChangedPages repos 0 newRev = findAllPages repos newRev
59 findChangedPages repos oldRev newRev
60 = mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev]
65 getCurrentRevNum :: Repository -> IO RevNum
66 getCurrentRevNum repos
67 = getRepositoryFS repos >>= getYoungestRev
70 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
71 startIndexManager lsdir repos mkDraft
72 = do chan <- newTChanIO
73 index <- openIndex indexDir revFile
74 forkIO (loop chan index)
77 indexDir = lsdir </> "index"
78 revFile = lsdir </> "indexRev"
80 loop :: TChan IndexReq -> Database -> IO ()
82 = do req <- atomically $ readTChan chan
85 -> do noticeM logger "Rebuilding the H.E. index..."
87 removeDirectoryRecursive indexDir
88 index' <- openIndex indexDir revFile
89 syncIndex' index' revFile repos mkDraft
93 -> do syncIndex' index revFile repos mkDraft
97 -> do result <- searchIndex index cond
98 atomically $ putTMVar var result
102 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
103 -- indexDir と revFile を削除してから casket を R/W モードで開く。
104 openIndex :: FilePath -> FilePath -> IO Database
105 openIndex indexDir revFile
106 = do ret <- openDatabase indexDir (Writer [])
109 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
113 -> do noticeM logger ("Failed to open an H.E. index on "
114 ++ indexDir ++ ": " ++ show err)
116 indexExists <- doesDirectoryExist indexDir
118 $ removeDirectoryRecursive indexDir
120 revFileExists <- doesFileExist revFile
124 Right index <- openDatabase indexDir (Writer [Create []])
125 addAttrIndex index "@uri" SeqIndex
126 addAttrIndex index "rakka:revision" SeqIndex
127 noticeM logger ("Created an H.E. index on " ++ indexDir)
132 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
133 syncIndex' index revFile repos mkDraft
134 = updateIndexRev revFile $ \ oldRev ->
135 do debugM logger ("The index revision is currently " ++ show oldRev)
137 newRev <- getCurrentRevNum repos
138 debugM logger ("The repository revision is currently " ++ show newRev)
140 when (oldRev == 0 || newRev /= oldRev)
141 $ syncIndex'' oldRev newRev
144 syncIndex'' :: RevNum -> RevNum -> IO ()
145 syncIndex'' oldRev newRev
146 = do pages <- findChangedPages repos oldRev newRev
147 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
150 searchIndex :: Database -> Condition -> IO [(PageName, RevNum)]
151 searchIndex index cond
152 = searchDatabase index cond >>= mapM fromId
154 fromId :: DocumentID -> IO (PageName, RevNum)
156 = do uri <- getDocURI index docId
157 rev <- getDocAttr index docId "rakka:revision"
158 >>= return . read . fromJust
159 return (decodePageName $ uriPath uri, rev)
162 updateIndex :: Database
164 -> (Page -> IO Document)
168 updateIndex index repos mkDraft rev name
169 = do pageM <- getPage' repos name (Just rev)
173 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
176 Just docId -> do removeDocument index docId [CleaningRemove]
177 infoM logger ("Removed page " ++ name ++ " from the index")
179 -> do draft <- mkDraft page
180 putDocument index draft [CleaningPut]
181 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
184 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
185 updateIndexRev revFile f = bracket acquireLock releaseLock update
189 = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags
190 waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
193 releaseLock :: Fd -> IO ()
195 = setLock fd (Unlock, AbsoluteSeek, 0, 0)
197 update :: Fd -> IO ()
199 = do fdSeek fd AbsoluteSeek 0
200 size <- return . fromIntegral . fileSize =<< getFdStatus fd
201 (revStr, gotSize) <- fdRead fd size
202 when (size /= gotSize) $ fail ("read " ++ show gotSize ++
203 " bytes but expected " ++ show size ++ " bytes")
205 let rev = case revStr of
211 let revStr' = show rev' ++ "\n"
212 size' = fromIntegral $ length revStr'
214 fdSeek fd AbsoluteSeek 0
216 wroteSize <- fdWrite fd revStr'
217 when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++
218 " bytes but expected " ++ show size' ++ " bytes")