mirror of
https://github.com/typeable/bloodhound.git
synced 2024-09-11 08:25:32 +03:00
V1 refactor building and passing tests now
I may have screwed up the arbitrary, I'm occasionally seeing a massive quickcheck error on some json roundtrip that clearly does not shrink properly. Otherwise things are compiling and seem to be working. I made no real effort to rearrange the massive amounts of code shifted around into a tidy order. Nobody really cares about V1 anymore so I'm not too concerned.
This commit is contained in:
parent
99788cc992
commit
14379a3c5a
@ -30,7 +30,7 @@ Flag ES1
|
|||||||
Flag ES5
|
Flag ES5
|
||||||
Description: Run the test suite against an Elasticsearch 5.x server
|
Description: Run the test suite against an Elasticsearch 5.x server
|
||||||
Default: True
|
Default: True
|
||||||
|
|
||||||
library
|
library
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
exposed-modules: Database.V5.Bloodhound
|
exposed-modules: Database.V5.Bloodhound
|
||||||
@ -51,16 +51,15 @@ library
|
|||||||
Database.V1.Bloodhound.Client
|
Database.V1.Bloodhound.Client
|
||||||
Database.V1.Bloodhound.Types
|
Database.V1.Bloodhound.Types
|
||||||
Database.V1.Bloodhound.Types.Class
|
Database.V1.Bloodhound.Types.Class
|
||||||
|
Database.V1.Bloodhound.Internal.Aggregation
|
||||||
-- Database.V1.Bloodhound.Internal.Aggregation
|
Database.V1.Bloodhound.Internal.Client
|
||||||
-- Database.V1.Bloodhound.Internal.Analysis
|
Database.V1.Bloodhound.Internal.Highlight
|
||||||
-- Database.V1.Bloodhound.Internal.Client
|
Database.V1.Bloodhound.Internal.Newtypes
|
||||||
-- Database.V1.Bloodhound.Internal.Highlight
|
Database.V1.Bloodhound.Internal.Query
|
||||||
-- Database.V1.Bloodhound.Internal.Newtypes
|
Database.V1.Bloodhound.Internal.Sort
|
||||||
-- Database.V1.Bloodhound.Internal.Query
|
|
||||||
-- Database.V1.Bloodhound.Internal.Sort
|
|
||||||
Database.V1.Bloodhound.Internal.StringlyTyped
|
Database.V1.Bloodhound.Internal.StringlyTyped
|
||||||
-- Database.V1.Bloodhound.Internal.Suggest
|
Database.V1.Bloodhound.Internal.Suggest
|
||||||
|
|
||||||
other-modules: Bloodhound.Import
|
other-modules: Bloodhound.Import
|
||||||
Database.Bloodhound.Common.Script
|
Database.Bloodhound.Common.Script
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
@ -103,7 +102,6 @@ test-suite bloodhound-tests
|
|||||||
Test.Indices
|
Test.Indices
|
||||||
Test.JSON
|
Test.JSON
|
||||||
Test.Query
|
Test.Query
|
||||||
Test.Script
|
|
||||||
Test.Snapshots
|
Test.Snapshots
|
||||||
Test.Sorting
|
Test.Sorting
|
||||||
Test.SourceFiltering
|
Test.SourceFiltering
|
||||||
|
@ -8,6 +8,7 @@ module Bloodhound.Import
|
|||||||
, readMay
|
, readMay
|
||||||
, showText
|
, showText
|
||||||
, deleteSeveral
|
, deleteSeveral
|
||||||
|
, oPath
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative as X (Alternative (..), optional)
|
import Control.Applicative as X (Alternative (..), optional)
|
||||||
@ -74,3 +75,7 @@ parseNEJSON (x:xs) = DT.mapM parseJSON (x :| xs)
|
|||||||
|
|
||||||
deleteSeveral :: (Eq k, Hashable k) => [k] -> HM.HashMap k v -> HM.HashMap k v
|
deleteSeveral :: (Eq k, Hashable k) => [k] -> HM.HashMap k v -> HM.HashMap k v
|
||||||
deleteSeveral ks hm = foldr HM.delete hm ks
|
deleteSeveral ks hm = foldr HM.delete hm ks
|
||||||
|
|
||||||
|
oPath :: ToJSON a => NonEmpty Text -> a -> Value
|
||||||
|
oPath (k :| []) v = object [k .= v]
|
||||||
|
oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]
|
||||||
|
@ -1,14 +1,16 @@
|
|||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Database.V1.Bloodhound.Internal.Aggregation where
|
module Database.V1.Bloodhound.Internal.Aggregation where
|
||||||
|
|
||||||
import Bloodhound.Import
|
import Bloodhound.Import
|
||||||
|
|
||||||
import qualified Data.HashMap.Strict as HM
|
import qualified Data.HashMap.Strict as HM
|
||||||
import qualified Data.Map.Strict as M
|
import qualified Data.Map.Strict as M
|
||||||
import Data.Text
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
|
import Database.V1.Bloodhound.Internal.Client
|
||||||
|
import Database.V1.Bloodhound.Internal.Highlight (HitHighlight)
|
||||||
import Database.V1.Bloodhound.Internal.Newtypes
|
import Database.V1.Bloodhound.Internal.Newtypes
|
||||||
import Database.V1.Bloodhound.Internal.Query
|
import Database.V1.Bloodhound.Internal.Query
|
||||||
import Database.V1.Bloodhound.Internal.Sort
|
import Database.V1.Bloodhound.Internal.Sort
|
||||||
@ -88,7 +90,7 @@ data TopHitsAggregation = TopHitsAggregation
|
|||||||
{ taFrom :: Maybe From
|
{ taFrom :: Maybe From
|
||||||
, taSize :: Maybe Size
|
, taSize :: Maybe Size
|
||||||
, taSort :: Maybe Sort
|
, taSort :: Maybe Sort
|
||||||
} deriving (Eq, Read, Show)
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
data MissingAggregation = MissingAggregation
|
data MissingAggregation = MissingAggregation
|
||||||
{ maField :: Text
|
{ maField :: Text
|
||||||
@ -224,3 +226,191 @@ data DateMathUnit =
|
|||||||
| DMMinute
|
| DMMinute
|
||||||
| DMSecond
|
| DMSecond
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
data CollectionMode = BreadthFirst
|
||||||
|
| DepthFirst deriving (Eq, Show)
|
||||||
|
|
||||||
|
type AggregationResults = M.Map Text Value
|
||||||
|
|
||||||
|
class BucketAggregation a where
|
||||||
|
key :: a -> BucketValue
|
||||||
|
docCount :: a -> Int
|
||||||
|
aggs :: a -> Maybe AggregationResults
|
||||||
|
|
||||||
|
data BucketValue = TextValue Text
|
||||||
|
| ScientificValue Scientific
|
||||||
|
| BoolValue Bool deriving (Show)
|
||||||
|
|
||||||
|
data Bucket a = Bucket { buckets :: [a]} deriving (Show)
|
||||||
|
|
||||||
|
data TermsResult = TermsResult { termKey :: BucketValue
|
||||||
|
, termsDocCount :: Int
|
||||||
|
, termsAggs :: Maybe AggregationResults } deriving (Show)
|
||||||
|
|
||||||
|
data DateHistogramResult = DateHistogramResult { dateKey :: Int
|
||||||
|
, dateKeyStr :: Maybe Text
|
||||||
|
, dateDocCount :: Int
|
||||||
|
, dateHistogramAggs :: Maybe AggregationResults } deriving (Show)
|
||||||
|
|
||||||
|
data DateRangeResult = DateRangeResult { dateRangeKey :: Text
|
||||||
|
, dateRangeFrom :: Maybe UTCTime
|
||||||
|
, dateRangeFromAsString :: Maybe Text
|
||||||
|
, dateRangeTo :: Maybe UTCTime
|
||||||
|
, dateRangeToAsString :: Maybe Text
|
||||||
|
, dateRangeDocCount :: Int
|
||||||
|
, dateRangeAggs :: Maybe AggregationResults } deriving (Show, Eq)
|
||||||
|
|
||||||
|
toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
|
||||||
|
toTerms = toAggResult
|
||||||
|
|
||||||
|
toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
|
||||||
|
toDateHistogram = toAggResult
|
||||||
|
|
||||||
|
toMissing :: Text -> AggregationResults -> Maybe MissingResult
|
||||||
|
toMissing = toAggResult
|
||||||
|
|
||||||
|
toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)
|
||||||
|
toTopHits = toAggResult
|
||||||
|
|
||||||
|
toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a
|
||||||
|
toAggResult t a = M.lookup t a >>= deserialize
|
||||||
|
where deserialize = parseMaybe parseJSON
|
||||||
|
|
||||||
|
instance BucketAggregation TermsResult where
|
||||||
|
key = termKey
|
||||||
|
docCount = termsDocCount
|
||||||
|
aggs = termsAggs
|
||||||
|
|
||||||
|
instance BucketAggregation DateHistogramResult where
|
||||||
|
key = TextValue . showText . dateKey
|
||||||
|
docCount = dateDocCount
|
||||||
|
aggs = dateHistogramAggs
|
||||||
|
|
||||||
|
instance BucketAggregation DateRangeResult where
|
||||||
|
key = TextValue . dateRangeKey
|
||||||
|
docCount = dateRangeDocCount
|
||||||
|
aggs = dateRangeAggs
|
||||||
|
|
||||||
|
instance (FromJSON a) => FromJSON (Bucket a) where
|
||||||
|
parseJSON (Object v) = Bucket <$>
|
||||||
|
v .: "buckets"
|
||||||
|
parseJSON _ = mempty
|
||||||
|
|
||||||
|
instance FromJSON BucketValue where
|
||||||
|
parseJSON (String t) = return $ TextValue t
|
||||||
|
parseJSON (Number s) = return $ ScientificValue s
|
||||||
|
parseJSON (Bool b) = return $ BoolValue b
|
||||||
|
parseJSON _ = mempty
|
||||||
|
|
||||||
|
instance FromJSON MissingResult where
|
||||||
|
parseJSON = withObject "MissingResult" parse
|
||||||
|
where parse v = MissingResult <$> v .: "doc_count"
|
||||||
|
|
||||||
|
instance FromJSON TermsResult where
|
||||||
|
parseJSON (Object v) = TermsResult <$>
|
||||||
|
v .: "key" <*>
|
||||||
|
v .: "doc_count" <*>
|
||||||
|
(pure $ getNamedSubAgg v ["key", "doc_count"])
|
||||||
|
parseJSON _ = mempty
|
||||||
|
|
||||||
|
instance FromJSON DateHistogramResult where
|
||||||
|
parseJSON (Object v) = DateHistogramResult <$>
|
||||||
|
v .: "key" <*>
|
||||||
|
v .:? "key_as_string" <*>
|
||||||
|
v .: "doc_count" <*>
|
||||||
|
(pure $ getNamedSubAgg v [ "key"
|
||||||
|
, "doc_count"
|
||||||
|
, "key_as_string"
|
||||||
|
]
|
||||||
|
)
|
||||||
|
parseJSON _ = mempty
|
||||||
|
|
||||||
|
instance FromJSON DateRangeResult where
|
||||||
|
parseJSON = withObject "DateRangeResult" parse
|
||||||
|
where parse v = DateRangeResult <$>
|
||||||
|
v .: "key" <*>
|
||||||
|
(fmap posixMS <$> v .:? "from") <*>
|
||||||
|
v .:? "from_as_string" <*>
|
||||||
|
(fmap posixMS <$> v .:? "to") <*>
|
||||||
|
v .:? "to_as_string" <*>
|
||||||
|
v .: "doc_count" <*>
|
||||||
|
(pure $ getNamedSubAgg v [ "key"
|
||||||
|
, "from"
|
||||||
|
, "from_as_string"
|
||||||
|
, "to"
|
||||||
|
, "to_as_string"
|
||||||
|
, "doc_count"
|
||||||
|
]
|
||||||
|
)
|
||||||
|
|
||||||
|
instance (FromJSON a) => FromJSON (TopHitResult a) where
|
||||||
|
parseJSON (Object v) = TopHitResult <$>
|
||||||
|
v .: "hits"
|
||||||
|
parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"
|
||||||
|
|
||||||
|
data MissingResult = MissingResult { missingDocCount :: Int } deriving (Show)
|
||||||
|
|
||||||
|
data TopHitResult a = TopHitResult { tarHits :: (SearchHits a)
|
||||||
|
} deriving Show
|
||||||
|
|
||||||
|
data SearchHits a =
|
||||||
|
SearchHits { hitsTotal :: Int
|
||||||
|
, maxScore :: Score
|
||||||
|
, hits :: [Hit a] } deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance Semigroup (SearchHits a) where
|
||||||
|
(SearchHits ta ma ha) <> (SearchHits tb mb hb) = SearchHits (ta + tb) (max ma mb) (ha <> hb)
|
||||||
|
|
||||||
|
instance Monoid (SearchHits a) where
|
||||||
|
mempty = SearchHits 0 Nothing mempty
|
||||||
|
mappend = (<>)
|
||||||
|
|
||||||
|
data Hit a =
|
||||||
|
Hit { hitIndex :: IndexName
|
||||||
|
, hitType :: MappingName
|
||||||
|
, hitDocId :: DocId
|
||||||
|
, hitScore :: Score
|
||||||
|
, hitSource :: Maybe a
|
||||||
|
, hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
|
||||||
|
|
||||||
|
-- Try to get an AggregationResults when we don't know the
|
||||||
|
-- field name. We filter out the known keys to try to minimize the noise.
|
||||||
|
getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
|
||||||
|
getNamedSubAgg o knownKeys = maggRes
|
||||||
|
where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
|
||||||
|
maggRes
|
||||||
|
| HM.null unknownKeys = Nothing
|
||||||
|
| otherwise = Just . M.fromList $ HM.toList unknownKeys
|
||||||
|
|
||||||
|
instance ToJSON CollectionMode where
|
||||||
|
toJSON BreadthFirst = "breadth_first"
|
||||||
|
toJSON DepthFirst = "depth_first"
|
||||||
|
|
||||||
|
instance ToJSON DateRangeAggregation where
|
||||||
|
toJSON DateRangeAggregation {..} =
|
||||||
|
omitNulls [ "field" .= draField
|
||||||
|
, "format" .= draFormat
|
||||||
|
, "ranges" .= toList draRanges
|
||||||
|
]
|
||||||
|
|
||||||
|
instance (FromJSON a) => FromJSON (SearchHits a) where
|
||||||
|
parseJSON (Object v) = SearchHits <$>
|
||||||
|
v .: "total" <*>
|
||||||
|
v .: "max_score" <*>
|
||||||
|
v .: "hits"
|
||||||
|
parseJSON _ = empty
|
||||||
|
|
||||||
|
instance ToJSON DateRangeAggRange where
|
||||||
|
toJSON (DateRangeFrom e) = object [ "from" .= e ]
|
||||||
|
toJSON (DateRangeTo e) = object [ "to" .= e ]
|
||||||
|
toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]
|
||||||
|
|
||||||
|
instance (FromJSON a) => FromJSON (Hit a) where
|
||||||
|
parseJSON (Object v) = Hit <$>
|
||||||
|
v .: "_index" <*>
|
||||||
|
v .: "_type" <*>
|
||||||
|
v .: "_id" <*>
|
||||||
|
v .: "_score" <*>
|
||||||
|
v .:? "_source" <*>
|
||||||
|
v .:? "highlight"
|
||||||
|
parseJSON _ = empty
|
||||||
|
File diff suppressed because it is too large
Load Diff
144
src/Database/V1/Bloodhound/Internal/Highlight.hs
Normal file
144
src/Database/V1/Bloodhound/Internal/Highlight.hs
Normal file
@ -0,0 +1,144 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Database.V1.Bloodhound.Internal.Highlight where
|
||||||
|
|
||||||
|
|
||||||
|
import Bloodhound.Import
|
||||||
|
|
||||||
|
import qualified Data.Map as M
|
||||||
|
|
||||||
|
import Database.V1.Bloodhound.Internal.Newtypes
|
||||||
|
import Database.V1.Bloodhound.Internal.Query
|
||||||
|
|
||||||
|
type HitHighlight = M.Map Text [Text]
|
||||||
|
|
||||||
|
data Highlights = Highlights { globalsettings :: Maybe HighlightSettings
|
||||||
|
, highlightFields :: [FieldHighlight]
|
||||||
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
instance ToJSON Highlights where
|
||||||
|
toJSON (Highlights global fields) =
|
||||||
|
omitNulls (("fields" .= fields)
|
||||||
|
: highlightSettingsPairs global)
|
||||||
|
|
||||||
|
data HighlightSettings = Plain PlainHighlight
|
||||||
|
| Postings PostingsHighlight
|
||||||
|
| FastVector FastVectorHighlight
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
data FieldHighlight = FieldHighlight FieldName (Maybe HighlightSettings)
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
data PlainHighlight =
|
||||||
|
PlainHighlight { plainCommon :: Maybe CommonHighlight
|
||||||
|
, plainNonPost :: Maybe NonPostings } deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- This requires that index_options are set to 'offset' in the mapping.
|
||||||
|
data PostingsHighlight = PostingsHighlight (Maybe CommonHighlight) deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
|
||||||
|
data FastVectorHighlight =
|
||||||
|
FastVectorHighlight { fvCommon :: Maybe CommonHighlight
|
||||||
|
, fvNonPostSettings :: Maybe NonPostings
|
||||||
|
, boundaryChars :: Maybe Text
|
||||||
|
, boundaryMaxScan :: Maybe Int
|
||||||
|
, fragmentOffset :: Maybe Int
|
||||||
|
, matchedFields :: [Text]
|
||||||
|
, phraseLimit :: Maybe Int
|
||||||
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
data CommonHighlight =
|
||||||
|
CommonHighlight { order :: Maybe Text
|
||||||
|
, forceSource :: Maybe Bool
|
||||||
|
, tag :: Maybe HighlightTag
|
||||||
|
, encoder :: Maybe HighlightEncoder
|
||||||
|
, noMatchSize :: Maybe Int
|
||||||
|
, highlightQuery :: Maybe Query
|
||||||
|
, requireFieldMatch :: Maybe Bool
|
||||||
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- Settings that are only applicable to FastVector and Plain highlighters.
|
||||||
|
data NonPostings =
|
||||||
|
NonPostings { fragmentSize :: Maybe Int
|
||||||
|
, numberOfFragments :: Maybe Int} deriving (Show, Eq)
|
||||||
|
|
||||||
|
data HighlightEncoder = DefaultEncoder
|
||||||
|
| HTMLEncoder
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- NOTE: Should the tags use some kind of HTML type, rather than Text?
|
||||||
|
data HighlightTag = TagSchema Text
|
||||||
|
| CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
|
||||||
|
highlightSettingsPairs Nothing = []
|
||||||
|
highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
|
||||||
|
highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
|
||||||
|
highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
|
||||||
|
|
||||||
|
plainHighPairs :: Maybe PlainHighlight -> [Pair]
|
||||||
|
plainHighPairs Nothing = []
|
||||||
|
plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
|
||||||
|
[ "type" .= String "plain"]
|
||||||
|
++ commonHighlightPairs plCom
|
||||||
|
++ nonPostingsToPairs plNonPost
|
||||||
|
|
||||||
|
postHighPairs :: Maybe PostingsHighlight -> [Pair]
|
||||||
|
postHighPairs Nothing = []
|
||||||
|
postHighPairs (Just (PostingsHighlight pCom)) =
|
||||||
|
("type" .= String "postings")
|
||||||
|
: commonHighlightPairs pCom
|
||||||
|
|
||||||
|
fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
|
||||||
|
fastVectorHighPairs Nothing = []
|
||||||
|
fastVectorHighPairs (Just
|
||||||
|
(FastVectorHighlight fvCom fvNonPostSettings' fvBoundChars
|
||||||
|
fvBoundMaxScan fvFragOff fvMatchedFields
|
||||||
|
fvPhraseLim)) =
|
||||||
|
[ "type" .= String "fvh"
|
||||||
|
, "boundary_chars" .= fvBoundChars
|
||||||
|
, "boundary_max_scan" .= fvBoundMaxScan
|
||||||
|
, "fragment_offset" .= fvFragOff
|
||||||
|
, "matched_fields" .= fvMatchedFields
|
||||||
|
, "phraseLimit" .= fvPhraseLim]
|
||||||
|
++ commonHighlightPairs fvCom
|
||||||
|
++ nonPostingsToPairs fvNonPostSettings'
|
||||||
|
|
||||||
|
commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
|
||||||
|
commonHighlightPairs Nothing = []
|
||||||
|
commonHighlightPairs (Just (CommonHighlight chScore chForceSource chTag chEncoder
|
||||||
|
chNoMatchSize chHighlightQuery
|
||||||
|
chRequireFieldMatch)) =
|
||||||
|
[ "order" .= chScore
|
||||||
|
, "force_source" .= chForceSource
|
||||||
|
, "encoder" .= chEncoder
|
||||||
|
, "no_match_size" .= chNoMatchSize
|
||||||
|
, "highlight_query" .= chHighlightQuery
|
||||||
|
, "require_fieldMatch" .= chRequireFieldMatch]
|
||||||
|
++ highlightTagToPairs chTag
|
||||||
|
|
||||||
|
nonPostingsToPairs :: Maybe NonPostings -> [Pair]
|
||||||
|
nonPostingsToPairs Nothing = []
|
||||||
|
nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
|
||||||
|
[ "fragment_size" .= npFragSize
|
||||||
|
, "number_of_fragments" .= npNumOfFrags]
|
||||||
|
|
||||||
|
highlightTagToPairs :: Maybe HighlightTag -> [Pair]
|
||||||
|
highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"]
|
||||||
|
highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre
|
||||||
|
, "post_tags" .= post]
|
||||||
|
highlightTagToPairs Nothing = []
|
||||||
|
|
||||||
|
instance ToJSON FieldHighlight where
|
||||||
|
toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
|
||||||
|
object [ fName .= fSettings ]
|
||||||
|
toJSON (FieldHighlight (FieldName fName) Nothing) =
|
||||||
|
object [ fName .= emptyObject ]
|
||||||
|
|
||||||
|
instance ToJSON HighlightSettings where
|
||||||
|
toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
|
||||||
|
|
||||||
|
instance ToJSON HighlightEncoder where
|
||||||
|
toJSON DefaultEncoder = String "default"
|
||||||
|
toJSON HTMLEncoder = String "html"
|
@ -3,10 +3,8 @@
|
|||||||
|
|
||||||
module Database.V1.Bloodhound.Internal.Newtypes where
|
module Database.V1.Bloodhound.Internal.Newtypes where
|
||||||
|
|
||||||
|
|
||||||
import Bloodhound.Import
|
import Bloodhound.Import
|
||||||
|
|
||||||
|
|
||||||
newtype From = From Int deriving (Eq, Show, ToJSON)
|
newtype From = From Int deriving (Eq, Show, ToJSON)
|
||||||
newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON)
|
newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON)
|
||||||
|
|
||||||
@ -16,7 +14,7 @@ newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON)
|
|||||||
-}
|
-}
|
||||||
newtype FieldName =
|
newtype FieldName =
|
||||||
FieldName Text
|
FieldName Text
|
||||||
deriving (Eq, Read, Show, ToJSON, FromJSON)
|
deriving (Eq, Show, ToJSON, FromJSON)
|
||||||
|
|
||||||
newtype Boost =
|
newtype Boost =
|
||||||
Boost Double
|
Boost Double
|
||||||
@ -159,3 +157,55 @@ newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, ToJSON, FromJS
|
|||||||
|
|
||||||
-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ
|
-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ
|
||||||
newtype POSIXMS = POSIXMS { posixMS :: UTCTime }
|
newtype POSIXMS = POSIXMS { posixMS :: UTCTime }
|
||||||
|
|
||||||
|
instance FromJSON POSIXMS where
|
||||||
|
parseJSON = withScientific "POSIXMS" (return . parse)
|
||||||
|
where parse n = let n' = truncate n :: Integer
|
||||||
|
in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))
|
||||||
|
|
||||||
|
{-| 'IndexName' is used to describe which index to query/create/delete
|
||||||
|
-}
|
||||||
|
newtype IndexName = IndexName Text deriving (Eq, Show, ToJSON, FromJSON)
|
||||||
|
|
||||||
|
newtype IndexAliasName = IndexAliasName { indexAliasName :: IndexName } deriving (Eq, Show, ToJSON)
|
||||||
|
|
||||||
|
type Score = Maybe Double
|
||||||
|
|
||||||
|
newtype ShardId = ShardId { shardId :: Int }
|
||||||
|
deriving (Eq, Show, FromJSON)
|
||||||
|
|
||||||
|
-- | Milliseconds
|
||||||
|
newtype MS = MS NominalDiffTime
|
||||||
|
|
||||||
|
|
||||||
|
-- keeps the unexported constructor warnings at bay
|
||||||
|
unMS :: MS -> NominalDiffTime
|
||||||
|
unMS (MS t) = t
|
||||||
|
|
||||||
|
instance FromJSON MS where
|
||||||
|
parseJSON = withScientific "MS" (return . MS . parse)
|
||||||
|
where
|
||||||
|
parse n = fromInteger ((truncate n) * 1000)
|
||||||
|
|
||||||
|
newtype MaybeNA a = MaybeNA { unMaybeNA :: Maybe a }
|
||||||
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
instance FromJSON a => FromJSON (MaybeNA a) where
|
||||||
|
parseJSON (String "NA") = pure $ MaybeNA Nothing
|
||||||
|
parseJSON o = MaybeNA . Just <$> parseJSON o
|
||||||
|
|
||||||
|
newtype SnapshotName = SnapshotName { snapshotName :: Text }
|
||||||
|
deriving (Show, Eq, Ord, ToJSON, FromJSON)
|
||||||
|
|
||||||
|
instance FromJSON ShardCount where
|
||||||
|
parseJSON v = parseAsInt v
|
||||||
|
<|> parseAsString v
|
||||||
|
where parseAsInt = fmap ShardCount . parseJSON
|
||||||
|
parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText)
|
||||||
|
|
||||||
|
|
||||||
|
instance FromJSON ReplicaCount where
|
||||||
|
parseJSON v = parseAsInt v
|
||||||
|
<|> parseAsString v
|
||||||
|
where parseAsInt = fmap ReplicaCount . parseJSON
|
||||||
|
parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)
|
||||||
|
@ -2,10 +2,7 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Database.V1.Bloodhound.Internal.Query
|
module Database.V1.Bloodhound.Internal.Query where
|
||||||
( module X
|
|
||||||
, module Database.V1.Bloodhound.Internal.Query
|
|
||||||
) where
|
|
||||||
|
|
||||||
|
|
||||||
import Bloodhound.Import
|
import Bloodhound.Import
|
||||||
@ -13,8 +10,8 @@ import Bloodhound.Import
|
|||||||
import qualified Data.HashMap.Strict as HM
|
import qualified Data.HashMap.Strict as HM
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
import Database.Bloodhound.Common.Script as X
|
import Database.V1.Bloodhound.Internal.Newtypes
|
||||||
import Database.V5.Bloodhound.Internal.Newtypes
|
import Database.V1.Bloodhound.Types.Class
|
||||||
|
|
||||||
|
|
||||||
data GeoPoint =
|
data GeoPoint =
|
||||||
@ -99,6 +96,15 @@ data Filter = AndFilter [Filter] Cache
|
|||||||
| TermFilter Term Cache
|
| TermFilter Term Cache
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance Semigroup Filter where
|
||||||
|
a <> b = AndFilter [a, b] defaultCache
|
||||||
|
|
||||||
|
instance Monoid Filter where
|
||||||
|
mempty = IdentityFilter
|
||||||
|
mappend = (<>)
|
||||||
|
|
||||||
|
instance Seminearring Filter where
|
||||||
|
a <||> b = OrFilter [a, b] defaultCache
|
||||||
|
|
||||||
data BoolMatch = MustMatch Term Cache
|
data BoolMatch = MustMatch Term Cache
|
||||||
| MustNotMatch Term Cache
|
| MustNotMatch Term Cache
|
||||||
|
@ -25,6 +25,22 @@ type Sort = [SortSpec]
|
|||||||
data SortSpec = DefaultSortSpec DefaultSort
|
data SortSpec = DefaultSortSpec DefaultSort
|
||||||
| GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit deriving (Eq, Show)
|
| GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance ToJSON SortSpec where
|
||||||
|
toJSON (DefaultSortSpec
|
||||||
|
(DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped
|
||||||
|
dsSortMode dsMissingSort dsNestedFilter)) =
|
||||||
|
object [dsSortFieldName .= omitNulls base] where
|
||||||
|
base = [ "order" .= dsSortOrder
|
||||||
|
, "ignore_unmapped" .= dsIgnoreUnmapped
|
||||||
|
, "mode" .= dsSortMode
|
||||||
|
, "missing" .= dsMissingSort
|
||||||
|
, "nested_filter" .= dsNestedFilter ]
|
||||||
|
|
||||||
|
toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) =
|
||||||
|
object [ "unit" .= units
|
||||||
|
, field .= gdsLatLon
|
||||||
|
, "order" .= gdsSortOrder ]
|
||||||
|
|
||||||
{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a
|
{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a
|
||||||
'mkSort' convenience function for when you want to specify only the most
|
'mkSort' convenience function for when you want to specify only the most
|
||||||
common parameters.
|
common parameters.
|
||||||
@ -49,6 +65,10 @@ data SortOrder = Ascending
|
|||||||
| Descending deriving (Eq, Show)
|
| Descending deriving (Eq, Show)
|
||||||
|
|
||||||
|
|
||||||
|
instance ToJSON SortOrder where
|
||||||
|
toJSON Ascending = String "asc"
|
||||||
|
toJSON Descending = String "desc"
|
||||||
|
|
||||||
{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.
|
{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.
|
||||||
|
|
||||||
http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option
|
http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option
|
||||||
@ -77,3 +97,10 @@ instance ToJSON Missing where
|
|||||||
toJSON LastMissing = String "_last"
|
toJSON LastMissing = String "_last"
|
||||||
toJSON FirstMissing = String "_first"
|
toJSON FirstMissing = String "_first"
|
||||||
toJSON (CustomMissing txt) = String txt
|
toJSON (CustomMissing txt) = String txt
|
||||||
|
|
||||||
|
-- {-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so
|
||||||
|
-- that you can concisely describe the usual kind of 'SortSpec's you want.
|
||||||
|
-- -}
|
||||||
|
mkSort :: FieldName -> SortOrder -> DefaultSort
|
||||||
|
mkSort fieldName sOrder = DefaultSort fieldName sOrder False Nothing Nothing Nothing
|
||||||
|
|
||||||
|
@ -8,8 +8,8 @@ import Bloodhound.Import
|
|||||||
|
|
||||||
import qualified Data.HashMap.Strict as HM
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
|
||||||
import Database.V5.Bloodhound.Internal.Newtypes
|
import Database.V1.Bloodhound.Internal.Newtypes
|
||||||
import Database.V5.Bloodhound.Internal.Query
|
import Database.V1.Bloodhound.Internal.Query
|
||||||
|
|
||||||
data Suggest = Suggest { suggestText :: Text
|
data Suggest = Suggest { suggestText :: Text
|
||||||
, suggestName :: Text
|
, suggestName :: Text
|
||||||
@ -209,7 +209,7 @@ data SuggestOptions =
|
|||||||
, suggestOptionsFreq :: Maybe Int
|
, suggestOptionsFreq :: Maybe Int
|
||||||
, suggestOptionsHighlighted :: Maybe Text
|
, suggestOptionsHighlighted :: Maybe Text
|
||||||
}
|
}
|
||||||
deriving (Eq, Read, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance FromJSON SuggestOptions where
|
instance FromJSON SuggestOptions where
|
||||||
parseJSON = withObject "SuggestOptions" parse
|
parseJSON = withObject "SuggestOptions" parse
|
||||||
@ -225,7 +225,7 @@ data SuggestResponse =
|
|||||||
, suggestResponseLength :: Int
|
, suggestResponseLength :: Int
|
||||||
, suggestResponseOptions :: [SuggestOptions]
|
, suggestResponseOptions :: [SuggestOptions]
|
||||||
}
|
}
|
||||||
deriving (Eq, Read, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance FromJSON SuggestResponse where
|
instance FromJSON SuggestResponse where
|
||||||
parseJSON = withObject "SuggestResponse" parse
|
parseJSON = withObject "SuggestResponse" parse
|
||||||
@ -239,7 +239,7 @@ data NamedSuggestionResponse =
|
|||||||
NamedSuggestionResponse { nsrName :: Text
|
NamedSuggestionResponse { nsrName :: Text
|
||||||
, nsrResponses :: [SuggestResponse]
|
, nsrResponses :: [SuggestResponse]
|
||||||
}
|
}
|
||||||
deriving (Eq, Read, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance FromJSON NamedSuggestionResponse where
|
instance FromJSON NamedSuggestionResponse where
|
||||||
parseJSON (Object o) = do
|
parseJSON (Object o) = do
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -236,10 +236,6 @@ data UpdatableIndexSetting = NumberOfReplicas ReplicaCount
|
|||||||
-- ^ Analysis is not a dynamic setting and can only be performed on a closed index.
|
-- ^ Analysis is not a dynamic setting and can only be performed on a closed index.
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
oPath :: ToJSON a => NonEmpty Text -> a -> Value
|
|
||||||
oPath (k :| []) v = object [k .= v]
|
|
||||||
oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]
|
|
||||||
|
|
||||||
attrFilterJSON :: NonEmpty NodeAttrFilter -> Value
|
attrFilterJSON :: NonEmpty NodeAttrFilter -> Value
|
||||||
attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)
|
attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)
|
||||||
| NodeAttrFilter (NodeAttrName n) vs <- toList fs]
|
| NodeAttrFilter (NodeAttrName n) vs <- toList fs]
|
||||||
|
132
tests/V1/Test/Aggregation.hs
Normal file
132
tests/V1/Test/Aggregation.hs
Normal file
@ -0,0 +1,132 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Aggregation (spec) where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import Control.Error (fmapL, note)
|
||||||
|
import qualified Data.Map as M
|
||||||
|
import qualified Database.V1.Bloodhound
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
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 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 "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]))
|
63
tests/V1/Test/ApproxEq.hs
Normal file
63
tests/V1/Test/ApproxEq.hs
Normal file
@ -0,0 +1,63 @@
|
|||||||
|
{-# LANGUAGE DefaultSignatures #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.ApproxEq where
|
||||||
|
|
||||||
|
import Database.V1.Bloodhound
|
||||||
|
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
|
||||||
|
showApproxEq :: a -> String
|
||||||
|
default showApproxEq :: (Show a) => a -> String
|
||||||
|
showApproxEq = show
|
||||||
|
|
||||||
|
(==~) :: (ApproxEq a) => a -> a -> Property
|
||||||
|
a ==~ b = counterexample (showApproxEq a ++ " !=~ " ++ showApproxEq b) (a =~ b)
|
||||||
|
|
||||||
|
instance ApproxEq NominalDiffTime where (=~) = (==)
|
||||||
|
instance ApproxEq Bool where (=~) = (==)
|
||||||
|
instance ApproxEq Int where (=~) = (==)
|
||||||
|
instance (Eq a, Show a) => ApproxEq (Maybe a) where (=~) = (==)
|
||||||
|
instance ApproxEq Char where
|
||||||
|
(=~) = (==)
|
||||||
|
|
||||||
|
instance ApproxEq NodeAttrFilter where (=~) = (==)
|
||||||
|
instance ApproxEq NodeAttrName where (=~) = (==)
|
||||||
|
instance (Eq a, Show a) => ApproxEq (NonEmpty a) where (=~) = (==)
|
||||||
|
instance (ApproxEq l, Show l, ApproxEq r, Show 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 a, Show a) => ApproxEq [a] where
|
||||||
|
as =~ bs = and (zipWith (=~) as bs)
|
||||||
|
instance ApproxEq ReplicaCount where (=~) = (==)
|
||||||
|
instance ApproxEq ReplicaBounds where (=~) = (==)
|
||||||
|
instance ApproxEq Bytes where (=~) = (==)
|
||||||
|
instance ApproxEq AllocationPolicy where (=~) = (==)
|
||||||
|
instance ApproxEq InitialShardCount where (=~) = (==)
|
||||||
|
instance ApproxEq FSType where (=~) = (==)
|
||||||
|
|
||||||
|
-- | 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
|
77
tests/V1/Test/BulkAPI.hs
Normal file
77
tests/V1/Test/BulkAPI.hs
Normal file
@ -0,0 +1,77 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.BulkAPI (spec) where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.Vector as V
|
||||||
|
import qualified Lens.Micro.Aeson as LMA
|
||||||
|
|
||||||
|
newtype BulkTest =
|
||||||
|
BulkTest Text
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance ToJSON BulkTest where
|
||||||
|
toJSON (BulkTest name') =
|
||||||
|
object ["name" .= name']
|
||||||
|
|
||||||
|
instance FromJSON BulkTest where
|
||||||
|
parseJSON = withObject "BulkTest" parse
|
||||||
|
where
|
||||||
|
parse o = do
|
||||||
|
t <- o .: "name"
|
||||||
|
BulkTest <$> parseJSON t
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "Bulk API" $
|
||||||
|
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")
|
||||||
|
-- note that we cannot query for fourthDoc and fifthDoc since we
|
||||||
|
-- do not know their autogenerated ids.
|
||||||
|
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)
|
||||||
|
-- Since we can't get the docs by doc id, we check for their existence in
|
||||||
|
-- a match all query.
|
||||||
|
let query = MatchAllQuery Nothing
|
||||||
|
let search = mkSearch (Just query) Nothing
|
||||||
|
resp <- searchByIndex testIndex search
|
||||||
|
parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))
|
||||||
|
case parsed of
|
||||||
|
Left e ->
|
||||||
|
liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)
|
||||||
|
(Right sr) -> do
|
||||||
|
liftIO $
|
||||||
|
hitsTotal (searchHits sr) `shouldBe` 3
|
||||||
|
let nameList :: [Text]
|
||||||
|
nameList =
|
||||||
|
hits (searchHits sr)
|
||||||
|
^.. traverse
|
||||||
|
. to hitSource
|
||||||
|
. _Just
|
||||||
|
. LMA.key "name"
|
||||||
|
. _String
|
||||||
|
liftIO $
|
||||||
|
nameList
|
||||||
|
`shouldBe` ["blah","bloo"]
|
289
tests/V1/Test/Common.hs
Normal file
289
tests/V1/Test/Common.hs
Normal file
@ -0,0 +1,289 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
module Test.Common where
|
||||||
|
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.Version as Vers
|
||||||
|
import qualified Network.HTTP.Types.Status as NHTS
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
data Location = Location { lat :: Double
|
||||||
|
, lon :: Double } deriving (Eq, Show)
|
||||||
|
|
||||||
|
data Tweet = Tweet { user :: Text
|
||||||
|
, postDate :: UTCTime
|
||||||
|
, message :: Text
|
||||||
|
, age :: Int
|
||||||
|
, location :: Location
|
||||||
|
, extra :: Maybe Text }
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
$(deriveJSON defaultOptions ''Location)
|
||||||
|
$(deriveJSON defaultOptions ''Tweet)
|
||||||
|
|
||||||
|
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)]
|
||||||
|
, "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: Text)]
|
||||||
|
]]
|
||||||
|
|
||||||
|
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] []
|
||||||
|
|
||||||
|
es50 :: Vers.Version
|
||||||
|
es50 = Vers.Version [5, 0, 0] []
|
||||||
|
|
||||||
|
getServerVersion :: IO (Maybe Vers.Version)
|
||||||
|
getServerVersion = fmap extractVersion <$> withTestEnv getStatus
|
||||||
|
where
|
||||||
|
extractVersion = versionNumber . number . version
|
||||||
|
|
||||||
|
createExampleIndex :: (MonadBH m) => m Reply
|
||||||
|
createExampleIndex =
|
||||||
|
createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
|
||||||
|
|
||||||
|
deleteExampleIndex :: (MonadBH m) => m Reply
|
||||||
|
deleteExampleIndex =
|
||||||
|
deleteIndex testIndex
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
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)]
|
||||||
|
, "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: Text)]
|
||||||
|
]]
|
||||||
|
|
||||||
|
data TweetMapping = TweetMapping deriving (Eq, Show)
|
||||||
|
|
||||||
|
instance ToJSON TweetMapping where
|
||||||
|
toJSON TweetMapping =
|
||||||
|
object ["tweet" .=
|
||||||
|
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)]
|
||||||
|
, "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: 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 tweetHit :: Either EsError (Maybe (Hit Tweet))
|
||||||
|
tweetHit = fmap (headMay . hits . searchHits) result
|
||||||
|
myHighlight :: Either EsError (Maybe HitHighlight)
|
||||||
|
myHighlight = (join . fmap hitHighlight) <$> tweetHit
|
||||||
|
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
|
||||||
|
|
||||||
|
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
|
52
tests/V1/Test/Documents.hs
Normal file
52
tests/V1/Test/Documents.hs
Normal file
@ -0,0 +1,52 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Documents where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
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
|
||||||
|
let validateStatus' stat = liftIO . flip validateStatus stat
|
||||||
|
_ <- validateStatus' 200 =<< putMapping testIndex (MappingName "child") ChildMapping
|
||||||
|
_ <- validateStatus' 200 =<< putMapping testIndex (MappingName "parent") ParentMapping
|
||||||
|
_ <- validateStatus' 201 =<< indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
|
||||||
|
let parent = (Just . DocumentParent . DocId) "1"
|
||||||
|
ids = IndexDocumentSettings NoVersionControl parent
|
||||||
|
_ <- validateStatus' 201 =<< indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
|
||||||
|
_ <- refreshIndex testIndex
|
||||||
|
exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
|
||||||
|
liftIO $ exists `shouldBe` True
|
432
tests/V1/Test/Generators.hs
Normal file
432
tests/V1/Test/Generators.hs
Normal file
@ -0,0 +1,432 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
module Test.Generators where
|
||||||
|
|
||||||
|
import Database.V1.Bloodhound
|
||||||
|
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
import qualified Data.List as L
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
import qualified Data.Map as M
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Version as Vers
|
||||||
|
import Test.QuickCheck.TH.Generators
|
||||||
|
|
||||||
|
import Test.ApproxEq
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
instance (Arbitrary a, Typeable a) => Arbitrary (SearchHits a) where
|
||||||
|
arbitrary = reduceSize $ do
|
||||||
|
tot <- getPositive <$> arbitrary
|
||||||
|
score <- arbitraryScore
|
||||||
|
hs <- arbitrary
|
||||||
|
return $ SearchHits tot score hs
|
||||||
|
|
||||||
|
|
||||||
|
reduceSize :: Gen a -> Gen a
|
||||||
|
reduceSize f = sized $ \n -> resize (n `div` 2) f
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
instance Arbitrary FieldName where
|
||||||
|
arbitrary =
|
||||||
|
FieldName
|
||||||
|
. T.pack
|
||||||
|
<$> listOf1 arbitraryAlphaNum
|
||||||
|
|
||||||
|
|
||||||
|
#if MIN_VERSION_base(4,10,0)
|
||||||
|
-- Test.QuickCheck.Modifiers
|
||||||
|
|
||||||
|
qcNonEmptyToNonEmpty :: NonEmptyList a -> NonEmpty a
|
||||||
|
qcNonEmptyToNonEmpty (NonEmpty (a : xs)) = (a :| xs)
|
||||||
|
qcNonEmptyToNonEmpty (NonEmpty []) = error "NonEmpty was empty!"
|
||||||
|
|
||||||
|
instance Arbitrary a => Arbitrary (NonEmpty a) where
|
||||||
|
arbitrary =
|
||||||
|
qcNonEmptyToNonEmpty
|
||||||
|
<$> arbitrary
|
||||||
|
#endif
|
||||||
|
|
||||||
|
instance Arbitrary RegexpFlags where
|
||||||
|
arbitrary = oneof [ pure AllRegexpFlags
|
||||||
|
, pure NoRegexpFlags
|
||||||
|
, SomeRegexpFlags <$> genUniqueFlags
|
||||||
|
]
|
||||||
|
where genUniqueFlags =
|
||||||
|
NE.fromList . L.nub
|
||||||
|
<$> listOf1 arbitrary
|
||||||
|
|
||||||
|
instance Arbitrary IndexAliasCreate where
|
||||||
|
arbitrary =
|
||||||
|
IndexAliasCreate
|
||||||
|
<$> arbitrary
|
||||||
|
<*> reduceSize arbitrary
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
makeArbitrary ''FilteredQuery
|
||||||
|
instance Arbitrary FilteredQuery where arbitrary = reduceSize arbitraryFilteredQuery
|
||||||
|
makeArbitrary ''Query
|
||||||
|
instance Arbitrary Query where arbitrary = reduceSize arbitraryQuery
|
||||||
|
makeArbitrary ''Filter
|
||||||
|
instance Arbitrary Filter where arbitrary = reduceSize arbitraryFilter
|
||||||
|
makeArbitrary ''IndexName
|
||||||
|
instance Arbitrary IndexName where arbitrary = arbitraryIndexName
|
||||||
|
makeArbitrary ''MappingName
|
||||||
|
instance Arbitrary MappingName where arbitrary = arbitraryMappingName
|
||||||
|
makeArbitrary ''DocId
|
||||||
|
instance Arbitrary DocId where arbitrary = arbitraryDocId
|
||||||
|
makeArbitrary ''Version
|
||||||
|
instance Arbitrary Version where arbitrary = arbitraryVersion
|
||||||
|
makeArbitrary ''BuildHash
|
||||||
|
instance Arbitrary BuildHash where arbitrary = arbitraryBuildHash
|
||||||
|
makeArbitrary ''IndexAliasRouting
|
||||||
|
instance Arbitrary IndexAliasRouting where arbitrary = arbitraryIndexAliasRouting
|
||||||
|
makeArbitrary ''ShardCount
|
||||||
|
instance Arbitrary ShardCount where arbitrary = arbitraryShardCount
|
||||||
|
makeArbitrary ''ReplicaCount
|
||||||
|
instance Arbitrary ReplicaCount where arbitrary = arbitraryReplicaCount
|
||||||
|
makeArbitrary ''TemplateName
|
||||||
|
instance Arbitrary TemplateName where arbitrary = arbitraryTemplateName
|
||||||
|
makeArbitrary ''TemplatePattern
|
||||||
|
instance Arbitrary TemplatePattern where arbitrary = arbitraryTemplatePattern
|
||||||
|
makeArbitrary ''QueryString
|
||||||
|
instance Arbitrary QueryString where arbitrary = arbitraryQueryString
|
||||||
|
makeArbitrary ''CacheName
|
||||||
|
instance Arbitrary CacheName where arbitrary = arbitraryCacheName
|
||||||
|
makeArbitrary ''CacheKey
|
||||||
|
instance Arbitrary CacheKey where arbitrary = arbitraryCacheKey
|
||||||
|
makeArbitrary ''Existence
|
||||||
|
instance Arbitrary Existence where arbitrary = arbitraryExistence
|
||||||
|
makeArbitrary ''CutoffFrequency
|
||||||
|
instance Arbitrary CutoffFrequency where arbitrary = arbitraryCutoffFrequency
|
||||||
|
makeArbitrary ''Analyzer
|
||||||
|
instance Arbitrary Analyzer where arbitrary = arbitraryAnalyzer
|
||||||
|
makeArbitrary ''MaxExpansions
|
||||||
|
instance Arbitrary MaxExpansions where arbitrary = arbitraryMaxExpansions
|
||||||
|
makeArbitrary ''Lenient
|
||||||
|
instance Arbitrary Lenient where arbitrary = arbitraryLenient
|
||||||
|
makeArbitrary ''Tiebreaker
|
||||||
|
instance Arbitrary Tiebreaker where arbitrary = arbitraryTiebreaker
|
||||||
|
makeArbitrary ''Boost
|
||||||
|
instance Arbitrary Boost where arbitrary = arbitraryBoost
|
||||||
|
makeArbitrary ''BoostTerms
|
||||||
|
instance Arbitrary BoostTerms where arbitrary = arbitraryBoostTerms
|
||||||
|
makeArbitrary ''MinimumMatch
|
||||||
|
instance Arbitrary MinimumMatch where arbitrary = arbitraryMinimumMatch
|
||||||
|
makeArbitrary ''DisableCoord
|
||||||
|
instance Arbitrary DisableCoord where arbitrary = arbitraryDisableCoord
|
||||||
|
makeArbitrary ''IgnoreTermFrequency
|
||||||
|
instance Arbitrary IgnoreTermFrequency where arbitrary = arbitraryIgnoreTermFrequency
|
||||||
|
makeArbitrary ''MinimumTermFrequency
|
||||||
|
instance Arbitrary MinimumTermFrequency where arbitrary = arbitraryMinimumTermFrequency
|
||||||
|
makeArbitrary ''MaxQueryTerms
|
||||||
|
instance Arbitrary MaxQueryTerms where arbitrary = arbitraryMaxQueryTerms
|
||||||
|
makeArbitrary ''Fuzziness
|
||||||
|
instance Arbitrary Fuzziness where arbitrary = arbitraryFuzziness
|
||||||
|
makeArbitrary ''PrefixLength
|
||||||
|
instance Arbitrary PrefixLength where arbitrary = arbitraryPrefixLength
|
||||||
|
makeArbitrary ''TypeName
|
||||||
|
instance Arbitrary TypeName where arbitrary = arbitraryTypeName
|
||||||
|
makeArbitrary ''PercentMatch
|
||||||
|
instance Arbitrary PercentMatch where arbitrary = arbitraryPercentMatch
|
||||||
|
makeArbitrary ''StopWord
|
||||||
|
instance Arbitrary StopWord where arbitrary = arbitraryStopWord
|
||||||
|
makeArbitrary ''QueryPath
|
||||||
|
instance Arbitrary QueryPath where arbitrary = arbitraryQueryPath
|
||||||
|
makeArbitrary ''AllowLeadingWildcard
|
||||||
|
instance Arbitrary AllowLeadingWildcard where arbitrary = arbitraryAllowLeadingWildcard
|
||||||
|
makeArbitrary ''LowercaseExpanded
|
||||||
|
instance Arbitrary LowercaseExpanded where arbitrary = arbitraryLowercaseExpanded
|
||||||
|
makeArbitrary ''EnablePositionIncrements
|
||||||
|
instance Arbitrary EnablePositionIncrements where arbitrary = arbitraryEnablePositionIncrements
|
||||||
|
makeArbitrary ''AnalyzeWildcard
|
||||||
|
instance Arbitrary AnalyzeWildcard where arbitrary = arbitraryAnalyzeWildcard
|
||||||
|
makeArbitrary ''GeneratePhraseQueries
|
||||||
|
instance Arbitrary GeneratePhraseQueries where arbitrary = arbitraryGeneratePhraseQueries
|
||||||
|
makeArbitrary ''Locale
|
||||||
|
instance Arbitrary Locale where arbitrary = arbitraryLocale
|
||||||
|
makeArbitrary ''MaxWordLength
|
||||||
|
instance Arbitrary MaxWordLength where arbitrary = arbitraryMaxWordLength
|
||||||
|
makeArbitrary ''MinWordLength
|
||||||
|
instance Arbitrary MinWordLength where arbitrary = arbitraryMinWordLength
|
||||||
|
makeArbitrary ''PhraseSlop
|
||||||
|
instance Arbitrary PhraseSlop where arbitrary = arbitraryPhraseSlop
|
||||||
|
makeArbitrary ''MinDocFrequency
|
||||||
|
instance Arbitrary MinDocFrequency where arbitrary = arbitraryMinDocFrequency
|
||||||
|
makeArbitrary ''MaxDocFrequency
|
||||||
|
instance Arbitrary MaxDocFrequency where arbitrary = arbitraryMaxDocFrequency
|
||||||
|
makeArbitrary ''Regexp
|
||||||
|
instance Arbitrary Regexp where arbitrary = arbitraryRegexp
|
||||||
|
makeArbitrary ''SimpleQueryStringQuery
|
||||||
|
instance Arbitrary SimpleQueryStringQuery where arbitrary = arbitrarySimpleQueryStringQuery
|
||||||
|
makeArbitrary ''FieldOrFields
|
||||||
|
instance Arbitrary FieldOrFields where arbitrary = arbitraryFieldOrFields
|
||||||
|
makeArbitrary ''SimpleQueryFlag
|
||||||
|
instance Arbitrary SimpleQueryFlag where arbitrary = arbitrarySimpleQueryFlag
|
||||||
|
makeArbitrary ''RegexpQuery
|
||||||
|
instance Arbitrary RegexpQuery where arbitrary = arbitraryRegexpQuery
|
||||||
|
makeArbitrary ''QueryStringQuery
|
||||||
|
instance Arbitrary QueryStringQuery where arbitrary = arbitraryQueryStringQuery
|
||||||
|
makeArbitrary ''RangeQuery
|
||||||
|
instance Arbitrary RangeQuery where arbitrary = arbitraryRangeQuery
|
||||||
|
makeArbitrary ''RangeValue
|
||||||
|
instance Arbitrary RangeValue where arbitrary = arbitraryRangeValue
|
||||||
|
makeArbitrary ''PrefixQuery
|
||||||
|
instance Arbitrary PrefixQuery where arbitrary = arbitraryPrefixQuery
|
||||||
|
makeArbitrary ''NestedQuery
|
||||||
|
instance Arbitrary NestedQuery where arbitrary = arbitraryNestedQuery
|
||||||
|
makeArbitrary ''MoreLikeThisFieldQuery
|
||||||
|
instance Arbitrary MoreLikeThisFieldQuery where arbitrary = arbitraryMoreLikeThisFieldQuery
|
||||||
|
makeArbitrary ''MoreLikeThisQuery
|
||||||
|
instance Arbitrary MoreLikeThisQuery where arbitrary = arbitraryMoreLikeThisQuery
|
||||||
|
makeArbitrary ''IndicesQuery
|
||||||
|
instance Arbitrary IndicesQuery where arbitrary = arbitraryIndicesQuery
|
||||||
|
makeArbitrary ''HasParentQuery
|
||||||
|
instance Arbitrary HasParentQuery where arbitrary = arbitraryHasParentQuery
|
||||||
|
makeArbitrary ''HasChildQuery
|
||||||
|
instance Arbitrary HasChildQuery where arbitrary = arbitraryHasChildQuery
|
||||||
|
makeArbitrary ''FuzzyQuery
|
||||||
|
instance Arbitrary FuzzyQuery where arbitrary = arbitraryFuzzyQuery
|
||||||
|
makeArbitrary ''FuzzyLikeFieldQuery
|
||||||
|
instance Arbitrary FuzzyLikeFieldQuery where arbitrary = arbitraryFuzzyLikeFieldQuery
|
||||||
|
makeArbitrary ''FuzzyLikeThisQuery
|
||||||
|
instance Arbitrary FuzzyLikeThisQuery where arbitrary = arbitraryFuzzyLikeThisQuery
|
||||||
|
makeArbitrary ''DisMaxQuery
|
||||||
|
instance Arbitrary DisMaxQuery where arbitrary = arbitraryDisMaxQuery
|
||||||
|
makeArbitrary ''CommonTermsQuery
|
||||||
|
instance Arbitrary CommonTermsQuery where arbitrary = arbitraryCommonTermsQuery
|
||||||
|
makeArbitrary ''DistanceRange
|
||||||
|
instance Arbitrary DistanceRange where arbitrary = arbitraryDistanceRange
|
||||||
|
makeArbitrary ''MultiMatchQuery
|
||||||
|
instance Arbitrary MultiMatchQuery where arbitrary = arbitraryMultiMatchQuery
|
||||||
|
makeArbitrary ''LessThanD
|
||||||
|
instance Arbitrary LessThanD where arbitrary = arbitraryLessThanD
|
||||||
|
makeArbitrary ''LessThanEqD
|
||||||
|
instance Arbitrary LessThanEqD where arbitrary = arbitraryLessThanEqD
|
||||||
|
makeArbitrary ''GreaterThanD
|
||||||
|
instance Arbitrary GreaterThanD where arbitrary = arbitraryGreaterThanD
|
||||||
|
makeArbitrary ''GreaterThanEqD
|
||||||
|
instance Arbitrary GreaterThanEqD where arbitrary = arbitraryGreaterThanEqD
|
||||||
|
makeArbitrary ''LessThan
|
||||||
|
instance Arbitrary LessThan where arbitrary = arbitraryLessThan
|
||||||
|
makeArbitrary ''LessThanEq
|
||||||
|
instance Arbitrary LessThanEq where arbitrary = arbitraryLessThanEq
|
||||||
|
makeArbitrary ''GreaterThan
|
||||||
|
instance Arbitrary GreaterThan where arbitrary = arbitraryGreaterThan
|
||||||
|
makeArbitrary ''GreaterThanEq
|
||||||
|
instance Arbitrary GreaterThanEq where arbitrary = arbitraryGreaterThanEq
|
||||||
|
makeArbitrary ''GeoPoint
|
||||||
|
instance Arbitrary GeoPoint where arbitrary = arbitraryGeoPoint
|
||||||
|
makeArbitrary ''NullValue
|
||||||
|
instance Arbitrary NullValue where arbitrary = arbitraryNullValue
|
||||||
|
makeArbitrary ''MinimumMatchHighLow
|
||||||
|
instance Arbitrary MinimumMatchHighLow where arbitrary = arbitraryMinimumMatchHighLow
|
||||||
|
makeArbitrary ''CommonMinimumMatch
|
||||||
|
instance Arbitrary CommonMinimumMatch where arbitrary = arbitraryCommonMinimumMatch
|
||||||
|
makeArbitrary ''BoostingQuery
|
||||||
|
instance Arbitrary BoostingQuery where arbitrary = arbitraryBoostingQuery
|
||||||
|
makeArbitrary ''BoolQuery
|
||||||
|
instance Arbitrary BoolQuery where arbitrary = arbitraryBoolQuery
|
||||||
|
makeArbitrary ''MatchQuery
|
||||||
|
instance Arbitrary MatchQuery where arbitrary = arbitraryMatchQuery
|
||||||
|
makeArbitrary ''MultiMatchQueryType
|
||||||
|
instance Arbitrary MultiMatchQueryType where arbitrary = arbitraryMultiMatchQueryType
|
||||||
|
makeArbitrary ''BooleanOperator
|
||||||
|
instance Arbitrary BooleanOperator where arbitrary = arbitraryBooleanOperator
|
||||||
|
makeArbitrary ''ZeroTermsQuery
|
||||||
|
instance Arbitrary ZeroTermsQuery where arbitrary = arbitraryZeroTermsQuery
|
||||||
|
makeArbitrary ''MatchQueryType
|
||||||
|
instance Arbitrary MatchQueryType where arbitrary = arbitraryMatchQueryType
|
||||||
|
makeArbitrary ''SearchAliasRouting
|
||||||
|
instance Arbitrary SearchAliasRouting where arbitrary = arbitrarySearchAliasRouting
|
||||||
|
makeArbitrary ''ScoreType
|
||||||
|
instance Arbitrary ScoreType where arbitrary = arbitraryScoreType
|
||||||
|
makeArbitrary ''Distance
|
||||||
|
instance Arbitrary Distance where arbitrary = arbitraryDistance
|
||||||
|
makeArbitrary ''DistanceUnit
|
||||||
|
instance Arbitrary DistanceUnit where arbitrary = arbitraryDistanceUnit
|
||||||
|
makeArbitrary ''DistanceType
|
||||||
|
instance Arbitrary DistanceType where arbitrary = arbitraryDistanceType
|
||||||
|
makeArbitrary ''OptimizeBbox
|
||||||
|
instance Arbitrary OptimizeBbox where arbitrary = arbitraryOptimizeBbox
|
||||||
|
makeArbitrary ''GeoBoundingBoxConstraint
|
||||||
|
instance Arbitrary GeoBoundingBoxConstraint where arbitrary = arbitraryGeoBoundingBoxConstraint
|
||||||
|
makeArbitrary ''GeoFilterType
|
||||||
|
instance Arbitrary GeoFilterType where arbitrary = arbitraryGeoFilterType
|
||||||
|
makeArbitrary ''GeoBoundingBox
|
||||||
|
instance Arbitrary GeoBoundingBox where arbitrary = arbitraryGeoBoundingBox
|
||||||
|
makeArbitrary ''LatLon
|
||||||
|
instance Arbitrary LatLon where arbitrary = arbitraryLatLon
|
||||||
|
makeArbitrary ''RangeExecution
|
||||||
|
instance Arbitrary RangeExecution where arbitrary = arbitraryRangeExecution
|
||||||
|
makeArbitrary ''RegexpFlag
|
||||||
|
instance Arbitrary RegexpFlag where arbitrary = arbitraryRegexpFlag
|
||||||
|
makeArbitrary ''BoolMatch
|
||||||
|
instance Arbitrary BoolMatch where arbitrary = arbitraryBoolMatch
|
||||||
|
makeArbitrary ''Term
|
||||||
|
instance Arbitrary Term where arbitrary = arbitraryTerm
|
||||||
|
makeArbitrary ''IndexSettings
|
||||||
|
instance Arbitrary IndexSettings where arbitrary = arbitraryIndexSettings
|
||||||
|
makeArbitrary ''UpdatableIndexSetting
|
||||||
|
instance Arbitrary UpdatableIndexSetting where
|
||||||
|
arbitrary = arbitraryUpdatableIndexSetting
|
||||||
|
makeArbitrary ''Bytes
|
||||||
|
instance Arbitrary Bytes where arbitrary = arbitraryBytes
|
||||||
|
makeArbitrary ''AllocationPolicy
|
||||||
|
instance Arbitrary AllocationPolicy where arbitrary = arbitraryAllocationPolicy
|
||||||
|
makeArbitrary ''InitialShardCount
|
||||||
|
instance Arbitrary InitialShardCount where arbitrary = arbitraryInitialShardCount
|
||||||
|
makeArbitrary ''FSType
|
||||||
|
instance Arbitrary FSType where arbitrary = arbitraryFSType
|
||||||
|
makeArbitrary ''CompoundFormat
|
||||||
|
instance Arbitrary CompoundFormat where arbitrary = arbitraryCompoundFormat
|
||||||
|
makeArbitrary ''FsSnapshotRepo
|
||||||
|
instance Arbitrary FsSnapshotRepo where arbitrary = arbitraryFsSnapshotRepo
|
||||||
|
makeArbitrary ''SnapshotRepoName
|
||||||
|
instance Arbitrary SnapshotRepoName where arbitrary = arbitrarySnapshotRepoName
|
||||||
|
makeArbitrary ''TemplateQueryInline
|
||||||
|
instance Arbitrary TemplateQueryInline where arbitrary = arbitraryTemplateQueryInline
|
||||||
|
makeArbitrary ''DirectGeneratorSuggestModeTypes
|
||||||
|
instance Arbitrary DirectGeneratorSuggestModeTypes where arbitrary = arbitraryDirectGeneratorSuggestModeTypes
|
||||||
|
makeArbitrary ''DirectGenerators
|
||||||
|
instance Arbitrary DirectGenerators where arbitrary = arbitraryDirectGenerators
|
||||||
|
makeArbitrary ''PhraseSuggesterCollate
|
||||||
|
instance Arbitrary PhraseSuggesterCollate where arbitrary = arbitraryPhraseSuggesterCollate
|
||||||
|
makeArbitrary ''PhraseSuggesterHighlighter
|
||||||
|
instance Arbitrary PhraseSuggesterHighlighter where arbitrary = arbitraryPhraseSuggesterHighlighter
|
||||||
|
makeArbitrary ''Size
|
||||||
|
instance Arbitrary Size where arbitrary = arbitrarySize
|
||||||
|
makeArbitrary ''PhraseSuggester
|
||||||
|
instance Arbitrary PhraseSuggester where arbitrary = arbitraryPhraseSuggester
|
||||||
|
makeArbitrary ''SuggestType
|
||||||
|
instance Arbitrary SuggestType where arbitrary = arbitrarySuggestType
|
||||||
|
makeArbitrary ''Suggest
|
||||||
|
instance Arbitrary Suggest where arbitrary = arbitrarySuggest
|
||||||
|
|
||||||
|
|
||||||
|
makeArbitrary ''Script
|
||||||
|
instance Arbitrary Script where arbitrary = arbitraryScript
|
||||||
|
|
||||||
|
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
|
||||||
|
-- shrink (UpdatableIndexSetting' x) = map UpdatableIndexSetting' (shrink x)
|
32
tests/V1/Test/Highlights.hs
Normal file
32
tests/V1/Test/Highlights.hs
Normal file
@ -0,0 +1,32 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Highlights where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.Map as M
|
||||||
|
|
||||||
|
initHighlights :: Text -> BH IO (Either EsError (Maybe HitHighlight))
|
||||||
|
initHighlights fieldName = do
|
||||||
|
_ <- insertData
|
||||||
|
_ <- insertOther
|
||||||
|
let query = QueryMatchQuery $ mkMatchQuery (FieldName fieldName) (QueryString "haskell")
|
||||||
|
let testHighlight = Highlights Nothing [FieldHighlight (FieldName fieldName) Nothing]
|
||||||
|
let search = mkHighlightSearch (Just query) testHighlight
|
||||||
|
searchTweetHighlight search
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "Highlights API" $ do
|
||||||
|
it "returns highlight from query when there should be one" $ withTestEnv $ do
|
||||||
|
myHighlight <- initHighlights "message"
|
||||||
|
liftIO $
|
||||||
|
myHighlight `shouldBe`
|
||||||
|
Right (Just (M.fromList [("message", ["Use <em>haskell</em>!"])]))
|
||||||
|
|
||||||
|
it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do
|
||||||
|
myHighlight <- initHighlights "user"
|
||||||
|
liftIO $
|
||||||
|
myHighlight `shouldBe`
|
||||||
|
Right Nothing
|
58
tests/V1/Test/Import.hs
Normal file
58
tests/V1/Test/Import.hs
Normal file
@ -0,0 +1,58 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Import
|
||||||
|
( module X
|
||||||
|
, module Test.Import
|
||||||
|
) where
|
||||||
|
|
||||||
|
|
||||||
|
import Control.Applicative as X
|
||||||
|
import Control.Exception as X (evaluate)
|
||||||
|
import Control.Monad as X
|
||||||
|
import Control.Monad.Catch as X
|
||||||
|
import Control.Monad.Reader as X
|
||||||
|
import Data.Aeson as X
|
||||||
|
import Data.Aeson.TH as X
|
||||||
|
import Data.Aeson.Types as X (parseEither)
|
||||||
|
import Data.Maybe as X
|
||||||
|
import Data.List.NonEmpty as X (NonEmpty(..))
|
||||||
|
import Data.Monoid as X
|
||||||
|
import Data.Ord as X (comparing)
|
||||||
|
import Data.Proxy as X
|
||||||
|
import Data.Text as X (Text)
|
||||||
|
import Data.Time.Calendar as X (Day(..), fromGregorian)
|
||||||
|
import Data.Time.Clock as X
|
||||||
|
import Data.Typeable as X
|
||||||
|
import Database.V1.Bloodhound as X hiding (key)
|
||||||
|
import Lens.Micro as X
|
||||||
|
import Lens.Micro.Aeson as X
|
||||||
|
import Network.HTTP.Client as X hiding (Proxy, fileSize)
|
||||||
|
import System.IO.Temp as X
|
||||||
|
import System.PosixCompat.Files as X
|
||||||
|
import Test.Hspec as X
|
||||||
|
import Test.Hspec.QuickCheck as X (prop)
|
||||||
|
import Test.QuickCheck as X hiding (Result, Success)
|
||||||
|
import Test.QuickCheck.Property.Monoid as X (T (..), eq, prop_Monoid)
|
||||||
|
import Text.Pretty.Simple as X (pPrint)
|
||||||
|
|
||||||
|
import qualified Data.List as L
|
||||||
|
|
||||||
|
noDuplicates :: Eq a => [a] -> Bool
|
||||||
|
noDuplicates xs = L.nub xs == xs
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
when' :: Monad m => m Bool -> m () -> m ()
|
||||||
|
when' b f = b >>= \x -> when x f
|
||||||
|
|
||||||
|
headMay :: [a] -> Maybe a
|
||||||
|
headMay (x : _) = Just x
|
||||||
|
headMay _ = Nothing
|
78
tests/V1/Test/Indices.hs
Normal file
78
tests/V1/Test/Indices.hs
Normal file
@ -0,0 +1,78 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Indices where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.List as L
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = 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 "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
|
||||||
|
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))
|
||||||
|
|
||||||
|
it "allows total fields to be set" $ when' (atleast es50) $ withTestEnv $ do
|
||||||
|
_ <- deleteExampleIndex
|
||||||
|
_ <- createExampleIndex
|
||||||
|
let updates = FailOnMergeFailure True :| []
|
||||||
|
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
|
202
tests/V1/Test/JSON.hs
Normal file
202
tests/V1/Test/JSON.hs
Normal file
@ -0,0 +1,202 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
module Test.JSON (spec) where
|
||||||
|
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.ByteString.Lazy.Char8 as BL8
|
||||||
|
import qualified Data.List as L
|
||||||
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
|
import qualified Data.List.NonEmpty as NE
|
||||||
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Vector as V
|
||||||
|
|
||||||
|
import Test.ApproxEq
|
||||||
|
import Test.Generators
|
||||||
|
|
||||||
|
propJSON :: forall a
|
||||||
|
. ( Arbitrary a
|
||||||
|
, ToJSON a
|
||||||
|
, FromJSON a
|
||||||
|
, Show a
|
||||||
|
, Eq 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)
|
||||||
|
|
||||||
|
propApproxJSON :: forall a
|
||||||
|
. ( Arbitrary a
|
||||||
|
, ToJSON a
|
||||||
|
, FromJSON a
|
||||||
|
, Show a
|
||||||
|
, ApproxEq a
|
||||||
|
, Typeable a
|
||||||
|
)
|
||||||
|
=> Proxy a -> Spec
|
||||||
|
propApproxJSON _ = 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)
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
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 "Exact isomorphism 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 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 (L.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 CompoundFormat)
|
||||||
|
propJSON (Proxy :: Proxy TemplateQueryInline)
|
||||||
|
propJSON (Proxy :: Proxy Suggest)
|
||||||
|
propJSON (Proxy :: Proxy DirectGenerators)
|
||||||
|
propJSON (Proxy :: Proxy DirectGeneratorSuggestModeTypes)
|
||||||
|
|
||||||
|
describe "Approximate isomorphism JSON instances" $ do
|
||||||
|
propApproxJSON (Proxy :: Proxy UpdatableIndexSetting')
|
||||||
|
propApproxJSON (Proxy :: Proxy ReplicaCount)
|
||||||
|
propApproxJSON (Proxy :: Proxy ReplicaBounds)
|
||||||
|
propApproxJSON (Proxy :: Proxy Bytes)
|
||||||
|
propApproxJSON (Proxy :: Proxy AllocationPolicy)
|
||||||
|
propApproxJSON (Proxy :: Proxy InitialShardCount)
|
||||||
|
propApproxJSON (Proxy :: Proxy FSType)
|
115
tests/V1/Test/Query.hs
Normal file
115
tests/V1/Test/Query.hs
Normal file
@ -0,0 +1,115 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Query where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
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
|
||||||
|
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 "returns document for terms query and identity filter" $ withTestEnv $ do
|
||||||
|
_ <- insertData
|
||||||
|
let query = TermsQuery "user" ("bitemyapp" :| [])
|
||||||
|
let filter' = 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
|
201
tests/V1/Test/Snapshots.hs
Normal file
201
tests/V1/Test/Snapshots.hs
Normal file
@ -0,0 +1,201 @@
|
|||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Snapshots (spec) where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import Data.Maybe (fromMaybe)
|
||||||
|
import qualified Data.List as L
|
||||||
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Vector as V
|
||||||
|
import qualified Network.HTTP.Types.Method as NHTM
|
||||||
|
import qualified Network.URI as URI
|
||||||
|
|
||||||
|
import Test.Generators ()
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "FsSnapshotRepo" $
|
||||||
|
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
|
||||||
|
|
||||||
|
-- | 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))
|
||||||
|
|
||||||
|
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 =
|
||||||
|
deleteSnapshot srn sn
|
22
tests/V1/Test/Sorting.hs
Normal file
22
tests/V1/Test/Sorting.hs
Normal file
@ -0,0 +1,22 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Sorting where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "sorting" $
|
||||||
|
it "returns documents in the right order" $ withTestEnv $ do
|
||||||
|
_ <- insertData
|
||||||
|
_ <- insertOther
|
||||||
|
let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
|
||||||
|
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 $
|
||||||
|
myTweet `shouldBe` Right otherTweet
|
38
tests/V1/Test/SourceFiltering.hs
Normal file
38
tests/V1/Test/SourceFiltering.hs
Normal file
@ -0,0 +1,38 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.SourceFiltering where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "Source filtering" $ do
|
||||||
|
|
||||||
|
it "doesn't include source when sources are disabled" $ withTestEnv $
|
||||||
|
searchExpectSource
|
||||||
|
NoSource
|
||||||
|
(Left (EsError 500 "Source was missing"))
|
||||||
|
|
||||||
|
it "includes a source" $ withTestEnv $
|
||||||
|
searchExpectSource
|
||||||
|
(SourcePatterns (PopPattern (Pattern "message")))
|
||||||
|
(Right (Object (HM.fromList [("message", String "Use haskell!")])))
|
||||||
|
|
||||||
|
it "includes sources" $ withTestEnv $
|
||||||
|
searchExpectSource
|
||||||
|
(SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))
|
||||||
|
(Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))
|
||||||
|
|
||||||
|
it "includes source patterns" $ withTestEnv $
|
||||||
|
searchExpectSource
|
||||||
|
(SourcePatterns (PopPattern (Pattern "*ge")))
|
||||||
|
(Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))
|
||||||
|
|
||||||
|
it "excludes source patterns" $ withTestEnv $
|
||||||
|
searchExpectSource
|
||||||
|
(SourceIncludeExclude (Include [])
|
||||||
|
(Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"]))
|
||||||
|
(Right (Object (HM.fromList [("user",String "bitemyapp")])))
|
22
tests/V1/Test/Suggest.hs
Normal file
22
tests/V1/Test/Suggest.hs
Normal file
@ -0,0 +1,22 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Suggest where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
describe "Suggest" $
|
||||||
|
it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do
|
||||||
|
_ <- insertData
|
||||||
|
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
|
26
tests/V1/Test/Templates.hs
Normal file
26
tests/V1/Test/Templates.hs
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Test.Templates where
|
||||||
|
|
||||||
|
import Test.Common
|
||||||
|
import Test.Import
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec =
|
||||||
|
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
|
1928
tests/V1/tests.hs
1928
tests/V1/tests.hs
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user