Merge pull request #182 from bermanjosh/suggest

Support for 'Suggesters' and 'Template Queries'
This commit is contained in:
Chris Allen 2017-05-30 20:41:41 -06:00 committed by GitHub
commit 79b4f90163
7 changed files with 620 additions and 22 deletions

View File

@ -861,17 +861,17 @@ scanSearch indexName mappingName search = do
-- syntax if you want to add things like aggregations or highlights while still using
-- this helper function.
mkSearch :: Maybe Query -> Maybe Filter -> Search
mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
-- the 'Query' and the 'Aggregation'.
mkAggregateSearch :: Maybe Query -> Aggregations -> Search
mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing
mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing Nothing
-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
-- the 'Query' and the 'Aggregation'.
mkHighlightSearch :: Maybe Query -> Highlights -> Search
mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
-- | 'pageSearch' is a helper function that takes a search and assigns the from
-- and size fields for the search. The from parameter defines the offset

View File

@ -195,6 +195,8 @@ module Database.V1.Bloodhound.Types
, RangeQuery(..)
, RegexpQuery(..)
, QueryString(..)
, TemplateQueryInline(..)
, TemplateQueryKeyValuePairs(..)
, BooleanOperator(..)
, ZeroTermsQuery(..)
, CutoffFrequency(..)
@ -322,6 +324,15 @@ module Database.V1.Bloodhound.Types
, rrGroupRefNum
, mkRRGroupRefNum
, RestoreIndexSettings(..)
, Suggest(..)
, SuggestType(..)
, PhraseSuggester(..)
, PhraseSuggesterHighlighter(..)
, PhraseSuggesterCollate(..)
, mkPhraseSuggester
, SuggestOptions(..)
, SuggestResponse(..)
, NamedSuggestionResponse(..)
, Aggregation(..)
, Aggregations
@ -376,7 +387,8 @@ import Control.Monad.Writer (MonadWriter)
import Data.Aeson
import Data.Aeson.Types (Pair, Parser,
emptyObject,
parseEither, parseMaybe)
parseEither, parseMaybe,
typeMismatch)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Char
import Data.Hashable (Hashable)
@ -1091,7 +1103,7 @@ unpackId (DocId docId) = docId
type TrackSortScores = Bool
newtype From = From Int deriving (Eq, Read, Show, Generic, ToJSON)
newtype Size = Size Int deriving (Eq, Read, Show, Generic, ToJSON)
newtype Size = Size Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
data Search = Search { queryBody :: Maybe Query
, filterBody :: Maybe Filter
@ -1104,7 +1116,9 @@ data Search = Search { queryBody :: Maybe Query
, size :: Size
, searchType :: SearchType
, fields :: Maybe [FieldName]
, source :: Maybe Source } deriving (Eq, Read, Show, Generic, Typeable)
, source :: Maybe Source
, suggestBody :: Maybe Suggest -- ^ Only one Suggestion request / response per Search is supported.
} deriving (Eq, Read, Show, Generic, Typeable)
data SearchType = SearchTypeQueryThenFetch
| SearchTypeDfsQueryThenFetch
@ -1211,6 +1225,7 @@ data Query =
| QuerySimpleQueryStringQuery SimpleQueryStringQuery
| QueryRangeQuery RangeQuery
| QueryRegexpQuery RegexpQuery
| QueryTemplateQueryInline TemplateQueryInline
deriving (Eq, Read, Show, Generic, Typeable)
data RegexpQuery =
@ -1635,13 +1650,48 @@ data DistanceRange =
DistanceRange { distanceFrom :: Distance
, distanceTo :: Distance } deriving (Eq, Read, Show, Generic, Typeable)
type TemplateQueryKey = Text
type TemplateQueryValue = Text
newtype TemplateQueryKeyValuePairs = TemplateQueryKeyValuePairs (HM.HashMap TemplateQueryKey TemplateQueryValue)
deriving (Eq, Read, Show, Generic, Typeable)
instance ToJSON TemplateQueryKeyValuePairs where
toJSON (TemplateQueryKeyValuePairs x) = Object $ HM.map toJSON x
instance FromJSON TemplateQueryKeyValuePairs where
parseJSON (Object o) = pure . TemplateQueryKeyValuePairs $ HM.mapMaybe getValue o
where getValue (String x) = Just x
getValue _ = Nothing
parseJSON _ = fail "error parsing TemplateQueryKeyValuePairs"
data TemplateQueryInline =
TemplateQueryInline { inline :: Query
, params :: TemplateQueryKeyValuePairs
}
deriving (Eq, Read, Show, Generic, Typeable)
instance ToJSON TemplateQueryInline where
toJSON TemplateQueryInline{..} = object [ "query" .= inline
, "params" .= params
]
instance FromJSON TemplateQueryInline where
parseJSON = withObject "TemplateQueryInline" parse
where parse o = TemplateQueryInline
<$> o .: "query"
<*> o .: "params"
data SearchResult a =
SearchResult { took :: Int
, timedOut :: Bool
, shards :: ShardResult
, searchHits :: SearchHits a
, aggregations :: Maybe AggregationResults
, scrollId :: Maybe ScrollId } deriving (Eq, Read, Show, Generic, Typeable)
, scrollId :: Maybe ScrollId
, suggest :: Maybe NamedSuggestionResponse -- ^ Only one Suggestion request / response per Search is supported.
}
deriving (Eq, Read, Show, Generic, Typeable)
newtype ScrollId = ScrollId Text deriving (Eq, Read, Show, Generic, Ord, ToJSON, FromJSON)
@ -2404,6 +2454,9 @@ instance ToJSON Query where
toJSON (QuerySimpleQueryStringQuery query) =
object [ "simple_query_string" .= query ]
toJSON (QueryTemplateQueryInline templateQuery) =
object [ "template" .= templateQuery ]
instance FromJSON Query where
parseJSON v = withObject "Query" parse v
where parse o = termQuery `taggedWith` "term"
@ -2433,6 +2486,7 @@ instance FromJSON Query where
<|> queryRangeQuery `taggedWith` "range"
<|> queryRegexpQuery `taggedWith` "regexp"
<|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"
<|> queryTemplateQueryInline `taggedWith` "template"
where taggedWith parser k = parser =<< o .: k
termQuery = fieldTagged $ \(FieldName fn) o ->
TermQuery <$> (Term fn <$> o .: "value") <*> o .:? "boost"
@ -2474,6 +2528,7 @@ instance FromJSON Query where
queryRangeQuery = pure . QueryRangeQuery
queryRegexpQuery = pure . QueryRegexpQuery
querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery
queryTemplateQueryInline = pure . QueryTemplateQueryInline
omitNulls :: [(Text, Value)] -> Value
@ -3412,7 +3467,7 @@ instance FromJSON SearchAliasRouting where
where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)
instance ToJSON Search where
toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _ sFields sSource) =
toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _ sFields sSource sSuggest) =
omitNulls [ "query" .= query
, "filter" .= sFilter
, "sort" .= sort
@ -3422,7 +3477,8 @@ instance ToJSON Search where
, "size" .= sSize
, "track_scores" .= sTrackSortScores
, "fields" .= sFields
, "_source" .= sSource]
, "_source" .= sSource
, "suggest" .= sSuggest]
instance ToJSON Source where
@ -3772,7 +3828,8 @@ instance (FromJSON a) => FromJSON (SearchResult a) where
v .: "_shards" <*>
v .: "hits" <*>
v .:? "aggregations" <*>
v .:? "_scroll_id"
v .:? "_scroll_id" <*>
v .:? "suggest"
parseJSON _ = empty
instance (FromJSON a) => FromJSON (SearchHits a) where
@ -5277,3 +5334,179 @@ newtype MaybeNA a = MaybeNA { unMaybeNA :: Maybe a }
instance FromJSON a => FromJSON (MaybeNA a) where
parseJSON (String "NA") = pure $ MaybeNA Nothing
parseJSON o = MaybeNA . Just <$> parseJSON o
data Suggest = Suggest { suggestText :: Text
, suggestName :: Text
, suggestType :: SuggestType
}
deriving (Show, Generic, Eq, Read, Typeable)
instance ToJSON Suggest where
toJSON Suggest{..} = object [ "text" .= suggestText
, suggestName .= suggestType
]
instance FromJSON Suggest where
parseJSON (Object o) = do
suggestText' <- o .: "text"
let dropTextList = HM.toList $ HM.filterWithKey (\x _ -> x /= "text") o
suggestName' <- case dropTextList of
[(x, _)] -> return x
_ -> fail "error parsing Suggest field name"
suggestType' <- o .: suggestName'
return $ Suggest suggestText' suggestName' suggestType'
parseJSON x = typeMismatch "Suggest" x
data SuggestType = SuggestTypePhraseSuggester PhraseSuggester
deriving (Show, Generic, Eq, Read, Typeable)
instance ToJSON SuggestType where
toJSON (SuggestTypePhraseSuggester x) = object ["phrase" .= x]
instance FromJSON SuggestType where
parseJSON = withObject "SuggestType" parse
where parse o = phraseSuggester `taggedWith` "phrase"
where taggedWith parser k = parser =<< o .: k
phraseSuggester = pure . SuggestTypePhraseSuggester
data PhraseSuggester =
PhraseSuggester { phraseSuggesterField :: FieldName
, phraseSuggesterGramSize :: Maybe Int
, phraseSuggesterRealWordErrorLikelihood :: Maybe Int
, phraseSuggesterConfidence :: Maybe Int
, phraseSuggesterMaxErrors :: Maybe Int
, phraseSuggesterSeparator :: Maybe Text
, phraseSuggesterSize :: Maybe Size
, phraseSuggesterAnalyzer :: Maybe Analyzer
, phraseSuggesterShardSize :: Maybe Int
, phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
, phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
}
deriving (Show, Generic, Eq, Read, Typeable)
instance ToJSON PhraseSuggester where
toJSON PhraseSuggester{..} = omitNulls [ "field" .= phraseSuggesterField
, "gram_size" .= phraseSuggesterGramSize
, "real_word_error_likelihood" .= phraseSuggesterRealWordErrorLikelihood
, "confidence" .= phraseSuggesterConfidence
, "max_errors" .= phraseSuggesterMaxErrors
, "separator" .= phraseSuggesterSeparator
, "size" .= phraseSuggesterSize
, "analyzer" .= phraseSuggesterAnalyzer
, "shard_size" .= phraseSuggesterShardSize
, "highlight" .= phraseSuggesterHighlight
, "collate" .= phraseSuggesterCollate
]
instance FromJSON PhraseSuggester where
parseJSON = withObject "PhraseSuggester" parse
where parse o = PhraseSuggester
<$> o .: "field"
<*> o .:? "gram_size"
<*> o .:? "real_word_error_likelihood"
<*> o .:? "confidence"
<*> o .:? "max_errors"
<*> o .:? "separator"
<*> o .:? "size"
<*> o .:? "analyzer"
<*> o .:? "shard_size"
<*> o .:? "highlight"
<*> o .:? "collate"
mkPhraseSuggester :: FieldName -> PhraseSuggester
mkPhraseSuggester fName =
PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
data PhraseSuggesterHighlighter =
PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
, phraseSuggesterHighlighterPostTag :: Text
}
deriving (Show, Generic, Eq, Read, Typeable)
instance ToJSON PhraseSuggesterHighlighter where
toJSON PhraseSuggesterHighlighter{..} =
object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
, "post_tag" .= phraseSuggesterHighlighterPostTag
]
instance FromJSON PhraseSuggesterHighlighter where
parseJSON = withObject "PhraseSuggesterHighlighter" parse
where parse o = PhraseSuggesterHighlighter
<$> o .: "pre_tag"
<*> o .: "post_tag"
data PhraseSuggesterCollate =
PhraseSuggesterCollate { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
, phraseSuggesterCollatePrune :: Bool
}
deriving (Show, Generic, Eq, Read, Typeable)
instance ToJSON PhraseSuggesterCollate where
toJSON PhraseSuggesterCollate{..} = object [ "query" .= object
[ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
]
, "params" .= (params phraseSuggesterCollateTemplateQuery)
, "prune" .= phraseSuggesterCollatePrune
]
instance FromJSON PhraseSuggesterCollate where
parseJSON (Object o) = do
query' <- o .: "query"
inline' <- query' .: "inline"
params' <- o .: "params"
prune' <- o .:? "prune" .!= False
return $ PhraseSuggesterCollate (TemplateQueryInline inline' params') prune'
parseJSON x = typeMismatch "PhraseSuggesterCollate" x
mkPhraseSuggesterCollate :: TemplateQueryInline -> PhraseSuggesterCollate
mkPhraseSuggesterCollate tQuery = PhraseSuggesterCollate tQuery False
data SuggestOptions =
SuggestOptions { suggestOptionsText :: Text
, suggestOptionsScore :: Double
, suggestOptionsFreq :: Maybe Int
, suggestOptionsHighlighted :: Maybe Text
}
deriving (Eq, Read, Show)
instance FromJSON SuggestOptions where
parseJSON = withObject "SuggestOptions" parse
where parse o = SuggestOptions
<$> o .: "text"
<*> o .: "score"
<*> o .:? "freq"
<*> o .:? "highlighted"
data SuggestResponse =
SuggestResponse { suggestResponseText :: Text
, suggestResponseOffset :: Int
, suggestResponseLength :: Int
, suggestResponseOptions :: [SuggestOptions]
}
deriving (Eq, Read, Show)
instance FromJSON SuggestResponse where
parseJSON = withObject "SuggestResponse" parse
where parse o = SuggestResponse
<$> o .: "text"
<*> o .: "offset"
<*> o .: "length"
<*> o .: "options"
data NamedSuggestionResponse =
NamedSuggestionResponse { nsrName :: Text
, nsrResponses :: [SuggestResponse]
}
deriving (Eq, Read, Show)
instance FromJSON NamedSuggestionResponse where
parseJSON (Object o) = do
suggestionName' <- case HM.toList o of
[(x, _)] -> return x
_ -> fail "error parsing NamedSuggestionResponse name"
suggestionResponses' <- o .: suggestionName'
return $ NamedSuggestionResponse suggestionName' suggestionResponses'
parseJSON x = typeMismatch "NamedSuggestionResponse" x

View File

@ -1044,7 +1044,7 @@ scanSearch indexName mappingName search = do
-- >>> mkSearch (Just query) Nothing
-- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}
mkSearch :: Maybe Query -> Maybe Filter -> Search
mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
-- the 'Query' and the 'Aggregation'.
@ -1054,7 +1054,7 @@ mkSearch query filter = Search query filter Nothing Nothing Nothing False (From
-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
mkAggregateSearch :: Maybe Query -> Aggregations -> Search
mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing
mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing Nothing
-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
-- the 'Query' and the 'Aggregation'.
@ -1063,7 +1063,7 @@ mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSear
-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
-- >>> let search = mkHighlightSearch (Just query) testHighlight
mkHighlightSearch :: Maybe Query -> Highlights -> Search
mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
-- | 'pageSearch' is a helper function that takes a search and assigns the from
-- and size fields for the search. The from parameter defines the offset

View File

@ -196,6 +196,8 @@ module Database.V5.Bloodhound.Types
, RangeQuery(..)
, RegexpQuery(..)
, QueryString(..)
, TemplateQueryInline(..)
, TemplateQueryKeyValuePairs(..)
, BooleanOperator(..)
, ZeroTermsQuery(..)
, CutoffFrequency(..)
@ -323,6 +325,15 @@ module Database.V5.Bloodhound.Types
, rrGroupRefNum
, mkRRGroupRefNum
, RestoreIndexSettings(..)
, Suggest(..)
, SuggestType(..)
, PhraseSuggester(..)
, PhraseSuggesterHighlighter(..)
, PhraseSuggesterCollate(..)
, mkPhraseSuggester
, SuggestOptions(..)
, SuggestResponse(..)
, NamedSuggestionResponse(..)
, Aggregation(..)
, Aggregations
@ -378,7 +389,8 @@ import Control.Monad.Writer (MonadWriter)
import Data.Aeson
import Data.Aeson.Types (Pair, Parser,
emptyObject,
parseEither, parseMaybe)
parseEither, parseMaybe,
typeMismatch)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Char
import Data.Hashable (Hashable)
@ -1095,7 +1107,7 @@ unpackId (DocId docId) = docId
type TrackSortScores = Bool
newtype From = From Int deriving (Eq, Read, Show, Generic, ToJSON)
newtype Size = Size Int deriving (Eq, Read, Show, Generic, ToJSON)
newtype Size = Size Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON)
data Search = Search { queryBody :: Maybe Query
, filterBody :: Maybe Filter
@ -1108,7 +1120,9 @@ data Search = Search { queryBody :: Maybe Query
, size :: Size
, searchType :: SearchType
, fields :: Maybe [FieldName]
, source :: Maybe Source } deriving (Eq, Read, Show, Generic, Typeable)
, source :: Maybe Source
, suggestBody :: Maybe Suggest -- ^ Only one Suggestion request / response per Search is supported.
} deriving (Eq, Read, Show, Generic, Typeable)
data SearchType = SearchTypeQueryThenFetch
| SearchTypeDfsQueryThenFetch
@ -1211,6 +1225,7 @@ data Query =
| QueryRegexpQuery RegexpQuery
| QueryExistsQuery FieldName
| QueryMatchNoneQuery
| QueryTemplateQueryInline TemplateQueryInline
deriving (Eq, Read, Show, Generic, Typeable)
-- | As of Elastic 2.0, 'Filters' are just 'Queries' housed in a Bool Query, and
@ -1622,13 +1637,49 @@ data DistanceRange =
DistanceRange { distanceFrom :: Distance
, distanceTo :: Distance } deriving (Eq, Read, Show, Generic, Typeable)
type TemplateQueryKey = Text
type TemplateQueryValue = Text
newtype TemplateQueryKeyValuePairs = TemplateQueryKeyValuePairs (HM.HashMap TemplateQueryKey TemplateQueryValue)
deriving (Eq, Read, Show, Generic)
instance ToJSON TemplateQueryKeyValuePairs where
toJSON (TemplateQueryKeyValuePairs x) = Object $ HM.map toJSON x
instance FromJSON TemplateQueryKeyValuePairs where
parseJSON (Object o) = pure . TemplateQueryKeyValuePairs $ HM.mapMaybe getValue o
where getValue (String x) = Just x
getValue _ = Nothing
parseJSON _ = fail "error parsing TemplateQueryKeyValuePairs"
data TemplateQueryInline =
TemplateQueryInline { inline :: Query
, params :: TemplateQueryKeyValuePairs
}
deriving (Eq, Read, Show, Generic, Typeable)
instance ToJSON TemplateQueryInline where
toJSON TemplateQueryInline{..} = object [ "inline" .= inline
, "params" .= params
]
instance FromJSON TemplateQueryInline where
parseJSON = withObject "TemplateQueryInline" parse
where parse o = TemplateQueryInline
<$> o .: "inline"
<*> o .: "params"
data SearchResult a =
SearchResult { took :: Int
, timedOut :: Bool
, shards :: ShardResult
, searchHits :: SearchHits a
, aggregations :: Maybe AggregationResults
, scrollId :: Maybe ScrollId } deriving (Eq, Read, Show, Generic, Typeable)
, scrollId :: Maybe ScrollId
, suggest :: Maybe NamedSuggestionResponse -- ^ Only one Suggestion request / response per Search is supported.
}
deriving (Eq, Read, Show, Generic, Typeable)
newtype ScrollId = ScrollId Text deriving (Eq, Read, Show, Generic, Ord, ToJSON, FromJSON)
@ -2220,6 +2271,9 @@ instance ToJSON Query where
toJSON QueryMatchNoneQuery =
object ["match_none" .= object []]
toJSON (QueryTemplateQueryInline templateQuery) =
object [ "template" .= templateQuery ]
instance FromJSON Query where
parseJSON v = withObject "Query" parse v
where parse o = termQuery `taggedWith` "term"
@ -2247,6 +2301,7 @@ instance FromJSON Query where
<|> queryRangeQuery `taggedWith` "range"
<|> queryRegexpQuery `taggedWith` "regexp"
<|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"
<|> queryTemplateQueryInline `taggedWith` "template"
where taggedWith parser k = parser =<< o .: k
termQuery = fieldTagged $ \(FieldName fn) o ->
TermQuery <$> (Term fn <$> o .: "value") <*> o .:? "boost"
@ -2284,6 +2339,7 @@ instance FromJSON Query where
queryRegexpQuery = pure . QueryRegexpQuery
querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery
-- queryExistsQuery o = QueryExistsQuery <$> o .: "field"
queryTemplateQueryInline = pure . QueryTemplateQueryInline
omitNulls :: [(Text, Value)] -> Value
@ -2810,7 +2866,7 @@ instance ToJSON MultiMatchQuery where
, "query" .= query
, "operator" .= boolOp
, "zero_terms_query" .= ztQ
, "tiebreaker" .= tb
, "tie_breaker" .= tb
, "type" .= mmqt
, "cutoff_frequency" .= cf
, "analyzer" .= analyzer
@ -2825,7 +2881,7 @@ instance FromJSON MultiMatchQuery where
<*> o .: "query"
<*> o .: "operator"
<*> o .: "zero_terms_query"
<*> o .:? "tiebreaker"
<*> o .:? "tie_breaker"
<*> o .:? "type"
<*> o .:? "cutoff_frequency"
<*> o .:? "analyzer"
@ -3212,7 +3268,7 @@ instance FromJSON SearchAliasRouting where
where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)
instance ToJSON Search where
toJSON (Search mquery sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _ sFields sSource) =
toJSON (Search mquery sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _ sFields sSource sSuggest) =
omitNulls [ "query" .= query'
, "sort" .= sort
, "aggregations" .= searchAggs
@ -3221,7 +3277,8 @@ instance ToJSON Search where
, "size" .= sSize
, "track_scores" .= sTrackSortScores
, "fields" .= sFields
, "_source" .= sSource]
, "_source" .= sSource
, "suggest" .= sSuggest]
where query' = case sFilter of
Nothing -> mquery
@ -3574,7 +3631,8 @@ instance (FromJSON a) => FromJSON (SearchResult a) where
v .: "_shards" <*>
v .: "hits" <*>
v .:? "aggregations" <*>
v .:? "_scroll_id"
v .:? "_scroll_id" <*>
v .:? "suggest"
parseJSON _ = empty
instance (FromJSON a) => FromJSON (SearchHits a) where
@ -5055,3 +5113,178 @@ newtype MaybeNA a = MaybeNA { unMaybeNA :: Maybe a }
instance FromJSON a => FromJSON (MaybeNA a) where
parseJSON (String "NA") = pure $ MaybeNA Nothing
parseJSON o = MaybeNA . Just <$> parseJSON o
data Suggest = Suggest { suggestText :: Text
, suggestName :: Text
, suggestType :: SuggestType
}
deriving (Show, Generic, Eq, Read)
instance ToJSON Suggest where
toJSON Suggest{..} = object [ "text" .= suggestText
, suggestName .= suggestType
]
instance FromJSON Suggest where
parseJSON (Object o) = do
suggestText' <- o .: "text"
let dropTextList = HM.toList $ HM.filterWithKey (\x _ -> x /= "text") o
suggestName' <- case dropTextList of
[(x, _)] -> return x
_ -> fail "error parsing Suggest field name"
suggestType' <- o .: suggestName'
return $ Suggest suggestText' suggestName' suggestType'
parseJSON x = typeMismatch "Suggest" x
data SuggestType = SuggestTypePhraseSuggester PhraseSuggester
deriving (Show, Generic, Eq, Read)
instance ToJSON SuggestType where
toJSON (SuggestTypePhraseSuggester x) = object ["phrase" .= x]
instance FromJSON SuggestType where
parseJSON = withObject "SuggestType" parse
where parse o = phraseSuggester `taggedWith` "phrase"
where taggedWith parser k = parser =<< o .: k
phraseSuggester = pure . SuggestTypePhraseSuggester
data PhraseSuggester =
PhraseSuggester { phraseSuggesterField :: FieldName
, phraseSuggesterGramSize :: Maybe Int
, phraseSuggesterRealWordErrorLikelihood :: Maybe Int
, phraseSuggesterConfidence :: Maybe Int
, phraseSuggesterMaxErrors :: Maybe Int
, phraseSuggesterSeparator :: Maybe Text
, phraseSuggesterSize :: Maybe Size
, phraseSuggesterAnalyzer :: Maybe Analyzer
, phraseSuggesterShardSize :: Maybe Int
, phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
, phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
}
deriving (Show, Generic, Eq, Read)
instance ToJSON PhraseSuggester where
toJSON PhraseSuggester{..} = omitNulls [ "field" .= phraseSuggesterField
, "gram_size" .= phraseSuggesterGramSize
, "real_word_error_likelihood" .= phraseSuggesterRealWordErrorLikelihood
, "confidence" .= phraseSuggesterConfidence
, "max_errors" .= phraseSuggesterMaxErrors
, "separator" .= phraseSuggesterSeparator
, "size" .= phraseSuggesterSize
, "analyzer" .= phraseSuggesterAnalyzer
, "shard_size" .= phraseSuggesterShardSize
, "highlight" .= phraseSuggesterHighlight
, "collate" .= phraseSuggesterCollate
]
instance FromJSON PhraseSuggester where
parseJSON = withObject "PhraseSuggester" parse
where parse o = PhraseSuggester
<$> o .: "field"
<*> o .:? "gram_size"
<*> o .:? "real_word_error_likelihood"
<*> o .:? "confidence"
<*> o .:? "max_errors"
<*> o .:? "separator"
<*> o .:? "size"
<*> o .:? "analyzer"
<*> o .:? "shard_size"
<*> o .:? "highlight"
<*> o .:? "collate"
mkPhraseSuggester :: FieldName -> PhraseSuggester
mkPhraseSuggester fName =
PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing
data PhraseSuggesterHighlighter =
PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
, phraseSuggesterHighlighterPostTag :: Text
}
deriving (Show, Generic, Eq, Read)
instance ToJSON PhraseSuggesterHighlighter where
toJSON PhraseSuggesterHighlighter{..} =
object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
, "post_tag" .= phraseSuggesterHighlighterPostTag
]
instance FromJSON PhraseSuggesterHighlighter where
parseJSON = withObject "PhraseSuggesterHighlighter" parse
where parse o = PhraseSuggesterHighlighter
<$> o .: "pre_tag"
<*> o .: "post_tag"
data PhraseSuggesterCollate =
PhraseSuggesterCollate { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
, phraseSuggesterCollatePrune :: Bool
}
deriving (Show, Generic, Eq, Read)
instance ToJSON PhraseSuggesterCollate where
toJSON PhraseSuggesterCollate{..} = object [ "query" .= object
[ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
]
, "params" .= (params phraseSuggesterCollateTemplateQuery)
, "prune" .= phraseSuggesterCollatePrune
]
instance FromJSON PhraseSuggesterCollate where
parseJSON (Object o) = do
query' <- o .: "query"
inline' <- query' .: "inline"
params' <- o .: "params"
prune' <- o .:? "prune" .!= False
return $ PhraseSuggesterCollate (TemplateQueryInline inline' params') prune'
parseJSON x = typeMismatch "PhraseSuggesterCollate" x
mkPhraseSuggesterCollate :: TemplateQueryInline -> PhraseSuggesterCollate
mkPhraseSuggesterCollate tQuery = PhraseSuggesterCollate tQuery False
data SuggestOptions =
SuggestOptions { suggestOptionsText :: Text
, suggestOptionsScore :: Double
, suggestOptionsFreq :: Maybe Int
, suggestOptionsHighlighted :: Maybe Text
}
deriving (Eq, Read, Show)
instance FromJSON SuggestOptions where
parseJSON = withObject "SuggestOptions" parse
where parse o = SuggestOptions
<$> o .: "text"
<*> o .: "score"
<*> o .:? "freq"
<*> o .:? "highlighted"
data SuggestResponse =
SuggestResponse { suggestResponseText :: Text
, suggestResponseOffset :: Int
, suggestResponseLength :: Int
, suggestResponseOptions :: [SuggestOptions]
}
deriving (Eq, Read, Show)
instance FromJSON SuggestResponse where
parseJSON = withObject "SuggestResponse" parse
where parse o = SuggestResponse
<$> o .: "text"
<*> o .: "offset"
<*> o .: "length"
<*> o .: "options"
data NamedSuggestionResponse =
NamedSuggestionResponse { nsrName :: Text
, nsrResponses :: [SuggestResponse]
}
deriving (Eq, Read, Show)
instance FromJSON NamedSuggestionResponse where
parseJSON (Object o) = do
suggestionName' <- case HM.toList o of
[(x, _)] -> return x
_ -> fail "error parsing NamedSuggestionResponse name"
suggestionResponses' <- o .: suggestionName'
return $ NamedSuggestionResponse suggestionName' suggestionResponses'
parseJSON x = typeMismatch "NamedSuggestionResponse" x

View File

@ -18,4 +18,5 @@ extra-deps:
- uri-bytestring-0.1.9
- void-0.7.1
- generics-sop-0.2.2.0
- unordered-containers-0.2.6.0
resolver: lts-2.18

View File

@ -595,6 +595,15 @@ instance (ApproxEq l, ApproxEq r) => ApproxEq (Either l r) where
instance ApproxEq NodeAttrFilter
instance ApproxEq NodeAttrName
instance ApproxEq BuildHash
instance ApproxEq TemplateQueryKeyValuePairs where
(=~) = (==)
instance ApproxEq TemplateQueryInline
instance ApproxEq Size
instance ApproxEq PhraseSuggesterHighlighter
instance ApproxEq PhraseSuggesterCollate
instance ApproxEq PhraseSuggester
instance ApproxEq SuggestType
instance ApproxEq Suggest
-- | Due to the way nodeattrfilters get serialized here, they may come
-- out in a different order, but they are morally equivalent
@ -746,6 +755,7 @@ instance Arbitrary Query where
, QuerySimpleQueryStringQuery <$> arbitrary
, QueryRangeQuery <$> arbitrary
, QueryRegexpQuery <$> arbitrary
, QueryTemplateQueryInline <$> arbitrary
]
shrink = genericShrink
@ -798,6 +808,10 @@ instance Arbitrary VersionNumber where
where
mk versions = VersionNumber (Vers.Version versions [])
instance Arbitrary TemplateQueryKeyValuePairs where
arbitrary = TemplateQueryKeyValuePairs . HM.fromList <$> arbitrary
shrink (TemplateQueryKeyValuePairs x) = map (TemplateQueryKeyValuePairs . HM.fromList) . shrink $ HM.toList x
instance Arbitrary IndexName where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary MappingName where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary DocId where arbitrary = sopArbitrary; shrink = genericShrink
@ -913,6 +927,13 @@ instance Arbitrary FSType where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary CompoundFormat where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary FsSnapshotRepo where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary SnapshotRepoName where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary TemplateQueryInline where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary PhraseSuggesterCollate where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary PhraseSuggesterHighlighter where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary Size where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary PhraseSuggester where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary SuggestType where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary Suggest where arbitrary = sopArbitrary; shrink = genericShrink
newtype UpdatableIndexSetting' = UpdatableIndexSetting' UpdatableIndexSetting
deriving (Show, Eq, ToJSON, FromJSON, ApproxEq, Typeable)
@ -1091,6 +1112,17 @@ main = hspec $ do
liftIO $
myTweet `shouldBe` Right exampleTweet
it "returns document for multi-match query with a custom tiebreaker" $ withTestEnv $ do
_ <- insertData
let tiebreaker = Just $ Tiebreaker 0.3
flds = [FieldName "user", FieldName "message"]
multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")
query = QueryMultiMatchQuery $ multiQuery' { multiMatchQueryTiebreaker = tiebreaker }
search = mkSearch (Just query) Nothing
myTweet <- searchTweet search
liftIO $
myTweet `shouldBe` Right exampleTweet
it "returns document for bool query" $ withTestEnv $ do
_ <- insertData
let innerQuery = QueryMatchQuery $
@ -1124,6 +1156,21 @@ main = hspec $ do
liftIO $
myTweet `shouldBe` Right exampleTweet
it "returns document for for inline template query" $ withTestEnv $ do
_ <- insertData
let innerQuery = QueryMatchQuery $
mkMatchQuery (FieldName "{{userKey}}")
(QueryString "{{bitemyappKey}}")
templateParams = TemplateQueryKeyValuePairs $ HM.fromList
[ ("userKey", "user")
, ("bitemyappKey", "bitemyapp")
]
templateQuery = QueryTemplateQueryInline $
TemplateQueryInline innerQuery templateParams
search = mkSearch (Just templateQuery) Nothing
myTweet <- searchTweet search
liftIO $ myTweet `shouldBe` Right exampleTweet
describe "sorting" $ do
it "returns documents in the right order" $ withTestEnv $ do
@ -1133,6 +1180,7 @@ main = hspec $ do
let search = Search Nothing
(Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
Nothing
result <- searchTweets search
let myTweet = grabFirst result
liftIO $
@ -1761,6 +1809,22 @@ main = hspec $ do
resp <- optimizeIndex (IndexList (testIndex :| [])) defaultIndexOptimizationSettings
liftIO $ validateStatus resp 200
describe "Suggest" $ do
it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do
_ <- insertData
let {- query = QueryMatchNoneQuery
query = TermQuery (Term "user" "bitemyapp") Nothing -}
let phraseSuggester = mkPhraseSuggester (FieldName "message")
namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
search' = mkSearch Nothing Nothing
search = search' { suggestBody = Just namedSuggester }
expectedText = Just "use haskell"
resp <- searchByIndex testIndex search
parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))
case parsed of
Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)
Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText
describe "JSON instances" $ do
propJSON (Proxy :: Proxy Version)
propJSON (Proxy :: Proxy IndexName)
@ -1864,6 +1928,8 @@ main = hspec $ do
propJSON (Proxy :: Proxy InitialShardCount)
propJSON (Proxy :: Proxy FSType)
propJSON (Proxy :: Proxy CompoundFormat)
propJSON (Proxy :: Proxy TemplateQueryInline)
propJSON (Proxy :: Proxy Suggest)
-- Temporary solution for lacking of generic derivation of Arbitrary
-- We use generics-sop, as it's much more concise than directly using GHC.Generics

View File

@ -607,6 +607,15 @@ instance (ApproxEq l, Show l, ApproxEq r, Show r) => ApproxEq (Either l r) where
instance ApproxEq NodeAttrFilter
instance ApproxEq NodeAttrName
instance ApproxEq BuildHash
instance ApproxEq TemplateQueryKeyValuePairs where
(=~) = (==)
instance ApproxEq TemplateQueryInline
instance ApproxEq Size
instance ApproxEq PhraseSuggesterHighlighter
instance ApproxEq PhraseSuggesterCollate
instance ApproxEq PhraseSuggester
instance ApproxEq SuggestType
instance ApproxEq Suggest
-- | Due to the way nodeattrfilters get serialized here, they may come
-- out in a different order, but they are morally equivalent
@ -756,6 +765,7 @@ instance Arbitrary Query where
, QuerySimpleQueryStringQuery <$> arbitrary
, QueryRangeQuery <$> arbitrary
, QueryRegexpQuery <$> arbitrary
, QueryTemplateQueryInline <$> arbitrary
]
shrink = genericShrink
@ -791,6 +801,10 @@ instance Arbitrary VersionNumber where
where
mk versions = VersionNumber (Vers.Version versions [])
instance Arbitrary TemplateQueryKeyValuePairs where
arbitrary = TemplateQueryKeyValuePairs . HM.fromList <$> arbitrary
shrink (TemplateQueryKeyValuePairs x) = map (TemplateQueryKeyValuePairs . HM.fromList) . shrink $ HM.toList x
instance Arbitrary IndexName where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary MappingName where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary DocId where arbitrary = sopArbitrary; shrink = genericShrink
@ -898,6 +912,13 @@ instance Arbitrary FSType where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary CompoundFormat where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary FsSnapshotRepo where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary SnapshotRepoName where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary TemplateQueryInline where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary PhraseSuggesterCollate where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary PhraseSuggesterHighlighter where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary Size where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary PhraseSuggester where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary SuggestType where arbitrary = sopArbitrary; shrink = genericShrink
instance Arbitrary Suggest where arbitrary = sopArbitrary; shrink = genericShrink
newtype UpdatableIndexSetting' = UpdatableIndexSetting' UpdatableIndexSetting
deriving (Show, Eq, ToJSON, FromJSON, ApproxEq, Typeable)
@ -1066,6 +1087,17 @@ main = hspec $ do
liftIO $
myTweet `shouldBe` Right exampleTweet
it "returns document for multi-match query with a custom tiebreaker" $ withTestEnv $ do
_ <- insertData
let tiebreaker = Just $ Tiebreaker 0.3
flds = [FieldName "user", FieldName "message"]
multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")
query = QueryMultiMatchQuery $ multiQuery' { multiMatchQueryTiebreaker = tiebreaker }
search = mkSearch (Just query) Nothing
myTweet <- searchTweet search
liftIO $
myTweet `shouldBe` Right exampleTweet
it "returns document for bool query" $ withTestEnv $ do
_ <- insertData
let innerQuery = QueryMatchQuery $
@ -1099,6 +1131,21 @@ main = hspec $ do
liftIO $
myTweet `shouldBe` Right exampleTweet
it "returns document for for inline template query" $ withTestEnv $ do
_ <- insertData
let innerQuery = QueryMatchQuery $
mkMatchQuery (FieldName "{{userKey}}")
(QueryString "{{bitemyappKey}}")
templateParams = TemplateQueryKeyValuePairs $ HM.fromList
[ ("userKey", "user")
, ("bitemyappKey", "bitemyapp")
]
templateQuery = QueryTemplateQueryInline $
TemplateQueryInline innerQuery templateParams
search = mkSearch (Just templateQuery) Nothing
myTweet <- searchTweet search
liftIO $ myTweet `shouldBe` Right exampleTweet
describe "sorting" $ do
it "returns documents in the right order" $ withTestEnv $ do
@ -1108,6 +1155,7 @@ main = hspec $ do
let search = Search Nothing
Nothing (Just [sortSpec]) Nothing Nothing
False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
Nothing
result <- searchTweets search
let myTweet = grabFirst result
liftIO $
@ -1546,6 +1594,21 @@ main = hspec $ do
resp <- forceMergeIndex (IndexList (testIndex :| [])) defaultForceMergeIndexSettings
liftIO $ validateStatus resp 200
describe "Suggest" $ do
it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do
_ <- insertData
let query = QueryMatchNoneQuery
phraseSuggester = mkPhraseSuggester (FieldName "message")
namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
search' = mkSearch (Just query) Nothing
search = search' { suggestBody = Just namedSuggester }
expectedText = Just "use haskell"
resp <- searchByIndex testIndex search
parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))
case parsed of
Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)
Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText
describe "JSON instances" $ do
propJSON (Proxy :: Proxy Version)
propJSON (Proxy :: Proxy IndexName)
@ -1648,6 +1711,8 @@ main = hspec $ do
propJSON (Proxy :: Proxy InitialShardCount)
propJSON (Proxy :: Proxy FSType)
propJSON (Proxy :: Proxy CompoundFormat)
propJSON (Proxy :: Proxy TemplateQueryInline)
propJSON (Proxy :: Proxy Suggest)
-- Temporary solution for lacking of generic derivation of Arbitrary
-- We use generics-sop, as it's much more concise than directly using GHC.Generics