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 = mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev]
76 getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName]
77 getDirContents' repos name rev
78 = do reposPages <- getDirContentsInRevision repos name rev
79 defaultPages <- getDefaultDirContents name
80 return $ S.toList (reposPages `S.union` defaultPages)
83 getCurrentRevNum :: Repository -> IO RevNum
84 getCurrentRevNum repos
85 = getRepositoryFS repos >>= getYoungestRev
88 getAttachment' :: Attachment a =>
94 getAttachment' = loadAttachmentInRepository
97 putAttachment' :: Attachment a =>
105 putAttachment' = putAttachmentIntoRepository
108 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
109 startIndexManager lsdir repos mkDraft
110 = do chan <- newTChanIO
111 index <- openIndex indexDir revFile
112 forkIO (loop chan index)
115 indexDir = lsdir </> "index"
116 revFile = lsdir </> "indexRev"
118 loop :: TChan IndexReq -> Database -> IO ()
120 = do req <- atomically $ readTChan chan
123 -> do noticeM logger "Rebuilding the H.E. index..."
125 removeDirectoryRecursive indexDir
126 index' <- openIndex indexDir revFile
127 syncIndex' index' revFile repos mkDraft
131 -> do syncIndex' index revFile repos mkDraft
135 -> do result <- searchIndex index cond
136 atomically $ putTMVar var result
140 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
141 -- indexDir と revFile を削除してから casket を R/W モードで開く。
142 openIndex :: FilePath -> FilePath -> IO Database
143 openIndex indexDir revFile
144 = do ret <- openDatabase indexDir (Writer [])
147 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
151 -> do noticeM logger ("Failed to open an H.E. index on "
152 ++ indexDir ++ ": " ++ show err)
154 indexExists <- doesDirectoryExist indexDir
156 $ removeDirectoryRecursive indexDir
158 revFileExists <- doesFileExist revFile
162 Right index <- openDatabase indexDir (Writer [Create []])
163 addAttrIndex index "@mdate" SeqIndex
164 addAttrIndex index "@type" StrIndex
165 addAttrIndex index "@uri" SeqIndex
166 addAttrIndex index "rakka:revision" SeqIndex
167 addAttrIndex index "rakka:isTheme" StrIndex
168 addAttrIndex index "rakka:isFeed" StrIndex
169 noticeM logger ("Created an H.E. index on " ++ indexDir)
174 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
175 syncIndex' index revFile repos mkDraft
176 = updateIndexRev revFile $ \ oldRev ->
177 do debugM logger ("The index revision is currently " ++ show oldRev)
179 newRev <- getCurrentRevNum repos
180 debugM logger ("The repository revision is currently " ++ show newRev)
182 when (oldRev == 0 || newRev /= oldRev)
183 $ syncIndex'' oldRev newRev
186 syncIndex'' :: RevNum -> RevNum -> IO ()
187 syncIndex'' oldRev newRev
188 = do pages <- findChangedPages repos oldRev newRev
189 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
192 searchIndex :: Database -> Condition -> IO SearchResult
193 searchIndex index cond
194 = do (ids, hint) <- searchDatabase' index cond
195 let (total, words) = parseHint hint
196 pages <- mapM (fromId words) ids
197 return SearchResult {
202 parseHint :: [(String, Int)] -> (Int, [String])
204 = let total = fromJust $ lookup "" xs
205 words = filter (/= "") $ map fst xs
209 fromId :: [String] -> DocumentID -> IO HitPage
211 = do uri <- getDocURI index docId
212 rev <- unsafeInterleaveIO $
213 getDocAttr index docId "rakka:revision"
215 return . read . fromJust
216 lastMod <- unsafeInterleaveIO $
217 getDocAttr index docId "@mdate"
219 return . zonedTimeToUTC . fromJust . parseW3CDateTime . fromJust
220 summary <- unsafeInterleaveIO $
221 getDocAttr index docId "rakka:summary"
222 snippet <- unsafeInterleaveIO $
223 do doc <- getDocument index docId [NoAttributes, NoKeywords]
224 sn <- makeSnippet doc words 300 80 80
225 return (trim (== Boundary) $ map toFragment sn)
227 hpPageName = decodePageName $ uriPath uri
229 , hpLastMod = lastMod
230 , hpSummary = summary
231 , hpSnippet = snippet
234 toFragment :: Either String (String, String) -> SnippetFragment
235 toFragment (Left "") = Boundary
236 toFragment (Left t) = NormalText t
237 toFragment (Right (w, _)) = HighlightedWord w
240 updateIndex :: Database
242 -> (Page -> IO Document)
246 updateIndex index repos mkDraft rev name
247 = do pageM <- getPage' repos name (Just rev)
251 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
254 Just docId -> do removeDocument index docId [CleaningRemove]
255 infoM logger ("Removed page " ++ name ++ " from the index")
257 -> do draft <- mkDraft page
258 putDocument index draft [CleaningPut]
259 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
262 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
263 updateIndexRev revFile f = withFile revFile ReadWriteMode update
265 update :: Handle -> IO ()
266 update h = do eof <- hIsEOF h
270 hGetLine h >>= return . read
272 hSeek h AbsoluteSeek 0
274 hPutStrLn h (show rev')