5 module Rakka.Storage.Impl
16 import Control.Applicative
17 import Control.Concurrent
18 import Control.Concurrent.STM
19 import Control.Exception
22 import Data.Monoid.Unicode
24 import qualified Data.Set as S
25 import Data.Text (Text)
26 import qualified Data.Text as T
28 import qualified Data.Time.W3C as W3C
29 import Network.HTTP.Lucu
30 import Network.HTTP.Lucu.Utils
32 import Prelude hiding (words)
33 import Prelude.Unicode
34 import Rakka.Attachment
36 import Rakka.Storage.DefaultPage
37 import Rakka.Storage.Repos
38 import Rakka.Storage.Types
39 import Subversion.Types
40 import Subversion.FileSystem
41 import Subversion.Repository
42 import System.Directory
43 import System.FilePath
45 import System.IO.Unsafe
46 import System.Log.Logger
47 import Text.HyperEstraier hiding (WriteLock)
51 logger = "Rakka.Storage"
54 getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page)
55 getPage' repos name rev
56 = do page <- loadPageInRepository repos name rev
58 Nothing -> loadDefaultPage name
62 putPage' :: Repository -> Maybe String -> Page -> IO StatusCode
63 putPage' = putPageIntoRepository
66 deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode
67 deletePage' = deletePageFromRepository
70 findAllPages :: Repository -> RevNum -> IO (Set PageName)
71 findAllPages _ 0 = findAllDefaultPages
72 findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev
73 defaultPages <- findAllDefaultPages
74 return (reposPages `S.union` defaultPages)
77 findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName)
78 findChangedPages repos 0 newRev = findAllPages repos newRev
79 findChangedPages repos oldRev newRev
80 = liftM S.unions (mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev])
83 getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName]
84 getDirContents' repos name rev
85 = do reposPages <- getDirContentsInRevision repos name rev
86 defaultPages <- getDefaultDirContents name
87 return $ S.toList (reposPages `S.union` defaultPages)
90 getCurrentRevNum :: Repository -> IO RevNum
91 getCurrentRevNum repos
92 = getRepositoryFS repos >>= getYoungestRev
95 getAttachment' :: Attachment a =>
101 getAttachment' = loadAttachmentInRepository
104 putAttachment' :: Attachment a =>
112 putAttachment' = putAttachmentIntoRepository
115 startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq)
116 startIndexManager lsdir repos mkDraft
117 = do chan <- newTChanIO
118 index <- openIndex indexDir revFile
119 _ <- forkIO (loop chan index `finally` closeDatabase index)
122 indexDir = lsdir </> "index"
123 revFile = lsdir </> "indexRev"
125 loop :: TChan IndexReq -> Database -> IO ()
127 = do req <- atomically $ readTChan chan
130 -> do noticeM logger "Rebuilding the H.E. index..."
132 removeDirectoryRecursive indexDir
133 index' <- openIndex indexDir revFile
134 syncIndex' index' revFile repos mkDraft
138 -> do syncIndex' index revFile repos mkDraft
142 -> do result <- searchIndex index cond
143 atomically $ putTMVar var result
147 -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら
148 -- indexDir と revFile を削除してから casket を R/W モードで開く。
149 openIndex :: FilePath -> FilePath -> IO Database
150 openIndex indexDir revFile
151 = do ret <- openDatabase indexDir (Writer [])
154 -> do debugM logger ("Opened an H.E. index on " ++ indexDir)
158 -> do noticeM logger ("Failed to open an H.E. index on "
159 ++ indexDir ++ ": " ++ show err)
161 indexExists <- doesDirectoryExist indexDir
163 $ removeDirectoryRecursive indexDir
165 revFileExists <- doesFileExist revFile
169 Right index <- openDatabase indexDir (Writer [Create []])
170 addAttrIndex index "@mdate" SeqIndex
171 addAttrIndex index "@type" StrIndex
172 addAttrIndex index "@uri" SeqIndex
173 addAttrIndex index "rakka:revision" SeqIndex
174 addAttrIndex index "rakka:isTheme" StrIndex
175 addAttrIndex index "rakka:isFeed" StrIndex
176 noticeM logger ("Created an H.E. index on " ++ indexDir)
181 syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO ()
182 syncIndex' index revFile repos mkDraft
183 = updateIndexRev revFile $ \ oldRev ->
184 do debugM logger ("The index revision is currently " ++ show oldRev)
186 newRev <- getCurrentRevNum repos
187 debugM logger ("The repository revision is currently " ++ show newRev)
189 when (oldRev == 0 || newRev /= oldRev)
190 $ syncIndex'' oldRev newRev
193 syncIndex'' :: RevNum -> RevNum -> IO ()
194 syncIndex'' oldRev newRev
195 = do pages <- findChangedPages repos oldRev newRev
196 mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages)
199 searchIndex ∷ Database → Condition → IO SearchResult
200 searchIndex index cond
201 = do (ids, hint) ← searchDatabase' index cond
202 let (total, words) = parseHint hint
203 pages ← mapM (fromId words) ids
204 return SearchResult {
209 parseHint ∷ [(Text, Int)] → (Int, [Text])
211 = let total = fromJust $ lookup "" xs
212 words = filter ((¬) ∘ T.null) $ map fst xs
216 fromId ∷ [Text] → DocumentID → IO HitPage
218 = do uri ← getDocURI index docId
219 rev ← unsafeInterleaveIO $
220 -- FIXME: use Data.Text.Read
221 read ∘ T.unpack ∘ fromJust
222 <$> getDocAttr index docId "rakka:revision"
223 lastMod ← unsafeInterleaveIO $
224 zonedTimeToUTC ∘ fromJust ∘ W3C.parse ∘ T.unpack ∘ fromJust
225 <$> getDocAttr index docId "@mdate"
226 summary ← unsafeInterleaveIO $
227 getDocAttr index docId "rakka:summary"
228 snippet ← unsafeInterleaveIO $
229 do doc ← getDocument index docId [NoAttributes, NoKeywords]
230 sn ← makeSnippet doc words 300 80 80
231 pure (trim (≡ Boundary) $ map toFragment sn)
233 hpPageName = decodePageName $ uriPath uri
235 , hpLastMod = lastMod
236 , hpSummary = summary
237 , hpSnippet = snippet
239 toFragment ∷ Either Text (Text, Text) -> SnippetFragment
240 toFragment (Left "" ) = Boundary
241 toFragment (Left t ) = NormalText t
242 toFragment (Right (w, _)) = HighlightedWord w
244 updateIndex :: Database
246 -> (Page -> IO Document)
250 updateIndex index repos mkDraft rev name
251 = do pageM <- getPage' repos name (Just rev)
255 -> do docIdM <- getDocIdByURI index (mkRakkaURI name)
258 Just docId -> do removeDocument index docId [CleaningRemove]
259 infoM logger ("Removed page " ⊕ T.unpack name ⊕ " from the index")
261 -> do draft <- mkDraft page
262 putDocument index draft [CleaningPut]
263 infoM logger ("Indexed page " ⊕ T.unpack name ⊕ " of revision " ⊕ show (pageRevision page))
266 updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO ()
267 updateIndexRev revFile f = withFile revFile ReadWriteMode update
269 update :: Handle -> IO ()
270 update h = do eof <- hIsEOF h
274 liftM read (hGetLine h)
276 hSeek h AbsoluteSeek 0
278 hPutStrLn h (show rev')