module Rakka.Storage.Impl ( getPage' , putPage' , deletePage' , getDirContents' , startIndexManager , getAttachment' , putAttachment' ) where import Control.Concurrent import Control.Concurrent.STM import Control.Monad import Data.Maybe import Data.Set (Set) import qualified Data.Set as S import Network.HTTP.Lucu import Network.URI import Prelude hiding (words) 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 = mapM (findChangedPagesAtRevision repos) [oldRev + 1 .. newRev] >>= return . S.unions 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) 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 "@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 mapM (fromId $ map fst hint) ids where fromId :: [String] -> DocumentID -> IO SearchResult fromId words docId = do uri <- getDocURI index docId rev <- getDocAttr index docId "rakka:revision" >>= return . read . fromJust snippet <- unsafeInterleaveIO $ do doc <- getDocument index docId [NoAttributes, NoKeywords] sn <- makeSnippet doc words 300 80 80 return (map toFragment sn) return SearchResult { srPageName = decodePageName $ uriPath uri , srPageRev = rev , srSnippet = snippet } toFragment :: Either String (String, String) -> SnippetFragment 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 " ++ name ++ " from the index") Just page -> do draft <- mkDraft page putDocument index draft [CleaningPut] infoM logger ("Indexed page " ++ 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 hGetLine h >>= return . read rev' <- f rev hSeek h AbsoluteSeek 0 hSetFileSize h 0 hPutStrLn h (show rev')