1 module Rakka.Storage.Impl
13 import Control.Concurrent
14 import Control.Concurrent.STM
18 import qualified Data.Set as S
20 import Network.HTTP.Lucu
21 import Network.HTTP.Lucu.Utils
23 import Prelude hiding (words)
24 import Rakka.Attachment
26 import Rakka.Storage.DefaultPage
27 import Rakka.Storage.Repos
28 import Rakka.Storage.Types
29 import Rakka.W3CDateTime
30 import Subversion.Types
31 import Subversion.FileSystem
32 import Subversion.Repository
33 import System.Directory
34 import System.FilePath
36 import System.IO.Unsafe
37 import System.Log.Logger
38 import Text.HyperEstraier hiding (WriteLock)
42 logger = "Rakka.Storage"
45 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
46 getPage' repos name rev
47 = do page <- loadPageInRepository repos name rev
49 Nothing -> loadDefaultPage name
53 putPage' :: Repository -> Maybe String -> Page -> IO StatusCode
54 putPage' = putPageIntoRepository
57 deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode
58 deletePage' = deletePageFromRepository
61 findAllPages :: Repository -> RevNum -> IO (Set PageName)
62 findAllPages _ 0 = findAllDefaultPages
63 findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev
64 defaultPages <- findAllDefaultPages
65 return (reposPages `S.union` defaultPages)
68 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
69 findChangedPages repos 0 newRev = findAllPages repos newRev
70 findChangedPages repos oldRev newRev
71 = liftM S.unions (mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev])
74 getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName]
75 getDirContents' repos name rev
76 = do reposPages <- getDirContentsInRevision repos name rev
77 defaultPages <- getDefaultDirContents name
78 return $ S.toList (reposPages `S.union` defaultPages)
81 getCurrentRevNum :: Repository -> IO RevNum
82 getCurrentRevNum repos
83 = getRepositoryFS repos >>= getYoungestRev
86 getAttachment' :: Attachment a =>
92 getAttachment' = loadAttachmentInRepository
95 putAttachment' :: Attachment a =>
103 putAttachment' = putAttachmentIntoRepository
106 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
107 startIndexManager lsdir repos mkDraft
108 = do chan <- newTChanIO
109 index <- openIndex indexDir revFile
110 _ <- forkIO (loop chan index)
113 indexDir = lsdir </> "index"
114 revFile = lsdir </> "indexRev"
116 loop :: TChan IndexReq -> Database -> IO ()
118 = do req <- atomically $ readTChan chan
121 -> do noticeM logger "Rebuilding the H.E. index..."
123 removeDirectoryRecursive indexDir
124 index' <- openIndex indexDir revFile
125 syncIndex' index' revFile repos mkDraft
129 -> do syncIndex' index revFile repos mkDraft
133 -> do result <- searchIndex index cond
134 atomically $ putTMVar var result
138 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
139 -- indexDir と revFile を削除してから casket を R/W モードで開く。
140 openIndex :: FilePath -> FilePath -> IO Database
141 openIndex indexDir revFile
142 = do ret <- openDatabase indexDir (Writer [])
145 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
149 -> do noticeM logger ("Failed to open an H.E. index on "
150 ++ indexDir ++ ": " ++ show err)
152 indexExists <- doesDirectoryExist indexDir
154 $ removeDirectoryRecursive indexDir
156 revFileExists <- doesFileExist revFile
160 Right index <- openDatabase indexDir (Writer [Create []])
161 addAttrIndex index "@mdate" SeqIndex
162 addAttrIndex index "@type" StrIndex
163 addAttrIndex index "@uri" SeqIndex
164 addAttrIndex index "rakka:revision" SeqIndex
165 addAttrIndex index "rakka:isTheme" StrIndex
166 addAttrIndex index "rakka:isFeed" StrIndex
167 noticeM logger ("Created an H.E. index on " ++ indexDir)
172 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
173 syncIndex' index revFile repos mkDraft
174 = updateIndexRev revFile $ \ oldRev ->
175 do debugM logger ("The index revision is currently " ++ show oldRev)
177 newRev <- getCurrentRevNum repos
178 debugM logger ("The repository revision is currently " ++ show newRev)
180 when (oldRev == 0 || newRev /= oldRev)
181 $ syncIndex'' oldRev newRev
184 syncIndex'' :: RevNum -> RevNum -> IO ()
185 syncIndex'' oldRev newRev
186 = do pages <- findChangedPages repos oldRev newRev
187 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
190 searchIndex :: Database -> Condition -> IO SearchResult
191 searchIndex index cond
192 = do (ids, hint) <- searchDatabase' index cond
193 let (total, words) = parseHint hint
194 pages <- mapM (fromId words) ids
195 return SearchResult {
200 parseHint :: [(String, Int)] -> (Int, [String])
202 = let total = fromJust $ lookup "" xs
203 words = filter (/= "") $ map fst xs
207 fromId :: [String] -> DocumentID -> IO HitPage
209 = do uri <- getDocURI index docId
210 rev <- unsafeInterleaveIO $
211 liftM (read . fromJust)
212 (getDocAttr index docId "rakka:revision")
213 lastMod <- unsafeInterleaveIO $
214 liftM (zonedTimeToUTC . fromJust . parseW3CDateTime . fromJust)
215 (getDocAttr index docId "@mdate")
216 summary <- unsafeInterleaveIO $
217 getDocAttr index docId "rakka:summary"
218 snippet <- unsafeInterleaveIO $
219 do doc <- getDocument index docId [NoAttributes, NoKeywords]
220 sn <- makeSnippet doc words 300 80 80
221 return (trim (== Boundary) $ map toFragment sn)
223 hpPageName = decodePageName $ uriPath uri
225 , hpLastMod = lastMod
226 , hpSummary = summary
227 , hpSnippet = snippet
230 toFragment :: Either String (String, String) -> SnippetFragment
231 toFragment (Left "") = Boundary
232 toFragment (Left t) = NormalText t
233 toFragment (Right (w, _)) = HighlightedWord w
236 updateIndex :: Database
238 -> (Page -> IO Document)
242 updateIndex index repos mkDraft rev name
243 = do pageM <- getPage' repos name (Just rev)
247 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
250 Just docId -> do removeDocument index docId [CleaningRemove]
251 infoM logger ("Removed page " ++ name ++ " from the index")
253 -> do draft <- mkDraft page
254 putDocument index draft [CleaningPut]
255 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
258 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
259 updateIndexRev revFile f = withFile revFile ReadWriteMode update
261 update :: Handle -> IO ()
262 update h = do eof <- hIsEOF h
266 liftM read (hGetLine h)
268 hSeek h AbsoluteSeek 0
270 hPutStrLn h (show rev')