X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FImpl.hs;h=bedc9eaa2808d3142e5d4abf91cd00d724369401;hb=8631d8de8373ec8226d19019ae7cf3a1bf2e44e5;hp=515667a9b40ddca019859b3b63fdcdbd6a6a8d76;hpb=b4a3d2cf3854b10d923cb4c546bf1fe32b021a68;p=Rakka.git diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index 515667a..bedc9ea 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -1,7 +1,12 @@ module Rakka.Storage.Impl ( getPage' , putPage' + , deletePage' + , getDirContents' , startIndexManager + + , getAttachment' + , putAttachment' ) where @@ -12,22 +17,25 @@ import Control.Monad import Data.Maybe import Data.Set (Set) import qualified Data.Set as S +import Data.Time import Network.HTTP.Lucu +import Network.HTTP.Lucu.Utils 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 Rakka.W3CDateTime 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 Text.HyperEstraier hiding (WriteLock) @@ -43,10 +51,14 @@ getPage' repos name rev p -> return p -putPage' :: Repository -> Page -> IO StatusCode +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 @@ -57,9 +69,14 @@ findAllPages repos rev = do reposPages <- findAllPagesInRevision repos rev 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 + = 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 @@ -67,11 +84,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" @@ -122,8 +159,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 @@ -147,16 +188,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 :: [(String, Int)] -> (Int, [String]) + parseHint xs + = let total = fromJust $ lookup "" xs + words = filter (/= "") $ map fst xs + in + (total, words) + + fromId :: [String] -> DocumentID -> IO HitPage + fromId words docId + = do uri <- getDocURI index docId + rev <- unsafeInterleaveIO $ + liftM (read . fromJust) + (getDocAttr index docId "rakka:revision") + lastMod <- unsafeInterleaveIO $ + liftM (zonedTimeToUTC . fromJust . parseW3CDateTime . 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 + return (trim (== Boundary) $ map toFragment sn) + return HitPage { + hpPageName = decodePageName $ uriPath uri + , hpPageRev = rev + , hpLastMod = lastMod + , hpSummary = summary + , hpSnippet = snippet + } + + toFragment :: Either String (String, String) -> SnippetFragment + toFragment (Left "") = Boundary + toFragment (Left t) = NormalText t + toFragment (Right (w, _)) = HighlightedWord w updateIndex :: Database @@ -178,41 +253,19 @@ updateIndex index repos mkDraft rev name Just page -> do draft <- mkDraft page putDocument index draft [CleaningPut] - infoM logger ("Indexed page " ++ name ++ " of revision " ++ show (entityRevision page)) + infoM logger ("Indexed page " ++ 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')