diff --git a/Holumbus-Searchengine.cabal b/Holumbus-Searchengine.cabal new file mode 100644 --- /dev/null +++ b/Holumbus-Searchengine.cabal @@ -0,0 +1,97 @@ +name: Holumbus-Searchengine +version: 1.2.0 +license: MIT +license-file: LICENSE +author: Sebastian M. Gauck, Timo B. Huebel, Uwe Schmidt +copyright: Copyright (c) 2007 - 2012 Uwe Schmidt, Sebastian M. Gauck and Timo B. Huebel +maintainer: Timo B. Huebel , Uwe Schmidt +stability: experimental +category: Text, Data +synopsis: A search and indexing engine. +homepage: http://holumbus.fh-wedel.de +description: The Holumbus-Searchengine library provides a document indexer + and crawler to build indexes over document collections + as well as a sophisticated query interface for these indexes. +cabal-version: >=1.6 +build-type: Simple +-- tested-with: ghc-7.0.3 + +extra-source-files: + README + +library + build-depends: base >= 4 && < 5 + , binary >= 0.5 && < 1 + , bytestring >= 0.9 && < 1 + , bzlib >= 0.4 && < 1 + , containers >= 0.2 && < 1 + , deepseq >= 1.1 && < 2 + , directory >= 1 && < 2 + , enummapset >= 0 && < 1 + , filepath >= 1 && < 2 + , hslogger >= 1 && < 2 + , hxt >= 9.1 && < 10 + , hxt-cache >= 9 && < 10 + , hxt-curl >= 9 && < 10 + , hxt-regex-xmlschema >= 9 && < 10 + , hxt-unicode >= 9 && < 10 + , mtl >= 1.1 && < 3 + , network >= 2.1 && < 3 + , parallel >= 3.1 && < 4 + , parsec >= 2.1 && < 4 + , process >= 1 && < 2 + , unix >= 2.3 && < 3 + + exposed-modules: + Control.Concurrent.MapFold + Control.Monad.ReaderStateIO + Control.Sequential.MapFoldBinary + Holumbus.Crawler.CacheCore + Holumbus.Crawler.Constants + Holumbus.Crawler.Core + Holumbus.Crawler + Holumbus.Crawler.Html + Holumbus.Crawler.IndexerCore + Holumbus.Crawler.Logger + Holumbus.Crawler.PdfToText + Holumbus.Crawler.Robots + Holumbus.Crawler.RobotTypes + Holumbus.Crawler.Types + Holumbus.Crawler.URIs + Holumbus.Crawler.Util + Holumbus.Crawler.XmlArrows + Holumbus.Data.Crunch + Holumbus.Data.PrefixTree.Core + Holumbus.Data.PrefixTree.FuzzySearch + Holumbus.Data.PrefixTree + Holumbus.Data.PrefixTree.PrefixSet + Holumbus.Data.PrefixTree.Types + Holumbus.Index.Common + Holumbus.Index.Common.BasicTypes + Holumbus.Index.Common.DiffList + Holumbus.Index.Common.DocId + Holumbus.Index.Common.DocIdMap + Holumbus.Index.Common.Document + Holumbus.Index.Common.LoadStore + Holumbus.Index.Common.Occurences + Holumbus.Index.Common.RawResult + Holumbus.Index.CompactDocuments + Holumbus.Index.CompactIndex + Holumbus.Index.CompactSmallDocuments + Holumbus.Index.Compression + Holumbus.Index.Inverted.CompressedPrefixMem + Holumbus.Index.Inverted.PrefixMem + Holumbus.Query.Fuzzy + Holumbus.Query.Intermediate + Holumbus.Query.Language.Grammar + Holumbus.Query.Language.Parser + Holumbus.Query.Processor + Holumbus.Query.Ranking + Holumbus.Query.Result + Holumbus.Utility + + hs-source-dirs: src + + ghc-options: -Wall -funbox-strict-fields -fwarn-tabs + + extensions: diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2007 Sebastian M. Schlatt, Timo B. Hübel + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation the +rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,56 @@ +This is Holumbus. + +Version 0.4 + +Sebastian M. Schlatt - sms@holumbus.org +Timo B. Hübel - tbh@holumbus.org + +http://www.holumbus.org + +About +----- + +Holumbus is a Haskell library which provides the basic building blocks for +creating powerful indexing and search applications. This includes a framework +for distributed crawling and indexing as well as distributed query processing. + +Contents +-------- + +doc Detailed information about the internals of Holumbus. +examples Some example applications and utilities. +source Source code of the Holumbus core library. +test Several tests for the Holumbus core library. + +Requirements +------------ + +The Holumbus core library requires at least GHC 6.8.2 and the +following packages (available via Hackage): + +- binary 0.4.1 +- bzlib 0.4.0.1 +- HDBC 1.1.4 +- HDBC-sqlite3 1.1.4.0 +- hxt 7.5 +- regex-compat 0.71.0.1 +- utf8-string 0.2 + +Installation +------------ + +A Cabal file is provided, therefore Holumbus can be installed using +the standard Cabal way: + +$ runhaskell Setup.hs configure +$ runhaskell Setup.hs build +$ runhaskell Setup.hs install # with root privileges + +Documentation +------------- + +Documentation is provided through the examples and extensive Haddock +API documentation available online at http://www.holumbus.org. + +Details about the internals of the Holumbus framework are available in +the extensive descriptions of the implementation in the "doc" directory. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/runhaskell + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/src/Control/Concurrent/MapFold.hs b/src/Control/Concurrent/MapFold.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/MapFold.hs @@ -0,0 +1,63 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +{- | + Module : Control.Concurrent.MapFold + Copyright : Copyright (C) 2010 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: none portable + + A map-fold function for performing list folds in parallel. + +-} + +-- ------------------------------------------------------------ + +module Control.Concurrent.MapFold + ( mapFold ) +where + +import Control.Concurrent +import Control.DeepSeq + +-- ------------------------------------------------------------ + +mapFold :: (NFData b) => Int -> (a -> IO b) -> (b -> b -> IO b) -> [a] -> IO b +mapFold n m f xs@(_:_) = do + c <- newChan + p <- newQSem n + mapFold' p c m f xs +mapFold _ _ _ [] = error "mapFold: empty list of arguments" + +mapFold' :: (NFData b) => QSem -> Chan b -> (a -> IO b) -> (b -> b -> IO b) -> [a] -> IO b +mapFold' p c m f xs = do + mapM_ (forkWorker m) xs + foldResults (length xs) + where + forkWorker m' x = forkIO process + >> return () + where + process = do + waitQSem p -- request processor + res <- m' x -- work + rnf res `seq` -- force complete elvaluation + writeChan c res -- deliver result + signalQSem p -- release processor + + + foldResults n + | n == 1 = readChan c -- get final result + + | otherwise = do + r1 <- readChan c -- get 1. arg + r2 <- readChan c -- get 2. arg + forkWorker (uncurry f) (r1, r2) + -- combine args and put result back into chanel + foldResults (n - 1) -- continue + +-- ------------------------------------------------------------ + diff --git a/src/Control/Monad/ReaderStateIO.hs b/src/Control/Monad/ReaderStateIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/ReaderStateIO.hs @@ -0,0 +1,60 @@ +{-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies -XFlexibleInstances #-} + +-- ------------------------------------------------------------ + +module Control.Monad.ReaderStateIO + ( module Control.Monad.ReaderStateIO + ) +where + +import Control.Monad.Reader +import Control.Monad.State + +-- ------------------------------------------------------------ + +-- | +-- reader state io monad implemented directly without any monad transformers + +newtype ReaderStateIO env state res = RSIO ( env -> state -> IO (res, state) ) + +instance Monad (ReaderStateIO env state) where + return v + = RSIO $ \ _e s -> return (v, s) + + RSIO cmd >>= f + = RSIO $ \ e s -> do + (r', s') <- cmd e s + let RSIO cmd2 = f r' + s' `seq` cmd2 e s' + +instance MonadIO (ReaderStateIO env state) where + liftIO a + = RSIO $ \ _e s -> do + r <- a + return (r, s) + +instance MonadState state (ReaderStateIO env state) where + get + = RSIO $ \ _e s -> return (s, s) + + put s + = RSIO $ \ _e _s -> return ((), s) + +instance MonadReader env (ReaderStateIO env state) where + ask + = RSIO $ \ e s -> return (e, s) + + local f (RSIO cmd) + = RSIO $ \ e s -> cmd (f e) s + +modifyIO :: (state -> IO state) -> ReaderStateIO env state () +modifyIO f = do + s0 <- get + s1 <- liftIO (f s0) + put s1 + +runReaderStateIO :: ReaderStateIO env state res -> env -> state -> IO (res, state) +runReaderStateIO (RSIO cmd) e s + = cmd e s + +-- ------------------------------------------------------------ diff --git a/src/Control/Sequential/MapFoldBinary.hs b/src/Control/Sequential/MapFoldBinary.hs new file mode 100644 --- /dev/null +++ b/src/Control/Sequential/MapFoldBinary.hs @@ -0,0 +1,127 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +{- | + Module : Control.Sequential.MapFoldBinary + Copyright : Copyright (C) 2010 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + + A map-fold function for interleaved map and fold. + The elements of a list are processed like in a binary tree. + +-} + +-- ------------------------------------------------------------ + +module Control.Sequential.MapFoldBinary + ( mapFoldBinary + , mapFoldBinaryM + ) +where + +-- ------------------------------------------------------------ + +-- | Pure version of binary map fold +-- +-- @mapFoldBinary id (+) [1..8]@ adds the elements of a list in the following order: +-- @(((1+2)+(3+4))+((5+6)+(7+8)))@ + +mapFoldBinary :: (a -> b) -> (b -> b -> b) -> [a] -> b +mapFoldBinary m f xs0 = fst $ mapLeft (1::Int) $ map1 xs0 + where + -- map1 :: [a] -> (b, [a]) + map1 (x:xs) = (m x, xs) + map1 [] = error "mapFoldBinary with empty list" + + -- mapLeft :: Int -> (b, [a]) -> (b, [a]) + mapLeft n (r1, xs1) + | null xs1 = (r1, []) + | null xs2 = (r, []) + | otherwise = mapLeft (n + 1) (r, xs2) + where + (r2, xs2) = mapRight n xs1 + r = f r1 r2 + + -- mapRight :: Int -> [a] -> (b, [a]) + mapRight 1 xs = map1 xs + mapRight n xs + | null xs1 = (r1, [] ) + | otherwise = (f r1 r2, xs2) + where + (r1, xs1) = mapRight (n - 1) xs + (r2, xs2) = mapRight (n - 1) xs1 + +-- ------------------------------------------------------------ +{- +t1 :: [Int] -> String +t1 = mapFoldBinary show (\ x y -> "(" ++ x ++ "+" ++ y ++ ")") + +r1 :: String +r1 = t1 [1..8] +-} +-- ------------------------------------------------------------ + +-- | Monadic version of a binary map fold +-- +-- The elements of a list are mapped and folded in the same way as in the pure version. +-- The map and fold operations are interleaved. In the above example the expressions are evaluated +-- from left to right, folding is performed, as early as possible. + + +mapFoldBinaryM :: (Monad m) => + (a -> m b) -> (b -> b -> m b) -> [a] -> m b +mapFoldBinaryM m f xs0 = do + r0 <- map1 xs0 + rn <- mapLeft (1::Int) r0 + return (fst rn) + where + -- map1 :: [a] -> m (b, [a]) + map1 (x:xs) = do + r1 <- m x + return (r1, xs) + map1 [] = error "mapFoldBinary with empty list" + + -- mapLeft :: Int -> (b, [a]) -> m (b, [a]) + mapLeft n r@(r1, xs1) + | null xs1 = return r + | otherwise = do + (r2, xs2) <- mapRight n xs1 + res <- f r1 r2 + ( if null xs2 + then return + else mapLeft (n + 1) ) (res, xs2) + + -- mapRight :: Int -> [a] -> m (b, [a]) + mapRight 1 xs = map1 xs + mapRight n xs = do + r@(r1, xs1) <- mapRight (n - 1) xs + if null xs1 + then return r + else do + (r2, xs2) <- mapRight (n - 1) xs1 + res <- f r1 r2 + return (res, xs2) + +-- ------------------------------------------------------------ +{- +t1m :: [Int] -> IO String +t1m = mapFoldBinaryM + ( \ x -> ( do + print x + return (show x) + ) + ) + ( \ x y -> ( do + putStrLn $ "(" ++ x ++ "+" ++ y ++ ")" + return $ "(" ++ x ++ "+" ++ y ++ ")" + ) + ) + +r1m :: IO String +r1m = t1m [1..8] +-} +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler.hs b/src/Holumbus/Crawler.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler.hs @@ -0,0 +1,30 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler + ( module Holumbus.Crawler.Constants + , module Holumbus.Crawler.Core + , module Holumbus.Crawler.Html + , module Holumbus.Crawler.Logger + , module Holumbus.Crawler.Robots + , module Holumbus.Crawler.RobotTypes + , module Holumbus.Crawler.Types + , module Holumbus.Crawler.URIs + , module Holumbus.Crawler.Util + , module Holumbus.Crawler.XmlArrows + ) +where + +import Holumbus.Crawler.Constants +import Holumbus.Crawler.Core +import Holumbus.Crawler.Html +import Holumbus.Crawler.Logger +import Holumbus.Crawler.Robots +import Holumbus.Crawler.RobotTypes +import Holumbus.Crawler.Types +import Holumbus.Crawler.URIs +import Holumbus.Crawler.Util +import Holumbus.Crawler.XmlArrows + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/CacheCore.hs b/src/Holumbus/Crawler/CacheCore.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/CacheCore.hs @@ -0,0 +1,144 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.CacheCore +where + +import Control.DeepSeq + +import Data.Binary ( Binary(..) ) +{- +import qualified Data.Binary as B +-- -} + +import Data.Function.Selector + +import Holumbus.Crawler + +import Text.XML.HXT.Core +import Text.XML.HXT.Curl + +-- ------------------------------------------------------------ + +type CacheCrawlerConfig = CrawlerConfig () CacheState +type CacheCrawlerState = CrawlerState CacheState + +newtype CacheState = CS () + +-- ------------------------------------------------------------ + +-- If CacheState was declared as alias for () this would be redundant, +-- but this can be taken as a pattern for other crawlers + +instance NFData CacheState where + +instance Binary CacheState where + put = const $ return () + get = return emptyCacheState + +instance XmlPickler CacheState where + xpickle = xpElem "cacheState" $ + xpWrap (const emptyCacheState, const ()) $ + xpUnit + +-- ------------------------------------------------------------ + +emptyCacheState :: CacheState +emptyCacheState = CS () + +-- ------------------------------------------------------------ + +unionCacheStatesM :: (Monad m) => CacheState -> CacheState -> m CacheState +unionCacheStatesM _s1 _s2 = return emptyCacheState + +insertCacheM :: (Monad m) => (URI, ()) -> CacheState -> m CacheState +insertCacheM _ _ = return emptyCacheState + +-- ------------------------------------------------------------ + +-- the cache crawler configureation + +cacheCrawlerConfig :: SysConfig -- ^ document read options + -> (URI -> Bool) -- ^ the filter for deciding, whether the URI shall be processed + -> CacheCrawlerConfig -- ^ result is a crawler config + +cacheCrawlerConfig opts followRef + = addSysConfig (defaultOpts >>> opts) -- install the default read options and + >>> -- overwrite and add specific read options + ( setS theFollowRef followRef ) + >>> + ( setS theProcessRefs getHtmlReferences ) + >>> + ( setS thePreDocFilter checkDocumentStatus ) -- in case of errors throw away any contents + >>> + ( setS theProcessDoc $ constA ()) + >>> + enableRobotsTxt -- add the robots stuff at the end + >>> -- the filter wrap the other filters + addRobotsNoFollow + >>> + addRobotsNoIndex + $ + defaultCrawlerConfig insertCacheM unionCacheStatesM + -- take the default crawler config + -- and set the result combining functions + where + defaultOpts = withCurl [ (curl_max_filesize, "1000000") -- limit document size to 1 Mbyte + , (curl_location, v_1) -- automatically follow redirects + , (curl_max_redirects, "3") -- but limit # of redirects to 3 + ] + >>> + withRedirect yes + >>> + withAcceptedMimeTypes ["text/html", "text/xhtml", "text/plain", "text/pdf"] + >>> + withInputEncoding isoLatin1 + >>> + withEncodingErrors no -- encoding errors and parser warnings are boring + >>> + withValidate no + >>> + withParseHTML yes + >>> + withWarnings no + +-- ------------------------------------------------------------ + +stdCacher :: (Int, Int, Int) -- ^ the parameters for parallel crawling + -> (Int, String) -- ^ the save intervall and file path + -> (Priority, Priority) -- ^ the log levels for the crawler and hxt + -> SysConfig -- ^ the read attributes + -> (CacheCrawlerConfig -> CacheCrawlerConfig) -- ^ further configuration settings + -> Maybe String -- ^ resume from interrupted index run with state stored in file + -> [URI] -- ^ start caching with this set of uris + -> (URI -> Bool) -> IO CacheCrawlerState + +stdCacher (maxDocs, maxParDocs, maxParThreads) + (saveIntervall, savePath) + (trc, trcx) + inpOptions + furtherConfigs + resumeLoc + startUris + followRef = execCrawler action config initState + where + initState = initCrawlerState emptyCacheState + action = do + noticeC "cacheCore" ["cache update started"] + maybe (crawlDocs startUris) crawlerResume $ resumeLoc + noticeC "cacheCore" ["cache update finished"] + + config = setCrawlerMaxDocs maxDocs maxParDocs maxParThreads + >>> + setCrawlerSaveConf saveIntervall savePath + >>> + setCrawlerTraceLevel trc trcx + >>> + enableRobotsTxt -- change to disableRobotsTxt, when robots.txt becomes boring + >>> + furtherConfigs + $ + cacheCrawlerConfig inpOptions followRef + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/Constants.hs b/src/Holumbus/Crawler/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/Constants.hs @@ -0,0 +1,36 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.Constants +where + +defaultCrawlerName :: String +defaultCrawlerName = "HolumBot/1.1 @http://holumbus.fh-wedel.de -" ++ "-location" + +curl_user_agent :: String +curl_user_agent = "curl-" ++ "-user-agent" + +curl_max_time :: String +curl_max_time = "curl-" ++ "-max-time" + +curl_connect_timeout :: String +curl_connect_timeout = "curl-" ++ "-connect-timeout" + +curl_max_filesize :: String +curl_max_filesize = "curl-" ++ "-max-filesize" + +curl_location :: String +curl_location = "curl-" ++ "-location" + +curl_max_redirects :: String +curl_max_redirects = "curl-" ++ "-max-redirs" + +http_location :: String +http_location = "http-location" + +http_last_modified :: String +http_last_modified = "http-Last-Modified" + +-- ------------------------------------------------------------ + diff --git a/src/Holumbus/Crawler/Core.hs b/src/Holumbus/Crawler/Core.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/Core.hs @@ -0,0 +1,391 @@ +{-# OPTIONS -XBangPatterns #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.Core +where + +import Control.Concurrent.MapFold ( mapFold ) +import Control.Sequential.MapFoldBinary ( mapFoldBinaryM ) +import Control.DeepSeq + +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.ReaderStateIO + +import Data.Binary ( Binary ) +import qualified Data.Binary as B -- else naming conflict with put and get from Monad.State + +import Data.Function.Selector + +import Data.List + +import Holumbus.Crawler.Constants +import Holumbus.Crawler.Logger +import Holumbus.Crawler.URIs +import Holumbus.Crawler.Robots +import Holumbus.Crawler.Types +import Holumbus.Crawler.Util ( mkTmpFile ) +import Holumbus.Crawler.XmlArrows + +import Text.XML.HXT.Core hiding + ( when + , getState + ) + +-- ------------------------------------------------------------ + +saveCrawlerState :: (Binary r) => FilePath -> CrawlerAction a r () +saveCrawlerState fn = do preSave + s <- get + liftIO $ B.encodeFile fn s + where + preSave = do act <- getConf theSavePreAction + act fn + +loadCrawlerState :: (Binary r) => FilePath -> CrawlerAction a r () +loadCrawlerState fn = do + s <- liftIO $ B.decodeFile fn + put s + + +uriProcessed :: URI -> CrawlerAction a r () +uriProcessed uri = do + modifyState theToBeProcessed $ deleteURI uri + modifyState theAlreadyProcessed $ insertURI uri + +urisProcessed :: URIs -> CrawlerAction a r () +urisProcessed uris = do + modifyState theToBeProcessed $ deleteURIs uris + modifyState theAlreadyProcessed $ flip unionURIs uris + +uriToBeProcessed :: URI -> Int -> CrawlerAction a r () +uriToBeProcessed uri level = do + aps <- getState theAlreadyProcessed + when ( not $ uri `memberURIs` aps ) + ( modifyState theToBeProcessed $ insertURI' uri level) + +urisToBeProcessed :: URIsWithLevel -> CrawlerAction a r () +urisToBeProcessed uris = do + aps <- getState theAlreadyProcessed + let newUris = deleteURIs aps uris + modifyState theToBeProcessed $ flip (unionURIs' min) newUris + +uriAddToRobotsTxt :: URI -> CrawlerAction a r () +uriAddToRobotsTxt uri = do + conf <- ask + let raa = getS theAddRobotsAction conf + modifyStateIO theRobots (raa conf uri) + +accumulateRes :: (NFData r) => (URI, a) -> CrawlerAction a r () +accumulateRes res = do + combine <- getConf theAccumulateOp + acc0 <- getState theResultAccu + acc1 <- liftIO $ combine res acc0 + putState theResultAccu acc1 + +-- ------------------------------------------------------------ + +crawlDocs :: (NFData a, NFData r, Binary r) => [URI] -> CrawlerAction a r () +crawlDocs uris = do + noticeC "crawlDocs" ["init crawler state and start crawler loop"] + putState theToBeProcessed (fromListURIs' $ zip uris (repeat 0)) + crawlerLoop + noticeC "crawlDocs" ["crawler loop finished"] + crawlerSaveState + +crawlerLoop :: (NFData a, NFData r, Binary r) => CrawlerAction a r () +crawlerLoop = do + n <- getState theNoOfDocs + m <- getConf theMaxNoOfDocs + t <- getConf theMaxParThreads + when (n < m) + ( do + noticeC "crawlerLoop" ["iteration", show $ n+1] + tbp <- getState theToBeProcessed + noticeC "crawlerLoop" [show $ cardURIs tbp, "uri(s) remain to be processed"] + when (not . nullURIs $ tbp) + ( do + case t of + 0 -> crawlNextDoc -- sequential crawling + 1 -> crawlNextDocs mapFoldBinaryM -- sequential crawling with binary mapFold + _ -> crawlNextDocs (mapFold t) -- parallel mapFold crawling + crawlerCheckSaveState + crawlerLoop + ) + ) + +crawlerResume :: (NFData a, NFData r, Binary r) => String -> CrawlerAction a r () +crawlerResume fn = do + noticeC "crawlerResume" ["read crawler state from", fn] + loadCrawlerState fn + noticeC "crawlerResume" ["resume crawler"] + crawlerLoop + +crawlerCheckSaveState :: Binary r => CrawlerAction a r () +crawlerCheckSaveState = do + n1 <- getState theNoOfDocs + n0 <- getState theNoOfDocsSaved + m <- getConf theSaveIntervall + when ( m > 0 && n1 - n0 >= m) + crawlerSaveState + +crawlerSaveState :: Binary r => CrawlerAction a r () +crawlerSaveState = do + n1 <- getState theNoOfDocs + n0 <- getState theNoOfDocsSaved + when (n1 > n0) -- else state has already been saved, don't do it twice + ( do + fn <- getConf theSavePathPrefix + let fn' = mkTmpFile 10 fn n1 + noticeC "crawlerSaveState" [show n1, "documents into", show fn'] + putState theNoOfDocsSaved n1 + modifyState theListOfDocsSaved (n1 :) + saveCrawlerState fn' + noticeC "crawlerSaveState" ["saving state finished"] + ) + +-- ------------------------------------------------------------ + +type MapFold a r = (a -> IO r) -> (r -> r -> IO r) -> [a] -> IO r + +crawlNextDocs :: (NFData r) => MapFold URIWithLevel (URIs, URIsWithLevel, r) -> CrawlerAction a r () +crawlNextDocs mapf = do + uris <- getState theToBeProcessed + nd <- getState theNoOfDocs + + mp <- getConf theMaxParDocs + md <- getConf theMaxNoOfDocs + + let n = mp `min` (md - nd) + let urisTBP = nextURIs n uris + + modifyState theNoOfDocs (+ (length urisTBP)) + + noticeC "crawlNextDocs" ["next", show (length urisTBP), "uri(s) will be processed"] + + urisProcessed $ fromListURIs $ map fst urisTBP + urisAllowed <- filterM (isAllowedByRobots . fst) urisTBP + + when (not . null $ urisAllowed) $ + do + conf <- ask + let mergeOp = getS theFoldOp conf + + state' <- get + ( ! urisMoved, + ! urisNew, + ! results + ) <- liftIO $ + mapf (processCmd conf state') (combineDocResults' mergeOp) $ + urisAllowed + + noticeC "crawlNextDocs" [show . cardURIs $ urisNew, "hrefs found, accumulating results"] + mapM_ (debugC "crawlNextDocs") $ map (("href" :) . (:[])) $ toListURIs urisNew + urisProcessed urisMoved + urisToBeProcessed urisNew + acc0 <- getState theResultAccu + ! acc1 <- liftIO $ mergeOp results acc0 + putState theResultAccu acc1 + noticeC "crawlNextDocs" ["document results accumulated"] + + where + processCmd c s u = do + noticeC "processCmd" ["processing document:", show u] + ((m1, n1, rawRes), _) <- runCrawler (processDoc' u) c s + r1 <- foldM (flip accOp) res0 rawRes + rnf r1 `seq` rnf m1 `seq` rnf r1 `seq` + noticeC "processCmd" ["document processed: ", show u] + return (m1, n1, r1) + where + res0 = getS theResultInit s + accOp = getS theAccumulateOp c + +-- ------------------------------------------------------------ + +processDoc' :: URIWithLevel -> CrawlerAction a r (URIs, URIsWithLevel, [(URI, a)]) +processDoc' (uri, lev) = do + conf <- ask + [(uri', (uris', docRes))] <- liftIO $ runX (processDocArrow conf uri) + let toBeFollowed = getS theFollowRef conf + let maxLevel = getS theClickLevel conf + let ! lev1 = lev + 1 + let movedUris = if null uri' + then emptyURIs + else singletonURIs uri' + let newUris = if lev >= maxLevel + then emptyURIs + else fromListURIs' + . map (\ u -> (u, lev1)) + . filter toBeFollowed + $ uris' + return (movedUris, newUris, docRes) + +-- ------------------------------------------------------------ + +combineDocResults' :: (NFData r) => + MergeDocResults r -> + (URIs, URIsWithLevel, r) -> + (URIs, URIsWithLevel, r) -> IO (URIs, URIsWithLevel, r) +combineDocResults' mergeOp (m1, n1, r1) (m2, n2, r2) + = do + noticeC "crawlNextDocs" ["combining results"] + r <- mergeOp r1 r2 + m <- return $ unionURIs m1 m2 + n <- return $ unionURIs' min n1 n2 + res <- return $ (m, n, r) + rnf res `seq` + noticeC "crawlNextDocs" ["results combined"] + return res + +-- ------------------------------------------------------------ +-- +-- | crawl a single doc, mark doc as processed, collect new hrefs and combine doc result with accumulator in state + +crawlNextDoc :: (NFData a, NFData r) => CrawlerAction a r () +crawlNextDoc = do + uris <- getState theToBeProcessed + modifyState theNoOfDocs (+1) + let uri@(u, _lev) = nextURI uris + noticeC "crawlNextDoc" [show uri] + uriProcessed u -- uri is put into processed URIs + isGood <- isAllowedByRobots u + when isGood $ + do + res <- processDoc uri -- get document and extract new refs and result + let (uri', uris', resList') = rnf res `seq` res -- force evaluation + + when (not . null $ uri') $ + uriProcessed uri' -- doc has been moved, uri' is real uri, so it's also put into the set of processed URIs + + noticeC "crawlNextDoc" [show . length . nub . sort $ uris', "new uris found"] + mapM_ (uncurry uriToBeProcessed) uris' -- insert new uris into toBeProcessed set + mapM_ accumulateRes resList' -- combine results with state accu + +-- | Run the process document arrow and prepare results + +processDoc :: URIWithLevel -> CrawlerAction a r (URI, [URIWithLevel], [(URI, a)]) +processDoc (uri, lev) = do + conf <- ask + let maxLevel = getS theClickLevel conf + let ! lev1 = lev + 1 + [(uri', (uris, res))] <- liftIO $ runX (processDocArrow conf uri) + let newUris = if lev >= maxLevel + then [] + else map (\ u -> (u, lev1)) + . filter (getS theFollowRef conf) + $ uris + return ( if uri' /= uri + then uri' + else "" + , newUris + , res -- usually in case of normal processing this is a singleton list + ) + -- and in case of an error it's an empty list +-- ------------------------------------------------------------ + +-- | filter uris rejected by robots.txt + +isAllowedByRobots :: URI -> CrawlerAction a r Bool +isAllowedByRobots uri = do + uriAddToRobotsTxt uri -- for the uri host, a robots.txt is loaded, if neccessary + rdm <- getState theRobots + if (robotsDisallow rdm uri) -- check, whether uri is disallowed by host/robots.txt + then do + noticeC "isAllowedByRobot" ["uri rejected by robots.txt", show uri] + return False + else do + -- noticeC "isAllowedByRobot" ["uri allowed by robots.txt", show uri] + return True + +-- ------------------------------------------------------------ + +-- | From a document two results are computed, 1. the list of all hrefs in the contents, +-- and 2. the collected info contained in the page. This result is augmented with the transfer uri +-- such that following functions know the source of this contents. The transfer-URI may be another one +-- as the input uri, there could happen a redirect in the http request. +-- +-- The two listA arrows make the whole arrow deterministic, so it never fails + +processDocArrow :: CrawlerConfig c r -> URI -> IOSArrow a (URI, ([URI], [(URI, c)])) + +processDocArrow c uri = ( hxtSetTraceAndErrorLogger (getS theTraceLevelHxt c) + >>> + readDocument [getS theSysConfig c] uri + >>> + perform ( ( getAttrValue transferStatus + &&& + getAttrValue transferMessage + ) + >>> + ( arr2 $ \ s m -> unwords ["processDocArrow: response code:", s, m] ) + >>> + traceString 1 id + ) + >>> + ( getRealDocURI + &&& + listA ( checkDocumentStatus + >>> + getS thePreRefsFilter c + >>> + getS theProcessRefs c + ) + &&& + listA ( getS thePreDocFilter c + >>> + ( getAttrValue transferURI + &&& + getS theProcessDoc c + ) + ) + ) + ) + `withDefault` ("", ([], [])) + +-- ------------------------------------------------------------ + +-- | compute the real URI in case of a 301 or 302 response (moved permanently or temporary), +-- else the arrow will fail + +getLocationReference :: ArrowXml a => a XmlTree String +getLocationReference = fromLA $ + ( getAttrValue0 transferStatus + >>> + isA (`elem` ["301", "302"]) + ) + `guards` + getAttrValue0 http_location + +-- | compute the real URI of the document, in case of a move response +-- this is contained in the \"http-location\" attribute, else it's the +-- tranferURI. + +getRealDocURI :: ArrowXml a => a XmlTree String +getRealDocURI = fromLA $ + getLocationReference + `orElse` + getAttrValue transferURI + +-- ------------------------------------------------------------ + +initCrawler :: CrawlerAction a r () +initCrawler = do + conf <- ask + setLogLevel "" (getS theTraceLevel conf) + + +runCrawler :: CrawlerAction a r x -> + CrawlerConfig a r -> + CrawlerState r -> IO (x, CrawlerState r) +runCrawler a = runReaderStateIO (initCrawler >> a) + +-- run a crawler and deliver just the accumulated result value + +execCrawler :: CrawlerAction a r x -> + CrawlerConfig a r -> + CrawlerState r -> IO (CrawlerState r) +execCrawler cmd config initState + = runCrawler cmd config initState >>= return . snd + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/Html.hs b/src/Holumbus/Crawler/Html.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/Html.hs @@ -0,0 +1,195 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.Html +where + +import Data.Function.Selector + +import Data.List +import Data.Maybe + +import Holumbus.Crawler.Types +import Holumbus.Crawler.URIs + +import System.FilePath + +import Text.XML.HXT.Core hiding ( when + , getState + ) +{- just for debugging +import qualified Debug.Trace as D +-- -} +-- ------------------------------------------------------------ + +defaultHtmlCrawlerConfig :: AccumulateDocResult a r -> + MergeDocResults r -> CrawlerConfig a r +defaultHtmlCrawlerConfig op op2 = ( setS theSysConfig + ( withValidate no + >>> + withParseHTML yes + >>> + withInputEncoding isoLatin1 + >>> + withWarnings no + >>> + withIgnoreNoneXmlContents yes + ) + >>> + setS thePreRefsFilter this + >>> + setS theProcessRefs getHtmlReferences + $ + defaultCrawlerConfig op op2 + ) + +-- ------------------------------------------------------------ + +-- | Collect all HTML references to other documents within a, frame and iframe elements + +getHtmlReferences :: ArrowXml a => a XmlTree URI +getHtmlReferences = fromLA (getRefs $< computeDocBase) + where + getRefs base = deep (hasNameWith + ( (`elem` ["a","frame","iframe"]) . localPart ) + ) + >>> + ( getAttrValue0 "href" + <+> + getAttrValue0 "src" + ) + >>^ toAbsRef base + +getDocReferences :: ArrowXml a => a XmlTree URI +getDocReferences = fromLA (getRefs $< computeDocBase) + where + getRefs base = multi selRefs >>^ toAbsRef base + where + hasLocName n = hasNameWith ((== n) . localPart) + selRef en an = hasLocName en :-> getAttrValue0 an + selRefs = choiceA $ + map (uncurry selRef) names + ++ + [ appletRefs + , objectRefs + , this :-> none + ] + names = [ ("img", "src") + , ("input", "src") -- input type="image" scr="..." + , ("link", "href") + , ("script", "src") + ] + appletRefs = hasLocName "applet" :-> (getAppRef $< getAppBase) + where + getAppBase = (getAttrValue0 "codebase" `withDefault` ".") >>^ toAbsRef base + getAppRef ab = getAttrValue0 "code" >>^ toAbsRef ab + + objectRefs = hasLocName "object" :-> none -- TODO + +-- | construct an absolute URI by a base URI and a possibly relative URI + +toAbsRef :: URI -> URI -> URI +toAbsRef base ref = ( expandURIString ref -- here >>> is normal function composition + >>> + fromMaybe ref + >>> + removeFragment + ) base + where + removeFragment r + | "#" `isPrefixOf` path = reverse . tail $ path + | otherwise = r + where + path = dropWhile (/='#') . reverse $ r + +-- ------------------------------------------------------------ + +-- | Compute the base URI of a HTML page with respect to a possibly +-- given base element in the head element of a html page. +-- +-- Stolen from Uwe Schmidt, http:\/\/www.haskell.org\/haskellwiki\/HXT +-- and then stolen back again by Uwe from Holumbus.Utility + +computeDocBase :: ArrowXml a => a XmlTree String +computeDocBase = ( ( ( getByPath ["html", "head", "base"] + >>> + getAttrValue "href" -- and compute document base with transfer uri and base + ) + &&& + getAttrValue transferURI + ) + >>> expandURI + ) + `orElse` + getAttrValue transferURI -- the default: take the transfer uri + +-- ------------------------------------------------------------ + +getByPath :: ArrowXml a => [String] -> a XmlTree XmlTree +getByPath = seqA . map (\ n -> getChildren >>> hasName n) + +getHtmlTitle :: ArrowXml a => a XmlTree String +getHtmlTitle = getAllText $ + getByPath ["html", "head", "title"] + +getHtmlPlainText :: ArrowXml a => a XmlTree String +getHtmlPlainText = getAllText $ + getByPath ["html", "body"] + +getAllText :: ArrowXml a => a XmlTree XmlTree -> a XmlTree String +getAllText getText' = ( getText' + >>> + ( fromLA $ deep getText ) + >>^ + (" " ++) -- text parts are separated by a space + ) + >. (concat >>> normalizeWS) -- normalize Space + +isHtmlContents :: ArrowXml a => a XmlTree XmlTree +isHtmlContents = ( getAttrValue transferMimeType + >>> + isA ( `elem` [text_html, application_xhtml] ) + ) `guards` this + +isPdfContents :: ArrowXml a => a XmlTree XmlTree +isPdfContents = ( getAttrValue transferMimeType + >>> + isA ( == application_pdf ) + ) `guards` this + +getTitleOrDocName :: ArrowXml a => a XmlTree String +getTitleOrDocName = ( getHtmlTitle >>> isA (not . null) ) + `orElse` + ( getAttrValue transferURI >>^ takeFileName ) + +isElemWithAttr :: ArrowXml a => String -> String -> (String -> Bool) -> a XmlTree XmlTree +isElemWithAttr en an av = isElem + >>> + hasName en + >>> + hasAttrValue an av + +-- ------------------------------------------------------------ + +application_pdf :: String +application_pdf = "application/pdf" + +-- ------------------------------------------------------------ + +-- | normalize whitespace by splitting a text into words and joining this together with unwords + +normalizeWS :: String -> String +normalizeWS = words >>> unwords + +-- | take the first n chars of a string, if the input +-- is too long the cut off is indicated by \"...\" at the end + +limitLength :: Int -> String -> String +limitLength n s + | length s' <= n = s + | otherwise = take (n - 3) s' ++ "..." + where + s' = take (n + 1) s + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/IndexerCore.hs b/src/Holumbus/Crawler/IndexerCore.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/IndexerCore.hs @@ -0,0 +1,281 @@ +{-# OPTIONS -XFlexibleContexts -XBangPatterns #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.IndexerCore + ( RawDoc + , RawContexts + , RawContext + , RawWords + , RawWord + , RawTitle + , IndexCrawlerConfig + , IndexContextConfig(..) + , IndexerState(..) + , emptyIndexerState + , indexCrawlerConfig + , stdIndexer + , unionIndexerStatesM + , insertRawDocM + ) +where + +-- ------------------------------------------------------------ + +import Control.DeepSeq +import Control.Monad ( foldM ) +import Control.Monad.Trans -- ( MonadIO ) + +import Data.Binary ( Binary ) +import qualified Data.Binary as B +import Data.Function.Selector +import Data.Maybe + +import Holumbus.Crawler + +import Holumbus.Index.Common hiding ( URI ) + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +type RawDoc c = (RawContexts, RawTitle, Maybe c) -- c is the user defined custom info +type RawContexts = [RawContext] +type RawContext = (Context, RawWords) +type RawWords = [RawWord] +type RawWord = (Word, Position) +type RawTitle = String + +type IndexCrawlerConfig i d c = CrawlerConfig (RawDoc c) (IndexerState i d c) +type IndexCrawlerState i d c = CrawlerState (IndexerState i d c) + +data IndexContextConfig = IndexContextConfig + { ixc_name :: String + , ixc_collectText :: IOSArrow XmlTree String + , ixc_textToWords :: String -> [String] + , ixc_boringWord :: String -> Bool + } + +data IndexerState i d c = IndexerState + { ixs_index :: ! i -- the index type + , ixs_documents :: ! (d c) -- the type for document descriptions + } deriving (Show) + +-- ------------------------------------------------------------ + +instance (NFData i, NFData (d c)) => NFData (IndexerState i d c) + where + rnf IndexerState { ixs_index = i + , ixs_documents = d + } = rnf i `seq` rnf d + +-- ------------------------------------------------------------ + +instance (Binary i, Binary (d c)) => Binary (IndexerState i d c) + where + put s = B.put (ixs_index s) + >> + B.put (ixs_documents s) + get = do + ix <- B.get + dm <- B.get + return $ IndexerState + { ixs_index = ix + , ixs_documents = dm + } + +-- ------------------------------------------------------------ + +instance (XmlPickler i, XmlPickler (d c)) => XmlPickler (IndexerState i d c) + where + xpickle = xpElem "index-state" $ + xpWrap ( uncurry IndexerState + , \ ix -> (ixs_index ix, ixs_documents ix) + ) $ + xpPair xpickle xpickle + +-- ------------------------------------------------------------ + +emptyIndexerState :: i -> d c -> IndexerState i d c +emptyIndexerState eix edm = IndexerState + { ixs_index = eix + , ixs_documents = edm + } + +-- ------------------------------------------------------------ + +stdIndexer :: ( Binary i + , Binary (d c) + , Binary c + , HolIndexM IO i + , HolDocuments d c + , NFData i + , NFData (d c) + , NFData c) => + IndexCrawlerConfig i d c -- ^ adapt configuration to special needs, + -- use id if default is ok + -> Maybe String -- ^ resume from interrupted index run with state + -- stored in file + -> [URI] -- ^ start indexing with this set of uris + -> IndexerState i d c -- ^ the initial empty indexer state + -> IO (IndexCrawlerState i d c) -- ^ result is a state consisting of the index and the map of indexed documents + +stdIndexer config resumeLoc startUris eis + = execCrawler action config (initCrawlerState eis) + where + action = do + noticeC "indexerCore" ["indexer started"] + res <- maybe (crawlDocs startUris) crawlerResume $ resumeLoc + noticeC "indexerCore" ["indexer finished"] + return res + +-- ------------------------------------------------------------ + +-- general HolIndexM IO i version, for old specialized version see code at end of this file + +indexCrawlerConfig :: ( HolIndexM IO i + , HolDocuments d c + , HolDocIndex d c i + , NFData i + , NFData c + , NFData (d c) + ) => + SysConfig -- ^ document read options + -> (URI -> Bool) -- ^ the filter for deciding, whether the URI shall be processed + -> Maybe (IOSArrow XmlTree String) -- ^ the document href collection filter, default is 'Holumbus.Crawler.Html.getHtmlReferences' + -> Maybe (IOSArrow XmlTree XmlTree) -- ^ the pre document filter, default is the this arrow + -> Maybe (IOSArrow XmlTree String) -- ^ the filter for computing the document title, default is empty string + -> Maybe (IOSArrow XmlTree c) -- ^ the filter for the cutomized doc info, default Nothing + -> [IndexContextConfig] -- ^ the configuration of the various index parts + -> IndexCrawlerConfig i d c -- ^ result is a crawler config + +indexCrawlerConfig opts followRef getHrefF preDocF titleF0 customF0 contextCs + = addSysConfig (defaultOpts >>> opts) -- install the default read options + >>> + ( setS theFollowRef followRef ) + >>> + ( setS theProcessRefs $ fromMaybe getHtmlReferences getHrefF ) + >>> + ( setS thePreDocFilter $ fromMaybe checkDocumentStatus preDocF ) -- in case of errors throw away any contents + >>> + ( setS theProcessDoc rawDocF ) -- rawDocF is build up by the context config, text, title and custom + >>> + enableRobotsTxt -- add the robots stuff at the end + >>> -- the filter wrap the other filters + addRobotsNoFollow + >>> + addRobotsNoIndex + $ + defaultCrawlerConfig insertRawDocM unionIndexerStatesM + -- take the default crawler config + -- and set the result combining functions + where + rawDocF = ( listA contextFs + &&& + titleF + &&& + customF + ) + >>^ (\ (x3, (x2, x1)) -> (x3, x2, x1)) + + titleF = ( fromMaybe (constA "") titleF0 ) >. concat + + customF = ( fromMaybe none customF0 ) >. listToMaybe + + contextFs :: IOSArrow XmlTree RawContext + contextFs = catA . map contextF $ contextCs -- collect all contexts + + contextF :: IndexContextConfig -> IOSArrow XmlTree RawContext + contextF ixc = constA (ixc_name ixc) -- the name of the raw context + &&& + ( ixc_collectText ixc >. processText ) -- the list of words and positions of the collected text + where -- this arrow is deterministic, it always delivers a single pair + processText :: [String] -> RawWords + processText = concat + >>> + ixc_textToWords ixc + >>> + flip zip [1..] + >>> + filter (fst >>> ixc_boringWord ixc >>> not) + + defaultOpts = withRedirect yes + >>> + withAcceptedMimeTypes ["text/html", "text/xhtml"] + >>> + withInputEncoding isoLatin1 + >>> + withEncodingErrors no -- encoding errors and parser warnings are boring + >>> + withValidate no + >>> + withParseHTML yes + >>> + withWarnings no + +-- ------------------------------------------------------------ + +unionIndexerStatesM :: ( MonadIO m + , HolIndexM m i + , HolDocuments d c + , HolDocIndex d c i + ) => + IndexerState i d c + -> IndexerState i d c + -> m (IndexerState i d c) +unionIndexerStatesM ixs1 ixs2 + = return + $! IndexerState { ixs_index = ix + , ixs_documents = dt + } + where + (! dt, ! ix) = unionDocIndex dt1 ix1 dt2 ix2 + ix1 = ixs_index ixs1 + ix2 = ixs_index ixs2 + dt1 = ixs_documents ixs1 + dt2 = ixs_documents ixs2 + +-- ------------------------------------------------------------ + +insertRawDocM :: ( MonadIO m + , HolIndexM m i + , HolDocuments d c + , NFData i + , NFData c + , NFData (d c) + ) => + (URI, RawDoc c) -- ^ extracted URI and doc info + -> IndexerState i d c -- ^ old indexer state + -> m (IndexerState i d c) -- ^ new indexer state + +insertRawDocM (rawUri, (rawContexts, rawTitle, rawCustom)) ixs + | nullContexts = return ixs -- no words found in document, + -- so there are no refs in index + -- and document is thrown away + | otherwise = do + newIx <- foldM (insertRawContextM did) (ixs_index ixs) $ rawContexts + newIxs <- return $ + IndexerState { ixs_index = newIx + , ixs_documents = newDocs + } + rnf newIxs `seq` + return newIxs + where + nullContexts = and . map (null . snd) $ rawContexts + (did, newDocs) = insertDoc (ixs_documents ixs) doc + doc = Document + { title = rawTitle + , uri = rawUri + , custom = rawCustom + } + +insertRawContextM :: (Monad m, HolIndexM m i) => + DocId -> i -> (Context, [(Word, Position)]) -> m i +insertRawContextM did ix (cx, ws) + = foldM (insWordM cx did) ix ws + +insWordM :: (Monad m, HolIndexM m i) => + Context -> DocId -> i -> (Word, Position) -> m i +insWordM cx' did' ix' (w', p') = insertPositionM cx' w' did' p' ix' + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/Logger.hs b/src/Holumbus/Crawler/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/Logger.hs @@ -0,0 +1,137 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.Logger + ( hxtLoggerName + , hxtSetTraceAndErrorLogger + , hxtSetLogLevel + , hxtSetErrorLog + + , module System.Log.Logger + + , logC + , noticeC + , infoC + , debugC + , warnC + , errC + + , setLogLevel + ) +where + +import Control.Monad.Trans + +import Data.List ( isPrefixOf ) + +import System.Log.Logger + +import Text.XML.HXT.Core + +crawlLoggerName :: String +crawlLoggerName = "crawl2" + +hxtLoggerName :: String +hxtLoggerName = "hxt" + +-- ------------------------------------------------------------ + +-- | Set trace level in config + +logC :: MonadIO m => String -> Priority -> [String] -> m () +logC logName' priority msg = liftIO $ logC' logName' priority msg + +noticeC + , infoC + , debugC + , warnC + , errC :: MonadIO m => String -> [String] -> m () + +noticeC n = logC n NOTICE +infoC n = logC n INFO +debugC n = logC n DEBUG +warnC n = logC n WARNING +errC n = logC n ERROR + +setLogLevel :: MonadIO m => String -> Priority -> m () +setLogLevel logName' priority = liftIO $ setLogLevel' logName' priority + +setLogLevel' :: String -> Priority -> IO () +setLogLevel' logName' priority = updateGlobalLogger (realLogName logName') (setLevel priority) + +-- ------------------------------------------------------------ + +realLogName :: String -> String +realLogName logName + | null logName = crawlLoggerName + | otherwise = crawlLoggerName ++ "." ++ logName + + +logC' :: String -> Priority -> [String] -> IO () +logC' logName' priority msg = logM logName priority msg' + where + logName = realLogName logName' + msg' = fillName 23 logName ++ " " ++ + fillName 9 (show priority) ++ " " ++ + unwords msg + +fillName :: Int -> String -> String +fillName n s = s ++ replicate b ' ' + where + b = (n - length s) `max` 0 + +-- ------------------------------------------------------------ + +hxtLogger :: Int -> String -> IO () +hxtLogger level msg = logC' hxtLoggerName priority [msg'] + where + msg' + | "-- (" `isPrefixOf` msg = drop 7 msg + | otherwise = msg + + priority = toPriority level + + toPriority l + | l <= 0 = NOTICE -- trace level 0 is issued as NOTICE, not as WARNING + | l == 1 = NOTICE + | l == 2 = INFO + | otherwise = DEBUG -- level >= 3 + +hxtSetTraceAndErrorLogger :: Priority -> IOStateArrow s b b +hxtSetTraceAndErrorLogger priority + = hxtSetLogLevel priority + >>> + hxtSetErrorLog + +hxtSetLogLevel :: Priority -> IOStateArrow s b b +hxtSetLogLevel priority + = setTraceLevel (fromPriority priority) + >>> + setTraceCmd hxtLogger + >>> + perform ( arrIO0 $ + updateGlobalLogger hxtLoggerName (setLevel priority) + ) + where + fromPriority NOTICE = 1 + fromPriority INFO = 2 + fromPriority DEBUG = 3 + fromPriority _ = 0 + +hxtSetErrorLog :: IOStateArrow s b b +hxtSetErrorLog = setErrorMsgHandler False hxtErrorLogger + +hxtErrorLogger :: String -> IO () +hxtErrorLogger msg = logC' hxtLoggerName + priority + [drop 1 . dropWhile (/= ':') $ msg] + where + priority = prio . drop 1 $ msg + prio m + | "fatal" `isPrefixOf` m = CRITICAL + | "error" `isPrefixOf` m = ERROR + | "warning" `isPrefixOf` m = WARNING + | otherwise = NOTICE + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/PdfToText.hs b/src/Holumbus/Crawler/PdfToText.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/PdfToText.hs @@ -0,0 +1,59 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.PdfToText +where + +import qualified Control.Exception as CE + +import qualified Data.ByteString.Lazy as BS +import Data.String.Unicode ( utf8ToUnicode ) + +import System.Directory ( getTemporaryDirectory + , removeFile + ) +import System.FilePath ( () ) +import System.Process ( rawSystem ) +import System.Posix.Process ( getProcessID ) + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +-- | Converstion of pdf data into plain text. The conversion is done +-- by calling an external program @pdftotext@ (contained in linux packages @xpdf@). +-- IO is done via the ByteString API. + +pdfToText :: String -> IO String +pdfToText = pdfToTextBS . BS.pack . map (toEnum . fromEnum) + +pdfToTextBS :: BS.ByteString -> IO String +pdfToTextBS inp = ( do + td <- getTemporaryDirectory + pid <- getProcessID + let fn1 = fn td pid "pdfToText.pdf" + let fn2 = fn td pid "pdfToText.txt" + BS.writeFile fn1 inp + _ <- rawSystem "pdftotext" ["-q", "-enc", "UTF-8", fn1, fn2] + removeFile fn1 + res <- BS.readFile fn2 + BS.length res `seq` + removeFile fn2 + + return ( fst . utf8ToUnicode . map (toEnum . fromEnum) . BS.unpack $ res ) + ) `mycatch` ( const $ return "" ) + where + fn d p f = d (show p ++ "-" ++ f) + + mycatch :: IO a -> (CE.SomeException -> IO a) -> IO a + mycatch = CE.catch + +pdfToTextA :: IOSArrow String String +pdfToTextA = perform ( traceString 2 (("pdfToTextA input:\n" ++) . take 128 . show) ) + >>> + arrIO pdfToText + >>> + perform ( traceString 2 (( "pdfToText result:\n" ++ ) . take 128 . show) ) + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/RobotTypes.hs b/src/Holumbus/Crawler/RobotTypes.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/RobotTypes.hs @@ -0,0 +1,115 @@ +-- ------------------------------------------------------------ + +module Holumbus.Crawler.RobotTypes +where + +import Control.DeepSeq + +import Data.Binary ( Binary ) +import qualified Data.Binary as B +import Data.Char +import qualified Data.Map as M + +import Holumbus.Crawler.URIs + +import Text.XML.HXT.Core + +{- +import Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch + +import qualified Debug.Trace as D +-} + +-- ------------------------------------------------------------ + +type Robots = M.Map URI RobotRestriction +type RobotRestriction = [RobotSpec] +type RobotSpec = (URI, RobotAction) + +data RobotAction = Disallow | Allow + deriving (Eq, Show, Read, Enum) + +type AddRobotsAction = URI -> Robots -> IO Robots + +-- ------------------------------------------------------------ + +instance Binary RobotAction where + put = B.put . fromEnum + get = do + b <- B.get + return (toEnum b) + +instance NFData RobotAction where + rnf x = x `seq` () + +instance XmlPickler RobotAction where + xpickle = xpPrim + +xpRobots :: PU Robots +xpRobots = xpElem "robots" $ + xpMap "robot" "host" xpText xpRobotRestriction + +xpRobotRestriction :: PU RobotRestriction +xpRobotRestriction = xpList $ + xpElem "restriction" $ + xpPair ( xpAttr "href" $ xpText ) + ( xpAttr "access" $ xpickle ) + +-- ------------------------------------------------------------ + +emptyRobots :: Robots +emptyRobots = M.singleton "" [] + +robotsExtend :: String -> AddRobotsAction +robotsExtend _robotName _uri robots + = return robots -- TODO + +robotsIndex :: URI -> Robots -> Bool +robotsIndex _uri _robots + = True -- TODO + +robotsFollow :: URI -> Robots -> Bool +robotsFollow _uri _robots + = True -- TODO + +-- ------------------------------------------------------------ + +robotsNo :: String -> LA XmlTree XmlTree +robotsNo what = none + `when` + ( this + /> hasName "html" + /> hasName "head" + /> hasName "meta" -- getByPath ["html", "head", "meta"] + >>> + hasAttrValue "name" ( map toUpper + >>> + (== "ROBOTS") + ) + >>> + getAttrValue0 "content" + >>> + isA ( map (toUpper + >>> + (\ x -> if isLetter x then x else ' ') + ) + >>> + words + >>> + (what `elem`) + ) + ) + +-- | robots no index filter. This filter checks HTML documents +-- for a \ in the head of the document + +robotsNoIndex :: ArrowXml a => a XmlTree XmlTree +robotsNoIndex = fromLA $ robotsNo "NOINDEX" + +-- | robots no follow filter. This filter checks HTML documents +-- for a \ in the head of the document + +robotsNoFollow :: ArrowXml a => a XmlTree XmlTree +robotsNoFollow = fromLA $ robotsNo "NOFOLLOW" + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/Robots.hs b/src/Holumbus/Crawler/Robots.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/Robots.hs @@ -0,0 +1,205 @@ +-- ------------------------------------------------------------ + +module Holumbus.Crawler.Robots +where + +import Control.DeepSeq + +import Data.Function.Selector + +import Data.List +import qualified Data.Map as M +import Data.Maybe + +import Holumbus.Crawler.URIs +import Holumbus.Crawler.RobotTypes +import Holumbus.Crawler.Types +import Holumbus.Crawler.Logger + +import qualified Network.URI as N + +import Text.XML.HXT.Core +import Text.XML.HXT.Cache + +{- +import Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch + +import qualified Debug.Trace as D +-} + +-- ------------------------------------------------------------ + +-- | Add a robots.txt description for a given URI, if it's not already there. +-- The 1. main function of this module + +robotsAddHost :: CrawlerConfig a r -> AddRobotsAction +robotsAddHost conf uri rdm + | not (isRobotsScheme uri) + = return rdm + | isJust spec = return rdm + | otherwise = do + (h, r) <- robotsGetSpec conf host + let rdm' = M.insert h r rdm + return $! rdm' + where + host = getHost uri + spec = M.lookup host rdm + +-- ------------------------------------------------------------ + +robotsDontAddHost :: CrawlerConfig a r -> AddRobotsAction +robotsDontAddHost = const $ const return + +-- ------------------------------------------------------------ + +-- | Check whether a robot is not allowed to access a page. +-- The 2. main function of this module + +robotsDisallow :: Robots -> URI -> Bool +robotsDisallow rdm uri + | not (isRobotsScheme uri) + = False + | isNothing restr = False + | otherwise = evalRestr $ fromJust restr + where + host = getHost uri + path' = getURIPart N.uriPath uri + restr = M.lookup host rdm + evalRestr = foldr isDis False + where + isDis (r, a) v + | r `isPrefixOf` path' + && + not (null r) = a == Disallow + | otherwise = v + +-- ------------------------------------------------------------ + +getURIPart :: (N.URI -> String) -> URI -> String +getURIPart f = maybe "" f + . + N.parseURIReference + +-- | Get the protocol-host-port part of an URI + +getHost :: URI -> URI +getHost = getURIPart h + where + h u = show $ u { N.uriPath = "" + , N.uriQuery = "" + , N.uriFragment = "" + } + +isRobotsScheme :: URI -> Bool +isRobotsScheme = (`elem` ["http:", "https:"]) . getURIPart N.uriScheme + +-- ------------------------------------------------------------ + +-- | Access, parse and evaluate a robots.txt file for a given URI + +robotsGetSpec :: CrawlerConfig a r -> URI -> IO (URI, RobotRestriction) +robotsGetSpec conf uri + | not (isRobotsScheme uri) + = return ("", []) + | null host = return ("", []) + | otherwise = do + r <- getRobotsTxt conf host + s <- return $ evalRobotsTxt agent r + rnf s `seq` return (host, s) + where + host = getHost uri + agent = getS theCrawlerName $ conf + +-- ------------------------------------------------------------ + +-- | Try to get the robots.txt file for a given host. +-- If it's not there or any errors occur during access, the empty string is returned + +getRobotsTxt :: CrawlerConfig c r -> URI -> IO String +getRobotsTxt c uri = runX processRobotsTxt >>= (return . concat) + where + processRobotsTxt = hxtSetTraceAndErrorLogger (getS theTraceLevelHxt c) + >>> + readDocument + [ getS theSysConfig c + >>> + withParseByMimeType yes -- these 3 options are important for reading none XML/HTML documents + >>> + withIgnoreNoneXmlContents no + >>> + withAcceptedMimeTypes [text_plain] -- robots.txt is plain text + >>> + withRedirect yes -- follow redirects for robots.txt + >>> + withoutCache + ] (getHost uri ++ "/robots.txt") + >>> + documentStatusOk + >>> + getChildren + >>> + getText + +-- ------------------------------------------------------------ + +-- | Parse the robots.txt, select the crawler specific parts and build a robots restriction value + +evalRobotsTxt :: String -> String -> RobotRestriction +evalRobotsTxt agent t = lines + >>> + map (takeWhile (/= '#') >>> stringTrim) -- remove comments and whitespace + >>> + filter (not . null) + >>> + filter ( stringToLower + >>> + takeWhile (/= ':') + >>> + (`elem` [ "disallow" + , "allow" + , "user-agent" + , "crawl-delay" + , "request-rate" + , "visit-time" + , "sitemap" + ] + ) + ) + >>> + map ( span (/= ':') + >>> + ( stringToLower *** (drop 1 >>> stringTrim) ) + ) + >>> + dropWhile ( \ (x, y) -> + ( x /= "user-agent" + || + ( y /= "*" && not (y `isPrefixOf` agent) ) + ) + ) + >>> + drop 1 + >>> + takeWhile (fst >>> (/= "user-agent")) + >>> + concatMap toRestr + $ + t + where + toRestr ("disallow", uri) = [(uri, Disallow)] -- other directives are currently ignored + toRestr ("allow", uri) = [(uri, Allow)] + toRestr _ = [] + +-- ------------------------------------------------------------ + +-- | Enable the evaluation of robots.txt + +enableRobotsTxt :: CrawlerConfig a r -> CrawlerConfig a r +enableRobotsTxt = setS theAddRobotsAction robotsAddHost + +-- | Disable the evaluation of robots.txt + +disableRobotsTxt :: CrawlerConfig a r -> CrawlerConfig a r +disableRobotsTxt = setS theAddRobotsAction robotsDontAddHost + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/Types.hs b/src/Holumbus/Crawler/Types.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/Types.hs @@ -0,0 +1,426 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.Types +where + +import Control.DeepSeq + +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.ReaderStateIO + +-- import Control.Monad.State + +import Data.Binary ( Binary ) +import qualified Data.Binary as B -- else naming conflict with put and get from Monad.State + +import Data.Function.Selector + +import Holumbus.Crawler.Constants +import Holumbus.Crawler.URIs +import Holumbus.Crawler.RobotTypes +import Holumbus.Crawler.XmlArrows ( checkDocumentStatus ) + +import Text.XML.HXT.Core +import Text.XML.HXT.Curl +import qualified Text.XML.HXT.Arrow.XmlState.RunIOStateArrow as HXT ( theSysConfigComp ) +import qualified Text.XML.HXT.Arrow.XmlState.TypeDefs as HXT ( theInputOptions ) + +import System.Log.Logger ( Priority(..) ) + +-- ------------------------------------------------------------ + +-- | The action to combine the result of a single document with the accumulator for the overall crawler result. +-- This combining function runs in the IO monad to enable storing parts of the result externally +-- but it is not a CrawlerAction, else parallel crawling with forkIO is not longer applicable + +type AccumulateDocResult a r = (URI, a) -> r -> IO r + +-- | The folding operator for merging partial results when working with mapFold and parallel crawling + +type MergeDocResults r = r -> r -> IO r + +-- | The operator for saving intermediate results + +type SavePartialResults r = FilePath -> r -> IO r + +-- | The extractor function for a single document + +type ProcessDocument a = IOSArrow XmlTree a + +-- | The crawler action monad + +type CrawlerAction a r = ReaderStateIO (CrawlerConfig a r) (CrawlerState r) + +-- | The crawler configuration record + +data CrawlerConfig a r + = CrawlerConfig + { cc_sysConfig :: SysConfig + , cc_preRefsFilter :: IOSArrow XmlTree XmlTree + , cc_processRefs :: IOSArrow XmlTree URI + , cc_preDocFilter :: IOSArrow XmlTree XmlTree + , cc_processDoc :: ProcessDocument a + , cc_accumulate :: AccumulateDocResult a r -- result accumulation runs in the IO monad to allow storing parts externally + , cc_fold :: MergeDocResults r + , cc_followRef :: URI -> Bool + , cc_addRobotsTxt :: CrawlerConfig a r -> AddRobotsAction + , cc_clickLevel :: ! Int + , cc_maxNoOfDocs :: ! Int + , cc_maxParDocs :: ! Int + , cc_maxParThreads :: ! Int + , cc_saveIntervall :: ! Int + , cc_savePathPrefix :: ! String + , cc_savePreAction :: FilePath -> CrawlerAction a r () -- SavePartialResults r + , cc_traceLevel :: ! Priority + , cc_traceLevelHxt :: ! Priority + } + +-- | The crawler state record + +data CrawlerState r + = CrawlerState + { cs_toBeProcessed :: ! URIsWithLevel + , cs_alreadyProcessed :: ! URIs + , cs_robots :: ! Robots -- is part of the state, it will grow during crawling + , cs_noOfDocs :: ! Int -- stop crawling when this counter reaches 0, (-1) means unlimited # of docs + , cs_noOfDocsSaved :: ! Int + , cs_listOfDocsSaved :: ! [Int] + , cs_resultAccu :: ! r -- evaluate accumulated result, else memory leaks show up + , cs_resultInit :: ! r -- the initial value for folding results + } + deriving (Show) + +instance (NFData r) => NFData (CrawlerState r) where + rnf CrawlerState { cs_toBeProcessed = a + , cs_alreadyProcessed = b + , cs_robots = c + , cs_noOfDocs = d + , cs_noOfDocsSaved = e + , cs_listOfDocsSaved = f + , cs_resultAccu = g + , cs_resultInit = h + } = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` + rnf e `seq` rnf f `seq` rnf g `seq` rnf h + +instance (XmlPickler r) => XmlPickler (CrawlerState r) where + xpickle = xpElem "crawler-state" $ + xpWrap ( \ ((d, e, f), (a, b, c, g, h)) -> CrawlerState a b c d e f g h + , \ (CrawlerState a b c d e f g h) -> ( (d, e, f) + , (a, b, c, g, h) + ) + ) $ + xpPair ( xpTriple + ( xpAttr "no-of-docs" xpPrim ) + ( xpAttr "no-of-docs-saved" xpPrim ) + ( xpAttr "list-of-docs-saved" $ + xpList $ + xpElem "saved-at" $ + xpPrim + ) + ) + ( xp5Tuple + ( xpElem "to-be-processed" $ + xpURIsWithLevel + ) + ( xpElem "already-processed" $ + xpURIs + ) + xpRobots + xpickle + xpickle + ) + where + xpURIs = xpWrap ( fromListURIs, toListURIs ) $ + xpList $ + xpElem "doc" $ + xpAttr "href" $ + xpText + xpURIsWithLevel = xpWrap ( fromListURIs', toListURIs' ) $ + xpList $ + xpElem "doc" $ + xpPair ( xpAttr "href" $ + xpText + ) + ( xpAttr "clicklevel" + xpInt + ) + +-- ------------------------------------------------------------ + +-- | selector functions for CrawlerState + +theToBeProcessed :: Selector (CrawlerState r) URIsWithLevel +theToBeProcessed = S cs_toBeProcessed (\ x s -> s {cs_toBeProcessed = x}) + +theAlreadyProcessed :: Selector (CrawlerState r) URIs +theAlreadyProcessed = S cs_alreadyProcessed (\ x s -> s {cs_alreadyProcessed = x}) + +theRobots :: Selector (CrawlerState r) Robots +theRobots = S cs_robots (\ x s -> s {cs_robots = x}) + +theNoOfDocs :: Selector (CrawlerState r) Int +theNoOfDocs = S cs_noOfDocs (\ x s -> s {cs_noOfDocs = x}) + +theNoOfDocsSaved :: Selector (CrawlerState r) Int +theNoOfDocsSaved = S cs_noOfDocsSaved (\ x s -> s {cs_noOfDocsSaved = x}) + +theListOfDocsSaved :: Selector (CrawlerState r) [Int] +theListOfDocsSaved = S cs_listOfDocsSaved (\ x s -> s {cs_listOfDocsSaved = x}) + +theResultAccu :: Selector (CrawlerState r) r +theResultAccu = S cs_resultAccu (\ x s -> s {cs_resultAccu = x}) + +theResultInit :: Selector (CrawlerState r) r +theResultInit = S cs_resultInit (\ x s -> s {cs_resultInit = x}) + +-- | selector functions for CrawlerConfig + +theSysConfig :: Selector (CrawlerConfig a r) SysConfig +theSysConfig = S cc_sysConfig (\ x s -> s {cc_sysConfig = x}) + +theTraceLevel :: Selector (CrawlerConfig a r) Priority +theTraceLevel = S cc_traceLevel (\ x s -> s {cc_traceLevel = x}) + +theTraceLevelHxt :: Selector (CrawlerConfig a r) Priority +theTraceLevelHxt = S cc_traceLevelHxt (\ x s -> s {cc_traceLevelHxt = x}) + +theClickLevel :: Selector (CrawlerConfig a r) Int +theClickLevel = S cc_clickLevel (\ x s -> s {cc_clickLevel = x}) + +theMaxNoOfDocs :: Selector (CrawlerConfig a r) Int +theMaxNoOfDocs = S cc_maxNoOfDocs (\ x s -> s {cc_maxNoOfDocs = x}) + +theMaxParDocs :: Selector (CrawlerConfig a r) Int +theMaxParDocs = S cc_maxParDocs (\ x s -> s {cc_maxParDocs = x}) + +theMaxParThreads :: Selector (CrawlerConfig a r) Int +theMaxParThreads = S cc_maxParThreads (\ x s -> s {cc_maxParThreads = x}) + +theSaveIntervall :: Selector (CrawlerConfig a r) Int +theSaveIntervall = S cc_saveIntervall (\ x s -> s {cc_saveIntervall = x}) + +theSavePathPrefix :: Selector (CrawlerConfig a r) String +theSavePathPrefix = S cc_savePathPrefix (\ x s -> s {cc_savePathPrefix = x}) + +theSavePreAction :: Selector (CrawlerConfig a r) (FilePath -> CrawlerAction a r ()) -- (SavePartialResults r) +theSavePreAction = S cc_savePreAction (\ x s -> s {cc_savePreAction = x}) + +theFollowRef :: Selector (CrawlerConfig a r) (URI -> Bool) +theFollowRef = S cc_followRef (\ x s -> s {cc_followRef = x}) + +theAddRobotsAction :: Selector (CrawlerConfig a r) (CrawlerConfig a r -> AddRobotsAction) +theAddRobotsAction = S cc_addRobotsTxt (\ x s -> s {cc_addRobotsTxt = x}) + +theAccumulateOp :: Selector (CrawlerConfig a r) (AccumulateDocResult a r) +theAccumulateOp = S cc_accumulate (\ x s -> s {cc_accumulate = x}) + +theFoldOp :: Selector (CrawlerConfig a r) (MergeDocResults r) +theFoldOp = S cc_fold (\ x s -> s {cc_fold = x}) + +thePreRefsFilter :: Selector (CrawlerConfig a r) (IOSArrow XmlTree XmlTree) +thePreRefsFilter = S cc_preRefsFilter (\ x s -> s {cc_preRefsFilter = x}) + +theProcessRefs :: Selector (CrawlerConfig a r) (IOSArrow XmlTree URI) +theProcessRefs = S cc_processRefs (\ x s -> s {cc_processRefs = x}) + +thePreDocFilter :: Selector (CrawlerConfig a r) (IOSArrow XmlTree XmlTree) +thePreDocFilter = S cc_preDocFilter (\ x s -> s {cc_preDocFilter = x}) + +theProcessDoc :: Selector (CrawlerConfig a r) (IOSArrow XmlTree a) +theProcessDoc = S cc_processDoc (\ x s -> s {cc_processDoc = x}) + +-- ------------------------------------------------------------ + +-- a rather boring default crawler configuration + +defaultCrawlerConfig :: AccumulateDocResult a r -> MergeDocResults r -> CrawlerConfig a r +defaultCrawlerConfig op op2 + = CrawlerConfig + { cc_sysConfig = ( withCurl [ (curl_user_agent, defaultCrawlerName) + , (curl_max_time, show $ (60 * 1000::Int)) -- whole transaction for reading a document must complete within 60,000 milli seconds, + , (curl_connect_timeout, show $ (10::Int)) -- connection must be established within 10 seconds + ] + ) + , cc_preRefsFilter = this -- no preprocessing for refs extraction + , cc_processRefs = none -- don't extract refs + , cc_preDocFilter = checkDocumentStatus -- default: in case of errors throw away any contents + , cc_processDoc = none -- no document processing at all + , cc_accumulate = op -- combining function for result accumulating + , cc_fold = op2 + , cc_followRef = const False -- do not follow any refs + , cc_addRobotsTxt = const $ const return -- do not add robots.txt evaluation + , cc_saveIntervall = (-1) -- never save an itermediate state + , cc_savePathPrefix = "/tmp/hc-" -- the prefix for filenames into which intermediate states are saved + , cc_savePreAction = const $ return () -- no action before saving state + , cc_clickLevel = maxBound -- click level set to infinity + , cc_maxNoOfDocs = (-1) -- maximum # of docs to be crawled, -1 means unlimited + , cc_maxParDocs = 20 -- maximum # of doc crawled in parallel + , cc_maxParThreads = 5 -- maximum # of threads running in parallel + , cc_traceLevel = NOTICE -- traceLevel + , cc_traceLevelHxt = WARNING -- traceLevel for hxt + } + +theInputOptions :: Selector (CrawlerConfig a r) Attributes +theInputOptions = theSysConfig + >>> + HXT.theSysConfigComp HXT.theInputOptions + +theCrawlerName :: Selector (CrawlerConfig a r) String +theCrawlerName = theInputOptions + >>> + S { getS = lookupDef defaultCrawlerName curl_user_agent + , setS = addEntry curl_user_agent + } + +theMaxTime :: Selector (CrawlerConfig a r) Int +theMaxTime = theInputOptions + >>> + S { getS = read . lookupDef "0" curl_max_time + , setS = addEntry curl_max_time . show . (`max` 1) + } + +theConnectTimeout :: Selector (CrawlerConfig a r) Int +theConnectTimeout = theInputOptions + >>> + S { getS = read . lookupDef "0" curl_connect_timeout + , setS = addEntry curl_connect_timeout . show . (`max` 1) + } + + +-- ------------------------------------------------------------ + +-- | Add attributes for accessing documents + +addSysConfig :: SysConfig -> CrawlerConfig a r -> CrawlerConfig a r +addSysConfig cf = chgS theSysConfig ( >>> cf ) + +-- | Insert a robots no follow filter before thePreRefsFilter + +addRobotsNoFollow :: CrawlerConfig a r -> CrawlerConfig a r +addRobotsNoFollow = chgS thePreRefsFilter ( robotsNoFollow >>> ) + +-- | Insert a robots no follow filter before thePreRefsFilter + +addRobotsNoIndex :: CrawlerConfig a r -> CrawlerConfig a r +addRobotsNoIndex = chgS thePreDocFilter ( robotsNoIndex >>> ) + + +-- | Set the log level + +setCrawlerTraceLevel :: Priority -> Priority -> CrawlerConfig a r -> CrawlerConfig a r +setCrawlerTraceLevel l lx + = setS theTraceLevel l + >>> + setS theTraceLevelHxt lx + +-- | Set save intervall in config + +setCrawlerSaveConf :: Int -> String -> CrawlerConfig a r -> CrawlerConfig a r +setCrawlerSaveConf i f = setS theSaveIntervall i + >>> + setS theSavePathPrefix f + +-- | Set action performed before saving crawler state + +setCrawlerSaveAction :: (FilePath -> CrawlerAction a r ()) -> CrawlerConfig a r -> CrawlerConfig a r +setCrawlerSaveAction f = setS theSavePreAction f + +-- | Set max # of steps (clicks) to reach a document + +setCrawlerClickLevel :: Int -> CrawlerConfig a r -> CrawlerConfig a r +setCrawlerClickLevel mcl + = setS theClickLevel mcl + +-- | Set max # of documents to be crawled +-- and max # of documents crawled in parallel + +setCrawlerMaxDocs :: Int -> Int -> Int -> CrawlerConfig a r -> CrawlerConfig a r +setCrawlerMaxDocs mxd mxp mxt + = setS theMaxNoOfDocs mxd + >>> + setS theMaxParDocs mxp + >>> + setS theMaxParThreads mxt + +-- | Set the pre hook filter executed before the hrefs are collected + +setCrawlerPreRefsFilter :: IOSArrow XmlTree XmlTree -> CrawlerConfig a r -> CrawlerConfig a r +setCrawlerPreRefsFilter f + = setS thePreRefsFilter f + +-- ------------------------------------------------------------ + +instance (Binary r) => Binary (CrawlerState r) where + put s = do + B.put (getS theToBeProcessed s) + B.put (getS theAlreadyProcessed s) + B.put (getS theRobots s) + B.put (getS theNoOfDocs s) + B.put (getS theNoOfDocsSaved s) + B.put (getS theListOfDocsSaved s) + B.put (getS theResultAccu s) + B.put (getS theResultInit s) + get = do + tbp <- B.get + alp <- B.get + rbt <- B.get + mxd <- B.get + mxs <- B.get + lsd <- B.get + acc <- B.get + ini <- B.get + return $ CrawlerState + { cs_toBeProcessed = tbp + , cs_alreadyProcessed = alp + , cs_robots = rbt + , cs_noOfDocs = mxd + , cs_noOfDocsSaved = mxs + , cs_listOfDocsSaved = lsd + , cs_resultAccu = acc + , cs_resultInit = ini + } + +putCrawlerState :: (Binary r) => CrawlerState r -> B.Put +putCrawlerState = B.put + +getCrawlerState :: (Binary r) => B.Get (CrawlerState r) +getCrawlerState = B.get + +initCrawlerState :: r -> CrawlerState r +initCrawlerState r = CrawlerState + { cs_toBeProcessed = emptyURIs + , cs_alreadyProcessed = emptyURIs + , cs_robots = emptyRobots + , cs_noOfDocs = 0 + , cs_noOfDocsSaved = 0 + , cs_listOfDocsSaved = [] + , cs_resultAccu = r + , cs_resultInit = r + } + +-- ------------------------------------------------------------ +-- +-- basic crawler actions + +-- | Load a component from the crawler configuration + +getConf :: Selector (CrawlerConfig a r) v -> CrawlerAction a r v +getConf = asks . getS + +getState :: Selector (CrawlerState r) v -> CrawlerAction a r v +getState = gets . getS + +putState :: Selector (CrawlerState r) v -> v -> CrawlerAction a r () +putState sel = modify . setS sel + +modifyState :: Selector (CrawlerState r) v -> (v -> v) -> CrawlerAction a r () +modifyState sel = modify . chgS sel + +modifyStateIO :: Selector (CrawlerState r) v -> (v -> IO v) -> CrawlerAction a r () +modifyStateIO sel = modifyIO . chgM sel + +-- ------------------------------------------------------------ + diff --git a/src/Holumbus/Crawler/URIs.hs b/src/Holumbus/Crawler/URIs.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/URIs.hs @@ -0,0 +1,91 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.URIs +where + +import qualified Holumbus.Data.PrefixTree as S + +-- ------------------------------------------------------------ + +-- | An URI is represented as a String +type URI = String +type URIWithLevel = (URI, Int) + +-- | A set of URIs implemeted as a prefix tree. This implementation +-- is space efficient, because of many equal prefixes in the crawled set of URIs + +type URIs = URIs' () +type URIsWithLevel = URIs' Int -- URIs with a priority or clicklevel + +type URIs' a = S.PrefixTree a + +-- ------------------------------------------------------------ + +emptyURIs :: URIs' a +emptyURIs = S.empty + +singletonURIs :: URI -> URIs +singletonURIs = flip S.singleton () + +singletonURIs' :: URI -> a -> URIs' a +singletonURIs' = S.singleton + +nullURIs :: URIs' a -> Bool +nullURIs = S.null + +memberURIs :: URI -> URIs' a -> Bool +memberURIs = S.member + +cardURIs :: URIs' a -> Int +cardURIs = S.size + +nextURI :: URIs' a -> (URI, a) +nextURI = head . toListURIs' + +nextURIs :: Int -> URIs' a -> [(URI, a)] +nextURIs n = take n . toListURIs' + +insertURI :: URI -> URIs -> URIs +insertURI = flip S.insert () + +insertURI' :: URI -> a -> URIs' a -> URIs' a +insertURI' = S.insert + +deleteURI :: URI -> URIs' a -> URIs' a +deleteURI = S.delete + +deleteURIs :: URIs' b -> URIs' a -> URIs' a +deleteURIs = flip S.difference + +unionURIs :: URIs -> URIs -> URIs +unionURIs = S.union + +unionURIs' :: (a -> a -> a) -> URIs' a -> URIs' a -> URIs' a +unionURIs' = S.unionWith + +diffURIs :: URIs' a -> URIs' a -> URIs' a +diffURIs = S.difference + +fromListURIs :: [URI] -> URIs +fromListURIs = S.fromList . map (\ x -> (x, ())) + +fromListURIs' :: [(URI, a)] -> URIs' a +fromListURIs' = S.fromList + +toListURIs :: URIs' a -> [URI] +toListURIs = S.keys -- map fst . S.toList + +toListURIs' :: URIs' a -> [(URI, a)] +toListURIs' = S.toList + +foldURIs :: (URI -> b -> b) -> b -> URIs -> b +foldURIs f = S.foldWithKey (\ x _ r -> f x r) + +foldURIs' :: (URI -> a -> b -> b) -> b -> URIs' a -> b +foldURIs' = S.foldWithKey + +-- ------------------------------------------------------------ + + diff --git a/src/Holumbus/Crawler/Util.hs b/src/Holumbus/Crawler/Util.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/Util.hs @@ -0,0 +1,75 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.Util +where + +import Control.Applicative ( liftA2 ) + +import Data.List + +import qualified Text.Regex.XMLSchema.String as RE + +-- ------------------------------------------------------------ + +-- | create temp file name + +mkTmpFile :: Int -> String -> Int -> String +mkTmpFile n s i = (s ++) . reverse . take n . (++ replicate n '0') . reverse . show $ i + +-- ------------------------------------------------------------ + +-- | Simple predicate genertor for filtering of URIs +-- If the first predicate (isAllowed) holds and the second (isDenied) does not hold +-- the predicate holds. This can be used for constructing simple URL filters + +simpleFollowRef :: (String -> Bool) -> (String -> Bool) -> (String -> Bool) +simpleFollowRef isAllowed isDenied + = isAllowed .&&. (not . isDenied) + where + (.&&.) = liftA2 (&&) + +-- | A convenient function, that takes two lists of strings in regexp syntax, +-- The first list are the patterns for the allowed strings, +-- the second one for the patterns to deny the string. +-- Two regular expressions are build from these lists of strings, +-- and the string to be tested is matched against both regexes + +simpleFollowRef' :: [String] -> [String] -> (String -> Bool) +simpleFollowRef' allowed denied + = simpleFollowRef allowed' denied' + where + mkAlt :: [String] -> String + mkAlt rs = "(" ++ intercalate "|" rs ++ ")" + allowed' + | null allowed = const True + | otherwise = match $ mkAlt allowed + denied' + | null denied = const False + | otherwise = match $ mkAlt denied + +-- ------------------------------------------------------------ + +match :: String -> String -> Bool +match re = RE.matchRE (parseRE re) + +sed :: (String -> String) -> String -> String -> String +sed edit re = parseRE re `seq` RE.sed edit re + +split :: String -> String -> (String, String) +split re = parseRE re `seq` RE.split re + +tokenize :: String -> String -> [String] +tokenize re = parseRE re `seq` RE.tokenize re + +-- ------------------------------------------------------------ + +parseRE :: String -> RE.Regex +parseRE re = check . RE.parseRegex $ re + where + check re' + | RE.isZero re' = error $ "\nsyntax error in regexp: " ++ re ++ "\n" ++ RE.errRegex re' + | otherwise = re' + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Crawler/XmlArrows.hs b/src/Holumbus/Crawler/XmlArrows.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Crawler/XmlArrows.hs @@ -0,0 +1,20 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Crawler.XmlArrows +where + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +-- | Remove contents, when document status isn't ok, but remain meta info + +checkDocumentStatus :: IOSArrow XmlTree XmlTree +checkDocumentStatus = replaceChildren none + `whenNot` + documentStatusOk + +-- ------------------------------------------------------------ + diff --git a/src/Holumbus/Data/Crunch.hs b/src/Holumbus/Data/Crunch.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Data/Crunch.hs @@ -0,0 +1,160 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Data.Crunch + Copyright : Copyright (C) 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.1 + + This module provides compression for streams of 32-bit words. Because of + some internal restriction in GHC, which makes all fixed integer size equal + in terms of bit-width, the algorithm tries to crunch as much numbers as + possible into a single 64-bit word. + + Based on the Simple9 encoding scheme from this article: + + * Vo N. Anh, Alstair Moffat, + \"/Inverted Index Compression Using Word-Aligned Binary Codes/\", + Information Retrieval, 8 (1), 2005, pages 151-166 + +-} + +-- ---------------------------------------------------------------------------- + +{-# OPTIONS -fno-warn-type-defaults #-} + +module Holumbus.Data.Crunch + ( + -- * Compression + crunch8 + , crunch16 + , crunch32 + , crunch64 + + -- * Decompression + , decrunch8 + , decrunch16 + , decrunch32 + , decrunch64 + ) +where + +import Data.Bits +import Data.Word + +data Width = W01 | W02 | W03 | W04 | W05 | W06 | W07 | W08 | W10 | W12 | W15 | W20 | W30 | W60 + deriving (Show, Eq, Enum) + +-- | Increase performance by avoiding the calculation of maximum values. +value :: Width -> Word64 +value W01 = (2 ^ 1) - 1 +value W02 = (2 ^ 2) - 1 +value W03 = (2 ^ 3) - 1 +value W04 = (2 ^ 4) - 1 +value W05 = (2 ^ 5) - 1 +value W06 = (2 ^ 6) - 1 +value W07 = (2 ^ 7) - 1 +value W08 = (2 ^ 8) - 1 +value W10 = (2 ^ 10) - 1 +value W12 = (2 ^ 12) - 1 +value W15 = (2 ^ 15) - 1 +value W20 = (2 ^ 20) - 1 +value W30 = (2 ^ 30) - 1 +value W60 = (2 ^ 60) - 1 + +-- | Increase performance by avoiding the calculation of counts. +count :: Width -> Int +count W01 = 60 +count W02 = 30 +count W03 = 20 +count W04 = 15 +count W05 = 12 +count W06 = 10 +count W07 = 8 +count W08 = 7 +count W10 = 6 +count W12 = 5 +count W15 = 4 +count W20 = 3 +count W30 = 2 +count W60 = 1 + +width :: Width -> Int +width W01 = 1 +width W02 = 2 +width W03 = 3 +width W04 = 4 +width W05 = 5 +width W06 = 6 +width W07 = 7 +width W08 = 8 +width W10 = 10 +width W12 = 12 +width W15 = 15 +width W20 = 20 +width W30 = 30 +width W60 = 60 + +-- | Crunch some values by encoding several values into one 'Word64'. The values may not exceed +-- the upper limit of @(2 ^ 60) - 1@. This precondition is not checked! The compression works +-- best on small values, therefore a difference encoding (like the one in +-- "Holumbus.Data.DiffList") prior to compression pays off well. +crunch64 :: [Word64] -> [Word64] +crunch64 [] = [] +crunch64 s = crunch' s (count W01) W01 [] + +-- | Crunch a non empty list. This precondition is not checked! +crunch' :: [Word64] -> Int -> Width -> [Word64] -> [Word64] +crunch' [] 0 m r = [encode m r] +crunch' [] _ m r = crunch' r (count (succ m)) (succ m) [] +crunch' s 0 m r = (encode m r):(crunch' s (count W01) W01 []) +crunch' s@(x:xs) n m r = if x <= value m then crunch' xs (n - 1) m (r ++ [x]) + else crunch' (r ++ s) (count (succ m)) (succ m) [] + +-- | Encode some numbers with a given width. The number of elements in the list may not exceed +-- the amount of numbers allowed for this width and the numbers in the list may not exceed the +-- upper bound for this width. These preconditions are not checked! +encode :: Width -> [Word64] -> Word64 +encode w [] = rotateR (fromIntegral (fromEnum w)) (64 - (width w * count w)) +encode w (x:xs) = rotateR (encode w xs .|. fromIntegral x) (width w) + +-- | Decrunch a list of crunched values. No checking for properly encoded values is done, weird +-- results have to be expected if calling this function on a list of arbitrary values. +decrunch64 :: [Word64] -> [Word64] +decrunch64 [] = [] +decrunch64 (x:xs) = (decode (width w) (count w) (value w) (rotateL x (width w))) ++ (decrunch64 xs) + where + w = toEnum $ fromIntegral (x .&. 15) -- Extract the 4 selector bits. + +-- Decode some numbers with a given width. +decode :: Int -> Int -> Word64 -> Word64 -> [Word64] +decode _ 0 _ _ = [] +decode w n m x = (x .&. m):(decode w (n - 1) m (rotateL x w)) + +-- | Crunching 'Word8' values, defined in terms of 'crunch64'. +crunch8 :: [Word8] -> [Word64] +crunch8 = crunch64 . (map fromIntegral) + +-- | Crunching 'Word16' values, defined in terms of 'crunch64'. +crunch16 :: [Word16] -> [Word64] +crunch16 = crunch64 . (map fromIntegral) + +-- | Crunching 'Word32' values, defined in terms of 'crunch64'. +crunch32 :: [Word32] -> [Word64] +crunch32 = crunch64 . (map fromIntegral) + +-- | Decrunching to 'Word8' values, defined in terms of 'decrunch64'. +decrunch8 :: [Word64] -> [Word8] +decrunch8 = (map fromIntegral) . decrunch64 + +-- | Decrunching to 'Word16' values, defined in terms of 'decrunch64'. +decrunch16 :: [Word64] -> [Word16] +decrunch16 = (map fromIntegral) . decrunch64 + +-- | Decrunching to 'Word32' values, defined in terms of 'decrunch64'. +decrunch32 :: [Word64] -> [Word32] +decrunch32 = (map fromIntegral) . decrunch64 diff --git a/src/Holumbus/Data/PrefixTree.hs b/src/Holumbus/Data/PrefixTree.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Data/PrefixTree.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Data.PrefixTree + Copyright : Copyright (C) 2009-2012 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: not portable + + Facade for prefix tree implementation + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Data.PrefixTree + ( PrefixTree (..) + , Key + , (!) + , value + , valueWithDefault + , null + , size + , member + , lookup + , findWithDefault + , prefixFind + , prefixFindWithKey + , prefixFindWithKeyBF + , empty + , singleton + , insert + , insertWith + , insertWithKey + , delete + , update + , updateWithKey + , map + , mapWithKey + , mapM + , mapWithKeyM + , fold + , foldWithKey + , union + , unionWith + , unionWithKey + , difference + , differenceWith + , differenceWithKey + , keys + , elems + , toList + , fromList + , toListBF + , toMap + , fromMap + , space + , keyChars + + , prefixFindCaseWithKey -- fuzzy search + , prefixFindNoCaseWithKey + , prefixFindNoCase + , lookupNoCase + + , prefixFindCaseWithKeyBF + , prefixFindNoCaseWithKeyBF + , lookupNoCaseBF + ) +where + +import Prelude hiding ( succ, lookup, map, mapM, null ) + +import Holumbus.Data.PrefixTree.Core +import Holumbus.Data.PrefixTree.FuzzySearch +import Holumbus.Data.PrefixTree.Types diff --git a/src/Holumbus/Data/PrefixTree/Core.hs b/src/Holumbus/Data/PrefixTree/Core.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Data/PrefixTree/Core.hs @@ -0,0 +1,942 @@ +{-# OPTIONS -XBangPatterns #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Data.PrefixTree.Core + Copyright : Copyright (C) 2009-2012 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: not portable + + An efficient implementation of maps from strings to arbitrary values. + + Values can associated with an arbitrary byte key. Searching for keys is very fast, but + the prefix tree probably consumes more memory than "Data.Map". The main differences are the special + 'prefixFind' functions, which can be used to perform prefix queries. The interface is + heavily borrowed from "Data.Map" and "Data.IntMap". + + Most other function names clash with "Prelude" names, therefore this module is usually + imported @qualified@, e.g. + + > import Holumbus.Data.PrefixTree (PrefixTree) + > import qualified Holumbus.Data.PrefixTree as T + + Many functions have a worst-case complexity of /O(min(n,L))/. This means that the operation + can become linear with the number of elements with a maximum of /L/, the length of the + key (the number of bytes in the list). The functions for searching a prefix have a worst-case + complexity of /O(max(L,R))/. This means that the operation can become linear with + /R/, the number of elements found for the prefix, with a minimum of /L/. + + The module exports include the internal data types, their constructors and access + functions for ultimate flexibility. Derived modules should not export these + (as shown in "Holumbus.Data.StrMap") to provide only a restricted interface. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Data.PrefixTree.Core +where + +import Prelude hiding ( succ, lookup, map, mapM, null ) + +import Control.Arrow +import Control.DeepSeq + +import qualified Data.Foldable + +import Data.Binary +import qualified Data.List as L +import qualified Data.Map as M +import Data.Maybe + +import Holumbus.Data.PrefixTree.Types +import Holumbus.Data.PrefixTree.PrefixSet + +data PrefixTree v = Empty + | Val { value' :: v + , tree :: ! (PrefixTree v) + } + | Branch { sym :: {-# UNPACK #-} + ! Sym + , child :: ! (PrefixTree v) + , next :: ! (PrefixTree v) + } + + -- the space optimisation nodes, these + -- will be normalized during access into + -- the three constructors Empty, Val and Branch + + | Leaf { value' :: v -- a value at a leaf of the tree + } + | Last { sym :: {-# UNPACK #-} + ! Sym -- the last entry in a branch list + , child :: ! (PrefixTree v) -- or no branch but a single child + } + | LsSeq { syms :: ! Key1 -- a sequence of single childs + , child :: ! (PrefixTree v) -- in a last node + } + | BrSeq { syms :: ! Key1 -- a sequence of single childs + , child :: ! (PrefixTree v) -- in a branch node + , next :: ! (PrefixTree v) + } + | LsSeL { syms :: ! Key1 -- a sequence of single childs + , value' :: v -- with a leaf + } + | BrSeL { syms :: ! Key1 -- a sequence of single childs + , value' :: v -- with a leaf in a branch node + , next :: ! (PrefixTree v) + } + | BrVal { sym :: {-# UNPACK #-} + ! Sym -- a branch with a single char + , value' :: v -- and a value + , next :: ! (PrefixTree v) + } + | LsVal { sym :: {-# UNPACK #-} + ! Sym -- a last node with a single char + , value' :: v -- and a value + } + deriving (Show, Eq, Ord) + +-- | strict list of chars with unpacked fields +-- +-- for internal use in prefix tree to optimize space efficiency + +data Key1 = Nil + | Cons {-# UNPACK #-} + ! Sym + ! Key1 + deriving (Show, Eq, Ord) + +(.++.) :: Key1 -> Key1 -> Key1 +Nil .++. k2 = k2 +(Cons k k1) .++. k2 = Cons k (k1 .++. k2) + +toKey :: Key1 -> Key +toKey Nil = [] +toKey (Cons c k1) = c : toKey k1 + +fromKey :: Key -> Key1 +fromKey [] = Nil +fromKey (c:k1) = Cons c (fromKey k1) + +length1 :: Key1 -> Int +length1 = length . toKey + +-- ---------------------------------------- + +-- smart constructors + +empty :: PrefixTree v +empty = Empty + +{-# INLINE empty #-} + +val :: v -> PrefixTree v -> PrefixTree v +val v Empty = Leaf v +val v t = Val v t + +{-# INLINE val #-} + +branch :: Sym -> PrefixTree v -> PrefixTree v -> PrefixTree v +branch !_k Empty n = n + +branch !k (Leaf v ) Empty = LsVal k v +branch !k (LsVal k1 v) Empty = LsSeL (Cons k (Cons k1 Nil)) v +branch !k (LsSeL ks v) Empty = LsSeL (Cons k ks) v +branch !k (Last k1 c) Empty = lsseq (Cons k (Cons k1 Nil)) c +branch !k (LsSeq ks c) Empty = lsseq (Cons k ks) c +branch !k c Empty = Last k c + +branch !k (Leaf v ) n = BrVal k v n +branch !k (LsVal k1 v) n = BrSeL (Cons k (Cons k1 Nil)) v n +branch !k (LsSeL ks v) n = BrSeL (Cons k ks) v n +branch !k (Last k1 c) n = brseq (Cons k (Cons k1 Nil)) c n +branch !k (LsSeq ks c) n = brseq (Cons k ks) c n +branch !k c n = Branch k c n + +lsseq :: Key1 -> PrefixTree v -> PrefixTree v +lsseq !k (Leaf v) = LsSeL k v +lsseq !k c = LsSeq k c + +{-# INLINE lsseq #-} + +brseq :: Key1 -> PrefixTree v -> PrefixTree v -> PrefixTree v +brseq !k (Leaf v) n = BrSeL k v n +brseq !k c n = BrSeq k c n + +{-# INLINE brseq #-} + +siseq :: Key1 -> PrefixTree v -> PrefixTree v +siseq Nil c = c +siseq (Cons k1 Nil) c = Last k1 c +siseq k c = LsSeq k c + +{-# INLINE siseq #-} + +-- smart selectors + +norm :: PrefixTree v -> PrefixTree v +norm (Leaf v) = Val v empty +norm (Last k c) = Branch k c empty +norm (LsSeq (Cons k Nil) c) = Branch k c empty +norm (LsSeq (Cons k ks ) c) = Branch k (siseq ks c) empty +norm (BrSeq (Cons k Nil) c n) = Branch k c n +norm (BrSeq (Cons k ks ) c n) = Branch k (siseq ks c) n +norm (LsSeL ks v) = norm (LsSeq ks (val v empty)) +norm (BrSeL ks v n) = norm (BrSeq ks (val v empty) n) +norm (LsVal k v) = norm (LsSeq (Cons k Nil) (val v empty)) +norm (BrVal k v n) = norm (BrSeq (Cons k Nil) (val v empty) n) +norm t = t + +-- ---------------------------------------- + +deepNorm :: PrefixTree v -> PrefixTree v +deepNorm t0 + = case norm t0 of + Empty -> Empty + Val v t -> Val v (deepNorm t) + Branch c s n -> Branch c (deepNorm s) (deepNorm n) + _ -> normError "deepNorm" + +-- ---------------------------------------- + +normError :: String -> a +normError f = error (f ++ ": pattern match error, prefix tree not normalized") + +-- ---------------------------------------- + +-- | /O(1)/ Is the map empty? + +null :: PrefixTree a -> Bool +null Empty = True +null _ = False + +{-# INLINE null #-} + +-- | /O(1)/ Create a map with a single element. + +singleton :: Key -> a -> PrefixTree a +singleton k v = foldr (\ c r -> branch c r empty) (val v empty) $ k -- siseq k (val v empty) + +{-# INLINE singleton #-} + +-- | /O(1)/ Extract the value of a node (if there is one) + +value :: Monad m => PrefixTree a -> m a +value t = case norm t of + Val v _ -> return v + _ -> fail "PrefixTree.value: no value at this node" + +{-# INLINE value #-} + +-- | /O(1)/ Extract the value of a node or return a default value if no value exists. + +valueWithDefault :: a -> PrefixTree a -> a +valueWithDefault d t = fromMaybe d . value $ t + + +-- | /O(1)/ Extract the successors of a node + +succ :: PrefixTree a -> PrefixTree a +succ t = case norm t of + Val _ t' -> succ t' + t' -> t' +{-# INLINE succ #-} + +-- ---------------------------------------- + +-- | /O(min(n,L))/ Find the value associated with a key. The function will @return@ the result in +-- the monad or @fail@ in it if the key isn't in the map. + +lookup :: Monad m => Key -> PrefixTree a -> m a +lookup k t = case lookup' k t of + Just v -> return v + Nothing -> fail "PrefixTree.lookup: Key not found" +{-# INLINE lookup #-} + +-- | /O(min(n,L))/ Find the value associated with a key. The function will @return@ the result in +-- the monad or @fail@ in it if the key isn't in the map. + +findWithDefault :: a -> Key -> PrefixTree a -> a +findWithDefault v0 k = fromMaybe v0 . lookup' k + +{-# INLINE findWithDefault #-} + +-- | /O(min(n,L))/ Is the key a member of the map? + +member :: Key -> PrefixTree a -> Bool +member k = maybe False (const True) . lookup k + +{-# INLINE member #-} + +-- | /O(min(n,L))/ Find the value at a key. Calls error when the element can not be found. + +(!) :: PrefixTree a -> Key -> a +(!) = flip $ findWithDefault (error "PrefixTree.! : element not in the map") + +-- | /O(min(n,L))/ Insert a new key and value into the map. If the key is already present in +-- the map, the associated value will be replaced with the new value. + +insert :: Key -> a -> PrefixTree a -> PrefixTree a +insert = insertWith const + +{-# INLINE insert #-} + +-- | /O(min(n,L))/ Insert with a combining function. If the key is already present in the map, +-- the value of @f new_value old_value@ will be inserted. + +insertWith :: (a -> a -> a) -> Key -> a -> PrefixTree a -> PrefixTree a +insertWith f = flip $ insert' f + +{-# INLINE insertWith #-} + +-- | /O(min(n,L))/ Insert with a combining function. If the key is already present in the map, +-- the value of @f key new_value old_value@ will be inserted. + +insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> PrefixTree a -> PrefixTree a +insertWithKey f k = insertWith (f k) k + + +{-# INLINE insertWithKey #-} + +-- | /O(min(n,L))/ Updates a value at a given key (if that key is in the trie) or deletes the +-- element if the result of the updating function is 'Nothing'. If the key is not found, the trie +-- is returned unchanged. + +update :: (a -> Maybe a) -> Key -> PrefixTree a -> PrefixTree a +update = update' + +{-# INLINE update #-} + +-- | /O(min(n,L))/ Updates a value at a given key (if that key is in the trie) or deletes the +-- element if the result of the updating function is 'Nothing'. If the key is not found, the trie +-- is returned unchanged. + +updateWithKey :: (Key -> a -> Maybe a) -> Key -> PrefixTree a -> PrefixTree a +updateWithKey f k = update' (f k) k + +{-# INLINE updateWithKey #-} + +-- | /O(min(n,L))/ Delete an element from the map. If no element exists for the key, the map +-- remains unchanged. + +delete :: Key -> PrefixTree a -> PrefixTree a +delete = update' (const Nothing) + +{-# INLINE delete #-} + +-- ---------------------------------------- + +lookupPx' :: Key -> PrefixTree a -> PrefixTree a +lookupPx' k0 = look k0 . norm + where + look [] t = t + look k@(c : k1) (Branch c' s' n') + | c < c' = empty + | c == c' = lookupPx' k1 s' + | otherwise = lookupPx' k n' + look _ Empty = empty + look k (Val _v' t') = lookupPx' k t' + + look _ _ = normError "lookupPx'" + +-- Internal lookup function which is generalised for arbitrary monads above. + +lookup' :: Key -> PrefixTree a -> Maybe a +lookup' k t + = case lookupPx' k t of + Val v _ -> Just v + _ -> Nothing + +-- ---------------------------------------- + +-- | /O(max(L,R))/ Find all values where the string is a prefix of the key. + +prefixFind :: Key -> PrefixTree a -> [a] +prefixFind k = elems . lookupPx' k + +-- | /O(max(L,R))/ Find all values where the string is a prefix of the key and include the keys +-- in the result. + +prefixFindWithKey :: Key -> PrefixTree a -> [(Key, a)] +prefixFindWithKey k = fmap (first (k ++)) . toList . lookupPx' k + +-- ---------------------------------------- + +insert' :: (a -> a -> a) -> a -> Key -> PrefixTree a -> PrefixTree a +insert' f v k0 = ins k0 . norm + where + ins' = insert' f v + + ins k (Branch c' s' n') + = case k of + [] -> val v (branch c' s' n') + (c : k1) + | c < c' -> branch c (singleton k1 v) (branch c' s' n') + | c == c' -> branch c (ins' k1 s') n' + | otherwise -> branch c' s' (ins' k n') + + ins k Empty = singleton k v + + ins k (Val v' t') + = case k of + [] -> val (f v v') t' + _ -> val v' (ins' k t') + + ins _ _ = normError "insert'" + +-- ---------------------------------------- + +update' :: (a -> Maybe a) -> Key -> PrefixTree a -> PrefixTree a +update' f k0 = upd k0 . norm + where + upd' = update' f + + upd k (Branch c' s' n') + = case k of + [] -> branch c' s' n' + (c : k1) + | c < c' -> branch c' s' n' + | c == c' -> branch c (upd' k1 s') n' + | otherwise -> branch c' s' (upd' k n') + + upd _ Empty = empty + + upd k (Val v' t') + = case k of + [] -> maybe t' (flip val t') $ f v' + _ -> val v' (upd' k t') + upd _ _ = normError "update'" + +-- ---------------------------------------- + +-- | /O(n+m)/ Left-biased union of two maps. It prefers the first map when duplicate keys are +-- encountered, i.e. ('union' == 'unionWith' 'const'). + +union :: PrefixTree a -> PrefixTree a -> PrefixTree a +union = union' const + +-- | /O(n+m)/ Union with a combining function. + +unionWith :: (a -> a -> a) -> PrefixTree a -> PrefixTree a -> PrefixTree a +unionWith = union' + +union' :: (a -> a -> a) -> PrefixTree a -> PrefixTree a -> PrefixTree a +union' f pt1 pt2 = uni (norm pt1) (norm pt2) + where + uni' t1' t2' = union' f (norm t1') (norm t2') + + uni Empty Empty = empty + uni Empty (Val v2 t2) = val v2 t2 + uni Empty (Branch c2 s2 n2) + = branch c2 s2 n2 + + uni (Val v1 t1) Empty = val v1 t1 + uni (Val v1 t1) (Val v2 t2) = val (f v1 v2) (uni' t1 t2) + uni (Val v1 t1) t2@(Branch _ _ _) = val v1 (uni' t1 t2) + + uni (Branch c1 s1 n1) Empty = branch c1 s1 n1 + uni t1@(Branch _ _ _ ) (Val v2 t2) = val v2 (uni' t1 t2) + uni t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2) + | c1 < c2 = branch c1 s1 (uni' n1 t2) + | c1 > c2 = branch c2 s2 (uni' t1 n2) + | otherwise = branch c1 (uni' s1 s2) (uni' n1 n2) + uni _ _ = normError "union'" + +-- ---------------------------------------- + +-- | /O(n+m)/ Union with a combining function, including the key. + +unionWithKey :: (Key -> a -> a -> a) -> PrefixTree a -> PrefixTree a -> PrefixTree a +unionWithKey f = union'' f id + +union'' :: (Key -> a -> a -> a) -> (Key -> Key) -> PrefixTree a -> PrefixTree a -> PrefixTree a +union'' f kf pt1 pt2 = uni (norm pt1) (norm pt2) + where + uni' t1' t2' = union'' f kf (norm t1') (norm t2') + + uni Empty Empty = empty + uni Empty (Val v2 t2) = val v2 t2 + uni Empty (Branch c2 s2 n2) + = branch c2 s2 n2 + + uni (Val v1 t1) Empty = val v1 t1 + uni (Val v1 t1) (Val v2 t2) = val (f (kf []) v1 v2) (uni' t1 t2) + uni (Val v1 t1) t2@(Branch _ _ _) = val v1 (uni' t1 t2) + + uni (Branch c1 s1 n1) Empty = branch c1 s1 n1 + uni t1@(Branch _ _ _ ) (Val v2 t2) = val v2 (uni' t1 t2) + uni t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2) + | c1 < c2 = branch c1 s1 (uni' n1 t2) + | c1 > c2 = branch c2 s2 (uni' t1 n2) + | otherwise = branch c1 (union'' f (kf . (c1:)) s1 s2) (uni' n1 n2) + + uni _ _ = normError "union''" + +-- ---------------------------------------- +-- +-- | /(O(min(n,m))/ Difference between two tries (based on keys). + +difference :: PrefixTree a -> PrefixTree b -> PrefixTree a +difference = differenceWith (const (const Nothing)) + +-- | /(O(min(n,m))/ Difference with a combining function. If the combining function always returns +-- 'Nothing', this is equal to proper set difference. + +differenceWith :: (a -> b -> Maybe a) -> PrefixTree a -> PrefixTree b -> PrefixTree a +differenceWith f = differenceWithKey (const f) + +-- | /O(min(n,m))/ Difference with a combining function, including the key. If two equal keys are +-- encountered, the combining function is applied to the key and both values. If it returns +-- 'Nothing', the element is discarded, if it returns 'Just' a value, the element is updated +-- with the new value. + +differenceWithKey :: (Key -> a -> b -> Maybe a) -> PrefixTree a -> PrefixTree b -> PrefixTree a +differenceWithKey f = diff'' f id + +diff'' :: (Key -> a -> b -> Maybe a) -> + (Key -> Key) -> + PrefixTree a -> PrefixTree b -> PrefixTree a +diff'' f kf pt1 pt2 = dif (norm pt1) (norm pt2) + where + dif' t1' t2' = diff'' f kf (norm t1') (norm t2') + + dif Empty _ = empty + + dif (Val v1 t1) Empty = val v1 t1 + dif (Val v1 t1) (Val v2 t2) = + case f (kf []) v1 v2 of + Nothing -> dif' t1 t2 + Just nv -> val nv (dif' t1 t2) + dif (Val v1 t1) t2@(Branch _ _ _) = val v1 (dif' t1 t2) + + dif (Branch c1 s1 n1) Empty = branch c1 s1 n1 + dif t1@(Branch _ _ _ ) (Val _ t2) = dif' t1 t2 + dif t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2) + | c1 < c2 = branch c1 s1 (dif' n1 t2) + | c1 > c2 = dif' t1 n2 + | otherwise = branch c1 (diff'' f (kf . (c1:)) s1 s2) (dif' n1 n2) + dif _ _ = normError "diff''" + + +-- ---------------------------------------- + +-- | cut off all branches from a tree @t2@ that are not part of set @t1@ +-- +-- the following laws must holds +-- +-- @lookup' k' . cutPx' (singlePS k) $ t == lookup' k t@ for every @k'@ with @k@ prefix of @k'@ +-- +-- @lookup' k' . cutPx' (singlePS k) $ t == Nothing@ for every @k'@ with @k@ not being a prefix of @k'@ + +cutPx'' :: (PrefixTree a -> PrefixTree a) -> PrefixSet -> PrefixTree a -> PrefixTree a +cutPx'' cf s1' t2' = cut s1' (norm t2') + where + cut PSempty _t2 = empty + cut (PSelem _s1) t2 = cf t2 + cut (PSnext _ _ _ ) Empty = empty + cut t1@(PSnext _ _ _ ) (Val _ t2) = cut t1 (norm t2) + cut t1@(PSnext c1 s1 n1) t2@(Branch c2 s2 n2) + | c1 < c2 = cut n1 t2 + | c1 > c2 = cut t1 (norm n2) + | otherwise = branch c1 (cutPx'' cf s1 s2) (cutPx'' cf n1 n2) + cut _ _ = normError "cutPx''" + +cutPx' :: PrefixSet -> PrefixTree a -> PrefixTree a +cutPx' = cutPx'' id + +cutAllPx' :: PrefixSet -> PrefixTree a -> PrefixTree a +cutAllPx' = cutPx'' (cv . norm) + where + cv (Val v _) = val v empty + cv _ = empty + +-- ---------------------------------------- + +-- | /O(n)/ Map a function over all values in the prefix tree. + +map :: (a -> b) -> PrefixTree a -> PrefixTree b +map f = mapWithKey (const f) + + +mapWithKey :: (Key -> a -> b) -> PrefixTree a -> PrefixTree b +mapWithKey f = map' f id + + +map' :: (Key -> a -> b) -> (Key -> Key) -> PrefixTree a -> PrefixTree b +map' _ _ (Empty) = Empty +map' f k (Val v t) = Val (f (k []) v) (map' f k t) +map' f k (Branch c s n) = Branch c (map' f ((c :) . k) s) (map' f k n) +map' f k (Leaf v) = Leaf (f (k []) v) +map' f k (Last c s) = Last c (map' f ((c :) . k) s) +map' f k (LsSeq cs s) = LsSeq cs (map' f ((toKey cs ++) . k) s) +map' f k (BrSeq cs s n) = BrSeq cs (map' f ((toKey cs ++) . k) s) (map' f k n) +map' f k (LsSeL cs v) = LsSeL cs (f (k []) v) +map' f k (BrSeL cs v n) = BrSeL cs (f (k []) v) (map' f k n) +map' f k (LsVal c v) = LsVal c (f (k []) v) +map' f k (BrVal c v n) = BrVal c (f (k []) v) (map' f k n) + +-- ---------------------------------------- + +-- | Variant of map that works on normalized trees + +mapN :: (a -> b) -> PrefixTree a -> PrefixTree b +mapN f = mapWithKeyN (const f) + + +mapWithKeyN :: (Key -> a -> b) -> PrefixTree a -> PrefixTree b +mapWithKeyN f = map'' f id + +map'' :: (Key -> a -> b) -> (Key -> Key) -> PrefixTree a -> PrefixTree b +map'' f k = mapn . norm + where + mapn Empty = empty + mapn (Val v t) = val (f (k []) v) (map'' f k t) + mapn (Branch c s n) = branch c (map'' f ((c :) . k) s) (map'' f k n) + mapn _ = normError "map''" + +-- ---------------------------------------- + +-- | Monadic map + +mapM :: Monad m => (a -> m b) -> PrefixTree a -> m (PrefixTree b) +mapM f = mapWithKeyM (const f) + +-- | Monadic mapWithKey + +mapWithKeyM :: Monad m => (Key -> a -> m b) -> PrefixTree a -> m (PrefixTree b) +mapWithKeyM f = mapM'' f id + +mapM'' :: Monad m => (Key -> a -> m b) -> (Key -> Key) -> PrefixTree a -> m (PrefixTree b) +mapM'' f k = mapn . norm + where + mapn Empty = return $ empty + mapn (Val v t) = do + v' <- f (k []) v + t' <- mapM'' f k t + return $ val v' t' + mapn (Branch c s n) = do + s' <- mapM'' f ((c :) . k) s + n' <- mapM'' f k n + return $ branch c s' n' + mapn _ = normError "mapM''" + +-- ---------------------------------------- +-- +-- A prefix tree visitor + +data PrefixTreeVisitor a b = PTV + { v_empty :: b + , v_val :: a -> b -> b + , v_branch :: Sym -> b -> b -> b + , v_leaf :: a -> b + , v_last :: Sym -> b -> b + , v_lsseq :: Key1 -> b -> b + , v_brseq :: Key1 -> b -> b -> b + , v_lssel :: Key1 -> a -> b + , v_brsel :: Key1 -> a -> b -> b + , v_lsval :: Sym -> a -> b + , v_brval :: Sym -> a -> b -> b + } + +visit :: PrefixTreeVisitor a b -> PrefixTree a -> b + +visit v (Empty) = v_empty v +visit v (Val v' t) = v_val v v' (visit v t) +visit v (Branch c s n) = v_branch v c (visit v s) (visit v n) +visit v (Leaf v') = v_leaf v v' +visit v (Last c s) = v_last v c (visit v s) +visit v (LsSeq cs s) = v_lsseq v cs (visit v s) +visit v (BrSeq cs s n) = v_brseq v cs (visit v s) (visit v n) +visit v (LsSeL cs v') = v_lssel v cs v' +visit v (BrSeL cs v' n) = v_brsel v cs v' (visit v n) +visit v (LsVal c v') = v_lsval v c v' +visit v (BrVal c v' n) = v_brval v c v' (visit v n) + +-- ---------------------------------------- +-- +-- | space required by a prefix tree (logically) +-- +-- Singletons are counted as 0, all other n-ary constructors +-- are counted as n+1 (1 for the constructor and 1 for every field) +-- cons nodes of char lists are counted 2, 1 for the cons, 1 for the char +-- for values only the ref to the value is counted, not the space for the value itself +-- key chars are assumed to be unboxed + +space :: PrefixTree a -> Int +space = visit $ + PTV + { v_empty = 0 + , v_val = const (3+) + , v_branch = const $ \ s n -> 4 + s + n + , v_leaf = const 2 + , v_last = const (3+) + , v_lsseq = \ cs s -> 3 + 2 * length1 cs + s + , v_brseq = \ cs s n -> 4 + 2 * length1 cs + s + n + , v_lssel = \ cs _ -> 3 + 2 * length1 cs + , v_brsel = \ cs _ n -> 4 + 2 * length1 cs + n + , v_lsval = \ _ _ -> 3 + , v_brval = \ _ _ n -> 4 + n + } + +keyChars :: PrefixTree a -> Int +keyChars = visit $ + PTV + { v_empty = 0 + , v_val = \ _ t -> t + , v_branch = \ _ s n -> 1 + s + n + , v_leaf = \ _ -> 0 + , v_last = \ _ s -> 1 + s + , v_lsseq = \ cs s -> length1 cs + s + , v_brseq = \ cs s n -> length1 cs + s + n + , v_lssel = \ cs _ -> length1 cs + , v_brsel = \ cs _ n -> length1 cs + n + , v_lsval = \ _ _ -> 1 + , v_brval = \ _ _ n -> 1 + n + } + +-- ---------------------------------------- +-- +-- | statistics about the # of different nodes in an optimized prefix tree + +stat :: PrefixTree a -> PrefixTree Int +stat = visit $ + PTV + { v_empty = singleton "empty" 1 + , v_val = \ _ t -> singleton "val" 1 `add` t + , v_branch = \ _ s n -> singleton "branch" 1 `add` (s `add` n) + , v_leaf = \ _ -> singleton "leaf" 1 + , v_last = \ _ s -> singleton "last" 1 `add` s + , v_lsseq = \ cs s -> singleton ("lsseq-" ++ show (length1 cs)) 1 `add` s + , v_brseq = \ cs s n -> singleton ("brseq-" ++ show (length1 cs)) 1 `add` (s `add` n) + , v_lssel = \ cs _ -> singleton ("lssel-" ++ show (length1 cs)) 1 + , v_brsel = \ cs _ n -> singleton ("brseq-" ++ show (length1 cs)) 1 `add` n + , v_lsval = \ _ _ -> singleton "lsval" 1 + , v_brval = \ _ _ n -> singleton "brval" 1 `add` n + } + where + add = unionWith (+) + +-- ---------------------------------------- + +-- | /O(n)/ Fold over all key\/value pairs in the map. + +foldWithKey :: (Key -> a -> b -> b) -> b -> PrefixTree a -> b +foldWithKey f e = fold' f e id + +{-# INLINE foldWithKey #-} + +-- | /O(n)/ Fold over all values in the map. + +fold :: (a -> b -> b) -> b -> PrefixTree a -> b +fold f = foldWithKey $ const f + +{-# INLINE fold #-} + +{- not yet used + +foldTopDown :: (Key -> a -> b -> b) -> b -> (Key -> Key) -> PrefixTree a -> b +foldTopDown f r k0 = fo k0 . norm + where + fo kf (Branch c' s' n') = let r' = foldTopDown f r ((c' :) . kf) s' in foldTopDown f r' kf n' + fo _ (Empty) = r + fo kf (Val v' t') = let r' = f (kf []) v' r in foldTopDown f r' kf t' + fo _ _ = normError "foldTopDown" +-- -} + +fold' :: (Key -> a -> b -> b) -> b -> (Key -> Key) -> PrefixTree a -> b +fold' f r k0 = fo k0 . norm + where + fo kf (Branch c' s' n') = let r' = fold' f r kf n' in fold' f r' (kf . (c':)) s' + fo _ (Empty) = r + fo kf (Val v' t') = let r' = fold' f r kf t' in f (kf []) v' r' + fo _ _ = normError "fold'" + +-- | /O(n)/ Convert into an ordinary map. + +toMap :: PrefixTree a -> M.Map Key a +toMap = foldWithKey M.insert M.empty + +-- | /O(n)/ Convert an ordinary map into a Prefix tree + +fromMap :: M.Map Key a -> PrefixTree a +fromMap = M.foldrWithKey insert empty + +-- | /O(n)/ Returns all elements as list of key value pairs, + +toList :: PrefixTree a -> [(Key, a)] +toList = foldWithKey (\k v r -> (k, v) : r) [] + +-- | /O(n)/ Creates a trie from a list of key\/value pairs. +fromList :: [(Key, a)] -> PrefixTree a +fromList = L.foldl' (\p (k, v) -> insert k v p) empty + +-- | /O(n)/ The number of elements. +size :: PrefixTree a -> Int +size = fold (const (+1)) 0 + +-- | /O(n)/ Returns all values. +elems :: PrefixTree a -> [a] +elems = fold (:) [] + +-- | /O(n)/ Returns all values. +keys :: PrefixTree a -> [Key] +keys = foldWithKey (\ k _v r -> k : r) [] + +-- ---------------------------------------- + +-- | returns all key-value pairs in breadth first order (short words first) +-- this enables prefix search with upper bounds on the size of the result set +-- e.g. @ search ... >>> toListBF >>> take 1000 @ will give the 1000 shortest words +-- found in the result set and will ignore all long words +-- +-- toList is derived from the following code found in the net when searching haskell breadth first search +-- +-- Haskell Standard Libraray Implementation +-- +-- > br :: Tree a -> [a] +-- > br t = map rootLabel $ +-- > concat $ +-- > takeWhile (not . null) $ +-- > iterate (concatMap subForest) [t] + +toListBF :: PrefixTree v -> [(Key, v)] +toListBF = (\ t0 -> [(id, t0)]) + >>> + iterate (concatMap (second norm >>> uncurry subForest)) + >>> + takeWhile (not . L.null) + >>> + concat + >>> + concatMap (second norm >>> uncurry rootLabel) + +rootLabel :: (Key -> Key) -> PrefixTree v -> [(Key, v)] +rootLabel kf (Val v _) = [(kf [], v)] +rootLabel _ _ = [] + +subForest :: (Key -> Key) -> PrefixTree v -> [(Key -> Key, PrefixTree v)] +subForest kf (Branch c s n) = (kf . (c:), s) : subForest kf (norm n) +subForest _ Empty = [] +subForest kf (Val _ t) = subForest kf (norm t) +subForest _ _ = error "PrefixTree.Core.subForest: Pattern match failure" + +-- ---------------------------------------- + +-- | /O(max(L,R))/ Find all values where the string is a prefix of the key and include the keys +-- in the result. The result list contains short words first + +prefixFindWithKeyBF :: Key -> PrefixTree a -> [(Key, a)] +prefixFindWithKeyBF k = fmap (first (k ++)) . toListBF . lookupPx' k + +-- ---------------------------------------- + +instance Functor PrefixTree where + fmap = map + +instance Data.Foldable.Foldable PrefixTree where + foldr = fold + +{- for debugging not yet enabled + +instance Show a => Show (PrefixTree a) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . shows (toList m) + +-- -} + +-- ---------------------------------------- + +instance Read a => Read (PrefixTree a) where + readsPrec p = readParen (p > 10) $ + \ r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + return (fromList xs,t) + +-- ---------------------------------------- + +instance NFData a => NFData (PrefixTree a) where + rnf (Empty) = () + rnf (Val v t) = rnf v `seq` rnf t + rnf (Branch _c s n) = rnf s `seq` rnf n + rnf (Leaf v) = rnf v + rnf (Last _c s) = rnf s + rnf (LsSeq _ks s) = rnf s + rnf (BrSeq _ks s n) = rnf s `seq` rnf n + rnf (LsSeL _ks v) = rnf v + rnf (BrSeL _ks v n) = rnf v `seq` rnf n + rnf (LsVal k v) = rnf k `seq` rnf v + rnf (BrVal k v n) = rnf k `seq` rnf v `seq` rnf n + +-- ---------------------------------------- +-- +-- Provide native binary serialization (not via to-/fromList). + +instance (Binary a) => Binary (PrefixTree a) where + put (Empty) = put (0::Word8) + put (Val v t) = put (1::Word8) >> put v >> put t + put (Branch c s n) = put (2::Word8) >> put c >> put s >> put n + put (Leaf v) = put (3::Word8) >> put v + put (Last c s) = put (4::Word8) >> put c >> put s + put (LsSeq k s) = put (5::Word8) >> put (toKey k) >> put s + put (BrSeq k s n) = put (6::Word8) >> put (toKey k) >> put s >> put n + put (LsSeL k v) = put (7::Word8) >> put (toKey k) >> put v + put (BrSeL k v n) = put (8::Word8) >> put (toKey k) >> put v >> put n + put (LsVal k v) = put (9::Word8) >> put k >> put v + put (BrVal k v n) = put (10::Word8) >> put k >> put v >> put n + + get = do + !tag <- getWord8 + case tag of + 0 -> return Empty + 1 -> do + !v <- get + !t <- get + return $! Val v t + 2 -> do + !c <- get + !s <- get + !n <- get + return $! Branch c s n + 3 -> do + !v <- get + return $! Leaf v + 4 -> do + !c <- get + !s <- get + return $! Last c s + 5 -> do + !k <- get + !s <- get + return $! LsSeq (fromKey k) s + 6 -> do + !k <- get + !s <- get + !n <- get + return $! BrSeq (fromKey k) s n + 7 -> do + !k <- get + !v <- get + return $! LsSeL (fromKey k) v + 8 -> do + !k <- get + !v <- get + !n <- get + return $! BrSeL (fromKey k) v n + 9 -> do + !k <- get + !v <- get + return $! LsVal k v + 10 -> do + !k <- get + !v <- get + !n <- get + return $! BrVal k v n + _ -> fail "PrefixTree.get: error while decoding PrefixTree" + +-- ---------------------------------------- diff --git a/src/Holumbus/Data/PrefixTree/FuzzySearch.hs b/src/Holumbus/Data/PrefixTree/FuzzySearch.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Data/PrefixTree/FuzzySearch.hs @@ -0,0 +1,101 @@ +{-# OPTIONS -XBangPatterns #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Data.PrefixTree.FuzzySearch + Copyright : Copyright (C) 2009-2012 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: not portable + + Functions for fuzzy search in a prefix tree + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Data.PrefixTree.FuzzySearch +where + +import Data.Char + +import Holumbus.Data.PrefixTree.Core +import Holumbus.Data.PrefixTree.PrefixSet +import Holumbus.Data.PrefixTree.Types + +-- ---------------------------------------- + +-- | /O(max(L,R))/ Find all values where the string is a prefix of the key. + +prefixFindCaseWithKey :: Key -> PrefixTree a -> [(Key, a)] +prefixFindCaseWithKey k = toList . cutPx' (singlePS k) + +prefixFindNoCaseWithKey :: Key -> PrefixTree a -> [(Key, a)] +prefixFindNoCaseWithKey k = toList . cutPx' (noCaseKeys k) + +prefixFindNoCase :: Key -> PrefixTree a -> [a] +prefixFindNoCase k = elems . cutPx' (noCaseKeys k) + +lookupNoCase :: Key -> PrefixTree a -> [(Key, a)] +lookupNoCase k = toList . cutAllPx' (noCaseKeys k) + +-- ---------------------------------------- + +-- | /O(max(L,R))/ Find all values where the string is a prefix of the key. +-- Breadth first variant, short words first in the result list + +prefixFindCaseWithKeyBF :: Key -> PrefixTree a -> [(Key, a)] +prefixFindCaseWithKeyBF k = toListBF . cutPx' (singlePS k) + +prefixFindNoCaseWithKeyBF :: Key -> PrefixTree a -> [(Key, a)] +prefixFindNoCaseWithKeyBF k = toListBF . cutPx' (noCaseKeys k) + +lookupNoCaseBF :: Key -> PrefixTree a -> [(Key, a)] +lookupNoCaseBF k = toListBF . cutAllPx' (noCaseKeys k) + +-- ---------------------------------------- + +noCaseKeys :: Key -> PrefixSet +noCaseKeys = noCasePS . singlePS + +noLowerCaseKeys :: Key -> PrefixSet +noLowerCaseKeys = noLowerCasePS . singlePS + +-- ---------------------------------------- + + +noCasePS :: PrefixSet -> PrefixSet +noCasePS = fuzzyCharPS (\ x -> [toUpper x, toLower x]) + +noLowerCasePS :: PrefixSet -> PrefixSet +noLowerCasePS = fuzzyCharPS (\ x -> [toUpper x, x]) + +-- ---------------------------------------- + +noUmlautPS :: PrefixSet -> PrefixSet +noUmlautPS = fuzzyCharsPS noUmlaut + where + noUmlaut '\196' = ["Ae"] + noUmlaut '\214' = ["Oe"] + noUmlaut '\220' = ["Ue"] + noUmlaut '\228' = ["ae"] + noUmlaut '\246' = ["oe"] + noUmlaut '\252' = ["ue"] + noUmlaut '\223' = ["ss"] + noUmlaut c = [[c]] + +-- ------------------------------------------------------------ +{- a few simple tests + +e1 = singlePS "abc" +e2 = prefixPS "abc" +e3 = foldl unionPS emptyPS . fmap singlePS $ ["zeus","anna","anton","an"] +e4 = noCasePS e3 +e5 = noLowerCasePS . singlePS $ "Data" +e6 = noUmlautPS . singlePS $ "äöüzß" + +-- -} +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Data/PrefixTree/PrefixSet.hs b/src/Holumbus/Data/PrefixTree/PrefixSet.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Data/PrefixTree/PrefixSet.hs @@ -0,0 +1,132 @@ +{-# OPTIONS -XBangPatterns #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Data.PrefixTree.PrefixSet + Copyright : Copyright (C) 2010 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: not portable + + A simplified version of PrefixTree for implementing sets. + + There is one important difference to the PrefixTree implementation: + The fields are not marked to be strict. This enables building the + set on the fly. + + This feature is used in fuzzy search, when an index tree is restricted + to a set of keys, e.g. the set of all none case significant keys + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Data.PrefixTree.PrefixSet +where + +import Data.List ( sort, nub ) + +import Holumbus.Data.PrefixTree.Types + +-- ---------------------------------------- + +-- | Set of strings implemented as lazy prefix tree. +-- @type PrefixSet = PrefixTree ()@ is not feasable because of the strict fields in the PrefixTree definition + +data PrefixSet = PSempty + | PSelem PrefixSet + | PSnext Sym PrefixSet PrefixSet + deriving (Show) + +emptyPS :: PrefixSet +emptyPS = PSempty + +elemPS :: PrefixSet -> PrefixSet +elemPS s@(PSelem _) = s +elemPS s = PSelem s + +elem0PS :: PrefixSet +elem0PS = elemPS emptyPS + +nextPS :: Sym -> PrefixSet -> PrefixSet -> PrefixSet +nextPS _ PSempty n = n +nextPS s c n = PSnext s c n + +lastPS :: Sym -> PrefixSet -> PrefixSet +lastPS s c = nextPS s c emptyPS + +nullPS :: PrefixSet -> Bool +nullPS PSempty = True +nullPS _ = False + +singlePS :: Key -> PrefixSet +singlePS = foldr (\ c r -> lastPS c r) elem0PS + +-- ------------------------------------------------------------ + +prefixPS :: Key -> PrefixSet +prefixPS = foldr (\ c r -> elemPS (lastPS c r)) elem0PS + +-- ------------------------------------------------------------ + +unionPS :: PrefixSet -> PrefixSet -> PrefixSet +unionPS PSempty ps2 = ps2 +unionPS ps1 PSempty = ps1 + +unionPS (PSelem ps1) (PSelem ps2) = PSelem (unionPS ps1 ps2) +unionPS (PSelem ps1) ps2 = PSelem (unionPS ps1 ps2) +unionPS ps1 (PSelem ps2) = PSelem (unionPS ps1 ps2) + +unionPS ps1@(PSnext c1 s1 n1) + ps2@(PSnext c2 s2 n2) + | c1 < c2 = nextPS c1 s1 (unionPS n1 ps2) + | c1 > c2 = nextPS c2 s2 (unionPS ps1 n2) + | otherwise = nextPS c1 (unionPS s1 s2) (unionPS n1 n2) + +-- ------------------------------------------------------------ + +foldPS :: (Key -> b -> b) -> b -> (Key -> Key) -> PrefixSet -> b +foldPS _ r _ PSempty = r +foldPS f r kf (PSelem ps1) = let r' = foldPS f r kf ps1 + in + f (kf []) r' +foldPS f r kf (PSnext c1 s1 n1) = let r' = foldPS f r kf n1 + in + foldPS f r' (kf . (c1:)) s1 + +foldWithKeyPS :: (Key -> b -> b) -> b -> PrefixSet -> b +foldWithKeyPS f e = foldPS f e id + +-- ------------------------------------------------------------ + +elemsPS :: PrefixSet -> [Key] +elemsPS = foldWithKeyPS (:) [] + +-- ------------------------------------------------------------ + +fuzzyCharPS :: (Sym -> [Sym]) -> PrefixSet -> PrefixSet +fuzzyCharPS _ PSempty = PSempty +fuzzyCharPS f (PSelem ps) = PSelem $ fuzzyCharPS f ps +fuzzyCharPS f (PSnext c s n) = unionPS ps1 (fuzzyCharPS f n) + where + s' = fuzzyCharPS f s + cs = sort . nub . f $ c + ps1 = foldr (\ c' r' -> nextPS c' s' r') emptyPS $ cs + +-- ------------------------------------------------------------ + +fuzzyCharsPS :: (Sym -> [Key]) -> PrefixSet -> PrefixSet +fuzzyCharsPS _ PSempty = PSempty +fuzzyCharsPS f (PSelem ps) = PSelem $ fuzzyCharsPS f ps +fuzzyCharsPS f (PSnext c s n) = unionPS ps1 (fuzzyCharsPS f n) + where + s' = fuzzyCharsPS f s + cs = sort . nub . f $ c + ps1 = foldr (\ w' r' -> nextPSw w' s' r') emptyPS $ cs + nextPSw [] _ r' = r' + nextPSw (x:xs) s'' r' = nextPS x (foldr lastPS s'' xs) r' + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Data/PrefixTree/Types.hs b/src/Holumbus/Data/PrefixTree/Types.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Data/PrefixTree/Types.hs @@ -0,0 +1,26 @@ +{-# OPTIONS #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Data.PrefixTree.Types + Copyright : Copyright (C) 2009-2012 Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: portable + + Data types used in all PrefixTree modules + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Data.PrefixTree.Types +where + +type Sym = Char +type Key = [Sym] + +-- ---------------------------------------------------------------------------- diff --git a/src/Holumbus/Index/Common.hs b/src/Holumbus/Index/Common.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common.hs @@ -0,0 +1,308 @@ +{-# OPTIONS -XMultiParamTypeClasses -XFlexibleContexts -XFlexibleInstances -XGeneralizedNewtypeDeriving -XTypeSynonymInstances -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common + Copyright : Copyright (C) 2007 Sebastian M. Schlatt, Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + Common data types shared by all index types and a unified interface for + all different index types. This module defines the common interfaces of + indexes and their document tables as well as full-text caches. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common + ( + -- * Common index types and classes + HolIndex (..) + , HolIndexM (..) + , HolDocuments (..) + , HolDocIndex (..) + , HolCache (..) + + -- * Indexes and Documents + -- , mergeAll + + , module Holumbus.Index.Common.BasicTypes + , module Holumbus.Index.Common.Document + , module Holumbus.Index.Common.DocId + , module Holumbus.Index.Common.DocIdMap + , module Holumbus.Index.Common.Occurences + , module Holumbus.Index.Common.RawResult + , module Holumbus.Index.Common.LoadStore + + ) +where + +import Control.Monad ( foldM ) + +-- import Data.Binary ( Binary (..) ) +-- import Data.Maybe + +import Holumbus.Index.Common.BasicTypes +import Holumbus.Index.Common.Document +import Holumbus.Index.Common.DocId +import Holumbus.Index.Common.DocIdMap +import Holumbus.Index.Common.Occurences +import Holumbus.Index.Common.RawResult +import Holumbus.Index.Common.LoadStore + +-- ------------------------------------------------------------ + +-- | This class provides a generic interface to different types of index implementations. + +class HolIndex i where + -- | Returns the number of unique words in the index. + sizeWords :: i -> Int + + -- | Returns a list of all contexts avaliable in the index. + contexts :: i -> [Context] + + -- | Returns the occurrences for every word. A potentially expensive operation. + allWords :: i -> Context -> RawResult + + -- | Searches for words beginning with the prefix in a given context (case-sensitive). + prefixCase :: i -> Context -> String -> RawResult + + -- | Searches for words beginning with the prefix in a given context (case-insensitive). + prefixNoCase :: i -> Context -> String -> RawResult + + -- | Searches for and exact word in a given context (case-sensitive). + lookupCase :: i -> Context -> String -> RawResult + + -- | Searches for and exact word in a given context (case-insensitive). + lookupNoCase :: i -> Context -> String -> RawResult + + -- | Insert occurrences. + insertOccurrences :: Context -> Word -> Occurrences -> i -> i + + -- | Delete occurrences. + deleteOccurrences :: Context -> Word -> Occurrences -> i -> i + + -- | Insert a position for a single document. + insertPosition :: Context -> Word -> DocId -> Position -> i -> i + insertPosition c w d p i = insertOccurrences c w (singletonOccurrence d p) i + + -- | Delete a position for a single document. + deletePosition :: Context -> Word -> DocId -> Position -> i -> i + deletePosition c w d p i = deleteOccurrences c w (singletonOccurrence d p) i + + -- | Merges two indexes. + mergeIndexes :: i -> i -> i + + -- | Substract one index from another. + substractIndexes :: i -> i -> i + + -- | Splitting an index by its contexts. + splitByContexts :: i -> Int -> [i] + + -- | Splitting an index by its documents. + splitByDocuments :: i -> Int -> [i] + + -- | Splitting an index by its words. + splitByWords :: i -> Int -> [i] + + -- | Update document id's (e.g. for renaming documents). If the function maps two different id's + -- to the same new id, the two sets of word positions will be merged if both old id's are present + -- in the occurrences for a word in a specific context. + updateDocIds :: (Context -> Word -> DocId -> DocId) -> i -> i + + -- | Update document id's with a simple injective editing function. + updateDocIds' :: (DocId -> DocId) -> i -> i + updateDocIds' f = updateDocIds (const . const $ f) + + -- Convert an Index to a list. Can be used for easy conversion between different index + -- implementations + + toList :: i -> [(Context, Word, Occurrences)] + + -- Create an Index from a list. Can be used for easy conversion between different index + -- implementations. Needs an empty index as first argument + + fromList :: i -> [(Context, Word, Occurrences)] -> i + fromList e = foldl (\i (c,w,o) -> insertOccurrences c w o i) e + +-- ------------------------------------------------------------ + +-- | This class provides a generic interface to different monadic types of index implementations. + +class (Monad m) => HolIndexM m i where + -- | Returns the number of unique words in the index. + sizeWordsM :: i -> m Int + + -- | Returns a list of all contexts avaliable in the index. + contextsM :: i -> m [Context] + + -- | Returns the occurrences for every word. A potentially expensive operation. + allWordsM :: i -> Context -> m RawResult + + -- | Searches for words beginning with the prefix in a given context (case-sensitive). + prefixCaseM :: i -> Context -> String -> m RawResult + + -- | Searches for words beginning with the prefix in a given context (case-insensitive). + prefixNoCaseM :: i -> Context -> String -> m RawResult + + -- | Searches for and exact word in a given context (case-sensitive). + lookupCaseM :: i -> Context -> String -> m RawResult + + -- | Searches for and exact word in a given context (case-insensitive). + lookupNoCaseM :: i -> Context -> String -> m RawResult + + -- | Insert occurrences. + insertOccurrencesM :: Context -> Word -> Occurrences -> i -> m i + + -- | Delete occurrences. + deleteOccurrencesM :: Context -> Word -> Occurrences -> i -> m i + + -- | Insert a position for a single document. + insertPositionM :: Context -> Word -> DocId -> Position -> i -> m i + insertPositionM c w d p i = insertOccurrencesM c w (singletonOccurrence d p) i + + -- | Delete a position for a single document. + deletePositionM :: Context -> Word -> DocId -> Position -> i -> m i + deletePositionM c w d p i = deleteOccurrencesM c w (singletonOccurrence d p) i + + -- | Merges two indexes. + mergeIndexesM :: i -> i -> m i + + -- | Update document id's (e.g. for renaming documents). If the function maps two different id's + -- to the same new id, the two sets of word positions will be merged if both old id's are present + -- in the occurrences for a word in a specific context. + updateDocIdsM :: (Context -> Word -> DocId -> DocId) -> i -> m i + + -- | Update document id's with an simple injective editing function. + updateDocIdsM' :: (DocId -> DocId) -> i -> m i + + -- Convert an Index to a list. Can be used for easy conversion between different index + -- implementations + toListM :: i -> m [(Context, Word, Occurrences)] + + -- Create an Index from a list. Can be used vor easy conversion between different index + -- implementations. Needs an empty index as first argument + fromListM :: i -> [(Context, Word, Occurrences)] -> m i + fromListM e = foldM (\i (c,w,o) -> insertOccurrencesM c w o i) e + +-- ------------------------------------------------------------ + +-- don't change IO into Monad m +-- this leads to ambiguities and error messages, when a context (HolIndexM m i) is used +-- +-- NOT: instance (Monad m, HolIndex i) => HolIndexM m i where + +instance (HolIndex i) => HolIndexM IO i where + sizeWordsM = return . sizeWords + contextsM = return . contexts + allWordsM i = return . allWords i + prefixCaseM i c = return . prefixCase i c + prefixNoCaseM i c = return . prefixNoCase i c + lookupCaseM i c = return . lookupCase i c + lookupNoCaseM i c = return . lookupNoCase i c + insertOccurrencesM c w o = return . insertOccurrences c w o + deleteOccurrencesM c w o = return . deleteOccurrences c w o + mergeIndexesM i1 = return . mergeIndexes i1 + updateDocIdsM u = return . updateDocIds u + updateDocIdsM' f = return . updateDocIds (const . const $ f) + toListM = return . toList + +-- ------------------------------------------------------------ + +class HolDocuments d a where + -- | doctable empty? + nullDocs :: d a -> Bool + nullDocs = (== 0) . sizeDocs + + -- | Returns the number of unique documents in the table. + sizeDocs :: d a -> Int + + -- | Lookup a document by its id. + lookupById :: Monad m => d a -> DocId -> m (Document a) + + -- | Lookup the id of a document by an URI. + lookupByURI :: Monad m => d a -> URI -> m DocId + + -- | Union of two disjoint document tables. It is assumed, that the DocIds and the document uris + -- of both indexes are disjoint. If only the sets of uris are disjoint, the DocIds can be made + -- disjoint by adding maxDocId of one to the DocIds of the second, e.g. with editDocIds + + unionDocs :: d a -> d a -> d a + unionDocs dt1 = foldDocIdMap addDoc dt1 . toMap + where + addDoc d dt = snd . insertDoc dt $ d + + -- | Test whether the doc ids of both tables are disjoint + disjointDocs :: d a -> d a -> Bool + + -- | Return an empty document table. The input parameter is taken to identify the typeclass + makeEmpty :: d a -> d a + + -- | Insert a document into the table. Returns a tuple of the id for that document and the + -- new table. If a document with the same URI is already present, its id will be returned + -- and the table is returned unchanged. + + insertDoc :: d a -> (Document a) -> (DocId, d a) + + -- | Update a document with a certain DocId. + updateDoc :: d a -> DocId -> (Document a) -> d a + + -- | Removes the document with the specified id from the table. + removeById :: d a -> DocId -> d a + + -- | Removes the document with the specified URI from the table. + removeByURI :: d a -> URI -> d a + removeByURI ds u = maybe ds (removeById ds) (lookupByURI ds u) + + -- | Update documents (through mapping over all documents). + updateDocuments :: (Document a -> Document a) -> d a -> d a + + filterDocuments :: (Document a -> Bool) -> d a -> d a + + -- | Create a document table from a single map. + fromMap :: DocIdMap (Document a) -> d a + + -- | Convert document table to a single map + toMap :: d a -> DocIdMap (Document a) + + -- | Edit document ids + editDocIds :: (DocId -> DocId) -> d a -> d a + editDocIds f = fromMap . foldWithKeyDocIdMap (insertDocIdMap . f) emptyDocIdMap . toMap + +-- ------------------------------------------------------------ + +class HolCache c where + -- | Retrieves the full text of a document for a given context. Will never throw any exception, + -- upon failure or if no text found for the document, @Nothing@ is returned. + getDocText :: c -> Context -> DocId -> IO (Maybe Content) + + -- | Store the full text of a document for a given context. May throw an exception if the + -- storage of the text failed. + + putDocText :: c -> Context -> DocId -> Content -> IO () + -- | Merge two caches in the way that everything that is in the second cache is inserted into the + -- first one. + + mergeCaches :: c -> c -> IO c + +-- ------------------------------------------------------------ + +class (HolDocuments d a, HolIndex i) => HolDocIndex d a i where + + -- | Merge two doctables and indexes together into a single doctable and index + unionDocIndex :: d a -> i -> d a -> i -> (d a, i) + + -- | Defragment a doctable and index, useful when the doc ids are + -- organized as an intervall of ints. + -- + -- Default implementation is the identity + + defragmentDocIndex :: d a -> i -> (d a, i) + defragmentDocIndex = (,) + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/Common/BasicTypes.hs b/src/Holumbus/Index/Common/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common/BasicTypes.hs @@ -0,0 +1,46 @@ +{-# OPTIONS #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common.BasicTypes + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + Basic data types for index + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common.BasicTypes +where + +import Data.Word ( Word32 ) + +-- ------------------------------------------------------------ + +-- | The URI describing the location of the original document. +type URI = String + +-- | The title of a document. +type Title = String + +-- | The content of a document. +type Content = String + +-- | The position of a word in the document. +--type Position = Int +type Position = Word32 + +-- | The name of a context. +type Context = String + +-- | A single word. +type Word = String + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/Common/DiffList.hs b/src/Holumbus/Index/Common/DiffList.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common/DiffList.hs @@ -0,0 +1,108 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common.DiffList + Copyright : Copyright (C) 2011 Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.1 + + Providing space efficient difference encoding for lists of integers. The encoded + lists are compressed using "Holumbus.Data.Crunch" to save even more space. For + convenience, conversion functions for "Data.IntSet" are provided. Only works + for non-negative integers. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common.DiffList + ( + -- * DiffList types + DiffList + + -- * Conversion + , fromPositions + , toPositions + , fromList + , toList + + -- * Debug + , diffs + ) +where + +import Data.List +import Data.Word ( Word32 + , Word64 + ) + +import Holumbus.Data.Crunch + +import Holumbus.Index.Common.BasicTypes ( Position ) +import Holumbus.Index.Common.Occurences ( Positions + , fromListPos + , toAscListPos + ) + +-- ---------------------------------------------------------------------------- + +-- | A single difference between two integers. +type Diff = Word64 + +-- | A list of differences. +type DiffList = [Diff] + +-- | Convert a set of integers into a list of difference encoded values. + +fromPositions :: Positions -> DiffList +fromPositions = fromList . toAscListPos + +-- | Convert the difference encoded values to a list of integers. + +toPositions :: DiffList -> Positions +toPositions = fromListPos . toList + +-- | Convert a list of positions into a list of difference encoded values. + +fromList :: [Position] -> DiffList +fromList = crunch32 . encode . sort + +-- | Convert the difference encoded values to a list of integers. +-- The resulting list will be +-- sorted in ascending order + +toList :: DiffList -> [Position] +toList = decode . decrunch32 + +-- | This is were the real work is done: Encoding a sorted list of integers. + +encode :: [Position] -> [Word32] +encode = encode' 0 + where + encode' :: Word32 -> [Position] -> [Word32] + encode' _ [] = [] + encode' l (x:xs) = n:(encode' x xs) + where + n = fromIntegral (x - l) + +-- | This is were the real work is done: Decoding a difference list. + +decode :: [Word32] -> [Position] +decode = decode' 0 + where + decode' :: Position -> [Word32] -> [Position] + decode' _ [] = [] + decode' l (x:xs) = n:(decode' n xs) + where + n = (fromIntegral x) + l + +-- | Returns all differences. Used for debugging purposes. + +diffs :: DiffList -> [Word32] +diffs = decrunch32 + +-- ---------------------------------------------------------------------------- diff --git a/src/Holumbus/Index/Common/DocId.hs b/src/Holumbus/Index/Common/DocId.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common/DocId.hs @@ -0,0 +1,64 @@ +{-# OPTIONS -XGeneralizedNewtypeDeriving #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common.DocId + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + The document identifier type DocId + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common.DocId +where + +import Control.DeepSeq + +import Data.Binary ( Binary (..) ) +import qualified + Data.Binary as B +import Data.Word ( Word64 ) + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +-- | The unique identifier of a document +-- (created upon insertion into the document table). + +newtype DocId = DocId { theDocId :: Word64 } + deriving (Eq, Ord, Enum) +instance Show DocId where + show = show . theDocId + +instance NFData DocId where + rnf (DocId i) = rnf i + +instance Binary DocId where + put = B.put . theDocId + get = B.get >>= return . DocId + +incrDocId :: DocId -> DocId +incrDocId = DocId . (1+) . theDocId + +nullDocId :: DocId +nullDocId = DocId 0 + +firstDocId :: DocId +firstDocId = DocId 1 + +mkDocId :: Word64 -> DocId +mkDocId = DocId + +xpDocId :: PU DocId +xpDocId = xpWrap (DocId, theDocId) xpPrim + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/Common/DocIdMap.hs b/src/Holumbus/Index/Common/DocIdMap.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common/DocIdMap.hs @@ -0,0 +1,131 @@ +{-# OPTIONS -XTypeSynonymInstances -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common.DocIdMap + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + DocId maps + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common.DocIdMap +where + +import Control.DeepSeq + +import Data.Binary ( Binary (..) ) +import qualified + Data.Binary as B +import qualified + Data.EnumMap as IM + +import Holumbus.Index.Common.DocId + +-- import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +type DocIdMap v = IM.EnumMap DocId v + +emptyDocIdMap :: DocIdMap v +emptyDocIdMap = IM.empty + +singletonDocIdMap :: DocId -> v -> DocIdMap v +singletonDocIdMap d v = insertDocIdMap d v emptyDocIdMap + +nullDocIdMap :: DocIdMap v -> Bool +nullDocIdMap = IM.null + +memberDocIdMap :: DocId -> DocIdMap v -> Bool +memberDocIdMap = IM.member + +lookupDocIdMap :: DocId -> DocIdMap v -> Maybe v +lookupDocIdMap = IM.lookup + +insertDocIdMap :: DocId -> v -> DocIdMap v -> DocIdMap v +insertDocIdMap = IM.insert + +deleteDocIdMap :: DocId -> DocIdMap v -> DocIdMap v +deleteDocIdMap = IM.delete + +insertWithDocIdMap :: (v -> v -> v) -> DocId -> v -> DocIdMap v -> DocIdMap v +insertWithDocIdMap = IM.insertWith + +sizeDocIdMap :: DocIdMap v -> Int +sizeDocIdMap = IM.size + +minKeyDocIdMap :: DocIdMap v -> DocId +minKeyDocIdMap = maybe nullDocId (fst . fst) . IM.minViewWithKey + +maxKeyDocIdMap :: DocIdMap v -> DocId +maxKeyDocIdMap = maybe nullDocId (fst . fst) . IM.maxViewWithKey + +isIntervallDocIdMap :: DocIdMap v -> Bool +isIntervallDocIdMap m = nullDocIdMap m + || + ( fromEnum (theDocId (minKeyDocIdMap m) - theDocId (maxKeyDocIdMap m)) + == sizeDocIdMap m + ) + +unionDocIdMap :: DocIdMap v -> DocIdMap v -> DocIdMap v +unionDocIdMap = IM.union + +differenceDocIdMap :: DocIdMap v -> DocIdMap v -> DocIdMap v +differenceDocIdMap = IM.difference + +unionWithDocIdMap :: (v -> v -> v) -> DocIdMap v -> DocIdMap v -> DocIdMap v +unionWithDocIdMap = IM.unionWith + +intersectionWithDocIdMap :: (v -> v -> v) -> DocIdMap v -> DocIdMap v -> DocIdMap v +intersectionWithDocIdMap = IM.intersectionWith + +unionsWithDocIdMap :: (v -> v -> v) -> [DocIdMap v] -> DocIdMap v +unionsWithDocIdMap = IM.unionsWith + +mapDocIdMap :: (v -> r) -> DocIdMap v -> DocIdMap r +mapDocIdMap = IM.map + +filterDocIdMap :: (v -> Bool) -> DocIdMap v -> DocIdMap v +filterDocIdMap = IM.filter + +filterWithKeyDocIdMap :: (DocId -> v -> Bool) -> DocIdMap v -> DocIdMap v +filterWithKeyDocIdMap = IM.filterWithKey + +mapWithKeyDocIdMap :: (DocId -> v -> r) -> DocIdMap v -> DocIdMap r +mapWithKeyDocIdMap = IM.mapWithKey + +foldDocIdMap :: (v -> b -> b) -> b -> DocIdMap v -> b +foldDocIdMap = IM.fold + +foldWithKeyDocIdMap :: (DocId -> v -> b -> b) -> b -> DocIdMap v -> b +foldWithKeyDocIdMap = IM.foldWithKey + +fromListDocIdMap :: [(DocId, v)] -> DocIdMap v +fromListDocIdMap = IM.fromList + +toListDocIdMap :: DocIdMap v -> [(DocId, v)] +toListDocIdMap = IM.toList + +keysDocIdMap :: DocIdMap v -> [DocId] +keysDocIdMap = IM.keys + +elemsDocIdMap :: DocIdMap v -> [v] +elemsDocIdMap = IM.elems + +instance NFData v => NFData (DocIdMap v) where + rnf m = rnf (IM.toList m) + +instance Binary v => Binary (DocIdMap v) where + put = B.put . IM.toList + get = B.get >>= return . IM.fromList + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/Common/Document.hs b/src/Holumbus/Index/Common/Document.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common/Document.hs @@ -0,0 +1,61 @@ +{-# OPTIONS #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common.Document + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + The Document datatype + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common.Document +where + +import Control.Monad ( liftM3 ) +import Control.DeepSeq + +import Data.Binary ( Binary (..) ) +import qualified + Data.Binary as B + +import Holumbus.Index.Common.BasicTypes + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +-- | A document consists of a title and its unique identifier (URI) +-- and a customizable component + +data Document a = Document + { title :: ! Title + , uri :: ! URI + , custom :: ! (Maybe a) + } + deriving (Show, Eq, Ord) + +instance Binary a => Binary (Document a) where + put (Document t u c) = put t >> put u >> put c + get = liftM3 Document get get get + +instance XmlPickler a => XmlPickler (Document a) where + xpickle = xpWrap ( \ (t, u, i) -> Document t u i + , \ (Document t u i) -> (t, u, i) + ) (xpTriple xpTitle xpURI xpickle) + where + xpURI = xpAttr "href" xpText0 + xpTitle = xpAttr "title" xpText0 + +instance NFData a => NFData (Document a) where + rnf (Document t u c) = rnf t `seq` rnf u `seq` rnf c + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/Common/LoadStore.hs b/src/Holumbus/Index/Common/LoadStore.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common/LoadStore.hs @@ -0,0 +1,68 @@ +{-# OPTIONS #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common.LoadStore + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, UweSchmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + Load and store indexes + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common.LoadStore +where + +import Data.Binary ( Binary (..) ) +import qualified + Data.Binary as B + +import qualified + Data.List as L + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +-- | Try to determine the file type automatically. The file is loaded as XML if the filename +-- ends with \".xml\" and otherwise is loaded as binary file. + +loadFromFile :: (XmlPickler a, Binary a) => FilePath -> IO a +loadFromFile f = if L.isSuffixOf ".xml" f then loadFromXmlFile f else loadFromBinFile f + +-- | Load from XML file. + +loadFromXmlFile :: XmlPickler a => FilePath -> IO a +loadFromXmlFile f = do + r <- runX (xunpickleDocument xpickle options f) + return $! head r + where + options = [ withRemoveWS yes, withInputEncoding utf8, withValidate no ] + +-- | Write to XML file. + +writeToXmlFile :: XmlPickler a => FilePath -> a -> IO () +writeToXmlFile f i = do + runX (constA i >>> xpickleDocument xpickle options f) + >> return () + where + options = [ withIndent yes, withOutputEncoding utf8 ] + +-- | Load from a binary file. + +loadFromBinFile :: Binary a => FilePath -> IO a +loadFromBinFile = B.decodeFile + +-- | Write to a binary file. + +writeToBinFile :: Binary a => FilePath -> a -> IO () +writeToBinFile = B.encodeFile + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/Common/Occurences.hs b/src/Holumbus/Index/Common/Occurences.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common/Occurences.hs @@ -0,0 +1,141 @@ +{-# OPTIONS -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common.Occurences + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + The Occurences data type + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common.Occurences +where + +import Control.DeepSeq + +import Data.Binary ( Binary (..) ) +import qualified + Data.Binary as B + +import qualified Data.EnumMap as IM +import qualified Data.EnumSet as IS + +import Holumbus.Index.Common.BasicTypes +import Holumbus.Index.Common.DocId +import Holumbus.Index.Common.DocIdMap + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +-- | The occurrences in a number of documents. +-- A mapping from document ids to the positions in the document. + +type Occurrences = DocIdMap Positions + +-- | Create an empty set of positions. +emptyOccurrences :: Occurrences +emptyOccurrences = IM.empty + +-- | Create an empty set of positions. +singletonOccurrence :: DocId -> Position -> Occurrences +singletonOccurrence d p = insertOccurrence d p IM.empty + +-- | Test on empty set of positions. +nullOccurrences :: Occurrences -> Bool +nullOccurrences = IM.null + +-- | Determine the number of positions in a set of occurrences. +sizeOccurrences :: Occurrences -> Int +sizeOccurrences = IM.fold ((+) . IS.size) 0 + +insertOccurrence :: DocId -> Position -> Occurrences -> Occurrences +insertOccurrence d p = IM.insertWith IS.union d (singletonPos p) + +deleteOccurrence :: DocId -> Position -> Occurrences -> Occurrences +deleteOccurrence d p = substractOccurrences (IM.singleton d (singletonPos p)) + +updateOccurrences :: (DocId -> DocId) -> Occurrences -> Occurrences +updateOccurrences f = IM.foldWithKey (\ d ps res -> IM.insertWith IS.union (f d) ps res) emptyOccurrences + +-- | Merge two occurrences. +mergeOccurrences :: Occurrences -> Occurrences -> Occurrences +mergeOccurrences = IM.unionWith IS.union + +diffOccurrences :: Occurrences -> Occurrences -> Occurrences +diffOccurrences = IM.difference + +-- | Substract occurrences from some other occurrences. +substractOccurrences :: Occurrences -> Occurrences -> Occurrences +substractOccurrences = IM.differenceWith substractPositions + where + substractPositions p1 p2 + = if IS.null diffPos + then Nothing + else Just diffPos + where + diffPos = IS.difference p1 p2 + +-- | The XML pickler for the occurrences of a word. + +xpOccurrences :: PU Occurrences +xpOccurrences = xpWrap (IM.fromList, IM.toList) + (xpList xpOccurrence) + where + xpOccurrence = xpElem "doc" $ + xpPair (xpAttr "idref" xpDocId) + xpPositions + +-- ------------------------------------------------------------ + +-- | The positions of the word in the document. +type Positions = IS.EnumSet Position + +emptyPos :: Positions +emptyPos = IS.empty + +singletonPos :: Position -> Positions +singletonPos = IS.singleton + +memberPos :: Position -> Positions -> Bool +memberPos = IS.member + +toAscListPos :: Positions -> [Position] +toAscListPos = IS.toAscList + +fromListPos :: [Position] -> Positions +fromListPos = IS.fromList + +sizePos :: Positions -> Int +sizePos = IS.size + +unionPos :: Positions -> Positions -> Positions +unionPos = IS.union + +foldPos :: (Position -> r -> r) -> r -> Positions -> r +foldPos = IS.fold + +-- | The XML pickler for a set of positions. +xpPositions :: PU Positions +xpPositions = xpWrap ( IS.fromList . (map read) . words + , unwords . (map show) . IS.toList + ) xpText + +instance (NFData v, Enum v) => NFData (IS.EnumSet v) where + rnf = rnf . IS.toList + +instance (Binary v, Enum v) => Binary (IS.EnumSet v) where + put = B.put . IS.toList + get = B.get >>= return . IS.fromList + +-- ------------------------------------------------------------ + diff --git a/src/Holumbus/Index/Common/RawResult.hs b/src/Holumbus/Index/Common/RawResult.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Common/RawResult.hs @@ -0,0 +1,55 @@ +{-# OPTIONS #-} {-XMultiParamTypeClasses -XFlexibleContexts -XFlexibleInstances -XGeneralizedNewtypeDeriving -XTypeSynonymInstances -fno-warn-orphans #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Common.RawResult + Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: none portable + + The RawResult data type + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Common.RawResult +where + +import qualified Data.EnumMap as IM + +import Data.Map (Map) +import qualified Data.Map as M + +import Holumbus.Index.Common.BasicTypes +import Holumbus.Index.Common.DocIdMap +import Holumbus.Index.Common.Occurences + +-- ------------------------------------------------------------ + +-- | The raw result returned when searching the index. + +type RawResult = [(Word, Occurrences)] + +-- | Transform the raw result into a tree structure ordered by word. + +resultByWord :: Context -> RawResult -> Map Word (Map Context Occurrences) +resultByWord c + = M.fromList . map (\ (w, o) -> (w, M.singleton c o)) + +-- | Transform the raw result into a tree structure ordered by document. + +resultByDocument :: Context -> RawResult -> DocIdMap (Map Context (Map Word Positions)) +resultByDocument c os + = mapDocIdMap transform $ + IM.unionsWith (flip $ (:) . head) (map insertWords os) + where + insertWords (w, o) = mapDocIdMap (\p -> [(w, p)]) o + transform w = M.singleton c (M.fromList w) + +-- ------------------------------------------------------------ + diff --git a/src/Holumbus/Index/CompactDocuments.hs b/src/Holumbus/Index/CompactDocuments.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/CompactDocuments.hs @@ -0,0 +1,313 @@ +{-# OPTIONS -XFlexibleInstances -XMultiParamTypeClasses #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.CompactDocuments + Copyright : Copyright (C) 2007- Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: MultiParamTypeClasses FlexibleInstances + + A more space efficient substitute for Holumbus.Index.Documents +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.CompactDocuments +( + -- * Documents type + Documents (..) + , CompressedDoc(..) + , DocMap + , URIMap + + -- * Construction + , emptyDocuments + , singleton + + -- * Conversion + , simplify + , toDocument + , fromDocument + , fromDocMap + , toDocMap +) +where + +import qualified Codec.Compression.BZip as BZ + +import Control.DeepSeq + +import Data.Binary ( Binary ) +import qualified Data.Binary as B +import Data.ByteString.Lazy ( ByteString ) +import qualified Data.ByteString.Lazy as BS +import Data.Maybe ( fromJust ) + +import qualified Holumbus.Data.PrefixTree as M +import Holumbus.Index.Common + +import Text.XML.HXT.Core + +-- ---------------------------------------------------------------------------- + +-- | The table which is used to map a document to an artificial id and vice versa. + +type URIMap = M.PrefixTree DocId +type DocMap a = DocIdMap (CompressedDoc a) + +newtype CompressedDoc a = CDoc { unCDoc :: ByteString } + deriving (Eq, Show) + +data Documents a = Documents + { idToDoc :: ! (DocMap a) -- ^ A mapping from a document id to + -- the document itself. + , docToId :: ! URIMap -- ^ A space efficient mapping from + -- the URI of a document to its id. + , lastDocId :: ! DocId -- ^ The last used document id. + } + deriving (Show) + +-- ---------------------------------------------------------------------------- + +instance (Binary a, HolIndex i) => HolDocIndex Documents a i where + defragmentDocIndex dt ix = (dt1, ix1) + where + dt1 = editDocIds editId dt + ix1 = updateDocIds' editId ix + editId i = fromJust . lookupDocIdMap i $ idMap + idMap = fromListDocIdMap . flip zip (map mkDocId [1..]) . keysDocIdMap . toMap $ dt + + unionDocIndex dt1 ix1 dt2 ix2 + | s1 == 0 = (dt2, ix2) + | s2 == 0 = (dt1, ix1) + | s1 < s2 = unionDocIndex dt2 ix2 dt1 ix1 + | otherwise = (dt, ix) + where + dt = unionDocs dt1 dt2s + ix = mergeIndexes ix1 ix2s + + dt2s = editDocIds add1 dt2 + ix2s = updateDocIds' add1 ix2 + + add1 = mkDocId . (+ disp) . theDocId + max1 = maxKeyDocIdMap . toMap $ dt1 + min2 = minKeyDocIdMap . toMap $ dt2 + disp = theDocId max1 + 1 - theDocId min2 + + s1 = sizeDocs dt1 + s2 = sizeDocs dt2 + +-- ---------------------------------------------------------------------------- + +toDocument :: (Binary a) => CompressedDoc a -> Document a +toDocument = B.decode . BZ.decompress . unCDoc + +fromDocument :: (Binary a) => Document a -> CompressedDoc a +fromDocument = CDoc . BZ.compress . B.encode + +mapDocument :: (Binary a) => (Document a -> Document a) -> CompressedDoc a -> CompressedDoc a +mapDocument f = fromDocument . f . toDocument + +toDocMap :: (Binary a) => DocIdMap (Document a) -> DocMap a +toDocMap = mapDocIdMap fromDocument + +fromDocMap :: (Binary a) => DocMap a -> DocIdMap (Document a) +fromDocMap = mapDocIdMap toDocument + +-- ---------------------------------------------------------------------------- + +instance Binary a => HolDocuments Documents a where + sizeDocs d = sizeDocIdMap (idToDoc d) + + lookupById d i = maybe (fail "") return + . fmap toDocument + . lookupDocIdMap i + $ idToDoc d + lookupByURI d u = maybe (fail "") return + . M.lookup u + $ docToId d + + -- this is a sufficient test, but if the doc ids don't form an intervall + -- it may be too restrictive + + disjointDocs dt1 dt2 + | nullDocs dt1 + || + nullDocs dt2 = True + | otherwise = disjoint ( minKeyDocIdMap . idToDoc $ dt1 + , maxKeyDocIdMap . idToDoc $ dt1 + ) + ( minKeyDocIdMap . idToDoc $ dt2 + , maxKeyDocIdMap . idToDoc $ dt2 + ) + where + disjoint p1@(x1, y1) p2@(x2, _y2) + | x1 <= x2 = y1 < x2 + | otherwise = disjoint p2 p1 + + unionDocs dt1 dt2 + | disjointDocs dt1 dt2 = Documents + { idToDoc = unionDocIdMap (idToDoc dt1) (idToDoc dt2) + , docToId = M.union (docToId dt1) (docToId dt2) + , lastDocId = lastDocId dt1 `max` lastDocId dt2 + } + | otherwise = error $ + "unionDocs: doctables are not disjoint: " ++ + show (didIntervall dt1) ++ ", " ++ show (didIntervall dt2) + where + didIntervall dt = ( minKeyDocIdMap . idToDoc $ dt + , maxKeyDocIdMap . idToDoc $ dt + ) + + makeEmpty _ = emptyDocuments + + insertDoc ds d = maybe reallyInsert (\oldId -> (oldId, ds)) (lookupByURI ds (uri d)) + where + reallyInsert = (newId, Documents newIdToDoc newDocToId newId) + where + newIdToDoc = insertDocIdMap newId (fromDocument d) (idToDoc ds) + newDocToId = M.insert (uri d) newId (docToId ds) + newId = incrDocId (lastDocId ds) + + updateDoc ds i d = ds + { idToDoc = insertDocIdMap i (fromDocument d) (idToDoc ds) + , docToId = M.insert (uri d) i (docToId (removeById ds i)) + } + + removeById ds d = maybe ds reallyRemove (lookupById ds d) + where + reallyRemove (Document _ u _) + = Documents + (deleteDocIdMap d (idToDoc ds)) + (M.delete u (docToId ds)) + (lastDocId ds) + + updateDocuments f d = Documents updated (idToDoc2docToId updated) (lastId updated) + where + updated = mapDocIdMap (mapDocument f) (idToDoc d) + + filterDocuments p d = Documents filtered (idToDoc2docToId filtered) (lastId filtered) + where + filtered = filterDocIdMap (p . toDocument) (idToDoc d) + + fromMap itd' = Documents itd (idToDoc2docToId itd) (lastId itd) + where + itd = toDocMap itd' + + toMap = fromDocMap . idToDoc + + editDocIds f d = Documents + { idToDoc = newIdToDoc + , docToId = M.map f $ docToId d + , lastDocId = lastId newIdToDoc + } + where + newIdToDoc = foldWithKeyDocIdMap (insertDocIdMap . f) emptyDocIdMap + $ idToDoc d + +-- ------------------------------------------------------------ + +-- Ignoring last document id when testing for equality + +instance Eq a => Eq (Documents a) + where + (==) (Documents i2da d2ia _) (Documents i2db d2ib _) + = (i2da == i2db) + && + (d2ia == d2ib) + +-- ---------------------------------------------------------------------------- + +instance NFData a => NFData (Documents a) + where + rnf (Documents i2d d2i lid) = rnf i2d `seq` rnf d2i `seq` rnf lid + +-- ---------------------------------------------------------------------------- + +instance (Binary a, XmlPickler a) => + XmlPickler (Documents a) + where + xpickle = xpElem "documents" $ + xpWrap convertDoctable $ + xpWrap (fromListDocIdMap, toListDocIdMap) $ + xpList xpDocumentWithId + where + convertDoctable = ( \ itd -> Documents itd (idToDoc2docToId itd) (lastId itd) + , \ (Documents itd _ _) -> itd + ) + xpDocumentWithId = xpElem "doc" $ + xpPair (xpAttr "id" xpDocId) xpickle + +-- ---------------------------------------------------------------------------- + +instance Binary a => Binary (Documents a) + where + put (Documents i2d _ lid) = B.put lid >> B.put i2d + get = do lid <- B.get + i2d <- B.get + return (Documents i2d (idToDoc2docToId i2d) lid) + +-- ------------------------------------------------------------ + +instance (Binary a, XmlPickler a) => + XmlPickler (CompressedDoc a) + where + xpickle = xpWrap (fromDocument , toDocument) $ + xpickle + +-- ---------------------------------------------------------------------------- + +instance Binary a => Binary (CompressedDoc a) + where + put = B.put . unCDoc + get = B.get >>= return . CDoc + +-- ---------------------------------------------------------------------------- + +instance NFData (CompressedDoc a) + where + rnf (CDoc s) = BS.length s `seq` () + +-- ------------------------------------------------------------ + +-- | Create an empty table. + +emptyDocuments :: Documents a +emptyDocuments = Documents emptyDocIdMap M.empty nullDocId + +-- | Create a document table containing a single document. + +singleton :: (Binary a) => Document a -> Documents a +singleton d = Documents + (singletonDocIdMap firstDocId (fromDocument d)) + (M.singleton (uri d) firstDocId) + firstDocId + +-- | Simplify a document table by transforming the custom information into a string. + +simplify :: (Binary a, Show a) => Documents a -> Documents String +simplify dt = Documents (simple (idToDoc dt)) (docToId dt) (lastDocId dt) + where + simple i2d = mapDocIdMap + ( fromDocument + . (\d -> Document (title d) (uri d) (maybe Nothing (Just . show) (custom d))) + . toDocument + ) i2d + +-- | Construct the inverse map from the original map. + +idToDoc2docToId :: Binary a => DocMap a -> URIMap +idToDoc2docToId = foldWithKeyDocIdMap + (\i d r -> M.insert (uri . toDocument $ d) i r) + M.empty + +-- | Query the 'idToDoc' part of the document table for the last id. + +lastId :: DocMap a -> DocId +lastId = maxKeyDocIdMap + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/CompactIndex.hs b/src/Holumbus/Index/CompactIndex.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/CompactIndex.hs @@ -0,0 +1,276 @@ +{-# OPTIONS #-} + +-- ------------------------------------------------------------ + +module Holumbus.Index.CompactIndex + ( Document + , Documents + , SmallDocuments + + , Inverted + , emptyInverted + , removeDocIdsInverted + + , CompactInverted + , emptyCompactInverted + , inverted2compactInverted + + , HolumbusState + , HolumbusConfig + , emptyHolumbusState + , defragmentHolumbusState + + , emptyIndexerState + , emptyDocuments + + , emptySmallDocuments + , docTable2smallDocTable + + , mergeAndWritePartialRes' + , writeXml + , writeBin + , writeSearchBin + , writePartialIndex + ) +where + +import Control.Arrow +import Control.DeepSeq +import Control.Monad.Reader + +import Data.Binary + +import Data.Function.Selector ( (.&&&.) ) + +import Holumbus.Crawler.Types +import Holumbus.Crawler.IndexerCore +import Holumbus.Crawler.Logger + +import Holumbus.Index.Common ( Document(..) + , Occurrences + , defragmentDocIndex + , fromList + , toList + , unionDocs + , mergeIndexes + ) + +import Holumbus.Index.CompactDocuments + ( Documents(..) + , emptyDocuments + ) + +import Holumbus.Index.CompactSmallDocuments + ( SmallDocuments(..) + , docTable2smallDocTable + ) +import qualified Holumbus.Index.CompactSmallDocuments + as CSD + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +{- .1: direct use of prefix tree with simple-9 encoded occurences + + concerning efficiency this implementation is about the same as the 2. one, + space and time are minimally better, the reason could be less code working with classes + +import Holumbus.Index.Inverted.PrefixMem + +-- -} +-- ------------------------------------------------------------ + +{- .2: indirect use of prefix tree with simple-9 encoded occurences via InvertedCompressed + + minimal overhead compared to .1 + but less efficient in time (1598s / 1038s) and space + total mem use (2612MB / 2498MB) than .3 + +import qualified Holumbus.Index.Inverted.CompressedPrefixMem as PM + +type Inverted = PM.InvertedCompressed + +emptyInverted :: Inverted +emptyInverted = PM.emptyInvertedCompressed + +-- -} + +-- ------------------------------------------------------------ +-- {- + +{- .3: indirect prefix tree without compression of position sets + + best of these 3 implementations + + implementations with serializations become much more inefficient + in runtime and are not worth to be considered +-} + +import qualified Holumbus.Index.Inverted.CompressedPrefixMem as PM + +type Inverted = PM.Inverted0 + +emptyInverted :: Inverted +emptyInverted = PM.emptyInverted0 + +removeDocIdsInverted :: Occurrences -> Inverted -> Inverted +removeDocIdsInverted = PM.removeDocIdsInverted + +type CompactInverted = PM.InvertedOSerialized + +emptyCompactInverted :: CompactInverted +emptyCompactInverted = PM.emptyInvertedOSerialized + +inverted2compactInverted :: Inverted -> CompactInverted +inverted2compactInverted = fromList PM.emptyInvertedOSerialized . toList + +-- -} +-- ------------------------------------------------------------ + +type HolumbusState di = IndexerState Inverted Documents di +type HolumbusConfig di = IndexCrawlerConfig Inverted Documents di + +emptyHolumbusState :: HolumbusState di +emptyHolumbusState = emptyIndexerState emptyInverted emptyDocuments + +flushHolumbusState :: HolumbusState di -> HolumbusState di +flushHolumbusState hs = hs { ixs_index = emptyInverted + , ixs_documents = emptyDocuments + { lastDocId = lastDocId . ixs_documents $ hs } + } + +emptySmallDocuments :: SmallDocuments a +emptySmallDocuments = CSD.emptyDocuments + +-- ------------------------------------------------------------ + +defragmentHolumbusState :: (Binary di) => + HolumbusState di -> HolumbusState di +defragmentHolumbusState IndexerState + { ixs_index = ix + , ixs_documents = dt + } = IndexerState + { ixs_index = ix' + , ixs_documents = dt' + } + where + (dt', ix') = defragmentDocIndex dt ix + +-- ------------------------------------------------------------ + +mergeAndWritePartialRes' :: (MonadIO m, NFData i, Binary i) => + (SmallDocuments i -> SmallDocuments i) -> [String] -> String -> m () +mergeAndWritePartialRes' id' pxs out + = do notice $ ["merge partial doctables from"] ++ pxs + mdocs <- mergeSmallDocs $ map (++ ".doc") pxs + notice $ ["write merged doctable to", out ++ ".doc"] + liftIO $ encodeFile (out ++ ".doc") (id' mdocs) + notice $ ["merge partial indexes from"] ++ pxs + mixs <- mergeCompactIxs $ map (++ ".idx") pxs + notice $ ["write merged indexes to", out ++ ".idx"] + liftIO $ encodeFile (out ++ ".idx") mixs + notice $ ["merge partial doctables and indexes done"] + +mergeSmallDocs :: (MonadIO m, NFData i, Binary i) => [String] -> m (SmallDocuments i) +mergeSmallDocs [] + = return emptySmallDocuments +mergeSmallDocs (x : xs) + = do docs <- mergeSmallDocs xs + notice ["merge small documents from file", x] + doc1 <- liftIO $ decodeFile x + rnf doc1 `seq` + (return $ unionDocs docs doc1) + +mergeCompactIxs :: (MonadIO m) => [String] -> m CompactInverted +mergeCompactIxs [] + = return emptyCompactInverted +mergeCompactIxs (x : xs) + = do ixs <- mergeCompactIxs xs + notice ["merge compact index from file", x] + ix1 <- liftIO $ decodeFile x + rnf ix1 `seq` + (return $ mergeIndexes ix1 ixs) + +-- ------------------------------------------------------------ + +writeXml :: (MonadIO m, XmlPickler a) => FilePath -> a -> m () +writeXml xf v + | xmlOut + = do notice ["writing into XML file", xmlFile] + liftIO $ runX (constA v + >>> hxtSetTraceAndErrorLogger WARNING + >>> xpickleDocument xpickle [withIndent yes] xmlFile + ) + >> return () + notice ["writing XML finished"] + | otherwise + = notice ["no XML output"] + where + (xmlOut, xmlFile) + | null xf = (False, xf) + | xf == "-" = (True, "") + | otherwise = (True, xf) + +writeBin :: (MonadIO m, Binary a) => FilePath -> a -> m () +writeBin out v + | null out + = notice ["no binary output"] + | otherwise + = do notice ["writing into binary file", out] + liftIO $ encodeFile out v + notice ["writing binary data finished"] + +writeSearchBin :: (Binary c, MonadIO m) => FilePath -> HolumbusState c -> m () +writeSearchBin out state + | null out + = notice ["no search index written"] + | otherwise + = do notice ["writing small document table into binary file", docFile] + liftIO $ encodeFile docFile (docTable2smallDocTable . ixs_documents $ state) + notice ["writing compressed inverted index into binary file", idxFile] + liftIO $ encodeFile idxFile (inverted2compactInverted . ixs_index $ state) + notice ["writing search index files finished"] + where + docFile = out ++ ".doc" + idxFile = out ++ ".idx" + +-- ------------------------------------------------------------ + +writePartialIndex :: (NFData c, XmlPickler c, Binary c) => + Bool -> FilePath -> CrawlerAction a (HolumbusState c) () +writePartialIndex xout fn + = modifyStateIO + (theResultAccu .&&&. theResultInit) + (\ (r, _i) -> do r' <- writePartialIndex' xout fn r + return (r', r') + ) + +{- the above code is a bit tricky: + when crawling is done in parallel, then initial result is used as a unit value, + when merging results. When a partial index is written out, the document id count + must not be set back to its initial value, to avoid renumbering when merging then + partial indexes. As a consequence, not only the result accu must be changed + but also the initial value. + + When this is not done, the indexer runs fine when using the sequential merge, + but when running the parallel one, the index ids will overlap. +-} + +writePartialIndex' :: (NFData c, XmlPickler c, Binary c) => + Bool -> FilePath -> HolumbusState c -> IO (HolumbusState c) +writePartialIndex' xout out ixs + = do writeSearchBin out ixs + if xout + then writeXml (out ++ ".xml") ixs + else return () + let ixs' = flushHolumbusState ixs + rnf ixs' `seq` + return ixs' + +-- ------------------------------------------------------------ + +notice :: MonadIO m => [String] -> m () +notice = noticeC "compactIndex" + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/CompactSmallDocuments.hs b/src/Holumbus/Index/CompactSmallDocuments.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/CompactSmallDocuments.hs @@ -0,0 +1,198 @@ +{-# OPTIONS -XFlexibleInstances -XMultiParamTypeClasses #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.CompactDocuments + Copyright : Copyright (C) 2007-2010 Sebastian M. Schlatt, Timo B. Huebel + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: MultiParamTypeClasses FlexibleInstances + + A simple version of Holumbus.Index.Documents. + This implementation is only for reading a document table in the search part of an application. + The mapping of URIs to DocIds is only required during index building, not when accessing the index. + So this 2. mapping is removed in this implementation for saving space +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.CompactSmallDocuments +( + -- * Documents type + SmallDocuments (..) + + -- * Construction + , emptyDocuments + , singleton + + -- * Conversion + , docTable2smallDocTable +) +where + +import Control.DeepSeq + +import Data.Binary ( Binary ) +import qualified Data.Binary as B + +import Holumbus.Index.Common +import qualified Holumbus.Index.CompactDocuments as CD + +import Text.XML.HXT.Core + +-- ---------------------------------------------------------------------------- + +-- | The table to store the document descriptions +-- +-- This table does not contain the reverse map from URIs do DocIds, +-- this reverse map is only needed when crawling, not for searching the index. +-- As a consequence, most of the indes operations are not implemented +-- +-- see also 'Holumbus.Index.CompactDocuments.Documents' data type + +newtype SmallDocuments a = SmallDocuments + { idToSmallDoc :: CD.DocMap a -- ^ A mapping from a doc id + -- to the document itself. + } + +-- ---------------------------------------------------------------------------- + +instance (Binary a, HolIndex i) => HolDocIndex SmallDocuments a i where + defragmentDocIndex = notImpl +{- + defragmentDocIndex dt ix = (dt1, ix1) + where + dt1 = editDocIds editId dt + ix1 = updateDocIds' editId ix + editId i = fromJust . lookupDocIdMap i $ idMap + idMap = fromListDocIdMap . flip zip (map mkDocId [1..]) . keysDocIdMap . toMap $ dt +-} + + unionDocIndex dt1 ix1 dt2 ix2 + = (dt, ix) + where + dt = unionDocs dt1 dt2 + ix = mergeIndexes ix1 ix2 + +-- ---------------------------------------------------------------------------- + +instance Binary a => HolDocuments SmallDocuments a where + sizeDocs = sizeDocIdMap . idToSmallDoc + + lookupById d i = maybe (fail "") return + . fmap CD.toDocument + . lookupDocIdMap i + . idToSmallDoc + $ d + + makeEmpty _ = emptyDocuments + + -- this is a sufficient test, but if the doc ids don't form an intervall + -- it may be too strict + + disjointDocs dt1 dt2 + | nullDocs dt1 + || + nullDocs dt2 = True + | otherwise = disjoint ( minKeyDocIdMap . idToSmallDoc $ dt1 + , maxKeyDocIdMap . idToSmallDoc $ dt1 + ) + ( minKeyDocIdMap . idToSmallDoc $ dt2 + , maxKeyDocIdMap . idToSmallDoc $ dt2 + ) + where + disjoint p1@(x1, y1) p2@(x2, _y2) + | x1 <= x2 = y1 < x2 + | otherwise = disjoint p2 p1 + + unionDocs dt1 dt2 + | disjointDocs dt1 dt2 = SmallDocuments + { idToSmallDoc = unionDocIdMap (idToSmallDoc dt1) (idToSmallDoc dt2) + } + | otherwise = error $ + "unionDocs: doctables are not disjoint: " ++ + show (didIntervall dt1) ++ ", " ++ show (didIntervall dt2) + where + didIntervall dt = ( minKeyDocIdMap . idToSmallDoc $ dt + , maxKeyDocIdMap . idToSmallDoc $ dt + ) + + editDocIds f d = SmallDocuments + { idToSmallDoc = newIdToDoc + } + where + newIdToDoc = foldWithKeyDocIdMap (insertDocIdMap . f) emptyDocIdMap + $ idToSmallDoc d + + fromMap = SmallDocuments . CD.toDocMap + toMap = CD.fromDocMap . idToSmallDoc + + -- only lookup by doc id, union and defragment ops are implemented + -- the others are not needed when merging or searching the doc indexes + + lookupByURI = notImpl + + insertDoc = notImpl + updateDoc = notImpl + removeById = notImpl + updateDocuments = notImpl + filterDocuments = notImpl + +-- ---------------------------------------------------------------------------- + +instance NFData a => NFData (SmallDocuments a) + where + rnf (SmallDocuments i2d) = rnf i2d + +-- ---------------------------------------------------------------------------- + +instance (Binary a, XmlPickler a) => + XmlPickler (SmallDocuments a) + where + xpickle = xpElem "documents" $ + xpWrap convertDoctable $ + xpWrap (fromListDocIdMap, toListDocIdMap) $ + xpList xpDocumentWithId + where + convertDoctable = ( SmallDocuments + , idToSmallDoc + ) + xpDocumentWithId = xpElem "doc" $ + xpPair (xpAttr "id" xpDocId) xpickle + +-- ---------------------------------------------------------------------------- + +instance Binary a => Binary (SmallDocuments a) + where + put (SmallDocuments i2d) = B.put i2d + get = do + i2d <- B.get + return $ SmallDocuments i2d + +-- ------------------------------------------------------------ + +notImpl :: a +notImpl = error "operation not implemented for SmallDocuments data type" + +-- ------------------------------------------------------------ + +-- | Create an empty table. + +emptyDocuments :: SmallDocuments a +emptyDocuments = SmallDocuments emptyDocIdMap + +-- | Create a document table containing a single document. + +singleton :: (Binary a) => Document a -> SmallDocuments a +singleton d = SmallDocuments (singletonDocIdMap firstDocId (CD.fromDocument d)) + +-- | Convert a Compact document table into a small compact document table. +-- Called at the end of building an index + +docTable2smallDocTable :: CD.Documents a -> SmallDocuments a +docTable2smallDocTable = SmallDocuments . CD.idToDoc + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Index/Compression.hs b/src/Holumbus/Index/Compression.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Compression.hs @@ -0,0 +1,68 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Compression + Copyright : Copyright (C) 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.1 + + This module provides several specific compression mechanisms for different + parts of indexes. Right now, just a general compression scheme for + the 'Occurrences' and 'Positions' are provided. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Index.Compression + ( + -- * Compression types + CompressedOccurrences + , CompressedPositions + + -- * Compress + , deflateOcc + , deflatePos + + -- * Decompress + , inflateOcc + , inflatePos + ) +where + +import Holumbus.Index.Common.DocIdMap +import Holumbus.Index.Common.Occurences +import Holumbus.Index.Common.DiffList + +-- ---------------------------------------------------------------------------- + +type CompressedOccurrences = DocIdMap CompressedPositions +type CompressedPositions = DiffList + +-- ---------------------------------------------------------------------------- + +-- | Decompressing the occurrences by just decompressing all contained positions. + +inflateOcc :: CompressedOccurrences -> Occurrences +inflateOcc = mapDocIdMap inflatePos + +-- | Compress the occurrences by just compressing all contained positions. + +deflateOcc :: Occurrences -> CompressedOccurrences +deflateOcc = mapDocIdMap deflatePos + +-- | Convert the compressed differences back to a set of integers. + +inflatePos :: CompressedPositions -> Positions +inflatePos = toPositions + +-- | Save some memory on the positions by just saving their differences and compressing these. + +deflatePos :: Positions -> CompressedPositions +deflatePos = fromPositions + +-- ---------------------------------------------------------------------------- diff --git a/src/Holumbus/Index/Inverted/CompressedPrefixMem.hs b/src/Holumbus/Index/Inverted/CompressedPrefixMem.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Inverted/CompressedPrefixMem.hs @@ -0,0 +1,464 @@ +module Holumbus.Index.Inverted.CompressedPrefixMem + ( Inverted(..) + , Parts + , Part + , Inverted0 + , InvertedCompressed + , InvertedSerialized + , InvertedCSerialized + , InvertedOSerialized + + , ComprOccurrences(..) + + , emptyInverted0 + , emptyInvertedCompressed + , emptyInvertedSerialized + , emptyInvertedCSerialized + , emptyInvertedOSerialized + + , Sizeof(..) + , sizeofAttrsInverted + + , mapOcc + , zipOcc + , emptyOcc + , theOcc + , nullOcc + , unionOcc + , diffOcc + , insertPosOcc + , deletePosOcc + , updateDocIdOcc + , deleteDocIds + + , removeDocIdsInverted + ) +where + +import qualified Codec.Compression.BZip as BZ + +import Control.DeepSeq + +import qualified Data.ByteString.Lazy as BS +import qualified Data.Binary as B + +import Data.Function ( on ) + +import Data.Int + +import Data.List ( foldl', sortBy ) +import qualified Data.Map as M +import Data.Maybe + +import Holumbus.Index.Common +import Holumbus.Index.Compression + +import qualified Holumbus.Data.PrefixTree as PT + +import Text.XML.HXT.Core + +-- ---------------------------------------------------------------------------- + +class ComprOccurrences s where + toOccurrences :: s -> Occurrences + fromOccurrences :: Occurrences -> s + +mapOcc :: (ComprOccurrences s) => (Occurrences -> Occurrences) -> s -> s +mapOcc f = fromOccurrences . f . toOccurrences + +zipOcc :: (ComprOccurrences s) => (Occurrences -> Occurrences -> Occurrences) -> s -> s -> s +zipOcc op x y = fromOccurrences $ op (toOccurrences x)(toOccurrences y) + +emptyOcc :: (ComprOccurrences s) => s +emptyOcc = fromOccurrences $ emptyOccurrences + +theOcc :: (ComprOccurrences s) => s -> Occurrences +theOcc = toOccurrences + +nullOcc :: (ComprOccurrences s) => s -> Bool +nullOcc = (== emptyOccurrences) . toOccurrences -- better nullOccurrences, but not yet there + +unionOcc :: (ComprOccurrences s) => Occurrences -> s -> s +unionOcc os = mapOcc $ mergeOccurrences os + +diffOcc :: (ComprOccurrences s) => Occurrences -> s -> s +diffOcc os = mapOcc $ substractOccurrences os + +insertPosOcc :: (ComprOccurrences s) => DocId -> Position -> s -> s +insertPosOcc d p = mapOcc $ insertOccurrence d p + +deletePosOcc :: (ComprOccurrences s) => DocId -> Position -> s -> s +deletePosOcc d p = mapOcc $ deleteOccurrence d p + +updateDocIdOcc :: (ComprOccurrences s) => (DocId -> DocId) -> s -> s +updateDocIdOcc f = mapOcc $ updateOccurrences f + +deleteDocIds :: (ComprOccurrences s) => Occurrences -> s -> s +deleteDocIds ids = mapOcc $ flip diffOccurrences ids + +-- ---------------------------------------------------------------------------- +-- +-- overloaded function sizeof for estimating the size of a value + +class Sizeof a where + sizeof :: a -> Int64 + +-- ---------------------------------------------------------------------------- +-- +-- auxiliary types + +newtype ByteString = Bs { unBs :: BS.ByteString } + deriving (Eq, Show) + +instance NFData ByteString where + rnf s = BS.length (unBs s) `seq` () + +instance B.Binary ByteString where + put = B.put . unBs + get = B.get >>= return . Bs + +instance Sizeof ByteString where + sizeof = (8 + ) . BS.length . unBs -- we need the size of the length + the length + +-- ---------------------------------------------------------------------------- +-- +-- the pure occurrence type, just wrapped in a newtype for instance declarations + +newtype Occ0 = Occ0 { unOcc0 :: Occurrences } + +instance ComprOccurrences Occ0 where + fromOccurrences = Occ0 + toOccurrences = unOcc0 + +instance NFData Occ0 where + rnf = rnf . unOcc0 + +instance B.Binary Occ0 where + put = B.put . unOcc0 + get = B.get >>= return . Occ0 + +instance Sizeof Occ0 where + sizeof = BS.length . B.encode . unOcc0 + +-- ---------------------------------------------------------------------------- +-- +-- the simple-9 compressed occurrence type, just wrapped in a newtype for instance declarations + +newtype OccCompressed = OccCp { unOccCp :: CompressedOccurrences } + deriving (Eq, Show) + +instance ComprOccurrences OccCompressed where + fromOccurrences = OccCp . deflateOcc + toOccurrences = inflateOcc . unOccCp + +instance NFData OccCompressed where + rnf = rnf . unOccCp + +instance B.Binary OccCompressed where + put = B.put . unOccCp + get = B.get >>= return . OccCp + +instance Sizeof OccCompressed where + sizeof = BS.length . B.encode . unOccCp + +-- ---------------------------------------------------------------------------- +-- +-- the simpe-9 compresses occurrences serialized into a byte strings + +newtype OccSerialized = OccBs { unOccBs :: ByteString } + deriving (Eq, Show) + +instance ComprOccurrences OccSerialized where + fromOccurrences = OccBs . Bs . B.encode . deflateOcc + toOccurrences = inflateOcc . B.decode . unBs . unOccBs + +instance NFData OccSerialized where + rnf = rnf . unOccBs + +instance B.Binary OccSerialized where + put = B.put . unOccBs + get = B.get >>= return . OccBs + +instance Sizeof OccSerialized where + sizeof = sizeof . unOccBs + +-- ---------------------------------------------------------------------------- +-- +-- the simple-9 compressed occurrences serialized and bzipped into a byte string + +newtype OccCSerialized = OccCBs { unOccCBs :: ByteString } + deriving (Eq, Show) + +instance ComprOccurrences OccCSerialized where + fromOccurrences = OccCBs . Bs . BZ.compress . B.encode . deflateOcc + toOccurrences = inflateOcc . B.decode . BZ.decompress . unBs . unOccCBs + +instance NFData OccCSerialized where + rnf = rnf . unOccCBs + +instance B.Binary OccCSerialized where + put = B.put . unOccCBs + get = B.get >>= return . OccCBs + +instance Sizeof OccCSerialized where + sizeof = sizeof . unOccCBs + +-- ---------------------------------------------------------------------------- +-- +-- the pure occurrences serialized and bzipped into a byte string +-- this seems to be the best choice: compression is about 4% better then simple-9 & bzip +-- and lookup is about 8% better + +newtype OccOSerialized = OccOBs { unOccOBs :: ByteString } + deriving (Eq, Show) + +instance ComprOccurrences OccOSerialized where + fromOccurrences = OccOBs . Bs . BZ.compress . B.encode + toOccurrences = B.decode . BZ.decompress . unBs . unOccOBs + +instance NFData OccOSerialized where + rnf = rnf . unOccOBs + +instance B.Binary OccOSerialized where + put = B.put . unOccOBs + get = B.get >>= return . OccOBs + +instance Sizeof OccOSerialized where + sizeof = sizeof . unOccOBs + +-- ---------------------------------------------------------------------------- + +-- | The index consists of a table which maps documents to ids and a number of index parts. + +newtype Inverted occ = Inverted + { unInverted :: Parts occ -- ^ The parts of the index, each representing one context. + } + deriving (Show, Eq) + +-- | The index parts are identified by a name, which should denote the context of the words. + +type Parts occ = M.Map Context (Part occ) + +-- | The index part is the real inverted index. Words are mapped to their occurrences. +-- The part is implemented as a prefix tree + +type Part occ = PT.PrefixTree occ + +-- ---------------------------------------------------------------------------- + +instance (NFData occ) => NFData (Inverted occ) where + rnf = rnf . unInverted + +-- ---------------------------------------------------------------------------- + +instance (ComprOccurrences occ) => XmlPickler (Inverted occ) where + xpickle = xpElem "indexes" $ + xpWrap (Inverted, unInverted) xpParts + +xpParts :: (ComprOccurrences occ) => PU (Parts occ) +xpParts = xpWrap (M.fromList, M.toList) (xpList xpContext) + where + xpContext = xpElem "part" (xpPair (xpAttr "id" xpText) xpPart) + +xpPart :: (ComprOccurrences occ) => PU (Part occ) +xpPart = xpElem "index" (xpWrap (PT.fromList, PT.toList) (xpList xpWord)) + where + xpWord = xpElem "word" $ + xpPair (xpAttr "w" xpText) + (xpWrap (fromOccurrences, toOccurrences) xpOccurrences) + +-- ---------------------------------------------------------------------------- + +instance (B.Binary occ) => B.Binary (Inverted occ) where + put = B.put . unInverted + get = B.get >>= return . Inverted + +-- ---------------------------------------------------------------------------- + +instance (B.Binary occ, ComprOccurrences occ) => HolIndex (Inverted occ) where + sizeWords = M.fold ((+) . PT.size) 0 . unInverted + contexts = fmap fst . M.toList . unInverted + + allWords i c = fmap (second toOccurrences) . PT.toList . getPart c $ i + prefixCase i c q = fmap (second toOccurrences) . PT.prefixFindWithKeyBF q . getPart c $ i + prefixNoCase i c q = fmap (second toOccurrences) . PT.prefixFindNoCaseWithKeyBF q . getPart c $ i + lookupCase i c q = fmap ((,) q . toOccurrences) . maybeToList . PT.lookup q . getPart c $ i + lookupNoCase i c q = fmap (second toOccurrences) . PT.lookupNoCase q . getPart c $ i + + mergeIndexes = zipInverted $ M.unionWith $ PT.unionWith (zipOcc mergeOccurrences) + substractIndexes = zipInverted $ M.differenceWith $ substractPart + + insertOccurrences c w o i = mergeIndexes i (singletonInverted c w o) -- see "http://holumbus.fh-wedel.de/hayoo/hayoo.html#0:unionWith%20module%3AData.Map" + deleteOccurrences c w o i = substractIndexes i (singletonInverted c w o) + + toList = concatMap (uncurry convertPart) . toListInverted + where + convertPart c = map (\(w, o) -> (c, w, toOccurrences o)) . PT.toList + + splitByContexts = splitInverted + . map ( (\ i -> (sizeWords i, i)) + . Inverted + . uncurry M.singleton + ) + . toListInverted + + splitByDocuments i = splitInverted ( map (uncurry convert) $ + toListDocIdMap $ + unionsWithDocIdMap (M.unionWith (M.unionWith unionPos)) docResults + ) + where + docResults = map (\c -> resultByDocument c (allWords i c)) (contexts i) + convert d cs = foldl' makeIndex (0, emptyInverted) (M.toList cs) + where + makeIndex r (c, ws) = foldl' makeOcc r (M.toList ws) + where + makeOcc (rs, ri) (w, p) = (sizePos p + rs, insertOccurrences c w (singletonDocIdMap d p) ri) + + splitByWords i = splitInverted ( map (uncurry convert) . + M.toList . + M.unionsWith (M.unionWith mergeOccurrences) $ wordResults + ) + where + wordResults = map (\c -> resultByWord c (allWords i c)) (contexts i) + convert w cs = foldl' makeIndex (0, emptyInverted) (M.toList cs) + where + makeIndex (rs, ri) (c, o) = (rs + sizeOccurrences o, insertOccurrences c w o ri) + + updateDocIds f = mapInverted (M.mapWithKey updatePart) + where + updatePart c = PT.mapWithKey (updateOcc (f c)) + updateOcc f' w = mapOcc $ updateOccurrences (f' w) + +-- ---------------------------------------------------------------------------- + +-- | Return a part of the index for a given context. + +getPart :: Context -> Inverted i -> Part i +getPart c = fromMaybe PT.empty . M.lookup c . unInverted + +-- | Substract one index part from another. +substractPart :: (ComprOccurrences i) => Part i -> Part i -> Maybe (Part i) +substractPart p1 p2 + | PT.null res = Nothing + | otherwise = Just res + where + res = diffPart p1 p2 + +diffPart :: (ComprOccurrences i) => Part i -> Part i -> Part i +diffPart = PT.differenceWith subtractDiffLists + where + subtractDiffLists o1 o2 + | nullOcc res = Nothing + | otherwise = Just res + where + res = zipOcc substractOccurrences o1 o2 + +removeDocIdsPart :: (ComprOccurrences i) => Occurrences -> Part i -> Part i +removeDocIdsPart ids = PT.foldWithKey removeDocIds PT.empty + where + removeDocIds k occ acc + | nullOcc occ' = acc + | otherwise = PT.insert k occ' acc + where + occ' = deleteDocIds ids occ + +-- ---------------------------------------------------------------------------- + +mapInverted :: (Parts i -> Parts i) -> Inverted i -> Inverted i +mapInverted f = Inverted . f . unInverted + +zipInverted :: (Parts i -> Parts i -> Parts i) -> Inverted i -> Inverted i -> Inverted i +zipInverted op i1 i2 = Inverted $ op (unInverted i1) (unInverted i2) + +emptyInverted :: Inverted i +emptyInverted = Inverted M.empty + +toListInverted :: Inverted i -> [(Context, Part i)] +toListInverted = M.toList . unInverted + +-- | Create an index with just one word in one context. + +singletonInverted :: (ComprOccurrences i) => Context -> String -> Occurrences -> Inverted i +singletonInverted c w o = Inverted . M.singleton c . PT.singleton w . fromOccurrences $ o + +sizeofAttrsInverted :: (Sizeof i) => Inverted i -> Int64 +sizeofAttrsInverted = M.fold ((+) . sizeofPT) 0 . unInverted + where + sizeofPT = PT.fold ((+) . sizeof) 0 + +-- | Remove DocIds from index + +removeDocIdsInverted :: (ComprOccurrences i) => Occurrences -> Inverted i -> Inverted i +removeDocIdsInverted ids = mapInverted $ M.map (removeDocIdsPart ids) + +-- ---------------------------------------------------------------------------- +-- +-- copied from Holumbus.Index.Inverted.Memory + +splitInverted :: (B.Binary i, ComprOccurrences i) => [(Int, Inverted i)] -> Int -> [Inverted i] +splitInverted inp n = allocate mergeIndexes stack buckets + where + buckets = zipWith const (createBuckets n) stack + stack = reverse (sortBy (compare `on` fst) inp) + +-- | Allocates values from the first list to the buckets in the second list. +allocate :: (a -> a -> a) -> [(Int, a)] -> [(Int, a)] -> [a] +allocate _ _ [] = [] +allocate _ [] ys = map snd ys +allocate f (x:xs) (y:ys) = allocate f xs (sortBy (compare `on` fst) ((combine x y):ys)) + where + combine (s1, v1) (s2, v2) = (s1 + s2, f v1 v2) + +-- | Create empty buckets for allocating indexes. +createBuckets :: Int -> [(Int, Inverted i)] +createBuckets n = (replicate n (0, emptyInverted)) + +-- ---------------------------------------------------------------------------- +-- +-- the 5 variants for the inverted index as prefix tree, + +-- | The pure inverted index implemented as a prefix tree without any space optimizations. +-- This may be taken as a reference for space and time measurements for the other index structures + +type Inverted0 = Inverted Occ0 + +-- | The inverted index with simple-9 encoding of the occurence sets + +type InvertedCompressed = Inverted OccCompressed + +-- | The inverted index with serialized occurence maps with simple-9 encoded sets + +type InvertedSerialized = Inverted OccSerialized + +-- | The inverted index with serialized occurence maps with simple-9 encoded sets +-- and with the serialized bytestrings compressed with bzip2 + +type InvertedCSerialized = Inverted OccCSerialized + +-- | The pure inverted index with serialized occurence maps +-- and with the serialized bytestrings compressed with bzip2, no simple-9 encoding. +-- This is the most space efficient index of the 5 variants, even a few percent smaller +-- then InvertedCSerialized, and a few percent faster in lookup + +type InvertedOSerialized = Inverted OccOSerialized + +-- ---------------------------------------------------------------------------- + +emptyInverted0 :: Inverted0 +emptyInverted0 = emptyInverted + +emptyInvertedCompressed :: InvertedCompressed +emptyInvertedCompressed = emptyInverted + +emptyInvertedSerialized :: InvertedSerialized +emptyInvertedSerialized = emptyInverted + +emptyInvertedCSerialized :: InvertedCSerialized +emptyInvertedCSerialized = emptyInverted + +emptyInvertedOSerialized :: InvertedOSerialized +emptyInvertedOSerialized = emptyInverted + + +-- ---------------------------------------------------------------------------- + diff --git a/src/Holumbus/Index/Inverted/PrefixMem.hs b/src/Holumbus/Index/Inverted/PrefixMem.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Index/Inverted/PrefixMem.hs @@ -0,0 +1,228 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Index.Inverted.PrefixMem + Copyright : Copyright (C) 2007 - 2009 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt + License : MIT + + Maintainer : Uwe Schmidt (uwe@fh-wedel.de) + Stability : experimental + Portability: portable + + A variant of the Inverted.Memory index with an optimized prefix tree + instead of a trie as central data structure. This version should be + more space efficient as the trie and more runtime efficient when combining + whole indexes. + + For switching from Memory to this module, only the import has to be modified + +-} + +-- ---------------------------------------------------------------------------- + +{-# OPTIONS -XTypeSynonymInstances -XFlexibleInstances -XMultiParamTypeClasses #-} + +module Holumbus.Index.Inverted.PrefixMem + ( + -- * Inverted index types + Inverted (..) + , Parts + , Part + + -- * Construction + , singleton + , emptyInverted + ) +where + +import Control.DeepSeq + +import Data.Binary hiding (Word) +import Data.Function +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe + +import qualified Holumbus.Data.PrefixTree as PT + +import Holumbus.Index.Common +import Holumbus.Index.Compression + +import Text.XML.HXT.Core + +-- ---------------------------------------------------------------------------- + +-- | The index consists of a table which maps documents to ids and a number of index parts. + +newtype Inverted = Inverted { indexParts :: Parts } + deriving (Show, Eq) + +-- | The index parts are identified by a name, which should denote the context of the words. + +type Parts = Map Context Part + +-- | The index part is the real inverted index. Words are mapped to their occurrences. + +type Part = PT.PrefixTree CompressedOccurrences + +-- ---------------------------------------------------------------------------- + +instance HolIndex Inverted where + sizeWords = M.fold ((+) . PT.size) 0 . indexParts + contexts = map fst . M.toList . indexParts + + allWords i c = map (\(w, o) -> (w, inflateOcc o)) $ PT.toList $ getPart c i + prefixCase i c q = map (\(w, o) -> (w, inflateOcc o)) $ PT.prefixFindWithKey q $ getPart c i + prefixNoCase i c q = map (\(w, o) -> (w, inflateOcc o)) $ PT.prefixFindNoCaseWithKey q $ getPart c i + lookupCase i c q = map (\ o -> (q, inflateOcc o)) $ maybeToList (PT.lookup q $ getPart c i) + lookupNoCase i c q = map (\(w, o) -> (w, inflateOcc o)) $ PT.lookupNoCase q $ getPart c i + + mergeIndexes i1 i2 = Inverted (mergeParts (indexParts i1) (indexParts i2)) + substractIndexes i1 i2 = Inverted (substractParts (indexParts i1) (indexParts i2)) + + insertOccurrences c w o i = mergeIndexes (singleton c w o) i + deleteOccurrences c w o i = substractIndexes i (singleton c w o) + + splitByContexts (Inverted ps) = splitInternal (map (uncurry annotate) . M.toList $ ps) + where + annotate c p = let + i = Inverted (M.singleton c p) + in + (sizeWords i, i) + + splitByDocuments i = splitInternal ( map convert $ + toListDocIdMap $ + unionsWithDocIdMap unionDocs' docResults + ) + where + unionDocs' = M.unionWith (M.unionWith unionPos) + docResults = map (\c -> resultByDocument c (allWords i c)) (contexts i) + convert (d, cs) = foldl' makeIndex (0, emptyInverted) (M.toList cs) + where + makeIndex r (c, ws) = foldl' makeOcc r (M.toList ws) + where + makeOcc (rs, ri) (w, p) = (sizePos p + rs , insertOccurrences c w (singletonDocIdMap d p) ri) + + splitByWords i = splitInternal indexes + where + indexes = map convert $ + M.toList $ + M.unionsWith (M.unionWith mergeOccurrences) wordResults + where + wordResults = map (\c -> resultByWord c (allWords i c)) (contexts i) + convert (w, cs) = foldl' makeIndex (0, emptyInverted) (M.toList cs) + where + makeIndex (rs, ri) (c, o) = (rs + sizeOccurrences o, insertOccurrences c w o ri) + + updateDocIds f (Inverted parts) + = Inverted (M.mapWithKey updatePart parts) + where + updatePart c p = PT.mapWithKey + (\w o -> foldWithKeyDocIdMap (updateDocument c w) emptyDocIdMap o) p + updateDocument c w d p r = insertWithDocIdMap mergePositions (f c w d) p r + where + mergePositions p1 p2 = deflatePos $ unionPos (inflatePos p1) (inflatePos p2) + + updateDocIds' f + = Inverted . M.map updatePart . indexParts + where + updatePart = PT.map updateOcc + updateOcc = foldWithKeyDocIdMap updateId emptyDocIdMap + updateId = insertDocIdMap . f + + toList i = concat $ map convertPart $ M.toList (indexParts i) + where convertPart (c,p) = map (\(w, o) -> (c, w, inflateOcc o)) $ + PT.toList $ + p + +-- ---------------------------------------------------------------------------- + +instance NFData Inverted where + rnf = rnf . indexParts + +-- ---------------------------------------------------------------------------- + +instance XmlPickler Inverted where + xpickle = xpElem "indexes" $ + xpWrap (\p -> Inverted p, \(Inverted p) -> p) xpParts + +-- | The XML pickler for the index parts. +xpParts :: PU Parts +xpParts = xpWrap (M.fromList, M.toList) (xpList xpContext) + where + xpContext = xpElem "part" (xpPair (xpAttr "id" xpText) xpPart) + +-- | The XML pickler for a single part. +xpPart :: PU Part +xpPart = xpElem "index" (xpWrap (PT.fromList, PT.toList) (xpList xpWord)) + where + xpWord = xpElem "word" $ + xpPair (xpAttr "w" xpText) + (xpWrap (deflateOcc, inflateOcc) xpOccurrences) + +-- ---------------------------------------------------------------------------- + +instance Binary Inverted where + put = put . indexParts + get = get >>= return . Inverted + +-- ---------------------------------------------------------------------------- + +-- | Create an empty index. +emptyInverted :: Inverted +emptyInverted = Inverted M.empty + +-- | Create an index with just one word in one context. +singleton :: Context -> String -> Occurrences -> Inverted +singleton c w o = Inverted (M.singleton c (PT.singleton w (deflateOcc o))) + +-- | Merge two sets of index parts. +mergeParts :: Parts -> Parts -> Parts +mergeParts = M.unionWith mergePart + +-- | Merge two index parts. +mergePart :: Part -> Part -> Part +mergePart = PT.unionWith mergeDiffLists + where + mergeDiffLists o1 o2 = deflateOcc $ + mergeOccurrences (inflateOcc o1) (inflateOcc o2) + +-- | Substract a set of index parts from another. +substractParts :: Parts -> Parts -> Parts +substractParts = M.differenceWith substractPart + +-- | Substract one index part from another. +substractPart :: Part -> Part -> Maybe Part +substractPart p1 p2 = if PT.null diffPart then Nothing else Just diffPart + where + diffPart = PT.differenceWith substractDiffLists p1 p2 + where + substractDiffLists o1 o2 = if diffOcc == emptyOccurrences then Nothing else Just (deflateOcc diffOcc) + where + diffOcc = substractOccurrences (inflateOcc o1) (inflateOcc o2) + +-- | Internal split function used by the split functions from the HolIndex interface (above). +splitInternal :: [(Int, Inverted)] -> Int -> [Inverted] +splitInternal inp n = allocate mergeIndexes stack buckets + where + buckets = zipWith const (createBuckets n) stack + stack = reverse (sortBy (compare `on` fst) inp) + +-- | Allocates values from the first list to the buckets in the second list. +allocate :: (a -> a -> a) -> [(Int, a)] -> [(Int, a)] -> [a] +allocate _ _ [] = [] +allocate _ [] ys = map snd ys +allocate f (x:xs) (y:ys) = allocate f xs (sortBy (compare `on` fst) ((combine x y):ys)) + where + combine (s1, v1) (s2, v2) = (s1 + s2, f v1 v2) + +-- | Create empty buckets for allocating indexes. +createBuckets :: Int -> [(Int, Inverted)] +createBuckets n = (replicate n (0, emptyInverted)) + +-- | Return a part of the index for a given context. +getPart :: Context -> Inverted -> Part +getPart c i = fromMaybe PT.empty (M.lookup c $ indexParts i) + +-- ---------------------------------------------------------------------------- diff --git a/src/Holumbus/Query/Fuzzy.hs b/src/Holumbus/Query/Fuzzy.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Query/Fuzzy.hs @@ -0,0 +1,218 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Query.Fuzzy + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.2 + + The unique Holumbus mechanism for generating fuzzy sets. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Query.Fuzzy + ( + -- * Fuzzy types + FuzzySet + , Replacements + , Replacement + , FuzzyScore + , FuzzyConfig (..) + + -- * Predefined replacements + , englishReplacements + , germanReplacements + + -- * Generation + , fuzz + + -- * Conversion + , toList + ) +where + +import Data.Binary +import Data.List +import Data.Function + +import Control.Monad + +import Data.Map (Map) +import qualified Data.Map as M + +-- | A set of string which have been "fuzzed" with an associated score. + +type FuzzySet = Map String FuzzyScore + +-- | Some replacements which can be applied to a string to generate a 'FuzzySet'. The scores of +-- the replacements will be normalized to a maximum of 1.0. + +type Replacements = [ Replacement ] + +-- | A single replacements, where the first will be replaced by the second and vice versa in +-- the target string. The score indicates the amount of fuzzines that one single application +-- of this replacement in just one direction will cause on the target string. + +type Replacement = ((String, String), FuzzyScore) + +-- | The score indicating an amount of fuzziness. + +type FuzzyScore = Float + +-- | The configuration of a fuzzy query. + +data FuzzyConfig + = FuzzyConfig + { applyReplacements :: Bool -- ^ Indicates whether the replacements should be applied. + , applySwappings :: Bool -- ^ Indicates whether the swapping of adjacent characters should be applied. + , maxFuzziness :: FuzzyScore -- ^ The maximum allowed fuzziness. + , customReplacements :: Replacements -- ^ The replacements that should be applied. + } + deriving (Show) + +instance Binary FuzzyConfig where + put (FuzzyConfig r s m f) + = put r >> put s >> put m >> put f + get + = liftM4 FuzzyConfig get get get get + +-- | Some default replacements for the english language. +englishReplacements :: Replacements +englishReplacements = + [ (("l", "ll"), 0.2) + , (("t", "tt"), 0.2) + , (("r", "rr"), 0.2) + , (("e", "ee"), 0.2) + , (("o", "oo"), 0.2) + , (("s", "ss"), 0.2) + + , (("g", "ck"), 0.4) + , (("k", "ck"), 0.4) + , (("ea", "ee"), 0.4) + , (("ou", "oo"), 0.4) + , (("ou", "au"), 0.4) + , (("ou", "ow"), 0.4) + + , (("s", "c"), 0.6) + , (("uy", "ye"), 0.6) + , (("y", "ey"), 0.6) + , (("kn", "n"), 0.6) + ] + +-- | Some default replacements for the german language. + +germanReplacements :: Replacements +germanReplacements = + [ (("l", "ll"), 0.2) + , (("t", "tt"), 0.2) + , (("n", "nn"), 0.2) + , (("r", "rr"), 0.2) + , (("i", "ie"), 0.2) + , (("ei", "ie"), 0.2) + , (("k", "ck"), 0.2) + + , (("d", "t"), 0.4) + , (("b", "p"), 0.4) + , (("g", "k"), 0.4) + , (("g", "ch"), 0.4) + , (("c", "k"), 0.4) + , (("s", "z"), 0.4) + , (("u", "ou"), 0.4) + + , (("ü", "ue"), 0.1) + , (("ä", "ae"), 0.1) + , (("ö", "oe"), 0.1) + , (("ß", "ss"), 0.1) + ] + +-- | Continue fuzzing a string with the an explicitly specified list of replacements until +-- a given score threshold is reached. + +fuzz :: FuzzyConfig -> String -> FuzzySet +fuzz cfg s = M.delete s (fuzz' (fuzzLimit cfg 0.0 s)) + where + fuzz' :: FuzzySet -> FuzzySet + fuzz' fs = if M.null more then fs else M.unionWith min fs (fuzz' more) + where + -- The current score is doubled on every recursive call, because fuzziness increases exponentially. + more = M.foldrWithKey (\sm sc res -> M.unionWith min res (fuzzLimit cfg (sc + sc) sm)) M.empty fs + +-- | Fuzz a string and limit the allowed score to a given threshold. + +fuzzLimit :: FuzzyConfig -> FuzzyScore -> String -> FuzzySet +fuzzLimit cfg sc s = if sc <= th then M.filter (\ns -> ns <= th) (fuzzInternal cfg sc s) else M.empty + where + th = maxFuzziness cfg + +-- | Fuzz a string with an list of explicitly specified replacements and combine the scores +-- with an initial score. + +fuzzInternal :: FuzzyConfig -> FuzzyScore -> String -> FuzzySet +fuzzInternal cfg sc s = M.unionWith min replaced swapped + where + replaced = let rs = customReplacements cfg in if (applyReplacements cfg) + then foldr (\r res -> M.unionWith min res (applyFuzz (replace rs r) sc s)) M.empty rs + else M.empty + swapped = if (applySwappings cfg) + then applyFuzz swap sc s + else M.empty + +-- | Applies a fuzzy function to a string. An initial score is combined with the new score +-- for the replacement. + +applyFuzz :: (String -> String -> [(String, FuzzyScore)]) -> FuzzyScore -> String -> FuzzySet +applyFuzz f sc s = apply (init $ inits s) (init $ tails s) + where + apply :: [String] -> [String] -> FuzzySet + apply [] _ = M.empty + apply _ [] = M.empty + apply (pr:prs) (su:sus) = M.unionsWith min $ (apply prs sus):(map create $ (f pr su)) + where + create (fuzzed, score) = M.singleton fuzzed (sc + score * (calcWeight (length pr) (length s))) + +-- | Apply a replacement in both directions to the suffix of a string and return the complete +-- string with a score, calculated from the replacement itself and the list of replacements. + +replace :: Replacements -> Replacement -> String -> String -> [(String, FuzzyScore)] +replace rs ((r1, r2), s) prefix suffix = (replace' r1 r2) ++ (replace' r2 r1) + where + replace' tok sub = if replaced == suffix then [] else [(prefix ++ replaced, score)] + where + replaced = replaceFirst tok sub suffix + score = s / (snd $ maximumBy (compare `on` snd) rs) + +-- | Swap the first two characters of the suffix and return the complete string with a score or +-- Nothing if there are not enough characters to swap. + +swap :: String -> String -> [(String, FuzzyScore)] +swap prefix (s1:s2:suffix) = [(prefix ++ (s2:s1:suffix), 1.0)] +swap _ _ = [] + +-- | Calculate the weighting factor depending on the position in the string and it's total length. + +calcWeight :: Int -> Int -> FuzzyScore +calcWeight pos len = (l - p) / l + where + p = fromIntegral pos + l = fromIntegral len + +-- | Searches a prefix and replaces it with a substitute in a list. + +replaceFirst :: Eq a => [a] -> [a] -> [a] -> [a] +replaceFirst [] ys zs = ys ++ zs +replaceFirst _ _ [] = [] +replaceFirst t@(x:xs) ys s@(z:zs) = if x == z && t `isPrefixOf` s then + if null ys then replaceFirst xs [] zs + else (head ys) : replaceFirst xs (tail ys) zs + else s + +-- | Transform a fuzzy set into a list (ordered by score). + +toList :: FuzzySet -> [ (String, FuzzyScore) ] +toList = sortBy (compare `on` snd) . M.toList diff --git a/src/Holumbus/Query/Intermediate.hs b/src/Holumbus/Query/Intermediate.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Query/Intermediate.hs @@ -0,0 +1,175 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Query.Intermediate + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.3 + + The data type for intermediate results occuring during query processing. + +-} + +-- ---------------------------------------------------------------------------- + +{-# OPTIONS #-} + +module Holumbus.Query.Intermediate +( + -- * The intermediate result type. + Intermediate + + -- * Construction + , emptyIntermediate + + -- * Query + , null + , sizeIntermediate + + -- * Combine + , union + , difference + , intersection + , unions + + -- * Conversion + , fromList + , toResult +) +where + +import Prelude hiding (null) + +import Data.Maybe + +import qualified Data.List as L + +import Data.Map (Map) +import qualified Data.Map as M + +import Holumbus.Query.Result hiding (null) + +import Holumbus.Index.Common hiding (toList, fromList) + +-- ---------------------------------------------------------------------------- + +-- | The intermediate result used during query processing. + +type Intermediate = DocIdMap IntermediateContexts +type IntermediateContexts = Map Context IntermediateWords +type IntermediateWords = Map Word (WordInfo, Positions) + +-- ---------------------------------------------------------------------------- + +-- | Create an empty intermediate result. + +emptyIntermediate :: Intermediate +emptyIntermediate = emptyDocIdMap + +-- | Check if the intermediate result is empty. + +null :: Intermediate -> Bool +null = nullDocIdMap + +-- | Returns the number of documents in the intermediate result. + +sizeIntermediate :: Intermediate -> Int +sizeIntermediate = sizeDocIdMap + +-- | Merges a bunch of intermediate results into one intermediate result by unioning them. + +unions :: [Intermediate] -> Intermediate +unions = L.foldl' union emptyIntermediate + +-- | Intersect two sets of intermediate results. + +intersection :: Intermediate -> Intermediate -> Intermediate +intersection = intersectionWithDocIdMap combineContexts + +-- | Union two sets of intermediate results. + +union :: Intermediate -> Intermediate -> Intermediate +union = unionWithDocIdMap combineContexts + +-- | Substract two sets of intermediate results. + +difference :: Intermediate -> Intermediate -> Intermediate +difference = differenceDocIdMap + +-- | Create an intermediate result from a list of words and their occurrences. + +fromList :: Word -> Context -> RawResult -> Intermediate +-- Beware! This is extremly optimized and will not work for merging arbitrary intermediate results! +-- Based on resultByDocument from Holumbus.Index.Common + +fromList t c os = mapDocIdMap transform $ + unionsWithDocIdMap (flip $ (:) . head) + (map insertWords os) + where + insertWords (w, o) = mapDocIdMap (\p -> [(w, (WordInfo [t] 0.0 , p))]) o + transform w = M.singleton c (M.fromList w) + +-- | Convert to a @Result@ by generating the 'WordHits' structure. + +toResult :: HolDocuments d c => d c -> Intermediate -> Result c +toResult d im = Result (createDocHits d im) (createWordHits im) + +-- | Create the doc hits structure from an intermediate result. + +createDocHits :: HolDocuments d c => d c -> Intermediate -> DocHits c +createDocHits d im = mapWithKeyDocIdMap transformDocs im + where + transformDocs did ic = let doc = fromMaybe (Document "" "" Nothing) (lookupById d did) in + (DocInfo doc 0.0, M.map (M.map (\(_, p) -> p)) ic) + +-- | Create the word hits structure from an intermediate result. + +createWordHits :: Intermediate -> WordHits +createWordHits im = foldWithKeyDocIdMap transformDoc M.empty im + where + transformDoc d ic wh = M.foldrWithKey transformContext wh ic + where + transformContext c iw wh' = M.foldrWithKey insertWord wh' iw + where + insertWord w (wi, pos) wh'' + = if terms wi == [""] + then wh'' + else M.insertWith combineWordHits + w + (wi, M.singleton c (singletonDocIdMap d pos)) + wh'' + +-- | Combine two tuples with score and context hits. + +combineWordHits :: (WordInfo, WordContextHits) -> + (WordInfo, WordContextHits) -> (WordInfo, WordContextHits) +combineWordHits (i1, c1) (i2, c2) + = ( combineWordInfo i1 i2 + , M.unionWith (unionWithDocIdMap unionPos) c1 c2 + ) + +-- | Combine two tuples with score and context hits. + +combineContexts :: IntermediateContexts -> IntermediateContexts -> IntermediateContexts +combineContexts = M.unionWith (M.unionWith merge) + where + merge (i1, p1) (i2, p2) = ( combineWordInfo i1 i2 + , unionPos p1 p2 + ) + +-- | Combine two word informations. + +combineWordInfo :: WordInfo -> WordInfo -> WordInfo +combineWordInfo (WordInfo t1 s1) (WordInfo t2 s2) + = WordInfo (t1 ++ t2) (combineScore s1 s2) + +-- | Combine two scores (just average between them). + +combineScore :: Score -> Score -> Score +combineScore s1 s2 = (s1 + s2) / 2.0 + +-- ---------------------------------------------------------------------------- diff --git a/src/Holumbus/Query/Language/Grammar.hs b/src/Holumbus/Query/Language/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Query/Language/Grammar.hs @@ -0,0 +1,144 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Query.Language.Grammar + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.2 + + The Holumbus query language definition. + + The specific syntax of any query language can be designed independently + by creating appropriate parsers. Also see "Holumbus.Query.Language.Parser". + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Query.Language.Grammar + ( + -- * Query data types + Query (Word, Phrase, CaseWord, CasePhrase, FuzzyWord, Specifier, Negation, BinQuery) + , BinOp (And, Or, But) + + -- * Optimizing + , optimize + , checkWith + , extractTerms + ) +where + +import Data.Char +import Data.List +import Data.Binary +import Control.Monad + +import Holumbus.Index.Common (Context) + +-- | The query language. +data Query = Word String -- ^ Single case-insensitive word. + | Phrase String -- ^ Single case-insensitive phrase. + | CaseWord String -- ^ Single case-sensitive word. + | CasePhrase String -- ^ Single case-sensitive phrase. + | FuzzyWord String -- ^ Single fuzzy word. + | Specifier [Context] Query -- ^ Restrict query to a list of contexts. + | Negation Query -- ^ Negate the query. + | BinQuery BinOp Query Query -- ^ Combine two queries through a binary operation. + deriving (Eq, Show) + +-- | A binary operation. +data BinOp = And -- ^ Intersect two queries. + | Or -- ^ Union two queries. + | But -- ^ Filter a query by another, @q1 BUT q2@ is equivalent to @q1 AND NOT q2@. + deriving (Eq, Show) + +instance Binary Query where + put (Word s) = put (0 :: Word8) >> put s + put (Phrase s) = put (1 :: Word8) >> put s + put (CaseWord s) = put (2 :: Word8) >> put s + put (CasePhrase s) = put (3 :: Word8) >> put s + put (FuzzyWord s) = put (4 :: Word8) >> put s + put (Specifier c q) = put (5 :: Word8) >> put c >> put q + put (Negation q) = put (6 :: Word8) >> put q + put (BinQuery o q1 q2) = put (7 :: Word8) >> put o >> put q1 >> put q2 + + get = do tag <- getWord8 + case tag of + 0 -> liftM Word get + 1 -> liftM Phrase get + 2 -> liftM CaseWord get + 3 -> liftM CasePhrase get + 4 -> liftM FuzzyWord get + 5 -> liftM2 Specifier get get + 6 -> liftM Negation get + 7 -> liftM3 BinQuery get get get + _ -> fail "Error while decoding Query" + +instance Binary BinOp where + put And = put (0 :: Word8) + put Or = put (1 :: Word8) + put But = put (2 :: Word8) + + get = do tag <- getWord8 + case tag of + 0 -> return And + 1 -> return Or + 2 -> return But + _ -> fail "Error while decoding BinOp" + +-- | Transforms all @(BinQuery And q1 q2)@ where one of @q1@ or @q2@ is a @Negation@ into +-- @BinQuery Filter q1 q2@ or @BinQuery Filter q2 q1@ respectively. +optimize :: Query -> Query + +optimize q@(BinQuery And (Word q1) (Word q2)) = + if (map toLower q1) `isPrefixOf` (map toLower q2) then Word q2 else + if (map toLower q2) `isPrefixOf` (map toLower q1) then Word q1 else q + +optimize q@(BinQuery And (CaseWord q1) (CaseWord q2)) = + if q1 `isPrefixOf` q2 then CaseWord q2 else + if q2 `isPrefixOf` q1 then CaseWord q1 else q + +optimize q@(BinQuery Or (Word q1) (Word q2)) = + if (map toLower q1) `isPrefixOf` (map toLower q2) then Word q1 else + if (map toLower q2) `isPrefixOf` (map toLower q1) then Word q2 else q + +optimize q@(BinQuery Or (CaseWord q1) (CaseWord q2)) = + if q1 `isPrefixOf` q2 then CaseWord q1 else + if q2 `isPrefixOf` q1 then CaseWord q2 else q + +optimize (BinQuery And q1 (Negation q2)) = BinQuery But (optimize q1) (optimize q2) +optimize (BinQuery And (Negation q1) q2) = BinQuery But (optimize q2) (optimize q1) + +optimize (BinQuery And q1 q2) = BinQuery And (optimize q1) (optimize q2) +optimize (BinQuery Or q1 q2) = BinQuery Or (optimize q1) (optimize q2) +optimize (BinQuery But q1 q2) = BinQuery But (optimize q1) (optimize q2) +optimize (Negation q) = Negation (optimize q) +optimize (Specifier cs q) = Specifier cs (optimize q) + +optimize q = q + +-- | Check if the query arguments comply with some custom predicate. +checkWith :: (String -> Bool) -> Query -> Bool +checkWith f (Word s) = f s +checkWith f (Phrase s) = f s +checkWith f (CaseWord s) = f s +checkWith f (CasePhrase s) = f s +checkWith f (FuzzyWord s) = f s +checkWith f (Negation q) = checkWith f q +checkWith f (BinQuery _ q1 q2) = (checkWith f q1) && (checkWith f q2) +checkWith f (Specifier _ q) = checkWith f q + +-- | Returns a list of all terms in the query. +extractTerms :: Query -> [String] +extractTerms (Word s) = [s] +extractTerms (CaseWord s) = [s] +extractTerms (FuzzyWord s) = [s] +extractTerms (Specifier _ q) = extractTerms q +extractTerms (Negation q) = extractTerms q +extractTerms (BinQuery _ q1 q2) = (extractTerms q1) ++ (extractTerms q2) +extractTerms _ = [] + diff --git a/src/Holumbus/Query/Language/Parser.hs b/src/Holumbus/Query/Language/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Query/Language/Parser.hs @@ -0,0 +1,181 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Query.Language.Parser + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.2 + + The Holumbus query parser, based on the famous Parsec library. + + The parser implements a default syntax for the query grammar which exposes + all possible query types and operators to the user. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Query.Language.Parser + ( + -- * Parsing + parseQuery + ) +where + +import Holumbus.Query.Language.Grammar +import Text.ParserCombinators.Parsec + +-- ---------------------------------------------------------------------------- + +-- | Parse a query using the default syntax provided by the Holumbus framework. +parseQuery :: String -> Either String Query +parseQuery = result . (parse query "") + where + result (Left err) = Left (show err) + result (Right q) = Right q + +-- | A query may always be surrounded by whitespace +query :: Parser Query +query = spaces >> andQuery + +-- | Parse an and query. +andQuery :: Parser Query +andQuery = do t <- orQuery + try (andOp' t) <|> return t + where + andOp' r = do andOp + q <- andQuery + return (BinQuery And r q) + +-- | Parse an or query. +orQuery :: Parser Query +orQuery = do t <- notQuery + do orOp + q <- orQuery + return (BinQuery Or t q) + <|> return t + +-- | Parse a negation. +notQuery :: Parser Query +notQuery = do notQuery' <|> contextQuery + where + notQuery' = do notOp + q <- contextQuery + return (Negation q) + +-- | Parse a context query. +contextQuery :: Parser Query +contextQuery = try contextQuery' <|> parQuery + where + contextQuery' = do c <- contexts + spaces + char ':' + spaces + t <- parQuery + return (Specifier c t) + +-- | Parse a query surrounded by parentheses. +parQuery :: Parser Query +parQuery = parQuery' <|> caseQuery + where + parQuery' = do char '(' + spaces + q <- andQuery + spaces + char ')' + return q + +-- | Parse a case-sensitive query. +caseQuery :: Parser Query +caseQuery = caseQuery' <|> fuzzyQuery + where + caseQuery' = do char '!' + spaces + (phraseQuery CasePhrase <|> wordQuery CaseWord) + +-- | Parse a fuzzy query. +fuzzyQuery :: Parser Query +fuzzyQuery = fuzzyQuery' <|> phraseQuery Phrase <|> wordQuery Word + where + fuzzyQuery' = do char '~' + spaces + wordQuery FuzzyWord + +-- | Parse a word query. +wordQuery :: (String -> Query) -> Parser Query +wordQuery c = do w <- word + return (c w) + +-- | Parse a phrase query. +phraseQuery :: (String -> Query) -> Parser Query +phraseQuery c = do p <- phrase + return (c p) + +-- | Parse an and operator. +andOp :: Parser () +andOp = (try andOp') <|> spaces1 + where + andOp' = do spaces + string "AND" + spaces1 + return () + +-- | Parse an or operator. +orOp :: Parser () +orOp = try orOp' + where + orOp' = do spaces + string "OR" + spaces1 + return () + +-- | Parse a not operator. +notOp :: Parser () +notOp = try notOp' + where + notOp' = do spaces + string "NOT" + spaces1 + return () + +-- | Parse a word. +word :: Parser String +word = many1 wordChar + +-- | Parse a phrase. +phrase :: Parser String +phrase = do char '"' + p <- many1 phraseChar + char '"' + return p + +-- | Parse a character of a word. +wordChar :: Parser Char +wordChar = noneOf "\")( " + +-- | Parse a character of a phrases. +phraseChar :: Parser Char +phraseChar = noneOf "\"" + +-- | Parse a list of contexts. +contexts :: Parser [String] +contexts = context `sepBy1` (char ',') + +-- | Parse a context. +context :: Parser String +context = do spaces + c <- (many1 alphaNum) + spaces + return c + +-- | Parse at least on white space character. +spaces1 :: Parser () +spaces1 = skipMany1 space + +-- ------------------------------------------------------------ diff --git a/src/Holumbus/Query/Processor.hs b/src/Holumbus/Query/Processor.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Query/Processor.hs @@ -0,0 +1,352 @@ +{-# OPTIONS #-} + +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Query.Processor + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + + The Holumbus query processor. Supports exact word or phrase queries as well + as fuzzy word and case-insensitive word and phrase queries. Boolean + operators like AND, OR and NOT are supported. Context specifiers and + priorities are supported, too. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Query.Processor + ( + -- * Processor types + ProcessConfig (..) + + -- * Processing + , processQuery + , processPartial + , processQueryM + , processPartialM + ) +where + +-- import Data.Maybe + +import Control.Monad +import Control.Parallel.Strategies + +import Data.Binary ( Binary (..) ) +import Data.Function +import qualified Data.List as L + +import Holumbus.Index.Common hiding (contexts) +import qualified Holumbus.Index.Common as IDX + +import Holumbus.Query.Language.Grammar + +import Holumbus.Query.Fuzzy ( FuzzyScore + , FuzzyConfig + ) +import qualified Holumbus.Query.Fuzzy as F + +import Holumbus.Query.Result ( Result ) + +import Holumbus.Query.Intermediate ( Intermediate ) +import qualified Holumbus.Query.Intermediate as I + +-- ---------------------------------------------------------------------------- + +-- | The configuration for the query processor. + +data ProcessConfig + = ProcessConfig + { fuzzyConfig :: ! FuzzyConfig -- ^ The configuration for fuzzy queries. + , optimizeQuery :: ! Bool -- ^ Optimize the query before processing. + , wordLimit :: ! Int -- ^ The maximum number of words used from a prefix. Zero switches off limiting. + , docLimit :: ! Int -- ^ The maximum number of documents taken into account. Zero switches off limiting. + } + +instance Binary ProcessConfig where + put (ProcessConfig fc o l d) + = put fc >> put o >> put l >> put d + get + = liftM4 ProcessConfig get get get get + +-- | The internal state of the query processor. +data ProcessState i + = ProcessState + { config :: ! ProcessConfig -- ^ The configuration for the query processor. + , contexts :: ! [Context] -- ^ The current list of contexts. + , index :: ! i -- ^ The index to search. + , total :: ! Int -- ^ The number of documents in the index. + } + +-- ---------------------------------------------------------------------------- + +-- | Get the fuzzy config out of the process state. + +getFuzzyConfig :: HolIndex i => ProcessState i -> FuzzyConfig +getFuzzyConfig = fuzzyConfig . config + +-- | Monadic version of 'getFuzzyConfig'. + +getFuzzyConfigM :: HolIndexM m i => ProcessState i -> m FuzzyConfig +getFuzzyConfigM s = return $ fuzzyConfig $ config s + +-- | Set the current context in the state. + +setContexts :: HolIndex i => [Context] -> ProcessState i -> ProcessState i +setContexts cs (ProcessState cfg _ i t) = ProcessState cfg cs i t + +-- | Monadic version of 'setContexts'. + +setContextsM :: HolIndexM m i => [Context] -> ProcessState i -> m (ProcessState i) +setContextsM cs (ProcessState cfg _ i t) = return $ ProcessState cfg cs i t + +-- | Initialize the state of the processor. + +initState :: HolIndex i => ProcessConfig -> i -> Int -> ProcessState i +initState cfg i t = ProcessState cfg (IDX.contexts i) i t + +-- | Monadic version of 'initState'. + +initStateM :: HolIndexM m i => ProcessConfig -> i -> Int -> m (ProcessState i) +initStateM cfg i t = IDX.contextsM i >>= \cs -> return $ ProcessState cfg cs i t + +-- | Try to evaluate the query for all contexts in parallel. + +forAllContexts :: (Context -> Intermediate) -> [Context] -> Intermediate +forAllContexts f cs = L.foldl' I.union I.emptyIntermediate $ parMap rdeepseq f cs + +-- | Monadic version of 'forAllContexts'. + +forAllContextsM :: Monad m => (Context -> m Intermediate) -> [Context] -> m Intermediate +forAllContextsM f cs = mapM f cs >>= \is -> return $ L.foldl' I.union I.emptyIntermediate is + +-- | Just everything. + +allDocuments :: HolIndex i => ProcessState i -> Intermediate +allDocuments s = forAllContexts (\c -> I.fromList "" c $ IDX.allWords (index s) c) (contexts s) + +allDocumentsM :: HolIndexM m i => ProcessState i -> m Intermediate +allDocumentsM s = forAllContextsM (\c -> IDX.allWordsM (index s) c >>= \r -> return $ I.fromList "" c r) (contexts s) + +-- | Process a query only partially in terms of a distributed index. Only the intermediate +-- result will be returned. + +processPartial :: (HolIndex i) => ProcessConfig -> i -> Int -> Query -> Intermediate +processPartial cfg i t q = process (initState cfg i t) oq + where + oq = if optimizeQuery cfg then optimize q else q + +-- | Monadic version of 'processPartial'. + +processPartialM :: (HolIndexM m i) => ProcessConfig -> i -> Int -> Query -> m Intermediate +processPartialM cfg i t q = initStateM cfg i t >>= (flip processM) oq + where + oq = if optimizeQuery cfg then optimize q else q + +-- | Process a query on a specific index with regard to the configuration. + +processQuery :: (HolIndex i, HolDocuments d c) => ProcessConfig -> i -> d c -> Query -> Result c +processQuery cfg i d q = I.toResult d (processPartial cfg i (sizeDocs d) q) + +-- | Monadic version of 'processQuery'. + +processQueryM :: (HolIndexM m i, HolDocuments d c) => ProcessConfig -> i -> d c -> Query -> m (Result c) +processQueryM cfg i d q = processPartialM cfg i (sizeDocs d) q >>= \ir -> return $ I.toResult d ir + +-- | Continue processing a query by deciding what to do depending on the current query element. + +process :: HolIndex i => ProcessState i -> Query -> Intermediate +process s (Word w) = processWord s w +process s (Phrase w) = processPhrase s w +process s (CaseWord w) = processCaseWord s w +process s (CasePhrase w) = processCasePhrase s w +process s (FuzzyWord w) = processFuzzyWord s w +process s (Negation q) = processNegation s (process s q) +process s (Specifier c q) = process (setContexts c s) q +process s (BinQuery o q1 q2) = processBin o (process s q1) (process s q2) + +-- | Monadic version of 'process'. + +processM :: HolIndexM m i => ProcessState i -> Query -> m Intermediate +processM s (Word w) = processWordM s w +processM _ (Phrase _) = return I.emptyIntermediate -- processPhraseM s w +processM s (CaseWord w) = processCaseWordM s w +processM _ (CasePhrase _) = return I.emptyIntermediate -- processCasePhraseM s w +processM s (FuzzyWord w) = processFuzzyWordM s w +processM s (Negation q) = processM s q >>= processNegationM s +processM s (Specifier c q) = setContextsM c s >>= \ns -> processM ns q +processM s (BinQuery o q1 q2) = do + ir1 <- processM s q1 + ir2 <- processM s q2 + return $ processBin o ir1 ir2 + +-- | Process a single, case-insensitive word by finding all documents whreturn I.emptyIntermediate -- ich contain the word as prefix. + +processWord :: HolIndex i => ProcessState i -> String -> Intermediate +processWord s q = forAllContexts wordNoCase (contexts s) + where + wordNoCase c = I.fromList q c $ limitWords s $ IDX.prefixNoCase (index s) c q + +-- | Monadic version of 'processWord'. + +processWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate +processWordM s q = forAllContextsM wordNoCase (contexts s) + where + wordNoCase c = IDX.prefixNoCaseM (index s) c q >>= limitWordsM s >>= \r -> return $ I.fromList q c r + +-- | Process a single, case-sensitive word by finding all documents which contain the word as prefix. + +processCaseWord :: HolIndex i => ProcessState i -> String -> Intermediate +processCaseWord s q = forAllContexts wordCase (contexts s) + where + wordCase c = I.fromList q c $ limitWords s $ IDX.prefixCase (index s) c q + +-- | Monadic version of 'processCaseWord'. + +processCaseWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate +processCaseWordM s q = forAllContextsM wordCase (contexts s) + where + wordCase c = IDX.prefixCaseM (index s) c q >>= limitWordsM s >>= \r -> return $ I.fromList q c r + +-- | Process a phrase case-insensitive. + +processPhrase :: HolIndex i => ProcessState i -> String -> Intermediate +processPhrase s q = forAllContexts phraseNoCase (contexts s) + where + phraseNoCase c = processPhraseInternal (IDX.lookupNoCase (index s) c) c q + +-- processPhraseM :: HolIndexM m i => ProcessState i -> String -> m Intermediate +-- processPhraseM s q = forAllContextsM phraseNoCase (contexts s) +-- where +-- phraseNoCase c = + +-- | Process a phrase case-sensitive. + +processCasePhrase :: HolIndex i => ProcessState i -> String -> Intermediate +processCasePhrase s q = forAllContexts phraseCase (contexts s) + where + phraseCase c = processPhraseInternal (IDX.lookupCase (index s) c) c q + +-- | Process a phrase query by searching for every word of the phrase and comparing their positions. + +processPhraseInternal :: (String -> RawResult) -> Context -> String -> Intermediate +processPhraseInternal f c q = let + w = words q + m = mergeOccurrencesList $ map snd $ f (head w) in + if nullDocIdMap m + then I.emptyIntermediate + else I.fromList q c [(q, processPhrase' (tail w) 1 m)] + where + processPhrase' :: [String] -> Position -> Occurrences -> Occurrences + processPhrase' [] _ o = o + processPhrase' (x:xs) p o = processPhrase' xs (p+1) (filterWithKeyDocIdMap (nextWord $ map snd $ f x) o) + where + nextWord :: [Occurrences] -> DocId -> Positions -> Bool + nextWord [] _ _ = False + nextWord no d np = maybe False hasSuccessor (lookupDocIdMap d (mergeOccurrencesList no)) + where + hasSuccessor :: Positions -> Bool + hasSuccessor w = foldPos (\cp r -> r || (memberPos (cp + p) w)) False np + +-- | Process a single word and try some fuzzy alternatives if nothing was found. + +processFuzzyWord :: HolIndex i => ProcessState i -> String -> Intermediate +processFuzzyWord s oq = processFuzzyWord' (F.toList $ F.fuzz (getFuzzyConfig s) oq) (processWord s oq) + where + processFuzzyWord' :: [(String, FuzzyScore)] -> Intermediate -> Intermediate + processFuzzyWord' [] r = r + processFuzzyWord' (q:qs) r = if I.null r then processFuzzyWord' qs (processWord s (fst q)) else r + +-- | Monadic version of 'processFuzzyWord'. + +processFuzzyWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate +processFuzzyWordM s oq = do + sr <- processWordM s oq + cfg <- getFuzzyConfigM s + processFuzzyWordM' (F.toList $ F.fuzz cfg oq) sr + where + processFuzzyWordM' [] r = return r + processFuzzyWordM' (q:qs) r = if I.null r + then processWordM s (fst q) >>= processFuzzyWordM' qs + else return r + +-- | Process a negation by getting all documents and substracting the result of the negated query. + +processNegation :: HolIndex i => ProcessState i -> Intermediate -> Intermediate +processNegation s r = I.difference (allDocuments s) r + +-- | Monadic version of 'processNegation'. + +processNegationM :: HolIndexM m i => ProcessState i -> Intermediate -> m Intermediate +processNegationM s r1 = allDocumentsM s >>= \r2 -> return $ I.difference r2 r1 + +-- | Process a binary operator by caculating the union or the intersection of the two subqueries. + +processBin :: BinOp -> Intermediate -> Intermediate -> Intermediate +processBin And r1 r2 = I.intersection r1 r2 +processBin Or r1 r2 = I.union r1 r2 +processBin But r1 r2 = I.difference r1 r2 + + +-- | Limit a 'RawResult' to a fixed amount of the best words. +-- +-- First heuristic applied is limiting the number of documents in the result, +-- assuming the short words come first in the result list +-- So the length of the result list depends on the number of documents found. +-- +-- TODO: This is fixed to 2000, should be part of the config part of the state +-- +-- A 2. simple heuristic is used to +-- determine the quality of a word: The total number of occurrences divided by the number of +-- documents in which the word appears. +-- +-- The second heuristic isn't that expensive any more when the resul list is cut of by the heuristic +-- +-- The limit 500 should be part of a configuration + +limitWords :: ProcessState i -> RawResult -> RawResult +limitWords s r = cutW . cutD $ r + where + limitD = docLimit $ config s + cutD + | limitD > 0 = limitDocs limitD + | otherwise = id + + limitW = wordLimit $ config s + cutW + | limitW > 0 + && + length r > limitW + = map snd . take limitW . L.sortBy (compare `on` fst) . map calcScore + | otherwise = id + + calcScore :: (Word, Occurrences) -> (Double, (Word, Occurrences)) + calcScore w@(_, o) = (log (fromIntegral (total s) / fromIntegral (sizeDocIdMap o)), w) + +-- ---------------------------------------------------------------------------- + +-- | Limit the number of docs in a raw result + +limitDocs :: Int -> RawResult -> RawResult +limitDocs _ [] = [] +limitDocs limit _ + | limit <= 0 = [] +limitDocs limit (x:xs) = x : limitDocs (limit - sizeDocIdMap (snd x)) xs + +-- ---------------------------------------------------------------------------- + +-- | Monadic version of 'limitWords'. +limitWordsM :: (Monad m) => ProcessState i -> RawResult -> m RawResult +limitWordsM s r = return $ limitWords s r + +-- | Merge occurrences +mergeOccurrencesList :: [Occurrences] -> Occurrences +mergeOccurrencesList = unionsWithDocIdMap unionPos + +-- ---------------------------------------------------------------------------- diff --git a/src/Holumbus/Query/Ranking.hs b/src/Holumbus/Query/Ranking.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Query/Ranking.hs @@ -0,0 +1,129 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Query.Ranking + Copyright : Copyright (C) 2007, 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.3 + + The ranking mechanism for Holumbus. + + Customized ranking functions for both documents and suggested words can be + provided by the user. Some predefined ranking functions are avaliable, too. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Query.Ranking + ( + -- * Ranking types + RankConfig (..) + , DocRanking + , WordRanking + + -- * Ranking + , rank + + -- * Predefined document rankings + , docRankByCount + , docRankWeightedByCount + + -- * Predefined word rankings + , wordRankByCount + , wordRankWeightedByCount + ) +where + +import Prelude hiding (foldr) + +import Data.Function +import Data.Foldable + +import qualified Data.List as L +import qualified Data.Map as M + +import Holumbus.Query.Result +import Holumbus.Index.Common + +-- ---------------------------------------------------------------------------- + +-- | The configuration of the ranking mechanism. +data RankConfig a = RankConfig + { docRanking :: DocRanking a -- ^ A function to determine the score of a document. + , wordRanking :: WordRanking -- ^ A funciton to determine the score of a word. + } + +-- | The signature of a function to determine the score of a document. +type DocRanking a = DocId -> DocInfo a -> DocContextHits -> Score + +-- | The signature of a function to determine the score of a word. +type WordRanking = Word -> WordInfo -> WordContextHits -> Score + +-- ---------------------------------------------------------------------------- + +-- | Rank the result with custom ranking functions. + +rank :: RankConfig a -> Result a -> Result a +rank (RankConfig fd fw {-ld lw-}) r + = Result scoredDocHits scoredWordHits + where + scoredDocHits = mapWithKeyDocIdMap (\k (di, dch) -> (setDocScore (fd k di dch) di, dch)) $ + docHits r + scoredWordHits = M.mapWithKey (\k (wi, wch) -> (setWordScore (fw k wi wch) wi, wch)) $ + wordHits r + +-- | Rank documents by count. + +docRankByCount :: DocId -> DocInfo a -> DocContextHits -> Score +docRankByCount _ _ h = fromIntegral $ + M.fold (\h1 r1 -> M.fold (\h2 r2 -> sizePos h2 + r2) r1 h1) 0 h + +-- | Rank words by count. + +wordRankByCount :: Word -> WordInfo -> WordContextHits -> Score +wordRankByCount _ _ h = fromIntegral $ M.fold (\h1 r1 -> foldDocIdMap ((+) . sizePos) r1 h1) 0 h + +-- | Rank documents by context-weighted count. The weights will be normalized to a maximum of 1.0. +-- Contexts with no weight (or a weight of zero) will be ignored. + +docRankWeightedByCount :: [(Context, Score)] -> DocId -> DocInfo a -> DocContextHits -> Score +docRankWeightedByCount ws _ _ h + = M.foldrWithKey (calcWeightedScore ws) 0.0 h + +-- | Rank words by context-weighted count. The weights will be normalized to a maximum of 1.0. +-- Contexts with no weight (or a weight of zero) will be ignored. + +wordRankWeightedByCount :: [(Context, Score)] -> Word -> WordInfo -> WordContextHits -> Score +wordRankWeightedByCount ws _ _ h + = M.foldrWithKey (calcWeightedScore ws) 0.0 h + +-- | Calculate the weighted score of occurrences of a word. + +calcWeightedScore :: (Foldable f) => + [(Context, Score)] -> Context -> (f Positions) -> Score -> Score +calcWeightedScore ws c h r + = maybe r (\w -> r + ((w / mw) * count)) $ + lookupWeight c ws + where + count = fromIntegral $ + foldl' (flip $ (+) . sizePos) 0 h + mw = snd $ + L.maximumBy (compare `on` snd) ws + +-- | Find the weight of a context in a list of weights. If the context was not found or it's +-- weight is equal to zero, 'Nothing' will be returned. + +lookupWeight :: Context -> [(Context, Score)] -> Maybe Score +lookupWeight _ [] = Nothing +lookupWeight c (x:xs) = if fst x == c + then if snd x /= 0.0 + then Just (snd x) + else Nothing + else lookupWeight c xs + +-- ---------------------------------------------------------------------------- diff --git a/src/Holumbus/Query/Result.hs b/src/Holumbus/Query/Result.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Query/Result.hs @@ -0,0 +1,260 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Query.Result + Copyright : Copyright (C) 2007 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + + The data type for results of Holumbus queries. + + The result of a query is defined in terms of two partial results, + the documents containing the search terms and the words which + are possible completions of the serach terms. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Query.Result + ( + -- * Result data types + Result (..) + , DocHits + , DocContextHits + , DocWordHits + , WordHits + , WordContextHits + , WordDocHits + , DocInfo (..) + , WordInfo (..) + , Score + + -- * Construction + , emptyResult + + -- * Query + , null + , sizeDocHits + , sizeWordHits + , maxScoreDocHits + , maxScoreWordHits + , getDocuments + + -- * Transform + , setDocScore + , setWordScore + + -- * Picklers + , xpDocHits + , xpWordHits + ) +where + +import Prelude hiding (null) + +import Control.DeepSeq +import Control.Monad ( liftM2 ) + +import Data.Binary ( Binary (..) ) +import Data.Function +import Data.Map (Map) +import qualified + Data.Map as M +import qualified + Data.List as L + +import Holumbus.Utility +import Holumbus.Index.Common + +import Text.XML.HXT.Core + +-- ---------------------------------------------------------------------------- + +-- | The combined result type for Holumbus queries. +data Result a = Result + { docHits :: (DocHits a) -- ^ The documents matching the query. + , wordHits :: WordHits -- ^ The words which are completions of the query terms. + } + deriving (Eq, Show) + +-- | Information about an document. +data DocInfo a = DocInfo + { document :: (Document a) -- ^ The document itself. + , docScore :: Score -- ^ The score for the document (initial score for all documents is @0.0@). + } + deriving (Eq, Show) + +-- | Information about a word. +data WordInfo = WordInfo + { terms :: Terms -- ^ The search terms that led to this very word. + , wordScore :: Score -- ^ The frequency of the word in the document for a context. + } + deriving (Eq, Show) + +-- | A mapping from a document to it's score and the contexts where it was found. +type DocHits a = DocIdMap (DocInfo a, DocContextHits) + +-- | A mapping from a context to the words of the document that were found in this context. +type DocContextHits = Map Context DocWordHits + +-- | A mapping from a word of the document in a specific context to it's positions. +type DocWordHits = Map Word Positions + +-- | A mapping from a word to it's score and the contexts where it was found. +type WordHits = Map Word (WordInfo, WordContextHits) + +-- | A mapping from a context to the documents that contain the word that were found in this context. +type WordContextHits = Map Context WordDocHits + +-- | A mapping from a document containing the word to the positions of the word. +type WordDocHits = Occurrences + +-- | The score of a hit (either a document hit or a word hit). +type Score = Float + +-- | The original search terms entered by the user. +type Terms = [String] + +-- ---------------------------------------------------------------------------- + +instance Binary a => Binary (Result a) where + put (Result dh wh) = put dh >> put wh + get = liftM2 Result get get + +instance Binary a => Binary (DocInfo a) where + put (DocInfo d s) = put d >> put s + get = liftM2 DocInfo get get + +instance Binary WordInfo where + put (WordInfo t s) = put t >> put s + get = liftM2 WordInfo get get + +instance NFData a => NFData (Result a) where + rnf (Result dh wh) = rnf dh `seq` rnf wh + +instance NFData a => NFData (DocInfo a) where + rnf (DocInfo d s) = rnf d `seq` rnf s + +instance NFData WordInfo where + rnf (WordInfo t s) = rnf t `seq` rnf s + +instance XmlPickler a => XmlPickler (Result a) where + xpickle = xpElem "result" $ + xpWrap ( \ (dh, wh) -> Result dh wh + , \ (Result dh wh) -> (dh, wh) + ) (xpPair xpDocHits xpWordHits) + +instance XmlPickler a => XmlPickler (DocInfo a) where + xpickle = xpWrap ( \ (d, s) -> DocInfo d s + , \ (DocInfo d s) -> (d, s) + ) xpDocInfo' + where + xpDocInfo' = xpPair xpickle (xpAttr "score" xpPrim) + +instance XmlPickler WordInfo where + xpickle = xpWrap ( \ (t, s) -> WordInfo t s + , \ (WordInfo t s) -> (t, s) + ) xpWordInfo + where + xpWordInfo = xpPair (xpAttr "term" xpTerms) + (xpAttr "score" xpPrim) + xpTerms = xpWrap (split ",", join ",") xpText0 + +-- ---------------------------------------------------------------------------- + +-- | The XML pickler for the document hits. Will be sorted by score. +xpDocHits :: XmlPickler a => PU (DocHits a) +xpDocHits = xpElem "dochits" $ + xpWrap ( fromListDocIdMap + , toListSorted + ) (xpList xpDocHit) + where + toListSorted = L.sortBy (compare `on` (docScore . fst . snd)) . toListDocIdMap -- Sort by score + xpDocHit = xpElem "doc" $ + xpPair (xpAttr "idref" xpDocId) + (xpPair xpickle xpDocContextHits) + +-- | The XML pickler for the contexts in which the documents were found. +xpDocContextHits :: PU DocContextHits +xpDocContextHits = xpWrap (M.fromList, M.toList) $ + xpList xpDocContextHit + where + xpDocContextHit = xpElem "context" $ + xpPair (xpAttr "name" xpText) xpDocWordHits + +-- | The XML pickler for the words and positions found in a document. +xpDocWordHits :: PU DocWordHits +xpDocWordHits = xpWrap (M.fromList, M.toList) (xpList xpDocWordHit) + where + xpDocWordHit = xpElem "word" $ + xpPair (xpAttr "w" xpText) xpPositions + +-- | The XML pickler for the word hits. Will be sorted alphabetically by the words. +xpWordHits :: PU WordHits +xpWordHits = xpElem "wordhits" $ + xpWrap (M.fromList, toListSorted) $ + xpList xpWordHit + where + toListSorted = L.sortBy (compare `on` fst) . M.toList -- Sort by word + xpWordHit = xpElem "word" $ + xpPair (xpAttr "w" xpText) + (xpPair xpickle xpWordContextHits) + +-- | The XML pickler for the contexts in which the words were found. +xpWordContextHits :: PU WordContextHits +xpWordContextHits = xpWrap (M.fromList, M.toList) $ + xpList xpWordContextHit + where + xpWordContextHit = xpElem "context" $ + xpPair (xpAttr "name" xpText) xpWordDocHits + +-- | The XML pickler for the documents and positions where the word occurs (reusing existing pickler). +xpWordDocHits :: PU WordDocHits +xpWordDocHits = xpOccurrences + +-- ---------------------------------------------------------------------------- + +-- | Create an empty result. +emptyResult :: Result a +emptyResult = Result emptyDocIdMap M.empty + +-- | Query the number of documents in a result. +sizeDocHits :: Result a -> Int +sizeDocHits = sizeDocIdMap . docHits + +-- | Query the number of documents in a result. +sizeWordHits :: Result a -> Int +sizeWordHits = M.size . wordHits + +-- | Query the maximum score of the documents. +maxScoreDocHits :: Result a -> Score +maxScoreDocHits = (foldDocIdMap (\(di, _) r -> max (docScore di) r) 0.0) . docHits + +-- | Query the maximum score of the words. +maxScoreWordHits :: Result a -> Score +maxScoreWordHits = (M.fold (\(wi, _) r -> max (wordScore wi) r) 0.0) . wordHits + +-- | Test if the result contains anything. +null :: Result a -> Bool +null = nullDocIdMap . docHits + +-- | Set the score in a document info. +setDocScore :: Score -> DocInfo a -> DocInfo a +setDocScore s (DocInfo d _) + = DocInfo d s + +-- | Set the score in a word info. +setWordScore :: Score -> WordInfo -> WordInfo +setWordScore s (WordInfo t _) + = WordInfo t s + +-- | Extract all documents from a result +getDocuments :: Result a -> [Document a] +getDocuments r = map (document . fst . snd) $ + toListDocIdMap (docHits r) + +-- ---------------------------------------------------------------------------- diff --git a/src/Holumbus/Utility.hs b/src/Holumbus/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Holumbus/Utility.hs @@ -0,0 +1,168 @@ +-- ---------------------------------------------------------------------------- + +{- | + Module : Holumbus.Utility + Copyright : Copyright (C) 2008 Timo B. Huebel + License : MIT + + Maintainer : Timo B. Huebel (tbh@holumbus.org) + Stability : experimental + Portability: portable + Version : 0.1 + + Small utility functions which are probably useful somewhere else, too. + +-} + +-- ---------------------------------------------------------------------------- + +module Holumbus.Utility where + + +import Control.Exception (bracket) + +import Data.Binary +import qualified Data.ByteString.Lazy as B +import Data.Char +import qualified Data.List as L + +import Numeric ( showHex ) + +import System.IO + +import Text.XML.HXT.Core + +-- ------------------------------------------------------------ + +-- | Split a string into seperate strings at a specific character sequence. + +split :: Eq a => [a] -> [a] -> [[a]] +split _ [] = [[]] +split at w@(x:xs) = maybe ((x:r):rs) ((:) [] . split at) (L.stripPrefix at w) + where (r:rs) = split at xs + +-- | Join with a seperating character sequence. + +join :: Eq a => [a] -> [[a]] -> [a] +join = L.intercalate + +-- | Removes leading and trailing whitespace from a string. + +strip :: String -> String +strip = stripWith isSpace + +-- | Removes leading whitespace from a string. + +stripl :: String -> String +stripl = dropWhile isSpace + +-- | Removes trailing whitespace from a string. + +stripr :: String -> String +stripr = reverse . dropWhile isSpace . reverse + +-- | Strip leading and trailing elements matching a predicate. + +stripWith :: (a -> Bool) -> [a] -> [a] +stripWith f = reverse . dropWhile f . reverse . dropWhile f + +-- | found on the haskell cafe mailing list +-- (). +-- Depends on bytestring >= 0.9.0.4 (?) + +strictDecodeFile :: Binary a => FilePath -> IO a +strictDecodeFile f = + bracket (openBinaryFile f ReadMode) + hClose + $ \h -> do c <- B.hGetContents h + return $! decode c + +-- | partition the list of input data into a list of input data lists of +-- approximately the same specified length + +partitionListByLength :: Int -> [a] -> [[a]] +partitionListByLength _ [] = [] +partitionListByLength count l = [take count l] ++ (partitionListByLength count (drop count l)) + +-- | partition the list of input data into a list of a specified number of input data lists with +-- approximately the same length + +partitionListByCount :: Int -> [a] -> [[a]] +partitionListByCount sublistCount list = partition sublistCount list + where + partition 0 _ = [] + partition sublists l + = let next = ((length l) `div` sublists) + in if next == 0 then [l] + else [take next l] ++ partition (sublists -1) (drop next l) + +-- | Escapes non-alphanumeric or space characters in a String + +escape :: String -> String +escape [] = [] +escape (c:cs) + = if isAlphaNum c || isSpace c + then c : escape cs + else '%' : showHex (fromEnum c) "" ++ escape cs + +-- ------------------------------------------------------------ +-- | Compute the base of a webpage +-- stolen from Uwe Schmidt, http:\/\/www.haskell.org\/haskellwiki\/HXT + +computeDocBase :: ArrowXml a => a XmlTree String +computeDocBase + = ( ( ( this + /> hasName "html" + /> hasName "head" + /> hasName "base" + >>> getAttrValue "href" + ) + &&& + getAttrValue "transfer-URI" + ) + >>> expandURI + ) + `orElse` + getAttrValue "transfer-URI" + +traceOffset :: Int +traceOffset = 3 + +trcMsg :: String -> IO () +trcMsg m = hPutStrLn stderr ('-':"- (0) " ++ m) + +-- ------------------------------------------------------------ +-- +-- simple and usefull access arrows + +getByPath :: ArrowXml a => [String] -> a XmlTree XmlTree +getByPath = seqA . map (\ n -> getChildren >>> hasName n) + +robotsNo :: String -> LA XmlTree XmlTree +robotsNo what = none + `when` + ( getByPath ["html", "head", "meta"] + >>> + hasAttrValue "name" ( map toUpper + >>> + (== "ROBOTS") + ) + >>> + getAttrValue0 "content" + >>> + isA ( map (toUpper >>> (\ x -> if isLetter x then x else ' ')) + >>> + words + >>> + (what `elem`) + ) + ) + +robotsNoIndex :: ArrowXml a => a XmlTree XmlTree +robotsNoIndex = fromLA $ robotsNo "NOINDEX" + +robotsNoFollow :: ArrowXml a => a XmlTree XmlTree +robotsNoFollow = fromLA $ robotsNo "NOFOLLOW" + +-- ------------------------------------------------------------ +