diff --git a/Text/Search/Sphinx.hs b/Text/Search/Sphinx.hs --- a/Text/Search/Sphinx.hs +++ b/Text/Search/Sphinx.hs @@ -7,227 +7,87 @@ import System import Control.Exception import Data.Binary.Get -import Data.Binary.Put -import Data.ByteString.Lazy hiding (pack, length, map) +import Data.Binary.Put (runPut, Put) +import Data.ByteString.Lazy hiding (pack, length, map, groupBy, head) import Data.ByteString.Lazy.Char8 (pack) import qualified Data.ByteString.Lazy as BS import Data.Char (ord, chr) -import Control.Monad import Data.Int (Int64) import Prelude hiding (readList) +import Text.Search.Sphinx.Get +import Text.Search.Sphinx.Put +import Text.Search.Sphinx.Configuration +import Text.Search.Sphinx.Types (SearchResult) +import qualified Text.Search.Sphinx.Types as T --- | The configuration for a query -data Configuration = Configuration { - -- | The hostname of the Sphinx daemon - host :: String - -- | The portnumber of the Sphinx daemon - , port :: PortID - -- | How many records to seek from result-set start (default is 0) - , offset :: Int - -- | How many records to return from result-set starting at offset (default is 20) - , limit :: Int - -- | Query matching mode - , mode :: Int - -- | Ranking mode - , ranker :: Int - -- | Match sorting mode - , sort :: Int - -- | Attribute to sort by - , sortBy :: String - -- | Minimum ID to match, 0 means no limit - , minId :: Int - -- | Maximum ID to match, 0 means no limit - , maxId :: Int - -- | Group-by sorting clause (to sort groups in result set with) - , groupSort :: String -} -data AttributeType = AttrNone - | AttrInteger - | AttrTimestamp - | AttrOrdinal - | AttrBool - | AttrFloat - | AttrMulti - -attributeType :: Int -> AttributeType -attributeType 0 = AttrNone -attributeType 1 = AttrInteger -attributeType 2 = AttrTimestamp -attributeType 3 = AttrOrdinal -attributeType 4 = AttrBool -attributeType 5 = AttrFloat -attributeType 0X40000000 = AttrMulti - type Connection = (Handle, Configuration) connect :: Configuration -> IO Connection -connect cfg = do connection <- connectTo (host cfg) (port cfg) - bs <- hGet connection 4 - let version = runGet getWord32be bs - myVersion = runPut (putWord32be 1) +connect cfg = do connection <- connectTo (host cfg) (PortNumber $ fromIntegral $ port cfg) + bs <- hGet connection 4 + let version = runGet getWord32be bs + myVersion = runPut (num 1) hPut connection myVersion return (connection, cfg) - --sClose connection -num = putWord32be . toEnum -num64 = putWord64be . toEnum -numList ls = do num (length ls) - mapM_ num ls - -nums cfg = mapM_ (\x -> num $ x cfg) -num64s cfg = mapM_ (\x -> num64 $ x cfg) - -str :: String -> Put -str s = do let bs = pack s - num (Prelude.length s) -- todo: dangerous - putLazyByteString bs - -addQuery :: Connection -> String -> String -> String -> Put -addQuery c q i cm = addQuery' c q i cm - -addQuery' (handle, cfg) query index comment = do - nums cfg [offset, limit, mode, ranker, sort] - -- pack sortbyLen and sortBy +addQuery :: Configuration -> String -> String -> String -> Put +addQuery cfg query index comment = do + nums cfg [ offset + , limit + , T.matchMode . mode + , T.rank . ranker + , T.sort . sort] str (sortBy cfg) - -- pack the queryLen and query encoded in utf-8 str query - -- weights - numList [100, 1] - -- pack len index and index + numList (weights cfg) str index - num 1 -- tODO: id64 range marker + num 1 num64s cfg [minId, maxId] - -- pack len filters + filters - num 0 -- todo - -- pack groupfunc - num 0 -- todo - -- pack len groupby + groupby - str "" --todo - -- -- req.append ( pack ( '>2L', self._maxmatches) ) ) - nums cfg [const 1000] --todo - - -- -- req.append ( len + self._groupsort ) - str (groupSort cfg) - - -- -- req.append ( pack ( '>LLL', self._cutoff, self._retrycount, self._retrydelay)) - nums cfg [const 0, const 0, const 0] - -- -- req.append ( self._groupdistinct) - str "" --todo - -- -- anchor point - num 0 --todo - -- -- per index weights - num 0 --todo - -- pack [max_query_time] - num 0 --todo - -- -- per-field weights - num 0 --todo - -- pack commentLen + comment + num 0 -- todo: pack len filters + filters + enum (groupByFunc cfg) + str (groupBy cfg) + num (maxMatches cfg) + str (groupSort cfg) + num (cutoff cfg) + num (retryCount cfg) + num (retryDelay cfg) + str (groupDistinct cfg) + num 0 -- anchor point: todo + stringIntList (indexWeights cfg) + num (maxQueryTime cfg) + stringIntList (fieldWeights cfg) str comment --- | A basic, default configuration. -defaultConfig = Configuration { - port = PortNumber 3312 - , host = "127.0.0.1" - , offset = 0 - , limit = 20 - , mode = sph_match_all - , ranker = sph_rank_proximity_bm25 - , sort = sort_relevance - , sortBy = "" - , minId = 0 - , maxId = 0 - , groupSort = "@group desc" - } - -sph_match_all = 0 -sph_rank_proximity_bm25 = 0 -sort_relevance = 0 - -cmdSearch = putWord16be 0 -verCmdSearch = putWord16be 0x113 - -query :: Configuration -> String -> IO [Text.Search.Sphinx.SearchResult] -query config s = do +-- | The 'query' function queries the Sphinx daemon. +query :: Configuration -- ^ The configuration + -> String -- ^ The indexes, "*" means every index + -> String -- ^ The query string + -> IO SearchResult +query config indexes s = do conn <- connect config - let q = addQuery conn s "*" "" - runQueries (fst conn) q 1 + let q = addQuery config s indexes "" + results <- runQueries (fst conn) q 1 + return $ head results -- We only do one query, so we always have one SearchResult runQueries :: Handle -> Put -> Int -> IO [SearchResult] runQueries conn q numQueries = do let req = runPut (makeRunQuery q numQueries) hPut conn req hFlush conn - getResponse conn 1 + getResponse conn numQueries makeRunQuery query numQueries = do - cmdSearch - verCmdSearch + cmd T.ScSearch + verCmd T.VcSearch num $ fromEnum $ BS.length (runPut query) + 4 num numQueries query ---getResponse :: Handle -> Int -> IO [SearchResult] getResponse conn numResults = do - bs <- hGet conn 8 - let x@(status, version, len) = runGet f bs + header <- hGet conn 8 + let x@(status, version, len) = readHeader header response <- hGet conn (fromIntegral len) return $ runGet (numResults `times` getResult) response - where - f = do status <- getWord16be - version <- getWord16be - length <- getWord32be - return (status, version, length) - --- todo applicative -getNum :: Get Int -getNum = getWord32be >>= return . fromEnum - -getNum64 :: Get Int64 -getNum64 = getWord64be >>= return . fromIntegral - -readList f = do num <- getNum - num `times` f - -type SearchResult = ([(Int64, Int, [Int])], Int, Int, Int, [(ByteString, Int, Int)]) -getResult :: Get SearchResult -getResult = do - status <- getNum - -- todo: we suppose the status is OK - fields <- readList readField - attrs <- readList readAttr - matchCount <- getNum - id64 <- getNum - matches <- matchCount `times` readMatch (id64 > 0) (map snd attrs) - [total, totalFound, time, numWords] <- 4 `times` getNum - wrds <- numWords `times` readWord - return $ (matches, total, totalFound, time, wrds) - -times = replicateM - -readWord = do s <- readStr - [doc, hits] <- 2 `times` getNum - return (s, doc, hits) - -readField = readStr - -readMatch isId64 attrs = do - doc <- if isId64 then getNum64 else (getNum >>= return . fromIntegral) - weight <- getNum - matchAttrs <- mapM readMatchAttr attrs - return (doc, weight, matchAttrs) - -readMatchAttr AttrFloat = error "readMatchAttr for AttrFloat not implemented yet." -readMatchAttr AttrMulti = error "readMatchAttr for AttrFloat not implemented yet." -readMatchAttr _ = getNum - - -readStr = do len <- getNum - getLazyByteString (fromIntegral len) - -readAttr = do - s <- readStr - t <- getNum - return (s, attributeType t) diff --git a/Text/Search/Sphinx/Configuration.hs b/Text/Search/Sphinx/Configuration.hs new file mode 100644 --- /dev/null +++ b/Text/Search/Sphinx/Configuration.hs @@ -0,0 +1,76 @@ +module Text.Search.Sphinx.Configuration where + +import qualified Text.Search.Sphinx.Types as T + +-- | The configuration for a query +data Configuration = Configuration { + -- | The hostname of the Sphinx daemon + host :: String + -- | The portnumber of the Sphinx daemon + , port :: Int + -- | Per-field weights + , weights :: [Int] + -- | How many records to seek from result-set start (default is 0) + , offset :: Int + -- | How many records to return from result-set starting at offset (default is 20) + , limit :: Int + -- | Query matching mode + , mode :: T.MatchMode + -- | Ranking mode + , ranker :: T.Rank + -- | Match sorting mode + , sort :: T.Sort + -- | Attribute to sort by + , sortBy :: String + -- | Minimum ID to match, 0 means no limit + , minId :: Int + -- | Maximum ID to match, 0 means no limit + , maxId :: Int + -- | Group-by sorting clause (to sort groups in result set with) + , groupBy :: String + -- | Group-by count-distinct attribute + , groupSort :: String + -- | Group-by function (to pre-process group-by attribute value with) + , groupByFunc :: T.GroupByFunction + -- | Group-by attribute name + , groupDistinct :: String + -- | Maximum number of matches to retrieve + , maxMatches :: Int + -- | Cutoff to stop searching at + , cutoff :: Int + -- | Distributed retries count + , retryCount :: Int + -- | Distributed retries delay + , retryDelay :: Int + -- | Per-index weights + , indexWeights :: [(String, Int)] + -- | Maximum query time in milliseconds, 0 means no limit + , maxQueryTime :: Int + -- | Per-field-name weights + , fieldWeights :: [(String, Int)] +} +-- | A basic, default configuration. +defaultConfig = Configuration { + port = 3312 + , host = "127.0.0.1" + , weights = [] + , offset = 0 + , limit = 20 + , mode = T.All + , ranker = T.ProximityBm25 + , sort = T.Relevance + , sortBy = "" + , minId = 0 + , maxId = 0 + , groupSort = "@group desc" + , groupBy = "" + , groupByFunc = T.Day + , groupDistinct = "" + , maxMatches = 1000 + , cutoff = 0 + , retryCount = 0 + , retryDelay = 0 + , indexWeights = [] + , maxQueryTime = 0 + , fieldWeights = [] + } diff --git a/Text/Search/Sphinx/Types.hs b/Text/Search/Sphinx/Types.hs new file mode 100644 --- /dev/null +++ b/Text/Search/Sphinx/Types.hs @@ -0,0 +1,146 @@ +module Text.Search.Sphinx.Types where + +import Data.ByteString.Lazy (ByteString) +import Data.Int (Int64) + +-- | Search commands +data SearchdCommand = ScSearch + | ScExcerpt + | ScUpdate + | ScKeywords + deriving (Show, Enum) + +searchdCommand :: SearchdCommand -> Int +searchdCommand = fromEnum + +-- | Current client-side command implementation versions +data VerCommand = VcSearch + | VcExcerpt + | VcUpdate + | VcKeywords + deriving (Show) + +verCommand VcSearch = 0x113 +verCommand VcExcerpt = 0x100 +verCommand VcUpdate = 0x101 +verCommand VcKeywords = 0x100 + +-- | Searchd status codes +data Searchd = Ok + | Error + | Retry + | Warning + deriving (Show, Enum) + +searchd :: Searchd -> Int +searchd = fromEnum + +-- | Match modes +data MatchMode = All + | Any + | Phrase + | Boolean + | Extended + | Fullscan + | Extended2 -- extended engine V2 (TEMPORARY, WILL BE REMOVED) + deriving (Show, Enum) + +matchMode :: MatchMode -> Int +matchMode = fromEnum + +-- | Ranking modes (ext2 only) +data Rank = ProximityBm25 -- default mode, phrase proximity major factor and BM25 minor one + | Bm25 -- statistical mode, BM25 ranking only (faster but worse quality) + | None -- no ranking, all matches get a weight of 1 + | WordCount -- simple word-count weighting, rank is a weighted sum of per-field keyword occurence counts + deriving (Show, Enum) + +rank :: Rank -> Int +rank = fromEnum + +-- | Sort modes +data Sort = Relevance + | AttrDesc + | AttrAsc + | TimeSegments + | SortExtended -- constructor already existed + | Expr + deriving (Show, Enum) + +sort :: Sort -> Int +sort = fromEnum + +-- | Filter types +data Filter = Values + | Range + | FloatRange + deriving (Show, Enum) + +filter :: Filter -> Int +filter = fromEnum + +-- | Attribute types +data AttrT = AttrTInteger + | AttrTTimestamp + | AttrTOrdinal + | AttrTBool + | AttrTFloat + | AttrTMulti + deriving (Show) + +instance Enum AttrT where + toEnum = toAttrT + fromEnum = attrT + +toAttrT 1 = AttrTInteger +toAttrT 2 = AttrTTimestamp +toAttrT 3 = AttrTOrdinal +toAttrT 4 = AttrTBool +toAttrT 5 = AttrTFloat +toAttrT 0x40000000 = AttrTMulti + +attrT AttrTInteger = 1 +attrT AttrTTimestamp = 2 +attrT AttrTOrdinal = 3 +attrT AttrTBool = 4 +attrT AttrTFloat = 5 +attrT AttrTMulti = 0x40000000 + +-- | Grouping functions +data GroupByFunction = Day + | Week + | Month + | Year + | Attr + | AttrPair + deriving (Show, Enum) + +groupByFunction :: GroupByFunction -> Int +groupByFunction = fromEnum + +-- | The result of a query +data SearchResult = SearchResult { + -- | The matches + matches :: [Match] + -- | Total amount of matches retrieved on server by this query. + , total :: Int + -- | Total amount of matching documents in index. + , totalFound :: Int + -- | List of processed words with the number of docs and the number of hits. + , words :: [(ByteString, Int, Int)] +} + deriving Show + +data Match = Match { + -- Document ID + documentId :: Int64 + -- Document weight + , documentWeight :: Int + -- Attribute values + , attributeValues :: [Attr] + } + deriving Show + +data Attr = AttrMulti [Int] + | AttrNum Int + deriving Show diff --git a/sphinx.cabal b/sphinx.cabal --- a/sphinx.cabal +++ b/sphinx.cabal @@ -1,5 +1,5 @@ Name: sphinx -Version: 0.0 +Version: 0.1 Synopsis: Haskell bindings to the Sphinx full-text searching deamon. Description: Haskell bindings to the Sphinx full-text searching deamon. This module is heavily inspired by the php and python client. @@ -9,6 +9,6 @@ Copyright: (c) 2008 Tupil Author: Tupil Maintainer: Chris Eidhof -Exposed-Modules: Text.Search.Sphinx +Exposed-Modules: Text.Search.Sphinx, Text.Search.Sphinx.Types, Text.Search.Sphinx.Configuration Build-Type: Simple Build-Depends: base, binary, bytestring, network, haskell98