{-# LANGUAGE OverloadedStrings , UnicodeSyntax #-} module Rakka.Storage.Impl ( getPage' , putPage' , deletePage' , getDirContents' , startIndexManager , getAttachment' , putAttachment' ) where import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad import Data.Maybe import Data.Monoid.Unicode import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Time import qualified Data.Time.W3C as W3C import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI import Prelude hiding (words) import Prelude.Unicode import Rakka.Attachment import Rakka.Page import Rakka.Storage.DefaultPage import Rakka.Storage.Repos import Rakka.Storage.Types import Subversion.Types import Subversion.FileSystem import Subversion.Repository import System.Directory import System.FilePath import System.IO import System.IO.Unsafe import System.Log.Logger import Text.HyperEstraier hiding (WriteLock) logger :: String logger = "Rakka.Storage" getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page) getPage' repos name rev = do page <- loadPageInRepository repos name rev case page of Nothing -> loadDefaultPage name p -> return p putPage' :: Repository -> Maybe String -> Page -> IO StatusCode putPage' = putPageIntoRepository deletePage' :: Repository -> Maybe String -> PageName -> IO StatusCode deletePage' = deletePageFromRepository findAllPages :: Repository -> RevNum -> IO (Set PageName) findAllPages _ 0 = findAllDefaultPages findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev defaultPages <- findAllDefaultPages return (reposPages `S.union` defaultPages) findChangedPages :: Repository -> RevNum -> RevNum -> IO (Set PageName) findChangedPages repos 0 newRev = findAllPages repos newRev findChangedPages repos oldRev newRev = liftM S.unions (mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev]) getDirContents' :: Repository -> PageName -> Maybe RevNum -> IO [PageName] getDirContents' repos name rev = do reposPages <- getDirContentsInRevision repos name rev defaultPages <- getDefaultDirContents name return $ S.toList (reposPages `S.union` defaultPages) getCurrentRevNum :: Repository -> IO RevNum getCurrentRevNum repos = getRepositoryFS repos >>= getYoungestRev getAttachment' :: Attachment a => Repository -> PageName -> String -> Maybe RevNum -> IO (Maybe a) getAttachment' = loadAttachmentInRepository putAttachment' :: Attachment a => Repository -> Maybe String -> Maybe RevNum -> PageName -> String -> a -> IO StatusCode putAttachment' = putAttachmentIntoRepository startIndexManager :: FilePath -> Repository -> (Page -> IO Document) -> IO (TChan IndexReq) startIndexManager lsdir repos mkDraft = do chan <- newTChanIO index <- openIndex indexDir revFile _ <- forkIO (loop chan index `finally` closeDatabase index) return chan where indexDir = lsdir "index" revFile = lsdir "indexRev" loop :: TChan IndexReq -> Database -> IO () loop chan index = do req <- atomically $ readTChan chan case req of RebuildIndex -> do noticeM logger "Rebuilding the H.E. index..." closeDatabase index removeDirectoryRecursive indexDir index' <- openIndex indexDir revFile syncIndex' index' revFile repos mkDraft loop chan index' SyncIndex -> do syncIndex' index revFile repos mkDraft loop chan index SearchIndex cond var -> do result <- searchIndex index cond atomically $ putTMVar var result loop chan index -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら -- indexDir と revFile を削除してから casket を R/W モードで開く。 openIndex :: FilePath -> FilePath -> IO Database openIndex indexDir revFile = do ret <- openDatabase indexDir (Writer []) case ret of Right index -> do debugM logger ("Opened an H.E. index on " ++ indexDir) return index Left err -> do noticeM logger ("Failed to open an H.E. index on " ++ indexDir ++ ": " ++ show err) indexExists <- doesDirectoryExist indexDir when indexExists $ removeDirectoryRecursive indexDir revFileExists <- doesFileExist revFile when revFileExists $ removeFile revFile Right index <- openDatabase indexDir (Writer [Create []]) addAttrIndex index "@mdate" SeqIndex addAttrIndex index "@type" StrIndex addAttrIndex index "@uri" SeqIndex addAttrIndex index "rakka:revision" SeqIndex addAttrIndex index "rakka:isTheme" StrIndex addAttrIndex index "rakka:isFeed" StrIndex noticeM logger ("Created an H.E. index on " ++ indexDir) return index syncIndex' :: Database -> FilePath -> Repository -> (Page -> IO Document) -> IO () syncIndex' index revFile repos mkDraft = updateIndexRev revFile $ \ oldRev -> do debugM logger ("The index revision is currently " ++ show oldRev) newRev <- getCurrentRevNum repos debugM logger ("The repository revision is currently " ++ show newRev) when (oldRev == 0 || newRev /= oldRev) $ syncIndex'' oldRev newRev return newRev where syncIndex'' :: RevNum -> RevNum -> IO () syncIndex'' oldRev newRev = do pages <- findChangedPages repos oldRev newRev mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages) searchIndex ∷ Database → Condition → IO SearchResult searchIndex index cond = do (ids, hint) ← searchDatabase' index cond let (total, words) = parseHint hint pages ← mapM (fromId words) ids return SearchResult { srTotal = total , srPages = pages } where parseHint ∷ [(Text, Int)] → (Int, [Text]) parseHint xs = let total = fromJust $ lookup "" xs words = filter ((¬) ∘ T.null) $ map fst xs in (total, words) fromId ∷ [Text] → DocumentID → IO HitPage fromId words docId = do uri ← getDocURI index docId rev ← unsafeInterleaveIO $ -- FIXME: use Data.Text.Read read ∘ T.unpack ∘ fromJust <$> getDocAttr index docId "rakka:revision" lastMod ← unsafeInterleaveIO $ zonedTimeToUTC ∘ fromJust ∘ W3C.parse ∘ T.unpack ∘ fromJust <$> getDocAttr index docId "@mdate" summary ← unsafeInterleaveIO $ getDocAttr index docId "rakka:summary" snippet ← unsafeInterleaveIO $ do doc ← getDocument index docId [NoAttributes, NoKeywords] sn ← makeSnippet doc words 300 80 80 pure (trim (≡ Boundary) $ map toFragment sn) pure HitPage { hpPageName = decodePageName $ uriPath uri , hpPageRev = rev , hpLastMod = lastMod , hpSummary = summary , hpSnippet = snippet } toFragment ∷ Either Text (Text, Text) -> SnippetFragment toFragment (Left "" ) = Boundary toFragment (Left t ) = NormalText t toFragment (Right (w, _)) = HighlightedWord w updateIndex :: Database -> Repository -> (Page -> IO Document) -> RevNum -> PageName -> IO () updateIndex index repos mkDraft rev name = do pageM <- getPage' repos name (Just rev) case pageM of -- ページが削除された Nothing -> do docIdM <- getDocIdByURI index (mkRakkaURI name) case docIdM of Nothing -> return () Just docId -> do removeDocument index docId [CleaningRemove] infoM logger ("Removed page " ⊕ T.unpack name ⊕ " from the index") Just page -> do draft <- mkDraft page putDocument index draft [CleaningPut] infoM logger ("Indexed page " ⊕ T.unpack name ⊕ " of revision " ⊕ show (pageRevision page)) updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO () updateIndexRev revFile f = withFile revFile ReadWriteMode update where update :: Handle -> IO () update h = do eof <- hIsEOF h rev <- if eof then return 0 else liftM read (hGetLine h) rev' <- f rev hSeek h AbsoluteSeek 0 hSetFileSize h 0 hPutStrLn h (show rev')