bc0da4a · typeable/bloodhound

git.iko.soy/typeable/bloodhound

hlint, weeder

commitbc0da4a4eb142e5bdef75384881b66cfcdd887df authorChris Allen <cma@bitemyapp.com> dateTue 13 Feb 2018, 15:47 (9 years ago) parent103aac6

23 files changed+983−846

compare with master

unifiedsplit

.hlint.yamlnew file+66

@@ -0,0 +1,66 @@

1+# HLint configuration file

2+# https://github.com/ndmitchell/hlint

3+##########################

5+# This file contains a template configuration file, which is typically

6+# placed as .hlint.yaml in the root of your project

9+# Specify additional command line arguments

10+#

11+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]

12+

13+

14+# Control which extensions/flags/modules/functions can be used

15+#

16+# - extensions:

17+# - default: false # all extension are banned by default

18+# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used

19+# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module

20+#

21+# - flags:

22+# - {name: -w, within: []} # -w is allowed nowhere

23+#

24+# - modules:

25+# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'

26+# - {name: Control.Arrow, within: []} # Certain modules are banned entirely

27+#

28+# - functions:

29+# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules

30+

31+

32+# Add custom hints for this project

33+#

34+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"

35+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}

36+

37+

38+# Turn on hints that are off by default

39+#

40+# Ban "module X(module X) where", to require a real export list

41+# - warn: {name: Use explicit module export list}

42+#

43+# Replace a $ b $ c with a . b $ c

44+# - group: {name: dollar, enabled: true}

45+#

46+# Generalise map to fmap, ++ to <>

47+# - group: {name: generalise, enabled: true}

48+

49+

50+# Ignore some builtin hints

51+- ignore: {name: "Use <$>"}

52+- ignore: {name: "Use lambda-case"}

53+# When we don't use camelCase it's to match ES.

54+# Possibly this is a mistake.

55+- ignore: {name: "Use camelCase"}

56+- ignore: {name: "Eta reduce"}

57+# - ignore: {name: Use let}

58+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules

59+

60+

61+# Define some custom infix operators

62+# - fixity: infixr 3 ~^#^~

63+

64+

65+# To generate a suitable file for HLint do:

66+# $ hlint --default > .hlint.yaml

Makefile+16

@@ -3,6 +3,9 @@ stack = STACK_YAML='stack.yaml' stack

33build:

44 stack build

6+build-validate:

7+ stack build --fast --ghc-options '-Werror'

69ghci:

710 stack ghci

811

@@ -18,6 +21,19 @@ test-ghci:

1821ghcid:

1922 ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"

2023

24+ghcid-validate:

25+ ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-Werror -fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"

26+

27+weeder:

28+ weeder . --build

29+

30+# hlint --default > .hlint.yaml

31+hlint:

32+ hlint .

33+

34+hlint-watch:

35+ sos src/ -c "hlint ." -p "src/(.*)\.hs"

36+

2137mod-build:

2238 stack build --ghc-options '+RTS -A128M -RTS'

2339

bloodhound.cabal+8−12

@@ -37,6 +37,11 @@ library

3737 Database.V5.Bloodhound.Client

3838 Database.V5.Bloodhound.Types

3939 Database.V5.Bloodhound.Types.Class

40+ Database.V5.Bloodhound.Internal.Analysis

41+ Database.V5.Bloodhound.Internal.Client

42+ Database.V5.Bloodhound.Internal.Newtypes

43+ Database.V5.Bloodhound.Internal.Query

44+ Database.V5.Bloodhound.Internal.StringlyTyped

4045 Database.V1.Bloodhound

4146 Database.V1.Bloodhound.Client

4247 Database.V1.Bloodhound.Types

@@ -44,11 +49,6 @@ library

4449 Database.V1.Bloodhound.Types.Internal

4550 other-modules: Bloodhound.Import

4651 Database.Bloodhound.Common.Script

47− Database.V5.Bloodhound.Internal.Analysis

48− Database.V5.Bloodhound.Internal.Client

49− Database.V5.Bloodhound.Internal.Newtypes

50− Database.V5.Bloodhound.Internal.Query

51− Database.V5.Bloodhound.Internal.StringlyTyped

5252 hs-source-dirs: src

5353 build-depends: base >= 4.3 && <5,

5454 bytestring >= 0.10.0 && <0.11,

@@ -64,13 +64,10 @@ library

6464 http-types >= 0.8 && <0.13,

6565 vector >= 0.10.9 && <0.13,

6666 scientific >= 0.3.0.0 && <0.4.0.0,

67− bifunctors,

68− exceptions,

69− data-default-class,

7067 blaze-builder,

71− unordered-containers,

72− mtl-compat,

73− hashable

68+ exceptions,

69+ hashable,

70+ unordered-containers

7471 default-language: Haskell2010

7572

7673test-suite bloodhound-tests

@@ -116,7 +113,6 @@ test-suite bloodhound-tests

116113 pretty-simple,

117114 quickcheck-arbitrary-template,

118115 quickcheck-properties,

119− generics-sop >=0.2 && <0.4,

120116 errors,

121117 exceptions,

122118 temporary,

src/Database/V1/Bloodhound/Client.hs+13−9

@@ -223,7 +223,8 @@ getStatus :: MonadBH m => m (Maybe Status)

223223getStatus = do

224224 response <- get =<< url

225225 return $ decode (responseBody response)

226− where url = joinPath []

226+ where

227+ url = joinPath []

227228

228229-- | 'getSnapshotRepos' gets the definitions of a subset of the

229230-- defined snapshot repos.

@@ -252,7 +253,7 @@ instance FromJSON GSRs where

252253 parseJSON = withObject "Collection of GenericSnapshotRepo" parse

253254 where

254255 parse = fmap GSRs . mapM (uncurry go) . HM.toList

255− go rawName = withObject "GenericSnapshotRepo" $ \o -> do

256+ go rawName = withObject "GenericSnapshotRepo" $ \o ->

256257 GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type"

257258 <*> o .: "settings"

258259

@@ -454,16 +455,18 @@ deleteIndex (IndexName indexName) =

454455updateIndexSettings :: MonadBH m => NonEmpty UpdatableIndexSetting -> IndexName -> m Reply

455456updateIndexSettings updates (IndexName indexName) =

456457 bindM2 put url (return body)

457− where url = joinPath [indexName, "_settings"]

458− body = Just (encode jsonBody)

459− jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])

458+ where

459+ url = joinPath [indexName, "_settings"]

460+ body = Just (encode jsonBody)

461+ jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])

460462

461463

462464getIndexSettings :: (MonadBH m, MonadThrow m) => IndexName

463465 -> m (Either EsError IndexSettingsSummary)

464−getIndexSettings (IndexName indexName) = do

466+getIndexSettings (IndexName indexName) =

465467 parseEsResponse =<< get =<< url

466− where url = joinPath [indexName, "_settings"]

468+ where

469+ url = joinPath [indexName, "_settings"]

467470

468471

469472-- | 'optimizeIndex' will optimize a single index, list of indexes or

@@ -586,7 +589,7 @@ listIndices =

586589 url = joinPath ["_cat/indices?format=json"]

587590 parse body = maybe (throwM (EsProtocolException body)) return $ do

588591 vals <- decode body

589− forM vals $ \val -> do

592+ forM vals $ \val ->

590593 case val of

591594 Object obj -> do

592595 indexVal <- HM.lookup "index" obj

@@ -718,7 +721,8 @@ encodeBulkOperations stream = collapsed where

718721 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")

719722

720723mash :: Builder -> V.Vector L.ByteString -> Builder

721−mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))

724+mash =

725+ V.foldl' (\b x -> b <> byteString "\n" <> lazyByteString x)

722726

723727mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value

724728mkBulkStreamValue operation indexName mappingName docId =

src/Database/V1/Bloodhound/Types.hs+7−5

@@ -4,7 +4,6 @@

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE GeneralizedNewtypeDeriving #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

7−-- {-# LANGUAGE NoMonomorphismRestriction #-}

87{-# LANGUAGE NamedFieldPuns #-}

98{-# LANGUAGE OverloadedStrings #-}

109{-# LANGUAGE RecordWildCards #-}

@@ -1137,8 +1136,10 @@ data Source =

11371136 | SourceIncludeExclude Include Exclude

11381137 deriving (Read, Show, Eq, Generic, Typeable)

11391138

1140−data PatternOrPatterns = PopPattern Pattern

1141− | PopPatterns [Pattern] deriving (Eq, Read, Show, Generic, Typeable)

1139+data PatternOrPatterns =

1140+ PopPattern Pattern

1141+ | PopPatterns [Pattern]

1142+ deriving (Eq, Read, Show, Generic, Typeable)

11421143

11431144data Include = Include [Pattern] deriving (Eq, Read, Show, Generic, Typeable)

11441145data Exclude = Exclude [Pattern] deriving (Eq, Read, Show, Generic, Typeable)

@@ -1906,8 +1907,9 @@ instance ToJSON TermOrder where

19061907

19071908instance ToJSON TermInclusion where

19081909 toJSON (TermInclusion x) = toJSON x

1909− toJSON (TermPattern pattern flags) = omitNulls [ "pattern" .= pattern,

1910− "flags" .= flags]

1910+ toJSON (TermPattern pattern flags) =

1911+ omitNulls [ "pattern" .= pattern

1912+ , "flags" .= flags]

19111913

19121914instance ToJSON CollectionMode where

19131915 toJSON BreadthFirst = "breadth_first"

src/Database/V5/Bloodhound/Client.hs+14−11

@@ -317,7 +317,7 @@ instance FromJSON GSRs where

317317 parseJSON = withObject "Collection of GenericSnapshotRepo" parse

318318 where

319319 parse = fmap GSRs . mapM (uncurry go) . HM.toList

320− go rawName = withObject "GenericSnapshotRepo" $ \o -> do

320+ go rawName = withObject "GenericSnapshotRepo" $ \o ->

321321 GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type"

322322 <*> o .: "settings"

323323

@@ -555,16 +555,18 @@ deleteIndex (IndexName indexName) =

555555updateIndexSettings :: MonadBH m => NonEmpty UpdatableIndexSetting -> IndexName -> m Reply

556556updateIndexSettings updates (IndexName indexName) =

557557 bindM2 put url (return body)

558− where url = joinPath [indexName, "_settings"]

559− body = Just (encode jsonBody)

560− jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])

558+ where

559+ url = joinPath [indexName, "_settings"]

560+ body = Just (encode jsonBody)

561+ jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])

561562

562563

563564getIndexSettings :: (MonadBH m, MonadThrow m) => IndexName

564565 -> m (Either EsError IndexSettingsSummary)

565−getIndexSettings (IndexName indexName) = do

566+getIndexSettings (IndexName indexName) =

566567 parseEsResponse =<< get =<< url

567− where url = joinPath [indexName, "_settings"]

568+ where

569+ url = joinPath [indexName, "_settings"]

568570

569571-- | 'forceMergeIndex'

570572--

@@ -704,7 +706,7 @@ listIndices =

704706 url = joinPath ["_cat/indices?format=json"]

705707 parse body = maybe (throwM (EsProtocolException body)) return $ do

706708 vals <- decode body

707− forM vals $ \val -> do

709+ forM vals $ \val ->

708710 case val of

709711 Object obj -> do

710712 indexVal <- HM.lookup "index" obj

@@ -861,10 +863,11 @@ deleteDocument (IndexName indexName)

861863-- >>> _ <- runBH' $ bulk stream

862864-- >>> _ <- runBH' $ refreshIndex testIndex

863865bulk :: MonadBH m => V.Vector BulkOperation -> m Reply

864−bulk bulkOps = do

866+bulk bulkOps =

865867 bindM2 post url (return body)

866− where url = joinPath ["_bulk"]

867− body = Just $ encodeBulkOperations bulkOps

868+ where

869+ url = joinPath ["_bulk"]

870+ body = Just $ encodeBulkOperations bulkOps

868871

869872-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'

870873-- into an 'L.ByteString'

@@ -882,7 +885,7 @@ encodeBulkOperations stream = collapsed where

882885 toLazyByteString $ mappend mashedTaters (byteString "\n")

883886

884887mash :: Builder -> V.Vector L.ByteString -> Builder

885−mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))

888+mash = V.foldl' (\b x -> b <> byteString "\n" <> lazyByteString x)

886889

887890mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value

888891mkBulkStreamValue operation indexName mappingName docId =

src/Database/V5/Bloodhound/Internal/Analysis.hs+4−4

@@ -52,8 +52,8 @@ instance FromJSON AnalyzerDefinition where

5252 <$> m .:? "tokenizer"

5353 <*> m .:? "filter" .!= []

5454

55−data TokenizerDefinition

56− = TokenizerDefinitionNgram Ngram

55+newtype TokenizerDefinition =

56+ TokenizerDefinitionNgram Ngram

5757 deriving (Eq,Show)

5858

5959instance ToJSON TokenizerDefinition where

@@ -70,8 +70,8 @@ instance FromJSON TokenizerDefinition where

7070 typ <- m .: "type" :: Parser Text

7171 case typ of

7272 "ngram" -> fmap TokenizerDefinitionNgram $ Ngram

73− <$> (fmap unStringlyTypedInt (m .: "min_gram"))

74− <*> (fmap unStringlyTypedInt (m .: "max_gram"))

73+ <$> fmap unStringlyTypedInt (m .: "min_gram")

74+ <*> fmap unStringlyTypedInt (m .: "max_gram")

7575 <*> m .: "token_chars"

7676 _ -> fail "invalid TokenizerDefinition"

7777

src/Database/V5/Bloodhound/Internal/Client.hs+393−60

@@ -10,6 +10,7 @@ module Database.V5.Bloodhound.Internal.Client where

1010import Bloodhound.Import

1111

1212import qualified Data.Text as T

13+import qualified Data.Traversable as DT

1314import qualified Data.HashMap.Strict as HM

1415import qualified Data.Vector as V

1516import qualified Data.Version as Vers

@@ -114,6 +115,15 @@ data Status = Status

114115 , tagline :: Text }

115116 deriving (Eq, Show)

116117

118+instance FromJSON Status where

119+ parseJSON (Object v) = Status <$>

120+ v .: "name" <*>

121+ v .: "cluster_name" <*>

122+ v .: "cluster_uuid" <*>

123+ v .: "version" <*>

124+ v .: "tagline"

125+ parseJSON _ = empty

126+

117127{-| 'IndexSettings' is used to configure the shards and replicas when

118128 you create an Elasticsearch Index.

119129

@@ -125,6 +135,20 @@ data IndexSettings = IndexSettings

125135 , indexReplicas :: ReplicaCount }

126136 deriving (Eq, Show)

127137

138+instance ToJSON IndexSettings where

139+ toJSON (IndexSettings s r) = object ["settings" .=

140+ object ["index" .=

141+ object ["number_of_shards" .= s, "number_of_replicas" .= r]

142+ ]

143+ ]

144+

145+instance FromJSON IndexSettings where

146+ parseJSON = withObject "IndexSettings" parse

147+ where parse o = do s <- o .: "settings"

148+ i <- s .: "index"

149+ IndexSettings <$> i .: "number_of_shards"

150+ <*> i .: "number_of_replicas"

151+

128152{-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and

129153 2 replicas. -}

130154defaultIndexSettings :: IndexSettings

@@ -212,11 +236,150 @@ data UpdatableIndexSetting = NumberOfReplicas ReplicaCount

212236 -- ^ Analysis is not a dynamic setting and can only be performed on a closed index.

213237 deriving (Eq, Show)

214238

239+oPath :: ToJSON a => NonEmpty Text -> a -> Value

240+oPath (k :| []) v = object [k .= v]

241+oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]

242+

243+attrFilterJSON :: NonEmpty NodeAttrFilter -> Value

244+attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)

245+ | NodeAttrFilter (NodeAttrName n) vs <- toList fs]

246+

247+parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)

248+parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse

249+ where parse o = case HM.toList o of

250+ [] -> fail "Expected non-empty list of NodeAttrFilters"

251+ x:xs -> DT.mapM (uncurry parse') (x :| xs)

252+ parse' n = withText "Text" $ \t ->

253+ case T.splitOn "," t of

254+ fv:fvs -> return (NodeAttrFilter (NodeAttrName n) (fv :| fvs))

255+ [] -> fail "Expected non-empty list of filter values"

256+

257+instance ToJSON UpdatableIndexSetting where

258+ toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x

259+ toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x

260+ toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x)

261+ toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x

262+ toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x

263+ toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x

264+ toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x

265+ toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x)

266+ toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x

267+ toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x

268+ toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x)

269+ toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x)

270+ toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs)

271+ toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs)

272+ toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs)

273+ toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x

274+ toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x

275+ toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x

276+ toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x)

277+ toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x

278+ toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x

279+ toJSON (CompressionSetting x) = oPath ("index" :| ["codec"]) x

280+ toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x

281+ toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x

282+ toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x

283+ toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x

284+ toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x

285+ toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x

286+ toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x

287+ toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping","total_fields","limit"]) x

288+ toJSON (AnalysisSetting x) = oPath ("index" :| ["analysis"]) x

289+

290+instance FromJSON UpdatableIndexSetting where

291+ parseJSON = withObject "UpdatableIndexSetting" parse

292+ where parse o = numberOfReplicas `taggedAt` ["index", "number_of_replicas"]

293+ <|> autoExpandReplicas `taggedAt` ["index", "auto_expand_replicas"]

294+ <|> refreshInterval `taggedAt` ["index", "refresh_interval"]

295+ <|> indexConcurrency `taggedAt` ["index", "concurrency"]

296+ <|> failOnMergeFailure `taggedAt` ["index", "fail_on_merge_failure"]

297+ <|> translogFlushThresholdOps `taggedAt` ["index", "translog", "flush_threshold_ops"]

298+ <|> translogFlushThresholdSize `taggedAt` ["index", "translog", "flush_threshold_size"]

299+ <|> translogFlushThresholdPeriod `taggedAt` ["index", "translog", "flush_threshold_period"]

300+ <|> translogDisableFlush `taggedAt` ["index", "translog", "disable_flush"]

301+ <|> cacheFilterMaxSize `taggedAt` ["index", "cache", "filter", "max_size"]

302+ <|> cacheFilterExpire `taggedAt` ["index", "cache", "filter", "expire"]

303+ <|> gatewaySnapshotInterval `taggedAt` ["index", "gateway", "snapshot_interval"]

304+ <|> routingAllocationInclude `taggedAt` ["index", "routing", "allocation", "include"]

305+ <|> routingAllocationExclude `taggedAt` ["index", "routing", "allocation", "exclude"]

306+ <|> routingAllocationRequire `taggedAt` ["index", "routing", "allocation", "require"]

307+ <|> routingAllocationEnable `taggedAt` ["index", "routing", "allocation", "enable"]

308+ <|> routingAllocationShardsPerNode `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"]

309+ <|> recoveryInitialShards `taggedAt` ["index", "recovery", "initial_shards"]

310+ <|> gcDeletes `taggedAt` ["index", "gc_deletes"]

311+ <|> ttlDisablePurge `taggedAt` ["index", "ttl", "disable_purge"]

312+ <|> translogFSType `taggedAt` ["index", "translog", "fs", "type"]

313+ <|> compressionSetting `taggedAt` ["index", "codec"]

314+ <|> compoundFormat `taggedAt` ["index", "compound_format"]

315+ <|> compoundOnFlush `taggedAt` ["index", "compound_on_flush"]

316+ <|> warmerEnabled `taggedAt` ["index", "warmer", "enabled"]

317+ <|> blocksReadOnly `taggedAt` ["blocks", "read_only"]

318+ <|> blocksRead `taggedAt` ["blocks", "read"]

319+ <|> blocksWrite `taggedAt` ["blocks", "write"]

320+ <|> blocksMetaData `taggedAt` ["blocks", "metadata"]

321+ <|> mappingTotalFieldsLimit `taggedAt` ["index", "mapping", "total_fields", "limit"]

322+ <|> analysisSetting `taggedAt` ["index", "analysis"]

323+ where taggedAt f ks = taggedAt' f (Object o) ks

324+ taggedAt' f v [] =

325+ f =<< (parseJSON v <|> parseJSON (unStringlyTypeJSON v))

326+ taggedAt' f v (k:ks) =

327+ withObject "Object" (\o -> do v' <- o .: k

328+ taggedAt' f v' ks) v

329+ numberOfReplicas = pure . NumberOfReplicas

330+ autoExpandReplicas = pure . AutoExpandReplicas

331+ refreshInterval = pure . RefreshInterval . ndtJSON

332+ indexConcurrency = pure . IndexConcurrency

333+ failOnMergeFailure = pure . FailOnMergeFailure

334+ translogFlushThresholdOps = pure . TranslogFlushThresholdOps

335+ translogFlushThresholdSize = pure . TranslogFlushThresholdSize

336+ translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON

337+ translogDisableFlush = pure . TranslogDisableFlush

338+ cacheFilterMaxSize = pure . CacheFilterMaxSize

339+ cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON

340+ gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON

341+ routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter

342+ routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter

343+ routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter

344+ routingAllocationEnable = pure . RoutingAllocationEnable

345+ routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode

346+ recoveryInitialShards = pure . RecoveryInitialShards

347+ gcDeletes = pure . GCDeletes . ndtJSON

348+ ttlDisablePurge = pure . TTLDisablePurge

349+ translogFSType = pure . TranslogFSType

350+ compressionSetting = pure . CompressionSetting

351+ compoundFormat = pure . IndexCompoundFormat

352+ compoundOnFlush = pure . IndexCompoundOnFlush

353+ warmerEnabled = pure . WarmerEnabled

354+ blocksReadOnly = pure . BlocksReadOnly

355+ blocksRead = pure . BlocksRead

356+ blocksWrite = pure . BlocksWrite

357+ blocksMetaData = pure . BlocksMetaData

358+ mappingTotalFieldsLimit = pure . MappingTotalFieldsLimit

359+ analysisSetting = pure . AnalysisSetting

360+

215361data ReplicaBounds = ReplicasBounded Int Int

216362 | ReplicasLowerBounded Int

217363 | ReplicasUnbounded

218364 deriving (Eq, Show)

219365

366+

367+instance ToJSON ReplicaBounds where

368+ toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b)

369+ toJSON (ReplicasLowerBounded a) = String (showText a <> "-all")

370+ toJSON ReplicasUnbounded = Bool False

371+

372+instance FromJSON ReplicaBounds where

373+ parseJSON v = withText "ReplicaBounds" parseText v

374+ <|> withBool "ReplicaBounds" parseBool v

375+ where parseText t = case T.splitOn "-" t of

376+ [a, "all"] -> ReplicasLowerBounded <$> parseReadText a

377+ [a, b] -> ReplicasBounded <$> parseReadText a

378+ <*> parseReadText b

379+ _ -> fail ("Could not parse ReplicaBounds: " <> show t)

380+ parseBool False = pure ReplicasUnbounded

381+ parseBool _ = fail "ReplicasUnbounded cannot be represented with True"

382+

220383data Compression

221384 = CompressionDefault

222385 -- ^ Compress with LZ4

@@ -267,6 +430,16 @@ kilobytes n = Bytes (1000 * n)

267430data FSType = FSSimple

268431 | FSBuffered deriving (Eq, Show)

269432

433+instance ToJSON FSType where

434+ toJSON FSSimple = "simple"

435+ toJSON FSBuffered = "buffered"

436+

437+instance FromJSON FSType where

438+ parseJSON = withText "FSType" parse

439+ where parse "simple" = pure FSSimple

440+ parse "buffered" = pure FSBuffered

441+ parse t = fail ("Invalid FSType: " <> show t)

442+

270443data InitialShardCount = QuorumShards

271444 | QuorumMinus1Shards

272445 | FullShards

@@ -274,6 +447,22 @@ data InitialShardCount = QuorumShards

274447 | ExplicitShards Int

275448 deriving (Eq, Show)

276449

450+instance FromJSON InitialShardCount where

451+ parseJSON v = withText "InitialShardCount" parseText v

452+ <|> ExplicitShards <$> parseJSON v

453+ where parseText "quorum" = pure QuorumShards

454+ parseText "quorum-1" = pure QuorumMinus1Shards

455+ parseText "full" = pure FullShards

456+ parseText "full-1" = pure FullMinus1Shards

457+ parseText _ = mzero

458+

459+instance ToJSON InitialShardCount where

460+ toJSON QuorumShards = String "quorum"

461+ toJSON QuorumMinus1Shards = String "quorum-1"

462+ toJSON FullShards = String "full"

463+ toJSON FullMinus1Shards = String "full-1"

464+ toJSON (ExplicitShards x) = toJSON x

465+

277466data NodeAttrFilter = NodeAttrFilter

278467 { nodeAttrFilterName :: NodeAttrName

279468 , nodeAttrFilterValues :: NonEmpty Text }

@@ -286,12 +475,52 @@ data CompoundFormat = CompoundFileFormat Bool

286475 -- ^ percentage between 0 and 1 where 0 is false, 1 is true

287476 deriving (Eq, Show)

288477

289−newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }

478+instance ToJSON CompoundFormat where

479+ toJSON (CompoundFileFormat x) = Bool x

480+ toJSON (MergeSegmentVsTotalIndex x) = toJSON x

481+

482+instance FromJSON CompoundFormat where

483+ parseJSON v = CompoundFileFormat <$> parseJSON v

484+ <|> MergeSegmentVsTotalIndex <$> parseJSON v

485+

486+newtype NominalDiffTimeJSON =

487+ NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }

290488

291−data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName

292− , sSummaryFixedSettings :: IndexSettings

293− , sSummaryUpdateable :: [UpdatableIndexSetting]}

294− deriving (Eq, Show)

489+instance ToJSON NominalDiffTimeJSON where

490+ toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s")

491+

492+instance FromJSON NominalDiffTimeJSON where

493+ parseJSON = withText "NominalDiffTime" parse

494+ where parse t = case T.takeEnd 1 t of

495+ "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t)

496+ _ -> fail "Invalid or missing NominalDiffTime unit (expected s)"

497+

498+data IndexSettingsSummary = IndexSettingsSummary

499+ { sSummaryIndexName :: IndexName

500+ , sSummaryFixedSettings :: IndexSettings

501+ , sSummaryUpdateable :: [UpdatableIndexSetting]}

502+ deriving (Eq, Show)

503+

504+parseSettings :: Object -> Parser [UpdatableIndexSetting]

505+parseSettings o = do

506+ o' <- o .: "index"

507+ -- slice the index object into singleton hashmaps and try to parse each

508+ parses <- forM (HM.toList o') $ \(k, v) -> do

509+ -- blocks are now nested into the "index" key, which is not how they're serialized

510+ let atRoot = Object (HM.singleton k v)

511+ let atIndex = Object (HM.singleton "index" atRoot)

512+ optional (parseJSON atRoot <|> parseJSON atIndex)

513+ return (catMaybes parses)

514+

515+instance FromJSON IndexSettingsSummary where

516+ parseJSON = withObject "IndexSettingsSummary" parse

517+ where parse o = case HM.toList o of

518+ [(ixn, v@(Object o'))] -> IndexSettingsSummary (IndexName ixn)

519+ <$> parseJSON v

520+ <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")

521+ _ -> fail "Expected single-key object with index name"

522+ redundant (NumberOfReplicas _) = True

523+ redundant _ = False

295524

296525{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -}

297526type Reply = Network.HTTP.Client.Response LByteString

@@ -310,8 +539,9 @@ data FieldType = GeoPointType

310539 | ShortType

311540 | ByteType deriving (Eq, Show)

312541

313−data FieldDefinition =

314− FieldDefinition { fieldType :: FieldType } deriving (Eq, Show)

542+newtype FieldDefinition = FieldDefinition

543+ { fieldType :: FieldType

544+ } deriving (Eq, Show)

315545

316546{-| An 'IndexTemplate' defines a template that will automatically be

317547 applied to new indices created. The templates include both

@@ -327,6 +557,17 @@ data IndexTemplate =

327557 , templateMappings :: [Value]

328558 }

329559

560+instance ToJSON IndexTemplate where

561+ toJSON (IndexTemplate p s m) = merge

562+ (object [ "template" .= p

563+ , "mappings" .= foldl' merge (object []) m

564+ ])

565+ (toJSON s)

566+ where

567+ merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2

568+ merge o Null = o

569+ merge _ _ = undefined

570+

330571data MappingField =

331572 MappingField { mappingFieldName :: FieldName

332573 , fieldDefinition :: FieldDefinition }

@@ -355,6 +596,20 @@ data AllocationPolicy = AllocAll

355596 -- ^ No shard allocation is allowed

356597 deriving (Eq, Show)

357598

599+instance ToJSON AllocationPolicy where

600+ toJSON AllocAll = String "all"

601+ toJSON AllocPrimaries = String "primaries"

602+ toJSON AllocNewPrimaries = String "new_primaries"

603+ toJSON AllocNone = String "none"

604+

605+instance FromJSON AllocationPolicy where

606+ parseJSON = withText "AllocationPolicy" parse

607+ where parse "all" = pure AllocAll

608+ parse "primaries" = pure AllocPrimaries

609+ parse "new_primaries" = pure AllocNewPrimaries

610+ parse "none" = pure AllocNone

611+ parse t = fail ("Invlaid AllocationPolicy: " <> show t)

612+

358613{-| 'BulkOperation' is a sum type for expressing the four kinds of bulk

359614 operation index, create, delete, and update. 'BulkIndex' behaves like an

360615 "upsert", 'BulkCreate' will fail if a document already exists at the DocId.

@@ -401,6 +656,24 @@ data EsResultFound a =

401656 , _source :: a }

402657 deriving (Eq, Show)

403658

659+instance (FromJSON a) => FromJSON (EsResult a) where

660+ parseJSON jsonVal@(Object v) = do

661+ found <- v .:? "found" .!= False

662+ fr <- if found

663+ then parseJSON jsonVal

664+ else return Nothing

665+ EsResult <$> v .: "_index" <*>

666+ v .: "_type" <*>

667+ v .: "_id" <*>

668+ pure fr

669+ parseJSON _ = empty

670+

671+instance (FromJSON a) => FromJSON (EsResultFound a) where

672+ parseJSON (Object v) = EsResultFound <$>

673+ v .: "_version" <*>

674+ v .: "_source"

675+ parseJSON _ = empty

676+

404677{-| 'EsError' is the generic type that will be returned when there was a

405678 problem. If you can't parse the expected response, its a good idea to

406679 try parsing this.

@@ -410,6 +683,12 @@ data EsError =

410683 , errorMessage :: Text }

411684 deriving (Eq, Show)

412685

686+instance FromJSON EsError where

687+ parseJSON (Object v) = EsError <$>

688+ v .: "status" <*>

689+ (v .: "error" <|> (v .: "error" >>= (.: "reason")))

690+ parseJSON _ = empty

691+

413692{-| 'EsProtocolException' will be thrown if Bloodhound cannot parse a response

414693returned by the ElasticSearch server. If you encounter this error, please

415694verify that your domain data types and FromJSON instances are working properly

@@ -418,8 +697,9 @@ sure that your mappings are correct, then this error may be an indication of an

418697incompatibility between Bloodhound and ElasticSearch. Please open a bug report

419698and be sure to include the exception body.

420699-}

421−data EsProtocolException = EsProtocolException { esProtoExBody :: LByteString }

422− deriving (Eq, Show)

700+newtype EsProtocolException = EsProtocolException

701+ { esProtoExBody :: LByteString

702+ } deriving (Eq, Show)

423703

424704instance Exception EsProtocolException

425705

@@ -445,6 +725,13 @@ newtype SearchAliasRouting =

445725 SearchAliasRouting (NonEmpty RoutingValue)

446726 deriving (Eq, Show)

447727

728+instance ToJSON SearchAliasRouting where

729+ toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs))

730+

731+instance FromJSON SearchAliasRouting where

732+ parseJSON = withText "SearchAliasRouting" parse

733+ where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)

734+

448735newtype IndexAliasRouting =

449736 IndexAliasRouting RoutingValue

450737 deriving (Eq, Show, ToJSON, FromJSON)

@@ -457,6 +744,55 @@ newtype IndexAliasesSummary =

457744 IndexAliasesSummary { indexAliasesSummary :: [IndexAliasSummary] }

458745 deriving (Eq, Show)

459746

747+instance FromJSON IndexAliasesSummary where

748+ parseJSON = withObject "IndexAliasesSummary" parse

749+ where parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (HM.toList o)

750+ go ixn = withObject "index aliases" $ \ia -> do

751+ aliases <- ia .:? "aliases" .!= mempty

752+ forM (HM.toList aliases) $ \(aName, v) -> do

753+ let indexAlias = IndexAlias (IndexName ixn) (IndexAliasName (IndexName aName))

754+ IndexAliasSummary indexAlias <$> parseJSON v

755+

756+

757+instance ToJSON IndexAliasAction where

758+ toJSON (AddAlias ia opts) = object ["add" .= (iaObj <> optsObj)]

759+ where Object iaObj = toJSON ia

760+ Object optsObj = toJSON opts

761+ toJSON (RemoveAlias ia) = object ["remove" .= iaObj]

762+ where Object iaObj = toJSON ia

763+

764+instance ToJSON IndexAlias where

765+ toJSON IndexAlias {..} = object ["index" .= srcIndex

766+ , "alias" .= indexAlias

767+ ]

768+

769+instance ToJSON IndexAliasCreate where

770+ toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj)

771+ where filterObj = maybe mempty (HM.singleton "filter" . toJSON) aliasCreateFilter

772+ Object routingObj = maybe (Object mempty) toJSON aliasCreateRouting

773+

774+instance ToJSON AliasRouting where

775+ toJSON (AllAliasRouting v) = object ["routing" .= v]

776+ toJSON (GranularAliasRouting srch idx) = object (catMaybes prs)

777+ where prs = [("search_routing" .=) <$> srch

778+ ,("index_routing" .=) <$> idx]

779+

780+instance FromJSON AliasRouting where

781+ parseJSON = withObject "AliasRouting" parse

782+ where parse o = parseAll o <|> parseGranular o

783+ parseAll o = AllAliasRouting <$> o .: "routing"

784+ parseGranular o = do

785+ sr <- o .:? "search_routing"

786+ ir <- o .:? "index_routing"

787+ if isNothing sr && isNothing ir

788+ then fail "Both search_routing and index_routing can't be blank"

789+ else return (GranularAliasRouting sr ir)

790+

791+instance FromJSON IndexAliasCreate where

792+ parseJSON v = withObject "IndexAliasCreate" parse v

793+ where parse o = IndexAliasCreate <$> optional (parseJSON v)

794+ <*> o .:? "filter"

795+

460796{-| 'IndexAliasSummary' is a summary of an index alias configured for a server. -}

461797data IndexAliasSummary = IndexAliasSummary

462798 { indexAliasSummaryAlias :: IndexAlias

@@ -473,10 +809,32 @@ newtype DocVersion = DocVersion {

473809-- | Smart constructor for in-range doc version

474810mkDocVersion :: Int -> Maybe DocVersion

475811mkDocVersion i

476− | i >= (docVersionNumber minBound) && i <= (docVersionNumber maxBound) =

812+ | i >= docVersionNumber minBound

813+ && i <= docVersionNumber maxBound =

477814 Just $ DocVersion i

478815 | otherwise = Nothing

479816

817+instance Bounded DocVersion where

818+ minBound = DocVersion 1

819+ maxBound = DocVersion 9200000000000000000 -- 9.2e+18

820+

821+instance Enum DocVersion where

822+ succ x

823+ | x /= maxBound = DocVersion (succ $ docVersionNumber x)

824+ | otherwise = succError "DocVersion"

825+ pred x

826+ | x /= minBound = DocVersion (pred $ docVersionNumber x)

827+ | otherwise = predError "DocVersion"

828+ toEnum i =

829+ fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i

830+ fromEnum = docVersionNumber

831+ enumFrom = boundedEnumFrom

832+ enumFromThen = boundedEnumFromThen

833+

834+instance FromJSON DocVersion where

835+ parseJSON v = do

836+ i <- parseJSON v

837+ maybe (fail "DocVersion out of range") return $ mkDocVersion i

480838

481839{-| 'ExternalDocVersion' is a convenience wrapper if your code uses its

482840own version numbers instead of ones from ES.

@@ -576,36 +934,6 @@ newtype TemplateName = TemplateName Text deriving (Eq, Show, ToJSON, FromJSON)

576934-}

577935newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, ToJSON, FromJSON)

578936

579−-- This insanity is because ES *sometimes* returns Replica/Shard counts as strings

580−instance FromJSON ReplicaCount where

581− parseJSON v = parseAsInt v

582− <|> parseAsString v

583− where parseAsInt = fmap ReplicaCount . parseJSON

584− parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)

585−

586−instance FromJSON ShardCount where

587− parseJSON v = parseAsInt v

588− <|> parseAsString v

589− where parseAsInt = fmap ShardCount . parseJSON

590− parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText)

591−

592−instance Bounded DocVersion where

593− minBound = DocVersion 1

594− maxBound = DocVersion 9200000000000000000 -- 9.2e+18

595−

596−instance Enum DocVersion where

597− succ x

598− | x /= maxBound = DocVersion (succ $ docVersionNumber x)

599− | otherwise = succError "DocVersion"

600− pred x

601− | x /= minBound = DocVersion (pred $ docVersionNumber x)

602− | otherwise = predError "DocVersion"

603− toEnum i =

604− fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i

605− fromEnum = docVersionNumber

606− enumFrom = boundedEnumFrom

607− enumFromThen = boundedEnumFromThen

608−

609937-- | Username type used for HTTP Basic authentication. See 'basicAuthHook'.

610938newtype EsUsername = EsUsername { esUsername :: Text } deriving (Read, Show, Eq)

611939

@@ -1225,13 +1553,13 @@ data SnapshotRestoreSettings = SnapshotRestoreSettings {

12251553 -- revert back to the server default during the restore process.

12261554 } deriving (Eq, Show)

12271555

1228−data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings {

1229− repoUpdateVerify :: Bool

1230− -- ^ After creation/update, synchronously check that nodes can

1231− -- write to this repo. Defaults to True. You may use False if you

1232− -- need a faster response and plan on verifying manually later

1233− -- with 'verifySnapshotRepo'.

1234− } deriving (Eq, Show)

1556+newtype SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings

1557+ { repoUpdateVerify :: Bool

1558+ -- ^ After creation/update, synchronously check that nodes can

1559+ -- write to this repo. Defaults to True. You may use False if you

1560+ -- need a faster response and plan on verifying manually later

1561+ -- with 'verifySnapshotRepo'.

1562+ } deriving (Eq, Show)

12351563

12361564

12371565-- | Reasonable defaults for repo creation/update

@@ -1271,7 +1599,7 @@ instance SnapshotRepo FsSnapshotRepo where

12711599 fromGSnapshotRepo GenericSnapshotRepo {..}

12721600 | gSnapshotRepoType == fsRepoType = do

12731601 let o = gSnapshotRepoSettingsObject gSnapshotRepoSettings

1274− parseRepo $ do

1602+ parseRepo $

12751603 FsSnapshotRepo gSnapshotRepoName <$> o .: "location"

12761604 <*> o .:? "compress" .!= False

12771605 <*> o .:? "chunk_size"

@@ -1370,12 +1698,6 @@ data SnapshotInfo = SnapshotInfo {

13701698 } deriving (Eq, Show)

13711699

13721700

1373−instance FromJSON POSIXMS where

1374− parseJSON = withScientific "POSIXMS" (return . parse)

1375− where parse n =

1376− let n' = truncate n :: Integer

1377− in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))

1378−

13791701instance FromJSON SnapshotInfo where

13801702 parseJSON = withObject "SnapshotInfo" parse

13811703 where

@@ -1437,7 +1759,8 @@ instance Bounded RRGroupRefNum where

14371759-- | Only allows valid group number references (1-9).

14381760mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum

14391761mkRRGroupRefNum i

1440− | i >= (rrGroupRefNum minBound) && i <= (rrGroupRefNum maxBound) =

1762+ | i >= rrGroupRefNum minBound

1763+ && i <= rrGroupRefNum maxBound =

14411764 Just $ RRGroupRefNum i

14421765 | otherwise = Nothing

14431766

@@ -1471,9 +1794,9 @@ defaultSnapshotRestoreSettings = SnapshotRestoreSettings {

14711794-- | Index settings that can be overridden. The docs only mention you

14721795-- can update number of replicas, but there may be more. You

14731796-- definitely cannot override shard count.

1474−data RestoreIndexSettings = RestoreIndexSettings {

1475− restoreOverrideReplicas :: Maybe ReplicaCount

1476− } deriving (Eq, Show)

1797+newtype RestoreIndexSettings = RestoreIndexSettings

1798+ { restoreOverrideReplicas :: Maybe ReplicaCount

1799+ } deriving (Eq, Show)

14771800

14781801

14791802instance ToJSON RestoreIndexSettings where

@@ -1813,7 +2136,7 @@ instance FromJSON NodeBreakersStats where

18132136 <*> o .: "fielddata"

18142137

18152138parseNodeStats :: FullNodeId -> Object -> Parser NodeStats

1816−parseNodeStats fnid o = do

2139+parseNodeStats fnid o =

18172140 NodeStats <$> o .: "name"

18182141 <*> pure fnid

18192142 <*> o .:? "breakers"

@@ -1871,7 +2194,7 @@ instance FromJSON BoundTransportAddress where

18712194instance FromJSON NodeOSInfo where

18722195 parseJSON = withObject "NodeOSInfo" parse

18732196 where

1874− parse o = do

2197+ parse o =

18752198 NodeOSInfo <$> (unMS <$> o .: "refresh_interval_in_millis")

18762199 <*> o .: "name"

18772200 <*> o .: "arch"

@@ -1990,6 +2313,16 @@ data Interval = Year

19902313 | Minute

19912314 | Second deriving (Eq, Show)

19922315

2316+instance ToJSON Interval where

2317+ toJSON Year = "year"

2318+ toJSON Quarter = "quarter"

2319+ toJSON Month = "month"

2320+ toJSON Week = "week"

2321+ toJSON Day = "day"

2322+ toJSON Hour = "hour"

2323+ toJSON Minute = "minute"

2324+ toJSON Second = "second"

2325+

19932326parseStringInterval :: (Monad m) => String -> m NominalDiffTime

19942327parseStringInterval s = case span isNumber s of

19952328 ("", _) -> fail "Invalid interval"

src/Database/V5/Bloodhound/Internal/Newtypes.hs+24−5

@@ -146,6 +146,12 @@ newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, FromJSON, ToJS

146146-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ

147147newtype POSIXMS = POSIXMS { posixMS :: UTCTime }

148148

149+instance FromJSON POSIXMS where

150+ parseJSON = withScientific "POSIXMS" (return . parse)

151+ where parse n =

152+ let n' = truncate n :: Integer

153+ in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))

154+

149155newtype Boost =

150156 Boost Double

151157 deriving (Eq, Show, ToJSON, FromJSON)

@@ -154,15 +160,28 @@ newtype BoostTerms =

154160 BoostTerms Double

155161 deriving (Eq, Show, ToJSON, FromJSON)

156162

163+{-| 'ReplicaCount' is part of 'IndexSettings' -}

164+newtype ReplicaCount =

165+ ReplicaCount Int

166+ deriving (Eq, Show, ToJSON)

167+

157168{-| 'ShardCount' is part of 'IndexSettings' -}

158169newtype ShardCount =

159170 ShardCount Int

160171 deriving (Eq, Show, ToJSON)

161172

162−{-| 'ReplicaCount' is part of 'IndexSettings' -}

163−newtype ReplicaCount =

164− ReplicaCount Int

165− deriving (Eq, Show, ToJSON)

173+-- This insanity is because ES *sometimes* returns Replica/Shard counts as strings

174+instance FromJSON ReplicaCount where

175+ parseJSON v = parseAsInt v

176+ <|> parseAsString v

177+ where parseAsInt = fmap ReplicaCount . parseJSON

178+ parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)

179+

180+instance FromJSON ShardCount where

181+ parseJSON v = parseAsInt v

182+ <|> parseAsString v

183+ where parseAsInt = fmap ShardCount . parseJSON

184+ parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText)

166185

167186{-| 'IndexName' is used to describe which index to query/create/delete -}

168187newtype IndexName =

@@ -195,7 +214,7 @@ unMS (MS t) = t

195214instance FromJSON MS where

196215 parseJSON = withScientific "MS" (return . MS . parse)

197216 where

198− parse n = fromInteger ((truncate n) * 1000)

217+ parse n = fromInteger (truncate n * 1000)

199218

200219newtype TokenFilter =

201220 TokenFilter Text deriving (Eq, Show, FromJSON, ToJSON)

src/Database/V5/Bloodhound/Internal/Query.hs+72−29

@@ -435,6 +435,10 @@ data GeoPoint =

435435 GeoPoint { geoField :: FieldName

436436 , latLon :: LatLon} deriving (Eq, Show)

437437

438+instance ToJSON GeoPoint where

439+ toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) =

440+ object [ geoPointField .= geoPointLatLon ]

441+

438442data DistanceUnit = Miles

439443 | Yards

440444 | Feet

@@ -882,7 +886,8 @@ instance FromJSON QueryStringQuery where

882886instance ToJSON RangeQuery where

883887 toJSON (RangeQuery (FieldName fieldName) range boost) =

884888 object [ fieldName .= object conjoined ]

885− where conjoined = [ "boost" .= boost ] ++ (rangeValueToPair range)

889+ where

890+ conjoined = ("boost" .= boost) : rangeValueToPair range

886891

887892instance FromJSON RangeQuery where

888893 parseJSON = withObject "RangeQuery" parse

@@ -891,38 +896,76 @@ instance FromJSON RangeQuery where

891896 <$> parseJSON (Object o)

892897 <*> o .: "boost"

893898

899+parseRangeValue :: ( FromJSON t4

900+ , FromJSON t3

901+ , FromJSON t2

902+ , FromJSON t1

903+ )

904+ => (t3 -> t5)

905+ -> (t1 -> t6)

906+ -> (t4 -> t7)

907+ -> (t2 -> t8)

908+ -> (t5 -> t6 -> b)

909+ -> (t7 -> t6 -> b)

910+ -> (t5 -> t8 -> b)

911+ -> (t7 -> t8 -> b)

912+ -> (t5 -> b)

913+ -> (t6 -> b)

914+ -> (t7 -> b)

915+ -> (t8 -> b)

916+ -> Parser b

917+ -> Object

918+ -> Parser b

919+parseRangeValue mkGt mkLt mkGte mkLte

920+ fGtLt fGteLt fGtLte fGteLte

921+ fGt fLt fGte fLte nada o = do

922+ lt <- o .:? "lt"

923+ lte <- o .:? "lte"

924+ gt <- o .:? "gt"

925+ gte <- o .:? "gte"

926+ case (lt, lte, gt, gte) of

927+ (Just a, _, Just b, _) ->

928+ return (fGtLt (mkGt b) (mkLt a))

929+ (Just a, _, _, Just b) ->

930+ return (fGteLt (mkGte b) (mkLt a))

931+ (_, Just a, Just b, _) ->

932+ return (fGtLte (mkGt b) (mkLte a))

933+ (_, Just a, _, Just b) ->

934+ return (fGteLte (mkGte b) (mkLte a))

935+ (_, _, Just a, _) ->

936+ return (fGt (mkGt a))

937+ (Just a, _, _, _) ->

938+ return (fLt (mkLt a))

939+ (_, _, _, Just a) ->

940+ return (fGte (mkGte a))

941+ (_, Just a, _, _) ->

942+ return (fLte (mkLte a))

943+ (Nothing, Nothing, Nothing, Nothing) ->

944+ nada

945+

946+

894947instance FromJSON RangeValue where

895948 parseJSON = withObject "RangeValue" parse

896949 where parse o = parseDate o

897950 <|> parseDouble o

898− parseDate o = do lt <- o .:? "lt"

899− lte <- o .:? "lte"

900− gt <- o .:? "gt"

901− gte <- o .:? "gte"

902− case (lt, lte, gt, gte) of

903− (Just a, _, Just b, _) -> return (RangeDateGtLt (GreaterThanD b) (LessThanD a))

904− (Just a, _, _, Just b)-> return (RangeDateGteLt (GreaterThanEqD b) (LessThanD a))

905− (_, Just a, Just b, _)-> return (RangeDateGtLte (GreaterThanD b) (LessThanEqD a))

906− (_, Just a, _, Just b)-> return (RangeDateGteLte (GreaterThanEqD b) (LessThanEqD a))

907− (_, _, Just a, _)-> return (RangeDateGt (GreaterThanD a))

908− (Just a, _, _, _)-> return (RangeDateLt (LessThanD a))

909− (_, _, _, Just a)-> return (RangeDateGte (GreaterThanEqD a))

910− (_, Just a, _, _)-> return (RangeDateLte (LessThanEqD a))

911− (Nothing, Nothing, Nothing, Nothing) -> mzero

912− parseDouble o = do lt <- o .:? "lt"

913− lte <- o .:? "lte"

914− gt <- o .:? "gt"

915− gte <- o .:? "gte"

916− case (lt, lte, gt, gte) of

917− (Just a, _, Just b, _) -> return (RangeDoubleGtLt (GreaterThan b) (LessThan a))

918− (Just a, _, _, Just b)-> return (RangeDoubleGteLt (GreaterThanEq b) (LessThan a))

919− (_, Just a, Just b, _)-> return (RangeDoubleGtLte (GreaterThan b) (LessThanEq a))

920− (_, Just a, _, Just b)-> return (RangeDoubleGteLte (GreaterThanEq b) (LessThanEq a))

921− (_, _, Just a, _)-> return (RangeDoubleGt (GreaterThan a))

922− (Just a, _, _, _)-> return (RangeDoubleLt (LessThan a))

923− (_, _, _, Just a)-> return (RangeDoubleGte (GreaterThanEq a))

924− (_, Just a, _, _)-> return (RangeDoubleLte (LessThanEq a))

925− (Nothing, Nothing, Nothing, Nothing) -> mzero

951+ parseDate o =

952+ parseRangeValue

953+ GreaterThanD LessThanD

954+ GreaterThanEqD LessThanEqD

955+ RangeDateGtLt RangeDateGteLt

956+ RangeDateGtLte RangeDateGteLte

957+ RangeDateGt RangeDateLt

958+ RangeDateGte RangeDateLte

959+ mzero o

960+ parseDouble o =

961+ parseRangeValue

962+ GreaterThan LessThan

963+ GreaterThanEq LessThanEq

964+ RangeDoubleGtLt RangeDoubleGteLt

965+ RangeDoubleGtLte RangeDoubleGteLte

966+ RangeDoubleGt RangeDoubleLt

967+ RangeDoubleGte RangeDoubleLte

968+ mzero o

926969

927970instance ToJSON PrefixQuery where

928971 toJSON (PrefixQuery (FieldName fieldName) queryValue boost) =

src/Database/V5/Bloodhound/Types.hs+317−659

@@ -414,7 +414,6 @@ module Database.V5.Bloodhound.Types

414414

415415import Bloodhound.Import

416416

417−import qualified Data.Traversable as DT

418417import qualified Data.HashMap.Strict as HM

419418import qualified Data.Map.Strict as M

420419import qualified Data.Text as T

@@ -424,7 +423,6 @@ import Database.V5.Bloodhound.Internal.Analysis

424423import Database.V5.Bloodhound.Internal.Client

425424import Database.V5.Bloodhound.Internal.Newtypes

426425import Database.V5.Bloodhound.Internal.Query

427−import Database.V5.Bloodhound.Internal.StringlyTyped

428426

429427{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order

430428 dependent with later sorts acting as tie-breakers for earlier sorts.

@@ -438,8 +436,26 @@ type Sort = [SortSpec]

438436

439437<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>

440438-}

441−data SortSpec = DefaultSortSpec DefaultSort

442− | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit deriving (Eq, Show)

439+data SortSpec =

440+ DefaultSortSpec DefaultSort

441+ | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit

442+ deriving (Eq, Show)

443+

444+instance ToJSON SortSpec where

445+ toJSON (DefaultSortSpec

446+ (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped

447+ dsSortMode dsMissingSort dsNestedFilter)) =

448+ object [dsSortFieldName .= omitNulls base] where

449+ base = [ "order" .= dsSortOrder

450+ , "unmapped_type" .= dsIgnoreUnmapped

451+ , "mode" .= dsSortMode

452+ , "missing" .= dsMissingSort

453+ , "nested_filter" .= dsNestedFilter ]

454+

455+ toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) =

456+ object [ "unit" .= units

457+ , field .= gdsLatLon

458+ , "order" .= gdsSortOrder ]

443459

444460{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a

445461 'mkSort' convenience function for when you want to specify only the most

@@ -466,6 +482,10 @@ data DefaultSort =

466482data SortOrder = Ascending

467483 | Descending deriving (Eq, Show)

468484

485+instance ToJSON SortOrder where

486+ toJSON Ascending = String "asc"

487+ toJSON Descending = String "desc"

488+

469489{-| 'Missing' prescribes how to handle missing fields. A missing field can be

470490 sorted last, first, or using a custom value as a substitute.

471491

@@ -475,6 +495,11 @@ data Missing = LastMissing

475495 | FirstMissing

476496 | CustomMissing Text deriving (Eq, Show)

477497

498+instance ToJSON Missing where

499+ toJSON LastMissing = String "_last"

500+ toJSON FirstMissing = String "_first"

501+ toJSON (CustomMissing txt) = String txt

502+

478503{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.

479504

480505http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option

@@ -484,6 +509,12 @@ data SortMode = SortMin

484509 | SortSum

485510 | SortAvg deriving (Eq, Show)

486511

512+instance ToJSON SortMode where

513+ toJSON SortMin = String "min"

514+ toJSON SortMax = String "max"

515+ toJSON SortSum = String "sum"

516+ toJSON SortAvg = String "avg"

517+

487518{-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so

488519 that you can concisely describe the usual kind of 'SortSpec's you want.

489520-}

@@ -590,6 +621,10 @@ data HighlightEncoder = DefaultEncoder

590621 | HTMLEncoder

591622 deriving (Eq, Show)

592623

624+instance ToJSON HighlightEncoder where

625+ toJSON DefaultEncoder = String "default"

626+ toJSON HTMLEncoder = String "html"

627+

593628-- NOTE: Should the tags use some kind of HTML type, rather than Text?

594629data HighlightTag =

595630 TagSchema Text

@@ -609,6 +644,18 @@ data SearchResult a =

609644 }

610645 deriving (Eq, Show)

611646

647+

648+instance (FromJSON a) => FromJSON (SearchResult a) where

649+ parseJSON (Object v) = SearchResult <$>

650+ v .: "took" <*>

651+ v .: "timed_out" <*>

652+ v .: "_shards" <*>

653+ v .: "hits" <*>

654+ v .:? "aggregations" <*>

655+ v .:? "_scroll_id" <*>

656+ v .:? "suggest"

657+ parseJSON _ = empty

658+

612659newtype ScrollId =

613660 ScrollId Text

614661 deriving (Eq, Show, Ord, ToJSON, FromJSON)

@@ -618,6 +665,14 @@ data SearchHits a =

618665 , maxScore :: Score

619666 , hits :: [Hit a] } deriving (Eq, Show)

620667

668+

669+instance (FromJSON a) => FromJSON (SearchHits a) where

670+ parseJSON (Object v) = SearchHits <$>

671+ v .: "total" <*>

672+ v .: "max_score" <*>

673+ v .: "hits"

674+ parseJSON _ = empty

675+

621676instance Semigroup (SearchHits a) where

622677 (SearchHits ta ma ha) <> (SearchHits tb mb hb) = SearchHits (ta + tb) (max ma mb) (ha <> hb)

623678

@@ -634,12 +689,26 @@ data Hit a =

634689 , hitFields :: Maybe HitFields

635690 , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)

636691

692+instance (FromJSON a) => FromJSON (Hit a) where

693+ parseJSON (Object v) = Hit <$>

694+ v .: "_index" <*>

695+ v .: "_type" <*>

696+ v .: "_id" <*>

697+ v .: "_score" <*>

698+ v .:? "_source" <*>

699+ v .:? "fields" <*>

700+ v .:? "highlight"

701+ parseJSON _ = empty

702+

637703newtype HitFields =

638704 HitFields (M.Map Text [Value])

639705 deriving (Eq, Show)

640706

641−type HitHighlight = M.Map Text [Text]

707+instance FromJSON HitFields where

708+ parseJSON x

709+ = HitFields <$> parseJSON x

642710

711+type HitHighlight = M.Map Text [Text]

643712

644713type Aggregations = M.Map Text Aggregation

645714

@@ -649,21 +718,43 @@ emptyAggregations = M.empty

649718mkAggregations :: Text -> Aggregation -> Aggregations

650719mkAggregations name aggregation = M.insert name aggregation emptyAggregations

651720

652−data TermOrder = TermOrder{ termSortField :: Text

653− , termSortOrder :: SortOrder } deriving (Eq, Show)

721+data TermOrder = TermOrder

722+ { termSortField :: Text

723+ , termSortOrder :: SortOrder } deriving (Eq, Show)

724+

725+instance ToJSON TermOrder where

726+ toJSON (TermOrder termSortField termSortOrder) =

727+ object [termSortField .= termSortOrder]

654728

655729data TermInclusion = TermInclusion Text

656730 | TermPattern Text Text deriving (Eq, Show)

657731

732+instance ToJSON TermInclusion where

733+ toJSON (TermInclusion x) = toJSON x

734+ toJSON (TermPattern pattern flags) =

735+ omitNulls [ "pattern" .= pattern

736+ , "flags" .= flags]

737+

658738data CollectionMode = BreadthFirst

659739 | DepthFirst deriving (Eq, Show)

660740

741+instance ToJSON CollectionMode where

742+ toJSON BreadthFirst = "breadth_first"

743+ toJSON DepthFirst = "depth_first"

744+

661745data ExecutionHint = Ordinals

662746 | GlobalOrdinals

663747 | GlobalOrdinalsHash

664748 | GlobalOrdinalsLowCardinality

665749 | Map deriving (Eq, Show)

666750

751+instance ToJSON ExecutionHint where

752+ toJSON Ordinals = "ordinals"

753+ toJSON GlobalOrdinals = "global_ordinals"

754+ toJSON GlobalOrdinalsHash = "global_ordinals_hash"

755+ toJSON GlobalOrdinalsLowCardinality = "global_ordinals_low_cardinality"

756+ toJSON Map = "map"

757+

667758data Aggregation = TermsAgg TermsAggregation

668759 | CardinalityAgg CardinalityAggregation

669760 | DateHistogramAgg DateHistogramAggregation

@@ -675,6 +766,67 @@ data Aggregation = TermsAgg TermsAggregation

675766 | StatsAgg StatisticsAggregation

676767 deriving (Eq, Show)

677768

769+instance ToJSON Aggregation where

770+ toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =

771+ omitNulls ["terms" .= omitNulls [ toJSON' term,

772+ "include" .= include,

773+ "exclude" .= exclude,

774+ "order" .= order,

775+ "min_doc_count" .= minDocCount,

776+ "size" .= size,

777+ "shard_size" .= shardSize,

778+ "collect_mode" .= collectMode,

779+ "execution_hint" .= executionHint

780+ ],

781+ "aggs" .= termAggs ]

782+ where

783+ toJSON' x = case x of { Left y -> "field" .= y; Right y -> "script" .= y }

784+

785+ toJSON (CardinalityAgg (CardinalityAggregation field precisionThreshold)) =

786+ object ["cardinality" .= omitNulls [ "field" .= field,

787+ "precisionThreshold" .= precisionThreshold

788+ ]

789+ ]

790+

791+ toJSON (DateHistogramAgg

792+ (DateHistogramAggregation field interval format

793+ preZone postZone preOffset postOffset dateHistoAggs)) =

794+ omitNulls ["date_histogram" .= omitNulls [ "field" .= field,

795+ "interval" .= interval,

796+ "format" .= format,

797+ "pre_zone" .= preZone,

798+ "post_zone" .= postZone,

799+ "pre_offset" .= preOffset,

800+ "post_offset" .= postOffset

801+ ],

802+ "aggs" .= dateHistoAggs ]

803+ toJSON (ValueCountAgg a) = object ["value_count" .= v]

804+ where v = case a of

805+ (FieldValueCount (FieldName n)) ->

806+ object ["field" .= n]

807+ (ScriptValueCount s) ->

808+ object ["script" .= s]

809+ toJSON (FilterAgg (FilterAggregation filt ags)) =

810+ omitNulls [ "filter" .= filt

811+ , "aggs" .= ags]

812+ toJSON (DateRangeAgg a) = object [ "date_range" .= a

813+ ]

814+ toJSON (MissingAgg (MissingAggregation{..})) =

815+ object ["missing" .= object ["field" .= maField]]

816+

817+ toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =

818+ omitNulls ["top_hits" .= omitNulls [ "size" .= msize

819+ , "from" .= mfrom

820+ , "sort" .= msort

821+ ]

822+ ]

823+

824+ toJSON (StatsAgg (StatisticsAggregation typ field)) =

825+ object [stType .= omitNulls [ "field" .= field ]]

826+ where

827+ stType | typ == Basic = "stats"

828+ | otherwise = "extended_stats"

829+

678830data TopHitsAggregation = TopHitsAggregation

679831 { taFrom :: Maybe From

680832 , taSize :: Maybe Size

@@ -685,17 +837,18 @@ data MissingAggregation = MissingAggregation

685837 { maField :: Text

686838 } deriving (Eq, Show)

687839

688−data TermsAggregation = TermsAggregation { term :: Either Text Text

689− , termInclude :: Maybe TermInclusion

690− , termExclude :: Maybe TermInclusion

691− , termOrder :: Maybe TermOrder

692− , termMinDocCount :: Maybe Int

693− , termSize :: Maybe Int

694− , termShardSize :: Maybe Int

695− , termCollectMode :: Maybe CollectionMode

696− , termExecutionHint :: Maybe ExecutionHint

697− , termAggs :: Maybe Aggregations

698− } deriving (Eq, Show)

840+data TermsAggregation = TermsAggregation

841+ { term :: Either Text Text

842+ , termInclude :: Maybe TermInclusion

843+ , termExclude :: Maybe TermInclusion

844+ , termOrder :: Maybe TermOrder

845+ , termMinDocCount :: Maybe Int

846+ , termSize :: Maybe Int

847+ , termShardSize :: Maybe Int

848+ , termCollectMode :: Maybe CollectionMode

849+ , termExecutionHint :: Maybe ExecutionHint

850+ , termAggs :: Maybe Aggregations

851+ } deriving (Eq, Show)

699852

700853data CardinalityAggregation = CardinalityAggregation

701854 { cardinalityField :: FieldName,

@@ -720,17 +873,43 @@ data DateRangeAggregation = DateRangeAggregation

720873 , draRanges :: NonEmpty DateRangeAggRange

721874 } deriving (Eq, Show)

722875

876+instance ToJSON DateRangeAggregation where

877+ toJSON DateRangeAggregation {..} =

878+ omitNulls [ "field" .= draField

879+ , "format" .= draFormat

880+ , "ranges" .= toList draRanges

881+ ]

882+

723883data DateRangeAggRange =

724884 DateRangeFrom DateMathExpr

725885 | DateRangeTo DateMathExpr

726886 | DateRangeFromAndTo DateMathExpr DateMathExpr

727887 deriving (Eq, Show)

728888

889+instance ToJSON DateRangeAggRange where

890+ toJSON (DateRangeFrom e) = object [ "from" .= e ]

891+ toJSON (DateRangeTo e) = object [ "to" .= e ]

892+ toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]

893+

729894-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#date-math> for more information.

730895data DateMathExpr =

731896 DateMathExpr DateMathAnchor [DateMathModifier]

732897 deriving (Eq, Show)

733898

899+instance ToJSON DateMathExpr where

900+ toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))

901+ where fmtA DMNow = "now"

902+ fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"

903+ fmtMod (AddTime n u) = "+" <> showText n <> fmtU u

904+ fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u

905+ fmtMod (RoundDownTo u) = "/" <> fmtU u

906+ fmtU DMYear = "y"

907+ fmtU DMMonth = "M"

908+ fmtU DMWeek = "w"

909+ fmtU DMDay = "d"

910+ fmtU DMHour = "h"

911+ fmtU DMMinute = "m"

912+ fmtU DMSecond = "s"

734913

735914-- | Starting point for a date range. This along with the 'DateMathModifiers' gets you the date ES will start from.

736915data DateMathAnchor =

@@ -796,124 +975,6 @@ mkStatsAggregation = StatisticsAggregation Basic

796975mkExtendedStatsAggregation :: FieldName -> StatisticsAggregation

797976mkExtendedStatsAggregation = StatisticsAggregation Extended

798977

799−instance ToJSON TermOrder where

800− toJSON (TermOrder termSortField termSortOrder) = object [termSortField .= termSortOrder]

801−

802−instance ToJSON TermInclusion where

803− toJSON (TermInclusion x) = toJSON x

804− toJSON (TermPattern pattern flags) = omitNulls [ "pattern" .= pattern,

805− "flags" .= flags]

806−

807−instance ToJSON CollectionMode where

808− toJSON BreadthFirst = "breadth_first"

809− toJSON DepthFirst = "depth_first"

810−

811−instance ToJSON ExecutionHint where

812− toJSON Ordinals = "ordinals"

813− toJSON GlobalOrdinals = "global_ordinals"

814− toJSON GlobalOrdinalsHash = "global_ordinals_hash"

815− toJSON GlobalOrdinalsLowCardinality = "global_ordinals_low_cardinality"

816− toJSON Map = "map"

817−

818−instance ToJSON Interval where

819− toJSON Year = "year"

820− toJSON Quarter = "quarter"

821− toJSON Month = "month"

822− toJSON Week = "week"

823− toJSON Day = "day"

824− toJSON Hour = "hour"

825− toJSON Minute = "minute"

826− toJSON Second = "second"

827−

828−instance ToJSON Aggregation where

829− toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =

830− omitNulls ["terms" .= omitNulls [ toJSON' term,

831− "include" .= include,

832− "exclude" .= exclude,

833− "order" .= order,

834− "min_doc_count" .= minDocCount,

835− "size" .= size,

836− "shard_size" .= shardSize,

837− "collect_mode" .= collectMode,

838− "execution_hint" .= executionHint

839− ],

840− "aggs" .= termAggs ]

841− where

842− toJSON' x = case x of { Left y -> "field" .= y; Right y -> "script" .= y }

843−

844− toJSON (CardinalityAgg (CardinalityAggregation field precisionThreshold)) =

845− object ["cardinality" .= omitNulls [ "field" .= field,

846− "precisionThreshold" .= precisionThreshold

847− ]

848− ]

849−

850− toJSON (DateHistogramAgg

851− (DateHistogramAggregation field interval format

852− preZone postZone preOffset postOffset dateHistoAggs)) =

853− omitNulls ["date_histogram" .= omitNulls [ "field" .= field,

854− "interval" .= interval,

855− "format" .= format,

856− "pre_zone" .= preZone,

857− "post_zone" .= postZone,

858− "pre_offset" .= preOffset,

859− "post_offset" .= postOffset

860− ],

861− "aggs" .= dateHistoAggs ]

862− toJSON (ValueCountAgg a) = object ["value_count" .= v]

863− where v = case a of

864− (FieldValueCount (FieldName n)) ->

865− object ["field" .= n]

866− (ScriptValueCount s) ->

867− object ["script" .= s]

868− toJSON (FilterAgg (FilterAggregation filt ags)) =

869− omitNulls [ "filter" .= filt

870− , "aggs" .= ags]

871− toJSON (DateRangeAgg a) = object [ "date_range" .= a

872− ]

873− toJSON (MissingAgg (MissingAggregation{..})) =

874− object ["missing" .= object ["field" .= maField]]

875−

876− toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =

877− omitNulls ["top_hits" .= omitNulls [ "size" .= msize

878− , "from" .= mfrom

879− , "sort" .= msort

880− ]

881− ]

882−

883− toJSON (StatsAgg (StatisticsAggregation typ field)) =

884− object [stType .= omitNulls [ "field" .= field ]]

885− where

886− stType | typ == Basic = "stats"

887− | otherwise = "extended_stats"

888−

889−instance ToJSON DateRangeAggregation where

890− toJSON DateRangeAggregation {..} =

891− omitNulls [ "field" .= draField

892− , "format" .= draFormat

893− , "ranges" .= toList draRanges

894− ]

895−

896−instance ToJSON DateRangeAggRange where

897− toJSON (DateRangeFrom e) = object [ "from" .= e ]

898− toJSON (DateRangeTo e) = object [ "to" .= e ]

899− toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]

900−

901−instance ToJSON DateMathExpr where

902− toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))

903− where fmtA DMNow = "now"

904− fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"

905− fmtMod (AddTime n u) = "+" <> showText n <> fmtU u

906− fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u

907− fmtMod (RoundDownTo u) = "/" <> fmtU u

908− fmtU DMYear = "y"

909− fmtU DMMonth = "M"

910− fmtU DMWeek = "w"

911− fmtU DMDay = "d"

912− fmtU DMHour = "h"

913− fmtU DMMinute = "m"

914− fmtU DMSecond = "s"

915−

916−

917978type AggregationResults = M.Map Text Value

918979

919980class BucketAggregation a where

@@ -921,83 +982,48 @@ class BucketAggregation a where

921982 docCount :: a -> Int

922983 aggs :: a -> Maybe AggregationResults

923984

924−

925−data Bucket a = Bucket { buckets :: [a]} deriving (Read, Show)

926−

927−data BucketValue = TextValue Text

928− | ScientificValue Scientific

929− | BoolValue Bool deriving (Read, Show)

930−

931−data MissingResult = MissingResult { missingDocCount :: Int } deriving (Show)

932−

933−data TopHitResult a = TopHitResult { tarHits :: (SearchHits a)

934− } deriving Show

935−

936−data TermsResult = TermsResult { termKey :: BucketValue

937− , termsDocCount :: Int

938− , termsAggs :: Maybe AggregationResults } deriving (Read, Show)

939−

940−data DateHistogramResult = DateHistogramResult { dateKey :: Int

941− , dateKeyStr :: Maybe Text

942− , dateDocCount :: Int

943− , dateHistogramAggs :: Maybe AggregationResults } deriving (Read, Show)

944−

945−data DateRangeResult =

946− DateRangeResult { dateRangeKey :: Text

947− , dateRangeFrom :: Maybe UTCTime

948− , dateRangeFromAsString :: Maybe Text

949− , dateRangeTo :: Maybe UTCTime

950− , dateRangeToAsString :: Maybe Text

951− , dateRangeDocCount :: Int

952− , dateRangeAggs :: Maybe AggregationResults }

953− deriving (Eq, Show)

954−

955−toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)

956−toTerms = toAggResult

957−

958−toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)

959−toDateHistogram = toAggResult

960−

961−toMissing :: Text -> AggregationResults -> Maybe MissingResult

962−toMissing = toAggResult

963−

964−toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)

965−toTopHits = toAggResult

966−

967−toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a

968−toAggResult t a = M.lookup t a >>= deserialize

969− where deserialize = parseMaybe parseJSON

970−

971−instance BucketAggregation TermsResult where

972− key = termKey

973− docCount = termsDocCount

974− aggs = termsAggs

975−

976−instance BucketAggregation DateHistogramResult where

977− key = TextValue . showText . dateKey

978− docCount = dateDocCount

979− aggs = dateHistogramAggs

980−

981−instance BucketAggregation DateRangeResult where

982− key = TextValue . dateRangeKey

983− docCount = dateRangeDocCount

984− aggs = dateRangeAggs

985+data Bucket a = Bucket

986+ { buckets :: [a]

987+ } deriving (Read, Show)

985988

986989instance (FromJSON a) => FromJSON (Bucket a) where

987990 parseJSON (Object v) = Bucket <$>

988991 v .: "buckets"

989992 parseJSON _ = mempty

990993

994+data BucketValue = TextValue Text

995+ | ScientificValue Scientific

996+ | BoolValue Bool deriving (Read, Show)

997+

991998instance FromJSON BucketValue where

992999 parseJSON (String t) = return $ TextValue t

9931000 parseJSON (Number s) = return $ ScientificValue s

9941001 parseJSON (Bool b) = return $ BoolValue b

9951002 parseJSON _ = mempty

9961003

1004+data MissingResult = MissingResult

1005+ { missingDocCount :: Int

1006+ } deriving (Show)

1007+

9971008instance FromJSON MissingResult where

9981009 parseJSON = withObject "MissingResult" parse

9991010 where parse v = MissingResult <$> v .: "doc_count"

10001011

1012+data TopHitResult a = TopHitResult

1013+ { tarHits :: (SearchHits a)

1014+ } deriving Show

1015+

1016+instance (FromJSON a) => FromJSON (TopHitResult a) where

1017+ parseJSON (Object v) = TopHitResult <$>

1018+ v .: "hits"

1019+ parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"

1020+

1021+data TermsResult = TermsResult

1022+ { termKey :: BucketValue

1023+ , termsDocCount :: Int

1024+ , termsAggs :: Maybe AggregationResults

1025+ } deriving (Read, Show)

1026+

10011027instance FromJSON TermsResult where

10021028 parseJSON (Object v) = TermsResult <$>

10031029 v .: "key" <*>

@@ -1005,6 +1031,18 @@ instance FromJSON TermsResult where

10051031 (pure $ getNamedSubAgg v ["key", "doc_count"])

10061032 parseJSON _ = mempty

10071033

1034+instance BucketAggregation TermsResult where

1035+ key = termKey

1036+ docCount = termsDocCount

1037+ aggs = termsAggs

1038+

1039+data DateHistogramResult = DateHistogramResult

1040+ { dateKey :: Int

1041+ , dateKeyStr :: Maybe Text

1042+ , dateDocCount :: Int

1043+ , dateHistogramAggs :: Maybe AggregationResults

1044+ } deriving (Show)

1045+

10081046instance FromJSON DateHistogramResult where

10091047 parseJSON (Object v) = DateHistogramResult <$>

10101048 v .: "key" <*>

@@ -1017,6 +1055,21 @@ instance FromJSON DateHistogramResult where

10171055 )

10181056 parseJSON _ = mempty

10191057

1058+instance BucketAggregation DateHistogramResult where

1059+ key = TextValue . showText . dateKey

1060+ docCount = dateDocCount

1061+ aggs = dateHistogramAggs

1062+

1063+data DateRangeResult = DateRangeResult

1064+ { dateRangeKey :: Text

1065+ , dateRangeFrom :: Maybe UTCTime

1066+ , dateRangeFromAsString :: Maybe Text

1067+ , dateRangeTo :: Maybe UTCTime

1068+ , dateRangeToAsString :: Maybe Text

1069+ , dateRangeDocCount :: Int

1070+ , dateRangeAggs :: Maybe AggregationResults

1071+ } deriving (Eq, Show)

1072+

10201073instance FromJSON DateRangeResult where

10211074 parseJSON = withObject "DateRangeResult" parse

10221075 where parse v = DateRangeResult <$>

@@ -1035,10 +1088,26 @@ instance FromJSON DateRangeResult where

10351088 ]

10361089 )

10371090

1038−instance (FromJSON a) => FromJSON (TopHitResult a) where

1039− parseJSON (Object v) = TopHitResult <$>

1040− v .: "hits"

1041− parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"

1091+instance BucketAggregation DateRangeResult where

1092+ key = TextValue . dateRangeKey

1093+ docCount = dateRangeDocCount

1094+ aggs = dateRangeAggs

1095+

1096+toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)

1097+toTerms = toAggResult

1098+

1099+toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)

1100+toDateHistogram = toAggResult

1101+

1102+toMissing :: Text -> AggregationResults -> Maybe MissingResult

1103+toMissing = toAggResult

1104+

1105+toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)

1106+toTopHits = toAggResult

1107+

1108+toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a

1109+toAggResult t a = M.lookup t a >>= deserialize

1110+ where deserialize = parseMaybe parseJSON

10421111

10431112-- Try to get an AggregationResults when we don't know the

10441113-- field name. We filter out the known keys to try to minimize the noise.

@@ -1049,339 +1118,6 @@ getNamedSubAgg o knownKeys = maggRes

10491118 | HM.null unknownKeys = Nothing

10501119 | otherwise = Just . M.fromList $ HM.toList unknownKeys

10511120

1052−instance ToJSON GeoPoint where

1053− toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) =

1054− object [ geoPointField .= geoPointLatLon ]

1055−

1056−instance FromJSON Status where

1057− parseJSON (Object v) = Status <$>

1058− v .: "name" <*>

1059− v .: "cluster_name" <*>

1060− v .: "cluster_uuid" <*>

1061− v .: "version" <*>

1062− v .: "tagline"

1063− parseJSON _ = empty

1064−

1065−instance ToJSON IndexSettings where

1066− toJSON (IndexSettings s r) = object ["settings" .=

1067− object ["index" .=

1068− object ["number_of_shards" .= s, "number_of_replicas" .= r]

1069− ]

1070− ]

1071−

1072−instance FromJSON IndexSettings where

1073− parseJSON = withObject "IndexSettings" parse

1074− where parse o = do s <- o .: "settings"

1075− i <- s .: "index"

1076− IndexSettings <$> i .: "number_of_shards"

1077− <*> i .: "number_of_replicas"

1078−

1079−instance ToJSON UpdatableIndexSetting where

1080− toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x

1081− toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x

1082− toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x)

1083− toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x

1084− toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x

1085− toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x

1086− toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x

1087− toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x)

1088− toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x

1089− toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x

1090− toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x)

1091− toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x)

1092− toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs)

1093− toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs)

1094− toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs)

1095− toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x

1096− toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x

1097− toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x

1098− toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x)

1099− toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x

1100− toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x

1101− toJSON (CompressionSetting x) = oPath ("index" :| ["codec"]) x

1102− toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x

1103− toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x

1104− toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x

1105− toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x

1106− toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x

1107− toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x

1108− toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x

1109− toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping","total_fields","limit"]) x

1110− toJSON (AnalysisSetting x) = oPath ("index" :| ["analysis"]) x

1111−

1112−instance FromJSON UpdatableIndexSetting where

1113− parseJSON = withObject "UpdatableIndexSetting" parse

1114− where parse o = numberOfReplicas `taggedAt` ["index", "number_of_replicas"]

1115− <|> autoExpandReplicas `taggedAt` ["index", "auto_expand_replicas"]

1116− <|> refreshInterval `taggedAt` ["index", "refresh_interval"]

1117− <|> indexConcurrency `taggedAt` ["index", "concurrency"]

1118− <|> failOnMergeFailure `taggedAt` ["index", "fail_on_merge_failure"]

1119− <|> translogFlushThresholdOps `taggedAt` ["index", "translog", "flush_threshold_ops"]

1120− <|> translogFlushThresholdSize `taggedAt` ["index", "translog", "flush_threshold_size"]

1121− <|> translogFlushThresholdPeriod `taggedAt` ["index", "translog", "flush_threshold_period"]

1122− <|> translogDisableFlush `taggedAt` ["index", "translog", "disable_flush"]

1123− <|> cacheFilterMaxSize `taggedAt` ["index", "cache", "filter", "max_size"]

1124− <|> cacheFilterExpire `taggedAt` ["index", "cache", "filter", "expire"]

1125− <|> gatewaySnapshotInterval `taggedAt` ["index", "gateway", "snapshot_interval"]

1126− <|> routingAllocationInclude `taggedAt` ["index", "routing", "allocation", "include"]

1127− <|> routingAllocationExclude `taggedAt` ["index", "routing", "allocation", "exclude"]

1128− <|> routingAllocationRequire `taggedAt` ["index", "routing", "allocation", "require"]

1129− <|> routingAllocationEnable `taggedAt` ["index", "routing", "allocation", "enable"]

1130− <|> routingAllocationShardsPerNode `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"]

1131− <|> recoveryInitialShards `taggedAt` ["index", "recovery", "initial_shards"]

1132− <|> gcDeletes `taggedAt` ["index", "gc_deletes"]

1133− <|> ttlDisablePurge `taggedAt` ["index", "ttl", "disable_purge"]

1134− <|> translogFSType `taggedAt` ["index", "translog", "fs", "type"]

1135− <|> compressionSetting `taggedAt` ["index", "codec"]

1136− <|> compoundFormat `taggedAt` ["index", "compound_format"]

1137− <|> compoundOnFlush `taggedAt` ["index", "compound_on_flush"]

1138− <|> warmerEnabled `taggedAt` ["index", "warmer", "enabled"]

1139− <|> blocksReadOnly `taggedAt` ["blocks", "read_only"]

1140− <|> blocksRead `taggedAt` ["blocks", "read"]

1141− <|> blocksWrite `taggedAt` ["blocks", "write"]

1142− <|> blocksMetaData `taggedAt` ["blocks", "metadata"]

1143− <|> mappingTotalFieldsLimit `taggedAt` ["index", "mapping", "total_fields", "limit"]

1144− <|> analysisSetting `taggedAt` ["index", "analysis"]

1145− where taggedAt f ks = taggedAt' f (Object o) ks

1146− taggedAt' f v [] = f =<< (parseJSON v <|> (parseJSON (unStringlyTypeJSON v)))

1147− taggedAt' f v (k:ks) = withObject "Object" (\o -> do v' <- o .: k

1148− taggedAt' f v' ks) v

1149− numberOfReplicas = pure . NumberOfReplicas

1150− autoExpandReplicas = pure . AutoExpandReplicas

1151− refreshInterval = pure . RefreshInterval . ndtJSON

1152− indexConcurrency = pure . IndexConcurrency

1153− failOnMergeFailure = pure . FailOnMergeFailure

1154− translogFlushThresholdOps = pure . TranslogFlushThresholdOps

1155− translogFlushThresholdSize = pure . TranslogFlushThresholdSize

1156− translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON

1157− translogDisableFlush = pure . TranslogDisableFlush

1158− cacheFilterMaxSize = pure . CacheFilterMaxSize

1159− cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON

1160− gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON

1161− routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter

1162− routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter

1163− routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter

1164− routingAllocationEnable = pure . RoutingAllocationEnable

1165− routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode

1166− recoveryInitialShards = pure . RecoveryInitialShards

1167− gcDeletes = pure . GCDeletes . ndtJSON

1168− ttlDisablePurge = pure . TTLDisablePurge

1169− translogFSType = pure . TranslogFSType

1170− compressionSetting = pure . CompressionSetting

1171− compoundFormat = pure . IndexCompoundFormat

1172− compoundOnFlush = pure . IndexCompoundOnFlush

1173− warmerEnabled = pure . WarmerEnabled

1174− blocksReadOnly = pure . BlocksReadOnly

1175− blocksRead = pure . BlocksRead

1176− blocksWrite = pure . BlocksWrite

1177− blocksMetaData = pure . BlocksMetaData

1178− mappingTotalFieldsLimit = pure . MappingTotalFieldsLimit

1179− analysisSetting = pure . AnalysisSetting

1180−

1181−instance FromJSON IndexSettingsSummary where

1182− parseJSON = withObject "IndexSettingsSummary" parse

1183− where parse o = case HM.toList o of

1184− [(ixn, v@(Object o'))] -> IndexSettingsSummary (IndexName ixn)

1185− <$> parseJSON v

1186− <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")

1187− _ -> fail "Expected single-key object with index name"

1188− redundant (NumberOfReplicas _) = True

1189− redundant _ = False

1190−

1191−

1192−parseSettings :: Object -> Parser [UpdatableIndexSetting]

1193−parseSettings o = do

1194− o' <- o .: "index"

1195− -- slice the index object into singleton hashmaps and try to parse each

1196− parses <- forM (HM.toList o') $ \(k, v) -> do

1197− -- blocks are now nested into the "index" key, which is not how they're serialized

1198− let atRoot = Object (HM.singleton k v)

1199− let atIndex = Object (HM.singleton "index" atRoot)

1200− optional (parseJSON atRoot <|> parseJSON atIndex)

1201− return (catMaybes parses)

1202−

1203−oPath :: ToJSON a => NonEmpty Text -> a -> Value

1204−oPath (k :| []) v = object [k .= v]

1205−oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]

1206−

1207−attrFilterJSON :: NonEmpty NodeAttrFilter -> Value

1208−attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)

1209− | NodeAttrFilter (NodeAttrName n) vs <- toList fs]

1210−

1211−parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)

1212−parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse

1213− where parse o = case HM.toList o of

1214− [] -> fail "Expected non-empty list of NodeAttrFilters"

1215− x:xs -> DT.mapM (uncurry parse') (x :| xs)

1216− parse' n = withText "Text" $ \t ->

1217− case T.splitOn "," t of

1218− fv:fvs -> return (NodeAttrFilter (NodeAttrName n) (fv :| fvs))

1219− [] -> fail "Expected non-empty list of filter values"

1220−

1221−instance ToJSON ReplicaBounds where

1222− toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b)

1223− toJSON (ReplicasLowerBounded a) = String (showText a <> "-all")

1224− toJSON ReplicasUnbounded = Bool False

1225−

1226−instance FromJSON ReplicaBounds where

1227− parseJSON v = withText "ReplicaBounds" parseText v

1228− <|> withBool "ReplicaBounds" parseBool v

1229− where parseText t = case T.splitOn "-" t of

1230− [a, "all"] -> ReplicasLowerBounded <$> parseReadText a

1231− [a, b] -> ReplicasBounded <$> parseReadText a

1232− <*> parseReadText b

1233− _ -> fail ("Could not parse ReplicaBounds: " <> show t)

1234− parseBool False = pure ReplicasUnbounded

1235− parseBool _ = fail "ReplicasUnbounded cannot be represented with True"

1236−

1237−instance ToJSON AllocationPolicy where

1238− toJSON AllocAll = String "all"

1239− toJSON AllocPrimaries = String "primaries"

1240− toJSON AllocNewPrimaries = String "new_primaries"

1241− toJSON AllocNone = String "none"

1242−

1243−instance FromJSON AllocationPolicy where

1244− parseJSON = withText "AllocationPolicy" parse

1245− where parse "all" = pure AllocAll

1246− parse "primaries" = pure AllocPrimaries

1247− parse "new_primaries" = pure AllocNewPrimaries

1248− parse "none" = pure AllocNone

1249− parse t = fail ("Invlaid AllocationPolicy: " <> show t)

1250−

1251−instance ToJSON InitialShardCount where

1252− toJSON QuorumShards = String "quorum"

1253− toJSON QuorumMinus1Shards = String "quorum-1"

1254− toJSON FullShards = String "full"

1255− toJSON FullMinus1Shards = String "full-1"

1256− toJSON (ExplicitShards x) = toJSON x

1257−

1258−instance FromJSON InitialShardCount where

1259− parseJSON v = withText "InitialShardCount" parseText v

1260− <|> ExplicitShards <$> parseJSON v

1261− where parseText "quorum" = pure QuorumShards

1262− parseText "quorum-1" = pure QuorumMinus1Shards

1263− parseText "full" = pure FullShards

1264− parseText "full-1" = pure FullMinus1Shards

1265− parseText _ = mzero

1266−

1267−instance ToJSON FSType where

1268− toJSON FSSimple = "simple"

1269− toJSON FSBuffered = "buffered"

1270−

1271−instance FromJSON FSType where

1272− parseJSON = withText "FSType" parse

1273− where parse "simple" = pure FSSimple

1274− parse "buffered" = pure FSBuffered

1275− parse t = fail ("Invalid FSType: " <> show t)

1276−

1277−instance ToJSON CompoundFormat where

1278− toJSON (CompoundFileFormat x) = Bool x

1279− toJSON (MergeSegmentVsTotalIndex x) = toJSON x

1280−

1281−instance FromJSON CompoundFormat where

1282− parseJSON v = CompoundFileFormat <$> parseJSON v

1283− <|> MergeSegmentVsTotalIndex <$> parseJSON v

1284−

1285−instance ToJSON NominalDiffTimeJSON where

1286− toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s")

1287−

1288−instance FromJSON NominalDiffTimeJSON where

1289− parseJSON = withText "NominalDiffTime" parse

1290− where parse t = case T.takeEnd 1 t of

1291− "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t)

1292− _ -> fail "Invalid or missing NominalDiffTime unit (expected s)"

1293−

1294−instance ToJSON IndexTemplate where

1295− toJSON (IndexTemplate p s m) = merge

1296− (object [ "template" .= p

1297− , "mappings" .= foldl' merge (object []) m

1298− ])

1299− (toJSON s)

1300− where

1301− merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2

1302− merge o Null = o

1303− merge _ _ = undefined

1304−

1305−instance (FromJSON a) => FromJSON (EsResult a) where

1306− parseJSON jsonVal@(Object v) = do

1307− found <- v .:? "found" .!= False

1308− fr <- if found

1309− then parseJSON jsonVal

1310− else return Nothing

1311− EsResult <$> v .: "_index" <*>

1312− v .: "_type" <*>

1313− v .: "_id" <*>

1314− pure fr

1315− parseJSON _ = empty

1316−

1317−instance (FromJSON a) => FromJSON (EsResultFound a) where

1318− parseJSON (Object v) = EsResultFound <$>

1319− v .: "_version" <*>

1320− v .: "_source"

1321− parseJSON _ = empty

1322−

1323−instance FromJSON EsError where

1324− parseJSON (Object v) = EsError <$>

1325− v .: "status" <*>

1326− (v .: "error" <|> (v .: "error" >>= (.: "reason")))

1327− parseJSON _ = empty

1328−

1329−instance FromJSON IndexAliasesSummary where

1330− parseJSON = withObject "IndexAliasesSummary" parse

1331− where parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (HM.toList o)

1332− go ixn = withObject "index aliases" $ \ia -> do

1333− aliases <- ia .:? "aliases" .!= mempty

1334− forM (HM.toList aliases) $ \(aName, v) -> do

1335− let indexAlias = IndexAlias (IndexName ixn) (IndexAliasName (IndexName aName))

1336− IndexAliasSummary indexAlias <$> parseJSON v

1337−

1338−

1339−instance ToJSON IndexAliasAction where

1340− toJSON (AddAlias ia opts) = object ["add" .= (iaObj <> optsObj)]

1341− where Object iaObj = toJSON ia

1342− Object optsObj = toJSON opts

1343− toJSON (RemoveAlias ia) = object ["remove" .= iaObj]

1344− where Object iaObj = toJSON ia

1345−

1346−instance ToJSON IndexAlias where

1347− toJSON IndexAlias {..} = object ["index" .= srcIndex

1348− , "alias" .= indexAlias

1349− ]

1350−

1351−instance ToJSON IndexAliasCreate where

1352− toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj)

1353− where filterObj = maybe mempty (HM.singleton "filter" . toJSON) aliasCreateFilter

1354− Object routingObj = maybe (Object mempty) toJSON aliasCreateRouting

1355−

1356−instance ToJSON AliasRouting where

1357− toJSON (AllAliasRouting v) = object ["routing" .= v]

1358− toJSON (GranularAliasRouting srch idx) = object (catMaybes prs)

1359− where prs = [("search_routing" .=) <$> srch

1360− ,("index_routing" .=) <$> idx]

1361−

1362−instance FromJSON AliasRouting where

1363− parseJSON = withObject "AliasRouting" parse

1364− where parse o = parseAll o <|> parseGranular o

1365− parseAll o = AllAliasRouting <$> o .: "routing"

1366− parseGranular o = do

1367− sr <- o .:? "search_routing"

1368− ir <- o .:? "index_routing"

1369− if isNothing sr && isNothing ir

1370− then fail "Both search_routing and index_routing can't be blank"

1371− else return (GranularAliasRouting sr ir)

1372−

1373−instance FromJSON IndexAliasCreate where

1374− parseJSON v = withObject "IndexAliasCreate" parse v

1375− where parse o = IndexAliasCreate <$> optional (parseJSON v)

1376− <*> o .:? "filter"

1377−

1378−instance ToJSON SearchAliasRouting where

1379− toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs))

1380−

1381−instance FromJSON SearchAliasRouting where

1382− parseJSON = withText "SearchAliasRouting" parse

1383− where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)

1384−

13851121instance ToJSON Search where

13861122 toJSON (Search mquery sFilter sort searchAggs

13871123 highlight sTrackSortScores sFrom sSize _ sFields

@@ -1494,91 +1230,12 @@ nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =

14941230 [ "fragment_size" .= npFragSize

14951231 , "number_of_fragments" .= npNumOfFrags]

14961232

1497−

1498−instance ToJSON HighlightEncoder where

1499− toJSON DefaultEncoder = String "default"

1500− toJSON HTMLEncoder = String "html"

1501−

15021233highlightTagToPairs :: Maybe HighlightTag -> [Pair]

15031234highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"]

15041235highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre

15051236 , "post_tags" .= post]

15061237highlightTagToPairs Nothing = []

15071238

1508−instance ToJSON SortSpec where

1509− toJSON (DefaultSortSpec

1510− (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped

1511− dsSortMode dsMissingSort dsNestedFilter)) =

1512− object [dsSortFieldName .= omitNulls base] where

1513− base = [ "order" .= dsSortOrder

1514− , "unmapped_type" .= dsIgnoreUnmapped

1515− , "mode" .= dsSortMode

1516− , "missing" .= dsMissingSort

1517− , "nested_filter" .= dsNestedFilter ]

1518−

1519− toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) =

1520− object [ "unit" .= units

1521− , field .= gdsLatLon

1522− , "order" .= gdsSortOrder ]

1523−

1524−

1525−instance ToJSON SortOrder where

1526− toJSON Ascending = String "asc"

1527− toJSON Descending = String "desc"

1528−

1529−

1530−instance ToJSON SortMode where

1531− toJSON SortMin = String "min"

1532− toJSON SortMax = String "max"

1533− toJSON SortSum = String "sum"

1534− toJSON SortAvg = String "avg"

1535−

1536−

1537−instance ToJSON Missing where

1538− toJSON LastMissing = String "_last"

1539− toJSON FirstMissing = String "_first"

1540− toJSON (CustomMissing txt) = String txt

1541−

1542−

1543−

1544−instance (FromJSON a) => FromJSON (SearchResult a) where

1545− parseJSON (Object v) = SearchResult <$>

1546− v .: "took" <*>

1547− v .: "timed_out" <*>

1548− v .: "_shards" <*>

1549− v .: "hits" <*>

1550− v .:? "aggregations" <*>

1551− v .:? "_scroll_id" <*>

1552− v .:? "suggest"

1553− parseJSON _ = empty

1554−

1555−instance (FromJSON a) => FromJSON (SearchHits a) where

1556− parseJSON (Object v) = SearchHits <$>

1557− v .: "total" <*>

1558− v .: "max_score" <*>

1559− v .: "hits"

1560− parseJSON _ = empty

1561−

1562−instance (FromJSON a) => FromJSON (Hit a) where

1563− parseJSON (Object v) = Hit <$>

1564− v .: "_index" <*>

1565− v .: "_type" <*>

1566− v .: "_id" <*>

1567− v .: "_score" <*>

1568− v .:? "_source" <*>

1569− v .:? "fields" <*>

1570− v .:? "highlight"

1571− parseJSON _ = empty

1572−

1573−instance FromJSON HitFields where

1574− parseJSON x

1575− = HitFields <$> parseJSON x

1576−

1577−instance FromJSON DocVersion where

1578− parseJSON v = do

1579− i <- parseJSON v

1580− maybe (fail "DocVersion out of range") return $ mkDocVersion i

1581−

15821239data Suggest = Suggest { suggestText :: Text

15831240 , suggestName :: Text

15841241 , suggestType :: SuggestType

@@ -1613,36 +1270,38 @@ instance FromJSON SuggestType where

16131270 where taggedWith parser k = parser =<< o .: k

16141271 phraseSuggester = pure . SuggestTypePhraseSuggester

16151272

1616−data PhraseSuggester =

1617− PhraseSuggester { phraseSuggesterField :: FieldName

1618− , phraseSuggesterGramSize :: Maybe Int

1619− , phraseSuggesterRealWordErrorLikelihood :: Maybe Int

1620− , phraseSuggesterConfidence :: Maybe Int

1621− , phraseSuggesterMaxErrors :: Maybe Int

1622− , phraseSuggesterSeparator :: Maybe Text

1623− , phraseSuggesterSize :: Maybe Size

1624− , phraseSuggesterAnalyzer :: Maybe Analyzer

1625− , phraseSuggesterShardSize :: Maybe Int

1626− , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter

1627− , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate

1628− , phraseSuggesterCandidateGenerators :: [DirectGenerators]

1629− }

1630− deriving (Eq, Show)

1273+data PhraseSuggester = PhraseSuggester

1274+ { phraseSuggesterField :: FieldName

1275+ , phraseSuggesterGramSize :: Maybe Int

1276+ , phraseSuggesterRealWordErrorLikelihood :: Maybe Int

1277+ , phraseSuggesterConfidence :: Maybe Int

1278+ , phraseSuggesterMaxErrors :: Maybe Int

1279+ , phraseSuggesterSeparator :: Maybe Text

1280+ , phraseSuggesterSize :: Maybe Size

1281+ , phraseSuggesterAnalyzer :: Maybe Analyzer

1282+ , phraseSuggesterShardSize :: Maybe Int

1283+ , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter

1284+ , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate

1285+ , phraseSuggesterCandidateGenerators :: [DirectGenerators]

1286+ } deriving (Eq, Show)

16311287

16321288instance ToJSON PhraseSuggester where

1633− toJSON PhraseSuggester{..} = omitNulls [ "field" .= phraseSuggesterField

1634− , "gram_size" .= phraseSuggesterGramSize

1635− , "real_word_error_likelihood" .= phraseSuggesterRealWordErrorLikelihood

1636− , "confidence" .= phraseSuggesterConfidence

1637− , "max_errors" .= phraseSuggesterMaxErrors

1638− , "separator" .= phraseSuggesterSeparator

1639− , "size" .= phraseSuggesterSize

1640− , "analyzer" .= phraseSuggesterAnalyzer

1641− , "shard_size" .= phraseSuggesterShardSize

1642− , "highlight" .= phraseSuggesterHighlight

1643− , "collate" .= phraseSuggesterCollate

1644− , "direct_generator" .= phraseSuggesterCandidateGenerators

1645− ]

1289+ toJSON PhraseSuggester{..} =

1290+ omitNulls [ "field" .= phraseSuggesterField

1291+ , "gram_size" .= phraseSuggesterGramSize

1292+ , "real_word_error_likelihood" .=

1293+ phraseSuggesterRealWordErrorLikelihood

1294+ , "confidence" .= phraseSuggesterConfidence

1295+ , "max_errors" .= phraseSuggesterMaxErrors

1296+ , "separator" .= phraseSuggesterSeparator

1297+ , "size" .= phraseSuggesterSize

1298+ , "analyzer" .= phraseSuggesterAnalyzer

1299+ , "shard_size" .= phraseSuggesterShardSize

1300+ , "highlight" .= phraseSuggesterHighlight

1301+ , "collate" .= phraseSuggesterCollate

1302+ , "direct_generator" .=

1303+ phraseSuggesterCandidateGenerators

1304+ ]

16461305

16471306instance FromJSON PhraseSuggester where

16481307 parseJSON = withObject "PhraseSuggester" parse

@@ -1683,19 +1342,19 @@ instance FromJSON PhraseSuggesterHighlighter where

16831342 <$> o .: "pre_tag"

16841343 <*> o .: "post_tag"

16851344

1686−data PhraseSuggesterCollate =

1687− PhraseSuggesterCollate { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline

1688− , phraseSuggesterCollatePrune :: Bool

1689− }

1690− deriving (Eq, Show)

1345+data PhraseSuggesterCollate = PhraseSuggesterCollate

1346+ { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline

1347+ , phraseSuggesterCollatePrune :: Bool

1348+ } deriving (Eq, Show)

16911349

16921350instance ToJSON PhraseSuggesterCollate where

1693− toJSON PhraseSuggesterCollate{..} = object [ "query" .= object

1694− [ "inline" .= (inline phraseSuggesterCollateTemplateQuery)

1695− ]

1696− , "params" .= (params phraseSuggesterCollateTemplateQuery)

1697− , "prune" .= phraseSuggesterCollatePrune

1698− ]

1351+ toJSON PhraseSuggesterCollate{..} =

1352+ object [ "query" .= object

1353+ [ "inline" .= (inline phraseSuggesterCollateTemplateQuery)

1354+ ]

1355+ , "params" .= (params phraseSuggesterCollateTemplateQuery)

1356+ , "prune" .= phraseSuggesterCollatePrune

1357+ ]

16991358

17001359instance FromJSON PhraseSuggesterCollate where

17011360 parseJSON (Object o) = do

@@ -1703,7 +1362,8 @@ instance FromJSON PhraseSuggesterCollate where

17031362 inline' <- query' .: "inline"

17041363 params' <- o .: "params"

17051364 prune' <- o .:? "prune" .!= False

1706− return $ PhraseSuggesterCollate (TemplateQueryInline inline' params') prune'

1365+ return $ PhraseSuggesterCollate

1366+ (TemplateQueryInline inline' params') prune'

17071367 parseJSON x = typeMismatch "PhraseSuggesterCollate" x

17081368

17091369data SuggestOptions =

@@ -1738,11 +1398,10 @@ instance FromJSON SuggestResponse where

17381398 <*> o .: "length"

17391399 <*> o .: "options"

17401400

1741−data NamedSuggestionResponse =

1742− NamedSuggestionResponse { nsrName :: Text

1743− , nsrResponses :: [SuggestResponse]

1744− }

1745− deriving (Eq, Read, Show)

1401+data NamedSuggestionResponse = NamedSuggestionResponse

1402+ { nsrName :: Text

1403+ , nsrResponses :: [SuggestResponse]

1404+ } deriving (Eq, Read, Show)

17461405

17471406instance FromJSON NamedSuggestionResponse where

17481407 parseJSON (Object o) = do

@@ -1786,7 +1445,6 @@ data DirectGenerators = DirectGenerators

17861445 }

17871446 deriving (Eq, Show)

17881447

1789−

17901448instance ToJSON DirectGenerators where

17911449 toJSON DirectGenerators{..} = omitNulls [ "field" .= directGeneratorsField

17921450 , "size" .= directGeneratorsSize

tests/V5/Test/Aggregation.hs+2−2

@@ -1,6 +1,6 @@

11{-# LANGUAGE OverloadedStrings #-}

3−module Test.Aggregation where

3+module Test.Aggregation (spec) where

55import Test.Common

66import Test.Import

@@ -29,7 +29,7 @@ spec =

2929 usersAggResults = result >>= aggregations >>= toTerms "users"

3030 subAggResults = usersAggResults >>= (listToMaybe . buckets) >>= termsAggs >>= toTerms "age_agg"

3131 subAddResultsExists = isJust subAggResults

32− liftIO $ (subAddResultsExists) `shouldBe` True

32+ liftIO $ subAddResultsExists `shouldBe` True

3333

3434 it "returns cardinality aggregation results" $ withTestEnv $ do

3535 _ <- insertData

tests/V5/Test/BulkAPI.hs+4−4

@@ -1,6 +1,6 @@

11{-# LANGUAGE OverloadedStrings #-}

3−module Test.BulkAPI where

3+module Test.BulkAPI (spec) where

55import Test.Common

66import Test.Import

@@ -9,7 +9,7 @@ import qualified Data.Vector as V

99import qualified Lens.Micro.Aeson as LMA

1010

1111newtype BulkTest =

12− BulkTest { name :: Text }

12+ BulkTest Text

1313 deriving (Eq, Show)

1414

1515instance ToJSON BulkTest where

@@ -25,7 +25,7 @@ instance FromJSON BulkTest where

2525

2626spec :: Spec

2727spec =

28− describe "Bulk API" $ do

28+ describe "Bulk API" $

2929 it "inserts all documents we request" $ withTestEnv $ do

3030 _ <- insertData

3131 let firstTest = BulkTest "blah"

@@ -84,7 +84,7 @@ spec =

8484 hitsTotal (searchHits sr) `shouldBe` 6

8585 let nameList :: [Text]

8686 nameList =

87− (hits (searchHits sr))

87+ hits (searchHits sr)

8888 ^.. traverse

8989 . to hitSource

9090 . _Just

tests/V5/Test/Documents.hs+2−2

@@ -14,14 +14,14 @@ spec =

1414 docInserted <- getDocument testIndex testMapping (DocId "1")

1515 let newTweet = eitherDecode

1616 (responseBody docInserted) :: Either String (EsResult Tweet)

17− liftIO $ (fmap getSource newTweet `shouldBe` Right (Just patchedTweet))

17+ liftIO $ fmap getSource newTweet `shouldBe` Right (Just patchedTweet)

1818

1919 it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do

2020 _ <- insertWithSpaceInId

2121 docInserted <- getDocument testIndex testMapping (DocId "Hello World")

2222 let newTweet = eitherDecode

2323 (responseBody docInserted) :: Either String (EsResult Tweet)

24− liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))

24+ liftIO $ fmap getSource newTweet `shouldBe` Right (Just exampleTweet)

2525

2626 it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do

2727 doc <- getDocument testIndex testMapping (DocId "bogus")

tests/V5/Test/Generators.hs+4−2

@@ -36,8 +36,10 @@ instance Arbitrary UTCTime where

3636 <*> (fromRational . toRational <$> choose (0::Double, 86400))

3737

3838instance Arbitrary Day where

39− arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary

40− shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay

39+ arbitrary =

40+ ModifiedJulianDay . (2000 +) <$> arbitrary

41+ shrink =

42+ (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay

4143

4244#if !MIN_VERSION_QuickCheck(2,9,0)

4345instance Arbitrary a => Arbitrary (NonEmpty a) where

tests/V5/Test/Highlights.hs+11−15

@@ -7,28 +7,24 @@ import Test.Import

88import qualified Data.Map as M

10+initHighlights :: Text -> BH IO (Either EsError (Maybe HitHighlight))

11+initHighlights fieldName = do

12+ _ <- insertData

13+ _ <- insertOther

14+ let query = QueryMatchQuery $ mkMatchQuery (FieldName fieldName) (QueryString "haskell")

15+ let testHighlight = Highlights Nothing [FieldHighlight (FieldName fieldName) Nothing]

16+ let search = mkHighlightSearch (Just query) testHighlight

17+ searchTweetHighlight search

18+

1019spec :: Spec

1120spec =

1221 describe "Highlights API" $ do

13−

1422 it "returns highlight from query when there should be one" $ withTestEnv $ do

15− _ <- insertData

16− _ <- insertOther

17− let query = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell")

18− let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]

19−

20− let search = mkHighlightSearch (Just query) testHighlight

21− myHighlight <- searchTweetHighlight search

23+ myHighlight <- initHighlights "message"

2224 liftIO $

2325 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))

2426

2527 it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do

26− _ <- insertData

27− _ <- insertOther

28− let query = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell")

29− let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]

30−

31− let search = mkHighlightSearch (Just query) testHighlight

32− myHighlight <- searchTweetHighlight search

28+ myHighlight <- initHighlights "user"

3329 liftIO $

3430 myHighlight `shouldBe` Right Nothing

tests/V5/Test/JSON.hs+1−1

@@ -1,7 +1,7 @@

11{-# LANGUAGE OverloadedStrings #-}

22{-# LANGUAGE ScopedTypeVariables #-}

4−module Test.JSON where

4+module Test.JSON (spec) where

66import Test.Import

tests/V5/Test/Script.hs+3−2

@@ -10,7 +10,7 @@ import qualified Data.Map as M

1010

1111spec :: Spec

1212spec =

13− describe "Script" $ do

13+ describe "Script" $

1414 it "returns a transformed document based on the script field" $ withTestEnv $ do

1515 _ <- insertData

1616 let query = MatchAllQuery Nothing

@@ -32,4 +32,5 @@ spec =

3232 Right sr -> do

3333 let Just results =

3434 hitFields (head (hits (searchHits sr)))

35− liftIO $ results `shouldBe` (HitFields (M.fromList [("test1", [Number 20000.0])]))

35+ liftIO $

36+ results `shouldBe` HitFields (M.fromList [("test1", [Number 20000.0])])

tests/V5/Test/Snapshots.hs+4−4

@@ -1,7 +1,7 @@

11{-# LANGUAGE RecordWildCards #-}

22{-# LANGUAGE OverloadedStrings #-}

4−module Test.Snapshots where

4+module Test.Snapshots (spec) where

66import Test.Common

77import Test.Import

@@ -18,7 +18,7 @@ import Test.Generators ()

1818

1919spec :: Spec

2020spec = do

21− describe "FsSnapshotRepo" $ do

21+ describe "FsSnapshotRepo" $

2222 prop "SnapshotRepo laws" $ \fsr ->

2323 fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)

2424

@@ -149,7 +149,7 @@ canSnapshot :: IO Bool

149149canSnapshot = do

150150 caresAboutRepos <- atleast es16

151151 repoPaths <- getRepoPaths

152− return (not caresAboutRepos || not (null (repoPaths)))

152+ return (not caresAboutRepos || not (null repoPaths))

153153

154154withSnapshotRepo

155155 :: ( MonadMask m

@@ -197,5 +197,5 @@ withSnapshot srn sn = bracket_ alloc free

197197 , snapIndices = Just (IndexList (testIndex :| []))

198198 -- We don't actually need to back up any data

199199 }

200− free = do

200+ free =

201201 deleteSnapshot srn sn

tests/V5/Test/Sorting.hs+1−1

@@ -7,7 +7,7 @@ import Test.Import

88spec :: Spec

99spec =

10− describe "sorting" $ do

10+ describe "sorting" $

1111 it "returns documents in the right order" $ withTestEnv $ do

1212 _ <- insertData

1313 _ <- insertOther

tests/V5/Test/SourceFiltering.hs+5−5

@@ -11,27 +11,27 @@ spec :: Spec

1111spec =

1212 describe "Source filtering" $ do

1313

14− it "doesn't include source when sources are disabled" $ withTestEnv $ do

14+ it "doesn't include source when sources are disabled" $ withTestEnv $

1515 searchExpectSource

1616 NoSource

1717 (Left (EsError 500 "Source was missing"))

1818

19− it "includes a source" $ withTestEnv $ do

19+ it "includes a source" $ withTestEnv $

2020 searchExpectSource

2121 (SourcePatterns (PopPattern (Pattern "message")))

2222 (Right (Object (HM.fromList [("message", String "Use haskell!")])))

2323

24− it "includes sources" $ withTestEnv $ do

24+ it "includes sources" $ withTestEnv $

2525 searchExpectSource

2626 (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))

2727 (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))

2828

29− it "includes source patterns" $ withTestEnv $ do

29+ it "includes source patterns" $ withTestEnv $

3030 searchExpectSource

3131 (SourcePatterns (PopPattern (Pattern "*ge")))

3232 (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))

3333

34− it "excludes source patterns" $ withTestEnv $ do

34+ it "excludes source patterns" $ withTestEnv $

3535 searchExpectSource

3636 (SourceIncludeExclude (Include [])

3737 (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"]))

tests/V5/Test/Suggest.hs+1−1

@@ -7,7 +7,7 @@ import Test.Import

88spec :: Spec

99spec =

10− describe "Suggest" $ do

10+ describe "Suggest" $

1111 it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do

1212 _ <- insertData

1313 let query = QueryMatchNoneQuery

tests/V5/tests.hs+11−13

@@ -1,13 +1,8 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DefaultSignatures #-}

3−{-# LANGUAGE DeriveDataTypeable #-}

4−{-# LANGUAGE DeriveGeneric #-}

52{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

73{-# LANGUAGE OverloadedStrings #-}

84{-# LANGUAGE RecordWildCards #-}

95{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TemplateHaskell #-}

116{-# LANGUAGE TypeOperators #-}

127{-# OPTIONS_GHC -fno-warn-orphans #-}

138#if __GLASGOW_HASKELL__ < 800

@@ -21,7 +16,7 @@ module Main where

2116import Test.Common

2217import Test.Import

2318

24−import Prelude hiding (filter)

19+import Prelude

2520

2621import qualified Test.Aggregation as Aggregation

2722import qualified Test.BulkAPI as Bulk

@@ -64,11 +59,11 @@ main = hspec $ do

6459 let errorResp = eitherDecode (responseBody res)

6560 liftIO (errorResp `shouldBe` Right (EsError 404 "no such index"))

6661

67− describe "Monoid (SearchHits a)" $ do

62+ describe "Monoid (SearchHits a)" $

6863 prop "abides the monoid laws" $ eq $

6964 prop_Monoid (T :: T (SearchHits ()))

7065

71− describe "mkDocVersion" $ do

66+ describe "mkDocVersion" $

7267 prop "can never construct an out of range docVersion" $ \i ->

7368 let res = mkDocVersion i

7469 in case res of

@@ -77,7 +72,7 @@ main = hspec $ do

7772 (dv <= maxBound) .&&.

7873 docVersionNumber dv === i

7974

80− describe "getNodesInfo" $ do

75+ describe "getNodesInfo" $

8176 it "fetches the responding node when LocalNode is used" $ withTestEnv $ do

8277 res <- getNodesInfo LocalNode

8378 liftIO $ case res of

@@ -87,7 +82,7 @@ main = hspec $ do

8782 Right NodesInfo {..} -> length nodesInfo `shouldBe` 1

8883 Left e -> expectationFailure ("Expected NodesInfo but got " <> show e)

8984

90− describe "getNodesStats" $ do

85+ describe "getNodesStats" $

9186 it "fetches the responding node when LocalNode is used" $ withTestEnv $ do

9287 res <- getNodesStats LocalNode

9388 liftIO $ case res of

@@ -97,7 +92,7 @@ main = hspec $ do

9792 Right NodesStats {..} -> length nodesStats `shouldBe` 1

9893 Left e -> expectationFailure ("Expected NodesStats but got " <> show e)

9994

100− describe "Enum DocVersion" $ do

95+ describe "Enum DocVersion" $

10196 it "follows the laws of Enum, Bounded" $ do

10297 evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall

10398 evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall

@@ -107,11 +102,14 @@ main = hspec $ do

107102 enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]

108103 enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]

109104

110− describe "Scan & Scroll API" $ do

105+ describe "Scan & Scroll API" $

111106 it "returns documents using the scan&scroll API" $ withTestEnv $ do

112107 _ <- insertData

113108 _ <- insertOther

114− let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) }

109+ let search =

110+ (mkSearch

111+ (Just $ MatchAllQuery Nothing) Nothing)

112+ { size = Size 1 }

115113 regular_search <- searchTweet search

116114 scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]

117115 let scan_search = map hitSource scan_search'