mirror of
https://github.com/typeable/bloodhound.git
synced 2024-11-22 09:32:06 +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:
Michael Xavier
parent
99788cc992
commit
14379a3c5a
@ -30,7 +30,7 @@ Flag ES1
|
||||
Flag ES5
|
||||
Description: Run the test suite against an Elasticsearch 5.x server
|
||||
Default: True
|
||||
|
||||
|
||||
library
|
||||
ghc-options: -Wall
|
||||
exposed-modules: Database.V5.Bloodhound
|
||||
@ -51,16 +51,15 @@ library
|
||||
Database.V1.Bloodhound.Client
|
||||
Database.V1.Bloodhound.Types
|
||||
Database.V1.Bloodhound.Types.Class
|
||||
|
||||
-- Database.V1.Bloodhound.Internal.Aggregation
|
||||
-- Database.V1.Bloodhound.Internal.Analysis
|
||||
-- Database.V1.Bloodhound.Internal.Client
|
||||
-- Database.V1.Bloodhound.Internal.Highlight
|
||||
-- Database.V1.Bloodhound.Internal.Newtypes
|
||||
-- Database.V1.Bloodhound.Internal.Query
|
||||
-- Database.V1.Bloodhound.Internal.Sort
|
||||
Database.V1.Bloodhound.Internal.Aggregation
|
||||
Database.V1.Bloodhound.Internal.Client
|
||||
Database.V1.Bloodhound.Internal.Highlight
|
||||
Database.V1.Bloodhound.Internal.Newtypes
|
||||
Database.V1.Bloodhound.Internal.Query
|
||||
Database.V1.Bloodhound.Internal.Sort
|
||||
Database.V1.Bloodhound.Internal.StringlyTyped
|
||||
-- Database.V1.Bloodhound.Internal.Suggest
|
||||
Database.V1.Bloodhound.Internal.Suggest
|
||||
|
||||
other-modules: Bloodhound.Import
|
||||
Database.Bloodhound.Common.Script
|
||||
hs-source-dirs: src
|
||||
@ -103,7 +102,6 @@ test-suite bloodhound-tests
|
||||
Test.Indices
|
||||
Test.JSON
|
||||
Test.Query
|
||||
Test.Script
|
||||
Test.Snapshots
|
||||
Test.Sorting
|
||||
Test.SourceFiltering
|
||||
|
||||
@ -8,6 +8,7 @@ module Bloodhound.Import
|
||||
, readMay
|
||||
, showText
|
||||
, deleteSeveral
|
||||
, oPath
|
||||
) where
|
||||
|
||||
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 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
|
||||
|
||||
import Bloodhound.Import
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Text
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Map.Strict as M
|
||||
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.Query
|
||||
import Database.V1.Bloodhound.Internal.Sort
|
||||
@ -88,7 +90,7 @@ data TopHitsAggregation = TopHitsAggregation
|
||||
{ taFrom :: Maybe From
|
||||
, taSize :: Maybe Size
|
||||
, taSort :: Maybe Sort
|
||||
} deriving (Eq, Read, Show)
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data MissingAggregation = MissingAggregation
|
||||
{ maField :: Text
|
||||
@ -224,3 +226,191 @@ data DateMathUnit =
|
||||
| DMMinute
|
||||
| DMSecond
|
||||
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
|
||||
|
||||
|
||||
import Bloodhound.Import
|
||||
|
||||
|
||||
newtype From = From Int deriving (Eq, Show, ToJSON)
|
||||
newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON)
|
||||
|
||||
@ -16,7 +14,7 @@ newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON)
|
||||
-}
|
||||
newtype FieldName =
|
||||
FieldName Text
|
||||
deriving (Eq, Read, Show, ToJSON, FromJSON)
|
||||
deriving (Eq, Show, ToJSON, FromJSON)
|
||||
|
||||
newtype Boost =
|
||||
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 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 RecordWildCards #-}
|
||||
|
||||
module Database.V1.Bloodhound.Internal.Query
|
||||
( module X
|
||||
, module Database.V1.Bloodhound.Internal.Query
|
||||
) where
|
||||
module Database.V1.Bloodhound.Internal.Query where
|
||||
|
||||
|
||||
import Bloodhound.Import
|
||||
@ -13,8 +10,8 @@ import Bloodhound.Import
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Database.Bloodhound.Common.Script as X
|
||||
import Database.V5.Bloodhound.Internal.Newtypes
|
||||
import Database.V1.Bloodhound.Internal.Newtypes
|
||||
import Database.V1.Bloodhound.Types.Class
|
||||
|
||||
|
||||
data GeoPoint =
|
||||
@ -99,6 +96,15 @@ data Filter = AndFilter [Filter] Cache
|
||||
| TermFilter Term Cache
|
||||
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
|
||||
| MustNotMatch Term Cache
|
||||
|
||||
@ -25,6 +25,22 @@ type Sort = [SortSpec]
|
||||
data SortSpec = DefaultSortSpec DefaultSort
|
||||
| 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
|
||||
'mkSort' convenience function for when you want to specify only the most
|
||||
common parameters.
|
||||
@ -49,6 +65,10 @@ data SortOrder = Ascending
|
||||
| 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.
|
||||
|
||||
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 FirstMissing = String "_first"
|
||||
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 Database.V5.Bloodhound.Internal.Newtypes
|
||||
import Database.V5.Bloodhound.Internal.Query
|
||||
import Database.V1.Bloodhound.Internal.Newtypes
|
||||
import Database.V1.Bloodhound.Internal.Query
|
||||
|
||||
data Suggest = Suggest { suggestText :: Text
|
||||
, suggestName :: Text
|
||||
@ -209,7 +209,7 @@ data SuggestOptions =
|
||||
, suggestOptionsFreq :: Maybe Int
|
||||
, suggestOptionsHighlighted :: Maybe Text
|
||||
}
|
||||
deriving (Eq, Read, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON SuggestOptions where
|
||||
parseJSON = withObject "SuggestOptions" parse
|
||||
@ -225,7 +225,7 @@ data SuggestResponse =
|
||||
, suggestResponseLength :: Int
|
||||
, suggestResponseOptions :: [SuggestOptions]
|
||||
}
|
||||
deriving (Eq, Read, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON SuggestResponse where
|
||||
parseJSON = withObject "SuggestResponse" parse
|
||||
@ -239,7 +239,7 @@ data NamedSuggestionResponse =
|
||||
NamedSuggestionResponse { nsrName :: Text
|
||||
, nsrResponses :: [SuggestResponse]
|
||||
}
|
||||
deriving (Eq, Read, Show)
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromJSON NamedSuggestionResponse where
|
||||
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.
|
||||
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 fs = object [ n .= T.intercalate "," (toList vs)
|
||||
| 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