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 Prelude hiding (words)
22 import Rakka.Attachment
24 import Rakka.Storage.DefaultPage
25 import Rakka.Storage.Repos
26 import Rakka.Storage.Types
27 import Subversion.Types
28 import Subversion.FileSystem
29 import Subversion.Repository
30 import System.Directory
31 import System.FilePath
33 import System.IO.Unsafe
34 import System.Log.Logger
35 import Text.HyperEstraier hiding (WriteLock)
39 logger = "Rakka.Storage"
42 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
43 getPage' repos name rev
44 = do page <- loadPageInRepository repos name rev
46 Nothing -> loadDefaultPage name
50 putPage' :: Repository -> Maybe String -> Page -> IO StatusCode
51 putPage' = putPageIntoRepository
54 deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode
55 deletePage' = deletePageFromRepository
58 findAllPages :: Repository -> RevNum -> IO (Set PageName)
59 findAllPages _ 0 = findAllDefaultPages
60 findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev
61 defaultPages <- findAllDefaultPages
62 return (reposPages `S.union` defaultPages)
65 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
66 findChangedPages repos 0 newRev = findAllPages repos newRev
67 findChangedPages repos oldRev newRev
68 = mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev]
73 getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName]
74 getDirContents' repos name rev
75 = do reposPages <- getDirContentsInRevision repos name rev
76 defaultPages <- getDefaultDirContents name
77 return $ S.toList (reposPages `S.union` defaultPages)
80 getCurrentRevNum :: Repository -> IO RevNum
81 getCurrentRevNum repos
82 = getRepositoryFS repos >>= getYoungestRev
85 getAttachment' :: Attachment a =>
91 getAttachment' = loadAttachmentInRepository
94 putAttachment' :: Attachment a =>
102 putAttachment' = putAttachmentIntoRepository
105 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
106 startIndexManager lsdir repos mkDraft
107 = do chan <- newTChanIO
108 index <- openIndex indexDir revFile
109 forkIO (loop chan index)
112 indexDir = lsdir </> "index"
113 revFile = lsdir </> "indexRev"
115 loop :: TChan IndexReq -> Database -> IO ()
117 = do req <- atomically $ readTChan chan
120 -> do noticeM logger "Rebuilding the H.E. index..."
122 removeDirectoryRecursive indexDir
123 index' <- openIndex indexDir revFile
124 syncIndex' index' revFile repos mkDraft
128 -> do syncIndex' index revFile repos mkDraft
132 -> do result <- searchIndex index cond
133 atomically $ putTMVar var result
137 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
138 -- indexDir と revFile を削除してから casket を R/W モードで開く。
139 openIndex :: FilePath -> FilePath -> IO Database
140 openIndex indexDir revFile
141 = do ret <- openDatabase indexDir (Writer [])
144 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
148 -> do noticeM logger ("Failed to open an H.E. index on "
149 ++ indexDir ++ ": " ++ show err)
151 indexExists <- doesDirectoryExist indexDir
153 $ removeDirectoryRecursive indexDir
155 revFileExists <- doesFileExist revFile
159 Right index <- openDatabase indexDir (Writer [Create []])
160 addAttrIndex index "@type" StrIndex
161 addAttrIndex index "@uri" SeqIndex
162 addAttrIndex index "rakka:revision" SeqIndex
163 addAttrIndex index "rakka:isTheme" StrIndex
164 addAttrIndex index "rakka:isFeed" StrIndex
165 noticeM logger ("Created an H.E. index on " ++ indexDir)
170 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
171 syncIndex' index revFile repos mkDraft
172 = updateIndexRev revFile $ \ oldRev ->
173 do debugM logger ("The index revision is currently " ++ show oldRev)
175 newRev <- getCurrentRevNum repos
176 debugM logger ("The repository revision is currently " ++ show newRev)
178 when (oldRev == 0 || newRev /= oldRev)
179 $ syncIndex'' oldRev newRev
182 syncIndex'' :: RevNum -> RevNum -> IO ()
183 syncIndex'' oldRev newRev
184 = do pages <- findChangedPages repos oldRev newRev
185 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
188 searchIndex :: Database -> Condition -> IO [SearchResult]
189 searchIndex index cond
190 = do (ids, hint) <- searchDatabase' index cond
191 mapM (fromId $ map fst hint) ids
193 fromId :: [String] -> DocumentID -> IO SearchResult
195 = do uri <- getDocURI index docId
196 rev <- getDocAttr index docId "rakka:revision"
197 >>= return . read . fromJust
198 snippet <- unsafeInterleaveIO $
199 do doc <- getDocument index docId [NoAttributes, NoKeywords]
200 sn <- makeSnippet doc words 300 80 80
201 return (map toFragment sn)
202 return SearchResult {
203 srPageName = decodePageName $ uriPath uri
205 , srSnippet = snippet
208 toFragment :: Either String (String, String) -> SnippetFragment
209 toFragment (Left t) = NormalText t
210 toFragment (Right (w, _)) = HighlightedWord w
213 updateIndex :: Database
215 -> (Page -> IO Document)
219 updateIndex index repos mkDraft rev name
220 = do pageM <- getPage' repos name (Just rev)
224 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
227 Just docId -> do removeDocument index docId [CleaningRemove]
228 infoM logger ("Removed page " ++ name ++ " from the index")
230 -> do draft <- mkDraft page
231 putDocument index draft [CleaningPut]
232 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
235 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
236 updateIndexRev revFile f = withFile revFile ReadWriteMode update
238 update :: Handle -> IO ()
239 update h = do eof <- hIsEOF h
243 hGetLine h >>= return . read
245 hSeek h AbsoluteSeek 0
247 hPutStrLn h (show rev')