X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FImpl.hs;h=55bda719f5f30190bfff48d2711ef4b63afd0593;hb=HEAD;hp=dd8b7c4c504f8ad40195334b8dbd3caa7eec86bb;hpb=126e9f3faff19add1fb3dea792ec10dc57c30f03;p=Rakka.git diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index dd8b7c4..55bda71 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -1,50 +1,90 @@ +{-# 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 System.Posix.Files -import System.Posix.Types -import System.Posix.IO -import Subversion.FileSystem -import Subversion.Repository import Text.HyperEstraier hiding (WriteLock) + +logger :: String logger = "Rakka.Storage" getPage' :: Repository -> PageName -> Maybe RevNum -> IO (Maybe Page) getPage' repos name rev - = loadDefaultPage name -- FIXME + = 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 - = findAllDefaultPages -- FIXME +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 - = fail "FIXME: not impl" + = 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 @@ -52,11 +92,31 @@ 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) + _ <- forkIO (loop chan index `finally` closeDatabase index) return chan where indexDir = lsdir "index" @@ -66,12 +126,22 @@ startIndexManager lsdir repos mkDraft 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 - -> syncIndex' index revFile repos mkDraft + -> do syncIndex' index revFile repos mkDraft + loop chan index + SearchIndex cond var -> do result <- searchIndex index cond atomically $ putTMVar var result - loop chan index + loop chan index -- casket を R/W モードで開く。成功したらそのまま返し、失敗したら @@ -85,8 +155,8 @@ openIndex indexDir revFile return index Left err - -> do warningM logger ("Failed to open an H.E. index on " - ++ indexDir ++ ": " ++ show err) + -> do noticeM logger ("Failed to open an H.E. index on " + ++ indexDir ++ ": " ++ show err) indexExists <- doesDirectoryExist indexDir when indexExists @@ -97,8 +167,12 @@ openIndex indexDir revFile $ 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 @@ -112,7 +186,8 @@ syncIndex' index revFile repos mkDraft newRev <- getCurrentRevNum repos debugM logger ("The repository revision is currently " ++ show newRev) - when (newRev /= oldRev) (syncIndex'' oldRev newRev) + when (oldRev == 0 || newRev /= oldRev) + $ syncIndex'' oldRev newRev return newRev where syncIndex'' :: RevNum -> RevNum -> IO () @@ -121,17 +196,50 @@ syncIndex' index revFile repos mkDraft mapM_ (updateIndex index repos mkDraft newRev) (S.toList pages) -searchIndex :: Database -> Condition -> IO [(PageName, RevNum)] +searchIndex ∷ Database → Condition → IO SearchResult searchIndex index cond - = searchDatabase index cond >>= mapM fromId + = do (ids, hint) ← searchDatabase' index cond + let (total, words) = parseHint hint + pages ← mapM (fromId words) ids + return SearchResult { + srTotal = total + , srPages = pages + } where - fromId :: DocumentID -> IO (PageName, RevNum) - fromId docId - = do uri <- getDocURI index docId - rev <- getDocAttr index docId "rakka:revision" - >>= return . read . fromJust - return (decodePageName $ uriPath uri, rev) - + 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 @@ -148,45 +256,23 @@ updateIndex index repos mkDraft rev name case docIdM of Nothing -> return () Just docId -> do removeDocument index docId [CleaningRemove] - infoM logger ("Removed page " ++ name ++ " from the index") + infoM logger ("Removed page " ⊕ T.unpack name ⊕ " from the index") Just page -> do draft <- mkDraft page putDocument index draft [CleaningPut] - infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (pageRevision page)) + infoM logger ("Indexed page " ⊕ T.unpack name ⊕ " of revision " ⊕ show (pageRevision page)) updateIndexRev :: FilePath -> (RevNum -> IO RevNum) -> IO () -updateIndexRev revFile f = bracket acquireLock releaseLock update +updateIndexRev revFile f = withFile revFile ReadWriteMode update where - acquireLock :: IO Fd - acquireLock - = do fd <- openFd revFile ReadWrite (Just stdFileMode) defaultFileFlags - waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0) - return fd - - releaseLock :: Fd -> IO () - releaseLock fd - = setLock fd (Unlock, AbsoluteSeek, 0, 0) - - update :: Fd -> IO () - update fd - = do fdSeek fd AbsoluteSeek 0 - size <- return . fromIntegral . fileSize =<< getFdStatus fd - (revStr, gotSize) <- fdRead fd size - when (size /= gotSize) $ fail ("read " ++ show gotSize ++ - " bytes but expected " ++ show size ++ " bytes") - - let rev = case revStr of - "" -> 0 - _ -> read revStr - - rev' <- f rev - - let revStr' = show rev' ++ "\n" - size' = fromIntegral $ length revStr' - - fdSeek fd AbsoluteSeek 0 - setFdSize fd 0 - wroteSize <- fdWrite fd revStr' - when (size' /= wroteSize) $ fail ("wrote " ++ show wroteSize ++ - " bytes but expected " ++ show size' ++ " bytes") + 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')