X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FStorage%2FImpl.hs;h=c9c2de2858320725b75c30396e54e179bcc6b3da;hb=b4c0033f297c28d95ad9298b489126331224bc42;hp=5db3f9257b0297e2d99d0e6c38677db7fdebd46f;hpb=e43bb104a7313dd696b8bb8aa3bafff94706a187;p=Rakka.git diff --git a/Rakka/Storage/Impl.hs b/Rakka/Storage/Impl.hs index 5db3f92..c9c2de2 100644 --- a/Rakka/Storage/Impl.hs +++ b/Rakka/Storage/Impl.hs @@ -1,50 +1,81 @@ module Rakka.Storage.Impl ( getPage' + , putPage' + , deletePage' + , getDirContents' , startIndexManager + + , getAttachment' + , putAttachment' ) where import Control.Concurrent import Control.Concurrent.STM -import Control.Exception import Control.Monad import Data.Maybe import Data.Set (Set) import qualified Data.Set as S +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 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" + = 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 @@ -52,6 +83,26 @@ 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 @@ -107,8 +158,11 @@ openIndex indexDir revFile $ 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 @@ -132,16 +186,42 @@ 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 <- 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 (trim (== Boundary) $ map toFragment sn) + return HitPage { + hpPageName = decodePageName $ uriPath uri + , hpPageRev = rev + , hpSnippet = snippet + } + + toFragment :: Either String (String, String) -> SnippetFragment + toFragment (Left "") = Boundary + toFragment (Left t) = NormalText t + toFragment (Right (w, _)) = HighlightedWord w updateIndex :: Database @@ -167,37 +247,15 @@ updateIndex index repos mkDraft rev name 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 + hGetLine h >>= return . read + rev' <- f rev + hSeek h AbsoluteSeek 0 + hSetFileSize h 0 + hPutStrLn h (show rev')