diff --git a/bloodhound.cabal b/bloodhound.cabal --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -1,5 +1,5 @@ name: bloodhound -version: 0.14.0.0 +version: 0.15.0.0 synopsis: ElasticSearch client library for Haskell description: ElasticSearch made awesome for Haskell hackers homepage: https://github.com/bitemyapp/bloodhound @@ -15,6 +15,9 @@ extra-source-files: README.md changelog.md + -- We do this to avoid package check errors when uploading to hackage + tests/V1/tests.hs + tests/V5/tests.hs source-repository head type: git @@ -22,11 +25,11 @@ Flag ES1 Description: Run the test suite against an Elasticsearch 1.x server - Default: True + Default: False Flag ES5 Description: Run the test suite against an Elasticsearch 5.x server - Default: False + Default: True library ghc-options: -Wall @@ -48,7 +51,7 @@ http-client >= 0.4.30 && <0.6, network-uri >= 2.6 && <2.7, semigroups >= 0.15 && <0.19, - time >= 1.4 && <1.7, + time >= 1.4 && <1.9, text >= 0.11 && <1.3, mtl >= 1.0 && <2.3, transformers >= 0.2 && <0.6, @@ -67,11 +70,11 @@ ghc-options: -Wall -fno-warn-orphans type: exitcode-stdio-1.0 main-is: tests.hs - if flag(ES5) - hs-source-dirs: tests/V5 - else + if flag(ES1) hs-source-dirs: tests/V1 - + else + hs-source-dirs: tests/V5 + build-depends: base, bloodhound, bytestring, @@ -88,7 +91,7 @@ unordered-containers >= 0.2.5.0 && <0.3, mtl, quickcheck-properties, - generics-sop >=0.2 && <0.3, + generics-sop >=0.2 && <0.4, errors, exceptions, temporary, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,31 @@ +0.15.0.0 +=================== + +- @jagare + - #204 Fix bug where Location was used instad of LatLon + - #207 Add instructions on how to run example code + +- @andrewthad + - #200 Add function for deleting alias + - #201 Add BulkCreateEncoding, which allows use of aeson's Encoding for faster bulk creates + - #203 Add support for total fields limit + +- @chrissound + - #196 Add missing import to example + +- @tmcgilchrist + - #186 Fix warnings and drop redundant constraints + +- @23Skidoo + - #183 Bump dependencies to support GHC 8.2 + +- @bermanjosh + - #182 Support for Suggesters and Template Queries + +- @dawei-dev + - #181 Fix typo + + 0.14.0.0 =================== diff --git a/src/Database/V1/Bloodhound/Client.hs b/src/Database/V1/Bloodhound/Client.hs --- a/src/Database/V1/Bloodhound/Client.hs +++ b/src/Database/V1/Bloodhound/Client.hs @@ -151,8 +151,11 @@ initReq <- liftIO $ parseUrl' url reqHook <- bhRequestHook A.<$> getBHEnv let reqBody = RequestBodyLBS $ fromMaybe emptyBody body - req <- liftIO $ reqHook $ setRequestIgnoreStatus $ initReq { method = dMethod - , requestBody = reqBody } + req <- liftIO + $ reqHook + $ setRequestIgnoreStatus + $ initReq { method = dMethod + , requestBody = reqBody } mgr <- bhManager <$> getBHEnv liftIO $ httpLbs req mgr @@ -861,17 +864,17 @@ -- 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 diff --git a/src/Database/V1/Bloodhound/Types.hs b/src/Database/V1/Bloodhound/Types.hs --- a/src/Database/V1/Bloodhound/Types.hs +++ b/src/Database/V1/Bloodhound/Types.hs @@ -195,6 +195,8 @@ , RangeQuery(..) , RegexpQuery(..) , QueryString(..) + , TemplateQueryInline(..) + , TemplateQueryKeyValuePairs(..) , BooleanOperator(..) , ZeroTermsQuery(..) , CutoffFrequency(..) @@ -322,6 +324,15 @@ , rrGroupRefNum , mkRRGroupRefNum , RestoreIndexSettings(..) + , Suggest(..) + , SuggestType(..) + , PhraseSuggester(..) + , PhraseSuggesterHighlighter(..) + , PhraseSuggesterCollate(..) + , mkPhraseSuggester + , SuggestOptions(..) + , SuggestResponse(..) + , NamedSuggestionResponse(..) , Aggregation(..) , Aggregations @@ -376,7 +387,8 @@ 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 @@ 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 @@ , 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 @@ | QuerySimpleQueryStringQuery SimpleQueryStringQuery | QueryRangeQuery RangeQuery | QueryRegexpQuery RegexpQuery + | QueryTemplateQueryInline TemplateQueryInline deriving (Eq, Read, Show, Generic, Typeable) data RegexpQuery = @@ -1635,13 +1650,48 @@ 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) @@ -2178,7 +2228,7 @@ toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) = object ["missing" .= - object ["field" .= fieldName + object [ "field" .= fieldName , "existence" .= existence , "null_value" .= nullValue]] @@ -2404,6 +2454,9 @@ 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 @@ <|> 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 @@ queryRangeQuery = pure . QueryRangeQuery queryRegexpQuery = pure . QueryRegexpQuery querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery + queryTemplateQueryInline = pure . QueryTemplateQueryInline omitNulls :: [(Text, Value)] -> Value @@ -3412,7 +3467,7 @@ 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 @@ , "size" .= sSize , "track_scores" .= sTrackSortScores , "fields" .= sFields - , "_source" .= sSource] + , "_source" .= sSource + , "suggest" .= sSuggest] instance ToJSON Source where @@ -3772,7 +3828,8 @@ 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,176 @@ 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 + +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 diff --git a/src/Database/V5/Bloodhound/Client.hs b/src/Database/V5/Bloodhound/Client.hs --- a/src/Database/V5/Bloodhound/Client.hs +++ b/src/Database/V5/Bloodhound/Client.hs @@ -7,7 +7,7 @@ -- Module : Database.Bloodhound.Client -- Copyright : (C) 2014 Chris Allen -- License : BSD-style (see the file LICENSE) --- Maintainer : Chris Allen -- Stability : provisional -- Portability : OverloadedStrings -- @@ -37,6 +37,7 @@ -- *** Index Aliases , updateIndexAliases , getIndexAliases + , deleteIndexAlias -- *** Index Templates , putTemplate , templateExists @@ -127,6 +128,7 @@ -- >>> :set -XOverloadedStrings -- >>> :set -XDeriveGeneric -- >>> import Database.V5.Bloodhound +-- >>> import Network.HTTP.Client -- >>> let testServer = (Server "http://localhost:9200") -- >>> let runBH' = withBH defaultManagerSettings testServer -- >>> let testIndex = IndexName "twitter" @@ -207,8 +209,15 @@ initReq <- liftIO $ parseUrl' url reqHook <- bhRequestHook A.<$> getBHEnv let reqBody = RequestBodyLBS $ fromMaybe emptyBody body - req <- liftIO $ reqHook $ setRequestIgnoreStatus $ initReq { method = dMethod - , requestBody = reqBody } + req <- liftIO + $ reqHook + $ setRequestIgnoreStatus + $ initReq { method = dMethod + , requestHeaders = + ("Content-Type", "application/json") : requestHeaders initReq + , requestBody = reqBody } + -- req <- liftIO $ reqHook $ setRequestIgnoreStatus $ initReq { method = dMethod + -- , requestBody = reqBody } mgr <- bhManager <$> getBHEnv liftIO $ httpLbs req mgr @@ -710,6 +719,12 @@ getIndexAliases = parseEsResponse =<< get =<< url where url = joinPath ["_aliases"] +-- | Delete a single alias, removing it from all indices it +-- is currently associated with. +deleteIndexAlias :: MonadBH m => IndexAliasName -> m Reply +deleteIndexAlias (IndexAliasName (IndexName name)) = delete =<< url + where url = joinPath ["_all","_alias",name] + -- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'. -- Explained in further detail at -- @@ -878,6 +893,12 @@ doc = object ["doc" .= value] blob = encode metadata `mappend` "\n" `mappend` encode doc +encodeBulkOperation (BulkCreateEncoding (IndexName indexName) + (MappingName mappingName) + (DocId docId) encoding) = toLazyByteString blob + where metadata = toEncoding (mkBulkStreamValue "create" indexName mappingName docId) + blob = fromEncoding metadata <> "\n" <> fromEncoding encoding + -- | 'getDocument' is a straight-forward way to fetch a single document from -- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'. -- The 'DocId' is the primary key for your Elasticsearch document. @@ -1044,7 +1065,7 @@ -- >>> 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 +1075,7 @@ -- 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 +1084,7 @@ -- >>> 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 diff --git a/src/Database/V5/Bloodhound/Types.hs b/src/Database/V5/Bloodhound/Types.hs --- a/src/Database/V5/Bloodhound/Types.hs +++ b/src/Database/V5/Bloodhound/Types.hs @@ -196,6 +196,8 @@ , RangeQuery(..) , RegexpQuery(..) , QueryString(..) + , TemplateQueryInline(..) + , TemplateQueryKeyValuePairs(..) , BooleanOperator(..) , ZeroTermsQuery(..) , CutoffFrequency(..) @@ -323,6 +325,15 @@ , rrGroupRefNum , mkRRGroupRefNum , RestoreIndexSettings(..) + , Suggest(..) + , SuggestType(..) + , PhraseSuggester(..) + , PhraseSuggesterHighlighter(..) + , PhraseSuggesterCollate(..) + , mkPhraseSuggester + , SuggestOptions(..) + , SuggestResponse(..) + , NamedSuggestionResponse(..) , Aggregation(..) , Aggregations @@ -378,7 +389,8 @@ 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) @@ -570,6 +582,7 @@ | IndexCompoundFormat CompoundFormat | IndexCompoundOnFlush Bool | WarmerEnabled Bool + | MappingTotalFieldsLimit Int deriving (Eq, Show, Generic, Typeable) data AllocationPolicy = AllocAll @@ -698,8 +711,9 @@ data BulkOperation = BulkIndex IndexName MappingName DocId Value | BulkCreate IndexName MappingName DocId Value + | BulkCreateEncoding IndexName MappingName DocId Encoding | BulkDelete IndexName MappingName DocId - | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Read, Show, Generic, Typeable) + | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show, Generic, Typeable) {-| 'EsResult' describes the standard wrapper JSON document that you see in successful Elasticsearch lookups or lookups that couldn't find the document. @@ -910,7 +924,7 @@ {-| 'PrefixValue' is used in 'PrefixQuery' as the main query component. -} -type PrefixValue = Text +-- type PrefixValue = Text {-| 'BooleanOperator' is the usual And/Or operators with an ES compatible JSON encoding baked in. Used all over the place. @@ -1095,7 +1109,7 @@ 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 +1122,9 @@ , 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 +1227,7 @@ | 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 +1639,49 @@ 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) @@ -2047,7 +2100,7 @@ docCount = dateRangeDocCount aggs = dateRangeAggs -instance (FromJSON a, BucketAggregation a) => FromJSON (Bucket a) where +instance (FromJSON a) => FromJSON (Bucket a) where parseJSON (Object v) = Bucket <$> v .: "buckets" parseJSON _ = mempty @@ -2220,6 +2273,9 @@ 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 +2303,7 @@ <|> 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" @@ -2283,7 +2340,8 @@ queryRangeQuery = pure . QueryRangeQuery queryRegexpQuery = pure . QueryRegexpQuery querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery - queryExistsQuery o = QueryExistsQuery <$> o .: "field" + -- queryExistsQuery o = QueryExistsQuery <$> o .: "field" + queryTemplateQueryInline = pure . QueryTemplateQueryInline omitNulls :: [(Text, Value)] -> Value @@ -2751,10 +2809,10 @@ <*> o .: "negative_boost" instance ToJSON BoolQuery where - toJSON (BoolQuery mustM filterM notM shouldM bqMin boost disableCoord) = + toJSON (BoolQuery mustM filterM' notM shouldM bqMin boost disableCoord) = omitNulls base where base = [ "must" .= mustM - , "filter" .= filterM + , "filter" .= filterM' , "must_not" .= notM , "should" .= shouldM , "minimum_should_match" .= bqMin @@ -2810,7 +2868,7 @@ , "query" .= query , "operator" .= boolOp , "zero_terms_query" .= ztQ - , "tiebreaker" .= tb + , "tie_breaker" .= tb , "type" .= mmqt , "cutoff_frequency" .= cf , "analyzer" .= analyzer @@ -2825,7 +2883,7 @@ <*> o .: "query" <*> o .: "operator" <*> o .: "zero_terms_query" - <*> o .:? "tiebreaker" + <*> o .:? "tie_breaker" <*> o .:? "type" <*> o .:? "cutoff_frequency" <*> o .:? "analyzer" @@ -2931,6 +2989,7 @@ toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x + toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping","total_fields","limit"]) x instance FromJSON UpdatableIndexSetting where parseJSON = withObject "UpdatableIndexSetting" parse @@ -2962,6 +3021,7 @@ <|> blocksRead `taggedAt` ["blocks", "read"] <|> blocksWrite `taggedAt` ["blocks", "write"] <|> blocksMetaData `taggedAt` ["blocks", "metadata"] + <|> mappingTotalFieldsLimit `taggedAt` ["index", "mapping", "total_fields", "limit"] where taggedAt f ks = taggedAt' f (Object o) ks taggedAt' f v [] = f =<< (parseJSON v <|> (parseJSON (unStringlyTypeJSON v))) taggedAt' f v (k:ks) = withObject "Object" (\o -> do v' <- o .: k @@ -2994,6 +3054,7 @@ blocksRead = pure . BlocksRead blocksWrite = pure . BlocksWrite blocksMetaData = pure . BlocksMetaData + mappingTotalFieldsLimit = pure . MappingTotalFieldsLimit instance FromJSON IndexSettingsSummary where parseJSON = withObject "IndexSettingsSummary" parse @@ -3212,7 +3273,7 @@ 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 +3282,8 @@ , "size" .= sSize , "track_scores" .= sTrackSortScores , "fields" .= sFields - , "_source" .= sSource] + , "_source" .= sSource + , "suggest" .= sSuggest] where query' = case sFilter of Nothing -> mquery @@ -3574,7 +3636,8 @@ 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 +5118,175 @@ 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 + +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 diff --git a/tests/V1/tests.hs b/tests/V1/tests.hs new file mode 100644 --- /dev/null +++ b/tests/V1/tests.hs @@ -0,0 +1,1949 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ < 800 +{-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif +#if __GLASGOW_HASKELL__ >= 802 +{-# LANGUAGE MonoLocalBinds #-} +#endif +module Main where + +import Control.Applicative +import Control.Error +import Control.Exception (evaluate) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Reader +import Data.Aeson +import Data.Aeson.Types (parseEither) +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.HashMap.Strict as HM +import Data.List (nub) +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import Data.Monoid +import Data.Ord (comparing) +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Calendar (Day (..), fromGregorian) +import Data.Time.Clock (NominalDiffTime, UTCTime (..), + secondsToDiffTime) +import Data.Typeable +import qualified Data.Vector as V +import qualified Data.Version as Vers +import Database.V1.Bloodhound +import GHC.Generics as G +import Network.HTTP.Client hiding (Proxy) +import qualified Network.HTTP.Types.Method as NHTM +import qualified Network.HTTP.Types.Status as NHTS +import qualified Network.URI as URI +import Prelude hiding (filter) +import System.IO.Temp +import System.PosixCompat.Files +import Test.Hspec +import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid) + +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + +import qualified Generics.SOP as SOP +import qualified Generics.SOP.GGP as SOP + +testServer :: Server +testServer = Server "http://localhost:9200" +testIndex :: IndexName +testIndex = IndexName "bloodhound-tests-twitter-1" +testMapping :: MappingName +testMapping = MappingName "tweet" + +withTestEnv :: BH IO a -> IO a +withTestEnv = withBH defaultManagerSettings testServer + +validateStatus :: Show body => Response body -> Int -> Expectation +validateStatus resp expected = + if actual == expected + then return () + else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body) + where + actual = NHTS.statusCode (responseStatus resp) + body = responseBody resp + +createExampleIndex :: (MonadBH m) => m Reply +createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex +deleteExampleIndex :: (MonadBH m) => m Reply +deleteExampleIndex = deleteIndex testIndex + +es13 :: Vers.Version +es13 = Vers.Version [1, 3, 0] [] + +es12 :: Vers.Version +es12 = Vers.Version [1, 2, 0] [] + +es11 :: Vers.Version +es11 = Vers.Version [1, 1, 0] [] + +es14 :: Vers.Version +es14 = Vers.Version [1, 4, 0] [] + +es15 :: Vers.Version +es15 = Vers.Version [1, 5, 0] [] + +es16 :: Vers.Version +es16 = Vers.Version [1, 6, 0] [] + +es20 :: Vers.Version +es20 = Vers.Version [2, 0, 0] [] + +getServerVersion :: IO (Maybe Vers.Version) +getServerVersion = fmap extractVersion <$> withTestEnv getStatus + where + extractVersion = versionNumber . number . version + +-- | Get configured repo paths for snapshotting. Note that by default +-- this is not enabled and if we are over es 1.5, we won't be able to +-- test snapshotting. Note that this can and should be part of the +-- client functionality in a much less ad-hoc incarnation. +getRepoPaths :: IO [FilePath] +getRepoPaths = withTestEnv $ do + bhe <- getBHEnv + let Server s = bhServer bhe + let tUrl = s <> "/" <> "_nodes" + initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl)) + let req = setRequestIgnoreStatus $ initReq { method = NHTM.methodGet } + Right (Object o) <- parseEsResponse =<< liftIO (httpLbs req (bhManager bhe)) + return $ fromMaybe mempty $ do + Object nodes <- HM.lookup "nodes" o + Object firstNode <- snd <$> headMay (HM.toList nodes) + Object settings <- HM.lookup "settings" firstNode + Object path <- HM.lookup "path" settings + Array repo <- HM.lookup "repo" path + return [ T.unpack t | String t <- V.toList repo] + +-- | 1.5 and earlier don't care about repo paths +canSnapshot :: IO Bool +canSnapshot = do + caresAboutRepos <- atleast es16 + repoPaths <- getRepoPaths + return (not caresAboutRepos || not (null (repoPaths))) + +atleast :: Vers.Version -> IO Bool +atleast v = getServerVersion >>= \x -> return $ x >= Just v + +atmost :: Vers.Version -> IO Bool +atmost v = getServerVersion >>= \x -> return $ x <= Just v + +is :: Vers.Version -> IO Bool +is v = getServerVersion >>= \x -> return $ x == Just v + +when' :: Monad m => m Bool -> m () -> m () +when' b f = b >>= \x -> when x f + +(==~) :: (ApproxEq a) => a -> a -> Property +a ==~ b = counterexample (showApproxEq a ++ " !=~ " ++ showApproxEq b) (a =~ b) + +propJSON :: forall a. (Arbitrary a, ToJSON a, FromJSON a, Show a, ApproxEq a, Typeable a) => Proxy a -> Spec +propJSON _ = prop testName $ \(a :: a) -> + let jsonStr = "via " <> BL8.unpack (encode a) + in counterexample jsonStr (parseEither parseJSON (toJSON a) ==~ Right a) + where testName = show ty <> " FromJSON/ToJSON roundtrips" + ty = typeOf (undefined :: a) + +data Location = Location { lat :: Double + , lon :: Double } deriving (Eq, Generic, Show) + +data Tweet = Tweet { user :: Text + , postDate :: UTCTime + , message :: Text + , age :: Int + , location :: Location + , extra :: Maybe Text } + deriving (Eq, Generic, Show) + +instance ToJSON Tweet where + toJSON = genericToJSON defaultOptions +instance FromJSON Tweet where + parseJSON = genericParseJSON defaultOptions +instance ToJSON Location where + toJSON = genericToJSON defaultOptions +instance FromJSON Location where + parseJSON = genericParseJSON defaultOptions + +data ParentMapping = ParentMapping deriving (Eq, Show) + +instance ToJSON ParentMapping where + toJSON ParentMapping = + object ["properties" .= + object [ "user" .= object ["type" .= ("string" :: Text)] + -- Serializing the date as a date is breaking other tests, mysteriously. + -- , "postDate" .= object [ "type" .= ("date" :: Text) + -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)] + , "message" .= object ["type" .= ("string" :: Text)] + , "age" .= object ["type" .= ("integer" :: Text)] + , "location" .= object ["type" .= ("geo_point" :: Text)] + ]] + +data ChildMapping = ChildMapping deriving (Eq, Show) + +instance ToJSON ChildMapping where + toJSON ChildMapping = + object ["_parent" .= object ["type" .= ("parent" :: Text)] + , "properties" .= + object [ "user" .= object ["type" .= ("string" :: Text)] + -- Serializing the date as a date is breaking other tests, mysteriously. + -- , "postDate" .= object [ "type" .= ("date" :: Text) + -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)] + , "message" .= object ["type" .= ("string" :: Text)] + , "age" .= object ["type" .= ("integer" :: Text)] + , "location" .= object ["type" .= ("geo_point" :: Text)] + ]] + +data TweetMapping = TweetMapping deriving (Eq, Show) + +instance ToJSON TweetMapping where + toJSON TweetMapping = + object ["properties" .= + object [ "user" .= object ["type" .= ("string" :: Text)] + -- Serializing the date as a date is breaking other tests, mysteriously. + -- , "postDate" .= object [ "type" .= ("date" :: Text) + -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)] + , "message" .= object ["type" .= ("string" :: Text)] + , "age" .= object ["type" .= ("integer" :: Text)] + , "location" .= object ["type" .= ("geo_point" :: Text)] + ]] + +exampleTweet :: Tweet +exampleTweet = Tweet { user = "bitemyapp" + , postDate = UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 10) + , message = "Use haskell!" + , age = 10000 + , location = Location 40.12 (-71.34) + , extra = Nothing } + +tweetWithExtra :: Tweet +tweetWithExtra = Tweet { user = "bitemyapp" + , postDate = UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 10) + , message = "Use haskell!" + , age = 10000 + , location = Location 40.12 (-71.34) + , extra = Just "blah blah" } + +newAge :: Int +newAge = 31337 + +newUser :: Text +newUser = "someotherapp" + +tweetPatch :: Value +tweetPatch = + object [ "age" .= newAge + , "user" .= newUser + ] + +patchedTweet :: Tweet +patchedTweet = exampleTweet{age = newAge, user = newUser} + +otherTweet :: Tweet +otherTweet = Tweet { user = "notmyapp" + , postDate = UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 11) + , message = "Use haskell!" + , age = 1000 + , location = Location 40.12 (-71.34) + , extra = Nothing } + +resetIndex :: BH IO () +resetIndex = do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- putMapping testIndex testMapping TweetMapping + return () + +insertData :: BH IO Reply +insertData = do + resetIndex + insertData' defaultIndexDocumentSettings + +insertData' :: IndexDocumentSettings -> BH IO Reply +insertData' ids = do + r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1") + _ <- refreshIndex testIndex + return r + +updateData :: BH IO Reply +updateData = do + r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1") + _ <- refreshIndex testIndex + return r + +insertOther :: BH IO () +insertOther = do + _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2") + _ <- refreshIndex testIndex + return () + +insertExtra :: BH IO () +insertExtra = do + _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4") + _ <- refreshIndex testIndex + return () + +insertWithSpaceInId :: BH IO () +insertWithSpaceInId = do + _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World") + _ <- refreshIndex testIndex + return () + +searchTweet :: Search -> BH IO (Either EsError Tweet) +searchTweet search = do + result <- searchTweets search + let myTweet :: Either EsError Tweet + myTweet = grabFirst result + return myTweet + +searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet)) +searchTweets search = parseEsResponse =<< searchByIndex testIndex search + +searchExpectNoResults :: Search -> BH IO () +searchExpectNoResults search = do + result <- searchTweets search + let emptyHits = fmap (hits . searchHits) result + liftIO $ + emptyHits `shouldBe` Right [] + +searchExpectAggs :: Search -> BH IO () +searchExpectAggs search = do + reply <- searchByIndex testIndex search + let isEmpty x = return (M.null x) + let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) + liftIO $ + (result >>= aggregations >>= isEmpty) `shouldBe` Just False + +searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => + Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO () +searchValidBucketAgg search aggKey extractor = do + reply <- searchByIndex testIndex search + let bucketDocs = docCount . head . buckets + let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) + let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x) + liftIO $ + count `shouldBe` Just 1 + +searchTermsAggHint :: [ExecutionHint] -> BH IO () +searchTermsAggHint hints = do + let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint } + let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint + forM_ hints $ searchExpectAggs . search + forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms) + +searchTweetHighlight :: Search -> BH IO (Either EsError (Maybe HitHighlight)) +searchTweetHighlight search = do + result <- searchTweets search + let myHighlight = fmap (hitHighlight . head . hits . searchHits) result + return myHighlight + +searchExpectSource :: Source -> Either EsError Value -> BH IO () +searchExpectSource src expected = do + _ <- insertData + let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") + let search = (mkSearch (Just query) Nothing) { source = Just src } + reply <- searchByIndex testIndex search + result <- parseEsResponse reply + let value = grabFirst result + liftIO $ + value `shouldBe` expected + +withSnapshotRepo + :: ( MonadMask m + , MonadBH m + ) + => SnapshotRepoName + -> (GenericSnapshotRepo -> m a) + -> m a +withSnapshotRepo srn@(SnapshotRepoName n) f = do + repoPaths <- liftIO getRepoPaths + -- we'll use the first repo path if available, otherwise system temp + -- dir. Note that this will fail on ES > 1.6, so be sure you use + -- @when' canSnapshot@. + case repoPaths of + (firstRepoPath:_) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f + [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f + where + alloc dir = do + liftIO (setFileMode dir mode) + let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing + resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo + liftIO (validateStatus resp 200) + return (toGSnapshotRepo repo) + mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes + free GenericSnapshotRepo {..} = do + resp <- deleteSnapshotRepo gSnapshotRepoName + liftIO (validateStatus resp 200) + + +withSnapshot + :: ( MonadMask m + , MonadBH m + ) + => SnapshotRepoName + -> SnapshotName + -> m a + -> m a +withSnapshot srn sn = bracket_ alloc free + where + alloc = do + resp <- createSnapshot srn sn createSettings + liftIO (validateStatus resp 200) + -- We'll make this synchronous for testing purposes + createSettings = defaultSnapshotCreateSettings { snapWaitForCompletion = True + , snapIndices = Just (IndexList (testIndex :| [])) + -- We don't actually need to back up any data + } + free = do + deleteSnapshot srn sn + + + +data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show) +instance FromJSON BulkTest where + parseJSON = genericParseJSON defaultOptions +instance ToJSON BulkTest where + toJSON = genericToJSON defaultOptions + +class GApproxEq f where + gApproxEq :: f a -> f a -> Bool + +-- | Unit type +instance GApproxEq U1 where + gApproxEq U1 U1 = True + +-- | Sum type, ensure same constructors, recurse +instance (GApproxEq a, GApproxEq b) => GApproxEq (a :+: b) where + gApproxEq (L1 a) (L1 b) = gApproxEq a b + gApproxEq (R1 a) (R1 b) = gApproxEq a b + gApproxEq _ _ = False + +-- | Product type, ensure each field is approx eq +instance (GApproxEq a, GApproxEq b) => GApproxEq (a :*: b) where + gApproxEq (a1 :*: b1) (a2 :*: b2) = gApproxEq a1 a2 && gApproxEq b1 b2 + +-- | Value type, actually check the values for approx equality +instance (ApproxEq a) => GApproxEq (K1 i a) where + gApproxEq (K1 a) (K1 b) = a =~ b + +instance (GApproxEq f) => GApproxEq (M1 i t f) where + gApproxEq (M1 a) (M1 b) = gApproxEq a b + +-- | Typeclass for "equal where it matters". Use this to specify +-- less-strict equivalence for things such as lists that can wind up +-- in an unpredictable order +class ApproxEq a where + (=~) :: a -> a -> Bool + default (=~) :: (Generic a, GApproxEq (Rep a)) => a -> a -> Bool + a =~ b = gApproxEq (G.from a) (G.from b) + + showApproxEq :: a -> String + default showApproxEq :: (Show a) => a -> String + showApproxEq = show + +instance ApproxEq NominalDiffTime where (=~) = (==) +instance ApproxEq UTCTime where (=~) = (==) +instance ApproxEq Text where (=~) = (==) +instance ApproxEq Bool where (=~) = (==) +instance ApproxEq Int where (=~) = (==) +instance ApproxEq Double where (=~) = (==) +instance (ApproxEq a, Show a) => ApproxEq (NonEmpty a) +instance (ApproxEq a, Show a) => ApproxEq (Maybe a) +instance ApproxEq GeoPoint +instance ApproxEq Regexp +instance ApproxEq RangeValue +instance ApproxEq LessThan +instance ApproxEq LessThanEq +instance ApproxEq LessThanD +instance ApproxEq LessThanEqD +instance ApproxEq GreaterThan +instance ApproxEq GreaterThanEq +instance ApproxEq GreaterThanD +instance ApproxEq GreaterThanEqD +instance ApproxEq MinimumMatchHighLow +instance ApproxEq RegexpFlag +instance ApproxEq RegexpFlags +instance ApproxEq NullValue +instance ApproxEq Version +instance ApproxEq VersionNumber +instance ApproxEq DistanceRange +instance ApproxEq IndexName +instance ApproxEq MappingName +instance ApproxEq DocId +instance ApproxEq IndexAliasRouting +instance ApproxEq RoutingValue +instance ApproxEq ShardCount +instance ApproxEq ReplicaCount +instance ApproxEq TemplateName +instance ApproxEq TemplatePattern +instance ApproxEq QueryString +instance ApproxEq FieldName +instance ApproxEq CacheName +instance ApproxEq CacheKey +instance ApproxEq Existence +instance ApproxEq CutoffFrequency +instance ApproxEq Analyzer +instance ApproxEq Lenient +instance ApproxEq Tiebreaker +instance ApproxEq Boost +instance ApproxEq BoostTerms +instance ApproxEq MaxExpansions +instance ApproxEq MinimumMatch +instance ApproxEq DisableCoord +instance ApproxEq IgnoreTermFrequency +instance ApproxEq MinimumTermFrequency +instance ApproxEq MaxQueryTerms +instance ApproxEq Fuzziness +instance ApproxEq PrefixLength +instance ApproxEq TypeName +instance ApproxEq PercentMatch +instance ApproxEq StopWord +instance ApproxEq QueryPath +instance ApproxEq AllowLeadingWildcard +instance ApproxEq LowercaseExpanded +instance ApproxEq EnablePositionIncrements +instance ApproxEq AnalyzeWildcard +instance ApproxEq GeneratePhraseQueries +instance ApproxEq Locale +instance ApproxEq MaxWordLength +instance ApproxEq MinWordLength +instance ApproxEq PhraseSlop +instance ApproxEq MinDocFrequency +instance ApproxEq MaxDocFrequency +instance ApproxEq Filter +instance ApproxEq Query +instance ApproxEq SimpleQueryStringQuery +instance ApproxEq FieldOrFields +instance ApproxEq SimpleQueryFlag +instance ApproxEq RegexpQuery +instance ApproxEq QueryStringQuery +instance ApproxEq RangeQuery +instance ApproxEq PrefixQuery +instance ApproxEq NestedQuery +instance ApproxEq MoreLikeThisFieldQuery +instance ApproxEq MoreLikeThisQuery +instance ApproxEq IndicesQuery +instance ApproxEq HasParentQuery +instance ApproxEq HasChildQuery +instance ApproxEq FuzzyQuery +instance ApproxEq FuzzyLikeFieldQuery +instance ApproxEq FuzzyLikeThisQuery +instance ApproxEq FilteredQuery +instance ApproxEq DisMaxQuery +instance ApproxEq CommonTermsQuery +instance ApproxEq CommonMinimumMatch +instance ApproxEq BoostingQuery +instance ApproxEq BoolQuery +instance ApproxEq MatchQuery +instance ApproxEq MultiMatchQueryType +instance ApproxEq BooleanOperator +instance ApproxEq ZeroTermsQuery +instance ApproxEq MatchQueryType +instance ApproxEq AliasRouting +instance ApproxEq IndexAliasCreate +instance ApproxEq SearchAliasRouting +instance ApproxEq ScoreType +instance ApproxEq Distance +instance ApproxEq DistanceUnit +instance ApproxEq DistanceType +instance ApproxEq OptimizeBbox +instance ApproxEq GeoBoundingBoxConstraint +instance ApproxEq GeoFilterType +instance ApproxEq GeoBoundingBox +instance ApproxEq LatLon +instance ApproxEq RangeExecution +instance ApproxEq FSType +instance ApproxEq CompoundFormat +instance ApproxEq InitialShardCount +instance ApproxEq Bytes +instance ApproxEq ReplicaBounds +instance ApproxEq Term +instance ApproxEq BoolMatch +instance ApproxEq MultiMatchQuery +instance ApproxEq IndexSettings +instance ApproxEq AllocationPolicy +instance ApproxEq Char where + (=~) = (==) +instance ApproxEq Vers.Version where + (=~) = (==) +instance (ApproxEq a, Show a) => ApproxEq [a] where + as =~ bs = and (zipWith (=~) as bs) +instance (ApproxEq l, ApproxEq r) => ApproxEq (Either l r) where + Left a =~ Left b = a =~ b + Right a =~ Right b = a =~ b + _ =~ _ = False + showApproxEq (Left x) = "Left " <> showApproxEq x + showApproxEq (Right x) = "Right " <> showApproxEq x +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 +instance ApproxEq UpdatableIndexSetting where + RoutingAllocationInclude a =~ RoutingAllocationInclude b = + NE.sort a =~ NE.sort b + RoutingAllocationExclude a =~ RoutingAllocationExclude b = + NE.sort a =~ NE.sort b + RoutingAllocationRequire a =~ RoutingAllocationRequire b = + NE.sort a =~ NE.sort b + a =~ b = a == b + showApproxEq (RoutingAllocationInclude xs) = show (RoutingAllocationInclude (NE.sort xs)) + showApproxEq (RoutingAllocationExclude xs) = show (RoutingAllocationExclude (NE.sort xs)) + showApproxEq (RoutingAllocationRequire xs) = show (RoutingAllocationRequire (NE.sort xs)) + showApproxEq x = show x + + +noDuplicates :: Eq a => [a] -> Bool +noDuplicates xs = nub xs == xs + +instance Arbitrary NominalDiffTime where + arbitrary = fromInteger <$> arbitrary + +#if !MIN_VERSION_QuickCheck(2,8,0) +instance (Arbitrary k, Ord k, Arbitrary v) => Arbitrary (M.Map k v) where + arbitrary = M.fromList <$> arbitrary +#endif + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + +instance Arbitrary UTCTime where + arbitrary = UTCTime + <$> arbitrary + <*> (fromRational . toRational <$> choose (0::Double, 86400)) + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary + shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay + +#if !MIN_VERSION_QuickCheck(2,9,0) +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = liftA2 (:|) arbitrary arbitrary +#endif + +arbitraryScore :: Gen Score +arbitraryScore = fmap getPositive <$> arbitrary + +instance (Arbitrary a, Typeable a) => Arbitrary (Hit a) where + arbitrary = Hit <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryScore + <*> arbitrary + <*> arbitrary + shrink = genericShrink + + +instance (Arbitrary a, Typeable a) => Arbitrary (SearchHits a) where + arbitrary = reduceSize $ do + tot <- getPositive <$> arbitrary + score <- arbitraryScore + hs <- arbitrary + return $ SearchHits tot score hs + shrink = genericShrink + +reduceSize :: Gen a -> Gen a +reduceSize f = sized $ \n -> resize (n `div` 2) f + +getSource :: EsResult a -> Maybe a +getSource = fmap _source . foundResult + +grabFirst :: Either EsError (SearchResult a) -> Either EsError a +grabFirst r = + case fmap (hitSource . head . hits . searchHits) r of + (Left e) -> Left e + (Right Nothing) -> Left (EsError 500 "Source was missing") + (Right (Just x)) -> Right x + +------------------------------------------------------------------------------- +arbitraryAlphaNum :: Gen Char +arbitraryAlphaNum = oneof [choose ('a', 'z') + ,choose ('A','Z') + , choose ('0', '9')] + +instance Arbitrary RoutingValue where + arbitrary = RoutingValue . T.pack <$> listOf1 arbitraryAlphaNum + +instance Arbitrary AliasRouting where + arbitrary = oneof [allAlias + ,one + ,theOther + ,both] + where one = GranularAliasRouting + <$> (Just <$> arbitrary) + <*> pure Nothing + theOther = GranularAliasRouting Nothing + <$> (Just <$> arbitrary) + both = GranularAliasRouting + <$> (Just <$> arbitrary) + <*> (Just <$> arbitrary) + allAlias = AllAliasRouting <$> arbitrary + shrink = genericShrink + + +instance Arbitrary FieldName where + arbitrary = FieldName . T.pack <$> listOf1 arbitraryAlphaNum + shrink = genericShrink + + +instance Arbitrary RegexpFlags where + arbitrary = oneof [ pure AllRegexpFlags + , pure NoRegexpFlags + , SomeRegexpFlags <$> genUniqueFlags + ] + where genUniqueFlags = NE.fromList . nub <$> listOf1 arbitrary + shrink = genericShrink + + +instance Arbitrary IndexAliasCreate where + arbitrary = IndexAliasCreate <$> arbitrary <*> reduceSize arbitrary + shrink = genericShrink + +instance Arbitrary Query where + arbitrary = reduceSize $ oneof [ TermQuery <$> arbitrary <*> arbitrary + , TermsQuery <$> arbitrary <*> arbitrary + , QueryMatchQuery <$> arbitrary + , QueryMultiMatchQuery <$> arbitrary + , QueryBoolQuery <$> arbitrary + , QueryBoostingQuery <$> arbitrary + , QueryCommonTermsQuery <$> arbitrary + , ConstantScoreFilter <$> arbitrary <*> arbitrary + , ConstantScoreQuery <$> arbitrary <*> arbitrary + , QueryDisMaxQuery <$> arbitrary + , QueryFilteredQuery <$> arbitrary + , QueryFuzzyLikeThisQuery <$> arbitrary + , QueryFuzzyLikeFieldQuery <$> arbitrary + , QueryFuzzyQuery <$> arbitrary + , QueryHasChildQuery <$> arbitrary + , QueryHasParentQuery <$> arbitrary + , IdsQuery <$> arbitrary <*> arbitrary + , QueryIndicesQuery <$> arbitrary + , MatchAllQuery <$> arbitrary + , QueryMoreLikeThisQuery <$> arbitrary + , QueryMoreLikeThisFieldQuery <$> arbitrary + , QueryNestedQuery <$> arbitrary + , QueryPrefixQuery <$> arbitrary + , QueryQueryStringQuery <$> arbitrary + , QuerySimpleQueryStringQuery <$> arbitrary + , QueryRangeQuery <$> arbitrary + , QueryRegexpQuery <$> arbitrary + , QueryTemplateQueryInline <$> arbitrary + ] + shrink = genericShrink + +instance Arbitrary Filter where + arbitrary = reduceSize $ oneof [ AndFilter <$> arbitrary <*> arbitrary + , OrFilter <$> arbitrary <*> arbitrary + , NotFilter <$> arbitrary <*> arbitrary + , pure IdentityFilter + , BoolFilter <$> arbitrary + , ExistsFilter <$> arbitrary + , GeoBoundingBoxFilter <$> arbitrary + , GeoDistanceFilter <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , GeoDistanceRangeFilter <$> arbitrary <*> arbitrary + , GeoPolygonFilter <$> arbitrary <*> arbitrary + , IdsFilter <$> arbitrary <*> arbitrary + , LimitFilter <$> arbitrary + , MissingFilter <$> arbitrary <*> arbitrary <*> arbitrary + , PrefixFilter <$> arbitrary <*> arbitrary <*> arbitrary + , QueryFilter <$> arbitrary <*> arbitrary + , RangeFilter <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , RegexpFilter <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , TermFilter <$> arbitrary <*> arbitrary] + shrink = genericShrink + +instance Arbitrary ReplicaBounds where + arbitrary = oneof [ replicasBounded + , replicasLowerBounded + , pure ReplicasUnbounded + ] + where replicasBounded = do Positive a <- arbitrary + Positive b <- arbitrary + return (ReplicasBounded a b) + replicasLowerBounded = do Positive a <- arbitrary + return (ReplicasLowerBounded a) + +instance Arbitrary NodeAttrName where + arbitrary = NodeAttrName . T.pack <$> listOf1 arbitraryAlphaNum + + +instance Arbitrary NodeAttrFilter where + arbitrary = do + n <- arbitrary + s:ss <- listOf1 (listOf1 arbitraryAlphaNum) + let ts = T.pack <$> s :| ss + return (NodeAttrFilter n ts) + shrink = genericShrink + +instance Arbitrary VersionNumber where + arbitrary = mk . fmap getPositive . getNonEmpty <$> arbitrary + 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 +instance Arbitrary Version where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary BuildHash where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary IndexAliasRouting where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary ShardCount where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary ReplicaCount where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary TemplateName where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary TemplatePattern where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary QueryString where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary CacheName where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary CacheKey where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Existence where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary CutoffFrequency where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Analyzer where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MaxExpansions where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Lenient where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Tiebreaker where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Boost where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary BoostTerms where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MinimumMatch where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary DisableCoord where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary IgnoreTermFrequency where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MinimumTermFrequency where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MaxQueryTerms where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Fuzziness where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary PrefixLength where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary TypeName where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary PercentMatch where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary StopWord where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary QueryPath where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary AllowLeadingWildcard where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary LowercaseExpanded where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary EnablePositionIncrements where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary AnalyzeWildcard where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GeneratePhraseQueries where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Locale where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MaxWordLength where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MinWordLength where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary PhraseSlop where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MinDocFrequency where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MaxDocFrequency where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Regexp where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary SimpleQueryStringQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary FieldOrFields where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary SimpleQueryFlag where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary RegexpQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary QueryStringQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary RangeQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary RangeValue where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary PrefixQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary NestedQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MoreLikeThisFieldQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MoreLikeThisQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary IndicesQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary HasParentQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary HasChildQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary FuzzyQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary FuzzyLikeFieldQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary FuzzyLikeThisQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary FilteredQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary DisMaxQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary CommonTermsQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary DistanceRange where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MultiMatchQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary LessThanD where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary LessThanEqD where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GreaterThanD where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GreaterThanEqD where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary LessThan where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary LessThanEq where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GreaterThan where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GreaterThanEq where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GeoPoint where + arbitrary = GeoPoint <$> (arbitrary `suchThat` reasonableFieldName) <*> arbitrary + where + -- These are problematic for geopoint for obvious reasons + reasonableFieldName (FieldName "from") = False + reasonableFieldName (FieldName "to") = False + reasonableFieldName _ = True + shrink = genericShrink +instance Arbitrary NullValue where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MinimumMatchHighLow where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary CommonMinimumMatch where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary BoostingQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary BoolQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MatchQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MultiMatchQueryType where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary BooleanOperator where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary ZeroTermsQuery where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary MatchQueryType where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary SearchAliasRouting where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary ScoreType where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Distance where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary DistanceUnit where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary DistanceType where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary OptimizeBbox where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GeoBoundingBoxConstraint where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GeoFilterType where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary GeoBoundingBox where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary LatLon where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary RangeExecution where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary RegexpFlag where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary BoolMatch where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Term where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary IndexSettings where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary UpdatableIndexSetting where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary Bytes where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary AllocationPolicy where arbitrary = sopArbitrary; shrink = genericShrink +instance Arbitrary InitialShardCount where arbitrary = sopArbitrary; shrink = genericShrink +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) + +instance Arbitrary UpdatableIndexSetting' where + arbitrary = do + settings <- arbitrary + return $ UpdatableIndexSetting' $ case settings of + RoutingAllocationInclude xs -> RoutingAllocationInclude (dropDuplicateAttrNames xs) + RoutingAllocationExclude xs -> RoutingAllocationExclude (dropDuplicateAttrNames xs) + RoutingAllocationRequire xs -> RoutingAllocationRequire (dropDuplicateAttrNames xs) + x -> x + where + dropDuplicateAttrNames = NE.fromList . L.nubBy sameAttrName . NE.toList + sameAttrName a b = nodeAttrFilterName a == nodeAttrFilterName b + +main :: IO () +main = hspec $ do + + describe "index create/delete API" $ do + it "creates and then deletes the requested index" $ withTestEnv $ do + -- priming state. + _ <- deleteExampleIndex + resp <- createExampleIndex + deleteResp <- deleteExampleIndex + liftIO $ do + validateStatus resp 200 + validateStatus deleteResp 200 + + describe "error parsing" $ do + it "can parse EsErrors for < 2.0" $ when' (atmost es16) $ withTestEnv $ do + res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well") + let errorResp = eitherDecode (responseBody res) + liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]")) + + it "can parse EsErrors for >= 2.0" $ when' (atleast es20) $ withTestEnv $ do + res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well") + let errorResp = eitherDecode (responseBody res) + liftIO (errorResp `shouldBe` Right (EsError 404 "no such index")) + + describe "document API" $ do + it "indexes, updates, gets, and then deletes the generated document" $ withTestEnv $ do + _ <- insertData + _ <- updateData + docInserted <- getDocument testIndex testMapping (DocId "1") + let newTweet = eitherDecode + (responseBody docInserted) :: Either String (EsResult Tweet) + liftIO $ (fmap getSource newTweet `shouldBe` Right (Just patchedTweet)) + + it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do + _ <- insertWithSpaceInId + docInserted <- getDocument testIndex testMapping (DocId "Hello World") + let newTweet = eitherDecode + (responseBody docInserted) :: Either String (EsResult Tweet) + liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet)) + + it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do + doc <- getDocument testIndex testMapping (DocId "bogus") + let noTweet = eitherDecode + (responseBody doc) :: Either String (EsResult Tweet) + liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing + + it "can use optimistic concurrency control" $ withTestEnv $ do + let ev = ExternalDocVersion minBound + let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev } + resetIndex + res <- insertData' cfg + liftIO $ isCreated res `shouldBe` True + res' <- insertData' cfg + liftIO $ isVersionConflict res' `shouldBe` True + + it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do + resetIndex + _ <- putMapping testIndex (MappingName "child") ChildMapping + _ <- putMapping testIndex (MappingName "parent") ParentMapping + _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1") + let parent = (Just . DocumentParent . DocId) "1" + ids = IndexDocumentSettings NoVersionControl parent + _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2") + _ <- refreshIndex testIndex + exists <- documentExists testIndex (MappingName "child") parent (DocId "2") + liftIO $ exists `shouldBe` True + + describe "template API" $ do + it "can create a template" $ withTestEnv $ do + let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] + resp <- putTemplate idxTpl (TemplateName "tweet-tpl") + liftIO $ validateStatus resp 200 + + it "can detect if a template exists" $ withTestEnv $ do + exists <- templateExists (TemplateName "tweet-tpl") + liftIO $ exists `shouldBe` True + + it "can delete a template" $ withTestEnv $ do + resp <- deleteTemplate (TemplateName "tweet-tpl") + liftIO $ validateStatus resp 200 + + it "can detect if a template doesn't exist" $ withTestEnv $ do + exists <- templateExists (TemplateName "tweet-tpl") + liftIO $ exists `shouldBe` False + + describe "bulk API" $ do + it "inserts all documents we request" $ withTestEnv $ do + _ <- insertData + let firstTest = BulkTest "blah" + let secondTest = BulkTest "bloo" + let firstDoc = BulkIndex testIndex + testMapping (DocId "2") (toJSON firstTest) + let secondDoc = BulkCreate testIndex + testMapping (DocId "3") (toJSON secondTest) + let stream = V.fromList [firstDoc, secondDoc] + _ <- bulk stream + _ <- refreshIndex testIndex + fDoc <- getDocument testIndex testMapping (DocId "2") + sDoc <- getDocument testIndex testMapping (DocId "3") + let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest) + let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest) + liftIO $ do + fmap getSource maybeFirst `shouldBe` Right (Just firstTest) + fmap getSource maybeSecond `shouldBe` Right (Just secondTest) + + + describe "query API" $ do + it "returns document for term query and identity filter" $ withTestEnv $ do + _ <- insertData + let query = TermQuery (Term "user" "bitemyapp") Nothing + let filter = IdentityFilter <&&> IdentityFilter + let search = mkSearch (Just query) (Just filter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "handles constant score queries" $ withTestEnv $ do + _ <- insertData + let query = TermsQuery "user" ("bitemyapp" :| []) + let cfQuery = ConstantScoreQuery query (Boost 1.0) + let filter = IdentityFilter + let search = mkSearch (Just cfQuery) (Just filter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + it "handles constant score filters" $ withTestEnv $ do + _ <- insertData + let query = TermsQuery "user" ("bitemyapp" :| []) + let cfFilter = ConstantScoreFilter IdentityFilter (Boost 1.0) + let boolQuery = mkBoolQuery [query, cfFilter] [] [] + let search = mkSearch (Just (QueryBoolQuery boolQuery)) Nothing + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + + it "returns document for terms query and identity filter" $ withTestEnv $ do + _ <- insertData + let query = TermsQuery "user" ("bitemyapp" :| []) + let filter = IdentityFilter <&&> IdentityFilter + let search = mkSearch (Just query) (Just filter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for match query" $ withTestEnv $ do + _ <- insertData + let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp") + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for multi-match query" $ withTestEnv $ do + _ <- insertData + let flds = [FieldName "user", FieldName "message"] + let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp") + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + 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 $ + mkMatchQuery (FieldName "user") (QueryString "bitemyapp") + let query = QueryBoolQuery $ + mkBoolQuery [innerQuery] [] [] + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for boosting query" $ withTestEnv $ do + _ <- insertData + let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp") + let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp") + let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2) + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for common terms query" $ withTestEnv $ do + _ <- insertData + let query = QueryCommonTermsQuery $ + CommonTermsQuery (FieldName "user") + (QueryString "bitemyapp") + (CutoffFrequency 0.0001) + Or Or Nothing Nothing Nothing Nothing + let search = mkSearch (Just query) Nothing + myTweet <- searchTweet search + 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 + _ <- insertData + _ <- insertOther + let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending + 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 $ + myTweet `shouldBe` Right otherTweet + + + describe "filtering API" $ do + it "returns document for composed boolmatch and identity" $ withTestEnv $ do + _ <- insertData + let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False) + <&&> IdentityFilter + let search = mkSearch Nothing (Just queryFilter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for term filter" $ withTestEnv $ do + _ <- insertData + let termFilter = TermFilter (Term "user" "bitemyapp") False + let search = mkSearch Nothing (Just termFilter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for existential filter" $ withTestEnv $ do + _ <- insertData + let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user"))) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for geo boundingbox filter" $ withTestEnv $ do + _ <- insertData + let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12)) + let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory + let geoFilter = GeoBoundingBoxFilter bbConstraint + let search = mkSearch Nothing (Just geoFilter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "doesn't return document for nonsensical boundingbox filter" $ withTestEnv $ do + _ <- insertData + let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12)) + let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory + let geoFilter = GeoBoundingBoxFilter bbConstraint + let search = mkSearch Nothing (Just geoFilter) + searchExpectNoResults search + + it "returns document for geo distance filter" $ withTestEnv $ do + _ <- insertData + let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34)) + let distance = Distance 10.0 Miles + let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory + let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False + let search = mkSearch Nothing (Just geoFilter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for geo distance range filter" $ withTestEnv $ do + _ <- insertData + let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34)) + let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles) + let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange + let search = mkSearch Nothing (Just geoFilter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "doesn't return document for wild geo distance range filter" $ withTestEnv $ do + _ <- insertData + let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34)) + let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles) + let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange + let search = mkSearch Nothing (Just geoFilter) + searchExpectNoResults search + + it "returns document for geo polygon filter" $ withTestEnv $ do + _ <- insertData + let points = [LatLon 40.0 (-70.00), + LatLon 40.0 (-72.00), + LatLon 41.0 (-70.00), + LatLon 41.0 (-72.00)] + let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points + let search = mkSearch Nothing (Just geoFilter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "doesn't return document for bad geo polygon filter" $ withTestEnv $ do + _ <- insertData + let points = [LatLon 40.0 (-70.00), + LatLon 40.0 (-71.00), + LatLon 41.0 (-70.00), + LatLon 41.0 (-71.00)] + let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points + let search = mkSearch Nothing (Just geoFilter) + searchExpectNoResults search + + it "returns document for ids filter" $ withTestEnv $ do + _ <- insertData + let filter = IdsFilter (MappingName "tweet") [DocId "1"] + let search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for Double range filter" $ withTestEnv $ do + _ <- insertData + let filter = RangeFilter (FieldName "age") + (RangeDoubleGtLt (GreaterThan 1000.0) (LessThan 100000.0)) + RangeExecutionIndex False + let search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for UTCTime date filter" $ withTestEnv $ do + _ <- insertData + let filter = RangeFilter (FieldName "postDate") + (RangeDateGtLt + (GreaterThanD (UTCTime + (ModifiedJulianDay 54000) + (secondsToDiffTime 0))) + (LessThanD (UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 11)))) + RangeExecutionIndex False + let search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "returns document for regexp filter" $ withTestEnv $ do + _ <- insertData + let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app") + AllRegexpFlags (CacheName "test") False (CacheKey "key") + let search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "doesn't return document for non-matching regexp filter" $ withTestEnv $ do + _ <- insertData + let filter = RegexpFilter (FieldName "user") + (Regexp "boy") AllRegexpFlags + (CacheName "test") False (CacheKey "key") + let search = mkSearch Nothing (Just filter) + searchExpectNoResults search + + it "returns document for query filter, uncached" $ withTestEnv $ do + _ <- insertData + let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) True + search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + liftIO $ myTweet `shouldBe` Right exampleTweet + + it "returns document for query filter, cached" $ withTestEnv $ do + _ <- insertData + let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) False + search = mkSearch Nothing (Just filter) + myTweet <- searchTweet search + liftIO $ myTweet `shouldBe` Right exampleTweet + + describe "Aggregation API" $ do + it "returns term aggregation results" $ withTestEnv $ do + _ <- insertData + let terms = TermsAgg $ mkTermsAggregation "user" + let search = mkAggregateSearch Nothing $ mkAggregations "users" terms + searchExpectAggs search + searchValidBucketAgg search "users" toTerms + + it "return sub-aggregation results" $ withTestEnv $ do + _ <- insertData + let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation "age" + agg = TermsAgg $ (mkTermsAggregation "user") { termAggs = Just subaggs} + search = mkAggregateSearch Nothing $ mkAggregations "users" agg + reply <- searchByIndex testIndex search + let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) + usersAggResults = result >>= aggregations >>= toTerms "users" + subAggResults = usersAggResults >>= (listToMaybe . buckets) >>= termsAggs >>= toTerms "age_agg" + subAddResultsExists = isJust subAggResults + liftIO $ (subAddResultsExists) `shouldBe` True + + it "returns cardinality aggregation results" $ withTestEnv $ do + _ <- insertData + let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user" + let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality + let search' = search { Database.V1.Bloodhound.from = From 0, size = Size 0 } + searchExpectAggs search' + let docCountPair k n = (k, object ["value" .= Number n]) + res <- searchTweets search' + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "users" 1])) + + it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do + _ <- insertData + let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst } + let search = mkAggregateSearch Nothing $ mkAggregations "users" terms + searchExpectAggs search + searchValidBucketAgg search "users" toTerms + + -- One of these fails with 1.7.3 + it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do + _ <- insertData + searchTermsAggHint [Map, Ordinals] + + it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do + _ <- insertData + searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals] + + it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do + _ <- insertData + searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map] + -- One of the above. + + it "can execute value_count aggregations" $ withTestEnv $ do + _ <- insertData + _ <- insertOther + let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <> + mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus"))) + let search = mkAggregateSearch Nothing ags + let docCountPair k n = (k, object ["value" .= Number n]) + res <- searchTweets search + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2 + , docCountPair "bogus_count" 0 + ])) + + it "can execute filter aggregations" $ withTestEnv $ do + _ <- insertData + _ <- insertOther + let ags = mkAggregations "bitemyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "bitemyapp") defaultCache) Nothing)) <> + mkAggregations "notmyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "notmyapp") defaultCache) Nothing)) + let search = mkAggregateSearch Nothing ags + let docCountPair k n = (k, object ["doc_count" .= Number n]) + res <- searchTweets search + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1 + , docCountPair "notmyapps" 1 + ])) + it "can execute date_range aggregations" $ withTestEnv $ do + let now = fromGregorian 2015 3 14 + let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0 + let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0 + let oldDoc = exampleTweet { postDate = ltAMonthAgo } + let newDoc = exampleTweet { postDate = ltAWeekAgo } + _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings oldDoc (DocId "1") + _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings newDoc (DocId "2") + _ <- refreshIndex testIndex + let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth]) + let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek]) + let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek]) + let ags = mkAggregations "date_ranges" (DateRangeAgg agg) + let search = mkAggregateSearch Nothing ags + res <- searchTweets search + liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right 2 + let bucks = do magrs <- fmapL show (aggregations <$> res) + agrs <- note "no aggregations returned" magrs + rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs + parseEither parseJSON rawBucks + let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0 + let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0 + liftIO $ buckets <$> bucks `shouldBe` Right [ DateRangeResult "2015-02-14T00:00:00.000Z-*" + (Just fromMonthT) + (Just "2015-02-14T00:00:00.000Z") + Nothing + Nothing + 2 + Nothing + , DateRangeResult "2015-03-07T00:00:00.000Z-*" + (Just fromWeekT) + (Just "2015-03-07T00:00:00.000Z") + Nothing + Nothing + 1 + Nothing + ] + + it "returns date histogram aggregation results" $ withTestEnv $ do + _ <- insertData + let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute + let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram) + searchExpectAggs search + searchValidBucketAgg search "byDate" toDateHistogram + + it "returns date histogram using fractional date" $ withTestEnv $ do + _ <- insertData + let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second] + let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds] + let intervals = periods ++ fractionals + let histogram = mkDateHistogram (FieldName "postDate") + let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval) + let expect interval = searchExpectAggs (search interval) + let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram + forM_ intervals expect + forM_ intervals valid + + it "can execute missing aggregations" $ withTestEnv $ do + _ <- insertData + _ <- insertExtra + let ags = mkAggregations "missing_agg" (MissingAgg (MissingAggregation "extra")) + let search = mkAggregateSearch Nothing ags + let docCountPair k n = (k, object ["doc_count" .= Number n]) + res <- searchTweets search + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "missing_agg" 1])) + + describe "Highlights API" $ do + + it "returns highlight from query when there should be one" $ withTestEnv $ do + _ <- insertData + _ <- insertOther + let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") + let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] + + let search = mkHighlightSearch (Just query) testHighlight + myHighlight <- searchTweetHighlight search + liftIO $ + myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use haskell!"])])) + + it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do + _ <- insertData + _ <- insertOther + let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") + let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing] + + let search = mkHighlightSearch (Just query) testHighlight + myHighlight <- searchTweetHighlight search + liftIO $ + myHighlight `shouldBe` Right Nothing + + describe "Source filtering" $ do + + it "doesn't include source when sources are disabled" $ withTestEnv $ do + searchExpectSource + NoSource + (Left (EsError 500 "Source was missing")) + + it "includes a source" $ withTestEnv $ do + searchExpectSource + (SourcePatterns (PopPattern (Pattern "message"))) + (Right (Object (HM.fromList [("message", String "Use haskell!")]))) + + it "includes sources" $ withTestEnv $ do + searchExpectSource + (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"])) + (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")]))) + + it "includes source patterns" $ withTestEnv $ do + searchExpectSource + (SourcePatterns (PopPattern (Pattern "*ge"))) + (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")]))) + + it "excludes source patterns" $ withTestEnv $ do + searchExpectSource + (SourceIncludeExclude (Include []) + (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"])) + (Right (Object (HM.fromList [("user",String "bitemyapp")]))) + + describe "ToJSON RegexpFlags" $ do + it "generates the correct JSON for AllRegexpFlags" $ + toJSON AllRegexpFlags `shouldBe` String "ALL" + + it "generates the correct JSON for NoRegexpFlags" $ + toJSON NoRegexpFlags `shouldBe` String "NONE" + + it "generates the correct JSON for SomeRegexpFlags" $ + let flags = AnyString :| [ Automaton + , Complement + , Empty + , Intersection + , Interval ] + in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL" + + prop "removes duplicates from flags" $ \(flags :: RegexpFlags) -> + let String str = toJSON flags + flagStrs = T.splitOn "|" str + in noDuplicates flagStrs + + describe "omitNulls" $ do + it "checks that omitNulls drops list elements when it should" $ + let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int])) + , "test2" .= (toJSON ("some value" :: Text))] + in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")]) + + it "checks that omitNulls doesn't drop list elements when it shouldn't" $ + let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int])) + , "test2" .= (toJSON ("some value" :: Text))] + in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0])) + , ("test2", String "some value")]) + it "checks that omitNulls drops non list elements when it should" $ + let dropped = omitNulls $ [ "test1" .= (toJSON Null) + , "test2" .= (toJSON ("some value" :: Text))] + in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")]) + it "checks that omitNulls doesn't drop non list elements when it shouldn't" $ + let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int)) + , "test2" .= (toJSON ("some value" :: Text))] + in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0) + , ("test2", String "some value")]) + describe "Monoid (SearchHits a)" $ do + prop "abides the monoid laws" $ eq $ + prop_Monoid (T :: T (SearchHits ())) + + describe "mkDocVersion" $ do + prop "can never construct an out of range docVersion" $ \i -> + let res = mkDocVersion i + in case res of + Nothing -> property True + Just dv -> (dv >= minBound) .&&. + (dv <= maxBound) .&&. + docVersionNumber dv === i + + describe "FsSnapshotRepo" $ do + prop "SnapshotRepo laws" $ \fsr -> + fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo) + + describe "snapshot repos" $ do + it "always parses all snapshot repos API" $ when' canSnapshot $ withTestEnv $ do + res <- getSnapshotRepos AllSnapshotRepos + liftIO $ case res of + Left e -> expectationFailure ("Expected a right but got Left " <> show e) + Right _ -> return () + + it "finds an existing list of repos" $ when' canSnapshot $ withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + let r2n = SnapshotRepoName "bloodhound-repo2" + withSnapshotRepo r1n $ \r1 -> + withSnapshotRepo r2n $ \r2 -> do + repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n])) + liftIO $ case repos of + Right xs -> do + let srt = L.sortBy (comparing gSnapshotRepoName) + srt xs `shouldBe` srt [r1, r2] + Left e -> expectationFailure (show e) + + it "creates and updates with updateSnapshotRepo" $ when' canSnapshot $ withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \r1 -> do + let Just (String dir) = HM.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1)) + let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing + resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression + liftIO (validateStatus resp 200) + Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [])) + liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression) + + -- verify came around in 1.4 it seems + it "can verify existing repos" $ when' canSnapshot $ when' (atleast es14) $ withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \_ -> do + res <- verifySnapshotRepo r1n + liftIO $ case res of + Right (SnapshotVerification vs) + | null vs -> expectationFailure "Expected nonempty set of verifying nodes" + | otherwise -> return () + Left e -> expectationFailure (show e) + + describe "snapshots" $ do + it "always parses all snapshots API" $ when' canSnapshot $ withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \_ -> do + res <- getSnapshots r1n AllSnapshots + liftIO $ case res of + Left e -> expectationFailure ("Expected a right but got Left " <> show e) + Right _ -> return () + + it "can parse a snapshot that it created" $ when' canSnapshot $ withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \_ -> do + let s1n = SnapshotName "example-snapshot" + withSnapshot r1n s1n $ do + res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| [])) + liftIO $ case res of + Right [snap] + | snapInfoState snap == SnapshotSuccess && + snapInfoName snap == s1n -> return () + | otherwise -> expectationFailure (show snap) + Right [] -> expectationFailure "There were no snapshots" + Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps)) + Left e -> expectationFailure (show e) + + describe "snapshot restore" $ do + it "can restore a snapshot that we create" $ when' canSnapshot $ withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \_ -> do + let s1n = SnapshotName "example-snapshot" + withSnapshot r1n s1n $ do + let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True } + -- have to close an index to restore it + resp1 <- closeIndex testIndex + liftIO (validateStatus resp1 200) + resp2 <- restoreSnapshot r1n s1n settings + liftIO (validateStatus resp2 200) + + it "can restore and rename" $ when' canSnapshot $ withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \_ -> do + let s1n = SnapshotName "example-snapshot" + withSnapshot r1n s1n $ do + let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)" + let replace = RRTLit "restored-" :| [RRSubWholeMatch] + let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1" + oldEnoughForOverrides <- liftIO (atleast es15) + let overrides = RestoreIndexSettings { restoreOverrideReplicas = Just (ReplicaCount 0) } + let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True + , snapRestoreRenamePattern = Just pat + , snapRestoreRenameReplacement = Just replace + , snapRestoreIndexSettingsOverrides = if oldEnoughForOverrides + then Just overrides + else Nothing + } + -- have to close an index to restore it + let go = do + resp <- restoreSnapshot r1n s1n settings + liftIO (validateStatus resp 200) + exists <- indexExists expectedIndex + liftIO (exists `shouldBe` True) + go `finally` deleteIndex expectedIndex + + describe "getNodesInfo" $ do + it "fetches the responding node when LocalNode is used" $ withTestEnv $ do + res <- getNodesInfo LocalNode + liftIO $ case res of + -- This is really just a smoke test for response + -- parsing. Node info is so variable, there's not much I can + -- assert here. + Right NodesInfo {..} -> length nodesInfo `shouldBe` 1 + Left e -> expectationFailure ("Expected NodesInfo but got " <> show e) + + describe "getNodesStats" $ do + it "fetches the responding node when LocalNode is used" $ withTestEnv $ do + res <- getNodesStats LocalNode + liftIO $ case res of + -- This is really just a smoke test for response + -- parsing. Node stats is so variable, there's not much I can + -- assert here. + Right NodesStats {..} -> length nodesStats `shouldBe` 1 + Left e -> expectationFailure ("Expected NodesStats but got " <> show e) + + describe "Enum DocVersion" $ do + it "follows the laws of Enum, Bounded" $ do + evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall + evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall + evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall + evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall + enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound] + enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound] + enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound] + + describe "scan&scroll API" $ do + it "returns documents using the scan&scroll API" $ withTestEnv $ do + _ <- insertData + _ <- insertOther + let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) } + regular_search <- searchTweet search + scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet] + let scan_search = map hitSource scan_search' + liftIO $ + regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored + liftIO $ + scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet] + + describe "index aliases" $ do + it "handles the simple case of aliasing an existing index" $ do + let alias = IndexAlias (testIndex) (IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias")) + let create = IndexAliasCreate Nothing Nothing + let action = AddAlias alias create + + withTestEnv $ do + resetIndex + resp <- updateIndexAliases (action :| []) + liftIO $ validateStatus resp 200 + let cleanup = withTestEnv (updateIndexAliases (RemoveAlias alias :| [])) + (do aliases <- withTestEnv getIndexAliases + let expected = IndexAliasSummary alias create + case aliases of + Right (IndexAliasesSummary summs) -> + L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected + Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup + + it "handles an alias with routing and a filter" $ do + let alias = IndexAlias (testIndex) (IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias")) + let sar = SearchAliasRouting (RoutingValue "search val" :| []) + let iar = IndexAliasRouting (RoutingValue "index val") + let routing = GranularAliasRouting (Just sar) (Just iar) + let filter = LimitFilter 42 + let create = IndexAliasCreate (Just routing) (Just filter) + let action = AddAlias alias create + + withTestEnv $ do + resetIndex + resp <- updateIndexAliases (action :| []) + liftIO $ validateStatus resp 200 + let cleanup = withTestEnv (updateIndexAliases (RemoveAlias alias :| [])) + (do aliases <- withTestEnv getIndexAliases + let expected = IndexAliasSummary alias create + case aliases of + Right (IndexAliasesSummary summs) -> + L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected + Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup + + describe "Index Listing" $ do + it "returns a list of index names" $ withTestEnv $ do + _ <- createExampleIndex + ixns <- listIndices + liftIO (ixns `shouldContain` [testIndex]) + + describe "Index Settings" $ do + it "persists settings" $ withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = BlocksWrite False :| [] + updateResp <- updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + getResp <- getIndexSettings testIndex + liftIO $ + getResp `shouldBe` Right (IndexSettingsSummary + testIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0)) + (NE.toList updates)) + + describe "Index Optimization" $ do + it "returns a successful response upon completion" $ withTestEnv $ do + _ <- createExampleIndex + 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) + propJSON (Proxy :: Proxy MappingName) + propJSON (Proxy :: Proxy DocId) + propJSON (Proxy :: Proxy IndexAliasRouting) + propJSON (Proxy :: Proxy RoutingValue) + propJSON (Proxy :: Proxy ShardCount) + propJSON (Proxy :: Proxy ReplicaCount) + propJSON (Proxy :: Proxy TemplateName) + propJSON (Proxy :: Proxy TemplatePattern) + propJSON (Proxy :: Proxy QueryString) + propJSON (Proxy :: Proxy FieldName) + propJSON (Proxy :: Proxy CacheName) + propJSON (Proxy :: Proxy CacheKey) + propJSON (Proxy :: Proxy Existence) + propJSON (Proxy :: Proxy CutoffFrequency) + propJSON (Proxy :: Proxy Analyzer) + propJSON (Proxy :: Proxy MaxExpansions) + propJSON (Proxy :: Proxy Lenient) + propJSON (Proxy :: Proxy Tiebreaker) + propJSON (Proxy :: Proxy Boost) + propJSON (Proxy :: Proxy BoostTerms) + propJSON (Proxy :: Proxy MinimumMatch) + propJSON (Proxy :: Proxy DisableCoord) + propJSON (Proxy :: Proxy IgnoreTermFrequency) + propJSON (Proxy :: Proxy MinimumTermFrequency) + propJSON (Proxy :: Proxy MaxQueryTerms) + propJSON (Proxy :: Proxy Fuzziness) + propJSON (Proxy :: Proxy PrefixLength) + propJSON (Proxy :: Proxy TypeName) + propJSON (Proxy :: Proxy PercentMatch) + propJSON (Proxy :: Proxy StopWord) + propJSON (Proxy :: Proxy QueryPath) + propJSON (Proxy :: Proxy AllowLeadingWildcard) + propJSON (Proxy :: Proxy LowercaseExpanded) + propJSON (Proxy :: Proxy EnablePositionIncrements) + propJSON (Proxy :: Proxy AnalyzeWildcard) + propJSON (Proxy :: Proxy GeneratePhraseQueries) + propJSON (Proxy :: Proxy Locale) + propJSON (Proxy :: Proxy MaxWordLength) + propJSON (Proxy :: Proxy MinWordLength) + propJSON (Proxy :: Proxy PhraseSlop) + propJSON (Proxy :: Proxy MinDocFrequency) + propJSON (Proxy :: Proxy MaxDocFrequency) + propJSON (Proxy :: Proxy Filter) + propJSON (Proxy :: Proxy Query) + propJSON (Proxy :: Proxy SimpleQueryStringQuery) + propJSON (Proxy :: Proxy FieldOrFields) + propJSON (Proxy :: Proxy SimpleQueryFlag) + propJSON (Proxy :: Proxy RegexpQuery) + propJSON (Proxy :: Proxy QueryStringQuery) + propJSON (Proxy :: Proxy RangeQuery) + propJSON (Proxy :: Proxy PrefixQuery) + propJSON (Proxy :: Proxy NestedQuery) + propJSON (Proxy :: Proxy MoreLikeThisFieldQuery) + propJSON (Proxy :: Proxy MoreLikeThisQuery) + propJSON (Proxy :: Proxy IndicesQuery) + propJSON (Proxy :: Proxy HasParentQuery) + propJSON (Proxy :: Proxy HasChildQuery) + propJSON (Proxy :: Proxy FuzzyQuery) + propJSON (Proxy :: Proxy FuzzyLikeFieldQuery) + propJSON (Proxy :: Proxy FuzzyLikeThisQuery) + propJSON (Proxy :: Proxy FilteredQuery) + propJSON (Proxy :: Proxy DisMaxQuery) + propJSON (Proxy :: Proxy CommonTermsQuery) + propJSON (Proxy :: Proxy CommonMinimumMatch) + propJSON (Proxy :: Proxy BoostingQuery) + propJSON (Proxy :: Proxy BoolQuery) + propJSON (Proxy :: Proxy MatchQuery) + propJSON (Proxy :: Proxy MultiMatchQueryType) + propJSON (Proxy :: Proxy BooleanOperator) + propJSON (Proxy :: Proxy ZeroTermsQuery) + propJSON (Proxy :: Proxy MatchQueryType) + propJSON (Proxy :: Proxy AliasRouting) + propJSON (Proxy :: Proxy IndexAliasCreate) + propJSON (Proxy :: Proxy SearchAliasRouting) + propJSON (Proxy :: Proxy ScoreType) + propJSON (Proxy :: Proxy Distance) + propJSON (Proxy :: Proxy DistanceUnit) + propJSON (Proxy :: Proxy DistanceType) + propJSON (Proxy :: Proxy OptimizeBbox) + propJSON (Proxy :: Proxy GeoBoundingBoxConstraint) + propJSON (Proxy :: Proxy GeoFilterType) + propJSON (Proxy :: Proxy GeoBoundingBox) + propJSON (Proxy :: Proxy LatLon) + propJSON (Proxy :: Proxy RangeExecution) + prop "RegexpFlags FromJSON/ToJSON roundtrips, removing dups " $ \rfs -> + let expected = case rfs of + SomeRegexpFlags fs -> SomeRegexpFlags (NE.fromList (nub (NE.toList fs))) + x -> x + in parseEither parseJSON (toJSON rfs) === Right expected + propJSON (Proxy :: Proxy BoolMatch) + propJSON (Proxy :: Proxy Term) + propJSON (Proxy :: Proxy MultiMatchQuery) + propJSON (Proxy :: Proxy IndexSettings) + propJSON (Proxy :: Proxy UpdatableIndexSetting') + propJSON (Proxy :: Proxy ReplicaBounds) + propJSON (Proxy :: Proxy Bytes) + propJSON (Proxy :: Proxy AllocationPolicy) + 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 +-- +-- This will be unneeded after https://github.com/nick8325/quickcheck/pull/112 +-- is merged and released +sopArbitrary :: forall a. (Generic a, SOP.GTo a, SOP.All SOP.SListI (SOP.GCode a), SOP.All2 Arbitrary (SOP.GCode a)) => Gen a +sopArbitrary = fmap SOP.gto sopArbitrary' + +sopArbitrary' :: forall xss. (SOP.All SOP.SListI xss, SOP.All2 Arbitrary xss) => Gen (SOP.SOP SOP.I xss) +sopArbitrary' = SOP.hsequence =<< elements (SOP.apInjs_POP $ SOP.hcpure p arbitrary) + where + p :: Proxy Arbitrary + p = Proxy diff --git a/tests/V5/tests.hs b/tests/V5/tests.hs --- a/tests/V5/tests.hs +++ b/tests/V5/tests.hs @@ -12,6 +12,9 @@ #if __GLASGOW_HASKELL__ < 800 {-# OPTIONS_GHC -fcontext-stack=100 #-} #endif +#if __GLASGOW_HASKELL__ >= 802 +{-# LANGUAGE MonoLocalBinds #-} +#endif module Main where import Control.Applicative @@ -607,6 +610,15 @@ 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 +768,7 @@ , QuerySimpleQueryStringQuery <$> arbitrary , QueryRangeQuery <$> arbitrary , QueryRegexpQuery <$> arbitrary + , QueryTemplateQueryInline <$> arbitrary ] shrink = genericShrink @@ -791,6 +804,10 @@ 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 +915,13 @@ 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) @@ -1004,20 +1028,26 @@ _ <- insertData let firstTest = BulkTest "blah" let secondTest = BulkTest "bloo" + let thirdTest = BulkTest "graffle" let firstDoc = BulkIndex testIndex testMapping (DocId "2") (toJSON firstTest) let secondDoc = BulkCreate testIndex testMapping (DocId "3") (toJSON secondTest) - let stream = V.fromList [firstDoc, secondDoc] + let thirdDoc = BulkCreateEncoding testIndex + testMapping (DocId "4") (toEncoding thirdTest) + let stream = V.fromList [firstDoc, secondDoc, thirdDoc] _ <- bulk stream _ <- refreshIndex testIndex fDoc <- getDocument testIndex testMapping (DocId "2") sDoc <- getDocument testIndex testMapping (DocId "3") + tDoc <- getDocument testIndex testMapping (DocId "4") let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest) let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest) + let maybeThird = eitherDecode $ responseBody tDoc :: Either String (EsResult BulkTest) liftIO $ do fmap getSource maybeFirst `shouldBe` Right (Just firstTest) fmap getSource maybeSecond `shouldBe` Right (Just secondTest) + fmap getSource maybeThird `shouldBe` Right (Just thirdTest) describe "query API" $ do @@ -1066,6 +1096,17 @@ 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,7 +1140,22 @@ 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 _ <- insertData @@ -1108,6 +1164,7 @@ 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 $ @@ -1503,11 +1560,11 @@ scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet] describe "index aliases" $ do + let aname = IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias") + let alias = IndexAlias (testIndex) aname + let create = IndexAliasCreate Nothing Nothing + let action = AddAlias alias create it "handles the simple case of aliasing an existing index" $ do - let alias = IndexAlias (testIndex) (IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias")) - let create = IndexAliasCreate Nothing Nothing - let action = AddAlias alias create - withTestEnv $ do resetIndex resp <- updateIndexAliases (action :| []) @@ -1519,6 +1576,18 @@ Right (IndexAliasesSummary summs) -> L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup + it "allows alias deletion" $ do + aliases <- withTestEnv $ do + resetIndex + resp <- updateIndexAliases (action :| []) + liftIO $ validateStatus resp 200 + deleteIndexAlias aname + getIndexAliases + let expected = IndexAliasSummary alias create + case aliases of + Right (IndexAliasesSummary summs) -> + L.find ((== aname) . indexAlias . indexAliasSummaryAlias) summs `shouldBe` Nothing + Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e) describe "Index Listing" $ do it "returns a list of index names" $ withTestEnv $ do @@ -1540,12 +1609,40 @@ (IndexSettings (ShardCount 1) (ReplicaCount 0)) (NE.toList updates)) + it "allows total fields to be set" $ when' (atleast es50) $ withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = MappingTotalFieldsLimit 2500 :| [] + updateResp <- updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + getResp <- getIndexSettings testIndex + liftIO $ + getResp `shouldBe` Right (IndexSettingsSummary + testIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0)) + (NE.toList updates)) + describe "Index Optimization" $ do it "returns a successful response upon completion" $ withTestEnv $ do _ <- createExampleIndex 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 +1745,8 @@ 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