{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

-- The following functions are not yet implemented:
-- setFilterFloatRange, setGeoAnchor
-- resetFilters, resetGroupBy
-- updateAttributes,
-- buildKeyWords, status, open, close
module Text.Search.Sphinx 
  ( escapeText
  , query
  , buildExcerpts
  , runQueries
  , runQueries'
  , resultsToMatches
  , maybeQueries
  , T.Query(..), simpleQuery
  , Configuration(..), defaultConfig
  ) where

import qualified Text.Search.Sphinx.Types as T (
  Match,
  Query(..),
  VerCommand(VcSearch, VcExcerpt),
  SearchdCommand(ScSearch, ScExcerpt),
  Filter, Filter(..),
  fromEnumFilter, Filter(..),
  QueryStatus(..), toStatus, Status(..),
  SingleResult(..), Result(..), QueryResult(..))

import Text.Search.Sphinx.Types ( Rank(..) )
import Text.Search.Sphinx.Configuration (Configuration(..), defaultConfig)
import qualified Text.Search.Sphinx.ExcerptConfiguration as ExConf (ExcerptConfiguration(..))
import Text.Search.Sphinx.Get (times, getResult, readHeader, getStr, getTxt)
import Text.Search.Sphinx.Put (num, num64, float, enum, list, numC, strC, foldPuts,
                              numC64, stringIntList, str, txt, cmd, verCmd)

import Data.Binary.Put (Put, runPut)
import Data.Binary.Get (runGet, getWord32be)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS8
import Data.Int (Int64)

import qualified Network.Simple.TCP as TCP
import System.IO (Handle, hFlush)
import Data.Bits ((.|.))

import Prelude hiding (filter, tail)
import Data.List (nub)

import Data.Text (Text)
import qualified Data.Text as X
import qualified Data.Text.ICU.Convert as ICU

import Control.Monad.Catch ( MonadMask )
import Control.Monad.IO.Class ( MonadIO )

{- the funnest way to debug this is to run the same query with an existing working client and look at the difference
 - sudo tcpflow -i lo dst port 9306 
import Debug.Trace; debug a = trace (show a) a
-}

escapedChars :: String
escapedChars :: [Char]
escapedChars =  Char
'"'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Char
'\\'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
"-!@~/()*[]="

-- | Escape all possible meta characters.
--   Most of these characters only need to be escaped in certain contexts
--   however, in normal searching they will all be ignored
escapeText :: Text -> Text
escapeText :: Text -> Text
escapeText = Text -> [Text] -> Text
X.intercalate Text
"\\" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
breakBy (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
escapedChars)
    where breakBy :: (Char -> Bool) -> Text -> [Text]
breakBy Char -> Bool
p Text
t | Text -> Bool
X.null Text
t  = [Text
X.empty]
                      | Bool
otherwise = (if Char -> Bool
p (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Char
Text -> Char
X.head Text
t then (Text
""Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) else [Text] -> [Text]
forall a. a -> a
id) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Char -> Char -> Bool) -> Text -> [Text]
X.groupBy (\Char
_ Char
x -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
p Char
x) Text
t

-- | The 'query' function runs a single query against the Sphinx daemon.
--   To pipeline multiple queries in a batch, use and 'runQueries'.
query :: Configuration -- ^ The configuration
      -> Text        -- ^ The indexes, \"*\" means every index
      -> Text        -- ^ The query string
      -> IO (T.Result T.QueryResult) -- ^ just one search result back
query :: Configuration -> Text -> Text -> IO (Result QueryResult)
query Configuration
config Text
indexes Text
search = do
    let q :: Query
q = Text -> Text -> Text -> Query
T.Query Text
search Text
indexes Text
X.empty
    Result [SingleResult]
results <- Configuration -> [Query] -> IO (Result [SingleResult])
runQueries' Configuration
config [Query
q]
    -- same as toSearchResult, but we know there is just one query
    -- could just remove and use runQueries in the future
    Result QueryResult -> IO (Result QueryResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result QueryResult -> IO (Result QueryResult))
-> Result QueryResult -> IO (Result QueryResult)
forall a b. (a -> b) -> a -> b
$ case Result [SingleResult]
results of
      T.Ok [SingleResult]
rs -> case [SingleResult] -> SingleResult
forall a. HasCallStack => [a] -> a
head [SingleResult]
rs of
                        T.QueryOk QueryResult
result        -> QueryResult -> Result QueryResult
forall a. a -> Result a
T.Ok QueryResult
result
                        T.QueryWarning Text
w QueryResult
result -> Text -> QueryResult -> Result QueryResult
forall a. Text -> a -> Result a
T.Warning Text
w QueryResult
result
                        T.QueryError Int
code Text
e     -> Int -> Text -> Result QueryResult
forall a. Int -> Text -> Result a
T.Error Int
code Text
e
      T.Error   Int
code Text
error      -> Int -> Text -> Result QueryResult
forall a. Int -> Text -> Result a
T.Error Int
code Text
error
      T.Retry   Text
retry           -> Text -> Result QueryResult
forall a. Text -> Result a
T.Retry Text
retry
      T.Warning Text
warning (SingleResult
result:[SingleResult]
results) -> case SingleResult
result of
                        T.QueryOk QueryResult
result        -> Text -> QueryResult -> Result QueryResult
forall a. Text -> a -> Result a
T.Warning Text
warning QueryResult
result
                        T.QueryWarning Text
w QueryResult
result -> Text -> QueryResult -> Result QueryResult
forall a. Text -> a -> Result a
T.Warning (Text -> Text -> Text
X.append Text
warning Text
w) QueryResult
result
                        T.QueryError Int
code Text
e     -> Int -> Text -> Result QueryResult
forall a. Int -> Text -> Result a
T.Error Int
code Text
e

-- | This is a convenience function which accepts a search string and
-- builds a query for that string over all indexes without attaching
-- comments to the queries.
simpleQuery :: Text  -- ^ The query string
            -> T.Query -- ^ A query value that can be sent to 'runQueries'
simpleQuery :: Text -> Query
simpleQuery Text
q = Text -> Text -> Text -> Query
T.Query Text
q Text
"*" Text
X.empty

withConnection :: (MonadIO m, MonadMask m, MonadFail m) => String -> Int -> (TCP.Socket -> m r) -> m r
withConnection :: forall (m :: * -> *) r.
(MonadIO m, MonadMask m, MonadFail m) =>
[Char] -> Int -> (Socket -> m r) -> m r
withConnection [Char]
host Int
port Socket -> m r
cont = [Char] -> [Char] -> ((Socket, SockAddr) -> m r) -> m r
forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
[Char] -> [Char] -> ((Socket, SockAddr) -> m r) -> m r
TCP.connect [Char]
host (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
port) (((Socket, SockAddr) -> m r) -> m r)
-> ((Socket, SockAddr) -> m r) -> m r
forall a b. (a -> b) -> a -> b
$ \(Socket
socket,SockAddr
_) -> do
  Just ByteString
bs <- Socket -> Int -> m (Maybe ByteString)
forall (m :: * -> *).
MonadIO m =>
Socket -> Int -> m (Maybe ByteString)
TCP.recv Socket
socket Int
4
  let version :: Word32
version   = Get Word32 -> ByteString -> Word32
forall a. Get a -> ByteString -> a
runGet Get Word32
getWord32be (ByteString -> Word32) -> ByteString -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.fromStrict ByteString
bs
      myVersion :: ByteString
myVersion = Put -> ByteString
runPut (Int -> Put
num Int
1)
  Socket -> ByteString -> m ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
TCP.send Socket
socket (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
myVersion
  Socket -> m r
cont Socket
socket

-- | TODO: add configuration options
buildExcerpts :: ExConf.ExcerptConfiguration -- ^ Contains host and port for connection and optional configuration for buildExcerpts
              -> [Text]               -- ^ list of document contents to be highlighted
              -> Text                 -- ^ The indexes, \"*\" means every index
              -> Text                  -- ^ The query string to use for excerpts
              -> IO (T.Result [Text]) -- ^ the documents with excerpts highlighted
buildExcerpts :: ExcerptConfiguration
-> [Text] -> Text -> Text -> IO (Result [Text])
buildExcerpts ExcerptConfiguration
config [Text]
docs Text
indexes Text
words = [Char]
-> Int -> (Socket -> IO (Result [Text])) -> IO (Result [Text])
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, MonadFail m) =>
[Char] -> Int -> (Socket -> m r) -> m r
withConnection (ExcerptConfiguration -> [Char]
ExConf.host ExcerptConfiguration
config) (ExcerptConfiguration -> Int
ExConf.port ExcerptConfiguration
config) ((Socket -> IO (Result [Text])) -> IO (Result [Text]))
-> (Socket -> IO (Result [Text])) -> IO (Result [Text])
forall a b. (a -> b) -> a -> b
$ \Socket
conn -> do
  Converter
conv <- [Char] -> Maybe Bool -> IO Converter
ICU.open (ExcerptConfiguration -> [Char]
ExConf.encoding ExcerptConfiguration
config) Maybe Bool
forall a. Maybe a
Nothing
  let req :: ByteString
req = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> Put
makeBuildExcerpt (Converter -> Put
addExcerpt Converter
conv)
  Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
TCP.send Socket
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict ByteString
req
  (Status
status, ByteString
response) <- Socket -> IO (Status, ByteString)
getResponse Socket
conn
  case Status
status of
    Status
T.OK      -> Result [Text] -> IO (Result [Text])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [Text] -> IO (Result [Text]))
-> Result [Text] -> IO (Result [Text])
forall a b. (a -> b) -> a -> b
$ [Text] -> Result [Text]
forall a. a -> Result a
T.Ok (ByteString -> Converter -> [Text]
getResults ByteString
response Converter
conv)
    Status
T.WARNING -> Result [Text] -> IO (Result [Text])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [Text] -> IO (Result [Text]))
-> Result [Text] -> IO (Result [Text])
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Result [Text]
forall a. Text -> a -> Result a
T.Warning (Get Text -> ByteString -> Text
forall a. Get a -> ByteString -> a
runGet (Converter -> Get Text
getTxt Converter
conv) ByteString
response) (ByteString -> Converter -> [Text]
getResults ByteString
response Converter
conv)
    Status
T.RETRY   -> Result [Text] -> IO (Result [Text])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [Text] -> IO (Result [Text]))
-> Result [Text] -> IO (Result [Text])
forall a b. (a -> b) -> a -> b
$ Text -> Result [Text]
forall a. Text -> Result a
T.Retry (Converter -> ByteString -> Text
errorMessage Converter
conv ByteString
response)
    T.ERROR Int
n -> Result [Text] -> IO (Result [Text])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [Text] -> IO (Result [Text]))
-> Result [Text] -> IO (Result [Text])
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Result [Text]
forall a. Int -> Text -> Result a
T.Error Int
n (Converter -> ByteString -> Text
errorMessage Converter
conv ByteString
response)
  where
    getResults :: ByteString -> Converter -> [Text]
getResults ByteString
response Converter
conv = Get [Text] -> ByteString -> [Text]
forall a. Get a -> ByteString -> a
runGet (([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
docs) Int -> Get Text -> Get [Text]
forall {a}. Int -> Get a -> Get [a]
`times` Converter -> Get Text
getTxt Converter
conv) ByteString
response
    errorMessage :: Converter -> ByteString -> Text
errorMessage Converter
conv ByteString
response = Get Text -> ByteString -> Text
forall a. Get a -> ByteString -> a
runGet (Converter -> Get Text
getTxt Converter
conv) ByteString
response

    makeBuildExcerpt :: Put -> Put
makeBuildExcerpt Put
putExcerpt = do
      SearchdCommand -> Put
cmd    SearchdCommand
T.ScExcerpt
      VerCommand -> Put
verCmd VerCommand
T.VcExcerpt  
      Int -> Put
num (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a. Enum a => a -> Int
fromEnum (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BS.length (Put -> ByteString
runPut Put
putExcerpt)
      Put
putExcerpt

    addExcerpt :: ICU.Converter -> Put
    addExcerpt :: Converter -> Put
addExcerpt Converter
conv = do
      Int -> Put
num Int
0 -- mode
      Int -> Put
num (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ ExcerptConfiguration -> Int
excerptFlags ExcerptConfiguration
config
      Converter -> Text -> Put
txt Converter
conv Text
indexes
      Converter -> Text -> Put
txt Converter
conv Text
words
      ExcerptConfiguration -> [ExcerptConfiguration -> [Char]] -> Put
forall {t1 :: * -> *} {t2}.
Foldable t1 =>
t2 -> t1 (t2 -> [Char]) -> Put
strC ExcerptConfiguration
config [ExcerptConfiguration -> [Char]
ExConf.beforeMatch, ExcerptConfiguration -> [Char]
ExConf.afterMatch, ExcerptConfiguration -> [Char]
ExConf.chunkSeparator]
      ExcerptConfiguration -> [ExcerptConfiguration -> Int] -> Put
forall {t1 :: * -> *} {t2}.
Foldable t1 =>
t2 -> t1 (t2 -> Int) -> Put
numC ExcerptConfiguration
config [ExcerptConfiguration -> Int
ExConf.limit, ExcerptConfiguration -> Int
ExConf.around, ExcerptConfiguration -> Int
ExConf.limitPassages, ExcerptConfiguration -> Int
ExConf.limitWords, ExcerptConfiguration -> Int
ExConf.startPassageId]
      [Char] -> Put
str ([Char] -> Put) -> [Char] -> Put
forall a b. (a -> b) -> a -> b
$ ExcerptConfiguration -> [Char]
ExConf.htmlStripMode ExcerptConfiguration
config
#ifndef ONE_ONE_BETA
      [Char] -> Put
str ([Char] -> Put) -> [Char] -> Put
forall a b. (a -> b) -> a -> b
$ ExcerptConfiguration -> [Char]
ExConf.passageBoundary ExcerptConfiguration
config
#endif
      (Text -> Put) -> [Text] -> Put
forall {t :: * -> *} {a} {b}.
Foldable t =>
(a -> PutM b) -> t a -> Put
list (Converter -> Text -> Put
txt Converter
conv) [Text]
docs

    modeFlag :: ExConf.ExcerptConfiguration -> (ExConf.ExcerptConfiguration -> Bool) -> Int -> Int
    modeFlag :: ExcerptConfiguration
-> (ExcerptConfiguration -> Bool) -> Int -> Int
modeFlag ExcerptConfiguration
cfg ExcerptConfiguration -> Bool
setting Int
value = if ExcerptConfiguration -> Bool
setting ExcerptConfiguration
cfg then Int
value else Int
0

    excerptFlags :: ExConf.ExcerptConfiguration -> Int
    excerptFlags :: ExcerptConfiguration -> Int
excerptFlags ExcerptConfiguration
cfg = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Bits a => a -> a -> a
(.|.) Int
1 (((ExcerptConfiguration -> Bool, Int) -> Int)
-> [(ExcerptConfiguration -> Bool, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(ExcerptConfiguration -> Bool
s,Int
v) -> ExcerptConfiguration
-> (ExcerptConfiguration -> Bool) -> Int -> Int
modeFlag ExcerptConfiguration
cfg ExcerptConfiguration -> Bool
s Int
v) [
        (ExcerptConfiguration -> Bool
ExConf.exactPhrase,      Int
2 )
      , (ExcerptConfiguration -> Bool
ExConf.singlePassage,    Int
4 )
      , (ExcerptConfiguration -> Bool
ExConf.useBoundaries,    Int
8 )
      , (ExcerptConfiguration -> Bool
ExConf.weightOrder,     Int
16 )
      , (ExcerptConfiguration -> Bool
ExConf.queryMode,       Int
32 )
      , (ExcerptConfiguration -> Bool
ExConf.forceAllWords,   Int
64 )
      , (ExcerptConfiguration -> Bool
ExConf.loadFiles,      Int
128 )
      , (ExcerptConfiguration -> Bool
ExConf.allowEmpty,     Int
256 )
      ])


-- | Make multiple queries at once, using a list of 'T.Query'.
-- For a single query, just use the query method
-- Easier handling of query result than runQueries'
runQueries :: Configuration -> [T.Query] -> IO (T.Result [T.QueryResult])
runQueries :: Configuration -> [Query] -> IO (Result [QueryResult])
runQueries Configuration
cfg [Query]
qs = Configuration -> [Query] -> IO (Result [SingleResult])
runQueries' Configuration
cfg [Query]
qs IO (Result [SingleResult])
-> (Result [SingleResult] -> IO (Result [QueryResult]))
-> IO (Result [QueryResult])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result [QueryResult] -> IO (Result [QueryResult])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [QueryResult] -> IO (Result [QueryResult]))
-> (Result [SingleResult] -> Result [QueryResult])
-> Result [SingleResult]
-> IO (Result [QueryResult])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result [SingleResult] -> Result [QueryResult]
toSearchResult
  where
    --   with batched queries, each query can have an error code,
    --     regardless of the error code given for the entire batch
    --   in general there isn't a reason for a valid query to return an error or warning
    --   using this could make it harder to debug the situation at hand
    --   perform the following conveniences:
    --   * return an Error Result if any SingleResult has an Error status
    --   * pull out any inner warnings to the top level Warning Result
    --     - this compresses all warnings into one which making debugging harder
    toSearchResult :: T.Result [T.SingleResult] -> T.Result [T.QueryResult]
    toSearchResult :: Result [SingleResult] -> Result [QueryResult]
toSearchResult Result [SingleResult]
results =
        case Result [SingleResult]
results of
          T.Ok [SingleResult]
rs              -> [SingleResult] -> [QueryResult] -> Text -> Result [QueryResult]
fromOk [SingleResult]
rs [] Text
X.empty
          T.Warning Text
warning [SingleResult]
rs -> Text -> [SingleResult] -> [QueryResult] -> Result [QueryResult]
fromWarn Text
warning [SingleResult]
rs []
          T.Retry   Text
retry      -> Text -> Result [QueryResult]
forall a. Text -> Result a
T.Retry Text
retry
          T.Error   Int
code Text
error -> Int -> Text -> Result [QueryResult]
forall a. Int -> Text -> Result a
T.Error Int
code Text
error
      where
        fromOk :: [T.SingleResult] -> [T.QueryResult] -> Text -> T.Result [T.QueryResult]
        fromOk :: [SingleResult] -> [QueryResult] -> Text -> Result [QueryResult]
fromOk [] [QueryResult]
acc Text
warn | Text -> Bool
X.null Text
warn = [QueryResult] -> Result [QueryResult]
forall a. a -> Result a
T.Ok [QueryResult]
acc
                           | Bool
otherwise = Text -> [QueryResult] -> Result [QueryResult]
forall a. Text -> a -> Result a
T.Warning Text
warn [QueryResult]
acc
        fromOk (SingleResult
r:[SingleResult]
rs) [QueryResult]
acc Text
warn = case SingleResult
r of
          T.QueryOk QueryResult
result        -> [SingleResult] -> [QueryResult] -> Text -> Result [QueryResult]
fromOk [SingleResult]
rs ([QueryResult]
acc [QueryResult] -> [QueryResult] -> [QueryResult]
forall a. [a] -> [a] -> [a]
++ [QueryResult
result]) Text
warn
          T.QueryWarning Text
w QueryResult
result -> [SingleResult] -> [QueryResult] -> Text -> Result [QueryResult]
fromOk [SingleResult]
rs ([QueryResult]
acc [QueryResult] -> [QueryResult] -> [QueryResult]
forall a. [a] -> [a] -> [a]
++ [QueryResult
result]) (Text -> Text -> Text
X.append Text
warn Text
w)
          T.QueryError Int
code Text
e     -> Int -> Text -> Result [QueryResult]
forall a. Int -> Text -> Result a
T.Error Int
code Text
e

        fromWarn :: Text -> [T.SingleResult] -> [T.QueryResult] -> T.Result [T.QueryResult]
        fromWarn :: Text -> [SingleResult] -> [QueryResult] -> Result [QueryResult]
fromWarn Text
warning [] [QueryResult]
acc = Text -> [QueryResult] -> Result [QueryResult]
forall a. Text -> a -> Result a
T.Warning Text
warning [QueryResult]
acc
        fromWarn Text
warning (SingleResult
r:[SingleResult]
rs) [QueryResult]
acc = case SingleResult
r of
          T.QueryOk QueryResult
result        -> Text -> [SingleResult] -> [QueryResult] -> Result [QueryResult]
fromWarn Text
warning [SingleResult]
rs (QueryResult
resultQueryResult -> [QueryResult] -> [QueryResult]
forall a. a -> [a] -> [a]
:[QueryResult]
acc)
          T.QueryWarning Text
w QueryResult
result -> Text -> [SingleResult] -> [QueryResult] -> Result [QueryResult]
fromWarn (Text -> Text -> Text
X.append Text
warning Text
w) [SingleResult]
rs (QueryResult
resultQueryResult -> [QueryResult] -> [QueryResult]
forall a. a -> [a] -> [a]
:[QueryResult]
acc)
          T.QueryError Int
code Text
e     -> Int -> Text -> Result [QueryResult]
forall a. Int -> Text -> Result a
T.Error Int
code Text
e

-- | Lower level- called by 'runQueries'.
-- This may be useful for debugging problems- warning messages won't get compressed
runQueries' :: Configuration -> [T.Query] -> IO (T.Result [T.SingleResult])
runQueries' :: Configuration -> [Query] -> IO (Result [SingleResult])
runQueries' Configuration
config [Query]
qs = [Char]
-> Int
-> (Socket -> IO (Result [SingleResult]))
-> IO (Result [SingleResult])
forall (m :: * -> *) r.
(MonadIO m, MonadMask m, MonadFail m) =>
[Char] -> Int -> (Socket -> m r) -> m r
withConnection (Configuration -> [Char]
host Configuration
config) (Configuration -> Int
port Configuration
config) ((Socket -> IO (Result [SingleResult]))
 -> IO (Result [SingleResult]))
-> (Socket -> IO (Result [SingleResult]))
-> IO (Result [SingleResult])
forall a b. (a -> b) -> a -> b
$ \Socket
conn -> do
    Converter
conv <- [Char] -> Maybe Bool -> IO Converter
ICU.open (Configuration -> [Char]
encoding Configuration
config) Maybe Bool
forall a. Maybe a
Nothing
    let queryReq :: Put
queryReq = [Put] -> Put
foldPuts ([Put] -> Put) -> [Put] -> Put
forall a b. (a -> b) -> a -> b
$ (Query -> Put) -> [Query] -> [Put]
forall a b. (a -> b) -> [a] -> [b]
map (Configuration -> Converter -> Query -> Put
serializeQuery Configuration
config Converter
conv) [Query]
qs
    Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
TCP.send Socket
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
request Put
queryReq
    Socket -> Converter -> IO (Result [SingleResult])
getSearchResult Socket
conn Converter
conv
  where 
    numQueries :: Int
numQueries = [Query] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Query]
qs
    request :: Put -> ByteString
request Put
qr = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
                SearchdCommand -> Put
cmd SearchdCommand
T.ScSearch
                VerCommand -> Put
verCmd VerCommand
T.VcSearch
                Int -> Put
num (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ 
#ifdef ONE_ONE_BETA
                      4
#else
                      Int
8
#endif
                        Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int64 -> Int
forall a. Enum a => a -> Int
fromEnum (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BS.length (Put -> ByteString
runPut Put
qr))
#ifndef ONE_ONE_BETA
                Int -> Put
num Int
0
#endif
                Int -> Put
num Int
numQueries
                Put
qr

    getSearchResult :: TCP.Socket -> ICU.Converter -> IO (T.Result [T.SingleResult])
    getSearchResult :: Socket -> Converter -> IO (Result [SingleResult])
getSearchResult Socket
conn Converter
conv = do
      (Status
status, ByteString
response) <- Socket -> IO (Status, ByteString)
getResponse Socket
conn
      case Status
status of
        Status
T.OK      -> Result [SingleResult] -> IO (Result [SingleResult])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [SingleResult] -> IO (Result [SingleResult]))
-> Result [SingleResult] -> IO (Result [SingleResult])
forall a b. (a -> b) -> a -> b
$ [SingleResult] -> Result [SingleResult]
forall a. a -> Result a
T.Ok (ByteString -> Converter -> [SingleResult]
getResults ByteString
response Converter
conv)
        Status
T.WARNING -> Result [SingleResult] -> IO (Result [SingleResult])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [SingleResult] -> IO (Result [SingleResult]))
-> Result [SingleResult] -> IO (Result [SingleResult])
forall a b. (a -> b) -> a -> b
$ Text -> [SingleResult] -> Result [SingleResult]
forall a. Text -> a -> Result a
T.Warning (Get Text -> ByteString -> Text
forall a. Get a -> ByteString -> a
runGet (Converter -> Get Text
getTxt Converter
conv) ByteString
response) (ByteString -> Converter -> [SingleResult]
getResults ByteString
response Converter
conv)
        Status
T.RETRY   -> Result [SingleResult] -> IO (Result [SingleResult])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [SingleResult] -> IO (Result [SingleResult]))
-> Result [SingleResult] -> IO (Result [SingleResult])
forall a b. (a -> b) -> a -> b
$ Text -> Result [SingleResult]
forall a. Text -> Result a
T.Retry (Converter -> ByteString -> Text
errorMessage Converter
conv ByteString
response)
        T.ERROR Int
n -> Result [SingleResult] -> IO (Result [SingleResult])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result [SingleResult] -> IO (Result [SingleResult]))
-> Result [SingleResult] -> IO (Result [SingleResult])
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Result [SingleResult]
forall a. Int -> Text -> Result a
T.Error Int
n (Converter -> ByteString -> Text
errorMessage Converter
conv ByteString
response)
      where
        getResults :: ByteString -> Converter -> [SingleResult]
getResults ByteString
response Converter
conv = Get [SingleResult] -> ByteString -> [SingleResult]
forall a. Get a -> ByteString -> a
runGet (Int
numQueries Int -> Get SingleResult -> Get [SingleResult]
forall {a}. Int -> Get a -> Get [a]
`times` Converter -> Get SingleResult
getResult Converter
conv) ByteString
response
        errorMessage :: Converter -> ByteString -> Text
errorMessage Converter
conv ByteString
response = Get Text -> ByteString -> Text
forall a. Get a -> ByteString -> a
runGet (Converter -> Get Text
getTxt Converter
conv) ByteString
response


-- | Combine results from 'runQueries' into matches.
resultsToMatches :: Int -> [T.QueryResult] -> [T.Match]
resultsToMatches :: Int -> [QueryResult] -> [Match]
resultsToMatches Int
maxResults = [QueryResult] -> [Match]
combine
  where
    combine :: [QueryResult] -> [Match]
combine [] = []
    combine (QueryResult
r:[QueryResult]
rs)
        | QueryResult -> Int
T.totalFound QueryResult
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxResults = QueryResult -> [Match]
T.matches QueryResult
r
        | QueryResult -> Int
T.totalFound QueryResult
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0          = [QueryResult] -> [Match]
combine [QueryResult]
rs
        | Bool
otherwise                          = [QueryResult] -> [Match]
takeResults (QueryResult
rQueryResult -> [QueryResult] -> [QueryResult]
forall a. a -> [a] -> [a]
:[QueryResult]
rs)
    takeResults :: [T.QueryResult] -> [T.Match]
    takeResults :: [QueryResult] -> [Match]
takeResults = Int -> [Match] -> [Match]
forall a. Int -> [a] -> [a]
take Int
maxResults ([Match] -> [Match])
-> ([QueryResult] -> [Match]) -> [QueryResult] -> [Match]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Match] -> [Match]
forall a. Eq a => [a] -> [a]
nub ([Match] -> [Match])
-> ([QueryResult] -> [Match]) -> [QueryResult] -> [Match]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Match] -> [Match] -> [Match]) -> [[Match]] -> [Match]
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 [Match] -> [Match] -> [Match]
forall a. [a] -> [a] -> [a]
(++) ([[Match]] -> [Match])
-> ([QueryResult] -> [[Match]]) -> [QueryResult] -> [Match]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QueryResult -> [Match]) -> [QueryResult] -> [[Match]]
forall a b. (a -> b) -> [a] -> [b]
map QueryResult -> [Match]
T.matches


-- | executes 'runQueries'. Log warning and errors, automatically retry.
-- Return a Nothing on error, otherwise a Just.
maybeQueries :: (Text -> IO ()) -> Configuration -> [T.Query] -> IO (Maybe [T.QueryResult])
maybeQueries :: (Text -> IO ())
-> Configuration -> [Query] -> IO (Maybe [QueryResult])
maybeQueries Text -> IO ()
logCallback Configuration
conf [Query]
queries = do
  Result [QueryResult]
result <- Configuration -> [Query] -> IO (Result [QueryResult])
runQueries Configuration
conf [Query]
queries
  case Result [QueryResult]
result of
    T.Ok [QueryResult]
r           -> Maybe [QueryResult] -> IO (Maybe [QueryResult])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([QueryResult] -> Maybe [QueryResult]
forall a. a -> Maybe a
Just [QueryResult]
r)
    T.Retry Text
msg      -> Text -> IO ()
logCallback Text
msg  IO () -> IO (Maybe [QueryResult]) -> IO (Maybe [QueryResult])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Text -> IO ())
-> Configuration -> [Query] -> IO (Maybe [QueryResult])
maybeQueries Text -> IO ()
logCallback Configuration
conf [Query]
queries
    T.Warning Text
w [QueryResult]
r    -> Text -> IO ()
logCallback Text
w    IO () -> IO (Maybe [QueryResult]) -> IO (Maybe [QueryResult])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [QueryResult] -> IO (Maybe [QueryResult])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([QueryResult] -> Maybe [QueryResult]
forall a. a -> Maybe a
Just [QueryResult]
r)
    T.Error Int
code Text
msg ->
      Text -> IO ()
logCallback ([Text] -> Text
X.concat [Text
"Error code ",[Char] -> Text
X.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
code,Text
". ",Text
msg]) IO () -> IO (Maybe [QueryResult]) -> IO (Maybe [QueryResult])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [QueryResult] -> IO (Maybe [QueryResult])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [QueryResult]
forall a. Maybe a
Nothing

getResponse :: TCP.Socket -> IO (T.Status, BS.ByteString)
getResponse :: Socket -> IO (Status, ByteString)
getResponse Socket
conn = do
  Just ByteString
header <- Socket -> Int -> IO (Maybe ByteString)
forall (m :: * -> *).
MonadIO m =>
Socket -> Int -> m (Maybe ByteString)
TCP.recv Socket
conn Int
8
  let (Status
status, Word16
version, Word32
len) = ByteString -> (Status, Word16, Word32)
readHeader (ByteString -> (Status, Word16, Word32))
-> ByteString -> (Status, Word16, Word32)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.fromStrict ByteString
header
  if Word32
len Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0
    then [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"received zero-sized searchd response (bad query?)"
    else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Just ByteString
response <- Socket -> Int -> IO (Maybe ByteString)
forall (m :: * -> *).
MonadIO m =>
Socket -> Int -> m (Maybe ByteString)
TCP.recv Socket
conn (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len)
  (Status, ByteString) -> IO (Status, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Status
status, ByteString -> ByteString
BS.fromStrict ByteString
response)

-- | use with runQueries to pipeline a batch of queries
serializeQuery :: Configuration -> ICU.Converter -> T.Query -> Put
serializeQuery :: Configuration -> Converter -> Query -> Put
serializeQuery Configuration
cfg Converter
conv (T.Query Text
qry Text
indexes Text
comment) = do
    Configuration -> [Configuration -> Int] -> Put
forall {t1 :: * -> *} {t2}.
Foldable t1 =>
t2 -> t1 (t2 -> Int) -> Put
numC Configuration
cfg [ Configuration -> Int
offset
             , Configuration -> Int
limit
             , MatchMode -> Int
forall a. Enum a => a -> Int
fromEnum (MatchMode -> Int)
-> (Configuration -> MatchMode) -> Configuration -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> MatchMode
mode
             , Rank -> Int
forall a. Enum a => a -> Int
fromEnum (Rank -> Int) -> (Configuration -> Rank) -> Configuration -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Configuration -> Rank
ranker
             ]
    case Configuration -> Rank
ranker Configuration
cfg of
      Rank
RankExpr -> [Char] -> Put
str (Configuration -> [Char]
rankExpr Configuration
cfg)
      Rank
_        -> () -> Put
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    Int -> Put
num (Sort -> Int
forall a. Enum a => a -> Int
fromEnum (Configuration -> Sort
sort Configuration
cfg))
    [Char] -> Put
str (Configuration -> [Char]
sortBy Configuration
cfg)
    Converter -> Text -> Put
txt Converter
conv Text
qry
    (Int -> Put) -> [Int] -> Put
forall {t :: * -> *} {a} {b}.
Foldable t =>
(a -> PutM b) -> t a -> Put
list Int -> Put
num (Configuration -> [Int]
weights Configuration
cfg)
    Converter -> Text -> Put
txt Converter
conv Text
indexes
    Int -> Put
num Int
1                     -- id64 range marker
    Configuration -> [Configuration -> Int] -> Put
forall {t1 :: * -> *} {a} {t2}.
(Foldable t1, Integral a) =>
t2 -> t1 (t2 -> a) -> Put
numC64 Configuration
cfg [Configuration -> Int
minId, Configuration -> Int
maxId] -- id64 range

    (Filter -> Put) -> [Filter] -> Put
forall {t :: * -> *} {a} {b}.
Foldable t =>
(a -> PutM b) -> t a -> Put
list Filter -> Put
putFilter (Configuration -> [Filter]
filters Configuration
cfg)

    GroupByFunction -> Put
forall a. Enum a => a -> Put
enum (Configuration -> GroupByFunction
groupByFunc   Configuration
cfg)
    [Char] -> Put
str  (Configuration -> [Char]
groupBy       Configuration
cfg)
    Int -> Put
num  (Configuration -> Int
maxMatches    Configuration
cfg)
    [Char] -> Put
str  (Configuration -> [Char]
groupSort     Configuration
cfg)
    Int -> Put
num  (Configuration -> Int
cutoff        Configuration
cfg)
    Int -> Put
num  (Configuration -> Int
retryCount    Configuration
cfg)
    Int -> Put
num  (Configuration -> Int
retryDelay    Configuration
cfg)
    [Char] -> Put
str  (Configuration -> [Char]
groupDistinct Configuration
cfg)
    Int -> Put
num Int
0 -- anchor point for setGeoAnchor
    [([Char], Int)] -> Put
stringIntList (Configuration -> [([Char], Int)]
indexWeights Configuration
cfg)
    Int -> Put
num (Configuration -> Int
maxQueryTime Configuration
cfg)
    [([Char], Int)] -> Put
stringIntList (Configuration -> [([Char], Int)]
fieldWeights Configuration
cfg)
    Converter -> Text -> Put
txt Converter
conv Text
comment
    Int -> Put
num Int
0 -- attribute overrides (none)
    [Char] -> Put
str (Configuration -> [Char]
selectClause Configuration
cfg) -- select-list
    where
      {- Not working properly -}
      putFilter :: T.Filter -> Put
      putFilter :: Filter -> Put
putFilter (T.ExclusionFilter Filter
filter) = Filter -> Bool -> Put
forall {a}. Enum a => Filter -> a -> Put
putFilter_ Filter
filter Bool
True
      putFilter Filter
filter                     = Filter -> Bool -> Put
forall {a}. Enum a => Filter -> a -> Put
putFilter_ Filter
filter Bool
False

      putFilter_ :: Filter -> a -> Put
putFilter_ f :: Filter
f@(T.FilterValues [Char]
attr [Int64]
values)  a
ex = Filter -> [Char] -> ([Int64] -> Put) -> [[Int64]] -> a -> Put
forall {t :: * -> *} {a} {a} {b}.
(Foldable t, Enum a) =>
Filter -> [Char] -> (a -> PutM b) -> t a -> a -> Put
putFilter__ Filter
f [Char]
attr ((Int64 -> Put) -> [Int64] -> Put
forall {t :: * -> *} {a} {b}.
Foldable t =>
(a -> PutM b) -> t a -> Put
list Int64 -> Put
forall {a}. Integral a => a -> Put
num64) [[Int64]
values] a
ex
      putFilter_ f :: Filter
f@(T.FilterRange  [Char]
attr Int64
min Int64
max) a
ex = Filter -> [Char] -> (Int64 -> Put) -> [Int64] -> a -> Put
forall {t :: * -> *} {a} {a} {b}.
(Foldable t, Enum a) =>
Filter -> [Char] -> (a -> PutM b) -> t a -> a -> Put
putFilter__ Filter
f [Char]
attr Int64 -> Put
forall {a}. Integral a => a -> Put
num64 [Int64
min, Int64
max] a
ex
      putFilter_ f :: Filter
f@(T.FilterFloatRange  [Char]
attr Float
min Float
max) a
ex = Filter -> [Char] -> (Float -> Put) -> [Float] -> a -> Put
forall {t :: * -> *} {a} {a} {b}.
(Foldable t, Enum a) =>
Filter -> [Char] -> (a -> PutM b) -> t a -> a -> Put
putFilter__ Filter
f [Char]
attr Float -> Put
float [Float
min, Float
max] a
ex

      putFilter__ :: Filter -> [Char] -> (a -> PutM b) -> t a -> a -> Put
putFilter__ Filter
filter [Char]
attr a -> PutM b
puter t a
values a
exclude = do
        [Char] -> Put
str [Char]
attr
        Int -> Put
num (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ Filter -> Int
forall {a}. Num a => Filter -> a
T.fromEnumFilter Filter
filter
        (a -> PutM b) -> t a -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> PutM b
puter t a
values
        Int -> Put
num (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum a
exclude

{- weren't working properly, should try out on latest version now
setFilter :: Configuration -> String -> [Int64] -> Bool -> Configuration
setFilter cfg attr values exclude =
  let f = (T.FilterValues attr values)
  in  addFilter cfg (if exclude then T.ExclusionFilter f else f)

setFilterRange :: Configuration -> String -> Int64 -> Int64 -> Bool -> Configuration
setFilterRange cfg attr min max exclude =
  let f = (T.FilterRange attr min max)
  in  addFilter cfg (if exclude then T.ExclusionFilter f else f)

--setFilterFloatRange :: Configuration -> String -> Float -> Float -> Bool -> Configuration
--setFilterFloatRange cfg attr min max exclude =
  --let f = (T.FilterFloatRange attr min max)
  --in  addFilter cfg (if exclude then T.ExclusionFilter f else f)

-- | alternative interface to setFilter* using Filter constructors
addFilter :: Configuration -> T.Filter -> Configuration
addFilter cfg filter = cfg { filters = filter : (filters cfg) }
  -}