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
20 import Network.HTTP.Lucu.Utils
22 import Prelude hiding (words)
23 import Rakka.Attachment
25 import Rakka.Storage.DefaultPage
26 import Rakka.Storage.Repos
27 import Rakka.Storage.Types
28 import Subversion.Types
29 import Subversion.FileSystem
30 import Subversion.Repository
31 import System.Directory
32 import System.FilePath
34 import System.IO.Unsafe
35 import System.Log.Logger
36 import Text.HyperEstraier hiding (WriteLock)
40 logger = "Rakka.Storage"
43 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
44 getPage' repos name rev
45 = do page <- loadPageInRepository repos name rev
47 Nothing -> loadDefaultPage name
51 putPage' :: Repository -> Maybe String -> Page -> IO StatusCode
52 putPage' = putPageIntoRepository
55 deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode
56 deletePage' = deletePageFromRepository
59 findAllPages :: Repository -> RevNum -> IO (Set PageName)
60 findAllPages _ 0 = findAllDefaultPages
61 findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev
62 defaultPages <- findAllDefaultPages
63 return (reposPages `S.union` defaultPages)
66 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
67 findChangedPages repos 0 newRev = findAllPages repos newRev
68 findChangedPages repos oldRev newRev
69 = 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 "@type" StrIndex
162 addAttrIndex index "@uri" SeqIndex
163 addAttrIndex index "rakka:revision" SeqIndex
164 addAttrIndex index "rakka:isTheme" StrIndex
165 addAttrIndex index "rakka:isFeed" StrIndex
166 noticeM logger ("Created an H.E. index on " ++ indexDir)
171 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
172 syncIndex' index revFile repos mkDraft
173 = updateIndexRev revFile $ \ oldRev ->
174 do debugM logger ("The index revision is currently " ++ show oldRev)
176 newRev <- getCurrentRevNum repos
177 debugM logger ("The repository revision is currently " ++ show newRev)
179 when (oldRev == 0 || newRev /= oldRev)
180 $ syncIndex'' oldRev newRev
183 syncIndex'' :: RevNum -> RevNum -> IO ()
184 syncIndex'' oldRev newRev
185 = do pages <- findChangedPages repos oldRev newRev
186 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
189 searchIndex :: Database -> Condition -> IO SearchResult
190 searchIndex index cond
191 = do (ids, hint) <- searchDatabase' index cond
192 let (total, words) = parseHint hint
193 pages <- mapM (fromId words) ids
194 return SearchResult {
199 parseHint :: [(String, Int)] -> (Int, [String])
201 = let total = fromJust $ lookup "" xs
202 words = filter (/= "") $ map fst xs
206 fromId :: [String] -> DocumentID -> IO HitPage
208 = do uri <- getDocURI index docId
209 rev <- getDocAttr index docId "rakka:revision"
210 >>= return . read . fromJust
211 snippet <- unsafeInterleaveIO $
212 do doc <- getDocument index docId [NoAttributes, NoKeywords]
213 sn <- makeSnippet doc words 300 80 80
214 return (trim (== Boundary) $ map toFragment sn)
216 hpPageName = decodePageName $ uriPath uri
218 , hpSnippet = snippet
221 toFragment :: Either String (String, String) -> SnippetFragment
222 toFragment (Left "") = Boundary
223 toFragment (Left t) = NormalText t
224 toFragment (Right (w, _)) = HighlightedWord w
227 updateIndex :: Database
229 -> (Page -> IO Document)
233 updateIndex index repos mkDraft rev name
234 = do pageM <- getPage' repos name (Just rev)
238 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
241 Just docId -> do removeDocument index docId [CleaningRemove]
242 infoM logger ("Removed page " ++ name ++ " from the index")
244 -> do draft <- mkDraft page
245 putDocument index draft [CleaningPut]
246 infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page))
249 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
250 updateIndexRev revFile f = withFile revFile ReadWriteMode update
252 update :: Handle -> IO ()
253 update h = do eof <- hIsEOF h
257 hGetLine h >>= return . read
259 hSeek h AbsoluteSeek 0
261 hPutStrLn h (show rev')