1 module Rakka.Storage.Impl
13 import Control.Concurrent
14 import Control.Concurrent.STM
18 import qualified Data.Set as S
19 import Network.HTTP.Lucu
21 import Rakka.Attachment
23 import Rakka.Storage.DefaultPage
24 import Rakka.Storage.Repos
25 import Rakka.Storage.Types
26 import Subversion.Types
27 import Subversion.FileSystem
28 import Subversion.Repository
29 import System.Directory
30 import System.FilePath
32 import System.Log.Logger
33 import Text.HyperEstraier hiding (WriteLock)
37 logger = "Rakka.Storage"
40 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
41 getPage' repos name rev
42 = do page <- loadPageInRepository repos name rev
44 Nothing -> loadDefaultPage name
48 putPage' :: Repository -> Maybe String -> Page -> IO StatusCode
49 putPage' = putPageIntoRepository
52 deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode
53 deletePage' = deletePageFromRepository
56 findAllPages :: Repository -> RevNum -> IO (Set PageName)
57 findAllPages _ 0 = findAllDefaultPages
58 findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev
59 defaultPages <- findAllDefaultPages
60 return (reposPages `S.union` defaultPages)
63 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
64 findChangedPages repos 0 newRev = findAllPages repos newRev
65 findChangedPages repos oldRev newRev
66 = mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev]
71 getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName]
72 getDirContents' repos name rev
73 = do reposPages <- getDirContentsInRevision repos name rev
74 defaultPages <- getDefaultDirContents name
75 return $ S.toList (reposPages `S.union` defaultPages)
78 getCurrentRevNum :: Repository -> IO RevNum
79 getCurrentRevNum repos
80 = getRepositoryFS repos >>= getYoungestRev
83 getAttachment' :: Attachment a =>
89 getAttachment' = loadAttachmentInRepository
92 putAttachment' :: Attachment a =>
100 putAttachment' = putAttachmentIntoRepository
103 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
104 startIndexManager lsdir repos mkDraft
105 = do chan <- newTChanIO
106 index <- openIndex indexDir revFile
107 forkIO (loop chan index)
110 indexDir = lsdir </> "index"
111 revFile = lsdir </> "indexRev"
113 loop :: TChan IndexReq -> Database -> IO ()
115 = do req <- atomically $ readTChan chan
118 -> do noticeM logger "Rebuilding the H.E. index..."
120 removeDirectoryRecursive indexDir
121 index' <- openIndex indexDir revFile
122 syncIndex' index' revFile repos mkDraft
126 -> do syncIndex' index revFile repos mkDraft
130 -> do result <- searchIndex index cond
131 atomically $ putTMVar var result
135 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
136 -- indexDir と revFile を削除してから casket を R/W モードで開く。
137 openIndex :: FilePath -> FilePath -> IO Database
138 openIndex indexDir revFile
139 = do ret <- openDatabase indexDir (Writer [])
142 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
146 -> do noticeM logger ("Failed to open an H.E. index on "
147 ++ indexDir ++ ": " ++ show err)
149 indexExists <- doesDirectoryExist indexDir
151 $ removeDirectoryRecursive indexDir
153 revFileExists <- doesFileExist revFile
157 Right index <- openDatabase indexDir (Writer [Create []])
158 addAttrIndex index "@type" StrIndex
159 addAttrIndex index "@uri" SeqIndex
160 addAttrIndex index "rakka:revision" SeqIndex
161 addAttrIndex index "rakka:isTheme" StrIndex
162 addAttrIndex index "rakka:isFeed" StrIndex
163 noticeM logger ("Created an H.E. index on " ++ indexDir)
168 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
169 syncIndex' index revFile repos mkDraft
170 = updateIndexRev revFile $ \ oldRev ->
171 do debugM logger ("The index revision is currently " ++ show oldRev)
173 newRev <- getCurrentRevNum repos
174 debugM logger ("The repository revision is currently " ++ show newRev)
176 when (oldRev == 0 || newRev /= oldRev)
177 $ syncIndex'' oldRev newRev
180 syncIndex'' :: RevNum -> RevNum -> IO ()
181 syncIndex'' oldRev newRev
182 = do pages <- findChangedPages repos oldRev newRev
183 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
186 searchIndex :: Database -> Condition -> IO [(PageName, RevNum)]
187 searchIndex index cond
188 = searchDatabase index cond >>= mapM fromId
190 fromId :: DocumentID -> IO (PageName, RevNum)
192 = do uri <- getDocURI index docId
193 rev <- getDocAttr index docId "rakka:revision"
194 >>= return . read . fromJust
195 return (decodePageName $ uriPath uri, rev)
198 updateIndex :: Database
200 -> (Page -> IO Document)
204 updateIndex index repos mkDraft rev name
205 = do pageM <- getPage' repos name (Just rev)
209 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
212 Just docId -> do removeDocument index docId [CleaningRemove]
213 infoM logger ("Removed page " ++ name ++ " from the index")
215 -> do draft <- mkDraft page
216 putDocument index draft [CleaningPut]
217 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
220 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
221 updateIndexRev revFile f = withFile revFile ReadWriteMode update
223 update :: Handle -> IO ()
224 update h = do eof <- hIsEOF h
228 hGetLine h >>= return . read
230 hSeek h AbsoluteSeek 0
232 hPutStrLn h (show rev')