module Solr.Search
( SearchType(..)
, SearchQuery(..)
, search
) where
import Control.Arrow (first)
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import Data.Char (isAlphaNum)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Client as HC
import Network.HTTP.Types.URI (renderSimpleQuery)
import Data.ByteString.Builder.Escape (escapeLazyByteStringCharsWith, escapeTextWith)
import Has
import Model.Paginate
import Model.Metric.Types
import Solr.Service
import Solr.Document
data SearchType
= SearchVolumes
| SearchParties
deriving (Eq)
data SearchQuery = SearchQuery
{ searchString :: Maybe T.Text
, searchFields :: [(T.Text, T.Text)]
, searchMetrics :: [(Metric, T.Text)]
, searchType :: SearchType
, searchPaginate :: !Paginate
}
checkTerm :: T.Text -> Bool
checkTerm = cq False [] . T.unpack where
cq False [] "" = True
cq q g ('"':s) = cq (not q) g s
cq q g ('\\':_:s) = cq q g s
cq _ _ ['\\'] = False
cq False ('(':gs) (')':s) = cq False gs s
cq False ('[':gs) (']':s) = cq False gs s
cq False ('[':gs) ('}':s) = cq False gs s
cq False ('{':gs) (']':s) = cq False gs s
cq False ('{':gs) ('}':s) = cq False gs s
cq False g (c:s)
| c `elem` ['(','[','{'] = cq False (c:g) s
| c `elem` [')',']','}'] = False
cq q g (_:s) = cq q g s
cq _ _ _ = False
checkField :: T.Text -> Bool
checkField = T.all cc where
cc '_' = True
cc c = isAlphaNum c
quoteQuery :: (Char -> String -> a -> B.Builder) -> a -> B.Builder
quoteQuery e s = B.char8 '"' <> e '\\' "\"\\" s <> B.char8 '"'
defaultParams :: B.Builder
defaultParams = B.string8 "{!dismax qf=\"text_en^0.5 text_gen^0.5 keyword^2 tag_name party_name\" pf=\"keyword^2 tag_name party_name\" ps=3}"
search :: MonadSolr c m => SearchQuery -> m (HC.Response BSL.ByteString)
search SearchQuery{..} = do
req <- peeks solrRequest
focusIO $ HC.httpLbs req
{ HC.path = HC.path req <> "search"
, HC.queryString = renderSimpleQuery True query
, HC.checkResponse = \_ _ -> putStrLn "Search Error"
}
where
query =
[ ("q", BSL.toStrict $ B.toLazyByteString $ qp <> uw ql)
, ("fq", "content_type:" <> ct)
, ("start", BSC.pack $ show $ paginateOffset searchPaginate)
, ("rows", BSC.pack $ show $ paginateLimit searchPaginate)
, ("q.op", "AND")
]
++ maybe [] (\q ->
[ ("spellcheck", "true")
, ("spellcheck.q", TE.encodeUtf8 q)
]) searchString
(ct, qp, qe) = case searchType of
SearchVolumes -> ("volume", mempty, B.string8 "{!join from=volume_id to=volume_id}")
SearchParties -> ("party", mempty, mempty)
ql = maybe id ((:) . bp . (defaultParams <>) . TE.encodeUtf8Builder) searchString $
map bt (searchFields ++ map (first metricField) searchMetrics)
bt (f, v)
| checkField f && checkTerm v = bp (TE.encodeUtf8Builder f <> B.string8 ":(" <> (if T.null v then B.char8 '*' else TE.encodeUtf8Builder v) <> B.char8 ')')
| otherwise = bp (B.string8 "{!dismax qf=" <> quoteQuery escapeTextWith f <> B.char8 '}' <> TE.encodeUtf8Builder v)
bp v = B.string8 "_query_:" <> quoteQuery escapeLazyByteStringCharsWith (B.toLazyByteString $ qe <> v)
uw [] = B.string8 "*:*"
uw (t:l) = t <> foldMap (B.char8 ' ' <>) l