git.iko.soy/typeable/bloodhound
on 3e5220c help sign in
.gitignore−1
since splitsnapshots
unifiedsplit
@@ -19,4 +19,3 @@ bloodhound.iml
19examples/bloodhound-examples.cabal
19examples/bloodhound-examples.cabal
20/.ghc.environment.*
20/.ghc.environment.*
21.hspec-failures
21.hspec-failures
22−bloodhound.cabal
.travis.yml+14−8
@@ -1,22 +1,28 @@
1sudo: false
1sudo: false
2language: generic
2language: generic
3
3
4−jdk:
5− - oraclejdk11
6−
7addons:
4addons:
8 apt:
5 apt:
9 packages:
6 packages:
10 - libgmp-dev
7 - libgmp-dev
8+ - oracle-java8-installer
11
9
12env:
10env:
11+ global:
12+ - JAVA_HOME=/usr/lib/jvm/java-8-oracle
13 matrix:
13 matrix:
14+ - GHCVER=8.0 ESVER=1.7.6 STACK_YAML=stack-8.0.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
15+ - GHCVER=8.0 ESVER=5.0.2 STACK_YAML=stack-8.0.yaml ESFLAG=ES5 DLINK=https://artifacts.elastic.co/downloads/elasticsearch/elasticsearch ES_JAVA_OPTS="-Xms500m -Xmx750m"
16+ - GHCVER=8.2 ESVER=1.7.6 STACK_YAML=stack.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
17+ - GHCVER=8.2 ESVER=5.0.2 STACK_YAML=stack.yaml ESFLAG=ES5 DLINK=https://artifacts.elastic.co/downloads/elasticsearch/elasticsearch ES_JAVA_OPTS="-Xms500m -Xmx750m"
18+ - GHCVER=8.2 ESVER=5.5.0 STACK_YAML=stack.yaml ESFLAG=ES5 DLINK=https://artifacts.elastic.co/downloads/elasticsearch/elasticsearch ES_JAVA_OPTS="-Xms500m -Xmx750m"
19+# allow_failures:
14− - GHCVER=8.6 ESVER=5.6.0 STACK_YAML=stack.yaml DLINK=https://artifacts.elastic.co/downloads/elasticsearch/elasticsearch ES_JAVA_OPTS="-Xms500m -Xmx750m"
20+# - GHCVER=8.2 ESVER=6.1.3 STACK_YAML=stack.yaml ESFLAG=ES5 DLINK=https://artifacts.elastic.co/downloads/elasticsearch/elasticsearch ES_JAVA_OPTS="-Xms500m -Xmx750m"
15
21
16install:
22install:
17 # stack
23 # stack
18 - mkdir -p ~/.local/bin
24 - mkdir -p ~/.local/bin
19− - travis_retry curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
25+ - travis_retry curl -L https://github.com/commercialhaskell/stack/releases/download/v1.7.1/stack-1.7.1-linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
20 - export PATH=~/.local/bin:$PATH
26 - export PATH=~/.local/bin:$PATH
21 - stack --no-terminal --version
27 - stack --no-terminal --version
22 # elasticsearch
28 # elasticsearch
@@ -30,11 +36,11 @@ script:
30 - stack setup --no-terminal
36 - stack setup --no-terminal
31 - stack update --no-terminal
37 - stack update --no-terminal
32 - stack build -j2 --fast --no-terminal
38 - stack build -j2 --fast --no-terminal
33− - travis_wait 60 sleep 1800 &
39+ - travis_wait 45 sleep 1800 &
34− - stack test --fast --no-terminal bloodhound:bloodhound-tests --test-arguments="--qc-max-success 500"
40+ - stack test --fast --no-terminal bloodhound:bloodhound-tests --test-arguments="--qc-max-success 500" --flag bloodhound:$ESFLAG
35
41
36cache:
42cache:
37− timeout: 1500
43+ timeout: 2000
38 directories:
44 directories:
39 - $HOME/.cabal
45 - $HOME/.cabal
40 - $HOME/.ghc
46 - $HOME/.ghc
Makefile+44−89
@@ -1,129 +1,84 @@
1−.PHONY : build build-validate ghci test test-rerun test-ghci ghcid ghcid-validate \
2− weeder hlint hlint-watch mod-build
3−
4−.DEFAULT_GOAL = help
5−
6stack = STACK_YAML='stack.yaml' stack
1stack = STACK_YAML='stack.yaml' stack
7−ghc_perf_options = --ghc-options '+RTS -A128M -RTS'
2+
8−build = build $(ghc_perf_options)
9−ghci = ghci $(ghc_perf_options)
10−test = test $(ghc_perf_options)
11−stack-8.0 = STACK_YAML="stack-8.0.yaml" stack
12−stack-8.2 = STACK_YAML="stack-8.2.yaml" stack
13−stack-8.4 = STACK_YAML="stack-8.4.yaml" stack
14−stack-8.6 = STACK_YAML="stack-8.6.yaml" stack
15−elasticsearch_directory = elasticsearch
16−
17−# stack build --ghc-options '+RTS -A128M -RTS'
18−
19−## run build
20build:
3build:
21− $(stack) $(build)
4+ stack build
22
5
23−## build with validation options (Wall, Werror)
24build-validate:
6build-validate:
25− $(stack) build --fast --ghc-options '-Wall -Werror +RTS -A128M -RTS'
7+ stack build --fast --ghc-options '-Wall -Werror'
26
8
27−## run ghci
28ghci:
9ghci:
29− $(stack) $(ghci)
10+ stack ghci
30
11
31−## run tests
32test: echo-warn
12test: echo-warn
33− $(stack) $(test)
13+ stack test
34
14
35−## run tests with forced re-run via "-r"
36test-rerun: echo-warn
15test-rerun: echo-warn
37− $(stack) $(test) --test-arguments "-r"
16+ stack test --test-arguments "-r"
38
17
39−## run ghci with test stanza
40test-ghci:
18test-ghci:
41− $(stack) $(ghci) bloodhound:test:bloodhound-tests
19+ stack ghci bloodhound:test:bloodhound-tests
42
20
43−## run ghcid
44ghcid:
21ghcid:
45 ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"
22 ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"
46
23
47−## run ghcid with validate options (Werror, etc.)
48ghcid-validate:
24ghcid-validate:
49 ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-Werror -fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"
25 ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-Werror -fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"
50
26
51−## run weeder
52weeder:
27weeder:
53 weeder . --build
28 weeder . --build
54
29
55−## run hlint
30+# hlint --default > .hlint.yaml
56hlint:
31hlint:
57 hlint .
32 hlint .
58
33
59−## hlint watch with `sos`
60hlint-watch:
34hlint-watch:
61 sos src/ -c "hlint ." -p "src/(.*)\.hs"
35 sos src/ -c "hlint ." -p "src/(.*)\.hs"
62
36
63−# mod-build:
37+mod-build:
64−# stack build --ghc-options '+RTS -A128M -RTS'
38+ stack build --ghc-options '+RTS -A128M -RTS'
65
39
66echo-warn:
40echo-warn:
67 @echo "Make certain you have an elasticsearch instance on localhost:9200 !"
41 @echo "Make certain you have an elasticsearch instance on localhost:9200 !"
68
42
69−## Test with GHC 8.0 and ES 5.x
43+7.8-build:
44+ STACK_YAML="stack-7.8.yaml" stack build
45+
70−test-8.0:
46+7.8-test: echo-warn
71− STACK_YAML="stack-8.0.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500"
47+ STACK_YAML="stack-7.8.yaml" stack test
48+
49+7.10-build:
50+ STACK_YAML="stack-7.10.yaml" stack build
51+
52+7.10-test: echo-warn
53+ STACK_YAML="stack-7.10.yaml" stack test
72
54
73−## Test with GHC 8.2 and ES 5.x
74−test-8.2:
55+7.10-test-ES1:
75− STACK_YAML="stack.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500"
56+ STACK_YAML="stack-7.10.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES1
76
57
77−## Build with the GHC 8.0 Stack YAML
58+7.10-test-ES5:
78−build-8.0:
59+ STACK_YAML="stack-7.10.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES5
79− $(stack-8.0) $(build)
80
60
81−## Build with the GHC 8.2 Stack YAML
61+8.0-test-ES1:
82−build-8.2:
62+ STACK_YAML="stack-8.0.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES1
83− $(stack-8.2) $(build)
84
63
85−## Build with the GHC 8.4 Stack YAML
64+8.0-test-ES5:
86−build-8.4:
65+ STACK_YAML="stack-8.0.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES5
87− $(stack-8.4) $(build)
88
66
89−## Build with the GHC 8.6 Stack YAML
67+8.2-test-ES1:
68+ STACK_YAML="stack.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES1
69+
70+8.2-test-ES5:
71+ STACK_YAML="stack.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES5
72+
90−build-8.6:
73+8.0-build:
74+ STACK_YAML="stack-8.0.yaml" stack build
75+
76+8.2-build:
91− $(stack-8.6) $(build)
77+ STACK_YAML="stack-8.2.yaml" stack build
78+
79+module-touch:
80+ touch src/Database/V1/Bloodhound/Types.hs
81+ touch src/Database/V5/Bloodhound/Types.hs
92
82
93−## Upload the package to Hackage
94upload:
83upload:
95 stack upload --no-signature .
84 stack upload --no-signature .
96−
97−# Create ES5 instance
98−
99−## Run test environment
100−compose-ES5:
101− @LOCAL_USER_ID=${LOCAL_USER_ID} docker-compose -f docker-compose.yml --project-directory $(elasticsearch_directory) up
102−
103−## Run test environment in detach mode
104−compose-ES5-detach-up:
105− @LOCAL_USER_ID=${LOCAL_USER_ID} docker-compose -f docker-compose.yml --project-directory $(elasticsearch_directory) up -d
106−
107−## Close test environment if run on detach mode
108−compose-ES5-detach-down:
109− @LOCAL_USER_ID=${LOCAL_USER_ID} docker-compose -f docker-compose.yml --project-directory $(elasticsearch_directory) down
110−
111−## build the docker compose images
112−compose-build:
113− @LOCAL_USER_ID=${LOCAL_USER_ID} docker-compose -f docker-compose.yml --project-directory $(elasticsearch_directory) build
114−
115−## Spawn bash shell in ES5 test container
116−ES5-shell:
117− @LOCAL_USER_ID=${LOCAL_USER_ID} docker-compose -f docker-compose.yml --project-directory $(elasticsearch_directory) exec elasticsearch1 bash
118−
119−help:
120− @echo "Please use \`make <target>' where <target> is one of\n\n"
121− @awk '/^[a-zA-Z\-\_0-9]+:/ { \
122− helpMessage = match(lastLine, /^## (.*)/); \
123− if (helpMessage) { \
124− helpCommand = substr($$1, 0, index($$1, ":")); \
125− helpMessage = substr(lastLine, RSTART + 3, RLENGTH); \
126− printf "%-30s %s\n", helpCommand, helpMessage; \
127− } \
128− } \
129− { lastLine = $$0 }' $(MAKEFILE_LIST)
bloodhound.cabalnew file+138
@@ -0,0 +1,138 @@
1+name: bloodhound
2+version: 0.16.0.0
3+synopsis: Elasticsearch client library for Haskell
4+description: Elasticsearch made awesome for Haskell hackers
5+homepage: https://github.com/bitemyapp/bloodhound
6+license: BSD3
7+license-file: LICENSE
8+author: Chris Allen
9+maintainer: cma@bitemyapp.com
10+copyright: 2018 Chris Allen
11+category: Database, Search
12+build-type: Simple
13+cabal-version: >=1.10
14+
15+extra-source-files:
16+ README.md
17+ changelog.md
18+ -- We do this to avoid package check errors when uploading to hackage
19+ tests/V1/tests.hs
20+ tests/V5/tests.hs
21+
22+source-repository head
23+ type: git
24+ location: https://github.com/bitemyapp/bloodhound.git
25+
26+Flag ES1
27+ Description: Run the test suite against an Elasticsearch 1.x server
28+ Default: False
29+
30+Flag ES5
31+ Description: Run the test suite against an Elasticsearch 5.x server
32+ Default: True
33+
34+library
35+ ghc-options: -Wall
36+ exposed-modules: Database.V5.Bloodhound
37+ Database.V5.Bloodhound.Client
38+ Database.V5.Bloodhound.Types
39+ Database.V5.Bloodhound.Types.Class
40+ Database.V5.Bloodhound.Internal.Aggregation
41+ Database.V5.Bloodhound.Internal.Analysis
42+ Database.V5.Bloodhound.Internal.Client
43+ Database.V5.Bloodhound.Internal.Highlight
44+ Database.V5.Bloodhound.Internal.Newtypes
45+ Database.V5.Bloodhound.Internal.Query
46+ Database.V5.Bloodhound.Internal.Sort
47+ Database.V5.Bloodhound.Internal.StringlyTyped
48+ Database.V5.Bloodhound.Internal.Suggest
49+
50+ Database.V1.Bloodhound
51+ Database.V1.Bloodhound.Client
52+ Database.V1.Bloodhound.Types
53+ Database.V1.Bloodhound.Types.Class
54+ Database.V1.Bloodhound.Internal.Aggregation
55+ Database.V1.Bloodhound.Internal.Client
56+ Database.V1.Bloodhound.Internal.Highlight
57+ Database.V1.Bloodhound.Internal.Newtypes
58+ Database.V1.Bloodhound.Internal.Query
59+ Database.V1.Bloodhound.Internal.Sort
60+ Database.V1.Bloodhound.Internal.StringlyTyped
61+ Database.V1.Bloodhound.Internal.Suggest
62+
63+ other-modules: Bloodhound.Import
64+ Database.Bloodhound.Common.Script
65+ hs-source-dirs: src
66+ build-depends: base >= 4.3 && <5,
67+ aeson >= 0.11.1,
68+ blaze-builder,
69+ bytestring >= 0.10.0 && <0.11,
70+ containers >= 0.5.0.0 && <0.6,
71+ exceptions,
72+ hashable,
73+ http-client >= 0.4.30 && <0.6,
74+ http-types >= 0.8 && <0.13,
75+ mtl >= 1.0 && <2.3,
76+ network-uri >= 2.6 && <2.7,
77+ scientific >= 0.3.0.0 && <0.4.0.0,
78+ semigroups >= 0.15 && <0.19,
79+ semver,
80+ text >= 0.11 && <1.3,
81+ time >= 1.4 && <1.9,
82+ transformers >= 0.2 && <0.6,
83+ unordered-containers,
84+ vector >= 0.10.9 && <0.13
85+ default-language: Haskell2010
86+
87+test-suite bloodhound-tests
88+ ghc-options: -Wall -fno-warn-orphans
89+ type: exitcode-stdio-1.0
90+ main-is: tests.hs
91+ if flag(ES1)
92+ hs-source-dirs: tests/V1
93+ else
94+ hs-source-dirs: tests/V5
95+ other-modules: Test.Script
96+ other-modules: Test.Aggregation
97+ Test.ApproxEq
98+ Test.BulkAPI
99+ Test.Common
100+ Test.Documents
101+ Test.Generators
102+ Test.Highlights
103+ Test.Import
104+ Test.Indices
105+ Test.JSON
106+ Test.Query
107+ Test.Snapshots
108+ Test.Sorting
109+ Test.SourceFiltering
110+ Test.Suggest
111+ Test.Templates
112+ build-depends: base,
113+ QuickCheck,
114+ aeson,
115+ bloodhound,
116+ bytestring,
117+ containers,
118+ errors,
119+ exceptions,
120+ hspec >= 1.8,
121+ http-client,
122+ http-types,
123+ microlens,
124+ microlens-aeson,
125+ mtl,
126+ network-uri,
127+ pretty-simple,
128+ quickcheck-arbitrary-template,
129+ quickcheck-properties,
130+ semigroups,
131+ semver,
132+ temporary,
133+ text,
134+ time,
135+ unix-compat,
136+ unordered-containers >= 0.2.5.0 && <0.3,
137+ vector
138+ default-language: Haskell2010
changelog.md−17
@@ -1,21 +1,8 @@
1−0.17.0.0
2−========
3−- @bitemyapp
4− - Removed V1 modules and support.
5− - Removed the cabal file, replaced with an Hpack `package.yaml`.
6−- @JoseD92
7− - Removed the disused `Seminearring` class.
8− - Added Docker Compose support.
9−
100.16.0.0
10.16.0.0
11========
2========
12- @bitemyapp
3- @bitemyapp
13 - Reorganized V5 modules internally, ripped out Generic,
4 - Reorganized V5 modules internally, ripped out Generic,
14 rewrote part of the test suite.
5 rewrote part of the test suite.
15− - Added message field to EsProtocolException
16− - Switch from Data.Version to Data.SemVer to support parsing broader version format.
17− - Drop support for GHC < 8.0
18− - Remove upper bound on aeson.
19- @mxavier
6- @mxavier
20 - Reorganized V1 modules, mirroring the work done on V5.
7 - Reorganized V1 modules, mirroring the work done on V5.
21- @andrewthad
8- @andrewthad
@@ -31,13 +18,9 @@
31 - Add the "stemmer" and "stop" [token filters][] to `TokenFilterDefinition`.
18 - Add the "stemmer" and "stop" [token filters][] to `TokenFilterDefinition`.
32- @ahodgen
19- @ahodgen
33 - Add support for wildcard queries
20 - Add support for wildcard queries
34−- @ashutoshrishi
35− - Added [fuzziness][] option to a Match Query
36− - Added support for "AUTO" Fuzziness alongside a numeric value.
37
21
38[Character Filters]: https://www.elastic.co/guide/en/elasticsearch/reference/5.6/analysis-charfilters.html
22[Character Filters]: https://www.elastic.co/guide/en/elasticsearch/reference/5.6/analysis-charfilters.html
39[Token Filters]: https://www.elastic.co/guide/en/elasticsearch/reference/5.6/analysis-tokenfilters.html
23[Token Filters]: https://www.elastic.co/guide/en/elasticsearch/reference/5.6/analysis-tokenfilters.html
40−[Fuzziness]: https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#fuzziness
41
24
420.15.0.2
250.15.0.2
43========
26========
docker-compose.ymldeleted−35
@@ -1,35 +0,0 @@
1−version: "2"
2−services:
3− elasticsearch1:
4− build: .
5− container_name: elasticsearch1
6− environment:
7− - cluster.name=docker-cluster
8− - bootstrap.memory_lock=true
9− - "ES_JAVA_OPTS=-Xms512m -Xmx512m"
10− ulimits:
11− memlock:
12− soft: -1
13− hard: -1
14− mem_limit: 1g
15− ports:
16− - 9200:9200
17− networks:
18− - esnet
19− elasticsearch2:
20− build: .
21− environment:
22− - cluster.name=docker-cluster
23− - bootstrap.memory_lock=true
24− - "ES_JAVA_OPTS=-Xms512m -Xmx512m"
25− - "discovery.zen.ping.unicast.hosts=elasticsearch1"
26− ulimits:
27− memlock:
28− soft: -1
29− hard: -1
30− mem_limit: 1g
31− networks:
32− - esnet
33−
34−networks:
35− esnet: {}
elasticsearch/Dockerfiledeleted−3
@@ -1,3 +0,0 @@
1−FROM docker.elastic.co/elasticsearch/elasticsearch:5.6.0
2−
3−COPY config /usr/share/elasticsearch/config/
elasticsearch/config/elasticsearch.ymldeleted−3
@@ -1,3 +0,0 @@
1−xpack.security.enabled: false
2−cluster.name: "docker-cluster"
3−network.host: 0.0.0.0
examples/Tweet.hs+2−2
@@ -14,7 +14,7 @@ import Data.Text (Text)
14import Data.Time.Calendar (Day (..))
14import Data.Time.Calendar (Day (..))
15import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
15import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
16import qualified Data.Vector as V
16import qualified Data.Vector as V
17−import Database.Bloodhound
17+import Database.V5.Bloodhound
18import GHC.Generics (Generic)
18import GHC.Generics (Generic)
19import Network.HTTP.Client (defaultManagerSettings)
19import Network.HTTP.Client (defaultManagerSettings)
20
20
@@ -83,7 +83,7 @@ main = runBH' $ do
83 True <- indexExists aliasName
83 True <- indexExists aliasName
84
84
85 -- create a template so that if we just write into an index named tweet-2017-01-02, for instance, the index will be automatically created with the given mapping. This is a great idea for any ongoing indices because it makes them much easier to manage and rotate.
85 -- create a template so that if we just write into an index named tweet-2017-01-02, for instance, the index will be automatically created with the given mapping. This is a great idea for any ongoing indices because it makes them much easier to manage and rotate.
86− let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [object ["tweet" .= toJSON TweetMapping]]
86+ let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
87 let templateName = TemplateName "tweet-tpl"
87 let templateName = TemplateName "tweet-tpl"
88 _ <- putTemplate idxTpl templateName
88 _ <- putTemplate idxTpl templateName
89 True <- templateExists templateName
89 True <- templateExists templateName
package.yamldeleted−74
@@ -1,74 +0,0 @@
1−name: bloodhound
2−version: '0.17.0.0'
3−synopsis: Elasticsearch client library for Haskell
4−description: Elasticsearch made awesome for Haskell hackers
5−category: Database, Search
6−author: Chris Allen
7−maintainer: cma@bitemyapp.com
8−copyright: 2018 Chris Allen
9−license: BSD3
10−github: bitemyapp/bloodhound.git
11−
12−extra-source-files:
13− - README.md
14− - changelog.md
15− - tests/tests.hs
16−
17−dependencies:
18− - aeson >=0.11.1
19− - base >=4.3 && <5
20− - blaze-builder
21− - bytestring >=0.10.0
22− - containers >=0.5.0.0
23− - exceptions
24− - hashable
25− - http-client >=0.4.30
26− - http-types >=0.8
27− - mtl >=1.0
28− - network-uri >=2.6
29− - scientific >=0.3.0.0
30− - semigroups >=0.15
31− - semver
32− - text >=0.11
33− - time >=1.4
34− - transformers >=0.2
35− - unordered-containers
36− - vector >=0.10.9
37−
38−library:
39− source-dirs: src
40− ghc-options: -Wall
41− exposed-modules:
42− - Database.Bloodhound
43− - Database.Bloodhound.Client
44− - Database.Bloodhound.Types
45− - Database.Bloodhound.Internal.Aggregation
46− - Database.Bloodhound.Internal.Analysis
47− - Database.Bloodhound.Internal.Client
48− - Database.Bloodhound.Internal.Highlight
49− - Database.Bloodhound.Internal.Newtypes
50− - Database.Bloodhound.Internal.Query
51− - Database.Bloodhound.Internal.Sort
52− - Database.Bloodhound.Internal.StringlyTyped
53− - Database.Bloodhound.Internal.Suggest
54−
55−tests:
56− bloodhound-tests:
57− source-dirs: tests
58− main: tests.hs
59− ghc-options:
60− - -Wall
61− - -fno-warn-orphans
62− dependencies:
63− - QuickCheck
64− - base
65− - bloodhound
66− - errors
67− - hspec >=1.8
68− - microlens
69− - microlens-aeson
70− - pretty-simple
71− - quickcheck-arbitrary-template
72− - quickcheck-properties
73− - temporary
74− - unix-compat
src/Database/Bloodhound.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Database.Bloodhound
2− ( -- module Data.Aeson.Types
3− -- ,
4− module Database.Bloodhound.Client
5− , module Database.Bloodhound.Types
6− ) where
7−
8−-- import Data.Aeson.Types
9−import Database.Bloodhound.Client
10−import Database.Bloodhound.Types
src/Database/Bloodhound/Common/Script.hs+1−1
@@ -7,7 +7,7 @@ import Bloodhound.Import
7
7
8import qualified Data.HashMap.Strict as HM
8import qualified Data.HashMap.Strict as HM
9
9
10−import Database.Bloodhound.Internal.Newtypes
10+import Database.V5.Bloodhound.Internal.Newtypes
11
11
12newtype ScriptFields =
12newtype ScriptFields =
13 ScriptFields (HM.HashMap ScriptFieldName ScriptFieldValue)
13 ScriptFields (HM.HashMap ScriptFieldName ScriptFieldValue)
src/Database/V1/Bloodhound.hsnew file+10
@@ -0,0 +1,10 @@
1+module Database.V1.Bloodhound
2+ ( -- module Data.Aeson.Types
3+ -- ,
4+ module Database.V1.Bloodhound.Client
5+ , module Database.V1.Bloodhound.Types
6+ ) where
7+
8+-- import Data.Aeson.Types
9+import Database.V1.Bloodhound.Client
10+import Database.V1.Bloodhound.Types
src/Database/V1/Bloodhound/Client.hsnew file+927
@@ -0,0 +1,927 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE TupleSections #-}
4+
5+-------------------------------------------------------------------------------
6+-- |
7+-- Module : Database.Bloodhound.Client
8+-- Copyright : (C) 2014 Chris Allen
9+-- License : BSD-style (see the file LICENSE)
10+-- Maintainer : Chris Allen <cma@bitemyapp.com
11+-- Stability : provisional
12+-- Portability : OverloadedStrings
13+--
14+-- Client side functions for talking to Elasticsearch servers.
15+--
16+-------------------------------------------------------------------------------
17+
18+module Database.V1.Bloodhound.Client
19+ ( -- * Bloodhound client functions
20+ -- | The examples in this module assume the following code has been run.
21+ -- The :{ and :} will only work in GHCi. You'll only need the data types
22+ -- and typeclass instances for the functions that make use of them.
23+
24+ -- $setup
25+ withBH
26+ -- ** Indices
27+ , createIndex
28+ , deleteIndex
29+ , updateIndexSettings
30+ , getIndexSettings
31+ , optimizeIndex
32+ , indexExists
33+ , openIndex
34+ , closeIndex
35+ , listIndices
36+ , waitForYellowIndex
37+ -- *** Index Aliases
38+ , updateIndexAliases
39+ , getIndexAliases
40+ -- *** Index Templates
41+ , putTemplate
42+ , templateExists
43+ , deleteTemplate
44+ -- ** Mapping
45+ , putMapping
46+ , deleteMapping
47+ -- ** Documents
48+ , indexDocument
49+ , updateDocument
50+ , getDocument
51+ , documentExists
52+ , deleteDocument
53+ -- ** Searching
54+ , searchAll
55+ , searchByIndex
56+ , searchByType
57+ , scanSearch
58+ , getInitialScroll
59+ , advanceScroll
60+ , refreshIndex
61+ , mkSearch
62+ , mkAggregateSearch
63+ , mkHighlightSearch
64+ , bulk
65+ , pageSearch
66+ , mkShardCount
67+ , mkReplicaCount
68+ , getStatus
69+ -- ** Snapshot/Restore
70+ -- *** Snapshot Repos
71+ , getSnapshotRepos
72+ , updateSnapshotRepo
73+ , verifySnapshotRepo
74+ , deleteSnapshotRepo
75+ -- *** Snapshots
76+ , createSnapshot
77+ , getSnapshots
78+ , deleteSnapshot
79+ -- *** Restoring Snapshots
80+ , restoreSnapshot
81+ -- ** Nodes
82+ , getNodesInfo
83+ , getNodesStats
84+ -- ** Request Utilities
85+ , encodeBulkOperations
86+ , encodeBulkOperation
87+ -- * Authentication
88+ , basicAuthHook
89+ -- * Reply-handling tools
90+ , isVersionConflict
91+ , isSuccess
92+ , isCreated
93+ , parseEsResponse
94+ )
95+ where
96+
97+import qualified Blaze.ByteString.Builder as BB
98+import Control.Applicative as A
99+import Control.Monad
100+import Control.Monad.Catch
101+import Control.Monad.IO.Class
102+import Data.Aeson
103+import Data.ByteString.Lazy.Builder
104+import qualified Data.ByteString.Lazy.Char8 as L
105+import Data.Foldable (toList)
106+import qualified Data.HashMap.Strict as HM
107+import Data.Ix
108+import qualified Data.List as LS (filter, foldl')
109+import Data.List.NonEmpty (NonEmpty (..))
110+import Data.Maybe (catMaybes, fromMaybe, isJust)
111+import Data.Monoid
112+import Data.Text (Text)
113+import qualified Data.Text as T
114+import qualified Data.Text.Encoding as T
115+import Data.Time.Clock
116+import qualified Data.Vector as V
117+import Network.HTTP.Client
118+import qualified Network.HTTP.Types.Method as NHTM
119+import qualified Network.HTTP.Types.Status as NHTS
120+import qualified Network.HTTP.Types.URI as NHTU
121+import qualified Network.URI as URI
122+import Prelude hiding (filter, head)
123+
124+import Database.V1.Bloodhound.Types
125+
126+-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'
127+-- which rejects 'Int' values below 1 and above 1000.
128+mkShardCount :: Int -> Maybe ShardCount
129+mkShardCount n
130+ | n < 1 = Nothing
131+ | n > 1000 = Nothing
132+ | otherwise = Just (ShardCount n)
133+
134+-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'
135+-- which rejects 'Int' values below 0 and above 1000.
136+mkReplicaCount :: Int -> Maybe ReplicaCount
137+mkReplicaCount n
138+ | n < 0 = Nothing
139+ | n > 1000 = Nothing -- ...
140+ | otherwise = Just (ReplicaCount n)
141+
142+emptyBody :: L.ByteString
143+emptyBody = L.pack ""
144+
145+dispatch :: MonadBH m
146+ => Method
147+ -> Text
148+ -> Maybe L.ByteString
149+ -> m Reply
150+dispatch dMethod url body = do
151+ initReq <- liftIO $ parseUrl' url
152+ reqHook <- bhRequestHook A.<$> getBHEnv
153+ let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
154+ req <- liftIO
155+ $ reqHook
156+ $ setRequestIgnoreStatus
157+ $ initReq { method = dMethod
158+ , requestBody = reqBody }
159+ mgr <- bhManager <$> getBHEnv
160+ liftIO $ httpLbs req mgr
161+
162+joinPath' :: [Text] -> Text
163+joinPath' = T.intercalate "/"
164+
165+joinPath :: MonadBH m => [Text] -> m Text
166+joinPath ps = do
167+ Server s <- bhServer <$> getBHEnv
168+ return $ joinPath' (s:ps)
169+
170+appendSearchTypeParam :: Text -> SearchType -> Text
171+appendSearchTypeParam originalUrl st = addQuery params originalUrl
172+ where stText = "search_type"
173+ params
174+ | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")]
175+ | st == SearchTypeCount = [(stText, Just "count")]
176+ | st == SearchTypeScan = [(stText, Just "scan"), ("scroll", Just "1m")]
177+ | st == SearchTypeQueryAndFetch = [(stText, Just "query_and_fetch")]
178+ | st == SearchTypeDfsQueryAndFetch = [(stText, Just "dfs_query_and_fetch")]
179+ -- used to catch 'SearchTypeQueryThenFetch', which is also the default
180+ | otherwise = [(stText, Just "query_then_fetch")]
181+
182+-- | Severely dumbed down query renderer. Assumes your data doesn't
183+-- need any encoding
184+addQuery :: [(Text, Maybe Text)] -> Text -> Text
185+addQuery q u = u <> rendered
186+ where
187+ rendered =
188+ T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q
189+ prependQuestionMark = True
190+
191+bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
192+bindM2 f ma mb = join (f <$> ma <*> mb)
193+
194+-- | Convenience function that sets up a manager and BHEnv and runs
195+-- the given set of bloodhound operations. Connections will be
196+-- pipelined automatically in accordance with the given manager
197+-- settings in IO. If you've got your own monad transformer stack, you
198+-- should use 'runBH' directly.
199+withBH :: ManagerSettings -> Server -> BH IO a -> IO a
200+withBH ms s f = do
201+ mgr <- newManager ms
202+ let env = mkBHEnv s mgr
203+ runBH env f
204+
205+-- Shortcut functions for HTTP methods
206+delete :: MonadBH m => Text -> m Reply
207+delete = flip (dispatch NHTM.methodDelete) Nothing
208+get :: MonadBH m => Text -> m Reply
209+get = flip (dispatch NHTM.methodGet) Nothing
210+head :: MonadBH m => Text -> m Reply
211+head = flip (dispatch NHTM.methodHead) Nothing
212+put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
213+put = dispatch NHTM.methodPut
214+post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
215+post = dispatch NHTM.methodPost
216+
217+-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
218+-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
219+-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
220+
221+-- | 'getStatus' fetches the 'Status' of a 'Server'
222+getStatus :: MonadBH m => m (Maybe Status)
223+getStatus = do
224+ response <- get =<< url
225+ return $ decode (responseBody response)
226+ where
227+ url = joinPath []
228+
229+-- | 'getSnapshotRepos' gets the definitions of a subset of the
230+-- defined snapshot repos.
231+getSnapshotRepos
232+ :: ( MonadBH m
233+ , MonadThrow m
234+ )
235+ => SnapshotRepoSelection
236+ -> m (Either EsError [GenericSnapshotRepo])
237+getSnapshotRepos sel = fmap (fmap unGSRs) . parseEsResponse =<< get =<< url
238+ where
239+ url = joinPath ["_snapshot", selectorSeg]
240+ selectorSeg = case sel of
241+ AllSnapshotRepos -> "_all"
242+ SnapshotRepoList (p :| ps) -> T.intercalate "," (renderPat <$> (p:ps))
243+ renderPat (RepoPattern t) = t
244+ renderPat (ExactRepo (SnapshotRepoName t)) = t
245+
246+
247+-- | Wrapper to extract the list of 'GenericSnapshotRepo' in the
248+-- format they're returned in
249+newtype GSRs = GSRs { unGSRs :: [GenericSnapshotRepo] }
250+
251+
252+instance FromJSON GSRs where
253+ parseJSON = withObject "Collection of GenericSnapshotRepo" parse
254+ where
255+ parse = fmap GSRs . mapM (uncurry go) . HM.toList
256+ go rawName = withObject "GenericSnapshotRepo" $ \o ->
257+ GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type"
258+ <*> o .: "settings"
259+
260+
261+-- | Create or update a snapshot repo
262+updateSnapshotRepo
263+ :: ( MonadBH m
264+ , SnapshotRepo repo
265+ )
266+ => SnapshotRepoUpdateSettings
267+ -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure
268+ -> repo
269+ -> m Reply
270+updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo =
271+ bindM2 put url (return (Just body))
272+ where
273+ url = addQuery params <$> joinPath ["_snapshot", snapshotRepoName gSnapshotRepoName]
274+ params
275+ | repoUpdateVerify = []
276+ | otherwise = [("verify", Just "false")]
277+ body = encode $ object [ "type" .= gSnapshotRepoType
278+ , "settings" .= gSnapshotRepoSettings
279+ ]
280+ GenericSnapshotRepo {..} = toGSnapshotRepo repo
281+
282+
283+
284+-- | Verify if a snapshot repo is working. __NOTE:__ this API did not
285+-- make it into Elasticsearch until 1.4. If you use an older version,
286+-- you will get an error here.
287+verifySnapshotRepo
288+ :: ( MonadBH m
289+ , MonadThrow m
290+ )
291+ => SnapshotRepoName
292+ -> m (Either EsError SnapshotVerification)
293+verifySnapshotRepo (SnapshotRepoName n) =
294+ parseEsResponse =<< bindM2 post url (return Nothing)
295+ where
296+ url = joinPath ["_snapshot", n, "_verify"]
297+
298+
299+deleteSnapshotRepo :: MonadBH m => SnapshotRepoName -> m Reply
300+deleteSnapshotRepo (SnapshotRepoName n) = delete =<< url
301+ where
302+ url = joinPath ["_snapshot", n]
303+
304+
305+-- | Create and start a snapshot
306+createSnapshot
307+ :: (MonadBH m)
308+ => SnapshotRepoName
309+ -> SnapshotName
310+ -> SnapshotCreateSettings
311+ -> m Reply
312+createSnapshot (SnapshotRepoName repoName)
313+ (SnapshotName snapName)
314+ SnapshotCreateSettings {..} =
315+ bindM2 put url (return (Just body))
316+ where
317+ url = addQuery params <$> joinPath ["_snapshot", repoName, snapName]
318+ params = [("wait_for_completion", Just (boolQP snapWaitForCompletion))]
319+ body = encode $ object prs
320+ prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapIndices
321+ , Just ("ignore_unavailable" .= snapIgnoreUnavailable)
322+ , Just ("ignore_global_state" .= snapIncludeGlobalState)
323+ , Just ("partial" .= snapPartial)
324+ ]
325+
326+
327+indexSelectionName :: IndexSelection -> Text
328+indexSelectionName AllIndexes = "_all"
329+indexSelectionName (IndexList (i :| is)) = T.intercalate "," (renderIndex <$> (i:is))
330+ where
331+ renderIndex (IndexName n) = n
332+
333+
334+-- | Get info about known snapshots given a pattern and repo name.
335+getSnapshots
336+ :: ( MonadBH m
337+ , MonadThrow m
338+ )
339+ => SnapshotRepoName
340+ -> SnapshotSelection
341+ -> m (Either EsError [SnapshotInfo])
342+getSnapshots (SnapshotRepoName repoName) sel =
343+ fmap (fmap unSIs) . parseEsResponse =<< get =<< url
344+ where
345+ url = joinPath ["_snapshot", repoName, snapPath]
346+ snapPath = case sel of
347+ AllSnapshots -> "_all"
348+ SnapshotList (s :| ss) -> T.intercalate "," (renderPath <$> (s:ss))
349+ renderPath (SnapPattern t) = t
350+ renderPath (ExactSnap (SnapshotName t)) = t
351+
352+
353+newtype SIs = SIs { unSIs :: [SnapshotInfo] }
354+
355+
356+instance FromJSON SIs where
357+ parseJSON = withObject "Collection of SnapshotInfo" parse
358+ where
359+ parse o = SIs <$> o .: "snapshots"
360+
361+
362+-- | Delete a snapshot. Cancels if it is running.
363+deleteSnapshot :: MonadBH m => SnapshotRepoName -> SnapshotName -> m Reply
364+deleteSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) =
365+ delete =<< url
366+ where
367+ url = joinPath ["_snapshot", repoName, snapName]
368+
369+
370+-- | Restore a snapshot to the cluster See
371+-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/modules-snapshots.html#_restore>
372+-- for more details.
373+restoreSnapshot
374+ :: MonadBH m
375+ => SnapshotRepoName
376+ -> SnapshotName
377+ -> SnapshotRestoreSettings
378+ -- ^ Start with 'defaultSnapshotRestoreSettings' and customize
379+ -- from there for reasonable defaults.
380+ -> m Reply
381+restoreSnapshot (SnapshotRepoName repoName)
382+ (SnapshotName snapName)
383+ SnapshotRestoreSettings {..} = bindM2 post url (return (Just body))
384+ where
385+ url = addQuery params <$> joinPath ["_snapshot", repoName, snapName, "_restore"]
386+ params = [("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion))]
387+ body = encode (object prs)
388+
389+
390+ prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapRestoreIndices
391+ , Just ("ignore_unavailable" .= snapRestoreIgnoreUnavailable)
392+ , Just ("include_global_state" .= snapRestoreIncludeGlobalState)
393+ , ("rename_pattern" .=) <$> snapRestoreRenamePattern
394+ , ("rename_replacement" .=) . renderTokens <$> snapRestoreRenameReplacement
395+ , Just ("include_aliases" .= snapRestoreIncludeAliases)
396+ , ("index_settings" .= ) <$> snapRestoreIndexSettingsOverrides
397+ , ("ignore_index_settings" .= ) <$> snapRestoreIgnoreIndexSettings
398+ ]
399+ renderTokens (t :| ts) = mconcat (renderToken <$> (t:ts))
400+ renderToken (RRTLit t) = t
401+ renderToken RRSubWholeMatch = "$0"
402+ renderToken (RRSubGroup g) = T.pack (show (rrGroupRefNum g))
403+
404+
405+getNodesInfo
406+ :: ( MonadBH m
407+ , MonadThrow m
408+ )
409+ => NodeSelection
410+ -> m (Either EsError NodesInfo)
411+getNodesInfo sel = parseEsResponse =<< get =<< url
412+ where
413+ url = joinPath ["_nodes", selectionSeg]
414+ selectionSeg = case sel of
415+ LocalNode -> "_local"
416+ NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l:ls))
417+ AllNodes -> "_all"
418+ selToSeg (NodeByName (NodeName n)) = n
419+ selToSeg (NodeByFullNodeId (FullNodeId i)) = i
420+ selToSeg (NodeByHost (Server s)) = s
421+ selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v
422+
423+getNodesStats
424+ :: ( MonadBH m
425+ , MonadThrow m
426+ )
427+ => NodeSelection
428+ -> m (Either EsError NodesStats)
429+getNodesStats sel = parseEsResponse =<< get =<< url
430+ where
431+ url = joinPath ["_nodes", selectionSeg, "stats"]
432+ selectionSeg = case sel of
433+ LocalNode -> "_local"
434+ NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l:ls))
435+ AllNodes -> "_all"
436+ selToSeg (NodeByName (NodeName n)) = n
437+ selToSeg (NodeByFullNodeId (FullNodeId i)) = i
438+ selToSeg (NodeByHost (Server s)) = s
439+ selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v
440+
441+-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
442+createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply
443+createIndex indexSettings (IndexName indexName) =
444+ bindM2 put url (return body)
445+ where url = joinPath [indexName]
446+ body = Just $ encode indexSettings
447+
448+
449+-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
450+deleteIndex :: MonadBH m => IndexName -> m Reply
451+deleteIndex (IndexName indexName) =
452+ delete =<< joinPath [indexName]
453+
454+-- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index
455+updateIndexSettings :: MonadBH m => NonEmpty UpdatableIndexSetting -> IndexName -> m Reply
456+updateIndexSettings updates (IndexName indexName) =
457+ bindM2 put url (return body)
458+ where
459+ url = joinPath [indexName, "_settings"]
460+ body = Just (encode jsonBody)
461+ jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])
462+
463+
464+getIndexSettings :: (MonadBH m, MonadThrow m) => IndexName
465+ -> m (Either EsError IndexSettingsSummary)
466+getIndexSettings (IndexName indexName) =
467+ parseEsResponse =<< get =<< url
468+ where
469+ url = joinPath [indexName, "_settings"]
470+
471+
472+-- | 'optimizeIndex' will optimize a single index, list of indexes or
473+-- all indexes. Note that this call will block until finishing but
474+-- will continue even if the request times out. Concurrent requests to
475+-- optimize an index while another is performing will block until the
476+-- previous one finishes. For more information see
477+-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-optimize.html>. Nothing
478+-- worthwhile comes back in the reply body, so matching on the status
479+-- should suffice.
480+--
481+-- 'optimizeIndex' with a maxNumSegments of 1 and onlyExpungeDeletes
482+-- to True is the main way to release disk space back to the OS being
483+-- held by deleted documents.
484+--
485+-- Note that this API was deprecated in Elasticsearch 2.1 for the
486+-- almost completely identical forcemerge API. Adding support to that
487+-- API would be trivial but due to the significant breaking changes,
488+-- this library cannot currently be used with >= 2.0, so that feature was omitted.
489+optimizeIndex :: MonadBH m => IndexSelection -> IndexOptimizationSettings -> m Reply
490+optimizeIndex ixs IndexOptimizationSettings {..} =
491+ bindM2 post url (return body)
492+ where url = addQuery params <$> joinPath [indexName, "_optimize"]
493+ params = catMaybes [ ("max_num_segments",) . Just . showText <$> maxNumSegments
494+ , Just ("only_expunge_deletes", Just (boolQP onlyExpungeDeletes))
495+ , Just ("flush", Just (boolQP flushAfterOptimize))
496+ ]
497+ indexName = indexSelectionName ixs
498+ body = Nothing
499+
500+
501+deepMerge :: [Object] -> Object
502+deepMerge = LS.foldl' go mempty
503+ where go acc = LS.foldl' go' acc . HM.toList
504+ go' acc (k, v) = HM.insertWith merge k v acc
505+ merge (Object a) (Object b) = Object (deepMerge [a, b])
506+ merge _ b = b
507+
508+
509+statusCodeIs :: (Int, Int) -> Reply -> Bool
510+statusCodeIs r resp = inRange r $ NHTS.statusCode (responseStatus resp)
511+
512+respIsTwoHunna :: Reply -> Bool
513+respIsTwoHunna = statusCodeIs (200, 299)
514+
515+existentialQuery :: MonadBH m => Text -> m (Reply, Bool)
516+existentialQuery url = do
517+ reply <- head url
518+ return (reply, respIsTwoHunna reply)
519+
520+
521+-- | Tries to parse a response body as the expected type @a@ and
522+-- failing that tries to parse it as an EsError. All well-formed, JSON
523+-- responses from elasticsearch should fall into these two
524+-- categories. If they don't, a 'EsProtocolException' will be
525+-- thrown. If you encounter this, please report the full body it
526+-- reports along with your Elasticsearch verison.
527+parseEsResponse :: (MonadThrow m, FromJSON a) => Reply
528+ -> m (Either EsError a)
529+parseEsResponse reply
530+ | respIsTwoHunna reply = case eitherDecode body of
531+ Right a -> return (Right a)
532+ Left _ -> tryParseError
533+ | otherwise = tryParseError
534+ where body = responseBody reply
535+ tryParseError = case eitherDecode body of
536+ Right e -> return (Left e)
537+ -- this case should not be possible
538+ Left _ -> explode
539+ explode = throwM (EsProtocolException body)
540+
541+-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
542+-- in IO
543+indexExists :: MonadBH m => IndexName -> m Bool
544+indexExists (IndexName indexName) = do
545+ (_, exists) <- existentialQuery =<< joinPath [indexName]
546+ return exists
547+
548+-- | 'refreshIndex' will force a refresh on an index. You must
549+-- do this if you want to read what you wrote.
550+refreshIndex :: MonadBH m => IndexName -> m Reply
551+refreshIndex (IndexName indexName) =
552+ bindM2 post url (return Nothing)
553+ where url = joinPath [indexName, "_refresh"]
554+
555+-- | Block until the index becomes available for indexing
556+-- documents. This is useful for integration tests in which
557+-- indices are rapidly created and deleted.
558+waitForYellowIndex :: MonadBH m => IndexName -> m Reply
559+waitForYellowIndex (IndexName indexName) = get =<< url
560+ where url = addQuery q <$> joinPath ["_cluster","health",indexName]
561+ q = [("wait_for_status",Just "yellow"),("timeout",Just "10s")]
562+
563+stringifyOCIndex :: OpenCloseIndex -> Text
564+stringifyOCIndex oci = case oci of
565+ OpenIndex -> "_open"
566+ CloseIndex -> "_close"
567+
568+openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply
569+openOrCloseIndexes oci (IndexName indexName) =
570+ bindM2 post url (return Nothing)
571+ where ociString = stringifyOCIndex oci
572+ url = joinPath [indexName, ociString]
573+
574+-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
575+-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
576+openIndex :: MonadBH m => IndexName -> m Reply
577+openIndex = openOrCloseIndexes OpenIndex
578+
579+-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
580+-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
581+closeIndex :: MonadBH m => IndexName -> m Reply
582+closeIndex = openOrCloseIndexes CloseIndex
583+
584+-- | 'listIndices' returns a list of all index names on a given 'Server'
585+listIndices :: (MonadThrow m, MonadBH m) => m [IndexName]
586+listIndices =
587+ parse . responseBody =<< get =<< url
588+ where
589+ url = joinPath ["_cat/indices?format=json"]
590+ parse body = maybe (throwM (EsProtocolException body)) return $ do
591+ vals <- decode body
592+ forM vals $ \val ->
593+ case val of
594+ Object obj -> do
595+ indexVal <- HM.lookup "index" obj
596+ case indexVal of
597+ String txt -> Just (IndexName txt)
598+ _ -> Nothing
599+ _ -> Nothing
600+
601+-- | 'updateIndexAliases' updates the server's index alias
602+-- table. Operations are atomic. Explained in further detail at
603+-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-aliases.html>
604+updateIndexAliases :: MonadBH m => NonEmpty IndexAliasAction -> m Reply
605+updateIndexAliases actions = bindM2 post url (return body)
606+ where url = joinPath ["_aliases"]
607+ body = Just (encode bodyJSON)
608+ bodyJSON = object [ "actions" .= toList actions]
609+
610+-- | Get all aliases configured on the server.
611+getIndexAliases :: (MonadBH m, MonadThrow m)
612+ => m (Either EsError IndexAliasesSummary)
613+getIndexAliases = parseEsResponse =<< get =<< url
614+ where url = joinPath ["_aliases"]
615+
616+-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.
617+-- Explained in further detail at
618+-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>
619+putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply
620+putTemplate indexTemplate (TemplateName templateName) =
621+ bindM2 put url (return body)
622+ where url = joinPath ["_template", templateName]
623+ body = Just $ encode indexTemplate
624+
625+-- | 'templateExists' checks to see if a template exists.
626+templateExists :: MonadBH m => TemplateName -> m Bool
627+templateExists (TemplateName templateName) = do
628+ (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
629+ return exists
630+
631+-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
632+deleteTemplate :: MonadBH m => TemplateName -> m Reply
633+deleteTemplate (TemplateName templateName) =
634+ delete =<< joinPath ["_template", templateName]
635+
636+-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
637+-- for documents in indexes.
638+putMapping :: (MonadBH m, ToJSON a) => IndexName
639+ -> MappingName -> a -> m Reply
640+putMapping (IndexName indexName) (MappingName mappingName) mapping =
641+ bindM2 put url (return body)
642+ where url = joinPath [indexName, "_mapping", mappingName]
643+ -- "_mapping" and mappingName above were originally transposed
644+ -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
645+ body = Just $ encode mapping
646+
647+-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
648+-- Mappings are schemas for documents in indexes.
649+deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
650+deleteMapping (IndexName indexName)
651+ (MappingName mappingName) =
652+ -- "_mapping" and mappingName below were originally transposed
653+ -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
654+ delete =<< joinPath [indexName, "_mapping", mappingName]
655+
656+versionCtlParams :: IndexDocumentSettings -> [(Text, Maybe Text)]
657+versionCtlParams cfg =
658+ case idsVersionControl cfg of
659+ NoVersionControl -> []
660+ InternalVersion v -> versionParams v "internal"
661+ ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"
662+ ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"
663+ ForceVersion (ExternalDocVersion v) -> versionParams v "force"
664+ where
665+ vt = showText . docVersionNumber
666+ versionParams v t = [ ("version", Just $ vt v)
667+ , ("version_type", Just t)
668+ ]
669+
670+-- | 'indexDocument' is the primary way to save a single document in
671+-- Elasticsearch. The document itself is simply something we can
672+-- convert into a JSON 'Value'. The 'DocId' will function as the
673+-- primary key for the document.
674+indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
675+ -> IndexDocumentSettings -> doc -> DocId -> m Reply
676+indexDocument (IndexName indexName)
677+ (MappingName mappingName) cfg document (DocId docId) =
678+ bindM2 put url (return body)
679+ where url = addQuery params <$> joinPath [indexName, mappingName, docId]
680+ parentParams = case idsParent cfg of
681+ Nothing -> []
682+ Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]
683+ params = versionCtlParams cfg ++ parentParams
684+ body = Just (encode document)
685+
686+-- | 'updateDocument' provides a way to perform an partial update of a
687+-- an already indexed document.
688+updateDocument :: (ToJSON patch, MonadBH m) => IndexName -> MappingName
689+ -> IndexDocumentSettings -> patch -> DocId -> m Reply
690+updateDocument (IndexName indexName)
691+ (MappingName mappingName) cfg patch (DocId docId) =
692+ bindM2 post url (return body)
693+ where url = addQuery (versionCtlParams cfg) <$>
694+ joinPath [indexName, mappingName, docId, "_update"]
695+ body = Just (encode $ object ["doc" .= toJSON patch])
696+
697+-- | 'deleteDocument' is the primary way to delete a single document.
698+deleteDocument :: MonadBH m => IndexName -> MappingName
699+ -> DocId -> m Reply
700+deleteDocument (IndexName indexName)
701+ (MappingName mappingName) (DocId docId) =
702+ delete =<< joinPath [indexName, mappingName, docId]
703+
704+-- | 'bulk' uses
705+-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>
706+-- to perform bulk operations. The 'BulkOperation' data type encodes the
707+-- index\/update\/delete\/create operations. You pass a 'V.Vector' of 'BulkOperation's
708+-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch
709+-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
710+bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
711+bulk bulkOps = bindM2 post url (return body)
712+ where url = joinPath ["_bulk"]
713+ body = Just $ encodeBulkOperations bulkOps
714+
715+-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
716+-- into an 'L.ByteString'
717+encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
718+encodeBulkOperations stream = collapsed where
719+ blobs = fmap encodeBulkOperation stream
720+ mashedTaters = mash (mempty :: Builder) blobs
721+ collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
722+
723+mash :: Builder -> V.Vector L.ByteString -> Builder
724+mash =
725+ V.foldl' (\b x -> b <> byteString "\n" <> lazyByteString x)
726+
727+mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
728+mkBulkStreamValue operation indexName mappingName docId =
729+ object [operation .=
730+ object [ "_index" .= indexName
731+ , "_type" .= mappingName
732+ , "_id" .= docId]]
733+
734+-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
735+-- into an 'L.ByteString'
736+encodeBulkOperation :: BulkOperation -> L.ByteString
737+encodeBulkOperation (BulkIndex (IndexName indexName)
738+ (MappingName mappingName)
739+ (DocId docId) value) = blob
740+ where metadata = mkBulkStreamValue "index" indexName mappingName docId
741+ blob = encode metadata `mappend` "\n" `mappend` encode value
742+
743+encodeBulkOperation (BulkCreate (IndexName indexName)
744+ (MappingName mappingName)
745+ (DocId docId) value) = blob
746+ where metadata = mkBulkStreamValue "create" indexName mappingName docId
747+ blob = encode metadata `mappend` "\n" `mappend` encode value
748+
749+encodeBulkOperation (BulkDelete (IndexName indexName)
750+ (MappingName mappingName)
751+ (DocId docId)) = blob
752+ where metadata = mkBulkStreamValue "delete" indexName mappingName docId
753+ blob = encode metadata
754+
755+encodeBulkOperation (BulkUpdate (IndexName indexName)
756+ (MappingName mappingName)
757+ (DocId docId) value) = blob
758+ where metadata = mkBulkStreamValue "update" indexName mappingName docId
759+ doc = object ["doc" .= value]
760+ blob = encode metadata `mappend` "\n" `mappend` encode doc
761+
762+-- | 'getDocument' is a straight-forward way to fetch a single document from
763+-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
764+-- The 'DocId' is the primary key for your Elasticsearch document.
765+getDocument :: MonadBH m => IndexName -> MappingName
766+ -> DocId -> m Reply
767+getDocument (IndexName indexName)
768+ (MappingName mappingName) (DocId docId) =
769+ get =<< joinPath [indexName, mappingName, docId]
770+
771+-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
772+-- in IO
773+documentExists :: MonadBH m => IndexName -> MappingName
774+ -> Maybe DocumentParent -> DocId -> m Bool
775+documentExists (IndexName indexName) (MappingName mappingName)
776+ parent (DocId docId) = do
777+ (_, exists) <- existentialQuery =<< url
778+ return exists
779+ where url = addQuery params <$> joinPath [indexName, mappingName, docId]
780+ parentParam = fmap (\(DocumentParent (DocId p)) -> p) parent
781+ params = LS.filter (\(_, v) -> isJust v) [("parent", parentParam)]
782+
783+dispatchSearch :: MonadBH m => Text -> Search -> m Reply
784+dispatchSearch url search = post url' (Just (encode search))
785+ where url' = appendSearchTypeParam url (searchType search)
786+
787+-- | 'searchAll', given a 'Search', will perform that search against all indexes
788+-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
789+searchAll :: MonadBH m => Search -> m Reply
790+searchAll = bindM2 dispatchSearch url . return
791+ where url = joinPath ["_search"]
792+
793+-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
794+-- against all mappings within an index on an Elasticsearch server.
795+searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
796+searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
797+ where url = joinPath [indexName, "_search"]
798+
799+-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
800+-- search against a specific mapping within an index on an Elasticsearch server.
801+searchByType :: MonadBH m => IndexName -> MappingName -> Search
802+ -> m Reply
803+searchByType (IndexName indexName)
804+ (MappingName mappingName) = bindM2 dispatchSearch url . return
805+ where url = joinPath [indexName, mappingName, "_search"]
806+
807+-- | For a given search, request a scroll for efficient streaming of
808+-- search results. Note that the search is put into 'SearchTypeScan'
809+-- mode and thus results will not be sorted. Combine this with
810+-- 'advanceScroll' to efficiently stream through the full result set
811+getInitialScroll :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId)
812+getInitialScroll (IndexName indexName) (MappingName mappingName) search = do
813+ let url = joinPath [indexName, mappingName, "_search"]
814+ search' = search { searchType = SearchTypeScan }
815+ resp' <- bindM2 dispatchSearch url (return search')
816+ let msr = decode' $ responseBody resp' :: Maybe (SearchResult ())
817+ msid = maybe Nothing scrollId msr
818+ return msid
819+
820+scroll' :: (FromJSON a, MonadBH m, MonadThrow m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId)
821+scroll' Nothing = return ([], Nothing)
822+scroll' (Just sid) = do
823+ res <- advanceScroll sid 60
824+ case res of
825+ Right SearchResult {..} -> return (hits searchHits, scrollId)
826+ Left _ -> return ([], Nothing)
827+
828+-- | Use the given scroll to fetch the next page of documents. If there are no
829+-- further pages, 'SearchResult.searchHits.hits' will be '[]'.
830+advanceScroll
831+ :: ( FromJSON a
832+ , MonadBH m
833+ , MonadThrow m
834+ )
835+ => ScrollId
836+ -> NominalDiffTime
837+ -- ^ How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default.
838+ -> m (Either EsError (SearchResult a))
839+advanceScroll (ScrollId sid) scroll = do
840+ url <- joinPath ["_search/scroll?scroll=" <> scrollTime]
841+ parseEsResponse =<< post url (Just . L.fromStrict $ T.encodeUtf8 sid)
842+ where scrollTime = showText secs <> "s"
843+ secs :: Integer
844+ secs = round scroll
845+
846+simpleAccumulator :: (FromJSON a, MonadBH m, MonadThrow m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId)
847+simpleAccumulator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)
848+simpleAccumulator oldHits ([], _) = return (oldHits, Nothing)
849+simpleAccumulator oldHits (newHits, msid) = do
850+ (newHits', msid') <- scroll' msid
851+ simpleAccumulator (oldHits ++ newHits) (newHits', msid')
852+
853+-- | 'scanSearch' uses the 'scan&scroll' API of elastic,
854+-- for a given 'IndexName' and 'MappingName'. Note that this will
855+-- consume the entire search result set and will be doing O(n) list
856+-- appends so this may not be suitable for large result sets. In that
857+-- case, 'getInitialScroll' and 'advanceScroll' are good low level
858+-- tools. You should be able to hook them up trivially to conduit,
859+-- pipes, or your favorite streaming IO abstraction of choice. Note
860+-- that ordering on the search would destroy performance and thus is
861+-- ignored.
862+scanSearch :: (FromJSON a, MonadBH m, MonadThrow m) => IndexName -> MappingName -> Search -> m [Hit a]
863+scanSearch indexName mappingName search = do
864+ msid <- getInitialScroll indexName mappingName search
865+ (hits, msid') <- scroll' msid
866+ (totalHits, _) <- simpleAccumulator [] (hits, msid')
867+ return totalHits
868+
869+-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
870+-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
871+-- syntax if you want to add things like aggregations or highlights while still using
872+-- this helper function.
873+mkSearch :: Maybe Query -> Maybe Filter -> Search
874+mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
875+
876+-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
877+-- the 'Query' and the 'Aggregation'.
878+mkAggregateSearch :: Maybe Query -> Aggregations -> Search
879+mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing Nothing
880+
881+-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
882+-- the 'Query' and the 'Aggregation'.
883+mkHighlightSearch :: Maybe Query -> Highlights -> Search
884+mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
885+
886+-- | 'pageSearch' is a helper function that takes a search and assigns the from
887+-- and size fields for the search. The from parameter defines the offset
888+-- from the first result you want to fetch. The size parameter allows you to
889+-- configure the maximum amount of hits to be returned.
890+pageSearch :: From -- ^ The result offset
891+ -> Size -- ^ The number of results to return
892+ -> Search -- ^ The current seach
893+ -> Search -- ^ The paged search
894+pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
895+
896+parseUrl' :: MonadThrow m => Text -> m Request
897+parseUrl' t = parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack t))
898+
899+-- | Was there an optimistic concurrency control conflict when
900+-- indexing a document?
901+isVersionConflict :: Reply -> Bool
902+isVersionConflict = statusCheck (== 409)
903+
904+isSuccess :: Reply -> Bool
905+isSuccess = statusCheck (inRange (200, 299))
906+
907+isCreated :: Reply -> Bool
908+isCreated = statusCheck (== 201)
909+
910+statusCheck :: (Int -> Bool) -> Reply -> Bool
911+statusCheck prd = prd . NHTS.statusCode . responseStatus
912+
913+-- | This is a hook that can be set via the 'bhRequestHook' function
914+-- that will authenticate all requests using an HTTP Basic
915+-- Authentication header. Note that it is *strongly* recommended that
916+-- this option only be used over an SSL connection.
917+--
918+-- >> (mkBHEnv myServer myManager) { bhRequestHook = basicAuthHook (EsUsername "myuser") (EsPassword "mypass") }
919+basicAuthHook :: Monad m => EsUsername -> EsPassword -> Request -> m Request
920+basicAuthHook (EsUsername u) (EsPassword p) = return . applyBasicAuth u' p'
921+ where u' = T.encodeUtf8 u
922+ p' = T.encodeUtf8 p
923+
924+
925+boolQP :: Bool -> Text
926+boolQP True = "true"
927+boolQP False = "false"
src/Database/V1/Bloodhound/Internal/Aggregation.hsnew file+416
@@ -0,0 +1,416 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+
4+module Database.V1.Bloodhound.Internal.Aggregation where
5+
6+import Bloodhound.Import
7+
8+import qualified Data.HashMap.Strict as HM
9+import qualified Data.Map.Strict as M
10+import qualified Data.Text as T
11+
12+import Database.V1.Bloodhound.Internal.Client
13+import Database.V1.Bloodhound.Internal.Highlight (HitHighlight)
14+import Database.V1.Bloodhound.Internal.Newtypes
15+import Database.V1.Bloodhound.Internal.Query
16+import Database.V1.Bloodhound.Internal.Sort
17+
18+
19+type Aggregations = M.Map Text Aggregation
20+
21+emptyAggregations :: Aggregations
22+emptyAggregations = M.empty
23+
24+mkAggregations :: Text -> Aggregation -> Aggregations
25+mkAggregations name aggregation = M.insert name aggregation emptyAggregations
26+
27+data Aggregation = TermsAgg TermsAggregation
28+ | CardinalityAgg CardinalityAggregation
29+ | DateHistogramAgg DateHistogramAggregation
30+ | ValueCountAgg ValueCountAggregation
31+ | FilterAgg FilterAggregation
32+ | DateRangeAgg DateRangeAggregation
33+ | MissingAgg MissingAggregation
34+ | TopHitsAgg TopHitsAggregation
35+ deriving (Eq, Show)
36+
37+
38+instance ToJSON Aggregation where
39+ toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =
40+ omitNulls ["terms" .= omitNulls [ toJSON' term,
41+ "include" .= include,
42+ "exclude" .= exclude,
43+ "order" .= order,
44+ "min_doc_count" .= minDocCount,
45+ "size" .= size,
46+ "shard_size" .= shardSize,
47+ "collect_mode" .= collectMode,
48+ "execution_hint" .= executionHint
49+ ],
50+ "aggs" .= termAggs ]
51+ where
52+ toJSON' x = case x of { Left y -> "field" .= y; Right y -> "script" .= y }
53+
54+ toJSON (CardinalityAgg (CardinalityAggregation field precisionThreshold)) =
55+ object ["cardinality" .= omitNulls [ "field" .= field,
56+ "precisionThreshold" .= precisionThreshold
57+ ]
58+ ]
59+
60+ toJSON (DateHistogramAgg (DateHistogramAggregation field interval format preZone postZone preOffset postOffset dateHistoAggs)) =
61+ omitNulls ["date_histogram" .= omitNulls [ "field" .= field,
62+ "interval" .= interval,
63+ "format" .= format,
64+ "pre_zone" .= preZone,
65+ "post_zone" .= postZone,
66+ "pre_offset" .= preOffset,
67+ "post_offset" .= postOffset
68+ ],
69+ "aggs" .= dateHistoAggs ]
70+ toJSON (ValueCountAgg a) = object ["value_count" .= v]
71+ where v = case a of
72+ (FieldValueCount (FieldName n)) -> object ["field" .= n]
73+ (ScriptValueCount (Script s)) -> object ["script" .= s]
74+ toJSON (FilterAgg (FilterAggregation filt ags)) =
75+ omitNulls [ "filter" .= filt
76+ , "aggs" .= ags]
77+ toJSON (DateRangeAgg a) = object [ "date_range" .= a
78+ ]
79+ toJSON (MissingAgg (MissingAggregation{..})) =
80+ object ["missing" .= object ["field" .= maField]]
81+
82+ toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =
83+ omitNulls ["top_hits" .= omitNulls [ "size" .= msize
84+ , "from" .= mfrom
85+ , "sort" .= msort
86+ ]
87+ ]
88+
89+data TopHitsAggregation = TopHitsAggregation
90+ { taFrom :: Maybe From
91+ , taSize :: Maybe Size
92+ , taSort :: Maybe Sort
93+ } deriving (Eq, Show)
94+
95+data MissingAggregation = MissingAggregation
96+ { maField :: Text
97+ } deriving (Eq, Show)
98+
99+data TermsAggregation = TermsAggregation { term :: Either Text Text
100+ , termInclude :: Maybe TermInclusion
101+ , termExclude :: Maybe TermInclusion
102+ , termOrder :: Maybe TermOrder
103+ , termMinDocCount :: Maybe Int
104+ , termSize :: Maybe Int
105+ , termShardSize :: Maybe Int
106+ , termCollectMode :: Maybe CollectionMode
107+ , termExecutionHint :: Maybe ExecutionHint
108+ , termAggs :: Maybe Aggregations
109+ } deriving (Eq, Show)
110+
111+data CardinalityAggregation = CardinalityAggregation { cardinalityField :: FieldName,
112+ precisionThreshold :: Maybe Int
113+ } deriving (Eq, Show)
114+
115+data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
116+ , dateInterval :: Interval
117+ , dateFormat :: Maybe Text
118+ -- pre and post deprecated in 1.5
119+ , datePreZone :: Maybe Text
120+ , datePostZone :: Maybe Text
121+ , datePreOffset :: Maybe Text
122+ , datePostOffset :: Maybe Text
123+ , dateAggs :: Maybe Aggregations
124+ } deriving (Eq, Show)
125+
126+
127+data DateRangeAggregation = DateRangeAggregation { draField :: FieldName
128+ , draFormat :: Maybe Text
129+ , draRanges :: NonEmpty DateRangeAggRange
130+ } deriving (Eq, Show)
131+
132+data DateRangeAggRange = DateRangeFrom DateMathExpr
133+ | DateRangeTo DateMathExpr
134+ | DateRangeFromAndTo DateMathExpr DateMathExpr deriving (Eq, Show)
135+
136+-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.
137+data ValueCountAggregation = FieldValueCount FieldName
138+ | ScriptValueCount Script deriving (Eq, Show)
139+
140+-- | Single-bucket filter aggregations. See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-bucket-filter-aggregation.html#search-aggregations-bucket-filter-aggregation> for more information.
141+data FilterAggregation = FilterAggregation { faFilter :: Filter
142+ , faAggs :: Maybe Aggregations} deriving (Eq, Show)
143+
144+mkTermsAggregation :: Text -> TermsAggregation
145+mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
146+
147+mkTermsScriptAggregation :: Text -> TermsAggregation
148+mkTermsScriptAggregation t = TermsAggregation (Right t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
149+
150+mkDateHistogram :: FieldName -> Interval -> DateHistogramAggregation
151+mkDateHistogram t i = DateHistogramAggregation t i Nothing Nothing Nothing Nothing Nothing Nothing
152+
153+mkCardinalityAggregation :: FieldName -> CardinalityAggregation
154+mkCardinalityAggregation t = CardinalityAggregation t Nothing
155+
156+data TermInclusion = TermInclusion Text
157+ | TermPattern Text Text deriving (Eq, Show)
158+
159+instance ToJSON TermInclusion where
160+ toJSON (TermInclusion x) = toJSON x
161+ toJSON (TermPattern pattern flags) =
162+ omitNulls [ "pattern" .= pattern
163+ , "flags" .= flags]
164+
165+data TermOrder = TermOrder
166+ { termSortField :: Text
167+ , termSortOrder :: SortOrder } deriving (Eq, Show)
168+
169+instance ToJSON TermOrder where
170+ toJSON (TermOrder termSortField termSortOrder) =
171+ object [termSortField .= termSortOrder]
172+
173+
174+data ExecutionHint = Ordinals
175+ | GlobalOrdinals
176+ | GlobalOrdinalsHash
177+ | GlobalOrdinalsLowCardinality
178+ | Map deriving (Eq, Show)
179+
180+instance ToJSON ExecutionHint where
181+ toJSON Ordinals = "ordinals"
182+ toJSON GlobalOrdinals = "global_ordinals"
183+ toJSON GlobalOrdinalsHash = "global_ordinals_hash"
184+ toJSON GlobalOrdinalsLowCardinality = "global_ordinals_low_cardinality"
185+ toJSON Map = "map"
186+
187+
188+-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#date-math> for more information.
189+data DateMathExpr =
190+ DateMathExpr DateMathAnchor [DateMathModifier]
191+ deriving (Eq, Show)
192+
193+instance ToJSON DateMathExpr where
194+ toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))
195+ where fmtA DMNow = "now"
196+ fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"
197+ fmtMod (AddTime n u) = "+" <> showText n <> fmtU u
198+ fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u
199+ fmtMod (RoundDownTo u) = "/" <> fmtU u
200+ fmtU DMYear = "y"
201+ fmtU DMMonth = "M"
202+ fmtU DMWeek = "w"
203+ fmtU DMDay = "d"
204+ fmtU DMHour = "h"
205+ fmtU DMMinute = "m"
206+ fmtU DMSecond = "s"
207+
208+-- | Starting point for a date range. This along with the 'DateMathModifiers' gets you the date ES will start from.
209+data DateMathAnchor =
210+ DMNow
211+ | DMDate Day
212+ deriving (Eq, Show)
213+
214+data DateMathModifier =
215+ AddTime Int DateMathUnit
216+ | SubtractTime Int DateMathUnit
217+ | RoundDownTo DateMathUnit
218+ deriving (Eq, Show)
219+
220+data DateMathUnit =
221+ DMYear
222+ | DMMonth
223+ | DMWeek
224+ | DMDay
225+ | DMHour
226+ | DMMinute
227+ | DMSecond
228+ deriving (Eq, Show)
229+
230+data CollectionMode = BreadthFirst
231+ | DepthFirst deriving (Eq, Show)
232+
233+type AggregationResults = M.Map Text Value
234+
235+class BucketAggregation a where
236+ key :: a -> BucketValue
237+ docCount :: a -> Int
238+ aggs :: a -> Maybe AggregationResults
239+
240+data BucketValue = TextValue Text
241+ | ScientificValue Scientific
242+ | BoolValue Bool deriving (Show)
243+
244+data Bucket a = Bucket { buckets :: [a]} deriving (Show)
245+
246+data TermsResult = TermsResult { termKey :: BucketValue
247+ , termsDocCount :: Int
248+ , termsAggs :: Maybe AggregationResults } deriving (Show)
249+
250+data DateHistogramResult = DateHistogramResult { dateKey :: Int
251+ , dateKeyStr :: Maybe Text
252+ , dateDocCount :: Int
253+ , dateHistogramAggs :: Maybe AggregationResults } deriving (Show)
254+
255+data DateRangeResult = DateRangeResult { dateRangeKey :: Text
256+ , dateRangeFrom :: Maybe UTCTime
257+ , dateRangeFromAsString :: Maybe Text
258+ , dateRangeTo :: Maybe UTCTime
259+ , dateRangeToAsString :: Maybe Text
260+ , dateRangeDocCount :: Int
261+ , dateRangeAggs :: Maybe AggregationResults } deriving (Show, Eq)
262+
263+toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
264+toTerms = toAggResult
265+
266+toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
267+toDateHistogram = toAggResult
268+
269+toMissing :: Text -> AggregationResults -> Maybe MissingResult
270+toMissing = toAggResult
271+
272+toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)
273+toTopHits = toAggResult
274+
275+toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a
276+toAggResult t a = M.lookup t a >>= deserialize
277+ where deserialize = parseMaybe parseJSON
278+
279+instance BucketAggregation TermsResult where
280+ key = termKey
281+ docCount = termsDocCount
282+ aggs = termsAggs
283+
284+instance BucketAggregation DateHistogramResult where
285+ key = TextValue . showText . dateKey
286+ docCount = dateDocCount
287+ aggs = dateHistogramAggs
288+
289+instance BucketAggregation DateRangeResult where
290+ key = TextValue . dateRangeKey
291+ docCount = dateRangeDocCount
292+ aggs = dateRangeAggs
293+
294+instance (FromJSON a) => FromJSON (Bucket a) where
295+ parseJSON (Object v) = Bucket <$>
296+ v .: "buckets"
297+ parseJSON _ = mempty
298+
299+instance FromJSON BucketValue where
300+ parseJSON (String t) = return $ TextValue t
301+ parseJSON (Number s) = return $ ScientificValue s
302+ parseJSON (Bool b) = return $ BoolValue b
303+ parseJSON _ = mempty
304+
305+instance FromJSON MissingResult where
306+ parseJSON = withObject "MissingResult" parse
307+ where parse v = MissingResult <$> v .: "doc_count"
308+
309+instance FromJSON TermsResult where
310+ parseJSON (Object v) = TermsResult <$>
311+ v .: "key" <*>
312+ v .: "doc_count" <*>
313+ (pure $ getNamedSubAgg v ["key", "doc_count"])
314+ parseJSON _ = mempty
315+
316+instance FromJSON DateHistogramResult where
317+ parseJSON (Object v) = DateHistogramResult <$>
318+ v .: "key" <*>
319+ v .:? "key_as_string" <*>
320+ v .: "doc_count" <*>
321+ (pure $ getNamedSubAgg v [ "key"
322+ , "doc_count"
323+ , "key_as_string"
324+ ]
325+ )
326+ parseJSON _ = mempty
327+
328+instance FromJSON DateRangeResult where
329+ parseJSON = withObject "DateRangeResult" parse
330+ where parse v = DateRangeResult <$>
331+ v .: "key" <*>
332+ (fmap posixMS <$> v .:? "from") <*>
333+ v .:? "from_as_string" <*>
334+ (fmap posixMS <$> v .:? "to") <*>
335+ v .:? "to_as_string" <*>
336+ v .: "doc_count" <*>
337+ (pure $ getNamedSubAgg v [ "key"
338+ , "from"
339+ , "from_as_string"
340+ , "to"
341+ , "to_as_string"
342+ , "doc_count"
343+ ]
344+ )
345+
346+instance (FromJSON a) => FromJSON (TopHitResult a) where
347+ parseJSON (Object v) = TopHitResult <$>
348+ v .: "hits"
349+ parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"
350+
351+data MissingResult = MissingResult { missingDocCount :: Int } deriving (Show)
352+
353+data TopHitResult a = TopHitResult { tarHits :: (SearchHits a)
354+ } deriving Show
355+
356+data SearchHits a =
357+ SearchHits { hitsTotal :: Int
358+ , maxScore :: Score
359+ , hits :: [Hit a] } deriving (Eq, Show)
360+
361+instance Semigroup (SearchHits a) where
362+ (SearchHits ta ma ha) <> (SearchHits tb mb hb) = SearchHits (ta + tb) (max ma mb) (ha <> hb)
363+
364+instance Monoid (SearchHits a) where
365+ mempty = SearchHits 0 Nothing mempty
366+ mappend = (<>)
367+
368+data Hit a =
369+ Hit { hitIndex :: IndexName
370+ , hitType :: MappingName
371+ , hitDocId :: DocId
372+ , hitScore :: Score
373+ , hitSource :: Maybe a
374+ , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
375+
376+-- Try to get an AggregationResults when we don't know the
377+-- field name. We filter out the known keys to try to minimize the noise.
378+getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
379+getNamedSubAgg o knownKeys = maggRes
380+ where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
381+ maggRes
382+ | HM.null unknownKeys = Nothing
383+ | otherwise = Just . M.fromList $ HM.toList unknownKeys
384+
385+instance ToJSON CollectionMode where
386+ toJSON BreadthFirst = "breadth_first"
387+ toJSON DepthFirst = "depth_first"
388+
389+instance ToJSON DateRangeAggregation where
390+ toJSON DateRangeAggregation {..} =
391+ omitNulls [ "field" .= draField
392+ , "format" .= draFormat
393+ , "ranges" .= toList draRanges
394+ ]
395+
396+instance (FromJSON a) => FromJSON (SearchHits a) where
397+ parseJSON (Object v) = SearchHits <$>
398+ v .: "total" <*>
399+ v .: "max_score" <*>
400+ v .: "hits"
401+ parseJSON _ = empty
402+
403+instance ToJSON DateRangeAggRange where
404+ toJSON (DateRangeFrom e) = object [ "from" .= e ]
405+ toJSON (DateRangeTo e) = object [ "to" .= e ]
406+ toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]
407+
408+instance (FromJSON a) => FromJSON (Hit a) where
409+ parseJSON (Object v) = Hit <$>
410+ v .: "_index" <*>
411+ v .: "_type" <*>
412+ v .: "_id" <*>
413+ v .: "_score" <*>
414+ v .:? "_source" <*>
415+ v .:? "highlight"
416+ parseJSON _ = empty
src/Database/V1/Bloodhound/Internal/Client.hsnew file+2341
@@ -0,0 +1,2341 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+
8+module Database.V1.Bloodhound.Internal.Client where
9+
10+import Bloodhound.Import
11+
12+import Control.Applicative as A
13+import qualified Data.HashMap.Strict as HM
14+import Data.Text (Text)
15+import qualified Data.Text as T
16+import qualified Data.Traversable as DT
17+import qualified Data.Vector as V
18+import qualified Data.Version as Vers
19+import GHC.Enum
20+import Network.HTTP.Client
21+import qualified Text.ParserCombinators.ReadP as RP
22+import Text.Read (Read (..))
23+import qualified Text.Read as TR
24+
25+import Database.V1.Bloodhound.Internal.Newtypes
26+import Database.V1.Bloodhound.Internal.Query
27+import Database.V1.Bloodhound.Internal.StringlyTyped
28+
29+
30+{-| Common environment for Elasticsearch calls. Connections will be
31+ pipelined according to the provided HTTP connection manager.
32+-}
33+data BHEnv = BHEnv { bhServer :: Server
34+ , bhManager :: Manager
35+ , bhRequestHook :: Request -> IO Request
36+ -- ^ Low-level hook that is run before every request is sent. Used to implement custom authentication strategies. Defaults to 'return' with 'mkBHEnv'.
37+ }
38+
39+instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) where
40+ getBHEnv = ask
41+
42+{-| 'Server' is used with the client functions to point at the ES instance
43+-}
44+newtype Server = Server Text deriving (Eq, Show, FromJSON)
45+
46+{-| All API calls to Elasticsearch operate within
47+ MonadBH
48+ . The idea is that it can be easily embedded in your
49+ own monad transformer stack. A default instance for a ReaderT and
50+ alias 'BH' is provided for the simple case.
51+-}
52+class (Functor m, A.Applicative m, MonadIO m) => MonadBH m where
53+ getBHEnv :: m BHEnv
54+
55+-- $setup
56+-- >>> :set -XOverloadedStrings
57+-- >>> import Data.Aeson
58+-- >>> import Database.V1.Bloodhound
59+-- >>> let testServer = (Server "http://localhost:9200")
60+-- >>> let testIndex = IndexName "twitter"
61+-- >>> let testMapping = MappingName "tweet"
62+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
63+
64+-- defaultIndexSettings is exported by Database.Bloodhound as well
65+-- no trailing slashes in servers, library handles building the path.
66+
67+-- | Create a 'BHEnv' with all optional fields defaulted. HTTP hook
68+-- will be a noop. You can use the exported fields to customize it further, e.g.:
69+--
70+-- >> (mkBHEnv myServer myManager) { bhRequestHook = customHook }
71+mkBHEnv :: Server -> Manager -> BHEnv
72+mkBHEnv s m = BHEnv s m return
73+
74+newtype BH m a = BH {
75+ unBH :: ReaderT BHEnv m a
76+ } deriving ( Functor
77+ , A.Applicative
78+ , Monad
79+ , MonadIO
80+ , MonadState s
81+ , MonadWriter w
82+ , MonadError e
83+ , Alternative
84+ , MonadPlus
85+ , MonadFix
86+ , MonadThrow
87+ , MonadCatch
88+ , MonadMask)
89+
90+instance MonadTrans BH where
91+ lift = BH . lift
92+
93+instance (MonadReader r m) => MonadReader r (BH m) where
94+ ask = lift ask
95+ local f (BH (ReaderT m)) = BH $ ReaderT $ \r ->
96+ local f (m r)
97+
98+instance (Functor m, Applicative m, MonadIO m) => MonadBH (BH m) where
99+ getBHEnv = BH getBHEnv
100+
101+runBH :: BHEnv -> BH m a -> m a
102+runBH e f = runReaderT (unBH f) e
103+
104+{-| 'Version' is embedded in 'Status' -}
105+data Version = Version { number :: VersionNumber
106+ , build_hash :: BuildHash
107+ , build_timestamp :: UTCTime
108+ , build_snapshot :: Bool
109+ , lucene_version :: VersionNumber } deriving (Eq, Show)
110+
111+instance ToJSON Version where
112+ toJSON Version {..} = object ["number" .= number
113+ ,"build_hash" .= build_hash
114+ ,"build_timestamp" .= build_timestamp
115+ ,"build_snapshot" .= build_snapshot
116+ ,"lucene_version" .= lucene_version]
117+
118+instance FromJSON Version where
119+ parseJSON = withObject "Version" parse
120+ where parse o = Version
121+ <$> o .: "number"
122+ <*> o .: "build_hash"
123+ <*> o .: "build_timestamp"
124+ <*> o .: "build_snapshot"
125+ <*> o .: "lucene_version"
126+
127+-- | Traditional software versioning number
128+newtype VersionNumber = VersionNumber { versionNumber :: Vers.Version
129+ } deriving (Eq, Show, Ord)
130+
131+{-| 'Status' is a data type for describing the JSON body returned by
132+ Elasticsearch when you query its status. This was deprecated in 1.2.0.
133+
134+ <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-status.html#indices-status>
135+-}
136+
137+data Status = Status { ok :: Maybe Bool
138+ , status :: Int
139+ , name :: Text
140+ , version :: Version
141+ , tagline :: Text } deriving (Eq, Show)
142+
143+instance FromJSON Status where
144+ parseJSON (Object v) = Status <$>
145+ v .:? "ok" <*>
146+ (v .:? "status" .!= 200) <*>
147+ v .: "name" <*>
148+ v .: "version" <*>
149+ v .: "tagline"
150+ parseJSON _ = empty
151+
152+{-| 'IndexSettings' is used to configure the shards and replicas when you create
153+ an Elasticsearch Index.
154+
155+ <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-create-index.html>
156+-}
157+
158+data IndexSettings =
159+ IndexSettings { indexShards :: ShardCount
160+ , indexReplicas :: ReplicaCount } deriving (Eq, Show)
161+
162+{-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and 2 replicas. -}
163+defaultIndexSettings :: IndexSettings
164+defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
165+
166+
167+{-| 'IndexOptimizationSettings' is used to configure index optimization. See
168+ <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-optimize.html>
169+ for more info.
170+-}
171+data IndexOptimizationSettings =
172+ IndexOptimizationSettings { maxNumSegments :: Maybe Int
173+ -- ^ Number of segments to optimize to. 1 will fully optimize the index. If omitted, the default behavior is to only optimize if the server deems it necessary.
174+ , onlyExpungeDeletes :: Bool
175+ -- ^ Should the optimize process only expunge segments with deletes in them? If the purpose of the optimization is to free disk space, this should be set to True.
176+ , flushAfterOptimize :: Bool
177+ -- ^ Should a flush be performed after the optimize.
178+ } deriving (Eq, Show)
179+
180+
181+{-| 'defaultIndexOptimizationSettings' implements the default settings that
182+ Elasticsearch uses for index optimization. 'maxNumSegments' is Nothing,
183+ 'onlyExpungeDeletes' is False, and flushAfterOptimize is True.
184+-}
185+defaultIndexOptimizationSettings :: IndexOptimizationSettings
186+defaultIndexOptimizationSettings = IndexOptimizationSettings Nothing False True
187+
188+{-| 'UpdatableIndexSetting' are settings which may be updated after an index is created.
189+
190+ <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-update-settings.html>
191+-}
192+data UpdatableIndexSetting = NumberOfReplicas ReplicaCount
193+ -- ^ The number of replicas each shard has.
194+ | AutoExpandReplicas ReplicaBounds
195+ | BlocksReadOnly Bool
196+ -- ^ Set to True to have the index read only. False to allow writes and metadata changes.
197+ | BlocksRead Bool
198+ -- ^ Set to True to disable read operations against the index.
199+ | BlocksWrite Bool
200+ -- ^ Set to True to disable write operations against the index.
201+ | BlocksMetaData Bool
202+ -- ^ Set to True to disable metadata operations against the index.
203+ | RefreshInterval NominalDiffTime
204+ -- ^ The async refresh interval of a shard
205+ | IndexConcurrency Int
206+ | FailOnMergeFailure Bool
207+ | TranslogFlushThresholdOps Int
208+ -- ^ When to flush on operations.
209+ | TranslogFlushThresholdSize Bytes
210+ -- ^ When to flush based on translog (bytes) size.
211+ | TranslogFlushThresholdPeriod NominalDiffTime
212+ -- ^ When to flush based on a period of not flushing.
213+ | TranslogDisableFlush Bool
214+ -- ^ Disables flushing. Note, should be set for a short interval and then enabled.
215+ | CacheFilterMaxSize (Maybe Bytes)
216+ -- ^ The maximum size of filter cache (per segment in shard).
217+ | CacheFilterExpire (Maybe NominalDiffTime)
218+ -- ^ The expire after access time for filter cache.
219+ | GatewaySnapshotInterval NominalDiffTime
220+ -- ^ The gateway snapshot interval (only applies to shared gateways).
221+ | RoutingAllocationInclude (NonEmpty NodeAttrFilter)
222+ -- ^ A node matching any rule will be allowed to host shards from the index.
223+ | RoutingAllocationExclude (NonEmpty NodeAttrFilter)
224+ -- ^ A node matching any rule will NOT be allowed to host shards from the index.
225+ | RoutingAllocationRequire (NonEmpty NodeAttrFilter)
226+ -- ^ Only nodes matching all rules will be allowed to host shards from the index.
227+ | RoutingAllocationEnable AllocationPolicy
228+ -- ^ Enables shard allocation for a specific index.
229+ | RoutingAllocationShardsPerNode ShardCount
230+ -- ^ Controls the total number of shards (replicas and primaries) allowed to be allocated on a single node.
231+ | RecoveryInitialShards InitialShardCount
232+ -- ^ When using local gateway a particular shard is recovered only if there can be allocated quorum shards in the cluster.
233+ | GCDeletes NominalDiffTime
234+ | TTLDisablePurge Bool
235+ -- ^ Disables temporarily the purge of expired docs.
236+ | TranslogFSType FSType
237+ | IndexCompoundFormat CompoundFormat
238+ | IndexCompoundOnFlush Bool
239+ | WarmerEnabled Bool
240+ deriving (Eq, Show)
241+
242+data AllocationPolicy = AllocAll
243+ -- ^ Allows shard allocation for all shards.
244+ | AllocPrimaries
245+ -- ^ Allows shard allocation only for primary shards.
246+ | AllocNewPrimaries
247+ -- ^ Allows shard allocation only for primary shards for new indices.
248+ | AllocNone
249+ -- ^ No shard allocation is allowed
250+ deriving (Eq, Show)
251+
252+data ReplicaBounds = ReplicasBounded Int Int
253+ | ReplicasLowerBounded Int
254+ | ReplicasUnbounded
255+ deriving (Eq, Show)
256+
257+-- | A measure of bytes used for various configurations. You may want
258+-- to use smart constructors like 'gigabytes' for larger values.
259+--
260+-- >>> gigabytes 9
261+-- Bytes 9000000000
262+--
263+-- >>> megabytes 9
264+-- Bytes 9000000
265+--
266+-- >>> kilobytes 9
267+-- Bytes 9000
268+newtype Bytes = Bytes Int deriving (Eq, Show, Ord, ToJSON, FromJSON)
269+
270+gigabytes :: Int -> Bytes
271+gigabytes n = megabytes (1000 * n)
272+
273+
274+megabytes :: Int -> Bytes
275+megabytes n = kilobytes (1000 * n)
276+
277+
278+kilobytes :: Int -> Bytes
279+kilobytes n = Bytes (1000 * n)
280+
281+data Interval = Year
282+ | Quarter
283+ | Month
284+ | Week
285+ | Day
286+ | Hour
287+ | Minute
288+ | Second
289+ | FractionalInterval Float TimeInterval deriving (Eq, Show)
290+
291+data TimeInterval = Weeks
292+ | Days
293+ | Hours
294+ | Minutes
295+ | Seconds deriving Eq
296+
297+instance Show TimeInterval where
298+ show Weeks = "w"
299+ show Days = "d"
300+ show Hours = "h"
301+ show Minutes = "m"
302+ show Seconds = "s"
303+
304+instance Read TimeInterval where
305+ readPrec = f =<< TR.get
306+ where
307+ f 'w' = return Weeks
308+ f 'd' = return Days
309+ f 'h' = return Hours
310+ f 'm' = return Minutes
311+ f 's' = return Seconds
312+ f _ = fail "TimeInterval expected one of w, d, h, m, s"
313+
314+-- | Typically a 7 character hex string.
315+newtype BuildHash = BuildHash { buildHash :: Text }
316+ deriving (Eq, Ord, Show, FromJSON, ToJSON)
317+
318+data NodeAttrFilter = NodeAttrFilter
319+ { nodeAttrFilterName :: NodeAttrName
320+ , nodeAttrFilterValues :: NonEmpty Text }
321+ deriving (Eq, Ord, Show)
322+
323+newtype NodeAttrName = NodeAttrName Text deriving (Eq, Ord, Show)
324+
325+data InitialShardCount = QuorumShards
326+ | QuorumMinus1Shards
327+ | FullShards
328+ | FullMinus1Shards
329+ | ExplicitShards Int
330+ deriving (Eq, Show)
331+
332+instance FromJSON InitialShardCount where
333+ parseJSON v = withText "InitialShardCount" parseText v
334+ <|> ExplicitShards <$> parseJSON v
335+ where parseText "quorum" = pure QuorumShards
336+ parseText "quorum-1" = pure QuorumMinus1Shards
337+ parseText "full" = pure FullShards
338+ parseText "full-1" = pure FullMinus1Shards
339+ parseText _ = mzero
340+
341+instance ToJSON InitialShardCount where
342+ toJSON QuorumShards = String "quorum"
343+ toJSON QuorumMinus1Shards = String "quorum-1"
344+ toJSON FullShards = String "full"
345+ toJSON FullMinus1Shards = String "full-1"
346+ toJSON (ExplicitShards x) = toJSON x
347+
348+data FSType = FSSimple
349+ | FSBuffered deriving (Eq, Show)
350+
351+instance ToJSON FSType where
352+ toJSON FSSimple = "simple"
353+ toJSON FSBuffered = "buffered"
354+
355+instance FromJSON FSType where
356+ parseJSON = withText "FSType" parse
357+ where parse "simple" = pure FSSimple
358+ parse "buffered" = pure FSBuffered
359+ parse t = fail ("Invalid FSType: " <> show t)
360+
361+data CompoundFormat = CompoundFileFormat Bool
362+ | MergeSegmentVsTotalIndex Double
363+ -- ^ percentage between 0 and 1 where 0 is false, 1 is true
364+ deriving (Eq, Show)
365+
366+attrFilterJSON :: NonEmpty NodeAttrFilter -> Value
367+attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)
368+ | NodeAttrFilter (NodeAttrName n) vs <- toList fs]
369+
370+parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)
371+parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse
372+ where parse o = case HM.toList o of
373+ [] -> fail "Expected non-empty list of NodeAttrFilters"
374+ x:xs -> DT.mapM (uncurry parse') (x :| xs)
375+ parse' n = withText "Text" $ \t ->
376+ case T.splitOn "," t of
377+ fv:fvs -> return (NodeAttrFilter (NodeAttrName n) (fv :| fvs))
378+ [] -> fail "Expected non-empty list of filter values"
379+
380+newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }
381+
382+data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName
383+ , sSummaryFixedSettings :: IndexSettings
384+ , sSummaryUpdateable :: [UpdatableIndexSetting]}
385+ deriving (Eq, Show)
386+
387+parseSettings :: Object -> Parser [UpdatableIndexSetting]
388+parseSettings o = do
389+ o' <- o .: "index"
390+ -- slice the index object into singleton hashmaps and try to parse each
391+ parses <- forM (HM.toList o') $ \(k, v) -> do
392+ -- blocks are now nested into the "index" key, which is not how they're serialized
393+ let atRoot = Object (HM.singleton k v)
394+ let atIndex = Object (HM.singleton "index" atRoot)
395+ optional (parseJSON atRoot <|> parseJSON atIndex)
396+ return (catMaybes parses)
397+
398+{-| 'OpenCloseIndex' is a sum type for opening and closing indices.
399+
400+ <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
401+-}
402+data OpenCloseIndex = OpenIndex | CloseIndex deriving (Eq, Show)
403+
404+data FieldType = GeoPointType
405+ | GeoShapeType
406+ | FloatType
407+ | IntegerType
408+ | LongType
409+ | ShortType
410+ | ByteType deriving (Eq, Show)
411+
412+data FieldDefinition =
413+ FieldDefinition { fieldType :: FieldType } deriving (Eq, Show)
414+
415+{-| An 'IndexTemplate' defines a template that will automatically be
416+ applied to new indices created. The templates include both
417+ 'IndexSettings' and mappings, and a simple 'TemplatePattern' that
418+ controls if the template will be applied to the index created.
419+ Specify mappings as follows: @[toJSON TweetMapping, ...]@
420+
421+ https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html
422+-}
423+data IndexTemplate =
424+ IndexTemplate { templatePattern :: TemplatePattern
425+ , templateSettings :: Maybe IndexSettings
426+ , templateMappings :: [Value]
427+ }
428+
429+data MappingField =
430+ MappingField { mappingFieldName :: FieldName
431+ , fieldDefinition :: FieldDefinition } deriving (Eq, Show)
432+
433+{-| Support for type reification of 'Mapping's is currently incomplete, for
434+ now the mapping API verbiage expects a 'ToJSON'able blob.
435+
436+ Indexes have mappings, mappings are schemas for the documents contained in the
437+ index. I'd recommend having only one mapping per index, always having a mapping,
438+ and keeping different kinds of documents separated if possible.
439+-}
440+data Mapping = Mapping { typeName :: TypeName
441+ , mappingFields :: [MappingField] } deriving (Eq, Show)
442+
443+{-| 'BulkOperation' is a sum type for expressing the four kinds of bulk
444+ operation index, create, delete, and update. 'BulkIndex' behaves like an
445+ "upsert", 'BulkCreate' will fail if a document already exists at the DocId.
446+
447+ <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html#docs-bulk>
448+-}
449+data BulkOperation =
450+ BulkIndex IndexName MappingName DocId Value
451+ | BulkCreate IndexName MappingName DocId Value
452+ | BulkDelete IndexName MappingName DocId
453+ | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show)
454+
455+{-| 'EsResult' describes the standard wrapper JSON document that you see in
456+ successful Elasticsearch lookups or lookups that couldn't find the document.
457+-}
458+data EsResult a = EsResult { _index :: Text
459+ , _type :: Text
460+ , _id :: Text
461+ , foundResult :: Maybe (EsResultFound a)} deriving (Eq, Show)
462+
463+instance (FromJSON a) => FromJSON (EsResult a) where
464+ parseJSON jsonVal@(Object v) = do
465+ found <- v .:? "found" .!= False
466+ fr <- if found
467+ then parseJSON jsonVal
468+ else return Nothing
469+ EsResult <$> v .: "_index" <*>
470+ v .: "_type" <*>
471+ v .: "_id" <*>
472+ pure fr
473+ parseJSON _ = empty
474+
475+{-| 'EsResultFound' contains the document and its metadata inside of an
476+ 'EsResult' when the document was successfully found.
477+-}
478+data EsResultFound a = EsResultFound { _version :: DocVersion
479+ , _source :: a } deriving (Eq, Show)
480+
481+instance (FromJSON a) => FromJSON (EsResultFound a) where
482+ parseJSON (Object v) = EsResultFound <$>
483+ v .: "_version" <*>
484+ v .: "_source"
485+ parseJSON _ = empty
486+
487+{-| 'EsError' is the generic type that will be returned when there was a
488+ problem. If you can't parse the expected response, its a good idea to
489+ try parsing this.
490+-}
491+data EsError = EsError { errorStatus :: Int
492+ , errorMessage :: Text } deriving (Eq, Show)
493+
494+{-| 'EsProtocolException' will be thrown if Bloodhound cannot parse a response
495+returned by the Elasticsearch server. If you encounter this error, please
496+verify that your domain data types and FromJSON instances are working properly
497+(for example, the 'a' of '[Hit a]' in 'SearchResult.searchHits.hits'). If you're
498+sure that your mappings are correct, then this error may be an indication of an
499+incompatibility between Bloodhound and Elasticsearch. Please open a bug report
500+and be sure to include the exception body.
501+-}
502+data EsProtocolException = EsProtocolException { esProtoExBody :: LByteString }
503+ deriving (Eq, Show)
504+
505+instance Exception EsProtocolException
506+
507+data IndexAlias = IndexAlias { srcIndex :: IndexName
508+ , indexAlias :: IndexAliasName } deriving (Eq, Show)
509+
510+{-| 'DocVersion' is an integer version number for a document between 1
511+and 9.2e+18 used for <<https://www.elastic.co/guide/en/elasticsearch/guide/current/optimistic-concurrency-control.html optimistic concurrency control>>.
512+-}
513+newtype DocVersion = DocVersion {
514+ docVersionNumber :: Int
515+ } deriving (Eq, Show, Ord, ToJSON)
516+
517+instance FromJSON DocVersion where
518+ parseJSON v = do
519+ i <- parseJSON v
520+ maybe (fail "DocVersion out of range") return $ mkDocVersion i
521+
522+-- | Smart constructor for in-range doc version
523+mkDocVersion :: Int -> Maybe DocVersion
524+mkDocVersion i
525+ | i >= (docVersionNumber minBound) && i <= (docVersionNumber maxBound) =
526+ Just $ DocVersion i
527+ | otherwise = Nothing
528+
529+data IndexAliasAction = AddAlias IndexAlias IndexAliasCreate
530+ | RemoveAlias IndexAlias deriving (Show, Eq)
531+
532+data IndexAliasCreate = IndexAliasCreate { aliasCreateRouting :: Maybe AliasRouting
533+ , aliasCreateFilter :: Maybe Filter}
534+ deriving (Show, Eq)
535+
536+data AliasRouting = AllAliasRouting RoutingValue
537+ | GranularAliasRouting (Maybe SearchAliasRouting) (Maybe IndexAliasRouting)
538+ deriving (Show, Eq)
539+
540+newtype SearchAliasRouting = SearchAliasRouting (NonEmpty RoutingValue) deriving (Show, Eq)
541+
542+newtype IndexAliasRouting = IndexAliasRouting RoutingValue deriving (Show, Eq, ToJSON, FromJSON)
543+
544+newtype RoutingValue = RoutingValue { routingValue :: Text } deriving (Show, Eq, ToJSON, FromJSON)
545+
546+newtype IndexAliasesSummary = IndexAliasesSummary { indexAliasesSummary :: [IndexAliasSummary] } deriving (Show, Eq)
547+
548+{-| 'IndexAliasSummary' is a summary of an index alias configured for a server. -}
549+data IndexAliasSummary = IndexAliasSummary { indexAliasSummaryAlias :: IndexAlias
550+ , indexAliasSummaryCreate :: IndexAliasCreate} deriving (Show, Eq)
551+
552+{-| 'ExternalDocVersion' is a convenience wrapper if your code uses its
553+own version numbers instead of ones from ES.
554+-}
555+newtype ExternalDocVersion = ExternalDocVersion DocVersion
556+ deriving (Eq, Show, Ord, Bounded, Enum, ToJSON)
557+
558+{-| 'VersionControl' is specified when indexing documents as a
559+optimistic concurrency control.
560+-}
561+data VersionControl = NoVersionControl
562+ -- ^ Don't send a version. This is a pure overwrite.
563+ | InternalVersion DocVersion
564+ -- ^ Use the default ES versioning scheme. Only
565+ -- index the document if the version is the same
566+ -- as the one specified. Only applicable to
567+ -- updates, as you should be getting Version from
568+ -- a search result.
569+ | ExternalGT ExternalDocVersion
570+ -- ^ Use your own version numbering. Only index
571+ -- the document if the version is strictly higher
572+ -- OR the document doesn't exist. The given
573+ -- version will be used as the new version number
574+ -- for the stored document. N.B. All updates must
575+ -- increment this number, meaning there is some
576+ -- global, external ordering of updates.
577+ | ExternalGTE ExternalDocVersion
578+ -- ^ Use your own version numbering. Only index
579+ -- the document if the version is equal or higher
580+ -- than the stored version. Will succeed if there
581+ -- is no existing document. The given version will
582+ -- be used as the new version number for the
583+ -- stored document. Use with care, as this could
584+ -- result in data loss.
585+ | ForceVersion ExternalDocVersion
586+ -- ^ The document will always be indexed and the
587+ -- given version will be the new version. This is
588+ -- typically used for correcting errors. Use with
589+ -- care, as this could result in data loss.
590+ deriving (Show, Eq, Ord)
591+
592+{-| 'DocumentParent' is used to specify a parent document.
593+-}
594+newtype DocumentParent = DocumentParent DocId
595+ deriving (Eq, Show)
596+
597+{-| 'IndexDocumentSettings' are special settings supplied when indexing
598+a document. For the best backwards compatiblity when new fields are
599+added, you should probably prefer to start with 'defaultIndexDocumentSettings'
600+-}
601+data IndexDocumentSettings =
602+ IndexDocumentSettings { idsVersionControl :: VersionControl
603+ , idsParent :: Maybe DocumentParent
604+ } deriving (Eq, Show)
605+
606+{-| Reasonable default settings. Chooses no version control and no parent.
607+-}
608+defaultIndexDocumentSettings :: IndexDocumentSettings
609+defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing
610+
611+{-| 'IndexSelection' is used for APIs which take a single index, a list of
612+ indexes, or the special @_all@ index.
613+-}
614+--TODO: this does not fully support <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/multi-index.html multi-index syntax>. It wouldn't be too hard to implement but you'd have to add the optional parameters (ignore_unavailable, allow_no_indices, expand_wildcards) to any APIs using it. Also would be a breaking API.
615+data IndexSelection = IndexList (NonEmpty IndexName)
616+ | AllIndexes deriving (Eq, Show)
617+
618+{-| 'NodeSelection' is used for most cluster APIs. See <https://www.elastic.co/guide/en/elasticsearch/reference/current/cluster.html#cluster-nodes here> for more details.
619+-}
620+data NodeSelection = LocalNode
621+ -- ^ Whatever node receives this request
622+ | NodeList (NonEmpty NodeSelector)
623+ | AllNodes deriving (Eq, Show)
624+
625+
626+-- | An exact match or pattern to identify a node. Note that All of
627+-- these options support wildcarding, so your node name, server, attr
628+-- name can all contain * characters to be a fuzzy match.
629+data NodeSelector = NodeByName NodeName
630+ | NodeByFullNodeId FullNodeId
631+ | NodeByHost Server
632+ -- ^ e.g. 10.0.0.1 or even 10.0.0.*
633+ | NodeByAttribute NodeAttrName Text
634+ -- ^ NodeAttrName can be a pattern, e.g. rack*. The value can too.
635+ deriving (Eq, Show)
636+
637+-- | A human-readable node name that is supplied by the user in the
638+-- node config or automatically generated by Elasticsearch.
639+newtype NodeName = NodeName { nodeName :: Text }
640+ deriving (Eq, Ord, Show, FromJSON)
641+
642+-- | Unique, automatically-generated name assigned to nodes that are
643+-- usually returned in node-oriented APIs.
644+newtype FullNodeId = FullNodeId { fullNodeId :: Text }
645+ deriving (Eq, Ord, Show, FromJSON)
646+
647+-- | Username type used for HTTP Basic authentication. See 'basicAuthHook'.
648+newtype EsUsername = EsUsername { esUsername :: Text } deriving (Show, Eq)
649+
650+-- | Password type used for HTTP Basic authentication. See 'basicAuthHook'.
651+newtype EsPassword = EsPassword { esPassword :: Text } deriving (Show, Eq)
652+
653+data SnapshotRepoSelection = SnapshotRepoList (NonEmpty SnapshotRepoPattern)
654+ | AllSnapshotRepos deriving (Eq, Show)
655+
656+
657+-- | Either specifies an exact repo name or one with globs in it,
658+-- e.g. @RepoPattern "foo*"@ __NOTE__: Patterns are not supported on ES < 1.7
659+data SnapshotRepoPattern = ExactRepo SnapshotRepoName
660+ | RepoPattern Text
661+ deriving (Eq, Show)
662+
663+-- | The unique name of a snapshot repository.
664+newtype SnapshotRepoName = SnapshotRepoName { snapshotRepoName :: Text }
665+ deriving (Eq, Ord, Show, ToJSON, FromJSON)
666+
667+
668+-- | A generic representation of a snapshot repo. This is what gets
669+-- sent to and parsed from the server. For repo types enabled by
670+-- plugins that aren't exported by this library, consider making a
671+-- custom type which implements 'SnapshotRepo'. If it is a common repo
672+-- type, consider submitting a pull request to have it included in the
673+-- library proper
674+data GenericSnapshotRepo = GenericSnapshotRepo {
675+ gSnapshotRepoName :: SnapshotRepoName
676+ , gSnapshotRepoType :: SnapshotRepoType
677+ , gSnapshotRepoSettings :: GenericSnapshotRepoSettings
678+ } deriving (Eq, Show)
679+
680+-- | Law: fromGSnapshotRepo (toGSnapshotRepo r) == Right r
681+class SnapshotRepo r where
682+ toGSnapshotRepo :: r -> GenericSnapshotRepo
683+ fromGSnapshotRepo :: GenericSnapshotRepo -> Either SnapshotRepoConversionError r
684+
685+data SnapshotRepoConversionError = RepoTypeMismatch SnapshotRepoType SnapshotRepoType
686+ -- ^ Expected type and actual type
687+ | OtherRepoConversionError Text
688+ deriving (Show, Eq)
689+
690+instance SnapshotRepo GenericSnapshotRepo where
691+ toGSnapshotRepo = id
692+ fromGSnapshotRepo = Right
693+
694+
695+newtype SnapshotRepoType = SnapshotRepoType { snapshotRepoType :: Text }
696+ deriving (Eq, Ord, Show, ToJSON, FromJSON)
697+
698+
699+-- | Opaque representation of snapshot repo settings. Instances of
700+-- 'SnapshotRepo' will produce this.
701+newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings { gSnapshotRepoSettingsObject :: Object }
702+ deriving (Eq, Show, ToJSON)
703+
704+
705+ -- Regardless of whether you send strongly typed json, my version of
706+ -- ES sends back stringly typed json in the settings, e.g. booleans
707+ -- as strings, so we'll try to convert them.
708+instance FromJSON GenericSnapshotRepoSettings where
709+ parseJSON = fmap (GenericSnapshotRepoSettings . fmap unStringlyTypeJSON). parseJSON
710+
711+-- | The result of running 'verifySnapshotRepo'.
712+newtype SnapshotVerification = SnapshotVerification { snapshotNodeVerifications :: [SnapshotNodeVerification] }
713+ deriving (Eq, Show)
714+
715+
716+instance FromJSON SnapshotVerification where
717+ parseJSON = withObject "SnapshotVerification" parse
718+ where
719+ parse o = do
720+ o2 <- o .: "nodes"
721+ SnapshotVerification <$> mapM (uncurry parse') (HM.toList o2)
722+ parse' rawFullId = withObject "SnapshotNodeVerification" $ \o ->
723+ SnapshotNodeVerification (FullNodeId rawFullId) <$> o .: "name"
724+
725+
726+-- | A node that has verified a snapshot
727+data SnapshotNodeVerification = SnapshotNodeVerification {
728+ snvFullId :: FullNodeId
729+ , snvNodeName :: NodeName
730+ } deriving (Eq, Show)
731+
732+newtype ClusterName = ClusterName { clusterName :: Text }
733+ deriving (Eq, Ord, Show, FromJSON)
734+
735+data NodesInfo = NodesInfo {
736+ nodesInfo :: [NodeInfo]
737+ , nodesClusterName :: ClusterName
738+ } deriving (Eq, Show)
739+
740+instance FromJSON NodesInfo where
741+ parseJSON = withObject "NodesInfo" parse
742+ where
743+ parse o = do
744+ nodes <- o .: "nodes"
745+ infos <- forM (HM.toList nodes) $ \(fullNID, v) -> do
746+ node <- parseJSON v
747+ parseNodeInfo (FullNodeId fullNID) node
748+ cn <- o .: "cluster_name"
749+ return (NodesInfo infos cn)
750+
751+data NodesStats = NodesStats {
752+ nodesStats :: [NodeStats]
753+ , nodesStatsClusterName :: ClusterName
754+ } deriving (Eq, Show)
755+
756+data NodeStats = NodeStats {
757+ nodeStatsName :: NodeName
758+ , nodeStatsFullId :: FullNodeId
759+ , nodeStatsBreakersStats :: Maybe NodeBreakersStats
760+ , nodeStatsHTTP :: NodeHTTPStats
761+ , nodeStatsTransport :: NodeTransportStats
762+ , nodeStatsFS :: NodeFSStats
763+ , nodeStatsNetwork :: NodeNetworkStats
764+ , nodeStatsThreadPool :: NodeThreadPoolsStats
765+ , nodeStatsJVM :: NodeJVMStats
766+ , nodeStatsProcess :: NodeProcessStats
767+ , nodeStatsOS :: NodeOSStats
768+ , nodeStatsIndices :: NodeIndicesStats
769+ } deriving (Eq, Show)
770+
771+data NodeBreakersStats = NodeBreakersStats {
772+ nodeStatsParentBreaker :: NodeBreakerStats
773+ , nodeStatsRequestBreaker :: NodeBreakerStats
774+ , nodeStatsFieldDataBreaker :: NodeBreakerStats
775+ } deriving (Eq, Show)
776+
777+data NodeBreakerStats = NodeBreakerStats {
778+ nodeBreakersTripped :: Int
779+ , nodeBreakersOverhead :: Double
780+ , nodeBreakersEstSize :: Bytes
781+ , nodeBreakersLimitSize :: Bytes
782+ } deriving (Eq, Show)
783+
784+data NodeHTTPStats = NodeHTTPStats {
785+ nodeHTTPTotalOpened :: Int
786+ , nodeHTTPCurrentOpen :: Int
787+ } deriving (Eq, Show)
788+
789+data NodeTransportStats = NodeTransportStats {
790+ nodeTransportTXSize :: Bytes
791+ , nodeTransportCount :: Int
792+ , nodeTransportRXSize :: Bytes
793+ , nodeTransportRXCount :: Int
794+ , nodeTransportServerOpen :: Int
795+ } deriving (Eq, Show)
796+
797+data NodeFSStats = NodeFSStats {
798+ nodeFSDataPaths :: [NodeDataPathStats]
799+ , nodeFSTotal :: NodeFSTotalStats
800+ , nodeFSTimestamp :: UTCTime
801+ } deriving (Eq, Show)
802+
803+data NodeDataPathStats = NodeDataPathStats {
804+ nodeDataPathDiskServiceTime :: Maybe Double
805+ , nodeDataPathDiskQueue :: Maybe Double
806+ , nodeDataPathIOSize :: Maybe Bytes
807+ , nodeDataPathWriteSize :: Maybe Bytes
808+ , nodeDataPathReadSize :: Maybe Bytes
809+ , nodeDataPathIOOps :: Maybe Int
810+ , nodeDataPathWrites :: Maybe Int
811+ , nodeDataPathReads :: Maybe Int
812+ , nodeDataPathAvailable :: Bytes
813+ , nodeDataPathFree :: Bytes
814+ , nodeDataPathTotal :: Bytes
815+ , nodeDataPathType :: Maybe Text
816+ , nodeDataPathDevice :: Text
817+ , nodeDataPathMount :: Text
818+ , nodeDataPathPath :: Text
819+ } deriving (Eq, Show)
820+
821+data NodeFSTotalStats = NodeFSTotalStats {
822+ nodeFSTotalDiskServiceTime :: Maybe Double
823+ , nodeFSTotalDiskQueue :: Maybe Double
824+ , nodeFSTotalIOSize :: Maybe Bytes
825+ , nodeFSTotalWriteSize :: Maybe Bytes
826+ , nodeFSTotalReadSize :: Maybe Bytes
827+ , nodeFSTotalIOOps :: Maybe Int
828+ , nodeFSTotalWrites :: Maybe Int
829+ , nodeFSTotalReads :: Maybe Int
830+ , nodeFSTotalAvailable :: Bytes
831+ , nodeFSTotalFree :: Bytes
832+ , nodeFSTotalTotal :: Bytes
833+ } deriving (Eq, Show)
834+
835+data NodeNetworkStats = NodeNetworkStats {
836+ nodeNetTCPOutRSTs :: Int
837+ , nodeNetTCPInErrs :: Int
838+ , nodeNetTCPAttemptFails :: Int
839+ , nodeNetTCPEstabResets :: Int
840+ , nodeNetTCPRetransSegs :: Int
841+ , nodeNetTCPOutSegs :: Int
842+ , nodeNetTCPInSegs :: Int
843+ , nodeNetTCPCurrEstab :: Int
844+ , nodeNetTCPPassiveOpens :: Int
845+ , nodeNetTCPActiveOpens :: Int
846+ } deriving (Eq, Show)
847+
848+data NodeThreadPoolsStats = NodeThreadPoolsStats {
849+ nodeThreadPoolsStatsSnapshot :: NodeThreadPoolStats
850+ , nodeThreadPoolsStatsBulk :: NodeThreadPoolStats
851+ , nodeThreadPoolsStatsMerge :: NodeThreadPoolStats
852+ , nodeThreadPoolsStatsGet :: NodeThreadPoolStats
853+ , nodeThreadPoolsStatsManagement :: NodeThreadPoolStats
854+ , nodeThreadPoolsStatsFetchShardStore :: Maybe NodeThreadPoolStats
855+ , nodeThreadPoolsStatsOptimize :: NodeThreadPoolStats
856+ , nodeThreadPoolsStatsFlush :: NodeThreadPoolStats
857+ , nodeThreadPoolsStatsSearch :: NodeThreadPoolStats
858+ , nodeThreadPoolsStatsWarmer :: NodeThreadPoolStats
859+ , nodeThreadPoolsStatsGeneric :: NodeThreadPoolStats
860+ , nodeThreadPoolsStatsSuggest :: NodeThreadPoolStats
861+ , nodeThreadPoolsStatsRefresh :: NodeThreadPoolStats
862+ , nodeThreadPoolsStatsIndex :: NodeThreadPoolStats
863+ , nodeThreadPoolsStatsListener :: Maybe NodeThreadPoolStats
864+ , nodeThreadPoolsStatsFetchShardStarted :: Maybe NodeThreadPoolStats
865+ , nodeThreadPoolsStatsPercolate :: NodeThreadPoolStats
866+ } deriving (Eq, Show)
867+
868+data NodeThreadPoolStats = NodeThreadPoolStats {
869+ nodeThreadPoolCompleted :: Int
870+ , nodeThreadPoolLargest :: Int
871+ , nodeThreadPoolRejected :: Int
872+ , nodeThreadPoolActive :: Int
873+ , nodeThreadPoolQueue :: Int
874+ , nodeThreadPoolThreads :: Int
875+ } deriving (Eq, Show)
876+
877+data NodeJVMStats = NodeJVMStats {
878+ nodeJVMStatsMappedBufferPool :: JVMBufferPoolStats
879+ , nodeJVMStatsDirectBufferPool :: JVMBufferPoolStats
880+ , nodeJVMStatsGCOldCollector :: JVMGCStats
881+ , nodeJVMStatsGCYoungCollector :: JVMGCStats
882+ , nodeJVMStatsPeakThreadsCount :: Int
883+ , nodeJVMStatsThreadsCount :: Int
884+ , nodeJVMStatsOldPool :: JVMPoolStats
885+ , nodeJVMStatsSurvivorPool :: JVMPoolStats
886+ , nodeJVMStatsYoungPool :: JVMPoolStats
887+ , nodeJVMStatsNonHeapCommitted :: Bytes
888+ , nodeJVMStatsNonHeapUsed :: Bytes
889+ , nodeJVMStatsHeapMax :: Bytes
890+ , nodeJVMStatsHeapCommitted :: Bytes
891+ , nodeJVMStatsHeapUsedPercent :: Int
892+ , nodeJVMStatsHeapUsed :: Bytes
893+ , nodeJVMStatsUptime :: NominalDiffTime
894+ , nodeJVMStatsTimestamp :: UTCTime
895+ } deriving (Eq, Show)
896+
897+data JVMBufferPoolStats = JVMBufferPoolStats {
898+ jvmBufferPoolStatsTotalCapacity :: Bytes
899+ , jvmBufferPoolStatsUsed :: Bytes
900+ , jvmBufferPoolStatsCount :: Int
901+ } deriving (Eq, Show)
902+
903+data JVMGCStats = JVMGCStats {
904+ jvmGCStatsCollectionTime :: NominalDiffTime
905+ , jvmGCStatsCollectionCount :: Int
906+ } deriving (Eq, Show)
907+
908+data JVMPoolStats = JVMPoolStats {
909+ jvmPoolStatsPeakMax :: Bytes
910+ , jvmPoolStatsPeakUsed :: Bytes
911+ , jvmPoolStatsMax :: Bytes
912+ , jvmPoolStatsUsed :: Bytes
913+ } deriving (Eq, Show)
914+
915+data NodeProcessStats = NodeProcessStats {
916+ nodeProcessMemTotalVirtual :: Bytes
917+ , nodeProcessMemShare :: Bytes
918+ , nodeProcessMemResident :: Bytes
919+ , nodeProcessCPUTotal :: NominalDiffTime
920+ , nodeProcessCPUUser :: NominalDiffTime
921+ , nodeProcessCPUSys :: NominalDiffTime
922+ , nodeProcessCPUPercent :: Int
923+ , nodeProcessOpenFDs :: Int
924+ , nodeProcessTimestamp :: UTCTime
925+ } deriving (Eq, Show)
926+
927+data NodeOSStats = NodeOSStats {
928+ nodeOSSwapFree :: Bytes
929+ , nodeOSSwapUsed :: Bytes
930+ , nodeOSMemActualUsed :: Bytes
931+ , nodeOSMemActualFree :: Bytes
932+ , nodeOSMemUsedPercent :: Int
933+ , nodeOSMemFreePercent :: Int
934+ , nodeOSMemUsed :: Bytes
935+ , nodeOSMemFree :: Bytes
936+ , nodeOSCPUStolen :: Int
937+ , nodeOSCPUUsage :: Int
938+ , nodeOSCPUIdle :: Int
939+ , nodeOSCPUUser :: Int
940+ , nodeOSCPUSys :: Int
941+ , nodeOSLoad :: Maybe LoadAvgs
942+ , nodeOSUptime :: NominalDiffTime
943+ , nodeOSTimestamp :: UTCTime
944+ } deriving (Eq, Show)
945+
946+data LoadAvgs = LoadAvgs {
947+ loadAvg1Min :: Double
948+ , loadAvg5Min :: Double
949+ , loadAvg15Min :: Double
950+ } deriving (Eq, Show)
951+
952+data NodeIndicesStats = NodeIndicesStats {
953+ nodeIndicesStatsRecoveryThrottleTime :: Maybe NominalDiffTime
954+ , nodeIndicesStatsRecoveryCurrentAsTarget :: Maybe Int
955+ , nodeIndicesStatsRecoveryCurrentAsSource :: Maybe Int
956+ , nodeIndicesStatsQueryCacheMisses :: Maybe Int
957+ , nodeIndicesStatsQueryCacheHits :: Maybe Int
958+ , nodeIndicesStatsQueryCacheEvictions :: Maybe Int
959+ , nodeIndicesStatsQueryCacheSize :: Maybe Bytes
960+ , nodeIndicesStatsSuggestCurrent :: Int
961+ , nodeIndicesStatsSuggestTime :: NominalDiffTime
962+ , nodeIndicesStatsSuggestTotal :: Int
963+ , nodeIndicesStatsTranslogSize :: Bytes
964+ , nodeIndicesStatsTranslogOps :: Int
965+ , nodeIndicesStatsSegFixedBitSetMemory :: Maybe Bytes
966+ , nodeIndicesStatsSegVersionMapMemory :: Bytes
967+ , nodeIndicesStatsSegIndexWriterMaxMemory :: Maybe Bytes
968+ , nodeIndicesStatsSegIndexWriterMemory :: Bytes
969+ , nodeIndicesStatsSegMemory :: Bytes
970+ , nodeIndicesStatsSegCount :: Int
971+ , nodeIndicesStatsCompletionSize :: Bytes
972+ , nodeIndicesStatsPercolateQueries :: Int
973+ , nodeIndicesStatsPercolateMemory :: Bytes
974+ , nodeIndicesStatsPercolateCurrent :: Int
975+ , nodeIndicesStatsPercolateTime :: NominalDiffTime
976+ , nodeIndicesStatsPercolateTotal :: Int
977+ , nodeIndicesStatsFieldDataEvictions :: Int
978+ , nodeIndicesStatsFieldDataMemory :: Bytes
979+ , nodeIndicesStatsIDCacheMemory :: Bytes
980+ , nodeIndicesStatsFilterCacheEvictions :: Int
981+ , nodeIndicesStatsFilterCacheMemory :: Bytes
982+ , nodeIndicesStatsWarmerTotalTime :: NominalDiffTime
983+ , nodeIndicesStatsWarmerTotal :: Int
984+ , nodeIndicesStatsWarmerCurrent :: Int
985+ , nodeIndicesStatsFlushTotalTime :: NominalDiffTime
986+ , nodeIndicesStatsFlushTotal :: Int
987+ , nodeIndicesStatsRefreshTotalTime :: NominalDiffTime
988+ , nodeIndicesStatsRefreshTotal :: Int
989+ , nodeIndicesStatsMergesTotalSize :: Bytes
990+ , nodeIndicesStatsMergesTotalDocs :: Int
991+ , nodeIndicesStatsMergesTotalTime :: NominalDiffTime
992+ , nodeIndicesStatsMergesTotal :: Int
993+ , nodeIndicesStatsMergesCurrentSize :: Bytes
994+ , nodeIndicesStatsMergesCurrentDocs :: Int
995+ , nodeIndicesStatsMergesCurrent :: Int
996+ , nodeIndicesStatsSearchFetchCurrent :: Int
997+ , nodeIndicesStatsSearchFetchTime :: NominalDiffTime
998+ , nodeIndicesStatsSearchFetchTotal :: Int
999+ , nodeIndicesStatsSearchQueryCurrent :: Int
1000+ , nodeIndicesStatsSearchQueryTime :: NominalDiffTime
1001+ , nodeIndicesStatsSearchQueryTotal :: Int
1002+ , nodeIndicesStatsSearchOpenContexts :: Int
1003+ , nodeIndicesStatsGetCurrent :: Int
1004+ , nodeIndicesStatsGetMissingTime :: NominalDiffTime
1005+ , nodeIndicesStatsGetMissingTotal :: Int
1006+ , nodeIndicesStatsGetExistsTime :: NominalDiffTime
1007+ , nodeIndicesStatsGetExistsTotal :: Int
1008+ , nodeIndicesStatsGetTime :: NominalDiffTime
1009+ , nodeIndicesStatsGetTotal :: Int
1010+ , nodeIndicesStatsIndexingThrottleTime :: Maybe NominalDiffTime
1011+ , nodeIndicesStatsIndexingIsThrottled :: Maybe Bool
1012+ , nodeIndicesStatsIndexingNoopUpdateTotal :: Maybe Int
1013+ , nodeIndicesStatsIndexingDeleteCurrent :: Int
1014+ , nodeIndicesStatsIndexingDeleteTime :: NominalDiffTime
1015+ , nodeIndicesStatsIndexingDeleteTotal :: Int
1016+ , nodeIndicesStatsIndexingIndexCurrent :: Int
1017+ , nodeIndicesStatsIndexingIndexTime :: NominalDiffTime
1018+ , nodeIndicesStatsIndexingTotal :: Int
1019+ , nodeIndicesStatsStoreThrottleTime :: NominalDiffTime
1020+ , nodeIndicesStatsStoreSize :: Bytes
1021+ , nodeIndicesStatsDocsDeleted :: Int
1022+ , nodeIndicesStatsDocsCount :: Int
1023+ } deriving (Eq, Show)
1024+
1025+data NodeInfo = NodeInfo {
1026+ nodeInfoHTTPAddress :: EsAddress
1027+ , nodeInfoBuild :: BuildHash
1028+ , nodeInfoESVersion :: VersionNumber
1029+ , nodeInfoIP :: Server
1030+ , nodeInfoHost :: Server
1031+ , nodeInfoTransportAddress :: EsAddress
1032+ , nodeInfoName :: NodeName
1033+ , nodeInfoFullId :: FullNodeId
1034+ , nodeInfoPlugins :: [NodePluginInfo]
1035+ , nodeInfoHTTP :: NodeHTTPInfo
1036+ , nodeInfoTransport :: NodeTransportInfo
1037+ , nodeInfoNetwork :: NodeNetworkInfo
1038+ , nodeInfoThreadPool :: NodeThreadPoolsInfo
1039+ , nodeInfoJVM :: NodeJVMInfo
1040+ , nodeInfoProcess :: NodeProcessInfo
1041+ , nodeInfoOS :: NodeOSInfo
1042+ , nodeInfoSettings :: Object
1043+ -- ^ The members of the settings objects are not consistent,
1044+ -- dependent on plugins, etc.
1045+ } deriving (Eq, Show)
1046+
1047+data NodePluginInfo = NodePluginInfo {
1048+ nodePluginSite :: Bool
1049+ -- ^ Is this a site plugin?
1050+ , nodePluginJVM :: Bool
1051+ -- ^ Is this plugin running on the JVM
1052+ , nodePluginDescription :: Text
1053+ , nodePluginVersion :: MaybeNA VersionNumber
1054+ , nodePluginName :: PluginName
1055+ } deriving (Eq, Show)
1056+
1057+data NodeHTTPInfo = NodeHTTPInfo {
1058+ nodeHTTPMaxContentLength :: Bytes
1059+ , nodeHTTPTransportAddress :: BoundTransportAddress
1060+ } deriving (Eq, Show)
1061+
1062+data NodeTransportInfo = NodeTransportInfo {
1063+ nodeTransportProfiles :: [BoundTransportAddress]
1064+ , nodeTransportAddress :: BoundTransportAddress
1065+ } deriving (Eq, Show)
1066+
1067+data BoundTransportAddress = BoundTransportAddress {
1068+ publishAddress :: EsAddress
1069+ , boundAddress :: EsAddress
1070+ } deriving (Eq, Show)
1071+
1072+data NodeNetworkInfo = NodeNetworkInfo {
1073+ nodeNetworkPrimaryInterface :: NodeNetworkInterface
1074+ , nodeNetworkRefreshInterval :: NominalDiffTime
1075+ } deriving (Eq, Show)
1076+
1077+newtype MacAddress = MacAddress { macAddress :: Text }
1078+ deriving (Eq, Ord, Show, FromJSON)
1079+
1080+newtype NetworkInterfaceName = NetworkInterfaceName { networkInterfaceName :: Text }
1081+ deriving (Eq, Ord, Show, FromJSON)
1082+
1083+data NodeNetworkInterface = NodeNetworkInterface {
1084+ nodeNetIfaceMacAddress :: MacAddress
1085+ , nodeNetIfaceName :: NetworkInterfaceName
1086+ , nodeNetIfaceAddress :: Server
1087+ } deriving (Eq, Show)
1088+
1089+data NodeThreadPoolsInfo = NodeThreadPoolsInfo {
1090+ nodeThreadPoolsRefresh :: NodeThreadPoolInfo
1091+ , nodeThreadPoolsManagement :: NodeThreadPoolInfo
1092+ , nodeThreadPoolsPercolate :: NodeThreadPoolInfo
1093+ , nodeThreadPoolsListener :: Maybe NodeThreadPoolInfo
1094+ , nodeThreadPoolsFetchShardStarted :: Maybe NodeThreadPoolInfo
1095+ , nodeThreadPoolsSearch :: NodeThreadPoolInfo
1096+ , nodeThreadPoolsFlush :: NodeThreadPoolInfo
1097+ , nodeThreadPoolsWarmer :: NodeThreadPoolInfo
1098+ , nodeThreadPoolsOptimize :: NodeThreadPoolInfo
1099+ , nodeThreadPoolsBulk :: NodeThreadPoolInfo
1100+ , nodeThreadPoolsSuggest :: NodeThreadPoolInfo
1101+ , nodeThreadPoolsMerge :: NodeThreadPoolInfo
1102+ , nodeThreadPoolsSnapshot :: NodeThreadPoolInfo
1103+ , nodeThreadPoolsGet :: NodeThreadPoolInfo
1104+ , nodeThreadPoolsFetchShardStore :: Maybe NodeThreadPoolInfo
1105+ , nodeThreadPoolsIndex :: NodeThreadPoolInfo
1106+ , nodeThreadPoolsGeneric :: NodeThreadPoolInfo
1107+ } deriving (Eq, Show)
1108+
1109+data NodeThreadPoolInfo = NodeThreadPoolInfo {
1110+ nodeThreadPoolQueueSize :: ThreadPoolSize
1111+ , nodeThreadPoolKeepalive :: Maybe NominalDiffTime
1112+ , nodeThreadPoolMin :: Maybe Int
1113+ , nodeThreadPoolMax :: Maybe Int
1114+ , nodeThreadPoolType :: ThreadPoolType
1115+ } deriving (Eq, Show)
1116+
1117+data ThreadPoolSize = ThreadPoolBounded Int
1118+ | ThreadPoolUnbounded
1119+ deriving (Eq, Show)
1120+
1121+data ThreadPoolType = ThreadPoolScaling
1122+ | ThreadPoolFixed
1123+ | ThreadPoolCached
1124+ deriving (Eq, Show)
1125+
1126+data NodeJVMInfo = NodeJVMInfo {
1127+ nodeJVMInfoMemoryPools :: [JVMMemoryPool]
1128+ , nodeJVMInfoMemoryPoolsGCCollectors :: [JVMGCCollector]
1129+ , nodeJVMInfoMemoryInfo :: JVMMemoryInfo
1130+ , nodeJVMInfoStartTime :: UTCTime
1131+ , nodeJVMInfoVMVendor :: Text
1132+ , nodeJVMVMVersion :: VersionNumber
1133+ -- ^ JVM doesn't seme to follow normal version conventions
1134+ , nodeJVMVMName :: Text
1135+ , nodeJVMVersion :: VersionNumber
1136+ , nodeJVMPID :: PID
1137+ } deriving (Eq, Show)
1138+
1139+-- | Handles quirks in the way JVM versions are rendered (1.7.0_101 -> 1.7.0.101)
1140+newtype JVMVersion = JVMVersion { unJVMVersion :: VersionNumber }
1141+
1142+data JVMMemoryInfo = JVMMemoryInfo {
1143+ jvmMemoryInfoDirectMax :: Bytes
1144+ , jvmMemoryInfoNonHeapMax :: Bytes
1145+ , jvmMemoryInfoNonHeapInit :: Bytes
1146+ , jvmMemoryInfoHeapMax :: Bytes
1147+ , jvmMemoryInfoHeapInit :: Bytes
1148+ } deriving (Eq, Show)
1149+
1150+newtype JVMMemoryPool = JVMMemoryPool {
1151+ jvmMemoryPool :: Text
1152+ } deriving (Eq, Show, FromJSON)
1153+
1154+newtype JVMGCCollector = JVMGCCollector {
1155+ jvmGCCollector :: Text
1156+ } deriving (Eq, Show, FromJSON)
1157+
1158+newtype PID = PID {
1159+ pid :: Int
1160+ } deriving (Eq, Show, FromJSON)
1161+
1162+data NodeOSInfo = NodeOSInfo {
1163+ nodeOSSwap :: Bytes
1164+ , nodeOSMem :: Bytes
1165+ , nodeOSCPUInfo :: CPUInfo
1166+ , nodeOSAvailableProcessors :: Int
1167+ , nodeOSRefreshInterval :: NominalDiffTime
1168+ } deriving (Eq, Show)
1169+
1170+data CPUInfo = CPUInfo {
1171+ cpuCacheSize :: Bytes
1172+ , cpuCoresPerSocket :: Int
1173+ , cpuTotalSockets :: Int
1174+ , cpuTotalCores :: Int
1175+ , cpuMHZ :: Int
1176+ , cpuModel :: Text
1177+ , cpuVendor :: Text
1178+ } deriving (Eq, Show)
1179+
1180+data NodeProcessInfo = NodeProcessInfo {
1181+ nodeProcessMLockAll :: Bool
1182+ -- ^ See <https://www.elastic.co/guide/en/elasticsearch/reference/current/setup-configuration.html>
1183+ , nodeProcessMaxFileDescriptors :: Int
1184+ , nodeProcessId :: PID
1185+ , nodeProcessRefreshInterval :: NominalDiffTime
1186+ } deriving (Eq, Show)
1187+
1188+-- | A quirky address format used throughout Elasticsearch. An example
1189+-- would be inet[/1.1.1.1:9200]. inet may be a placeholder for a
1190+-- <https://en.wikipedia.org/wiki/Fully_qualified_domain_name FQDN>.
1191+newtype EsAddress = EsAddress { esAddress :: Text }
1192+ deriving (Eq, Ord, Show, FromJSON)
1193+
1194+newtype PluginName = PluginName { pluginName :: Text }
1195+ deriving (Eq, Ord, Show, FromJSON)
1196+
1197+data ShardResult =
1198+ ShardResult { shardTotal :: Int
1199+ , shardsSuccessful :: Int
1200+ , shardsFailed :: Int } deriving (Eq, Show)
1201+
1202+data SnapshotState = SnapshotInit
1203+ | SnapshotStarted
1204+ | SnapshotSuccess
1205+ | SnapshotFailed
1206+ | SnapshotAborted
1207+ | SnapshotMissing
1208+ | SnapshotWaiting
1209+ deriving (Show, Eq)
1210+
1211+instance FromJSON SnapshotState where
1212+ parseJSON = withText "SnapshotState" parse
1213+ where
1214+ parse "INIT" = return SnapshotInit
1215+ parse "STARTED" = return SnapshotStarted
1216+ parse "SUCCESS" = return SnapshotSuccess
1217+ parse "FAILED" = return SnapshotFailed
1218+ parse "ABORTED" = return SnapshotAborted
1219+ parse "MISSING" = return SnapshotMissing
1220+ parse "WAITING" = return SnapshotWaiting
1221+ parse t = fail ("Invalid snapshot state " <> T.unpack t)
1222+
1223+data SnapshotRestoreSettings = SnapshotRestoreSettings {
1224+ snapRestoreWaitForCompletion :: Bool
1225+ -- ^ Should the API call return immediately after initializing
1226+ -- the restore or wait until completed? Note that if this is
1227+ -- enabled, it could wait a long time, so you should adjust your
1228+ -- 'ManagerSettings' accordingly to set long timeouts or
1229+ -- explicitly handle timeouts.
1230+ , snapRestoreIndices :: Maybe IndexSelection
1231+ -- ^ Nothing will restore all indices in the snapshot. Just [] is
1232+ -- permissable and will essentially be a no-op restore.
1233+ , snapRestoreIgnoreUnavailable :: Bool
1234+ -- ^ If set to True, any indices that do not exist will be ignored
1235+ -- during snapshot rather than failing the restore.
1236+ , snapRestoreIncludeGlobalState :: Bool
1237+ -- ^ If set to false, will ignore any global state in the snapshot
1238+ -- and will not restore it.
1239+ , snapRestoreRenamePattern :: Maybe RestoreRenamePattern
1240+ -- ^ A regex pattern for matching indices. Used with
1241+ -- 'snapRestoreRenameReplacement', the restore can reference the
1242+ -- matched index and create a new index name upon restore.
1243+ , snapRestoreRenameReplacement :: Maybe (NonEmpty RestoreRenameToken)
1244+ -- ^ Expression of how index renames should be constructed.
1245+ , snapRestorePartial :: Bool
1246+ -- ^ If some indices fail to restore, should the process proceed?
1247+ , snapRestoreIncludeAliases :: Bool
1248+ -- ^ Should the restore also restore the aliases captured in the
1249+ -- snapshot.
1250+ , snapRestoreIndexSettingsOverrides :: Maybe RestoreIndexSettings
1251+ -- ^ Settings to apply during the restore process. __NOTE:__ This
1252+ -- option is not supported in ES < 1.5 and should be set to
1253+ -- Nothing in that case.
1254+ , snapRestoreIgnoreIndexSettings :: Maybe (NonEmpty Text)
1255+ -- ^ This type could be more rich but it isn't clear which
1256+ -- settings are allowed to be ignored during restore, so we're
1257+ -- going with including this feature in a basic form rather than
1258+ -- omitting it. One example here would be
1259+ -- "index.refresh_interval". Any setting specified here will
1260+ -- revert back to the server default during the restore process.
1261+ } deriving (Eq, Show)
1262+
1263+-- | Regex-stype pattern, e.g. "index_(.+)" to match index names
1264+newtype RestoreRenamePattern = RestoreRenamePattern { rrPattern :: Text }
1265+ deriving (Show, Eq, Ord, ToJSON)
1266+
1267+
1268+-- | A single token in a index renaming scheme for a restore. These
1269+-- are concatenated into a string before being sent to
1270+-- Elasticsearch. Check out these Java
1271+-- <https://docs.oracle.com/javase/7/docs/api/java/util/regex/Matcher.html docs> to find out more if you're into that sort of thing.
1272+data RestoreRenameToken = RRTLit Text
1273+ -- ^ Just a literal string of characters
1274+ | RRSubWholeMatch
1275+ -- ^ Equivalent to $0. The entire matched pattern, not any subgroup
1276+ | RRSubGroup RRGroupRefNum
1277+ -- ^ A specific reference to a group number
1278+ deriving (Show, Eq)
1279+
1280+
1281+-- | A group number for regex matching. Only values from 1-9 are
1282+-- supported. Construct with 'mkRRGroupRefNum'
1283+newtype RRGroupRefNum = RRGroupRefNum { rrGroupRefNum :: Int }
1284+ deriving (Show, Eq, Ord)
1285+
1286+instance Bounded RRGroupRefNum where
1287+ minBound = RRGroupRefNum 1
1288+ maxBound = RRGroupRefNum 9
1289+
1290+
1291+-- | Only allows valid group number references (1-9).
1292+mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum
1293+mkRRGroupRefNum i
1294+ | i >= (rrGroupRefNum minBound) && i <= (rrGroupRefNum maxBound) =
1295+ Just $ RRGroupRefNum i
1296+ | otherwise = Nothing
1297+
1298+-- | Index settings that can be overridden. The docs only mention you
1299+-- can update number of replicas, but there may be more. You
1300+-- definitely cannot override shard count.
1301+data RestoreIndexSettings = RestoreIndexSettings {
1302+ restoreOverrideReplicas :: Maybe ReplicaCount
1303+ } deriving (Show, Eq)
1304+
1305+instance ToJSON RestoreIndexSettings where
1306+ toJSON RestoreIndexSettings {..} = object prs
1307+ where
1308+ prs = catMaybes [("index.number_of_replicas" .=) <$> restoreOverrideReplicas]
1309+
1310+data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings {
1311+ repoUpdateVerify :: Bool
1312+ -- ^ After creation/update, synchronously check that nodes can
1313+ -- write to this repo. Defaults to True. You may use False if you
1314+ -- need a faster response and plan on verifying manually later
1315+ -- with 'verifySnapshotRepo'.
1316+ } deriving (Eq, Show)
1317+
1318+-- | Reasonable defaults for repo creation/update
1319+--
1320+-- * repoUpdateVerify True
1321+defaultSnapshotRepoUpdateSettings :: SnapshotRepoUpdateSettings
1322+defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True
1323+
1324+-- | A filesystem-based snapshot repo that ships with
1325+-- Elasticsearch. This is an instance of 'SnapshotRepo' so it can be
1326+-- used with 'updateSnapshotRepo'
1327+data FsSnapshotRepo = FsSnapshotRepo {
1328+ fsrName :: SnapshotRepoName
1329+ , fsrLocation :: FilePath
1330+ , fsrCompressMetadata :: Bool
1331+ , fsrChunkSize :: Maybe Bytes
1332+ -- ^ Size by which to split large files during snapshotting.
1333+ , fsrMaxRestoreBytesPerSec :: Maybe Bytes
1334+ -- ^ Throttle node restore rate. If not supplied, defaults to 40mb/sec
1335+ , fsrMaxSnapshotBytesPerSec :: Maybe Bytes
1336+ -- ^ Throttle node snapshot rate. If not supplied, defaults to 40mb/sec
1337+ } deriving (Eq, Show)
1338+
1339+instance SnapshotRepo FsSnapshotRepo where
1340+ toGSnapshotRepo FsSnapshotRepo {..} =
1341+ GenericSnapshotRepo fsrName fsRepoType (GenericSnapshotRepoSettings settings)
1342+ where
1343+ Object settings = object $ [ "location" .= fsrLocation
1344+ , "compress" .= fsrCompressMetadata
1345+ ] ++ optionalPairs
1346+ optionalPairs = catMaybes [ ("chunk_size" .=) <$> fsrChunkSize
1347+ , ("max_restore_bytes_per_sec" .=) <$> fsrMaxRestoreBytesPerSec
1348+ , ("max_snapshot_bytes_per_sec" .=) <$> fsrMaxSnapshotBytesPerSec
1349+ ]
1350+ fromGSnapshotRepo GenericSnapshotRepo {..}
1351+ | gSnapshotRepoType == fsRepoType = do
1352+ let o = gSnapshotRepoSettingsObject gSnapshotRepoSettings
1353+ parseRepo $ do
1354+ FsSnapshotRepo gSnapshotRepoName <$> o .: "location"
1355+ <*> o .:? "compress" .!= False
1356+ <*> o .:? "chunk_size"
1357+ <*> o .:? "max_restore_bytes_per_sec"
1358+ <*> o .:? "max_snapshot_bytes_per_sec"
1359+ | otherwise = Left (RepoTypeMismatch fsRepoType gSnapshotRepoType)
1360+
1361+data SnapshotCreateSettings = SnapshotCreateSettings {
1362+ snapWaitForCompletion :: Bool
1363+ -- ^ Should the API call return immediately after initializing
1364+ -- the snapshot or wait until completed? Note that if this is
1365+ -- enabled it could wait a long time, so you should adjust your
1366+ -- 'ManagerSettings' accordingly to set long timeouts or
1367+ -- explicitly handle timeouts.
1368+ , snapIndices :: Maybe IndexSelection
1369+ -- ^ Nothing will snapshot all indices. Just [] is permissable and
1370+ -- will essentially be a no-op snapshot.
1371+ , snapIgnoreUnavailable :: Bool
1372+ -- ^ If set to True, any matched indices that don't exist will be
1373+ -- ignored. Otherwise it will be an error and fail.
1374+ , snapIncludeGlobalState :: Bool
1375+ , snapPartial :: Bool
1376+ -- ^ If some indices failed to snapshot (e.g. if not all primary
1377+ -- shards are available), should the process proceed?
1378+ } deriving (Eq, Show)
1379+
1380+-- | Reasonable defaults for snapshot creation
1381+--
1382+-- * snapWaitForCompletion False
1383+-- * snapIndices Nothing
1384+-- * snapIgnoreUnavailable False
1385+-- * snapIncludeGlobalState True
1386+-- * snapPartial False
1387+defaultSnapshotCreateSettings :: SnapshotCreateSettings
1388+defaultSnapshotCreateSettings = SnapshotCreateSettings {
1389+ snapWaitForCompletion = False
1390+ , snapIndices = Nothing
1391+ , snapIgnoreUnavailable = False
1392+ , snapIncludeGlobalState = True
1393+ , snapPartial = False
1394+ }
1395+
1396+
1397+data SnapshotSelection = SnapshotList (NonEmpty SnapshotPattern)
1398+ | AllSnapshots deriving (Eq, Show)
1399+
1400+
1401+-- | Either specifies an exact snapshot name or one with globs in it,
1402+-- e.g. @SnapPattern "foo*"@ __NOTE__: Patterns are not supported on
1403+-- ES < 1.7
1404+data SnapshotPattern = ExactSnap SnapshotName
1405+ | SnapPattern Text
1406+ deriving (Eq, Show)
1407+
1408+
1409+-- | General information about the state of a snapshot. Has some
1410+-- redundancies with 'SnapshotStatus'
1411+data SnapshotInfo = SnapshotInfo {
1412+ snapInfoShards :: ShardResult
1413+ , snapInfoFailures :: [SnapshotShardFailure]
1414+ , snapInfoDuration :: NominalDiffTime
1415+ , snapInfoEndTime :: UTCTime
1416+ , snapInfoStartTime :: UTCTime
1417+ , snapInfoState :: SnapshotState
1418+ , snapInfoIndices :: [IndexName]
1419+ , snapInfoName :: SnapshotName
1420+ } deriving (Eq, Show)
1421+
1422+
1423+instance FromJSON SnapshotInfo where
1424+ parseJSON = withObject "SnapshotInfo" parse
1425+ where
1426+ parse o = SnapshotInfo <$> o .: "shards"
1427+ <*> o .: "failures"
1428+ <*> (unMS <$> o .: "duration_in_millis")
1429+ <*> (posixMS <$> o .: "end_time_in_millis")
1430+ <*> (posixMS <$> o .: "start_time_in_millis")
1431+ <*> o .: "state"
1432+ <*> o .: "indices"
1433+ <*> o .: "snapshot"
1434+
1435+data SnapshotShardFailure = SnapshotShardFailure {
1436+ snapShardFailureIndex :: IndexName
1437+ , snapShardFailureNodeId :: Maybe NodeName -- I'm not 100% sure this isn't actually 'FullNodeId'
1438+ , snapShardFailureReason :: Text
1439+ , snapShardFailureShardId :: ShardId
1440+ } deriving (Eq, Show)
1441+
1442+
1443+instance FromJSON SnapshotShardFailure where
1444+ parseJSON = withObject "SnapshotShardFailure" parse
1445+ where
1446+ parse o = SnapshotShardFailure <$> o .: "index"
1447+ <*> o .:? "node_id"
1448+ <*> o .: "reason"
1449+ <*> o .: "shard_id"
1450+
1451+parseRepo :: Parser a -> Either SnapshotRepoConversionError a
1452+parseRepo parser = case parseEither (const parser) () of
1453+ Left e -> Left (OtherRepoConversionError (T.pack e))
1454+ Right a -> Right a
1455+
1456+parseNodeStats :: FullNodeId -> Object -> Parser NodeStats
1457+parseNodeStats fnid o = do
1458+ NodeStats <$> o .: "name"
1459+ <*> pure fnid
1460+ <*> o .:? "breakers"
1461+ <*> o .: "http"
1462+ <*> o .: "transport"
1463+ <*> o .: "fs"
1464+ <*> o .: "network"
1465+ <*> o .: "thread_pool"
1466+ <*> o .: "jvm"
1467+ <*> o .: "process"
1468+ <*> o .: "os"
1469+ <*> o .: "indices"
1470+
1471+parseNodeInfo :: FullNodeId -> Object -> Parser NodeInfo
1472+parseNodeInfo nid o =
1473+ NodeInfo <$> o .: "http_address"
1474+ <*> o .: "build"
1475+ <*> o .: "version"
1476+ <*> o .: "ip"
1477+ <*> o .: "host"
1478+ <*> o .: "transport_address"
1479+ <*> o .: "name"
1480+ <*> pure nid
1481+ <*> o .: "plugins"
1482+ <*> o .: "http"
1483+ <*> o .: "transport"
1484+ <*> o .: "network"
1485+ <*> o .: "thread_pool"
1486+ <*> o .: "jvm"
1487+ <*> o .: "process"
1488+ <*> o .: "os"
1489+ <*> o .: "settings"
1490+
1491+-- | Reasonable defaults for snapshot restores
1492+--
1493+-- * snapRestoreWaitForCompletion False
1494+-- * snapRestoreIndices Nothing
1495+-- * snapRestoreIgnoreUnavailable False
1496+-- * snapRestoreIncludeGlobalState True
1497+-- * snapRestoreRenamePattern Nothing
1498+-- * snapRestoreRenameReplacement Nothing
1499+-- * snapRestorePartial False
1500+-- * snapRestoreIncludeAliases True
1501+-- * snapRestoreIndexSettingsOverrides Nothing
1502+-- * snapRestoreIgnoreIndexSettings Nothing
1503+defaultSnapshotRestoreSettings :: SnapshotRestoreSettings
1504+defaultSnapshotRestoreSettings = SnapshotRestoreSettings {
1505+ snapRestoreWaitForCompletion = False
1506+ , snapRestoreIndices = Nothing
1507+ , snapRestoreIgnoreUnavailable = False
1508+ , snapRestoreIncludeGlobalState = True
1509+ , snapRestoreRenamePattern = Nothing
1510+ , snapRestoreRenameReplacement = Nothing
1511+ , snapRestorePartial = False
1512+ , snapRestoreIncludeAliases = True
1513+ , snapRestoreIndexSettingsOverrides = Nothing
1514+ , snapRestoreIgnoreIndexSettings = Nothing
1515+ }
1516+
1517+fsRepoType :: SnapshotRepoType
1518+fsRepoType = SnapshotRepoType "fs"
1519+
1520+{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -}
1521+type Reply = Network.HTTP.Client.Response LByteString
1522+
1523+instance FromJSON IndexSettingsSummary where
1524+ parseJSON = withObject "IndexSettingsSummary" parse
1525+ where parse o = case HM.toList o of
1526+ [(ixn, v@(Object o'))] -> IndexSettingsSummary (IndexName ixn)
1527+ <$> parseJSON v
1528+ <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")
1529+ _ -> fail "Expected single-key object with index name"
1530+ redundant (NumberOfReplicas _) = True
1531+ redundant _ = False
1532+
1533+instance ToJSON VersionNumber where
1534+ toJSON = toJSON . Vers.showVersion . versionNumber
1535+
1536+instance FromJSON VersionNumber where
1537+ parseJSON = withText "VersionNumber" (parse . T.unpack)
1538+ where
1539+ parse s = case filter (null . snd)(RP.readP_to_S Vers.parseVersion s) of
1540+ [(v, _)] -> pure (VersionNumber v)
1541+ [] -> fail ("Invalid version string " ++ s)
1542+ xs -> fail ("Ambiguous version string " ++ s ++ " (" ++ intercalate ", " (Vers.showVersion . fst <$> xs) ++ ")")
1543+
1544+instance ToJSON Interval where
1545+ toJSON Year = "year"
1546+ toJSON Quarter = "quarter"
1547+ toJSON Month = "month"
1548+ toJSON Week = "week"
1549+ toJSON Day = "day"
1550+ toJSON Hour = "hour"
1551+ toJSON Minute = "minute"
1552+ toJSON Second = "second"
1553+ toJSON (FractionalInterval fraction interval) = toJSON $ show fraction ++ show interval
1554+
1555+parseStringInterval :: (Monad m) => String -> m NominalDiffTime
1556+parseStringInterval s = case span isNumber s of
1557+ ("", _) -> fail "Invalid interval"
1558+ (nS, unitS) -> case (readMay nS, readMay unitS) of
1559+ (Just n, Just unit) -> return (fromInteger (n * unitNDT unit))
1560+ (Nothing, _) -> fail "Invalid interval number"
1561+ (_, Nothing) -> fail "Invalid interval unit"
1562+ where
1563+ unitNDT Seconds = 1
1564+ unitNDT Minutes = 60
1565+ unitNDT Hours = 60 * 60
1566+ unitNDT Days = 24 * 60 * 60
1567+ unitNDT Weeks = 7 * 24 * 60 * 60
1568+
1569+instance ToJSON IndexSettings where
1570+ toJSON (IndexSettings s r) = object ["settings" .=
1571+ object ["index" .=
1572+ object ["number_of_shards" .= s, "number_of_replicas" .= r]
1573+ ]
1574+ ]
1575+
1576+instance FromJSON IndexSettings where
1577+ parseJSON = withObject "IndexSettings" parse
1578+ where parse o = do s <- o .: "settings"
1579+ i <- s .: "index"
1580+ IndexSettings <$> i .: "number_of_shards"
1581+ <*> i .: "number_of_replicas"
1582+
1583+instance Bounded DocVersion where
1584+ minBound = DocVersion 1
1585+ maxBound = DocVersion 9200000000000000000 -- 9.2e+18
1586+
1587+instance Enum DocVersion where
1588+ succ x
1589+ | x /= maxBound = DocVersion (succ $ docVersionNumber x)
1590+ | otherwise = succError "DocVersion"
1591+ pred x
1592+ | x /= minBound = DocVersion (pred $ docVersionNumber x)
1593+ | otherwise = predError "DocVersion"
1594+ toEnum i =
1595+ fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i
1596+ fromEnum = docVersionNumber
1597+ enumFrom = boundedEnumFrom
1598+ enumFromThen = boundedEnumFromThen
1599+
1600+instance FromJSON ShardResult where
1601+ parseJSON (Object v) = ShardResult <$>
1602+ v .: "total" <*>
1603+ v .: "successful" <*>
1604+ v .: "failed"
1605+ parseJSON _ = empty
1606+
1607+instance FromJSON NodeBreakerStats where
1608+ parseJSON = withObject "NodeBreakerStats" parse
1609+ where
1610+ parse o = NodeBreakerStats <$> o .: "tripped"
1611+ <*> o .: "overhead"
1612+ <*> o .: "estimated_size_in_bytes"
1613+ <*> o .: "limit_size_in_bytes"
1614+
1615+instance FromJSON NodeHTTPStats where
1616+ parseJSON = withObject "NodeHTTPStats" parse
1617+ where
1618+ parse o = NodeHTTPStats <$> o .: "total_opened"
1619+ <*> o .: "current_open"
1620+
1621+instance FromJSON NodeTransportStats where
1622+ parseJSON = withObject "NodeTransportStats" parse
1623+ where
1624+ parse o = NodeTransportStats <$> o .: "tx_size_in_bytes"
1625+ <*> o .: "tx_count"
1626+ <*> o .: "rx_size_in_bytes"
1627+ <*> o .: "rx_count"
1628+ <*> o .: "server_open"
1629+
1630+instance FromJSON NodeFSStats where
1631+ parseJSON = withObject "NodeFSStats" parse
1632+ where
1633+ parse o = NodeFSStats <$> o .: "data"
1634+ <*> o .: "total"
1635+ <*> (posixMS <$> o .: "timestamp")
1636+
1637+instance FromJSON NodeDataPathStats where
1638+ parseJSON = withObject "NodeDataPathStats" parse
1639+ where
1640+ parse o =
1641+ NodeDataPathStats <$> (fmap unStringlyTypedDouble <$> o .:? "disk_service_time")
1642+ <*> (fmap unStringlyTypedDouble <$> o .:? "disk_queue")
1643+ <*> o .:? "disk_io_size_in_bytes"
1644+ <*> o .:? "disk_write_size_in_bytes"
1645+ <*> o .:? "disk_read_size_in_bytes"
1646+ <*> o .:? "disk_io_op"
1647+ <*> o .:? "disk_writes"
1648+ <*> o .:? "disk_reads"
1649+ <*> o .: "available_in_bytes"
1650+ <*> o .: "free_in_bytes"
1651+ <*> o .: "total_in_bytes"
1652+ <*> o .:? "type"
1653+ <*> o .: "dev"
1654+ <*> o .: "mount"
1655+ <*> o .: "path"
1656+
1657+instance FromJSON NodeNetworkStats where
1658+ parseJSON = withObject "NodeNetworkStats" parse
1659+ where
1660+ parse o = do
1661+ tcp <- o .: "tcp"
1662+ NodeNetworkStats <$> tcp .: "out_rsts"
1663+ <*> tcp .: "in_errs"
1664+ <*> tcp .: "attempt_fails"
1665+ <*> tcp .: "estab_resets"
1666+ <*> tcp .: "retrans_segs"
1667+ <*> tcp .: "out_segs"
1668+ <*> tcp .: "in_segs"
1669+ <*> tcp .: "curr_estab"
1670+ <*> tcp .: "passive_opens"
1671+ <*> tcp .: "active_opens"
1672+
1673+instance FromJSON NodeThreadPoolsStats where
1674+ parseJSON = withObject "NodeThreadPoolsStats" parse
1675+ where
1676+ parse o = NodeThreadPoolsStats <$> o .: "snapshot"
1677+ <*> o .: "bulk"
1678+ <*> o .: "merge"
1679+ <*> o .: "get"
1680+ <*> o .: "management"
1681+ <*> o .:? "fetch_shard_store"
1682+ <*> o .: "optimize"
1683+ <*> o .: "flush"
1684+ <*> o .: "search"
1685+ <*> o .: "warmer"
1686+ <*> o .: "generic"
1687+ <*> o .: "suggest"
1688+ <*> o .: "refresh"
1689+ <*> o .: "index"
1690+ <*> o .:? "listener"
1691+ <*> o .:? "fetch_shard_started"
1692+ <*> o .: "percolate"
1693+instance FromJSON NodeThreadPoolStats where
1694+ parseJSON = withObject "NodeThreadPoolStats" parse
1695+ where
1696+ parse o = NodeThreadPoolStats <$> o .: "completed"
1697+ <*> o .: "largest"
1698+ <*> o .: "rejected"
1699+ <*> o .: "active"
1700+ <*> o .: "queue"
1701+ <*> o .: "threads"
1702+
1703+instance FromJSON NodeJVMStats where
1704+ parseJSON = withObject "NodeJVMStats" parse
1705+ where
1706+ parse o = do
1707+ bufferPools <- o .: "buffer_pools"
1708+ mapped <- bufferPools .: "mapped"
1709+ direct <- bufferPools .: "direct"
1710+ gc <- o .: "gc"
1711+ collectors <- gc .: "collectors"
1712+ oldC <- collectors .: "old"
1713+ youngC <- collectors .: "young"
1714+ threads <- o .: "threads"
1715+ mem <- o .: "mem"
1716+ pools <- mem .: "pools"
1717+ oldM <- pools .: "old"
1718+ survivorM <- pools .: "survivor"
1719+ youngM <- pools .: "young"
1720+ NodeJVMStats <$> pure mapped
1721+ <*> pure direct
1722+ <*> pure oldC
1723+ <*> pure youngC
1724+ <*> threads .: "peak_count"
1725+ <*> threads .: "count"
1726+ <*> pure oldM
1727+ <*> pure survivorM
1728+ <*> pure youngM
1729+ <*> mem .: "non_heap_committed_in_bytes"
1730+ <*> mem .: "non_heap_used_in_bytes"
1731+ <*> mem .: "heap_max_in_bytes"
1732+ <*> mem .: "heap_committed_in_bytes"
1733+ <*> mem .: "heap_used_percent"
1734+ <*> mem .: "heap_used_in_bytes"
1735+ <*> (unMS <$> o .: "uptime_in_millis")
1736+ <*> (posixMS <$> o .: "timestamp")
1737+
1738+instance FromJSON JVMBufferPoolStats where
1739+ parseJSON = withObject "JVMBufferPoolStats" parse
1740+ where
1741+ parse o = JVMBufferPoolStats <$> o .: "total_capacity_in_bytes"
1742+ <*> o .: "used_in_bytes"
1743+ <*> o .: "count"
1744+
1745+instance FromJSON JVMGCStats where
1746+ parseJSON = withObject "JVMGCStats" parse
1747+ where
1748+ parse o = JVMGCStats <$> (unMS <$> o .: "collection_time_in_millis")
1749+ <*> o .: "collection_count"
1750+
1751+instance FromJSON JVMPoolStats where
1752+ parseJSON = withObject "JVMPoolStats" parse
1753+ where
1754+ parse o = JVMPoolStats <$> o .: "peak_max_in_bytes"
1755+ <*> o .: "peak_used_in_bytes"
1756+ <*> o .: "max_in_bytes"
1757+ <*> o .: "used_in_bytes"
1758+
1759+instance FromJSON NodeProcessStats where
1760+ parseJSON = withObject "NodeProcessStats" parse
1761+ where
1762+ parse o = do
1763+ mem <- o .: "mem"
1764+ cpu <- o .: "cpu"
1765+ NodeProcessStats <$> mem .: "total_virtual_in_bytes"
1766+ <*> mem .: "share_in_bytes"
1767+ <*> mem .: "resident_in_bytes"
1768+ <*> (unMS <$> cpu .: "total_in_millis")
1769+ <*> (unMS <$> cpu .: "user_in_millis")
1770+ <*> (unMS <$> cpu .: "sys_in_millis")
1771+ <*> cpu .: "percent"
1772+ <*> o .: "open_file_descriptors"
1773+ <*> (posixMS <$> o .: "timestamp")
1774+
1775+instance FromJSON NodeOSStats where
1776+ parseJSON = withObject "NodeOSStats" parse
1777+ where
1778+ parse o = do
1779+ swap <- o .: "swap"
1780+ mem <- o .: "mem"
1781+ cpu <- o .: "cpu"
1782+ load <- o .:? "load_average"
1783+ NodeOSStats <$> swap .: "free_in_bytes"
1784+ <*> swap .: "used_in_bytes"
1785+ <*> mem .: "actual_used_in_bytes"
1786+ <*> mem .: "actual_free_in_bytes"
1787+ <*> mem .: "used_percent"
1788+ <*> mem .: "free_percent"
1789+ <*> mem .: "used_in_bytes"
1790+ <*> mem .: "free_in_bytes"
1791+ <*> cpu .: "stolen"
1792+ <*> cpu .: "usage"
1793+ <*> cpu .: "idle"
1794+ <*> cpu .: "user"
1795+ <*> cpu .: "sys"
1796+ <*> pure load
1797+ <*> (unMS <$> o .: "uptime_in_millis")
1798+ <*> (posixMS <$> o .: "timestamp")
1799+
1800+instance FromJSON LoadAvgs where
1801+ parseJSON = withArray "LoadAvgs" parse
1802+ where
1803+ parse v = case V.toList v of
1804+ [one, five, fifteen] -> LoadAvgs <$> parseJSON one
1805+ <*> parseJSON five
1806+ <*> parseJSON fifteen
1807+ _ -> fail "Expecting a triple of Doubles"
1808+
1809+instance FromJSON NodeIndicesStats where
1810+ parseJSON = withObject "NodeIndicesStats" parse
1811+ where
1812+ parse o = do
1813+ let (.::) mv k = case mv of
1814+ Just v -> Just <$> v .: k
1815+ Nothing -> pure Nothing
1816+ mRecovery <- o .:? "recovery"
1817+ mQueryCache <- o .:? "query_cache"
1818+ suggest <- o .: "suggest"
1819+ translog <- o .: "translog"
1820+ segments <- o .: "segments"
1821+ completion <- o .: "completion"
1822+ percolate <- o .: "percolate"
1823+ fielddata <- o .: "fielddata"
1824+ idCache <- o .: "id_cache"
1825+ filterCache <- o .: "filter_cache"
1826+ warmer <- o .: "warmer"
1827+ flush <- o .: "flush"
1828+ refresh <- o .: "refresh"
1829+ merges <- o .: "merges"
1830+ search <- o .: "search"
1831+ getStats <- o .: "get"
1832+ indexing <- o .: "indexing"
1833+ store <- o .: "store"
1834+ docs <- o .: "docs"
1835+ NodeIndicesStats <$> (fmap unMS <$> mRecovery .:: "throttle_time_in_millis")
1836+ <*> mRecovery .:: "current_as_target"
1837+ <*> mRecovery .:: "current_as_source"
1838+ <*> mQueryCache .:: "miss_count"
1839+ <*> mQueryCache .:: "hit_count"
1840+ <*> mQueryCache .:: "evictions"
1841+ <*> mQueryCache .:: "memory_size_in_bytes"
1842+ <*> suggest .: "current"
1843+ <*> (unMS <$> suggest .: "time_in_millis")
1844+ <*> suggest .: "total"
1845+ <*> translog .: "size_in_bytes"
1846+ <*> translog .: "operations"
1847+ <*> segments .:? "fixed_bit_set_memory_in_bytes"
1848+ <*> segments .: "version_map_memory_in_bytes"
1849+ <*> segments .:? "index_writer_max_memory_in_bytes"
1850+ <*> segments .: "index_writer_memory_in_bytes"
1851+ <*> segments .: "memory_in_bytes"
1852+ <*> segments .: "count"
1853+ <*> completion .: "size_in_bytes"
1854+ <*> percolate .: "queries"
1855+ <*> percolate .: "memory_size_in_bytes"
1856+ <*> percolate .: "current"
1857+ <*> (unMS <$> percolate .: "time_in_millis")
1858+ <*> percolate .: "total"
1859+ <*> fielddata .: "evictions"
1860+ <*> fielddata .: "memory_size_in_bytes"
1861+ <*> idCache .: "memory_size_in_bytes"
1862+ <*> filterCache .: "evictions"
1863+ <*> filterCache .: "memory_size_in_bytes"
1864+ <*> (unMS <$> warmer .: "total_time_in_millis")
1865+ <*> warmer .: "total"
1866+ <*> warmer .: "current"
1867+ <*> (unMS <$> flush .: "total_time_in_millis")
1868+ <*> flush .: "total"
1869+ <*> (unMS <$> refresh .: "total_time_in_millis")
1870+ <*> refresh .: "total"
1871+ <*> merges .: "total_size_in_bytes"
1872+ <*> merges .: "total_docs"
1873+ <*> (unMS <$> merges .: "total_time_in_millis")
1874+ <*> merges .: "total"
1875+ <*> merges .: "current_size_in_bytes"
1876+ <*> merges .: "current_docs"
1877+ <*> merges .: "current"
1878+ <*> search .: "fetch_current"
1879+ <*> (unMS <$> search .: "fetch_time_in_millis")
1880+ <*> search .: "fetch_total"
1881+ <*> search .: "query_current"
1882+ <*> (unMS <$> search .: "query_time_in_millis")
1883+ <*> search .: "query_total"
1884+ <*> search .: "open_contexts"
1885+ <*> getStats .: "current"
1886+ <*> (unMS <$> getStats .: "missing_time_in_millis")
1887+ <*> getStats .: "missing_total"
1888+ <*> (unMS <$> getStats .: "exists_time_in_millis")
1889+ <*> getStats .: "exists_total"
1890+ <*> (unMS <$> getStats .: "time_in_millis")
1891+ <*> getStats .: "total"
1892+ <*> (fmap unMS <$> indexing .:? "throttle_time_in_millis")
1893+ <*> indexing .:? "is_throttled"
1894+ <*> indexing .:? "noop_update_total"
1895+ <*> indexing .: "delete_current"
1896+ <*> (unMS <$> indexing .: "delete_time_in_millis")
1897+ <*> indexing .: "delete_total"
1898+ <*> indexing .: "index_current"
1899+ <*> (unMS <$> indexing .: "index_time_in_millis")
1900+ <*> indexing .: "index_total"
1901+ <*> (unMS <$> store .: "throttle_time_in_millis")
1902+ <*> store .: "size_in_bytes"
1903+ <*> docs .: "deleted"
1904+ <*> docs .: "count"
1905+
1906+instance FromJSON NodeBreakersStats where
1907+ parseJSON = withObject "NodeBreakersStats" parse
1908+ where
1909+ parse o = NodeBreakersStats <$> o .: "parent"
1910+ <*> o .: "request"
1911+ <*> o .: "fielddata"
1912+
1913+instance FromJSON NodePluginInfo where
1914+ parseJSON = withObject "NodePluginInfo" parse
1915+ where
1916+ parse o = NodePluginInfo <$> o .: "site"
1917+ <*> o .: "jvm"
1918+ <*> o .: "description"
1919+ <*> o .: "version"
1920+ <*> o .: "name"
1921+
1922+instance FromJSON NodeHTTPInfo where
1923+ parseJSON = withObject "NodeHTTPInfo" parse
1924+ where
1925+ parse o = NodeHTTPInfo <$> o .: "max_content_length_in_bytes"
1926+ <*> parseJSON (Object o)
1927+
1928+instance FromJSON NodeTransportInfo where
1929+ parseJSON = withObject "NodeTransportInfo" parse
1930+ where
1931+ parse o = NodeTransportInfo <$> (maybe (return mempty) parseProfiles =<< o .:? "profiles")
1932+ <*> parseJSON (Object o)
1933+ parseProfiles (Object o) | HM.null o = return []
1934+ parseProfiles v@(Array _) = parseJSON v
1935+ parseProfiles Null = return []
1936+ parseProfiles _ = fail "Could not parse profiles"
1937+
1938+instance FromJSON NodeNetworkInfo where
1939+ parseJSON = withObject "NodeNetworkInfo" parse
1940+ where
1941+ parse o = NodeNetworkInfo <$> o .: "primary_interface"
1942+ <*> (unMS <$> o .: "refresh_interval_in_millis")
1943+
1944+instance FromJSON NodeNetworkInterface where
1945+ parseJSON = withObject "NodeNetworkInterface" parse
1946+ where
1947+ parse o = NodeNetworkInterface <$> o .: "mac_address"
1948+ <*> o .: "name"
1949+ <*> o .: "address"
1950+
1951+instance FromJSON NodeJVMInfo where
1952+ parseJSON = withObject "NodeJVMInfo" parse
1953+ where
1954+ parse o = NodeJVMInfo <$> o .: "memory_pools"
1955+ <*> o .: "gc_collectors"
1956+ <*> o .: "mem"
1957+ <*> (posixMS <$> o .: "start_time_in_millis")
1958+ <*> o .: "vm_vendor"
1959+ <*> o .: "vm_version"
1960+ <*> o .: "vm_name"
1961+ <*> (unJVMVersion <$> o .: "version")
1962+ <*> o .: "pid"
1963+
1964+instance FromJSON NodeThreadPoolsInfo where
1965+ parseJSON = withObject "NodeThreadPoolsInfo" parse
1966+ where
1967+ parse o = NodeThreadPoolsInfo <$> o .: "refresh"
1968+ <*> o .: "management"
1969+ <*> o .: "percolate"
1970+ <*> o .:? "listener"
1971+ <*> o .:? "fetch_shard_started"
1972+ <*> o .: "search"
1973+ <*> o .: "flush"
1974+ <*> o .: "warmer"
1975+ <*> o .: "optimize"
1976+ <*> o .: "bulk"
1977+ <*> o .: "suggest"
1978+ <*> o .: "merge"
1979+ <*> o .: "snapshot"
1980+ <*> o .: "get"
1981+ <*> o .:? "fetch_shard_store"
1982+ <*> o .: "index"
1983+ <*> o .: "generic"
1984+
1985+instance FromJSON NodeProcessInfo where
1986+ parseJSON = withObject "NodeProcessInfo" parse
1987+ where
1988+ parse o = NodeProcessInfo <$> o .: "mlockall"
1989+ <*> o .: "max_file_descriptors"
1990+ <*> o .: "id"
1991+ <*> (unMS <$> o .: "refresh_interval_in_millis")
1992+
1993+instance FromJSON NodeOSInfo where
1994+ parseJSON = withObject "NodeOSInfo" parse
1995+ where
1996+ parse o = do
1997+ swap <- o .: "swap"
1998+ mem <- o .: "mem"
1999+ NodeOSInfo <$> swap .: "total_in_bytes"
2000+ <*> mem .: "total_in_bytes"
2001+ <*> o .: "cpu"
2002+ <*> o .: "available_processors"
2003+ <*> (unMS <$> o .: "refresh_interval_in_millis")
2004+
2005+instance FromJSON ReplicaBounds where
2006+ parseJSON v = withText "ReplicaBounds" parseText v
2007+ <|> withBool "ReplicaBounds" parseBool v
2008+ where parseText t = case T.splitOn "-" t of
2009+ [a, "all"] -> ReplicasLowerBounded <$> parseReadText a
2010+ [a, b] -> ReplicasBounded <$> parseReadText a
2011+ <*> parseReadText b
2012+ _ -> fail ("Could not parse ReplicaBounds: " <> show t)
2013+ parseBool False = pure ReplicasUnbounded
2014+ parseBool _ = fail "ReplicasUnbounded cannot be represented with True"
2015+
2016+instance FromJSON NominalDiffTimeJSON where
2017+ parseJSON = withText "NominalDiffTime" parse
2018+ where parse t = case T.takeEnd 1 t of
2019+ "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t)
2020+ _ -> fail "Invalid or missing NominalDiffTime unit (expected s)"
2021+
2022+instance FromJSON AllocationPolicy where
2023+ parseJSON = withText "AllocationPolicy" parse
2024+ where parse "all" = pure AllocAll
2025+ parse "primaries" = pure AllocPrimaries
2026+ parse "new_primaries" = pure AllocNewPrimaries
2027+ parse "none" = pure AllocNone
2028+ parse t = fail ("Invlaid AllocationPolicy: " <> show t)
2029+
2030+instance ToJSON CompoundFormat where
2031+ toJSON (CompoundFileFormat x) = Bool x
2032+ toJSON (MergeSegmentVsTotalIndex x) = toJSON x
2033+
2034+instance FromJSON CompoundFormat where
2035+ parseJSON v = CompoundFileFormat <$> parseJSON v
2036+ <|> MergeSegmentVsTotalIndex <$> parseJSON v
2037+
2038+instance FromJSON NodeFSTotalStats where
2039+ parseJSON = withObject "NodeFSTotalStats" parse
2040+ where
2041+ parse o = NodeFSTotalStats <$> (fmap unStringlyTypedDouble <$> o .:? "disk_service_time")
2042+ <*> (fmap unStringlyTypedDouble <$> o .:? "disk_queue")
2043+ <*> o .:? "disk_io_size_in_bytes"
2044+ <*> o .:? "disk_write_size_in_bytes"
2045+ <*> o .:? "disk_read_size_in_bytes"
2046+ <*> o .:? "disk_io_op"
2047+ <*> o .:? "disk_writes"
2048+ <*> o .:? "disk_reads"
2049+ <*> o .: "available_in_bytes"
2050+ <*> o .: "free_in_bytes"
2051+ <*> o .: "total_in_bytes"
2052+
2053+instance FromJSON BoundTransportAddress where
2054+ parseJSON = withObject "BoundTransportAddress" parse
2055+ where
2056+ parse o = BoundTransportAddress <$> o .: "publish_address"
2057+ <*> o .: "bound_address"
2058+
2059+instance FromJSON JVMMemoryInfo where
2060+ parseJSON = withObject "JVMMemoryInfo" parse
2061+ where
2062+ parse o = JVMMemoryInfo <$> o .: "direct_max_in_bytes"
2063+ <*> o .: "non_heap_max_in_bytes"
2064+ <*> o .: "non_heap_init_in_bytes"
2065+ <*> o .: "heap_max_in_bytes"
2066+ <*> o .: "heap_init_in_bytes"
2067+
2068+instance FromJSON JVMVersion where
2069+ parseJSON (String t) =
2070+ JVMVersion <$> parseJSON (String (T.replace "_" "." t))
2071+ parseJSON v = JVMVersion <$> parseJSON v
2072+
2073+instance FromJSON NodeThreadPoolInfo where
2074+ parseJSON = withObject "NodeThreadPoolInfo" parse
2075+ where
2076+ parse o = do
2077+ ka <- maybe (return Nothing) (fmap Just . parseStringInterval) =<< o .:? "keep_alive"
2078+ NodeThreadPoolInfo <$> (parseJSON . unStringlyTypeJSON =<< o .: "queue_size")
2079+ <*> pure ka
2080+ <*> o .:? "min"
2081+ <*> o .:? "max"
2082+ <*> o .: "type"
2083+
2084+instance FromJSON CPUInfo where
2085+ parseJSON = withObject "CPUInfo" parse
2086+ where
2087+ parse o = CPUInfo <$> o .: "cache_size_in_bytes"
2088+ <*> o .: "cores_per_socket"
2089+ <*> o .: "total_sockets"
2090+ <*> o .: "total_cores"
2091+ <*> o .: "mhz"
2092+ <*> o .: "model"
2093+ <*> o .: "vendor"
2094+
2095+instance FromJSON ThreadPoolSize where
2096+ parseJSON v = parseAsNumber v <|> parseAsString v
2097+ where
2098+ parseAsNumber = parseAsInt <=< parseJSON
2099+ parseAsInt (-1) = return ThreadPoolUnbounded
2100+ parseAsInt n
2101+ | n >= 0 = return (ThreadPoolBounded n)
2102+ | otherwise = fail "Thread pool size must be >= -1."
2103+ parseAsString = withText "ThreadPoolSize" $ \t ->
2104+ case first (readMay . T.unpack) (T.span isNumber t) of
2105+ (Just n, "k") -> return (ThreadPoolBounded (n * 1000))
2106+ (Just n, "") -> return (ThreadPoolBounded n)
2107+ _ -> fail ("Invalid thread pool size " <> T.unpack t)
2108+
2109+instance FromJSON ThreadPoolType where
2110+ parseJSON = withText "ThreadPoolType" parse
2111+ where
2112+ parse "scaling" = return ThreadPoolScaling
2113+ parse "fixed" = return ThreadPoolFixed
2114+ parse "cached" = return ThreadPoolCached
2115+ parse e = fail ("Unexpected thread pool type" <> T.unpack e)
2116+
2117+data Source =
2118+ NoSource
2119+ | SourcePatterns PatternOrPatterns
2120+ | SourceIncludeExclude Include Exclude
2121+ deriving (Show, Eq)
2122+
2123+instance ToJSON Source where
2124+ toJSON NoSource = toJSON False
2125+ toJSON (SourcePatterns patterns) = toJSON patterns
2126+ toJSON (SourceIncludeExclude incl excl) = object [ "include" .= incl, "exclude" .= excl ]
2127+
2128+data PatternOrPatterns =
2129+ PopPattern Pattern
2130+ | PopPatterns [Pattern]
2131+ deriving (Eq, Show)
2132+
2133+data Include = Include [Pattern] deriving (Eq, Show)
2134+data Exclude = Exclude [Pattern] deriving (Eq, Show)
2135+
2136+newtype Pattern = Pattern Text deriving (Eq, Show)
2137+
2138+newtype ScrollId = ScrollId Text deriving (Eq, Show, Ord, ToJSON, FromJSON)
2139+
2140+instance ToJSON PatternOrPatterns where
2141+ toJSON (PopPattern pattern) = toJSON pattern
2142+ toJSON (PopPatterns patterns) = toJSON patterns
2143+
2144+instance ToJSON Include where
2145+ toJSON (Include patterns) = toJSON patterns
2146+
2147+instance ToJSON Exclude where
2148+ toJSON (Exclude patterns) = toJSON patterns
2149+
2150+instance ToJSON Pattern where
2151+ toJSON (Pattern pattern) = toJSON pattern
2152+
2153+instance FromJSON NodesStats where
2154+ parseJSON = withObject "NodesStats" parse
2155+ where
2156+ parse o = do
2157+ nodes <- o .: "nodes"
2158+ stats <- forM (HM.toList nodes) $ \(fullNID, v) -> do
2159+ node <- parseJSON v
2160+ parseNodeStats (FullNodeId fullNID) node
2161+ cn <- o .: "cluster_name"
2162+ return (NodesStats stats cn)
2163+
2164+instance ToJSON UpdatableIndexSetting where
2165+ toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x
2166+ toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x
2167+ toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x)
2168+ toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x
2169+ toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x
2170+ toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x
2171+ toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x
2172+ toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x)
2173+ toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x
2174+ toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x
2175+ toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x)
2176+ toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x)
2177+ toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs)
2178+ toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs)
2179+ toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs)
2180+ toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x
2181+ toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x
2182+ toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x
2183+ toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x)
2184+ toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x
2185+ toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x
2186+ toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x
2187+ toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x
2188+ toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x
2189+ toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x
2190+ toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x
2191+ toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x
2192+ toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x
2193+
2194+instance FromJSON UpdatableIndexSetting where
2195+ parseJSON = withObject "UpdatableIndexSetting" parse
2196+ where parse o = numberOfReplicas `taggedAt` ["index", "number_of_replicas"]
2197+ <|> autoExpandReplicas `taggedAt` ["index", "auto_expand_replicas"]
2198+ <|> refreshInterval `taggedAt` ["index", "refresh_interval"]
2199+ <|> indexConcurrency `taggedAt` ["index", "concurrency"]
2200+ <|> failOnMergeFailure `taggedAt` ["index", "fail_on_merge_failure"]
2201+ <|> translogFlushThresholdOps `taggedAt` ["index", "translog", "flush_threshold_ops"]
2202+ <|> translogFlushThresholdSize `taggedAt` ["index", "translog", "flush_threshold_size"]
2203+ <|> translogFlushThresholdPeriod `taggedAt` ["index", "translog", "flush_threshold_period"]
2204+ <|> translogDisableFlush `taggedAt` ["index", "translog", "disable_flush"]
2205+ <|> cacheFilterMaxSize `taggedAt` ["index", "cache", "filter", "max_size"]
2206+ <|> cacheFilterExpire `taggedAt` ["index", "cache", "filter", "expire"]
2207+ <|> gatewaySnapshotInterval `taggedAt` ["index", "gateway", "snapshot_interval"]
2208+ <|> routingAllocationInclude `taggedAt` ["index", "routing", "allocation", "include"]
2209+ <|> routingAllocationExclude `taggedAt` ["index", "routing", "allocation", "exclude"]
2210+ <|> routingAllocationRequire `taggedAt` ["index", "routing", "allocation", "require"]
2211+ <|> routingAllocationEnable `taggedAt` ["index", "routing", "allocation", "enable"]
2212+ <|> routingAllocationShardsPerNode `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"]
2213+ <|> recoveryInitialShards `taggedAt` ["index", "recovery", "initial_shards"]
2214+ <|> gcDeletes `taggedAt` ["index", "gc_deletes"]
2215+ <|> ttlDisablePurge `taggedAt` ["index", "ttl", "disable_purge"]
2216+ <|> translogFSType `taggedAt` ["index", "translog", "fs", "type"]
2217+ <|> compoundFormat `taggedAt` ["index", "compound_format"]
2218+ <|> compoundOnFlush `taggedAt` ["index", "compound_on_flush"]
2219+ <|> warmerEnabled `taggedAt` ["index", "warmer", "enabled"]
2220+ <|> blocksReadOnly `taggedAt` ["blocks", "read_only"]
2221+ <|> blocksRead `taggedAt` ["blocks", "read"]
2222+ <|> blocksWrite `taggedAt` ["blocks", "write"]
2223+ <|> blocksMetaData `taggedAt` ["blocks", "metadata"]
2224+ where taggedAt f ks = taggedAt' f (Object o) ks
2225+ taggedAt' f v [] = f =<< (parseJSON v <|> (parseJSON (unStringlyTypeJSON v)))
2226+ taggedAt' f v (k:ks) = withObject "Object" (\o -> do v' <- o .: k
2227+ taggedAt' f v' ks) v
2228+ numberOfReplicas = pure . NumberOfReplicas
2229+ autoExpandReplicas = pure . AutoExpandReplicas
2230+ refreshInterval = pure . RefreshInterval . ndtJSON
2231+ indexConcurrency = pure . IndexConcurrency
2232+ failOnMergeFailure = pure . FailOnMergeFailure
2233+ translogFlushThresholdOps = pure . TranslogFlushThresholdOps
2234+ translogFlushThresholdSize = pure . TranslogFlushThresholdSize
2235+ translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON
2236+ translogDisableFlush = pure . TranslogDisableFlush
2237+ cacheFilterMaxSize = pure . CacheFilterMaxSize
2238+ cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON
2239+ gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON
2240+ routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter
2241+ routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter
2242+ routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter
2243+ routingAllocationEnable = pure . RoutingAllocationEnable
2244+ routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode
2245+ recoveryInitialShards = pure . RecoveryInitialShards
2246+ gcDeletes = pure . GCDeletes . ndtJSON
2247+ ttlDisablePurge = pure . TTLDisablePurge
2248+ translogFSType = pure . TranslogFSType
2249+ compoundFormat = pure . IndexCompoundFormat
2250+ compoundOnFlush = pure . IndexCompoundOnFlush
2251+ warmerEnabled = pure . WarmerEnabled
2252+ blocksReadOnly = pure . BlocksReadOnly
2253+ blocksRead = pure . BlocksRead
2254+ blocksWrite = pure . BlocksWrite
2255+ blocksMetaData = pure . BlocksMetaData
2256+
2257+instance ToJSON ReplicaBounds where
2258+ toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b)
2259+ toJSON (ReplicasLowerBounded a) = String (showText a <> "-all")
2260+ toJSON ReplicasUnbounded = Bool False
2261+
2262+instance ToJSON NominalDiffTimeJSON where
2263+ toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s")
2264+
2265+instance ToJSON AllocationPolicy where
2266+ toJSON AllocAll = String "all"
2267+ toJSON AllocPrimaries = String "primaries"
2268+ toJSON AllocNewPrimaries = String "new_primaries"
2269+ toJSON AllocNone = String "none"
2270+
2271+instance ToJSON IndexTemplate where
2272+ toJSON (IndexTemplate p s m) = merge
2273+ (object [ "template" .= p
2274+ , "mappings" .= foldl' merge (object []) m
2275+ ])
2276+ (toJSON s)
2277+ where
2278+ merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2
2279+ merge o Null = o
2280+ merge _ _ = undefined
2281+
2282+instance FromJSON IndexAliasesSummary where
2283+ parseJSON = withObject "IndexAliasesSummary" parse
2284+ where parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (HM.toList o)
2285+ go ixn = withObject "index aliases" $ \ia -> do
2286+ aliases <- ia .:? "aliases" .!= mempty
2287+ forM (HM.toList aliases) $ \(aName, v) -> do
2288+ let indexAlias = IndexAlias (IndexName ixn) (IndexAliasName (IndexName aName))
2289+ IndexAliasSummary indexAlias <$> parseJSON v
2290+
2291+instance ToJSON IndexAliasAction where
2292+ toJSON (AddAlias ia opts) = object ["add" .= (iaObj <> optsObj)]
2293+ where Object iaObj = toJSON ia
2294+ Object optsObj = toJSON opts
2295+ toJSON (RemoveAlias ia) = object ["remove" .= iaObj]
2296+ where Object iaObj = toJSON ia
2297+
2298+instance ToJSON IndexAlias where
2299+ toJSON IndexAlias {..} = object ["index" .= srcIndex
2300+ , "alias" .= indexAlias
2301+ ]
2302+
2303+instance FromJSON AliasRouting where
2304+ parseJSON = withObject "AliasRouting" parse
2305+ where parse o = parseAll o <|> parseGranular o
2306+ parseAll o = AllAliasRouting <$> o .: "routing"
2307+ parseGranular o = do
2308+ sr <- o .:? "search_routing"
2309+ ir <- o .:? "index_routing"
2310+ if isNothing sr && isNothing ir
2311+ then fail "Both search_routing and index_routing can't be blank"
2312+ else return (GranularAliasRouting sr ir)
2313+
2314+instance FromJSON IndexAliasCreate where
2315+ parseJSON v = withObject "IndexAliasCreate" parse v
2316+ where parse o = IndexAliasCreate <$> optional (parseJSON v)
2317+ <*> o .:? "filter"
2318+
2319+instance ToJSON IndexAliasCreate where
2320+ toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj)
2321+ where filterObj = maybe mempty (HM.singleton "filter" . toJSON) aliasCreateFilter
2322+ Object routingObj = maybe (Object mempty) toJSON aliasCreateRouting
2323+
2324+instance ToJSON AliasRouting where
2325+ toJSON (AllAliasRouting v) = object ["routing" .= v]
2326+ toJSON (GranularAliasRouting srch idx) = object (catMaybes prs)
2327+ where prs = [("search_routing" .=) <$> srch
2328+ ,("index_routing" .=) <$> idx]
2329+
2330+instance ToJSON SearchAliasRouting where
2331+ toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs))
2332+
2333+instance FromJSON SearchAliasRouting where
2334+ parseJSON = withText "SearchAliasRouting" parse
2335+ where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)
2336+
2337+instance FromJSON EsError where
2338+ parseJSON (Object v) = EsError <$>
2339+ v .: "status" <*>
2340+ (v .: "error" <|> (v .: "error" >>= (.: "reason")))
2341+ parseJSON _ = empty
src/Database/V1/Bloodhound/Internal/Highlight.hsnew file+144
@@ -0,0 +1,144 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Database.V1.Bloodhound.Internal.Highlight where
4+
5+
6+import Bloodhound.Import
7+
8+import qualified Data.Map as M
9+
10+import Database.V1.Bloodhound.Internal.Newtypes
11+import Database.V1.Bloodhound.Internal.Query
12+
13+type HitHighlight = M.Map Text [Text]
14+
15+data Highlights = Highlights { globalsettings :: Maybe HighlightSettings
16+ , highlightFields :: [FieldHighlight]
17+ } deriving (Show, Eq)
18+
19+instance ToJSON Highlights where
20+ toJSON (Highlights global fields) =
21+ omitNulls (("fields" .= fields)
22+ : highlightSettingsPairs global)
23+
24+data HighlightSettings = Plain PlainHighlight
25+ | Postings PostingsHighlight
26+ | FastVector FastVectorHighlight
27+ deriving (Show, Eq)
28+
29+data FieldHighlight = FieldHighlight FieldName (Maybe HighlightSettings)
30+ deriving (Show, Eq)
31+
32+data PlainHighlight =
33+ PlainHighlight { plainCommon :: Maybe CommonHighlight
34+ , plainNonPost :: Maybe NonPostings } deriving (Show, Eq)
35+
36+ -- This requires that index_options are set to 'offset' in the mapping.
37+data PostingsHighlight = PostingsHighlight (Maybe CommonHighlight) deriving (Show, Eq)
38+
39+-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
40+data FastVectorHighlight =
41+ FastVectorHighlight { fvCommon :: Maybe CommonHighlight
42+ , fvNonPostSettings :: Maybe NonPostings
43+ , boundaryChars :: Maybe Text
44+ , boundaryMaxScan :: Maybe Int
45+ , fragmentOffset :: Maybe Int
46+ , matchedFields :: [Text]
47+ , phraseLimit :: Maybe Int
48+ } deriving (Show, Eq)
49+
50+data CommonHighlight =
51+ CommonHighlight { order :: Maybe Text
52+ , forceSource :: Maybe Bool
53+ , tag :: Maybe HighlightTag
54+ , encoder :: Maybe HighlightEncoder
55+ , noMatchSize :: Maybe Int
56+ , highlightQuery :: Maybe Query
57+ , requireFieldMatch :: Maybe Bool
58+ } deriving (Show, Eq)
59+
60+-- Settings that are only applicable to FastVector and Plain highlighters.
61+data NonPostings =
62+ NonPostings { fragmentSize :: Maybe Int
63+ , numberOfFragments :: Maybe Int} deriving (Show, Eq)
64+
65+data HighlightEncoder = DefaultEncoder
66+ | HTMLEncoder
67+ deriving (Show, Eq)
68+
69+-- NOTE: Should the tags use some kind of HTML type, rather than Text?
70+data HighlightTag = TagSchema Text
71+ | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh
72+ deriving (Show, Eq)
73+
74+highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
75+highlightSettingsPairs Nothing = []
76+highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
77+highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
78+highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
79+
80+plainHighPairs :: Maybe PlainHighlight -> [Pair]
81+plainHighPairs Nothing = []
82+plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
83+ [ "type" .= String "plain"]
84+ ++ commonHighlightPairs plCom
85+ ++ nonPostingsToPairs plNonPost
86+
87+postHighPairs :: Maybe PostingsHighlight -> [Pair]
88+postHighPairs Nothing = []
89+postHighPairs (Just (PostingsHighlight pCom)) =
90+ ("type" .= String "postings")
91+ : commonHighlightPairs pCom
92+
93+fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
94+fastVectorHighPairs Nothing = []
95+fastVectorHighPairs (Just
96+ (FastVectorHighlight fvCom fvNonPostSettings' fvBoundChars
97+ fvBoundMaxScan fvFragOff fvMatchedFields
98+ fvPhraseLim)) =
99+ [ "type" .= String "fvh"
100+ , "boundary_chars" .= fvBoundChars
101+ , "boundary_max_scan" .= fvBoundMaxScan
102+ , "fragment_offset" .= fvFragOff
103+ , "matched_fields" .= fvMatchedFields
104+ , "phraseLimit" .= fvPhraseLim]
105+ ++ commonHighlightPairs fvCom
106+ ++ nonPostingsToPairs fvNonPostSettings'
107+
108+commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
109+commonHighlightPairs Nothing = []
110+commonHighlightPairs (Just (CommonHighlight chScore chForceSource chTag chEncoder
111+ chNoMatchSize chHighlightQuery
112+ chRequireFieldMatch)) =
113+ [ "order" .= chScore
114+ , "force_source" .= chForceSource
115+ , "encoder" .= chEncoder
116+ , "no_match_size" .= chNoMatchSize
117+ , "highlight_query" .= chHighlightQuery
118+ , "require_fieldMatch" .= chRequireFieldMatch]
119+ ++ highlightTagToPairs chTag
120+
121+nonPostingsToPairs :: Maybe NonPostings -> [Pair]
122+nonPostingsToPairs Nothing = []
123+nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
124+ [ "fragment_size" .= npFragSize
125+ , "number_of_fragments" .= npNumOfFrags]
126+
127+highlightTagToPairs :: Maybe HighlightTag -> [Pair]
128+highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"]
129+highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre
130+ , "post_tags" .= post]
131+highlightTagToPairs Nothing = []
132+
133+instance ToJSON FieldHighlight where
134+ toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
135+ object [ fName .= fSettings ]
136+ toJSON (FieldHighlight (FieldName fName) Nothing) =
137+ object [ fName .= emptyObject ]
138+
139+instance ToJSON HighlightSettings where
140+ toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
141+
142+instance ToJSON HighlightEncoder where
143+ toJSON DefaultEncoder = String "default"
144+ toJSON HTMLEncoder = String "html"
src/Database/V1/Bloodhound/Internal/Newtypes.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+module Database.V1.Bloodhound.Internal.Newtypes where
5+
6+import Bloodhound.Import
7+
8+newtype From = From Int deriving (Eq, Show, ToJSON)
9+newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON)
10+
11+
12+{-| 'FieldName' is used all over the place wherever a specific field within
13+ a document needs to be specified, usually in 'Query's or 'Filter's.
14+-}
15+newtype FieldName =
16+ FieldName Text
17+ deriving (Eq, Show, ToJSON, FromJSON)
18+
19+newtype Boost =
20+ Boost Double
21+ deriving (Eq, Show, ToJSON, FromJSON)
22+
23+newtype BoostTerms =
24+ BoostTerms Double
25+ deriving (Eq, Show, ToJSON, FromJSON)
26+
27+{-| 'ReplicaCount' is part of 'IndexSettings' -}
28+newtype ReplicaCount =
29+ ReplicaCount Int
30+ deriving (Eq, Show, ToJSON)
31+
32+{-| 'ShardCount' is part of 'IndexSettings' -}
33+newtype ShardCount =
34+ ShardCount Int
35+ deriving (Eq, Show, ToJSON)
36+
37+
38+{-| 'TemplateName' is used to describe which template to query/create/delete
39+-}
40+newtype TemplateName = TemplateName Text deriving (Eq, Show, ToJSON, FromJSON)
41+
42+{-| 'TemplatePattern' represents a pattern which is matched against index names
43+-}
44+newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, ToJSON, FromJSON)
45+
46+{-| 'MappingName' is part of mappings which are how ES describes and schematizes
47+ the data in the indices.
48+-}
49+newtype MappingName = MappingName Text deriving (Eq, Show, ToJSON, FromJSON)
50+
51+{-| 'DocId' is a generic wrapper value for expressing unique Document IDs.
52+ Can be set by the user or created by ES itself. Often used in client
53+ functions for poking at specific documents.
54+-}
55+newtype DocId = DocId Text deriving (Eq, Show, ToJSON, FromJSON)
56+
57+{-| 'QueryString' is used to wrap query text bodies, be they human written or not.
58+-}
59+newtype QueryString = QueryString Text deriving (Eq, Show, ToJSON, FromJSON)
60+
61+{-| 'Script' is often used in place of 'FieldName' to specify more
62+complex ways of extracting a value from a document.
63+-}
64+newtype Script = Script { scriptText :: Text } deriving (Eq, Show)
65+
66+{-| 'CacheName' is used in 'RegexpFilter' for describing the
67+ 'CacheKey' keyed caching behavior.
68+-}
69+newtype CacheName = CacheName Text deriving (Eq, Show, ToJSON, FromJSON)
70+
71+{-| 'CacheKey' is used in 'RegexpFilter' to key regex caching.
72+-}
73+newtype CacheKey =
74+ CacheKey Text deriving (Eq, Show, ToJSON, FromJSON)
75+newtype Existence =
76+ Existence Bool deriving (Eq, Show, ToJSON, FromJSON)
77+newtype NullValue =
78+ NullValue Bool deriving (Eq, Show, ToJSON, FromJSON)
79+newtype CutoffFrequency =
80+ CutoffFrequency Double deriving (Eq, Show, ToJSON, FromJSON)
81+newtype Analyzer =
82+ Analyzer Text deriving (Eq, Show, ToJSON, FromJSON)
83+newtype MaxExpansions =
84+ MaxExpansions Int deriving (Eq, Show, ToJSON, FromJSON)
85+
86+{-| 'Lenient', if set to true, will cause format based failures to be
87+ ignored. I don't know what the bloody default is, Elasticsearch
88+ documentation didn't say what it was. Let me know if you figure it out.
89+-}
90+newtype Lenient =
91+ Lenient Bool deriving (Eq, Show, ToJSON, FromJSON)
92+newtype Tiebreaker =
93+ Tiebreaker Double deriving (Eq, Show, ToJSON, FromJSON)
94+
95+{-| 'MinimumMatch' controls how many should clauses in the bool query should
96+ match. Can be an absolute value (2) or a percentage (30%) or a
97+ combination of both.
98+-}
99+newtype MinimumMatch =
100+ MinimumMatch Int deriving (Eq, Show, ToJSON, FromJSON)
101+newtype DisableCoord =
102+ DisableCoord Bool deriving (Eq, Show, ToJSON, FromJSON)
103+newtype IgnoreTermFrequency =
104+ IgnoreTermFrequency Bool deriving (Eq, Show, ToJSON, FromJSON)
105+newtype MinimumTermFrequency =
106+ MinimumTermFrequency Int deriving (Eq, Show, ToJSON, FromJSON)
107+newtype MaxQueryTerms =
108+ MaxQueryTerms Int deriving (Eq, Show, ToJSON, FromJSON)
109+newtype Fuzziness =
110+ Fuzziness Double deriving (Eq, Show, ToJSON, FromJSON)
111+
112+{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -}
113+newtype PrefixLength =
114+ PrefixLength Int deriving (Eq, Show, ToJSON, FromJSON)
115+newtype TypeName =
116+ TypeName Text deriving (Eq, Show, ToJSON, FromJSON)
117+newtype PercentMatch =
118+ PercentMatch Double deriving (Eq, Show, ToJSON, FromJSON)
119+newtype StopWord =
120+ StopWord Text deriving (Eq, Show, ToJSON, FromJSON)
121+newtype QueryPath =
122+ QueryPath Text deriving (Eq, Show, ToJSON, FromJSON)
123+
124+{-| Allowing a wildcard at the beginning of a word (eg "*ing") is particularly
125+ heavy, because all terms in the index need to be examined, just in case
126+ they match. Leading wildcards can be disabled by setting
127+ 'AllowLeadingWildcard' to false. -}
128+newtype AllowLeadingWildcard =
129+ AllowLeadingWildcard Bool deriving (Eq, Show, ToJSON, FromJSON)
130+newtype LowercaseExpanded =
131+ LowercaseExpanded Bool deriving (Eq, Show, ToJSON, FromJSON)
132+newtype EnablePositionIncrements =
133+ EnablePositionIncrements Bool deriving (Eq, Show, ToJSON, FromJSON)
134+
135+{-| By default, wildcard terms in a query are not analyzed.
136+ Setting 'AnalyzeWildcard' to true enables best-effort analysis.
137+-}
138+newtype AnalyzeWildcard = AnalyzeWildcard Bool deriving (Eq, Show, ToJSON, FromJSON)
139+
140+{-| 'GeneratePhraseQueries' defaults to false.
141+-}
142+newtype GeneratePhraseQueries =
143+ GeneratePhraseQueries Bool deriving (Eq, Show, ToJSON, FromJSON)
144+
145+{-| 'Locale' is used for string conversions - defaults to ROOT.
146+-}
147+newtype Locale = Locale Text deriving (Eq, Show, ToJSON, FromJSON)
148+newtype MaxWordLength = MaxWordLength Int deriving (Eq, Show, ToJSON, FromJSON)
149+newtype MinWordLength = MinWordLength Int deriving (Eq, Show, ToJSON, FromJSON)
150+
151+{-| 'PhraseSlop' sets the default slop for phrases, 0 means exact
152+ phrase matches. Default is 0.
153+-}
154+newtype PhraseSlop = PhraseSlop Int deriving (Eq, Show, ToJSON, FromJSON)
155+newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Show, ToJSON, FromJSON)
156+newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, ToJSON, FromJSON)
157+
158+-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ
159+newtype POSIXMS = POSIXMS { posixMS :: UTCTime }
160+
161+instance FromJSON POSIXMS where
162+ parseJSON = withScientific "POSIXMS" (return . parse)
163+ where parse n = let n' = truncate n :: Integer
164+ in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))
165+
166+{-| 'IndexName' is used to describe which index to query/create/delete
167+-}
168+newtype IndexName = IndexName Text deriving (Eq, Show, ToJSON, FromJSON)
169+
170+newtype IndexAliasName = IndexAliasName { indexAliasName :: IndexName } deriving (Eq, Show, ToJSON)
171+
172+type Score = Maybe Double
173+
174+newtype ShardId = ShardId { shardId :: Int }
175+ deriving (Eq, Show, FromJSON)
176+
177+-- | Milliseconds
178+newtype MS = MS NominalDiffTime
179+
180+
181+-- keeps the unexported constructor warnings at bay
182+unMS :: MS -> NominalDiffTime
183+unMS (MS t) = t
184+
185+instance FromJSON MS where
186+ parseJSON = withScientific "MS" (return . MS . parse)
187+ where
188+ parse n = fromInteger ((truncate n) * 1000)
189+
190+newtype MaybeNA a = MaybeNA { unMaybeNA :: Maybe a }
191+ deriving (Show, Eq)
192+
193+instance FromJSON a => FromJSON (MaybeNA a) where
194+ parseJSON (String "NA") = pure $ MaybeNA Nothing
195+ parseJSON o = MaybeNA . Just <$> parseJSON o
196+
197+newtype SnapshotName = SnapshotName { snapshotName :: Text }
198+ deriving (Show, Eq, Ord, ToJSON, FromJSON)
199+
200+instance FromJSON ShardCount where
201+ parseJSON v = parseAsInt v
202+ <|> parseAsString v
203+ where parseAsInt = fmap ShardCount . parseJSON
204+ parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText)
205+
206+
207+instance FromJSON ReplicaCount where
208+ parseJSON v = parseAsInt v
209+ <|> parseAsString v
210+ where parseAsInt = fmap ReplicaCount . parseJSON
211+ parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)
src/Database/V1/Bloodhound/Internal/Query.hsnew file+1689
@@ -0,0 +1,1689 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
4+
5+module Database.V1.Bloodhound.Internal.Query where
6+
7+
8+import Bloodhound.Import
9+
10+import qualified Data.HashMap.Strict as HM
11+import qualified Data.Text as T
12+
13+import Database.V1.Bloodhound.Internal.Newtypes
14+import Database.V1.Bloodhound.Types.Class
15+
16+
17+data GeoPoint =
18+ GeoPoint { geoField :: FieldName
19+ , latLon :: LatLon} deriving (Eq, Show)
20+
21+instance ToJSON GeoPoint where
22+ toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) =
23+ object [ geoPointField .= geoPointLatLon ]
24+
25+
26+data LatLon = LatLon { lat :: Double
27+ , lon :: Double } deriving (Eq, Show)
28+
29+instance ToJSON LatLon where
30+ toJSON (LatLon lLat lLon) =
31+ object ["lat" .= lLat
32+ , "lon" .= lLon]
33+
34+instance FromJSON LatLon where
35+ parseJSON = withObject "LatLon" parse
36+ where parse o = LatLon <$> o .: "lat"
37+ <*> o .: "lon"
38+
39+data DistanceUnit = Miles
40+ | Yards
41+ | Feet
42+ | Inches
43+ | Kilometers
44+ | Meters
45+ | Centimeters
46+ | Millimeters
47+ | NauticalMiles deriving (Eq, Show)
48+
49+instance ToJSON DistanceUnit where
50+ toJSON Miles = String "mi"
51+ toJSON Yards = String "yd"
52+ toJSON Feet = String "ft"
53+ toJSON Inches = String "in"
54+ toJSON Kilometers = String "km"
55+ toJSON Meters = String "m"
56+ toJSON Centimeters = String "cm"
57+ toJSON Millimeters = String "mm"
58+ toJSON NauticalMiles = String "nmi"
59+
60+instance FromJSON DistanceUnit where
61+ parseJSON = withText "DistanceUnit" parse
62+ where parse "mi" = pure Miles
63+ parse "yd" = pure Yards
64+ parse "ft" = pure Feet
65+ parse "in" = pure Inches
66+ parse "km" = pure Kilometers
67+ parse "m" = pure Meters
68+ parse "cm" = pure Centimeters
69+ parse "mm" = pure Millimeters
70+ parse "nmi" = pure NauticalMiles
71+ parse u = fail ("Unrecognized DistanceUnit: " <> show u)
72+
73+{-| 'Cache' is for telling ES whether it should cache a 'Filter' not.
74+ 'Query's cannot be cached.
75+-}
76+type Cache = Bool -- caching on/off
77+
78+
79+data Filter = AndFilter [Filter] Cache
80+ | OrFilter [Filter] Cache
81+ | NotFilter Filter Cache
82+ | IdentityFilter
83+ | BoolFilter BoolMatch
84+ | ExistsFilter FieldName -- always cached
85+ | GeoBoundingBoxFilter GeoBoundingBoxConstraint
86+ | GeoDistanceFilter GeoPoint Distance DistanceType OptimizeBbox Cache
87+ | GeoDistanceRangeFilter GeoPoint DistanceRange
88+ | GeoPolygonFilter FieldName [LatLon]
89+ | IdsFilter MappingName [DocId]
90+ | LimitFilter Int
91+ | MissingFilter FieldName Existence NullValue
92+ | PrefixFilter FieldName PrefixValue Cache
93+ | QueryFilter Query Cache
94+ | RangeFilter FieldName RangeValue RangeExecution Cache
95+ | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey
96+ | TermFilter Term Cache
97+ deriving (Eq, Show)
98+
99+instance Semigroup Filter where
100+ a <> b = AndFilter [a, b] defaultCache
101+
102+instance Monoid Filter where
103+ mempty = IdentityFilter
104+ mappend = (<>)
105+
106+instance Seminearring Filter where
107+ a <||> b = OrFilter [a, b] defaultCache
108+
109+data BoolMatch = MustMatch Term Cache
110+ | MustNotMatch Term Cache
111+ | ShouldMatch [Term] Cache deriving (Eq, Show)
112+
113+data Term = Term { termField :: Text
114+ , termValue :: Text } deriving (Eq, Show)
115+
116+
117+data OptimizeBbox = OptimizeGeoFilterType GeoFilterType
118+ | NoOptimizeBbox deriving (Eq, Show)
119+
120+
121+data Distance =
122+ Distance { coefficient :: Double
123+ , unit :: DistanceUnit } deriving (Eq, Show)
124+
125+data DistanceRange =
126+ DistanceRange { distanceFrom :: Distance
127+ , distanceTo :: Distance } deriving (Eq, Show)
128+
129+-- "memory" or "indexed"
130+data GeoFilterType = GeoFilterMemory
131+ | GeoFilterIndexed deriving (Eq, Show)
132+
133+data GeoBoundingBoxConstraint =
134+ GeoBoundingBoxConstraint { geoBBField :: FieldName
135+ , constraintBox :: GeoBoundingBox
136+ , bbConstraintcache :: Cache
137+ , geoType :: GeoFilterType
138+ } deriving (Eq, Show)
139+
140+
141+data DistanceType = Arc
142+ | SloppyArc -- doesn't exist <1.0
143+ | Plane deriving (Eq, Show)
144+
145+data GeoBoundingBox =
146+ GeoBoundingBox { topLeft :: LatLon
147+ , bottomRight :: LatLon } deriving (Eq, Show)
148+
149+{-| 'PrefixValue' is used in 'PrefixQuery' as the main query component.
150+-}
151+type PrefixValue = Text
152+
153+
154+data RangeValue = RangeDateLte LessThanEqD
155+ | RangeDateLt LessThanD
156+ | RangeDateGte GreaterThanEqD
157+ | RangeDateGt GreaterThanD
158+ | RangeDateGtLt GreaterThanD LessThanD
159+ | RangeDateGteLte GreaterThanEqD LessThanEqD
160+ | RangeDateGteLt GreaterThanEqD LessThanD
161+ | RangeDateGtLte GreaterThanD LessThanEqD
162+ | RangeDoubleLte LessThanEq
163+ | RangeDoubleLt LessThan
164+ | RangeDoubleGte GreaterThanEq
165+ | RangeDoubleGt GreaterThan
166+ | RangeDoubleGtLt GreaterThan LessThan
167+ | RangeDoubleGteLte GreaterThanEq LessThanEq
168+ | RangeDoubleGteLt GreaterThanEq LessThan
169+ | RangeDoubleGtLte GreaterThan LessThanEq
170+ deriving (Eq, Show)
171+
172+
173+newtype LessThan = LessThan Double deriving (Eq, Show)
174+newtype LessThanEq = LessThanEq Double deriving (Eq, Show)
175+newtype GreaterThan = GreaterThan Double deriving (Eq, Show)
176+newtype GreaterThanEq = GreaterThanEq Double deriving (Eq, Show)
177+
178+newtype LessThanD = LessThanD UTCTime deriving (Eq, Show)
179+newtype LessThanEqD = LessThanEqD UTCTime deriving (Eq, Show)
180+newtype GreaterThanD = GreaterThanD UTCTime deriving (Eq, Show)
181+newtype GreaterThanEqD = GreaterThanEqD UTCTime deriving (Eq, Show)
182+
183+
184+data Query =
185+ TermQuery Term (Maybe Boost)
186+ | TermsQuery Text (NonEmpty Text)
187+ | QueryMatchQuery MatchQuery
188+ | QueryMultiMatchQuery MultiMatchQuery
189+ | QueryBoolQuery BoolQuery
190+ | QueryBoostingQuery BoostingQuery
191+ | QueryCommonTermsQuery CommonTermsQuery
192+ | ConstantScoreFilter Filter Boost
193+ | ConstantScoreQuery Query Boost
194+ | QueryDisMaxQuery DisMaxQuery
195+ | QueryFilteredQuery FilteredQuery
196+ | QueryFuzzyLikeThisQuery FuzzyLikeThisQuery
197+ | QueryFuzzyLikeFieldQuery FuzzyLikeFieldQuery
198+ | QueryFuzzyQuery FuzzyQuery
199+ | QueryHasChildQuery HasChildQuery
200+ | QueryHasParentQuery HasParentQuery
201+ | IdsQuery MappingName [DocId]
202+ | QueryIndicesQuery IndicesQuery
203+ | MatchAllQuery (Maybe Boost)
204+ | QueryMoreLikeThisQuery MoreLikeThisQuery
205+ | QueryMoreLikeThisFieldQuery MoreLikeThisFieldQuery
206+ | QueryNestedQuery NestedQuery
207+ | QueryPrefixQuery PrefixQuery
208+ | QueryQueryStringQuery QueryStringQuery
209+ | QuerySimpleQueryStringQuery SimpleQueryStringQuery
210+ | QueryRangeQuery RangeQuery
211+ | QueryRegexpQuery RegexpQuery
212+ | QueryTemplateQueryInline TemplateQueryInline
213+ deriving (Eq, Show)
214+
215+data RegexpQuery =
216+ RegexpQuery { regexpQueryField :: FieldName
217+ , regexpQuery :: Regexp
218+ , regexpQueryFlags :: RegexpFlags
219+ , regexpQueryBoost :: Maybe Boost
220+ } deriving (Eq, Show)
221+
222+data RangeQuery =
223+ RangeQuery { rangeQueryField :: FieldName
224+ , rangeQueryRange :: RangeValue
225+ , rangeQueryBoost :: Boost } deriving (Eq, Show)
226+
227+mkRangeQuery :: FieldName -> RangeValue -> RangeQuery
228+mkRangeQuery f r = RangeQuery f r (Boost 1.0)
229+
230+data SimpleQueryStringQuery =
231+ SimpleQueryStringQuery
232+ { simpleQueryStringQuery :: QueryString
233+ , simpleQueryStringField :: Maybe FieldOrFields
234+ , simpleQueryStringOperator :: Maybe BooleanOperator
235+ , simpleQueryStringAnalyzer :: Maybe Analyzer
236+ , simpleQueryStringFlags :: Maybe (NonEmpty SimpleQueryFlag)
237+ , simpleQueryStringLowercaseExpanded :: Maybe LowercaseExpanded
238+ , simpleQueryStringLocale :: Maybe Locale
239+ } deriving (Eq, Show)
240+
241+data SimpleQueryFlag =
242+ SimpleQueryAll
243+ | SimpleQueryNone
244+ | SimpleQueryAnd
245+ | SimpleQueryOr
246+ | SimpleQueryPrefix
247+ | SimpleQueryPhrase
248+ | SimpleQueryPrecedence
249+ | SimpleQueryEscape
250+ | SimpleQueryWhitespace
251+ | SimpleQueryFuzzy
252+ | SimpleQueryNear
253+ | SimpleQuerySlop deriving (Eq, Show)
254+
255+-- use_dis_max and tie_breaker when fields are plural?
256+data QueryStringQuery =
257+ QueryStringQuery
258+ { queryStringQuery :: QueryString
259+ , queryStringDefaultField :: Maybe FieldName
260+ , queryStringOperator :: Maybe BooleanOperator
261+ , queryStringAnalyzer :: Maybe Analyzer
262+ , queryStringAllowLeadingWildcard :: Maybe AllowLeadingWildcard
263+ , queryStringLowercaseExpanded :: Maybe LowercaseExpanded
264+ , queryStringEnablePositionIncrements :: Maybe EnablePositionIncrements
265+ , queryStringFuzzyMaxExpansions :: Maybe MaxExpansions
266+ , queryStringFuzziness :: Maybe Fuzziness
267+ , queryStringFuzzyPrefixLength :: Maybe PrefixLength
268+ , queryStringPhraseSlop :: Maybe PhraseSlop
269+ , queryStringBoost :: Maybe Boost
270+ , queryStringAnalyzeWildcard :: Maybe AnalyzeWildcard
271+ , queryStringGeneratePhraseQueries :: Maybe GeneratePhraseQueries
272+ , queryStringMinimumShouldMatch :: Maybe MinimumMatch
273+ , queryStringLenient :: Maybe Lenient
274+ , queryStringLocale :: Maybe Locale
275+ } deriving (Eq, Show)
276+
277+mkQueryStringQuery :: QueryString -> QueryStringQuery
278+mkQueryStringQuery qs =
279+ QueryStringQuery qs Nothing Nothing
280+ Nothing Nothing Nothing Nothing
281+ Nothing Nothing Nothing Nothing
282+ Nothing Nothing Nothing Nothing
283+ Nothing Nothing
284+
285+data FieldOrFields = FofField FieldName
286+ | FofFields (NonEmpty FieldName) deriving (Eq, Show)
287+
288+data PrefixQuery =
289+ PrefixQuery
290+ { prefixQueryField :: FieldName
291+ , prefixQueryPrefixValue :: Text
292+ , prefixQueryBoost :: Maybe Boost } deriving (Eq, Show)
293+
294+data NestedQuery =
295+ NestedQuery
296+ { nestedQueryPath :: QueryPath
297+ , nestedQueryScoreType :: ScoreType
298+ , nestedQuery :: Query } deriving (Eq, Show)
299+
300+data MoreLikeThisFieldQuery =
301+ MoreLikeThisFieldQuery
302+ { moreLikeThisFieldText :: Text
303+ , moreLikeThisFieldFields :: FieldName
304+ -- default 0.3 (30%)
305+ , moreLikeThisFieldPercentMatch :: Maybe PercentMatch
306+ , moreLikeThisFieldMinimumTermFreq :: Maybe MinimumTermFrequency
307+ , moreLikeThisFieldMaxQueryTerms :: Maybe MaxQueryTerms
308+ , moreLikeThisFieldStopWords :: Maybe (NonEmpty StopWord)
309+ , moreLikeThisFieldMinDocFrequency :: Maybe MinDocFrequency
310+ , moreLikeThisFieldMaxDocFrequency :: Maybe MaxDocFrequency
311+ , moreLikeThisFieldMinWordLength :: Maybe MinWordLength
312+ , moreLikeThisFieldMaxWordLength :: Maybe MaxWordLength
313+ , moreLikeThisFieldBoostTerms :: Maybe BoostTerms
314+ , moreLikeThisFieldBoost :: Maybe Boost
315+ , moreLikeThisFieldAnalyzer :: Maybe Analyzer
316+ } deriving (Eq, Show)
317+
318+data MoreLikeThisQuery =
319+ MoreLikeThisQuery
320+ { moreLikeThisText :: Text
321+ , moreLikeThisFields :: Maybe (NonEmpty FieldName)
322+ -- default 0.3 (30%)
323+ , moreLikeThisPercentMatch :: Maybe PercentMatch
324+ , moreLikeThisMinimumTermFreq :: Maybe MinimumTermFrequency
325+ , moreLikeThisMaxQueryTerms :: Maybe MaxQueryTerms
326+ , moreLikeThisStopWords :: Maybe (NonEmpty StopWord)
327+ , moreLikeThisMinDocFrequency :: Maybe MinDocFrequency
328+ , moreLikeThisMaxDocFrequency :: Maybe MaxDocFrequency
329+ , moreLikeThisMinWordLength :: Maybe MinWordLength
330+ , moreLikeThisMaxWordLength :: Maybe MaxWordLength
331+ , moreLikeThisBoostTerms :: Maybe BoostTerms
332+ , moreLikeThisBoost :: Maybe Boost
333+ , moreLikeThisAnalyzer :: Maybe Analyzer
334+ } deriving (Eq, Show)
335+
336+data IndicesQuery =
337+ IndicesQuery
338+ { indicesQueryIndices :: [IndexName]
339+ , indicesQuery :: Query
340+ -- default "all"
341+ , indicesQueryNoMatch :: Maybe Query } deriving (Eq, Show)
342+
343+data HasParentQuery =
344+ HasParentQuery
345+ { hasParentQueryType :: TypeName
346+ , hasParentQuery :: Query
347+ , hasParentQueryScoreType :: Maybe ScoreType } deriving (Eq, Show)
348+
349+data HasChildQuery =
350+ HasChildQuery
351+ { hasChildQueryType :: TypeName
352+ , hasChildQuery :: Query
353+ , hasChildQueryScoreType :: Maybe ScoreType } deriving (Eq, Show)
354+
355+data ScoreType =
356+ ScoreTypeMax
357+ | ScoreTypeSum
358+ | ScoreTypeAvg
359+ | ScoreTypeNone deriving (Eq, Show)
360+
361+data FuzzyQuery =
362+ FuzzyQuery { fuzzyQueryField :: FieldName
363+ , fuzzyQueryValue :: Text
364+ , fuzzyQueryPrefixLength :: PrefixLength
365+ , fuzzyQueryMaxExpansions :: MaxExpansions
366+ , fuzzyQueryFuzziness :: Fuzziness
367+ , fuzzyQueryBoost :: Maybe Boost
368+ } deriving (Eq, Show)
369+
370+data FuzzyLikeFieldQuery =
371+ FuzzyLikeFieldQuery
372+ { fuzzyLikeField :: FieldName
373+ -- anaphora is good for the soul.
374+ , fuzzyLikeFieldText :: Text
375+ , fuzzyLikeFieldMaxQueryTerms :: MaxQueryTerms
376+ , fuzzyLikeFieldIgnoreTermFrequency :: IgnoreTermFrequency
377+ , fuzzyLikeFieldFuzziness :: Fuzziness
378+ , fuzzyLikeFieldPrefixLength :: PrefixLength
379+ , fuzzyLikeFieldBoost :: Boost
380+ , fuzzyLikeFieldAnalyzer :: Maybe Analyzer
381+ } deriving (Eq, Show)
382+
383+data FuzzyLikeThisQuery =
384+ FuzzyLikeThisQuery
385+ { fuzzyLikeFields :: [FieldName]
386+ , fuzzyLikeText :: Text
387+ , fuzzyLikeMaxQueryTerms :: MaxQueryTerms
388+ , fuzzyLikeIgnoreTermFrequency :: IgnoreTermFrequency
389+ , fuzzyLikeFuzziness :: Fuzziness
390+ , fuzzyLikePrefixLength :: PrefixLength
391+ , fuzzyLikeBoost :: Boost
392+ , fuzzyLikeAnalyzer :: Maybe Analyzer
393+ } deriving (Eq, Show)
394+
395+data FilteredQuery =
396+ FilteredQuery
397+ { filteredQuery :: Query
398+ , filteredFilter :: Filter } deriving (Eq, Show)
399+
400+data DisMaxQuery =
401+ DisMaxQuery { disMaxQueries :: [Query]
402+ -- default 0.0
403+ , disMaxTiebreaker :: Tiebreaker
404+ , disMaxBoost :: Maybe Boost
405+ } deriving (Eq, Show)
406+
407+data MatchQuery =
408+ MatchQuery { matchQueryField :: FieldName
409+ , matchQueryQueryString :: QueryString
410+ , matchQueryOperator :: BooleanOperator
411+ , matchQueryZeroTerms :: ZeroTermsQuery
412+ , matchQueryCutoffFrequency :: Maybe CutoffFrequency
413+ , matchQueryMatchType :: Maybe MatchQueryType
414+ , matchQueryAnalyzer :: Maybe Analyzer
415+ , matchQueryMaxExpansions :: Maybe MaxExpansions
416+ , matchQueryLenient :: Maybe Lenient
417+ , matchQueryBoost :: Maybe Boost } deriving (Eq, Show)
418+
419+{-| 'mkMatchQuery' is a convenience function that defaults the less common parameters,
420+ enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery'
421+-}
422+mkMatchQuery :: FieldName -> QueryString -> MatchQuery
423+mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing
424+
425+data MatchQueryType =
426+ MatchPhrase
427+ | MatchPhrasePrefix deriving (Eq, Show)
428+
429+data MultiMatchQuery =
430+ MultiMatchQuery { multiMatchQueryFields :: [FieldName]
431+ , multiMatchQueryString :: QueryString
432+ , multiMatchQueryOperator :: BooleanOperator
433+ , multiMatchQueryZeroTerms :: ZeroTermsQuery
434+ , multiMatchQueryTiebreaker :: Maybe Tiebreaker
435+ , multiMatchQueryType :: Maybe MultiMatchQueryType
436+ , multiMatchQueryCutoffFrequency :: Maybe CutoffFrequency
437+ , multiMatchQueryAnalyzer :: Maybe Analyzer
438+ , multiMatchQueryMaxExpansions :: Maybe MaxExpansions
439+ , multiMatchQueryLenient :: Maybe Lenient } deriving (Eq, Show)
440+
441+{-| 'mkMultiMatchQuery' is a convenience function that defaults the less common parameters,
442+ enabling you to provide only the list of 'FieldName's and 'QueryString' to
443+ make a 'MultiMatchQuery'.
444+-}
445+
446+mkMultiMatchQuery :: [FieldName] -> QueryString -> MultiMatchQuery
447+mkMultiMatchQuery matchFields query =
448+ MultiMatchQuery matchFields query
449+ Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing
450+
451+data MultiMatchQueryType =
452+ MultiMatchBestFields
453+ | MultiMatchMostFields
454+ | MultiMatchCrossFields
455+ | MultiMatchPhrase
456+ | MultiMatchPhrasePrefix deriving (Eq, Show)
457+
458+data BoolQuery =
459+ BoolQuery { boolQueryMustMatch :: [Query]
460+ , boolQueryMustNotMatch :: [Query]
461+ , boolQueryShouldMatch :: [Query]
462+ , boolQueryMinimumShouldMatch :: Maybe MinimumMatch
463+ , boolQueryBoost :: Maybe Boost
464+ , boolQueryDisableCoord :: Maybe DisableCoord
465+ } deriving (Eq, Show)
466+
467+mkBoolQuery :: [Query] -> [Query] -> [Query] -> BoolQuery
468+mkBoolQuery must mustNot should =
469+ BoolQuery must mustNot should Nothing Nothing Nothing
470+
471+data BoostingQuery =
472+ BoostingQuery { positiveQuery :: Query
473+ , negativeQuery :: Query
474+ , negativeBoost :: Boost } deriving (Eq, Show)
475+
476+data CommonTermsQuery =
477+ CommonTermsQuery { commonField :: FieldName
478+ , commonQuery :: QueryString
479+ , commonCutoffFrequency :: CutoffFrequency
480+ , commonLowFreqOperator :: BooleanOperator
481+ , commonHighFreqOperator :: BooleanOperator
482+ , commonMinimumShouldMatch :: Maybe CommonMinimumMatch
483+ , commonBoost :: Maybe Boost
484+ , commonAnalyzer :: Maybe Analyzer
485+ , commonDisableCoord :: Maybe DisableCoord
486+ } deriving (Eq, Show)
487+
488+data CommonMinimumMatch =
489+ CommonMinimumMatchHighLow MinimumMatchHighLow
490+ | CommonMinimumMatch MinimumMatch
491+ deriving (Eq, Show)
492+
493+data MinimumMatchHighLow =
494+ MinimumMatchHighLow { lowFreq :: MinimumMatch
495+ , highFreq :: MinimumMatch } deriving (Eq, Show)
496+
497+
498+data TemplateQueryInline =
499+ TemplateQueryInline { inline :: Query
500+ , params :: TemplateQueryKeyValuePairs
501+ }
502+ deriving (Eq, Show)
503+
504+instance ToJSON TemplateQueryInline where
505+ toJSON TemplateQueryInline{..} = object [ "query" .= inline
506+ , "params" .= params
507+ ]
508+
509+instance FromJSON TemplateQueryInline where
510+ parseJSON = withObject "TemplateQueryInline" parse
511+ where parse o = TemplateQueryInline
512+ <$> o .: "query"
513+ <*> o .: "params"
514+
515+{-| 'BooleanOperator' is the usual And/Or operators with an ES compatible
516+ JSON encoding baked in. Used all over the place.
517+-}
518+data BooleanOperator = And | Or deriving (Eq, Show)
519+
520+type TemplateQueryKey = Text
521+type TemplateQueryValue = Text
522+
523+newtype TemplateQueryKeyValuePairs = TemplateQueryKeyValuePairs (HM.HashMap TemplateQueryKey TemplateQueryValue)
524+ deriving (Eq, Show)
525+
526+instance ToJSON TemplateQueryKeyValuePairs where
527+ toJSON (TemplateQueryKeyValuePairs x) = Object $ HM.map toJSON x
528+
529+instance FromJSON TemplateQueryKeyValuePairs where
530+ parseJSON (Object o) = pure . TemplateQueryKeyValuePairs $ HM.mapMaybe getValue o
531+ where getValue (String x) = Just x
532+ getValue _ = Nothing
533+ parseJSON _ = fail "error parsing TemplateQueryKeyValuePairs"
534+
535+newtype Regexp = Regexp Text deriving (Eq, Show, FromJSON)
536+
537+data RegexpFlags = AllRegexpFlags
538+ | NoRegexpFlags
539+ | SomeRegexpFlags (NonEmpty RegexpFlag) deriving (Eq, Show)
540+
541+data RegexpFlag = AnyString
542+ | Automaton
543+ | Complement
544+ | Empty
545+ | Intersection
546+ | Interval deriving (Eq, Show)
547+
548+data RangeExecution = RangeExecutionIndex
549+ | RangeExecutionFielddata deriving (Eq, Show)
550+
551+data ZeroTermsQuery = ZeroTermsNone
552+ | ZeroTermsAll deriving (Eq, Show)
553+
554+instance ToJSON Query where
555+ toJSON (TermQuery (Term termQueryField termQueryValue) boost) =
556+ object [ "term" .=
557+ object [termQueryField .= object merged]]
558+ where
559+ base = [ "value" .= termQueryValue ]
560+ boosted = maybe [] (return . ("boost" .=)) boost
561+ merged = mappend base boosted
562+
563+ toJSON (TermsQuery fieldName terms) =
564+ object [ "terms" .= object conjoined ]
565+ where conjoined = [fieldName .= terms]
566+
567+ toJSON (IdsQuery idsQueryMappingName docIds) =
568+ object [ "ids" .= object conjoined ]
569+ where conjoined = [ "type" .= idsQueryMappingName
570+ , "values" .= fmap toJSON docIds ]
571+
572+ toJSON (QueryQueryStringQuery qQueryStringQuery) =
573+ object [ "query_string" .= qQueryStringQuery ]
574+
575+ toJSON (QueryMatchQuery matchQuery) =
576+ object [ "match" .= matchQuery ]
577+
578+ toJSON (QueryMultiMatchQuery multiMatchQuery) =
579+ toJSON multiMatchQuery
580+
581+ toJSON (QueryBoolQuery boolQuery) =
582+ object [ "bool" .= boolQuery ]
583+
584+ toJSON (QueryBoostingQuery boostingQuery) =
585+ object [ "boosting" .= boostingQuery ]
586+
587+ toJSON (QueryCommonTermsQuery commonTermsQuery) =
588+ object [ "common" .= commonTermsQuery ]
589+
590+ toJSON (ConstantScoreFilter csFilter boost) =
591+ object ["constant_score" .= object ["filter" .= csFilter
592+ , "boost" .= boost]]
593+
594+ toJSON (ConstantScoreQuery query boost) =
595+ object ["constant_score" .= object ["query" .= query
596+ , "boost" .= boost]]
597+
598+ toJSON (QueryDisMaxQuery disMaxQuery) =
599+ object [ "dis_max" .= disMaxQuery ]
600+
601+ toJSON (QueryFilteredQuery qFilteredQuery) =
602+ object [ "filtered" .= qFilteredQuery ]
603+
604+ toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) =
605+ object [ "fuzzy_like_this" .= fuzzyQuery ]
606+
607+ toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) =
608+ object [ "fuzzy_like_this_field" .= fuzzyFieldQuery ]
609+
610+ toJSON (QueryFuzzyQuery fuzzyQuery) =
611+ object [ "fuzzy" .= fuzzyQuery ]
612+
613+ toJSON (QueryHasChildQuery childQuery) =
614+ object [ "has_child" .= childQuery ]
615+
616+ toJSON (QueryHasParentQuery parentQuery) =
617+ object [ "has_parent" .= parentQuery ]
618+
619+ toJSON (QueryIndicesQuery qIndicesQuery) =
620+ object [ "indices" .= qIndicesQuery ]
621+
622+ toJSON (MatchAllQuery boost) =
623+ object [ "match_all" .= omitNulls [ "boost" .= boost ] ]
624+
625+ toJSON (QueryMoreLikeThisQuery query) =
626+ object [ "more_like_this" .= query ]
627+
628+ toJSON (QueryMoreLikeThisFieldQuery query) =
629+ object [ "more_like_this_field" .= query ]
630+
631+ toJSON (QueryNestedQuery query) =
632+ object [ "nested" .= query ]
633+
634+ toJSON (QueryPrefixQuery query) =
635+ object [ "prefix" .= query ]
636+
637+ toJSON (QueryRangeQuery query) =
638+ object [ "range" .= query ]
639+
640+ toJSON (QueryRegexpQuery query) =
641+ object [ "regexp" .= query ]
642+
643+ toJSON (QuerySimpleQueryStringQuery query) =
644+ object [ "simple_query_string" .= query ]
645+
646+ toJSON (QueryTemplateQueryInline templateQuery) =
647+ object [ "template" .= templateQuery ]
648+
649+instance FromJSON Query where
650+ parseJSON v = withObject "Query" parse v
651+ where parse o = termQuery `taggedWith` "term"
652+ <|> termsQuery `taggedWith` "terms"
653+ <|> idsQuery `taggedWith` "ids"
654+ <|> queryQueryStringQuery `taggedWith` "query_string"
655+ <|> queryMatchQuery `taggedWith` "match"
656+ <|> queryMultiMatchQuery
657+ <|> queryBoolQuery `taggedWith` "bool"
658+ <|> queryBoostingQuery `taggedWith` "boosting"
659+ <|> queryCommonTermsQuery `taggedWith` "common"
660+ <|> constantScoreFilter `taggedWith` "constant_score"
661+ <|> constantScoreQuery `taggedWith` "constant_score"
662+ <|> queryDisMaxQuery `taggedWith` "dis_max"
663+ <|> queryFilteredQuery `taggedWith` "filtered"
664+ <|> queryFuzzyLikeThisQuery `taggedWith` "fuzzy_like_this"
665+ <|> queryFuzzyLikeFieldQuery `taggedWith` "fuzzy_like_this_field"
666+ <|> queryFuzzyQuery `taggedWith` "fuzzy"
667+ <|> queryHasChildQuery `taggedWith` "has_child"
668+ <|> queryHasParentQuery `taggedWith` "has_parent"
669+ <|> queryIndicesQuery `taggedWith` "indices"
670+ <|> matchAllQuery `taggedWith` "match_all"
671+ <|> queryMoreLikeThisQuery `taggedWith` "more_like_this"
672+ <|> queryMoreLikeThisFieldQuery `taggedWith` "more_like_this_field"
673+ <|> queryNestedQuery `taggedWith` "nested"
674+ <|> queryPrefixQuery `taggedWith` "prefix"
675+ <|> queryRangeQuery `taggedWith` "range"
676+ <|> queryRegexpQuery `taggedWith` "regexp"
677+ <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"
678+ <|> queryTemplateQueryInline `taggedWith` "template"
679+ where taggedWith parser k = parser =<< o .: k
680+ termQuery = fieldTagged $ \(FieldName fn) o ->
681+ TermQuery <$> (Term fn <$> o .: "value") <*> o .:? "boost"
682+ termsQuery o = case HM.toList o of
683+ [(fn, vs)] -> do vals <- parseJSON vs
684+ case vals of
685+ x:xs -> return (TermsQuery fn (x :| xs))
686+ _ -> fail "Expected non empty list of values"
687+ _ -> fail "Expected object with 1 field-named key"
688+ idsQuery o = IdsQuery <$> o .: "type"
689+ <*> o .: "values"
690+ queryQueryStringQuery = pure . QueryQueryStringQuery
691+ queryMatchQuery = pure . QueryMatchQuery
692+ queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v
693+ queryBoolQuery = pure . QueryBoolQuery
694+ queryBoostingQuery = pure . QueryBoostingQuery
695+ queryCommonTermsQuery = pure . QueryCommonTermsQuery
696+ constantScoreFilter o = case HM.lookup "filter" o of
697+ Just x -> ConstantScoreFilter <$> parseJSON x
698+ <*> o .: "boost"
699+ _ -> fail "Does not appear to be a ConstantScoreFilter"
700+ constantScoreQuery o = case HM.lookup "query" o of
701+ Just x -> ConstantScoreQuery <$> parseJSON x
702+ <*> o .: "boost"
703+ _ -> fail "Does not appear to be a ConstantScoreQuery"
704+ queryDisMaxQuery = pure . QueryDisMaxQuery
705+ queryFilteredQuery = pure . QueryFilteredQuery
706+ queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery
707+ queryFuzzyLikeFieldQuery = pure . QueryFuzzyLikeFieldQuery
708+ queryFuzzyQuery = pure . QueryFuzzyQuery
709+ queryHasChildQuery = pure . QueryHasChildQuery
710+ queryHasParentQuery = pure . QueryHasParentQuery
711+ queryIndicesQuery = pure . QueryIndicesQuery
712+ matchAllQuery o = MatchAllQuery <$> o .:? "boost"
713+ queryMoreLikeThisQuery = pure . QueryMoreLikeThisQuery
714+ queryMoreLikeThisFieldQuery = pure . QueryMoreLikeThisFieldQuery
715+ queryNestedQuery = pure . QueryNestedQuery
716+ queryPrefixQuery = pure . QueryPrefixQuery
717+ queryRangeQuery = pure . QueryRangeQuery
718+ queryRegexpQuery = pure . QueryRegexpQuery
719+ querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery
720+ queryTemplateQueryInline = pure . QueryTemplateQueryInline
721+
722+instance ToJSON SimpleQueryStringQuery where
723+ toJSON SimpleQueryStringQuery {..} =
724+ omitNulls (base ++ maybeAdd)
725+ where base = [ "query" .= simpleQueryStringQuery ]
726+ maybeAdd = [ "fields" .= simpleQueryStringField
727+ , "default_operator" .= simpleQueryStringOperator
728+ , "analyzer" .= simpleQueryStringAnalyzer
729+ , "flags" .= simpleQueryStringFlags
730+ , "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded
731+ , "locale" .= simpleQueryStringLocale ]
732+
733+instance FromJSON SimpleQueryStringQuery where
734+ parseJSON = withObject "SimpleQueryStringQuery" parse
735+ where parse o = SimpleQueryStringQuery <$> o .: "query"
736+ <*> o .:? "fields"
737+ <*> o .:? "default_operator"
738+ <*> o .:? "analyzer"
739+ <*> (parseFlags <$> o .:? "flags")
740+ <*> o .:? "lowercase_expanded_terms"
741+ <*> o .:? "locale"
742+ parseFlags (Just (x:xs)) = Just (x :| xs)
743+ parseFlags _ = Nothing
744+
745+instance ToJSON FieldOrFields where
746+ toJSON (FofField fieldName) =
747+ toJSON fieldName
748+ toJSON (FofFields fieldNames) =
749+ toJSON fieldNames
750+
751+instance FromJSON FieldOrFields where
752+ parseJSON v = FofField <$> parseJSON v
753+ <|> FofFields <$> (parseNEJSON =<< parseJSON v)
754+
755+instance ToJSON SimpleQueryFlag where
756+ toJSON SimpleQueryAll = "ALL"
757+ toJSON SimpleQueryNone = "NONE"
758+ toJSON SimpleQueryAnd = "AND"
759+ toJSON SimpleQueryOr = "OR"
760+ toJSON SimpleQueryPrefix = "PREFIX"
761+ toJSON SimpleQueryPhrase = "PHRASE"
762+ toJSON SimpleQueryPrecedence = "PRECEDENCE"
763+ toJSON SimpleQueryEscape = "ESCAPE"
764+ toJSON SimpleQueryWhitespace = "WHITESPACE"
765+ toJSON SimpleQueryFuzzy = "FUZZY"
766+ toJSON SimpleQueryNear = "NEAR"
767+ toJSON SimpleQuerySlop = "SLOP"
768+
769+instance FromJSON SimpleQueryFlag where
770+ parseJSON = withText "SimpleQueryFlag" parse
771+ where parse "ALL" = pure SimpleQueryAll
772+ parse "NONE" = pure SimpleQueryNone
773+ parse "AND" = pure SimpleQueryAnd
774+ parse "OR" = pure SimpleQueryOr
775+ parse "PREFIX" = pure SimpleQueryPrefix
776+ parse "PHRASE" = pure SimpleQueryPhrase
777+ parse "PRECEDENCE" = pure SimpleQueryPrecedence
778+ parse "ESCAPE" = pure SimpleQueryEscape
779+ parse "WHITESPACE" = pure SimpleQueryWhitespace
780+ parse "FUZZY" = pure SimpleQueryFuzzy
781+ parse "NEAR" = pure SimpleQueryNear
782+ parse "SLOP" = pure SimpleQuerySlop
783+ parse f = fail ("Unexpected SimpleQueryFlag: " <> show f)
784+
785+instance ToJSON RegexpQuery where
786+ toJSON (RegexpQuery (FieldName rqQueryField)
787+ (Regexp regexpQueryQuery) rqQueryFlags
788+ rqQueryBoost) =
789+ object [ rqQueryField .= omitNulls base ]
790+ where base = [ "value" .= regexpQueryQuery
791+ , "flags" .= rqQueryFlags
792+ , "boost" .= rqQueryBoost ]
793+
794+instance FromJSON RegexpQuery where
795+ parseJSON = withObject "RegexpQuery" parse
796+ where parse = fieldTagged $ \fn o ->
797+ RegexpQuery fn
798+ <$> o .: "value"
799+ <*> o .: "flags"
800+ <*> o .:? "boost"
801+
802+instance ToJSON QueryStringQuery where
803+ toJSON (QueryStringQuery qsQueryString
804+ qsDefaultField qsOperator
805+ qsAnalyzer qsAllowWildcard
806+ qsLowercaseExpanded qsEnablePositionIncrements
807+ qsFuzzyMaxExpansions qsFuzziness
808+ qsFuzzyPrefixLength qsPhraseSlop
809+ qsBoost qsAnalyzeWildcard
810+ qsGeneratePhraseQueries qsMinimumShouldMatch
811+ qsLenient qsLocale) =
812+ omitNulls base
813+ where
814+ base = [ "query" .= qsQueryString
815+ , "default_field" .= qsDefaultField
816+ , "default_operator" .= qsOperator
817+ , "analyzer" .= qsAnalyzer
818+ , "allow_leading_wildcard" .= qsAllowWildcard
819+ , "lowercase_expanded_terms" .= qsLowercaseExpanded
820+ , "enable_position_increments" .= qsEnablePositionIncrements
821+ , "fuzzy_max_expansions" .= qsFuzzyMaxExpansions
822+ , "fuzziness" .= qsFuzziness
823+ , "fuzzy_prefix_length" .= qsFuzzyPrefixLength
824+ , "phrase_slop" .= qsPhraseSlop
825+ , "boost" .= qsBoost
826+ , "analyze_wildcard" .= qsAnalyzeWildcard
827+ , "auto_generate_phrase_queries" .= qsGeneratePhraseQueries
828+ , "minimum_should_match" .= qsMinimumShouldMatch
829+ , "lenient" .= qsLenient
830+ , "locale" .= qsLocale ]
831+
832+instance FromJSON QueryStringQuery where
833+ parseJSON = withObject "QueryStringQuery" parse
834+ where parse o = QueryStringQuery
835+ <$> o .: "query"
836+ <*> o .:? "default_field"
837+ <*> o .:? "default_operator"
838+ <*> o .:? "analyzer"
839+ <*> o .:? "allow_leading_wildcard"
840+ <*> o .:? "lowercase_expanded_terms"
841+ <*> o .:? "enable_position_increments"
842+ <*> o .:? "fuzzy_max_expansions"
843+ <*> o .:? "fuzziness"
844+ <*> o .:? "fuzzy_prefix_length"
845+ <*> o .:? "phrase_slop"
846+ <*> o .:? "boost"
847+ <*> o .:? "analyze_wildcard"
848+ <*> o .:? "auto_generate_phrase_queries"
849+ <*> o .:? "minimum_should_match"
850+ <*> o .:? "lenient"
851+ <*> o .:? "locale"
852+
853+instance ToJSON RangeQuery where
854+ toJSON (RangeQuery (FieldName fieldName) range boost) =
855+ object [ fieldName .= object conjoined ]
856+ where conjoined = [ "boost" .= boost ] ++ (rangeValueToPair range)
857+
858+instance FromJSON RangeQuery where
859+ parseJSON = withObject "RangeQuery" parse
860+ where parse = fieldTagged $ \fn o ->
861+ RangeQuery fn
862+ <$> parseJSON (Object o)
863+ <*> o .: "boost"
864+
865+instance FromJSON RangeValue where
866+ parseJSON = withObject "RangeValue" parse
867+ where parse o = parseDate o
868+ <|> parseDouble o
869+ parseDate o = do lt <- o .:? "lt"
870+ lte <- o .:? "lte"
871+ gt <- o .:? "gt"
872+ gte <- o .:? "gte"
873+ case (lt, lte, gt, gte) of
874+ (Just a, _, Just b, _) -> return (RangeDateGtLt (GreaterThanD b) (LessThanD a))
875+ (Just a, _, _, Just b)-> return (RangeDateGteLt (GreaterThanEqD b) (LessThanD a))
876+ (_, Just a, Just b, _)-> return (RangeDateGtLte (GreaterThanD b) (LessThanEqD a))
877+ (_, Just a, _, Just b)-> return (RangeDateGteLte (GreaterThanEqD b) (LessThanEqD a))
878+ (_, _, Just a, _)-> return (RangeDateGt (GreaterThanD a))
879+ (Just a, _, _, _)-> return (RangeDateLt (LessThanD a))
880+ (_, _, _, Just a)-> return (RangeDateGte (GreaterThanEqD a))
881+ (_, Just a, _, _)-> return (RangeDateLte (LessThanEqD a))
882+ (Nothing, Nothing, Nothing, Nothing) -> mzero
883+ parseDouble o = do lt <- o .:? "lt"
884+ lte <- o .:? "lte"
885+ gt <- o .:? "gt"
886+ gte <- o .:? "gte"
887+ case (lt, lte, gt, gte) of
888+ (Just a, _, Just b, _) -> return (RangeDoubleGtLt (GreaterThan b) (LessThan a))
889+ (Just a, _, _, Just b)-> return (RangeDoubleGteLt (GreaterThanEq b) (LessThan a))
890+ (_, Just a, Just b, _)-> return (RangeDoubleGtLte (GreaterThan b) (LessThanEq a))
891+ (_, Just a, _, Just b)-> return (RangeDoubleGteLte (GreaterThanEq b) (LessThanEq a))
892+ (_, _, Just a, _)-> return (RangeDoubleGt (GreaterThan a))
893+ (Just a, _, _, _)-> return (RangeDoubleLt (LessThan a))
894+ (_, _, _, Just a)-> return (RangeDoubleGte (GreaterThanEq a))
895+ (_, Just a, _, _)-> return (RangeDoubleLte (LessThanEq a))
896+ (Nothing, Nothing, Nothing, Nothing) -> mzero
897+
898+instance ToJSON PrefixQuery where
899+ toJSON (PrefixQuery (FieldName fieldName) queryValue boost) =
900+ object [ fieldName .= omitNulls base ]
901+ where base = [ "value" .= queryValue
902+ , "boost" .= boost ]
903+
904+instance FromJSON PrefixQuery where
905+ parseJSON = withObject "PrefixQuery" parse
906+ where parse = fieldTagged $ \fn o ->
907+ PrefixQuery fn
908+ <$> o .: "value"
909+ <*> o .:? "boost"
910+
911+instance ToJSON NestedQuery where
912+ toJSON (NestedQuery nqPath nqScoreType nqQuery) =
913+ object [ "path" .= nqPath
914+ , "score_mode" .= nqScoreType
915+ , "query" .= nqQuery ]
916+
917+instance FromJSON NestedQuery where
918+ parseJSON = withObject "NestedQuery" parse
919+ where parse o = NestedQuery
920+ <$> o .: "path"
921+ <*> o .: "score_mode"
922+ <*> o .: "query"
923+
924+instance ToJSON MoreLikeThisFieldQuery where
925+ toJSON (MoreLikeThisFieldQuery text (FieldName fieldName)
926+ percent mtf mqt stopwords mindf maxdf
927+ minwl maxwl boostTerms boost analyzer) =
928+ object [ fieldName .= omitNulls base ]
929+ where base = [ "like_text" .= text
930+ , "percent_terms_to_match" .= percent
931+ , "min_term_freq" .= mtf
932+ , "max_query_terms" .= mqt
933+ , "stop_words" .= stopwords
934+ , "min_doc_freq" .= mindf
935+ , "max_doc_freq" .= maxdf
936+ , "min_word_length" .= minwl
937+ , "max_word_length" .= maxwl
938+ , "boost_terms" .= boostTerms
939+ , "boost" .= boost
940+ , "analyzer" .= analyzer ]
941+
942+instance FromJSON MoreLikeThisFieldQuery where
943+ parseJSON = withObject "MoreLikeThisFieldQuery" parse
944+ where parse = fieldTagged $ \fn o ->
945+ MoreLikeThisFieldQuery
946+ <$> o .: "like_text"
947+ <*> pure fn
948+ <*> o .:? "percent_terms_to_match"
949+ <*> o .:? "min_term_freq"
950+ <*> o .:? "max_query_terms"
951+ -- <*> (optionalNE =<< o .:? "stop_words")
952+ <*> o .:? "stop_words"
953+ <*> o .:? "min_doc_freq"
954+ <*> o .:? "max_doc_freq"
955+ <*> o .:? "min_word_length"
956+ <*> o .:? "max_word_length"
957+ <*> o .:? "boost_terms"
958+ <*> o .:? "boost"
959+ <*> o .:? "analyzer"
960+ -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)
961+
962+instance ToJSON MoreLikeThisQuery where
963+ toJSON (MoreLikeThisQuery text fields percent
964+ mtf mqt stopwords mindf maxdf
965+ minwl maxwl boostTerms boost analyzer) =
966+ omitNulls base
967+ where base = [ "like_text" .= text
968+ , "fields" .= fields
969+ , "percent_terms_to_match" .= percent
970+ , "min_term_freq" .= mtf
971+ , "max_query_terms" .= mqt
972+ , "stop_words" .= stopwords
973+ , "min_doc_freq" .= mindf
974+ , "max_doc_freq" .= maxdf
975+ , "min_word_length" .= minwl
976+ , "max_word_length" .= maxwl
977+ , "boost_terms" .= boostTerms
978+ , "boost" .= boost
979+ , "analyzer" .= analyzer ]
980+
981+instance FromJSON MoreLikeThisQuery where
982+ parseJSON = withObject "MoreLikeThisQuery" parse
983+ where parse o = MoreLikeThisQuery
984+ <$> o .: "like_text"
985+ -- <*> (optionalNE =<< o .:? "fields")
986+ <*> o .:? "fields"
987+ <*> o .:? "percent_terms_to_match"
988+ <*> o .:? "min_term_freq"
989+ <*> o .:? "max_query_terms"
990+ -- <*> (optionalNE =<< o .:? "stop_words")
991+ <*> o .:? "stop_words"
992+ <*> o .:? "min_doc_freq"
993+ <*> o .:? "max_doc_freq"
994+ <*> o .:? "min_word_length"
995+ <*> o .:? "max_word_length"
996+ <*> o .:? "boost_terms"
997+ <*> o .:? "boost"
998+ <*> o .:? "analyzer"
999+ -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)
1000+
1001+instance ToJSON IndicesQuery where
1002+ toJSON (IndicesQuery indices query noMatch) =
1003+ omitNulls [ "indices" .= indices
1004+ , "no_match_query" .= noMatch
1005+ , "query" .= query ]
1006+
1007+instance FromJSON IndicesQuery where
1008+ parseJSON = withObject "IndicesQuery" parse
1009+ where parse o = IndicesQuery
1010+ <$> o .:? "indices" .!= []
1011+ <*> o .: "query"
1012+ <*> o .:? "no_match_query"
1013+
1014+instance ToJSON HasParentQuery where
1015+ toJSON (HasParentQuery queryType query scoreType) =
1016+ omitNulls [ "parent_type" .= queryType
1017+ , "score_type" .= scoreType
1018+ , "query" .= query ]
1019+
1020+instance FromJSON HasParentQuery where
1021+ parseJSON = withObject "HasParentQuery" parse
1022+ where parse o = HasParentQuery
1023+ <$> o .: "parent_type"
1024+ <*> o .: "query"
1025+ <*> o .:? "score_type"
1026+
1027+instance ToJSON HasChildQuery where
1028+ toJSON (HasChildQuery queryType query scoreType) =
1029+ omitNulls [ "query" .= query
1030+ , "score_type" .= scoreType
1031+ , "type" .= queryType ]
1032+
1033+instance FromJSON HasChildQuery where
1034+ parseJSON = withObject "HasChildQuery" parse
1035+ where parse o = HasChildQuery
1036+ <$> o .: "type"
1037+ <*> o .: "query"
1038+ <*> o .:? "score_type"
1039+
1040+instance ToJSON FuzzyQuery where
1041+ toJSON (FuzzyQuery (FieldName fieldName) queryText
1042+ prefixLength maxEx fuzziness boost) =
1043+ object [ fieldName .= omitNulls base ]
1044+ where base = [ "value" .= queryText
1045+ , "fuzziness" .= fuzziness
1046+ , "prefix_length" .= prefixLength
1047+ , "boost" .= boost
1048+ , "max_expansions" .= maxEx ]
1049+
1050+instance FromJSON FuzzyQuery where
1051+ parseJSON = withObject "FuzzyQuery" parse
1052+ where parse = fieldTagged $ \fn o ->
1053+ FuzzyQuery fn
1054+ <$> o .: "value"
1055+ <*> o .: "prefix_length"
1056+ <*> o .: "max_expansions"
1057+ <*> o .: "fuzziness"
1058+ <*> o .:? "boost"
1059+
1060+instance ToJSON FuzzyLikeFieldQuery where
1061+ toJSON (FuzzyLikeFieldQuery (FieldName fieldName)
1062+ fieldText maxTerms ignoreFreq fuzziness prefixLength
1063+ boost analyzer) =
1064+ object [ fieldName .=
1065+ omitNulls [ "like_text" .= fieldText
1066+ , "max_query_terms" .= maxTerms
1067+ , "ignore_tf" .= ignoreFreq
1068+ , "fuzziness" .= fuzziness
1069+ , "prefix_length" .= prefixLength
1070+ , "analyzer" .= analyzer
1071+ , "boost" .= boost ]]
1072+
1073+instance FromJSON FuzzyLikeFieldQuery where
1074+ parseJSON = withObject "FuzzyLikeFieldQuery" parse
1075+ where parse = fieldTagged $ \fn o ->
1076+ FuzzyLikeFieldQuery fn
1077+ <$> o .: "like_text"
1078+ <*> o .: "max_query_terms"
1079+ <*> o .: "ignore_tf"
1080+ <*> o .: "fuzziness"
1081+ <*> o .: "prefix_length"
1082+ <*> o .: "boost"
1083+ <*> o .:? "analyzer"
1084+
1085+instance ToJSON FuzzyLikeThisQuery where
1086+ toJSON (FuzzyLikeThisQuery fields text maxTerms
1087+ ignoreFreq fuzziness prefixLength boost analyzer) =
1088+ omitNulls base
1089+ where base = [ "fields" .= fields
1090+ , "like_text" .= text
1091+ , "max_query_terms" .= maxTerms
1092+ , "ignore_tf" .= ignoreFreq
1093+ , "fuzziness" .= fuzziness
1094+ , "prefix_length" .= prefixLength
1095+ , "analyzer" .= analyzer
1096+ , "boost" .= boost ]
1097+
1098+instance FromJSON FuzzyLikeThisQuery where
1099+ parseJSON = withObject "FuzzyLikeThisQuery" parse
1100+ where parse o = FuzzyLikeThisQuery
1101+ <$> o .:? "fields" .!= []
1102+ <*> o .: "like_text"
1103+ <*> o .: "max_query_terms"
1104+ <*> o .: "ignore_tf"
1105+ <*> o .: "fuzziness"
1106+ <*> o .: "prefix_length"
1107+ <*> o .: "boost"
1108+ <*> o .:? "analyzer"
1109+
1110+instance ToJSON FilteredQuery where
1111+ toJSON (FilteredQuery query fFilter) =
1112+ object [ "query" .= query
1113+ , "filter" .= fFilter ]
1114+
1115+instance FromJSON FilteredQuery where
1116+ parseJSON = withObject "FilteredQuery" parse
1117+ where parse o = FilteredQuery
1118+ <$> o .: "query"
1119+ <*> o .: "filter"
1120+
1121+instance ToJSON DisMaxQuery where
1122+ toJSON (DisMaxQuery queries tiebreaker boost) =
1123+ omitNulls base
1124+ where base = [ "queries" .= queries
1125+ , "boost" .= boost
1126+ , "tie_breaker" .= tiebreaker ]
1127+
1128+instance FromJSON DisMaxQuery where
1129+ parseJSON = withObject "DisMaxQuery" parse
1130+ where parse o = DisMaxQuery
1131+ <$> o .:? "queries" .!= []
1132+ <*> o .: "tie_breaker"
1133+ <*> o .:? "boost"
1134+
1135+instance ToJSON CommonTermsQuery where
1136+ toJSON (CommonTermsQuery (FieldName fieldName)
1137+ (QueryString query) cf lfo hfo msm
1138+ boost analyzer disableCoord) =
1139+ object [fieldName .= omitNulls base ]
1140+ where base = [ "query" .= query
1141+ , "cutoff_frequency" .= cf
1142+ , "low_freq_operator" .= lfo
1143+ , "minimum_should_match" .= msm
1144+ , "boost" .= boost
1145+ , "analyzer" .= analyzer
1146+ , "disable_coord" .= disableCoord
1147+ , "high_freq_operator" .= hfo ]
1148+
1149+instance FromJSON CommonTermsQuery where
1150+ parseJSON = withObject "CommonTermsQuery" parse
1151+ where parse = fieldTagged $ \fn o ->
1152+ CommonTermsQuery fn
1153+ <$> o .: "query"
1154+ <*> o .: "cutoff_frequency"
1155+ <*> o .: "low_freq_operator"
1156+ <*> o .: "high_freq_operator"
1157+ <*> o .:? "minimum_should_match"
1158+ <*> o .:? "boost"
1159+ <*> o .:? "analyzer"
1160+ <*> o .:? "disable_coord"
1161+
1162+instance ToJSON CommonMinimumMatch where
1163+ toJSON (CommonMinimumMatch mm) = toJSON mm
1164+ toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) =
1165+ object [ "low_freq" .= lowF
1166+ , "high_freq" .= highF ]
1167+
1168+instance FromJSON CommonMinimumMatch where
1169+ parseJSON v = parseMinimum v
1170+ <|> parseMinimumHighLow v
1171+ where parseMinimum = fmap CommonMinimumMatch . parseJSON
1172+ parseMinimumHighLow = fmap CommonMinimumMatchHighLow . withObject "CommonMinimumMatchHighLow" (\o ->
1173+ MinimumMatchHighLow
1174+ <$> o .: "low_freq"
1175+ <*> o .: "high_freq")
1176+
1177+
1178+instance ToJSON BoostingQuery where
1179+ toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) =
1180+ object [ "positive" .= bqPositiveQuery
1181+ , "negative" .= bqNegativeQuery
1182+ , "negative_boost" .= bqNegativeBoost ]
1183+
1184+instance FromJSON BoostingQuery where
1185+ parseJSON = withObject "BoostingQuery" parse
1186+ where parse o = BoostingQuery
1187+ <$> o .: "positive"
1188+ <*> o .: "negative"
1189+ <*> o .: "negative_boost"
1190+
1191+instance ToJSON BoolQuery where
1192+ toJSON (BoolQuery mustM notM shouldM bqMin boost disableCoord) =
1193+ omitNulls base
1194+ where base = [ "must" .= mustM
1195+ , "must_not" .= notM
1196+ , "should" .= shouldM
1197+ , "minimum_should_match" .= bqMin
1198+ , "boost" .= boost
1199+ , "disable_coord" .= disableCoord ]
1200+
1201+instance FromJSON BoolQuery where
1202+ parseJSON = withObject "BoolQuery" parse
1203+ where parse o = BoolQuery
1204+ <$> o .:? "must" .!= []
1205+ <*> o .:? "must_not" .!= []
1206+ <*> o .:? "should" .!= []
1207+ <*> o .:? "minimum_should_match"
1208+ <*> o .:? "boost"
1209+ <*> o .:? "disable_coord"
1210+
1211+instance ToJSON MatchQuery where
1212+ toJSON (MatchQuery (FieldName fieldName)
1213+ (QueryString mqQueryString) booleanOperator
1214+ zeroTermsQuery cutoffFrequency matchQueryType
1215+ analyzer maxExpansions lenient boost) =
1216+ object [ fieldName .= omitNulls base ]
1217+ where base = [ "query" .= mqQueryString
1218+ , "operator" .= booleanOperator
1219+ , "zero_terms_query" .= zeroTermsQuery
1220+ , "cutoff_frequency" .= cutoffFrequency
1221+ , "type" .= matchQueryType
1222+ , "analyzer" .= analyzer
1223+ , "max_expansions" .= maxExpansions
1224+ , "lenient" .= lenient
1225+ , "boost" .= boost ]
1226+
1227+instance FromJSON MatchQuery where
1228+ parseJSON = withObject "MatchQuery" parse
1229+ where parse = fieldTagged $ \fn o ->
1230+ MatchQuery fn
1231+ <$> o .: "query"
1232+ <*> o .: "operator"
1233+ <*> o .: "zero_terms_query"
1234+ <*> o .:? "cutoff_frequency"
1235+ <*> o .:? "type"
1236+ <*> o .:? "analyzer"
1237+ <*> o .:? "max_expansions"
1238+ <*> o .:? "lenient"
1239+ <*> o .:? "boost"
1240+
1241+instance ToJSON MultiMatchQuery where
1242+ toJSON (MultiMatchQuery fields (QueryString query) boolOp
1243+ ztQ tb mmqt cf analyzer maxEx lenient) =
1244+ object ["multi_match" .= omitNulls base]
1245+ where base = [ "fields" .= fmap toJSON fields
1246+ , "query" .= query
1247+ , "operator" .= boolOp
1248+ , "zero_terms_query" .= ztQ
1249+ , "tie_breaker" .= tb
1250+ , "type" .= mmqt
1251+ , "cutoff_frequency" .= cf
1252+ , "analyzer" .= analyzer
1253+ , "max_expansions" .= maxEx
1254+ , "lenient" .= lenient ]
1255+
1256+instance FromJSON MultiMatchQuery where
1257+ parseJSON = withObject "MultiMatchQuery" parse
1258+ where parse raw = do o <- raw .: "multi_match"
1259+ MultiMatchQuery
1260+ <$> o .:? "fields" .!= []
1261+ <*> o .: "query"
1262+ <*> o .: "operator"
1263+ <*> o .: "zero_terms_query"
1264+ <*> o .:? "tie_breaker"
1265+ <*> o .:? "type"
1266+ <*> o .:? "cutoff_frequency"
1267+ <*> o .:? "analyzer"
1268+ <*> o .:? "max_expansions"
1269+ <*> o .:? "lenient"
1270+
1271+instance ToJSON Filter where
1272+ toJSON (AndFilter filters cache) =
1273+ object ["and" .=
1274+ object [ "filters" .= fmap toJSON filters
1275+ , "_cache" .= cache]]
1276+
1277+ toJSON (OrFilter filters cache) =
1278+ object ["or" .=
1279+ object [ "filters" .= fmap toJSON filters
1280+ , "_cache" .= cache]]
1281+
1282+ toJSON (NotFilter notFilter cache) =
1283+ object ["not" .=
1284+ object ["filter" .= notFilter
1285+ , "_cache" .= cache]]
1286+
1287+ toJSON (IdentityFilter) =
1288+ object ["match_all" .= object []]
1289+
1290+ toJSON (TermFilter (Term termFilterField termFilterValue) cache) =
1291+ object ["term" .= object base]
1292+ where base = [termFilterField .= termFilterValue,
1293+ "_cache" .= cache]
1294+
1295+ toJSON (ExistsFilter (FieldName fieldName)) =
1296+ object ["exists" .= object
1297+ ["field" .= fieldName]]
1298+
1299+ toJSON (BoolFilter boolMatch) =
1300+ object ["bool" .= boolMatch]
1301+
1302+ toJSON (GeoBoundingBoxFilter bbConstraint) =
1303+ object ["geo_bounding_box" .= bbConstraint]
1304+
1305+ toJSON (GeoDistanceFilter (GeoPoint (FieldName distanceGeoField) geoDistLatLon)
1306+ distance distanceType optimizeBbox cache) =
1307+ object ["geo_distance" .=
1308+ object ["distance" .= distance
1309+ , "distance_type" .= distanceType
1310+ , "optimize_bbox" .= optimizeBbox
1311+ , distanceGeoField .= geoDistLatLon
1312+ , "_cache" .= cache]]
1313+
1314+ toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName gddrField) drLatLon)
1315+ (DistanceRange geoDistRangeDistFrom drDistanceTo)) =
1316+ object ["geo_distance_range" .=
1317+ object ["from" .= geoDistRangeDistFrom
1318+ , "to" .= drDistanceTo
1319+ , gddrField .= drLatLon]]
1320+
1321+ toJSON (GeoPolygonFilter (FieldName geoPolygonFilterField) latLons) =
1322+ object ["geo_polygon" .=
1323+ object [geoPolygonFilterField .=
1324+ object ["points" .= fmap toJSON latLons]]]
1325+
1326+ toJSON (IdsFilter (MappingName mappingName) values) =
1327+ object ["ids" .=
1328+ object ["type" .= mappingName
1329+ , "values" .= fmap unpackId values]]
1330+
1331+ toJSON (LimitFilter limit) =
1332+ object ["limit" .= object ["value" .= limit]]
1333+
1334+ toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) =
1335+ object ["missing" .=
1336+ object [ "field" .= fieldName
1337+ , "existence" .= existence
1338+ , "null_value" .= nullValue]]
1339+
1340+ toJSON (PrefixFilter (FieldName fieldName) fieldValue cache) =
1341+ object ["prefix" .=
1342+ object [fieldName .= fieldValue
1343+ , "_cache" .= cache]]
1344+
1345+ toJSON (QueryFilter query False) =
1346+ object ["query" .= toJSON query ]
1347+ toJSON (QueryFilter query True) =
1348+ object ["fquery" .=
1349+ object [ "query" .= toJSON query
1350+ , "_cache" .= True ]]
1351+
1352+ toJSON (RangeFilter (FieldName fieldName) rangeValue rangeExecution cache) =
1353+ object ["range" .=
1354+ object [ fieldName .= object (rangeValueToPair rangeValue)
1355+ , "execution" .= rangeExecution
1356+ , "_cache" .= cache]]
1357+
1358+ toJSON (RegexpFilter (FieldName fieldName)
1359+ (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) =
1360+ object ["regexp" .=
1361+ object [fieldName .=
1362+ object ["value" .= regexText
1363+ , "flags" .= flags]
1364+ , "_name" .= cacheName
1365+ , "_cache" .= cache
1366+ , "_cache_key" .= cacheKey]]
1367+
1368+instance FromJSON Filter where
1369+ parseJSON = withObject "Filter" parse
1370+ where parse o = andFilter `taggedWith` "and"
1371+ <|> orFilter `taggedWith` "or"
1372+ <|> notFilter `taggedWith` "not"
1373+ <|> identityFilter `taggedWith` "match_all"
1374+ <|> boolFilter `taggedWith` "bool"
1375+ <|> existsFilter `taggedWith` "exists"
1376+ <|> geoBoundingBoxFilter `taggedWith` "geo_bounding_box"
1377+ <|> geoDistanceFilter `taggedWith` "geo_distance"
1378+ <|> geoDistanceRangeFilter `taggedWith` "geo_distance_range"
1379+ <|> geoPolygonFilter `taggedWith` "geo_polygon"
1380+ <|> idsFilter `taggedWith` "ids"
1381+ <|> limitFilter `taggedWith` "limit"
1382+ <|> missingFilter `taggedWith` "missing"
1383+ <|> prefixFilter `taggedWith` "prefix"
1384+ <|> queryFilter `taggedWith` "query"
1385+ <|> fqueryFilter `taggedWith` "fquery"
1386+ <|> rangeFilter `taggedWith` "range"
1387+ <|> regexpFilter `taggedWith` "regexp"
1388+ <|> termFilter `taggedWith` "term"
1389+ where taggedWith parser k = parser =<< o .: k
1390+ andFilter o = AndFilter <$> o .: "filters"
1391+ <*> o .:? "_cache" .!= defaultCache
1392+ orFilter o = OrFilter <$> o .: "filters"
1393+ <*> o .:? "_cache" .!= defaultCache
1394+ notFilter o = NotFilter <$> o .: "filter"
1395+ <*> o .: "_cache" .!= defaultCache
1396+ identityFilter :: Object -> Parser Filter
1397+ identityFilter m
1398+ | HM.null m = pure IdentityFilter
1399+ | otherwise = fail ("Identityfilter expected empty object but got " <> show m)
1400+ boolFilter = pure . BoolFilter
1401+ existsFilter o = ExistsFilter <$> o .: "field"
1402+ geoBoundingBoxFilter = pure . GeoBoundingBoxFilter
1403+ geoDistanceFilter o = do
1404+ case HM.toList (deleteSeveral ["distance", "distance_type", "optimize_bbox", "_cache"] o) of
1405+ [(fn, v)] -> do
1406+ gp <- GeoPoint (FieldName fn) <$> parseJSON v
1407+ GeoDistanceFilter gp <$> o .: "distance"
1408+ <*> o .: "distance_type"
1409+ <*> o .: "optimize_bbox"
1410+ <*> o .:? "_cache" .!= defaultCache
1411+ _ -> fail "Could not find GeoDistanceFilter field name"
1412+ geoDistanceRangeFilter o = do
1413+ case HM.toList (deleteSeveral ["from", "to"] o) of
1414+ [(fn, v)] -> do
1415+ gp <- GeoPoint (FieldName fn) <$> parseJSON v
1416+ rng <- DistanceRange <$> o .: "from" <*> o .: "to"
1417+ return (GeoDistanceRangeFilter gp rng)
1418+ _ -> fail "Could not find GeoDistanceRangeFilter field name"
1419+ geoPolygonFilter = fieldTagged $ \fn o -> GeoPolygonFilter fn <$> o .: "points"
1420+ idsFilter o = IdsFilter <$> o .: "type"
1421+ <*> o .: "values"
1422+ limitFilter o = LimitFilter <$> o .: "value"
1423+ missingFilter o = MissingFilter <$> o .: "field"
1424+ <*> o .: "existence"
1425+ <*> o .: "null_value"
1426+ prefixFilter o = case HM.toList (HM.delete "_cache" o) of
1427+ [(fn, String v)] -> PrefixFilter (FieldName fn) v <$> o .:? "_cache" .!= defaultCache
1428+ _ -> fail "Could not parse PrefixFilter"
1429+
1430+ queryFilter q = pure (QueryFilter q False)
1431+ fqueryFilter o = QueryFilter <$> o .: "query" <*> pure True
1432+ rangeFilter o = case HM.toList (deleteSeveral ["execution", "_cache"] o) of
1433+ [(fn, v)] -> RangeFilter (FieldName fn)
1434+ <$> parseJSON v
1435+ <*> o .: "execution"
1436+ <*> o .:? "_cache" .!= defaultCache
1437+ _ -> fail "Could not find field name for RangeFilter"
1438+ regexpFilter o = case HM.toList (deleteSeveral ["_name", "_cache", "_cache_key"] o) of
1439+ [(fn, Object o')] -> RegexpFilter (FieldName fn)
1440+ <$> o' .: "value"
1441+ <*> o' .: "flags"
1442+ <*> o .: "_name"
1443+ <*> o .:? "_cache" .!= defaultCache
1444+ <*> o .: "_cache_key"
1445+ _ -> fail "Could not find field name for RegexpFilter"
1446+ termFilter o = case HM.toList (HM.delete "_cache" o) of
1447+ [(termField, String termVal)] -> TermFilter (Term termField termVal)
1448+ <$> o .:? "_cache" .!= defaultCache
1449+ _ -> fail "Could not find term field for TermFilter"
1450+
1451+instance ToJSON BooleanOperator where
1452+ toJSON And = String "and"
1453+ toJSON Or = String "or"
1454+
1455+instance FromJSON BooleanOperator where
1456+ parseJSON = withText "BooleanOperator" parse
1457+ where parse "and" = pure And
1458+ parse "or" = pure Or
1459+ parse o = fail ("Unexpected BooleanOperator: " <> show o)
1460+
1461+instance ToJSON ZeroTermsQuery where
1462+ toJSON ZeroTermsNone = String "none"
1463+ toJSON ZeroTermsAll = String "all"
1464+
1465+instance FromJSON ZeroTermsQuery where
1466+ parseJSON = withText "ZeroTermsQuery" parse
1467+ where parse "none" = pure ZeroTermsNone
1468+ parse "all" = pure ZeroTermsAll
1469+ parse q = fail ("Unexpected ZeroTermsQuery: " <> show q)
1470+
1471+fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a
1472+fieldTagged f o = case HM.toList o of
1473+ [(k, Object o')] -> f (FieldName k) o'
1474+ _ -> fail "Expected object with 1 field-named key"
1475+
1476+instance ToJSON RangeExecution where
1477+ toJSON RangeExecutionIndex = "index"
1478+ toJSON RangeExecutionFielddata = "fielddata"
1479+
1480+
1481+instance FromJSON RangeExecution where
1482+ parseJSON = withText "RangeExecution" parse
1483+ where parse "index" = pure RangeExecutionIndex
1484+ parse "fielddata" = pure RangeExecutionFielddata
1485+ parse t = error ("Unrecognized RangeExecution " <> show t)
1486+
1487+instance ToJSON RegexpFlags where
1488+ toJSON AllRegexpFlags = String "ALL"
1489+ toJSON NoRegexpFlags = String "NONE"
1490+ toJSON (SomeRegexpFlags (h :| fs)) = String $ T.intercalate "|" flagStrs
1491+ where flagStrs = map flagStr . nub $ h:fs
1492+ flagStr AnyString = "ANYSTRING"
1493+ flagStr Automaton = "AUTOMATON"
1494+ flagStr Complement = "COMPLEMENT"
1495+ flagStr Empty = "EMPTY"
1496+ flagStr Intersection = "INTERSECTION"
1497+ flagStr Interval = "INTERVAL"
1498+
1499+instance FromJSON RegexpFlags where
1500+ parseJSON = withText "RegexpFlags" parse
1501+ where parse "ALL" = pure AllRegexpFlags
1502+ parse "NONE" = pure NoRegexpFlags
1503+ parse t = SomeRegexpFlags <$> parseNEJSON (String <$> T.splitOn "|" t)
1504+
1505+instance FromJSON RegexpFlag where
1506+ parseJSON = withText "RegexpFlag" parse
1507+ where parse "ANYSTRING" = pure AnyString
1508+ parse "AUTOMATON" = pure Automaton
1509+ parse "COMPLEMENT" = pure Complement
1510+ parse "EMPTY" = pure Empty
1511+ parse "INTERSECTION" = pure Intersection
1512+ parse "INTERVAL" = pure Interval
1513+ parse f = fail ("Unknown RegexpFlag: " <> show f)
1514+
1515+rangeValueToPair :: RangeValue -> [Pair]
1516+rangeValueToPair rv = case rv of
1517+ RangeDateLte (LessThanEqD t) -> ["lte" .= t]
1518+ RangeDateGte (GreaterThanEqD t) -> ["gte" .= t]
1519+ RangeDateLt (LessThanD t) -> ["lt" .= t]
1520+ RangeDateGt (GreaterThanD t) -> ["gt" .= t]
1521+ RangeDateGteLte (GreaterThanEqD l) (LessThanEqD g) -> ["gte" .= l, "lte" .= g]
1522+ RangeDateGtLte (GreaterThanD l) (LessThanEqD g) -> ["gt" .= l, "lte" .= g]
1523+ RangeDateGteLt (GreaterThanEqD l) (LessThanD g) -> ["gte" .= l, "lt" .= g]
1524+ RangeDateGtLt (GreaterThanD l) (LessThanD g) -> ["gt" .= l, "lt" .= g]
1525+ RangeDoubleLte (LessThanEq t) -> ["lte" .= t]
1526+ RangeDoubleGte (GreaterThanEq t) -> ["gte" .= t]
1527+ RangeDoubleLt (LessThan t) -> ["lt" .= t]
1528+ RangeDoubleGt (GreaterThan t) -> ["gt" .= t]
1529+ RangeDoubleGteLte (GreaterThanEq l) (LessThanEq g) -> ["gte" .= l, "lte" .= g]
1530+ RangeDoubleGtLte (GreaterThan l) (LessThanEq g) -> ["gt" .= l, "lte" .= g]
1531+ RangeDoubleGteLt (GreaterThanEq l) (LessThan g) -> ["gte" .= l, "lt" .= g]
1532+ RangeDoubleGtLt (GreaterThan l) (LessThan g) -> ["gt" .= l, "lt" .= g]
1533+
1534+instance ToJSON ScoreType where
1535+ toJSON ScoreTypeMax = "max"
1536+ toJSON ScoreTypeAvg = "avg"
1537+ toJSON ScoreTypeSum = "sum"
1538+ toJSON ScoreTypeNone = "none"
1539+
1540+instance FromJSON ScoreType where
1541+ parseJSON = withText "ScoreType" parse
1542+ where parse "max" = pure ScoreTypeMax
1543+ parse "avg" = pure ScoreTypeAvg
1544+ parse "sum" = pure ScoreTypeSum
1545+ parse "none" = pure ScoreTypeNone
1546+ parse t = fail ("Unexpected ScoreType: " <> show t)
1547+
1548+instance ToJSON MatchQueryType where
1549+ toJSON MatchPhrase = "phrase"
1550+ toJSON MatchPhrasePrefix = "phrase_prefix"
1551+
1552+instance FromJSON MatchQueryType where
1553+ parseJSON = withText "MatchQueryType" parse
1554+ where parse "phrase" = pure MatchPhrase
1555+ parse "phrase_prefix" = pure MatchPhrasePrefix
1556+ parse t = fail ("Unexpected MatchQueryType: " <> show t)
1557+
1558+instance ToJSON MultiMatchQueryType where
1559+ toJSON MultiMatchBestFields = "best_fields"
1560+ toJSON MultiMatchMostFields = "most_fields"
1561+ toJSON MultiMatchCrossFields = "cross_fields"
1562+ toJSON MultiMatchPhrase = "phrase"
1563+ toJSON MultiMatchPhrasePrefix = "phrase_prefix"
1564+
1565+instance FromJSON MultiMatchQueryType where
1566+ parseJSON = withText "MultiMatchPhrasePrefix" parse
1567+ where parse "best_fields" = pure MultiMatchBestFields
1568+ parse "most_fields" = pure MultiMatchMostFields
1569+ parse "cross_fields" = pure MultiMatchCrossFields
1570+ parse "phrase" = pure MultiMatchPhrase
1571+ parse "phrase_prefix" = pure MultiMatchPhrasePrefix
1572+ parse t = fail ("Unexpected MultiMatchPhrasePrefix: " <> show t)
1573+
1574+defaultCache :: Cache
1575+defaultCache = False
1576+
1577+instance ToJSON BoolMatch where
1578+ toJSON (MustMatch term cache) = object ["must" .= term,
1579+ "_cache" .= cache]
1580+ toJSON (MustNotMatch term cache) = object ["must_not" .= term,
1581+ "_cache" .= cache]
1582+ toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms,
1583+ "_cache" .= cache]
1584+
1585+instance FromJSON BoolMatch where
1586+ parseJSON = withObject "BoolMatch" parse
1587+ where parse o = mustMatch `taggedWith` "must"
1588+ <|> mustNotMatch `taggedWith` "must_not"
1589+ <|> shouldMatch `taggedWith` "should"
1590+ where taggedWith parser k = parser =<< o .: k
1591+ mustMatch t = MustMatch t <$> o .:? "_cache" .!= defaultCache
1592+ mustNotMatch t = MustNotMatch t <$> o .:? "_cache" .!= defaultCache
1593+ shouldMatch t = ShouldMatch t <$> o .:? "_cache" .!= defaultCache
1594+
1595+instance ToJSON GeoBoundingBoxConstraint where
1596+ toJSON (GeoBoundingBoxConstraint
1597+ (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') =
1598+ object [gbbcGeoBBField .= gbbcConstraintBox
1599+ , "_cache" .= cache
1600+ , "type" .= type']
1601+
1602+instance FromJSON GeoBoundingBoxConstraint where
1603+ parseJSON = withObject "GeoBoundingBoxConstraint" parse
1604+ where parse o = case HM.toList (deleteSeveral ["type", "_cache"] o) of
1605+ [(fn, v)] -> GeoBoundingBoxConstraint (FieldName fn)
1606+ <$> parseJSON v
1607+ <*> o .:? "_cache" .!= defaultCache
1608+ <*> o .: "type"
1609+ _ -> fail "Could not find field name for GeoBoundingBoxConstraint"
1610+
1611+instance ToJSON Distance where
1612+ toJSON (Distance dCoefficient dUnit) =
1613+ String boltedTogether where
1614+ coefText = showText dCoefficient
1615+ (String unitText) = toJSON dUnit
1616+ boltedTogether = mappend coefText unitText
1617+
1618+instance FromJSON Distance where
1619+ parseJSON = withText "Distance" parse
1620+ where parse t = Distance <$> parseCoeff nT
1621+ <*> parseJSON (String unitT)
1622+ where (nT, unitT) = T.span validForNumber t
1623+ -- may be a better way to do this
1624+ validForNumber '-' = True
1625+ validForNumber '.' = True
1626+ validForNumber 'e' = True
1627+ validForNumber c = isNumber c
1628+ parseCoeff "" = fail "Empty string cannot be parsed as number"
1629+ parseCoeff s = return (read (T.unpack s))
1630+
1631+instance ToJSON DistanceType where
1632+ toJSON Arc = String "arc"
1633+ toJSON SloppyArc = String "sloppy_arc"
1634+ toJSON Plane = String "plane"
1635+
1636+instance FromJSON DistanceType where
1637+ parseJSON = withText "DistanceType" parse
1638+ where parse "arc" = pure Arc
1639+ parse "sloppy_arc" = pure SloppyArc
1640+ parse "plane" = pure Plane
1641+ parse t = fail ("Unrecognized DistanceType: " <> show t)
1642+
1643+instance ToJSON OptimizeBbox where
1644+ toJSON NoOptimizeBbox = String "none"
1645+ toJSON (OptimizeGeoFilterType gft) = toJSON gft
1646+
1647+instance FromJSON OptimizeBbox where
1648+ parseJSON v = withText "NoOptimizeBbox" parseNoOptimize v
1649+ <|> parseOptimize v
1650+ where parseNoOptimize "none" = pure NoOptimizeBbox
1651+ parseNoOptimize _ = mzero
1652+ parseOptimize = fmap OptimizeGeoFilterType . parseJSON
1653+
1654+instance ToJSON Term where
1655+ toJSON (Term field value) = object ["term" .= object
1656+ [field .= value]]
1657+
1658+instance FromJSON Term where
1659+ parseJSON = withObject "Term" parse
1660+ where parse o = do termObj <- o .: "term"
1661+ case HM.toList termObj of
1662+ [(fn, v)] -> Term fn <$> parseJSON v
1663+ _ -> fail "Expected object with 1 field-named key"
1664+
1665+instance ToJSON GeoBoundingBox where
1666+ toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) =
1667+ object ["top_left" .= gbbTopLeft
1668+ , "bottom_right" .= gbbBottomRight]
1669+
1670+instance FromJSON GeoBoundingBox where
1671+ parseJSON = withObject "GeoBoundingBox" parse
1672+ where parse o = GeoBoundingBox
1673+ <$> o .: "top_left"
1674+ <*> o .: "bottom_right"
1675+
1676+instance ToJSON GeoFilterType where
1677+ toJSON GeoFilterMemory = String "memory"
1678+ toJSON GeoFilterIndexed = String "indexed"
1679+
1680+instance FromJSON GeoFilterType where
1681+ parseJSON = withText "GeoFilterType" parse
1682+ where parse "memory" = pure GeoFilterMemory
1683+ parse "indexed" = pure GeoFilterIndexed
1684+ parse t = fail ("Unrecognized GeoFilterType: " <> show t)
1685+
1686+{-| 'unpackId' is a silly convenience function that gets used once.
1687+-}
1688+unpackId :: DocId -> Text
1689+unpackId (DocId docId) = docId
src/Database/V1/Bloodhound/Internal/Sort.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Database.V1.Bloodhound.Internal.Sort where
4+
5+
6+import Bloodhound.Import
7+
8+import Database.V1.Bloodhound.Internal.Newtypes
9+import Database.V1.Bloodhound.Internal.Query
10+
11+
12+{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order
13+ dependent with later sorts acting as tie-breakers for earlier sorts.
14+-}
15+type Sort = [SortSpec]
16+
17+
18+{-| The two main kinds of 'SortSpec' are 'DefaultSortSpec' and
19+ 'GeoDistanceSortSpec'. The latter takes a 'SortOrder', 'GeoPoint', and
20+ 'DistanceUnit' to express "nearness" to a single geographical point as a
21+ sort specification.
22+
23+<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
24+-}
25+data SortSpec = DefaultSortSpec DefaultSort
26+ | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit deriving (Eq, Show)
27+
28+instance ToJSON SortSpec where
29+ toJSON (DefaultSortSpec
30+ (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped
31+ dsSortMode dsMissingSort dsNestedFilter)) =
32+ object [dsSortFieldName .= omitNulls base] where
33+ base = [ "order" .= dsSortOrder
34+ , "ignore_unmapped" .= dsIgnoreUnmapped
35+ , "mode" .= dsSortMode
36+ , "missing" .= dsMissingSort
37+ , "nested_filter" .= dsNestedFilter ]
38+
39+ toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) =
40+ object [ "unit" .= units
41+ , field .= gdsLatLon
42+ , "order" .= gdsSortOrder ]
43+
44+{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a
45+ 'mkSort' convenience function for when you want to specify only the most
46+ common parameters.
47+
48+<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
49+-}
50+data DefaultSort =
51+ DefaultSort { sortFieldName :: FieldName
52+ , sortOrder :: SortOrder
53+ -- default False
54+ , ignoreUnmapped :: Bool
55+ , sortMode :: Maybe SortMode
56+ , missingSort :: Maybe Missing
57+ , nestedFilter :: Maybe Filter } deriving (Eq, Show)
58+
59+{-| 'SortOrder' is 'Ascending' or 'Descending', as you might expect. These get
60+ encoded into "asc" or "desc" when turned into JSON.
61+
62+<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
63+-}
64+data SortOrder = Ascending
65+ | Descending deriving (Eq, Show)
66+
67+
68+instance ToJSON SortOrder where
69+ toJSON Ascending = String "asc"
70+ toJSON Descending = String "desc"
71+
72+{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.
73+
74+http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option
75+-}
76+data SortMode = SortMin
77+ | SortMax
78+ | SortSum
79+ | SortAvg deriving (Eq, Show)
80+
81+instance ToJSON SortMode where
82+ toJSON SortMin = String "min"
83+ toJSON SortMax = String "max"
84+ toJSON SortSum = String "sum"
85+ toJSON SortAvg = String "avg"
86+
87+{-| 'Missing' prescribes how to handle missing fields. A missing field can be
88+ sorted last, first, or using a custom value as a substitute.
89+
90+<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_missing_values>
91+-}
92+data Missing = LastMissing
93+ | FirstMissing
94+ | CustomMissing Text deriving (Eq, Show)
95+
96+instance ToJSON Missing where
97+ toJSON LastMissing = String "_last"
98+ toJSON FirstMissing = String "_first"
99+ toJSON (CustomMissing txt) = String txt
100+
101+-- {-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so
102+-- that you can concisely describe the usual kind of 'SortSpec's you want.
103+-- -}
104+mkSort :: FieldName -> SortOrder -> DefaultSort
105+mkSort fieldName sOrder = DefaultSort fieldName sOrder False Nothing Nothing Nothing
106+
src/Database/V1/Bloodhound/Internal/StringlyTyped.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Database.V1.Bloodhound.Internal.StringlyTyped where
4+
5+import Bloodhound.Import
6+
7+import qualified Data.Text as T
8+
9+newtype StringlyTypedDouble = StringlyTypedDouble { unStringlyTypedDouble :: Double }
10+
11+
12+instance FromJSON StringlyTypedDouble where
13+ parseJSON = fmap StringlyTypedDouble . parseJSON . unStringlyTypeJSON
14+
15+
16+-- | For some reason in several settings APIs, all leaf values get returned
17+-- as strings. This function attepmts to recover from this for all
18+-- non-recursive JSON types. If nothing can be done, the value is left alone.
19+unStringlyTypeJSON :: Value -> Value
20+unStringlyTypeJSON (String "true") = Bool True
21+unStringlyTypeJSON (String "false") = Bool False
22+unStringlyTypeJSON (String "null") = Null
23+unStringlyTypeJSON v@(String t) = case readMay (T.unpack t) of
24+ Just n -> Number n
25+ Nothing -> v
26+unStringlyTypeJSON v = v
src/Database/V1/Bloodhound/Internal/Suggest.hsnew file+252
@@ -0,0 +1,252 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+
4+module Database.V1.Bloodhound.Internal.Suggest where
5+
6+
7+import Bloodhound.Import
8+
9+import qualified Data.HashMap.Strict as HM
10+
11+import Database.V1.Bloodhound.Internal.Newtypes
12+import Database.V1.Bloodhound.Internal.Query
13+
14+data Suggest = Suggest { suggestText :: Text
15+ , suggestName :: Text
16+ , suggestType :: SuggestType
17+ }
18+ deriving (Show, Eq)
19+
20+instance ToJSON Suggest where
21+ toJSON Suggest{..} = object [ "text" .= suggestText
22+ , suggestName .= suggestType
23+ ]
24+
25+instance FromJSON Suggest where
26+ parseJSON (Object o) = do
27+ suggestText' <- o .: "text"
28+ let dropTextList = HM.toList $ HM.filterWithKey (\x _ -> x /= "text") o
29+ suggestName' <- case dropTextList of
30+ [(x, _)] -> return x
31+ _ -> fail "error parsing Suggest field name"
32+ suggestType' <- o .: suggestName'
33+ return $ Suggest suggestText' suggestName' suggestType'
34+ parseJSON x = typeMismatch "Suggest" x
35+
36+data SuggestType = SuggestTypePhraseSuggester PhraseSuggester
37+ deriving (Show, Eq)
38+
39+instance ToJSON SuggestType where
40+ toJSON (SuggestTypePhraseSuggester x) = object ["phrase" .= x]
41+
42+instance FromJSON SuggestType where
43+ parseJSON = withObject "SuggestType" parse
44+ where parse o = phraseSuggester `taggedWith` "phrase"
45+ where taggedWith parser k = parser =<< o .: k
46+ phraseSuggester = pure . SuggestTypePhraseSuggester
47+
48+data PhraseSuggester =
49+ PhraseSuggester { phraseSuggesterField :: FieldName
50+ , phraseSuggesterGramSize :: Maybe Int
51+ , phraseSuggesterRealWordErrorLikelihood :: Maybe Int
52+ , phraseSuggesterConfidence :: Maybe Int
53+ , phraseSuggesterMaxErrors :: Maybe Int
54+ , phraseSuggesterSeparator :: Maybe Text
55+ , phraseSuggesterSize :: Maybe Size
56+ , phraseSuggesterAnalyzer :: Maybe Analyzer
57+ , phraseSuggesterShardSize :: Maybe Int
58+ , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
59+ , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
60+ , phraseSuggesterCandidateGenerators :: [DirectGenerators]
61+ }
62+ deriving (Show, Eq)
63+
64+instance ToJSON PhraseSuggester where
65+ toJSON PhraseSuggester{..} = omitNulls [ "field" .= phraseSuggesterField
66+ , "gram_size" .= phraseSuggesterGramSize
67+ , "real_word_error_likelihood" .= phraseSuggesterRealWordErrorLikelihood
68+ , "confidence" .= phraseSuggesterConfidence
69+ , "max_errors" .= phraseSuggesterMaxErrors
70+ , "separator" .= phraseSuggesterSeparator
71+ , "size" .= phraseSuggesterSize
72+ , "analyzer" .= phraseSuggesterAnalyzer
73+ , "shard_size" .= phraseSuggesterShardSize
74+ , "highlight" .= phraseSuggesterHighlight
75+ , "collate" .= phraseSuggesterCollate
76+ , "direct_generator" .= phraseSuggesterCandidateGenerators
77+ ]
78+
79+instance FromJSON PhraseSuggester where
80+ parseJSON = withObject "PhraseSuggester" parse
81+ where parse o = PhraseSuggester
82+ <$> o .: "field"
83+ <*> o .:? "gram_size"
84+ <*> o .:? "real_word_error_likelihood"
85+ <*> o .:? "confidence"
86+ <*> o .:? "max_errors"
87+ <*> o .:? "separator"
88+ <*> o .:? "size"
89+ <*> o .:? "analyzer"
90+ <*> o .:? "shard_size"
91+ <*> o .:? "highlight"
92+ <*> o .:? "collate"
93+ <*> o .:? "direct_generator" .!= []
94+
95+mkPhraseSuggester :: FieldName -> PhraseSuggester
96+mkPhraseSuggester fName =
97+ PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
98+ Nothing Nothing Nothing Nothing []
99+
100+data PhraseSuggesterHighlighter =
101+ PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
102+ , phraseSuggesterHighlighterPostTag :: Text
103+ }
104+ deriving (Show, Eq)
105+
106+instance ToJSON PhraseSuggesterHighlighter where
107+ toJSON PhraseSuggesterHighlighter{..} =
108+ object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
109+ , "post_tag" .= phraseSuggesterHighlighterPostTag
110+ ]
111+
112+instance FromJSON PhraseSuggesterHighlighter where
113+ parseJSON = withObject "PhraseSuggesterHighlighter" parse
114+ where parse o = PhraseSuggesterHighlighter
115+ <$> o .: "pre_tag"
116+ <*> o .: "post_tag"
117+
118+data PhraseSuggesterCollate =
119+ PhraseSuggesterCollate { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
120+ , phraseSuggesterCollatePrune :: Bool
121+ }
122+ deriving (Show, Eq)
123+
124+instance ToJSON PhraseSuggesterCollate where
125+ toJSON PhraseSuggesterCollate{..} = object [ "query" .= object
126+ [ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
127+ ]
128+ , "params" .= (params phraseSuggesterCollateTemplateQuery)
129+ , "prune" .= phraseSuggesterCollatePrune
130+ ]
131+
132+instance FromJSON PhraseSuggesterCollate where
133+ parseJSON (Object o) = do
134+ query' <- o .: "query"
135+ inline' <- query' .: "inline"
136+ params' <- o .: "params"
137+ prune' <- o .:? "prune" .!= False
138+ return $ PhraseSuggesterCollate (TemplateQueryInline inline' params') prune'
139+ parseJSON x = typeMismatch "PhraseSuggesterCollate" x
140+
141+data DirectGenerators = DirectGenerators
142+ { directGeneratorsField :: FieldName
143+ , directGeneratorsSize :: Maybe Int
144+ , directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes
145+ , directGeneratorMaxEdits :: Maybe Double
146+ , directGeneratorPrefixLength :: Maybe Int
147+ , directGeneratorMinWordLength :: Maybe Int
148+ , directGeneratorMaxInspections :: Maybe Int
149+ , directGeneratorMinDocFreq :: Maybe Double
150+ , directGeneratorMaxTermFreq :: Maybe Double
151+ , directGeneratorPreFilter :: Maybe Text
152+ , directGeneratorPostFilter :: Maybe Text
153+ }
154+ deriving (Show, Eq)
155+
156+
157+instance ToJSON DirectGenerators where
158+ toJSON DirectGenerators{..} = omitNulls [ "field" .= directGeneratorsField
159+ , "size" .= directGeneratorsSize
160+ , "suggest_mode" .= directGeneratorSuggestMode
161+ , "max_edits" .= directGeneratorMaxEdits
162+ , "prefix_length" .= directGeneratorPrefixLength
163+ , "min_word_length" .= directGeneratorMinWordLength
164+ , "max_inspections" .= directGeneratorMaxInspections
165+ , "min_doc_freq" .= directGeneratorMinDocFreq
166+ , "max_term_freq" .= directGeneratorMaxTermFreq
167+ , "pre_filter" .= directGeneratorPreFilter
168+ , "post_filter" .= directGeneratorPostFilter
169+ ]
170+
171+instance FromJSON DirectGenerators where
172+ parseJSON = withObject "DirectGenerators" parse
173+ where parse o = DirectGenerators
174+ <$> o .: "field"
175+ <*> o .:? "size"
176+ <*> o .: "suggest_mode"
177+ <*> o .:? "max_edits"
178+ <*> o .:? "prefix_length"
179+ <*> o .:? "min_word_length"
180+ <*> o .:? "max_inspections"
181+ <*> o .:? "min_doc_freq"
182+ <*> o .:? "max_term_freq"
183+ <*> o .:? "pre_filter"
184+ <*> o .:? "post_filter"
185+
186+mkDirectGenerators :: FieldName -> DirectGenerators
187+mkDirectGenerators fn = DirectGenerators fn Nothing DirectGeneratorSuggestModeMissing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
188+
189+data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing
190+ | DirectGeneratorSuggestModePopular
191+ | DirectGeneratorSuggestModeAlways
192+ deriving (Show, Eq)
193+
194+instance ToJSON DirectGeneratorSuggestModeTypes where
195+ toJSON DirectGeneratorSuggestModeMissing = "missing"
196+ toJSON DirectGeneratorSuggestModePopular = "popular"
197+ toJSON DirectGeneratorSuggestModeAlways = "always"
198+
199+instance FromJSON DirectGeneratorSuggestModeTypes where
200+ parseJSON = withText "DirectGeneratorSuggestModeTypes" parse
201+ where parse "missing" = pure DirectGeneratorSuggestModeMissing
202+ parse "popular" = pure DirectGeneratorSuggestModePopular
203+ parse "always" = pure DirectGeneratorSuggestModeAlways
204+ parse f = fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f)
205+
206+data SuggestOptions =
207+ SuggestOptions { suggestOptionsText :: Text
208+ , suggestOptionsScore :: Double
209+ , suggestOptionsFreq :: Maybe Int
210+ , suggestOptionsHighlighted :: Maybe Text
211+ }
212+ deriving (Eq, Show)
213+
214+instance FromJSON SuggestOptions where
215+ parseJSON = withObject "SuggestOptions" parse
216+ where parse o = SuggestOptions
217+ <$> o .: "text"
218+ <*> o .: "score"
219+ <*> o .:? "freq"
220+ <*> o .:? "highlighted"
221+
222+data SuggestResponse =
223+ SuggestResponse { suggestResponseText :: Text
224+ , suggestResponseOffset :: Int
225+ , suggestResponseLength :: Int
226+ , suggestResponseOptions :: [SuggestOptions]
227+ }
228+ deriving (Eq, Show)
229+
230+instance FromJSON SuggestResponse where
231+ parseJSON = withObject "SuggestResponse" parse
232+ where parse o = SuggestResponse
233+ <$> o .: "text"
234+ <*> o .: "offset"
235+ <*> o .: "length"
236+ <*> o .: "options"
237+
238+data NamedSuggestionResponse =
239+ NamedSuggestionResponse { nsrName :: Text
240+ , nsrResponses :: [SuggestResponse]
241+ }
242+ deriving (Eq, Show)
243+
244+instance FromJSON NamedSuggestionResponse where
245+ parseJSON (Object o) = do
246+ suggestionName' <- case HM.toList o of
247+ [(x, _)] -> return x
248+ _ -> fail "error parsing NamedSuggestionResponse name"
249+ suggestionResponses' <- o .: suggestionName'
250+ return $ NamedSuggestionResponse suggestionName' suggestionResponses'
251+
252+ parseJSON x = typeMismatch "NamedSuggestionResponse" x
src/Database/V1/Bloodhound/Types.hsnew file+452
@@ -0,0 +1,452 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE NamedFieldPuns #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RecordWildCards #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+
12+-------------------------------------------------------------------------------
13+-- |
14+-- Module : Database.Bloodhound.Types
15+-- Copyright : (C) 2014, 2015, 2016 Chris Allen
16+-- License : BSD-style (see the file LICENSE)
17+-- Maintainer : Chris Allen <cma@bitemyapp.com
18+-- Stability : provisional
19+-- Portability : DeriveGeneric, RecordWildCards
20+--
21+-- Data types for describing actions and data structures performed to interact
22+-- with Elasticsearch. The two main buckets your queries against Elasticsearch
23+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like
24+-- traditional database constraints and often have preferable performance
25+-- properties. 'Query's support human-written textual queries, such as fuzzy
26+-- queries.
27+-------------------------------------------------------------------------------
28+
29+
30+
31+module Database.V1.Bloodhound.Types
32+ ( defaultCache
33+ , defaultIndexSettings
34+ , defaultIndexDocumentSettings
35+ , mkSort
36+ , showText
37+ , unpackId
38+ , mkMatchQuery
39+ , mkMultiMatchQuery
40+ , mkBoolQuery
41+ , mkRangeQuery
42+ , mkQueryStringQuery
43+ , mkAggregations
44+ , mkTermsAggregation
45+ , mkTermsScriptAggregation
46+ , mkDateHistogram
47+ , mkCardinalityAggregation
48+ , mkDocVersion
49+ , docVersionNumber
50+ , toMissing
51+ , toTerms
52+ , toDateHistogram
53+ , toTopHits
54+ , omitNulls
55+ , BH(..)
56+ , runBH
57+ , BHEnv
58+ , bhServer
59+ , bhManager
60+ , bhRequestHook
61+ , mkBHEnv
62+ , MonadBH(..)
63+ , Version(..)
64+ , VersionNumber(..)
65+ , MaybeNA(..)
66+ , BuildHash(..)
67+ , Status(..)
68+ , Existence(..)
69+ , NullValue(..)
70+ , IndexSettings(..)
71+ , UpdatableIndexSetting(..)
72+ , IndexSettingsSummary(..)
73+ , AllocationPolicy(..)
74+ , ReplicaBounds(..)
75+ , Bytes(..)
76+ , gigabytes
77+ , megabytes
78+ , kilobytes
79+ , FSType(..)
80+ , InitialShardCount(..)
81+ , NodeAttrFilter(..)
82+ , NodeAttrName(..)
83+ , CompoundFormat(..)
84+ , IndexTemplate(..)
85+ , Server(..)
86+ , Reply
87+ , EsResult(..)
88+ , EsResultFound(..)
89+ , EsError(..)
90+ , EsProtocolException(..)
91+ , IndexAlias(..)
92+ , IndexAliasName(..)
93+ , IndexAliasAction(..)
94+ , IndexAliasCreate(..)
95+ , IndexAliasSummary(..)
96+ , IndexAliasesSummary(..)
97+ , AliasRouting(..)
98+ , SearchAliasRouting(..)
99+ , IndexAliasRouting(..)
100+ , RoutingValue(..)
101+ , DocVersion
102+ , ExternalDocVersion(..)
103+ , VersionControl(..)
104+ , DocumentParent(..)
105+ , IndexDocumentSettings(..)
106+ , Query(..)
107+ , Search(..)
108+ , SearchType(..)
109+ , SearchResult(..)
110+ , ScrollId(..)
111+ , SearchHits(..)
112+ , TrackSortScores
113+ , From(..)
114+ , Size(..)
115+ , Source(..)
116+ , PatternOrPatterns(..)
117+ , Include(..)
118+ , Exclude(..)
119+ , Pattern(..)
120+ , ShardResult(..)
121+ , Hit(..)
122+ , Filter(..)
123+ , Seminearring(..)
124+ , BoolMatch(..)
125+ , Term(..)
126+ , GeoPoint(..)
127+ , GeoBoundingBoxConstraint(..)
128+ , GeoBoundingBox(..)
129+ , GeoFilterType(..)
130+ , Distance(..)
131+ , DistanceUnit(..)
132+ , DistanceType(..)
133+ , DistanceRange(..)
134+ , OptimizeBbox(..)
135+ , LatLon(..)
136+ , RangeValue(..)
137+ , RangeExecution(..)
138+ , LessThan(..)
139+ , LessThanEq(..)
140+ , GreaterThan(..)
141+ , GreaterThanEq(..)
142+ , LessThanD(..)
143+ , LessThanEqD(..)
144+ , GreaterThanD(..)
145+ , GreaterThanEqD(..)
146+ , Regexp(..)
147+ , RegexpFlags(..)
148+ , RegexpFlag(..)
149+ , FieldName(..)
150+ , Script(..)
151+ , IndexName(..)
152+ , IndexSelection(..)
153+ , NodeSelection(..)
154+ , NodeSelector(..)
155+ , IndexOptimizationSettings(..)
156+ , defaultIndexOptimizationSettings
157+ , TemplateName(..)
158+ , TemplatePattern(..)
159+ , MappingName(..)
160+ , DocId(..)
161+ , CacheName(..)
162+ , CacheKey(..)
163+ , BulkOperation(..)
164+ , ReplicaCount(..)
165+ , ShardCount(..)
166+ , Sort
167+ , SortMode(..)
168+ , SortOrder(..)
169+ , SortSpec(..)
170+ , DefaultSort(..)
171+ , Missing(..)
172+ , OpenCloseIndex(..)
173+ , Method
174+ , Boost(..)
175+ , MatchQuery(..)
176+ , MultiMatchQuery(..)
177+ , BoolQuery(..)
178+ , BoostingQuery(..)
179+ , CommonTermsQuery(..)
180+ , DisMaxQuery(..)
181+ , FilteredQuery(..)
182+ , FuzzyLikeThisQuery(..)
183+ , FuzzyLikeFieldQuery(..)
184+ , FuzzyQuery(..)
185+ , HasChildQuery(..)
186+ , HasParentQuery(..)
187+ , IndicesQuery(..)
188+ , MoreLikeThisQuery(..)
189+ , MoreLikeThisFieldQuery(..)
190+ , NestedQuery(..)
191+ , PrefixQuery(..)
192+ , QueryStringQuery(..)
193+ , SimpleQueryStringQuery(..)
194+ , RangeQuery(..)
195+ , RegexpQuery(..)
196+ , QueryString(..)
197+ , TemplateQueryInline(..)
198+ , TemplateQueryKeyValuePairs(..)
199+ , BooleanOperator(..)
200+ , ZeroTermsQuery(..)
201+ , CutoffFrequency(..)
202+ , Analyzer(..)
203+ , MaxExpansions(..)
204+ , Lenient(..)
205+ , MatchQueryType(..)
206+ , MultiMatchQueryType(..)
207+ , Tiebreaker(..)
208+ , MinimumMatch(..)
209+ , DisableCoord(..)
210+ , CommonMinimumMatch(..)
211+ , MinimumMatchHighLow(..)
212+ , PrefixLength(..)
213+ , Fuzziness(..)
214+ , IgnoreTermFrequency(..)
215+ , MaxQueryTerms(..)
216+ , ScoreType(..)
217+ , Score
218+ , Cache
219+ , TypeName(..)
220+ , BoostTerms(..)
221+ , MaxWordLength(..)
222+ , MinWordLength(..)
223+ , MaxDocFrequency(..)
224+ , MinDocFrequency(..)
225+ , PhraseSlop(..)
226+ , StopWord(..)
227+ , QueryPath(..)
228+ , MinimumTermFrequency(..)
229+ , PercentMatch(..)
230+ , FieldDefinition(..)
231+ , MappingField(..)
232+ , Mapping(..)
233+ , AllowLeadingWildcard(..)
234+ , LowercaseExpanded(..)
235+ , GeneratePhraseQueries(..)
236+ , Locale(..)
237+ , AnalyzeWildcard(..)
238+ , EnablePositionIncrements(..)
239+ , SimpleQueryFlag(..)
240+ , FieldOrFields(..)
241+ , Monoid(..)
242+ , ToJSON(..)
243+ , Interval(..)
244+ , TimeInterval(..)
245+ , ExecutionHint(..)
246+ , CollectionMode(..)
247+ , TermOrder(..)
248+ , TermInclusion(..)
249+ , SnapshotRepoSelection(..)
250+ , GenericSnapshotRepo(..)
251+ , SnapshotRepo(..)
252+ , SnapshotRepoConversionError(..)
253+ , SnapshotRepoType(..)
254+ , GenericSnapshotRepoSettings(..)
255+ , SnapshotRepoUpdateSettings(..)
256+ , defaultSnapshotRepoUpdateSettings
257+ , SnapshotRepoName(..)
258+ , SnapshotRepoPattern(..)
259+ , SnapshotVerification(..)
260+ , SnapshotNodeVerification(..)
261+ , FullNodeId(..)
262+ , NodeName(..)
263+ , ClusterName(..)
264+ , NodesInfo(..)
265+ , NodesStats(..)
266+ , NodeStats(..)
267+ , NodeBreakersStats(..)
268+ , NodeBreakerStats(..)
269+ , NodeHTTPStats(..)
270+ , NodeTransportStats(..)
271+ , NodeFSStats(..)
272+ , NodeDataPathStats(..)
273+ , NodeFSTotalStats(..)
274+ , NodeNetworkStats(..)
275+ , NodeThreadPoolsStats(..)
276+ , NodeThreadPoolStats(..)
277+ , NodeJVMStats(..)
278+ , JVMBufferPoolStats(..)
279+ , JVMGCStats(..)
280+ , JVMPoolStats(..)
281+ , NodeProcessStats(..)
282+ , NodeOSStats(..)
283+ , LoadAvgs(..)
284+ , NodeIndicesStats(..)
285+ , EsAddress(..)
286+ , PluginName(..)
287+ , NodeInfo(..)
288+ , NodePluginInfo(..)
289+ , NodeHTTPInfo(..)
290+ , NodeTransportInfo(..)
291+ , BoundTransportAddress(..)
292+ , NodeNetworkInfo(..)
293+ , MacAddress(..)
294+ , NetworkInterfaceName(..)
295+ , NodeNetworkInterface(..)
296+ , NodeThreadPoolsInfo(..)
297+ , NodeThreadPoolInfo(..)
298+ , ThreadPoolSize(..)
299+ , ThreadPoolType(..)
300+ , NodeJVMInfo(..)
301+ , JVMMemoryPool(..)
302+ , JVMGCCollector(..)
303+ , JVMMemoryInfo(..)
304+ , PID(..)
305+ , NodeOSInfo(..)
306+ , CPUInfo(..)
307+ , NodeProcessInfo(..)
308+ , FsSnapshotRepo(..)
309+ , SnapshotCreateSettings(..)
310+ , defaultSnapshotCreateSettings
311+ , SnapshotSelection(..)
312+ , SnapshotPattern(..)
313+ , SnapshotInfo(..)
314+ , SnapshotShardFailure(..)
315+ , ShardId(..)
316+ , SnapshotName(..)
317+ , SnapshotState(..)
318+ , SnapshotRestoreSettings(..)
319+ , defaultSnapshotRestoreSettings
320+ , RestoreRenamePattern(..)
321+ , RestoreRenameToken(..)
322+ , RRGroupRefNum
323+ , rrGroupRefNum
324+ , mkRRGroupRefNum
325+ , RestoreIndexSettings(..)
326+ , Suggest(..)
327+ , SuggestType(..)
328+ , PhraseSuggester(..)
329+ , PhraseSuggesterHighlighter(..)
330+ , PhraseSuggesterCollate(..)
331+ , mkPhraseSuggester
332+ , SuggestOptions(..)
333+ , SuggestResponse(..)
334+ , NamedSuggestionResponse(..)
335+ , DirectGenerators(..)
336+ , mkDirectGenerators
337+ , DirectGeneratorSuggestModeTypes (..)
338+
339+ , Aggregation(..)
340+ , Aggregations
341+ , AggregationResults
342+ , BucketValue(..)
343+ , Bucket(..)
344+ , BucketAggregation(..)
345+ , TermsAggregation(..)
346+ , MissingAggregation(..)
347+ , ValueCountAggregation(..)
348+ , FilterAggregation(..)
349+ , CardinalityAggregation(..)
350+ , DateHistogramAggregation(..)
351+ , DateRangeAggregation(..)
352+ , DateRangeAggRange(..)
353+ , DateMathExpr(..)
354+ , DateMathAnchor(..)
355+ , DateMathModifier(..)
356+ , DateMathUnit(..)
357+ , TopHitsAggregation(..)
358+
359+ , Highlights(..)
360+ , FieldHighlight(..)
361+ , HighlightSettings(..)
362+ , PlainHighlight(..)
363+ , PostingsHighlight(..)
364+ , FastVectorHighlight(..)
365+ , CommonHighlight(..)
366+ , NonPostings(..)
367+ , HighlightEncoder(..)
368+ , HighlightTag(..)
369+ , HitHighlight
370+
371+ , MissingResult(..)
372+ , TermsResult(..)
373+ , DateHistogramResult(..)
374+ , DateRangeResult(..)
375+ , TopHitResult(..)
376+
377+ , EsUsername(..)
378+ , EsPassword(..)
379+ ) where
380+
381+import Bloodhound.Import
382+
383+import Database.V1.Bloodhound.Types.Class
384+import Database.V1.Bloodhound.Internal.Aggregation
385+import Database.V1.Bloodhound.Internal.Client
386+import Database.V1.Bloodhound.Internal.Highlight
387+import Database.V1.Bloodhound.Internal.Newtypes
388+import Database.V1.Bloodhound.Internal.Query
389+import Database.V1.Bloodhound.Internal.Sort
390+import Database.V1.Bloodhound.Internal.Suggest
391+
392+data SearchResult a =
393+ SearchResult { took :: Int
394+ , timedOut :: Bool
395+ , shards :: ShardResult
396+ , searchHits :: SearchHits a
397+ , aggregations :: Maybe AggregationResults
398+ , scrollId :: Maybe ScrollId
399+ , suggest :: Maybe NamedSuggestionResponse -- ^ Only one Suggestion request / response per Search is supported.
400+ }
401+ deriving (Eq, Show)
402+
403+type TrackSortScores = Bool
404+
405+data Search = Search { queryBody :: Maybe Query
406+ , filterBody :: Maybe Filter
407+ , sortBody :: Maybe Sort
408+ , aggBody :: Maybe Aggregations
409+ , highlight :: Maybe Highlights
410+ -- default False
411+ , trackSortScores :: TrackSortScores
412+ , from :: From
413+ , size :: Size
414+ , searchType :: SearchType
415+ , fields :: Maybe [FieldName]
416+ , source :: Maybe Source
417+ , suggestBody :: Maybe Suggest -- ^ Only one Suggestion request / response per Search is supported.
418+ } deriving (Eq, Show)
419+
420+data SearchType = SearchTypeQueryThenFetch
421+ | SearchTypeDfsQueryThenFetch
422+ | SearchTypeCount
423+ | SearchTypeScan
424+ | SearchTypeQueryAndFetch
425+ | SearchTypeDfsQueryAndFetch
426+ deriving (Eq, Show)
427+
428+instance ToJSON Search where
429+ toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _ sFields sSource sSuggest) =
430+ omitNulls [ "query" .= query
431+ , "filter" .= sFilter
432+ , "sort" .= sort
433+ , "aggregations" .= searchAggs
434+ , "highlight" .= highlight
435+ , "from" .= sFrom
436+ , "size" .= sSize
437+ , "track_scores" .= sTrackSortScores
438+ , "fields" .= sFields
439+ , "_source" .= sSource
440+ , "suggest" .= sSuggest]
441+
442+
443+instance (FromJSON a) => FromJSON (SearchResult a) where
444+ parseJSON (Object v) = SearchResult <$>
445+ v .: "took" <*>
446+ v .: "timed_out" <*>
447+ v .: "_shards" <*>
448+ v .: "hits" <*>
449+ v .:? "aggregations" <*>
450+ v .:? "_scroll_id" <*>
451+ v .:? "suggest"
452+ parseJSON _ = empty
src/Database/V1/Bloodhound/Types/Class.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE CPP #-}
2+module Database.V1.Bloodhound.Types.Class
3+ ( Seminearring(..) )
4+ where
5+
6+#if !MIN_VERSION_base(4,8,0)
7+import Data.Monoid
8+#endif
9+
10+class Monoid a => Seminearring a where
11+ -- 0, +, *
12+ (<||>) :: a -> a -> a
13+ (<&&>) :: a -> a -> a
14+ (<&&>) = mappend
15+
16+infixr 5 <||>
17+infixr 5 <&&>
src/Database/V5/Bloodhound.hsnew file+10
@@ -0,0 +1,10 @@
1+module Database.V5.Bloodhound
2+ ( -- module Data.Aeson.Types
3+ -- ,
4+ module Database.V5.Bloodhound.Client
5+ , module Database.V5.Bloodhound.Types
6+ ) where
7+
8+-- import Data.Aeson.Types
9+import Database.V5.Bloodhound.Client
10+import Database.V5.Bloodhound.Types
src/Database/Bloodhound/Client.hs → src/Database/V5/Bloodhound/Client.hsrenamed+19−19
@@ -15,7 +15,7 @@
15--
15--
16-------------------------------------------------------------------------------
16-------------------------------------------------------------------------------
17
17
18−module Database.Bloodhound.Client
18+module Database.V5.Bloodhound.Client
19 ( -- * Bloodhound client functions
19 ( -- * Bloodhound client functions
20 -- | The examples in this module assume the following code has been run.
20 -- | The examples in this module assume the following code has been run.
21 -- The :{ and :} will only work in GHCi. You'll only need the data types
21 -- The :{ and :} will only work in GHCi. You'll only need the data types
@@ -125,12 +125,12 @@ import qualified Network.HTTP.Types.URI as NHTU
125import qualified Network.URI as URI
125import qualified Network.URI as URI
126import Prelude hiding (filter, head)
126import Prelude hiding (filter, head)
127
127
128−import Database.Bloodhound.Types
128+import Database.V5.Bloodhound.Types
129
129
130-- $setup
130-- $setup
131-- >>> :set -XOverloadedStrings
131-- >>> :set -XOverloadedStrings
132-- >>> :set -XDeriveGeneric
132-- >>> :set -XDeriveGeneric
133−-- >>> import Database.Bloodhound
133+-- >>> import Database.V5.Bloodhound
134-- >>> import Network.HTTP.Client
134-- >>> import Network.HTTP.Client
135-- >>> let testServer = (Server "http://localhost:9200")
135-- >>> let testServer = (Server "http://localhost:9200")
136-- >>> let runBH' = withBH defaultManagerSettings testServer
136-- >>> let runBH' = withBH defaultManagerSettings testServer
@@ -523,13 +523,13 @@ createIndex indexSettings (IndexName indexName) =
523createIndexWith :: MonadBH m
523createIndexWith :: MonadBH m
524 => [UpdatableIndexSetting]
524 => [UpdatableIndexSetting]
525 -> Int -- ^ shard count
525 -> Int -- ^ shard count
526− -> IndexName
526+ -> IndexName
527 -> m Reply
527 -> m Reply
528createIndexWith updates shards (IndexName indexName) =
528createIndexWith updates shards (IndexName indexName) =
529 bindM2 put url (return (Just body))
529 bindM2 put url (return (Just body))
530 where url = joinPath [indexName]
530 where url = joinPath [indexName]
531 body = encode $ object
531 body = encode $ object
532− ["settings" .= deepMerge
532+ ["settings" .= deepMerge
533 ( HM.singleton "index.number_of_shards" (toJSON shards) :
533 ( HM.singleton "index.number_of_shards" (toJSON shards) :
534 [u | Object u <- toJSON <$> updates]
534 [u | Object u <- toJSON <$> updates]
535 )
535 )
@@ -575,8 +575,8 @@ getIndexSettings (IndexName indexName) =
575 where
575 where
576 url = joinPath [indexName, "_settings"]
576 url = joinPath [indexName, "_settings"]
577
577
578−-- | 'forceMergeIndex'
578+-- | 'forceMergeIndex'
579−--
579+--
580-- The force merge API allows to force merging of one or more indices through
580-- The force merge API allows to force merging of one or more indices through
581-- an API. The merge relates to the number of segments a Lucene index holds
581-- an API. The merge relates to the number of segments a Lucene index holds
582-- within each shard. The force merge operation allows to reduce the number of
582-- within each shard. The force merge operation allows to reduce the number of
@@ -1035,10 +1035,10 @@ searchByType (IndexName indexName)
1035-- search results. Note that the search is put into 'SearchTypeScan'
1035-- search results. Note that the search is put into 'SearchTypeScan'
1036-- mode and thus results will not be sorted. Combine this with
1036-- mode and thus results will not be sorted. Combine this with
1037-- 'advanceScroll' to efficiently stream through the full result set
1037-- 'advanceScroll' to efficiently stream through the full result set
1038−getInitialScroll ::
1038+getInitialScroll ::
1039− (FromJSON a, MonadThrow m, MonadBH m) => IndexName ->
1039+ (FromJSON a, MonadThrow m, MonadBH m) => IndexName ->
1040− MappingName ->
1040+ MappingName ->
1041− Search ->
1041+ Search ->
1042 m (Either EsError (SearchResult a))
1042 m (Either EsError (SearchResult a))
1043getInitialScroll (IndexName indexName) (MappingName mappingName) search' = do
1043getInitialScroll (IndexName indexName) (MappingName mappingName) search' = do
1044 let url = addQuery params <$> joinPath [indexName, mappingName, "_search"]
1044 let url = addQuery params <$> joinPath [indexName, mappingName, "_search"]
@@ -1063,7 +1063,7 @@ getInitialSortedScroll (IndexName indexName) (MappingName mappingName) search =
1063 resp' <- bindM2 dispatchSearch url (return search)
1063 resp' <- bindM2 dispatchSearch url (return search)
1064 parseEsResponse resp'
1064 parseEsResponse resp'
1065
1065
1066−scroll' :: (FromJSON a, MonadBH m, MonadThrow m) => Maybe ScrollId ->
1066+scroll' :: (FromJSON a, MonadBH m, MonadThrow m) => Maybe ScrollId ->
1067 m ([Hit a], Maybe ScrollId)
1067 m ([Hit a], Maybe ScrollId)
1068scroll' Nothing = return ([], Nothing)
1068scroll' Nothing = return ([], Nothing)
1069scroll' (Just sid) = do
1069scroll' (Just sid) = do
@@ -1090,13 +1090,13 @@ advanceScroll (ScrollId sid) scroll = do
1090 where scrollTime = showText secs <> "s"
1090 where scrollTime = showText secs <> "s"
1091 secs :: Integer
1091 secs :: Integer
1092 secs = round scroll
1092 secs = round scroll
1093−
1093+
1094 scrollObject = object [ "scroll" .= scrollTime
1094 scrollObject = object [ "scroll" .= scrollTime
1095 , "scroll_id" .= sid
1095 , "scroll_id" .= sid
1096 ]
1096 ]
1097
1097
1098−simpleAccumulator ::
1098+simpleAccumulator ::
1099− (FromJSON a, MonadBH m, MonadThrow m) =>
1099+ (FromJSON a, MonadBH m, MonadThrow m) =>
1100 [Hit a] ->
1100 [Hit a] ->
1101 ([Hit a], Maybe ScrollId) ->
1101 ([Hit a], Maybe ScrollId) ->
1102 m ([Hit a], Maybe ScrollId)
1102 m ([Hit a], Maybe ScrollId)
@@ -1134,9 +1134,9 @@ scanSearch indexName mappingName search = do
1134--
1134--
1135-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
1135-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
1136-- >>> mkSearch (Just query) Nothing
1136-- >>> mkSearch (Just query) Nothing
1137−-- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, searchAfterKey = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}
1137+-- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}
1138mkSearch :: Maybe Query -> Maybe Filter -> Search
1138mkSearch :: Maybe Query -> Maybe Filter -> Search
1139−mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing Nothing Nothing
1139+mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing Nothing
1140
1140
1141-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
1141-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
1142-- the 'Query' and the 'Aggregation'.
1142-- the 'Query' and the 'Aggregation'.
@@ -1146,7 +1146,7 @@ mkSearch query filter = Search query filter Nothing Nothing Nothing False (From
1146-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
1146-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
1147-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
1147-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
1148mkAggregateSearch :: Maybe Query -> Aggregations -> Search
1148mkAggregateSearch :: Maybe Query -> Aggregations -> Search
1149−mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing Nothing Nothing Nothing
1149+mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing Nothing Nothing
1150
1150
1151-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
1151-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
1152-- the 'Query' and the 'Aggregation'.
1152-- the 'Query' and the 'Aggregation'.
@@ -1155,7 +1155,7 @@ mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSear
1155-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
1155-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
1156-- >>> let search = mkHighlightSearch (Just query) testHighlight
1156-- >>> let search = mkHighlightSearch (Just query) testHighlight
1157mkHighlightSearch :: Maybe Query -> Highlights -> Search
1157mkHighlightSearch :: Maybe Query -> Highlights -> Search
1158−mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing Nothing Nothing
1158+mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing Nothing
1159
1159
1160-- | 'pageSearch' is a helper function that takes a search and assigns the from
1160-- | 'pageSearch' is a helper function that takes a search and assigns the from
1161-- and size fields for the search. The from parameter defines the offset
1161-- and size fields for the search. The from parameter defines the offset
src/Database/Bloodhound/Internal/Aggregation.hs → src/Database/V5/Bloodhound/Internal/Aggregation.hsrenamed+6−18
@@ -2,20 +2,19 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4
4
5−module Database.Bloodhound.Internal.Aggregation where
5+module Database.V5.Bloodhound.Internal.Aggregation where
6
6
7import Bloodhound.Import
7import Bloodhound.Import
8
8
9−import qualified Data.Aeson as Aeson
10import qualified Data.HashMap.Strict as HM
9import qualified Data.HashMap.Strict as HM
11import qualified Data.Map.Strict as M
10import qualified Data.Map.Strict as M
12import qualified Data.Text as T
11import qualified Data.Text as T
13
12
14−import Database.Bloodhound.Internal.Client
13+import Database.V5.Bloodhound.Internal.Client
15−import Database.Bloodhound.Internal.Highlight (HitHighlight)
14+import Database.V5.Bloodhound.Internal.Highlight (HitHighlight)
16−import Database.Bloodhound.Internal.Newtypes
15+import Database.V5.Bloodhound.Internal.Newtypes
17−import Database.Bloodhound.Internal.Query
16+import Database.V5.Bloodhound.Internal.Query
18−import Database.Bloodhound.Internal.Sort
17+import Database.V5.Bloodhound.Internal.Sort
19
18
20type Aggregations = M.Map Text Aggregation
19type Aggregations = M.Map Text Aggregation
21
20
@@ -27,7 +26,6 @@ mkAggregations name aggregation = M.insert name aggregation emptyAggregations
27
26
28data Aggregation = TermsAgg TermsAggregation
27data Aggregation = TermsAgg TermsAggregation
29 | CardinalityAgg CardinalityAggregation
28 | CardinalityAgg CardinalityAggregation
30− | MaxAgg MaxAggregation
31 | DateHistogramAgg DateHistogramAggregation
29 | DateHistogramAgg DateHistogramAggregation
32 | ValueCountAgg ValueCountAggregation
30 | ValueCountAgg ValueCountAggregation
33 | FilterAgg FilterAggregation
31 | FilterAgg FilterAggregation
@@ -59,9 +57,6 @@ instance ToJSON Aggregation where
59 ]
57 ]
60 ]
58 ]
61
59
62− toJSON (MaxAgg (MaxAggregation field)) =
63− object ["max" .= omitNulls [ "field" .= field ]]
64−
65 toJSON (DateHistogramAgg
60 toJSON (DateHistogramAgg
66 (DateHistogramAggregation field interval format
61 (DateHistogramAggregation field interval format
67 preZone postZone preOffset postOffset dateHistoAggs)) =
62 preZone postZone preOffset postOffset dateHistoAggs)) =
@@ -129,10 +124,6 @@ data CardinalityAggregation = CardinalityAggregation
129 precisionThreshold :: Maybe Int
124 precisionThreshold :: Maybe Int
130 } deriving (Eq, Show)
125 } deriving (Eq, Show)
131
126
132−data MaxAggregation = MaxAggregation
133− { maxField :: FieldName
134− } deriving (Eq, Show)
135−
136data DateHistogramAggregation = DateHistogramAggregation
127data DateHistogramAggregation = DateHistogramAggregation
137 { dateField :: FieldName
128 { dateField :: FieldName
138 , dateInterval :: Interval
129 , dateInterval :: Interval
@@ -454,7 +445,6 @@ instance Monoid (SearchHits a) where
454 mempty = SearchHits 0 Nothing mempty
445 mempty = SearchHits 0 Nothing mempty
455 mappend = (<>)
446 mappend = (<>)
456
447
457−type SearchAfterKey = [Aeson.Value]
458
448
459data Hit a =
449data Hit a =
460 Hit { hitIndex :: IndexName
450 Hit { hitIndex :: IndexName
@@ -462,7 +452,6 @@ data Hit a =
462 , hitDocId :: DocId
452 , hitDocId :: DocId
463 , hitScore :: Score
453 , hitScore :: Score
464 , hitSource :: Maybe a
454 , hitSource :: Maybe a
465− , hitSort :: Maybe SearchAfterKey
466 , hitFields :: Maybe HitFields
455 , hitFields :: Maybe HitFields
467 , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
456 , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
468
457
@@ -473,7 +462,6 @@ instance (FromJSON a) => FromJSON (Hit a) where
473 v .: "_id" <*>
462 v .: "_id" <*>
474 v .: "_score" <*>
463 v .: "_score" <*>
475 v .:? "_source" <*>
464 v .:? "_source" <*>
476− v .:? "sort" <*>
477 v .:? "fields" <*>
465 v .:? "fields" <*>
478 v .:? "highlight"
466 v .:? "highlight"
479 parseJSON _ = empty
467 parseJSON _ = empty
src/Database/Bloodhound/Internal/Analysis.hs → src/Database/V5/Bloodhound/Internal/Analysis.hsrenamed+4−3
@@ -1,15 +1,16 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3
3
4−module Database.Bloodhound.Internal.Analysis where
4+module Database.V5.Bloodhound.Internal.Analysis where
5
5
6import Bloodhound.Import
6import Bloodhound.Import
7
7
8import qualified Data.Map.Strict as M
8import qualified Data.Map.Strict as M
9+import Data.String
9import qualified Data.Text as T
10import qualified Data.Text as T
10
11
11−import Database.Bloodhound.Internal.Newtypes
12+import Database.V5.Bloodhound.Internal.Newtypes
12−import Database.Bloodhound.Internal.StringlyTyped
13+import Database.V5.Bloodhound.Internal.StringlyTyped
13
14
14data Analysis = Analysis
15data Analysis = Analysis
15 { analysisAnalyzer :: M.Map Text AnalyzerDefinition
16 { analysisAnalyzer :: M.Map Text AnalyzerDefinition
src/Database/Bloodhound/Internal/Client.hs → src/Database/V5/Bloodhound/Internal/Client.hsrenamed+5−16
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
1{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
@@ -6,15 +5,10 @@
6{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE RecordWildCards #-}
7{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE UndecidableInstances #-}
8
7
9−module Database.Bloodhound.Internal.Client where
8+module Database.V5.Bloodhound.Internal.Client where
10
9
11import Bloodhound.Import
10import Bloodhound.Import
12
11
13−#if defined(MIN_VERSION_GLASGOW_HASKELL)
14−#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
15−import Control.Monad.Fail (MonadFail)
16−#endif
17−#endif
18import qualified Data.Text as T
12import qualified Data.Text as T
19import qualified Data.Traversable as DT
13import qualified Data.Traversable as DT
20import qualified Data.HashMap.Strict as HM
14import qualified Data.HashMap.Strict as HM
@@ -25,10 +19,10 @@ import Network.HTTP.Client
25import Text.Read (Read(..))
19import Text.Read (Read(..))
26import qualified Text.Read as TR
20import qualified Text.Read as TR
27
21
28−import Database.Bloodhound.Internal.Analysis
22+import Database.V5.Bloodhound.Internal.Analysis
29−import Database.Bloodhound.Internal.Newtypes
23+import Database.V5.Bloodhound.Internal.Newtypes
30−import Database.Bloodhound.Internal.Query
24+import Database.V5.Bloodhound.Internal.Query
31−import Database.Bloodhound.Internal.StringlyTyped
25+import Database.V5.Bloodhound.Internal.StringlyTyped
32
26
33{-| Common environment for Elasticsearch calls. Connections will be
27{-| Common environment for Elasticsearch calls. Connections will be
34 pipelined according to the provided HTTP connection manager.
28 pipelined according to the provided HTTP connection manager.
@@ -77,11 +71,6 @@ newtype BH m a = BH {
77 , MonadFix
71 , MonadFix
78 , MonadThrow
72 , MonadThrow
79 , MonadCatch
73 , MonadCatch
80−#if defined(MIN_VERSION_GLASGOW_HASKELL)
81−#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
82− , MonadFail
83−#endif
84−#endif
85 , MonadMask)
74 , MonadMask)
86
75
87instance MonadTrans BH where
76instance MonadTrans BH where
src/Database/Bloodhound/Internal/Highlight.hs → src/Database/V5/Bloodhound/Internal/Highlight.hsrenamed+3−3
@@ -1,14 +1,14 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3
3
4−module Database.Bloodhound.Internal.Highlight where
4+module Database.V5.Bloodhound.Internal.Highlight where
5
5
6import Bloodhound.Import
6import Bloodhound.Import
7
7
8import qualified Data.Map.Strict as M
8import qualified Data.Map.Strict as M
9
9
10−import Database.Bloodhound.Internal.Newtypes
10+import Database.V5.Bloodhound.Internal.Newtypes
11−import Database.Bloodhound.Internal.Query
11+import Database.V5.Bloodhound.Internal.Query
12
12
13type HitHighlight = M.Map Text [Text]
13type HitHighlight = M.Map Text [Text]
14
14
src/Database/Bloodhound/Internal/Newtypes.hs → src/Database/V5/Bloodhound/Internal/Newtypes.hsrenamed+3−1
@@ -1,7 +1,7 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3
3
4−module Database.Bloodhound.Internal.Newtypes where
4+module Database.V5.Bloodhound.Internal.Newtypes where
5
5
6import Bloodhound.Import
6import Bloodhound.Import
7
7
@@ -110,6 +110,8 @@ newtype MinimumTermFrequency =
110 MinimumTermFrequency Int deriving (Eq, Show, FromJSON, ToJSON)
110 MinimumTermFrequency Int deriving (Eq, Show, FromJSON, ToJSON)
111newtype MaxQueryTerms =
111newtype MaxQueryTerms =
112 MaxQueryTerms Int deriving (Eq, Show, FromJSON, ToJSON)
112 MaxQueryTerms Int deriving (Eq, Show, FromJSON, ToJSON)
113+newtype Fuzziness =
114+ Fuzziness Double deriving (Eq, Show, FromJSON, ToJSON)
113
115
114{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -}
116{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -}
115newtype PrefixLength =
117newtype PrefixLength =
src/Database/Bloodhound/Internal/Query.hs → src/Database/V5/Bloodhound/Internal/Query.hsrenamed+15−32
@@ -2,9 +2,9 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4
4
5−module Database.Bloodhound.Internal.Query
5+module Database.V5.Bloodhound.Internal.Query
6 ( module X
6 ( module X
7− , module Database.Bloodhound.Internal.Query
7+ , module Database.V5.Bloodhound.Internal.Query
8 ) where
8 ) where
9
9
10import Bloodhound.Import
10import Bloodhound.Import
@@ -15,7 +15,7 @@ import Data.List (nub)
15import qualified Data.Text as T
15import qualified Data.Text as T
16
16
17import Database.Bloodhound.Common.Script as X
17import Database.Bloodhound.Common.Script as X
18−import Database.Bloodhound.Internal.Newtypes
18+import Database.V5.Bloodhound.Internal.Newtypes
19
19
20data Query =
20data Query =
21 TermQuery Term (Maybe Boost)
21 TermQuery Term (Maybe Boost)
@@ -834,18 +834,17 @@ instance FromJSON DisMaxQuery where
834 <*> o .:? "boost"
834 <*> o .:? "boost"
835
835
836data MatchQuery = MatchQuery
836data MatchQuery = MatchQuery
837− { matchQueryField :: FieldName
837+ { matchQueryField :: FieldName
838− , matchQueryQueryString :: QueryString
838+ , matchQueryQueryString :: QueryString
839− , matchQueryOperator :: BooleanOperator
839+ , matchQueryOperator :: BooleanOperator
840− , matchQueryZeroTerms :: ZeroTermsQuery
840+ , matchQueryZeroTerms :: ZeroTermsQuery
841− , matchQueryCutoffFrequency :: Maybe CutoffFrequency
841+ , matchQueryCutoffFrequency :: Maybe CutoffFrequency
842− , matchQueryMatchType :: Maybe MatchQueryType
842+ , matchQueryMatchType :: Maybe MatchQueryType
843− , matchQueryAnalyzer :: Maybe Analyzer
843+ , matchQueryAnalyzer :: Maybe Analyzer
844− , matchQueryMaxExpansions :: Maybe MaxExpansions
844+ , matchQueryMaxExpansions :: Maybe MaxExpansions
845− , matchQueryLenient :: Maybe Lenient
845+ , matchQueryLenient :: Maybe Lenient
846− , matchQueryBoost :: Maybe Boost
846+ , matchQueryBoost :: Maybe Boost
847 , matchQueryMinimumShouldMatch :: Maybe Text
847 , matchQueryMinimumShouldMatch :: Maybe Text
848− , matchQueryFuzziness :: Maybe Fuzziness
849 } deriving (Eq, Show)
848 } deriving (Eq, Show)
850
849
851
850
@@ -854,7 +853,7 @@ instance ToJSON MatchQuery where
854 (QueryString mqQueryString) booleanOperator
853 (QueryString mqQueryString) booleanOperator
855 zeroTermsQuery cutoffFrequency matchQueryType
854 zeroTermsQuery cutoffFrequency matchQueryType
856 analyzer maxExpansions lenient boost
855 analyzer maxExpansions lenient boost
857− minShouldMatch mqFuzziness
856+ minShouldMatch
858 ) =
857 ) =
859 object [ fieldName .= omitNulls base ]
858 object [ fieldName .= omitNulls base ]
860 where base = [ "query" .= mqQueryString
859 where base = [ "query" .= mqQueryString
@@ -867,7 +866,6 @@ instance ToJSON MatchQuery where
867 , "lenient" .= lenient
866 , "lenient" .= lenient
868 , "boost" .= boost
867 , "boost" .= boost
869 , "minimum_should_match" .= minShouldMatch
868 , "minimum_should_match" .= minShouldMatch
870− , "fuzziness" .= mqFuzziness
871 ]
869 ]
872
870
873instance FromJSON MatchQuery where
871instance FromJSON MatchQuery where
@@ -884,13 +882,12 @@ instance FromJSON MatchQuery where
884 <*> o .:? "lenient"
882 <*> o .:? "lenient"
885 <*> o .:? "boost"
883 <*> o .:? "boost"
886 <*> o .:? "minimum_should_match"
884 <*> o .:? "minimum_should_match"
887− <*> o .:? "fuzziness"
888
885
889{-| 'mkMatchQuery' is a convenience function that defaults the less common parameters,
886{-| 'mkMatchQuery' is a convenience function that defaults the less common parameters,
890 enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery'
887 enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery'
891-}
888-}
892mkMatchQuery :: FieldName -> QueryString -> MatchQuery
889mkMatchQuery :: FieldName -> QueryString -> MatchQuery
893−mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
890+mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing Nothing
894
891
895data MatchQueryType =
892data MatchQueryType =
896 MatchPhrase
893 MatchPhrase
@@ -1624,17 +1621,3 @@ fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a
1624fieldTagged f o = case HM.toList o of
1621fieldTagged f o = case HM.toList o of
1625 [(k, Object o')] -> f (FieldName k) o'
1622 [(k, Object o')] -> f (FieldName k) o'
1626 _ -> fail "Expected object with 1 field-named key"
1623 _ -> fail "Expected object with 1 field-named key"
1627−
1628−-- | Fuzziness value as a number or 'AUTO'.
1629−-- See:
1630−-- https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#fuzziness
1631−data Fuzziness = Fuzziness Double | FuzzinessAuto
1632− deriving (Eq, Show)
1633−
1634−instance ToJSON Fuzziness where
1635− toJSON (Fuzziness n) = toJSON n
1636− toJSON FuzzinessAuto = String "AUTO"
1637−
1638−instance FromJSON Fuzziness where
1639− parseJSON (String "AUTO") = return FuzzinessAuto
1640− parseJSON v = Fuzziness <$> parseJSON v
src/Database/Bloodhound/Internal/Sort.hs → src/Database/V5/Bloodhound/Internal/Sort.hsrenamed+3−3
@@ -2,12 +2,12 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4
4
5−module Database.Bloodhound.Internal.Sort where
5+module Database.V5.Bloodhound.Internal.Sort where
6
6
7import Bloodhound.Import
7import Bloodhound.Import
8
8
9−import Database.Bloodhound.Internal.Newtypes
9+import Database.V5.Bloodhound.Internal.Newtypes
10−import Database.Bloodhound.Internal.Query
10+import Database.V5.Bloodhound.Internal.Query
11
11
12{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.
12{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.
13
13
src/Database/Bloodhound/Internal/StringlyTyped.hs → src/Database/V5/Bloodhound/Internal/StringlyTyped.hsrenamed+1−1
@@ -1,6 +1,6 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2
2
3−module Database.Bloodhound.Internal.StringlyTyped where
3+module Database.V5.Bloodhound.Internal.StringlyTyped where
4
4
5import Bloodhound.Import
5import Bloodhound.Import
6
6
src/Database/Bloodhound/Internal/Suggest.hs → src/Database/V5/Bloodhound/Internal/Suggest.hsrenamed+3−3
@@ -2,14 +2,14 @@
2{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4
4
5−module Database.Bloodhound.Internal.Suggest where
5+module Database.V5.Bloodhound.Internal.Suggest where
6
6
7import Bloodhound.Import
7import Bloodhound.Import
8
8
9import qualified Data.HashMap.Strict as HM
9import qualified Data.HashMap.Strict as HM
10
10
11−import Database.Bloodhound.Internal.Newtypes
11+import Database.V5.Bloodhound.Internal.Newtypes
12−import Database.Bloodhound.Internal.Query (TemplateQueryInline(..), params)
12+import Database.V5.Bloodhound.Internal.Query (TemplateQueryInline(..), params)
13
13
14data Suggest = Suggest
14data Suggest = Suggest
15 { suggestText :: Text
15 { suggestText :: Text
src/Database/Bloodhound/Types.hs → src/Database/V5/Bloodhound/Types.hsrenamed+13−15
@@ -26,7 +26,7 @@
26
26
27
27
28
28
29−module Database.Bloodhound.Types
29+module Database.V5.Bloodhound.Types
30 ( defaultCache
30 ( defaultCache
31 , defaultIndexSettings
31 , defaultIndexSettings
32 , defaultIndexDocumentSettings
32 , defaultIndexDocumentSettings
@@ -122,6 +122,7 @@ module Database.Bloodhound.Types
122 , Hit(..)
122 , Hit(..)
123 , HitFields(..)
123 , HitFields(..)
124 , Filter(..)
124 , Filter(..)
125+ , Seminearring(..)
125 , BoolMatch(..)
126 , BoolMatch(..)
126 , Term(..)
127 , Term(..)
127 , GeoPoint(..)
128 , GeoPoint(..)
@@ -372,7 +373,6 @@ module Database.Bloodhound.Types
372 , ValueCountAggregation(..)
373 , ValueCountAggregation(..)
373 , FilterAggregation(..)
374 , FilterAggregation(..)
374 , CardinalityAggregation(..)
375 , CardinalityAggregation(..)
375− , MaxAggregation(..)
376 , DateHistogramAggregation(..)
376 , DateHistogramAggregation(..)
377 , DateRangeAggregation(..)
377 , DateRangeAggregation(..)
378 , DateRangeAggRange(..)
378 , DateRangeAggRange(..)
@@ -382,7 +382,6 @@ module Database.Bloodhound.Types
382 , DateMathUnit(..)
382 , DateMathUnit(..)
383 , TopHitsAggregation(..)
383 , TopHitsAggregation(..)
384 , StatisticsAggregation(..)
384 , StatisticsAggregation(..)
385− , SearchAfterKey
386
385
387 , Highlights(..)
386 , Highlights(..)
388 , FieldHighlight(..)
387 , FieldHighlight(..)
@@ -414,18 +413,19 @@ module Database.Bloodhound.Types
414 , TokenChar(..)
413 , TokenChar(..)
415 , Shingle(..)
414 , Shingle(..)
416 , Language(..)
415 , Language(..)
417− ) where
416+ ) where
418
417
419import Bloodhound.Import
418import Bloodhound.Import
420
419
420+import Database.V5.Bloodhound.Types.Class
421+import Database.V5.Bloodhound.Internal.Analysis
421−import Database.Bloodhound.Internal.Aggregation
422+import Database.V5.Bloodhound.Internal.Aggregation
422−import Database.Bloodhound.Internal.Analysis
423−import Database.Bloodhound.Internal.Client
423+import Database.V5.Bloodhound.Internal.Client
424−import Database.Bloodhound.Internal.Highlight
424+import Database.V5.Bloodhound.Internal.Highlight
425−import Database.Bloodhound.Internal.Newtypes
425+import Database.V5.Bloodhound.Internal.Newtypes
426−import Database.Bloodhound.Internal.Query
426+import Database.V5.Bloodhound.Internal.Query
427−import Database.Bloodhound.Internal.Sort
427+import Database.V5.Bloodhound.Internal.Sort
428−import Database.Bloodhound.Internal.Suggest
428+import Database.V5.Bloodhound.Internal.Suggest
429
429
430{-| 'unpackId' is a silly convenience function that gets used once.
430{-| 'unpackId' is a silly convenience function that gets used once.
431-}
431-}
@@ -444,7 +444,6 @@ data Search = Search { queryBody :: Maybe Query
444 , from :: From
444 , from :: From
445 , size :: Size
445 , size :: Size
446 , searchType :: SearchType
446 , searchType :: SearchType
447− , searchAfterKey :: Maybe SearchAfterKey
448 , fields :: Maybe [FieldName]
447 , fields :: Maybe [FieldName]
449 , scriptFields :: Maybe ScriptFields
448 , scriptFields :: Maybe ScriptFields
450 , source :: Maybe Source
449 , source :: Maybe Source
@@ -454,7 +453,7 @@ data Search = Search { queryBody :: Maybe Query
454
453
455instance ToJSON Search where
454instance ToJSON Search where
456 toJSON (Search mquery sFilter sort searchAggs
455 toJSON (Search mquery sFilter sort searchAggs
457− highlight sTrackSortScores sFrom sSize _ sAfter sFields
456+ highlight sTrackSortScores sFrom sSize _ sFields
458 sScriptFields sSource sSuggest) =
457 sScriptFields sSource sSuggest) =
459 omitNulls [ "query" .= query'
458 omitNulls [ "query" .= query'
460 , "sort" .= sort
459 , "sort" .= sort
@@ -463,7 +462,6 @@ instance ToJSON Search where
463 , "from" .= sFrom
462 , "from" .= sFrom
464 , "size" .= sSize
463 , "size" .= sSize
465 , "track_scores" .= sTrackSortScores
464 , "track_scores" .= sTrackSortScores
466− , "search_after" .= sAfter
467 , "fields" .= sFields
465 , "fields" .= sFields
468 , "script_fields" .= sScriptFields
466 , "script_fields" .= sScriptFields
469 , "_source" .= sSource
467 , "_source" .= sSource
src/Database/V5/Bloodhound/Types/Class.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE CPP #-}
2+module Database.V5.Bloodhound.Types.Class
3+ ( Seminearring(..) )
4+ where
5+
6+#if !MIN_VERSION_base(4,8,0)
7+import Data.Monoid
8+#endif
9+
10+class Monoid a => Seminearring a where
11+ -- 0, +, *
12+ (<||>) :: a -> a -> a
13+ (<&&>) :: a -> a -> a
14+ (<&&>) = mappend
15+
16+infixr 5 <||>
17+infixr 5 <&&>
stack-8.2.yaml.lockdeleted−40
@@ -1,40 +0,0 @@
1−# This file was autogenerated by Stack.
2−# You should not edit this file by hand.
3−# For more information, please see the documentation at:
4−# https://docs.haskellstack.org/en/stable/lock_files
5−
6−packages:
7−- completed:
8− hackage: aeson-1.3.0.0@sha256:23c353da98033eab7dca65d496df6c79c929f8d1413119648d1de01e703fbd3b,6539
9− pantry-tree:
10− size: 39767
11− sha256: 68512381071165c48e123cf515c1098ee455ec75b56724e31f6d570d3c865c47
12− original:
13− hackage: aeson-1.3.0.0
14−- completed:
15− hackage: http-types-0.12.1@sha256:12ce2fc081fde3cf219b630c2fb3815183a64eee236ba7aa735f666eab949610,2035
16− pantry-tree:
17− size: 832
18− sha256: c66c35b8f4f1b8b82f99cf8de3711027b5d0cc64bd031ab84375100038f81310
19− original:
20− hackage: http-types-0.12.1
21−- completed:
22− hackage: quickcheck-arbitrary-template-0.2.0.0@sha256:c8afad9c6e1f2a1d9813bb6c94158a99f7d6edeae8bb696b29d6c450f67811ec,2025
23− pantry-tree:
24− size: 625
25− sha256: 64262d8f3365305c35babbb2f5727ea3287c3fad61d3b66c3a2c68185fe92c5a
26− original:
27− hackage: quickcheck-arbitrary-template-0.2.0.0
28−- completed:
29− hackage: quickcheck-properties-0.1@sha256:3bd0890e84ec4cf1c1e6e475152c2c0d7c85915a051cf4e8bf9ec70c32df735c,1268
30− pantry-tree:
31− size: 550
32− sha256: 12264d8a89883b42e78c313792f8cba9af51c8fda915fce34e9780ff6972cf7e
33− original:
34− hackage: quickcheck-properties-0.1
35−snapshots:
36−- completed:
37− size: 507208
38− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/6.yaml
39− sha256: 99d52f009dc5a53ac61ffc4e6044f910ca7b28b4596b6962135a48e8c7d3d093
40− original: lts-11.6
stack-8.4.yamldeleted−15
@@ -1,15 +0,0 @@
1−flags:
2− bloodhound-examples:
3− werror: true
4−
5−packages:
6− - '.'
7− - './examples'
8−
9−# extra-deps:
10−# - aeson-1.3.0.0
11−# - http-types-0.12.1
12−# - quickcheck-arbitrary-template-0.2.0.0
13−# - quickcheck-properties-0.1
14−
15−resolver: lts-12.6
stack-8.4.yaml.lockdeleted−12
@@ -1,12 +0,0 @@
1−# This file was autogenerated by Stack.
2−# You should not edit this file by hand.
3−# For more information, please see the documentation at:
4−# https://docs.haskellstack.org/en/stable/lock_files
5−
6−packages: []
7−snapshots:
8−- completed:
9− size: 502349
10− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/6.yaml
11− sha256: fbce9f11b2f1c637855eb29fe952f3ac16c35d46836df0dee0cc54a85e1e33d6
12− original: lts-12.6
stack-8.6.yamldeleted−14
@@ -1,14 +0,0 @@
1−flags:
2− bloodhound-examples:
3− werror: true
4−
5−packages:
6− - '.'
7− - './examples'
8−
9−extra-deps:
10− - git: https://github.com/bitemyapp/quickcheck-arbitrary-template.git
11− commit: bf9cee96a88ecce2ff920ce74c166a38712e5ed2
12− - quickcheck-properties-0.1
13−
14−resolver: lts-13.30
stack-8.6.yaml.lockdeleted−33
@@ -1,33 +0,0 @@
1−# This file was autogenerated by Stack.
2−# You should not edit this file by hand.
3−# For more information, please see the documentation at:
4−# https://docs.haskellstack.org/en/stable/lock_files
5−
6−packages:
7−- completed:
8− cabal-file:
9− size: 2026
10− sha256: d340ae2f3fd0b54b2f899d482072be24f41eddac8ea081f11d9db260b14264c8
11− name: quickcheck-arbitrary-template
12− version: 0.2.0.0
13− git: https://github.com/bitemyapp/quickcheck-arbitrary-template.git
14− pantry-tree:
15− size: 859
16− sha256: a6c70780465af154ada9481c0a5ffcda1b069d249522634c578218c3c390cbf1
17− commit: bf9cee96a88ecce2ff920ce74c166a38712e5ed2
18− original:
19− git: https://github.com/bitemyapp/quickcheck-arbitrary-template.git
20− commit: bf9cee96a88ecce2ff920ce74c166a38712e5ed2
21−- completed:
22− hackage: quickcheck-properties-0.1@sha256:3bd0890e84ec4cf1c1e6e475152c2c0d7c85915a051cf4e8bf9ec70c32df735c,1268
23− pantry-tree:
24− size: 550
25− sha256: 12264d8a89883b42e78c313792f8cba9af51c8fda915fce34e9780ff6972cf7e
26− original:
27− hackage: quickcheck-properties-0.1
28−snapshots:
29−- completed:
30− size: 500539
31− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/30.yaml
32− sha256: 59ad6b944c9903847fecdc1d4815e8500c1f9999d80fd1b4d2d66e408faec44b
33− original: lts-13.30
stack.yaml+1−1
@@ -1 +1 @@
1−stack-8.6.yaml
1+stack-8.2.yaml
stack.yaml.lockdeleted−12
@@ -1,12 +0,0 @@
1−# This file was autogenerated by Stack.
2−# You should not edit this file by hand.
3−# For more information, please see the documentation at:
4−# https://docs.haskellstack.org/en/stable/lock_files
5−
6−packages: []
7−snapshots:
8−- completed:
9− size: 500539
10− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/30.yaml
11− sha256: 59ad6b944c9903847fecdc1d4815e8500c1f9999d80fd1b4d2d66e408faec44b
12− original: lts-13.30
tests/V1/Test/Aggregation.hsnew file+132
@@ -0,0 +1,132 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Aggregation (spec) where
4+
5+import Test.Common
6+import Test.Import
7+
8+import Control.Error (fmapL, note)
9+import qualified Data.Map as M
10+import qualified Database.V1.Bloodhound
11+
12+spec :: Spec
13+spec =
14+ describe "Aggregation API" $ do
15+ it "returns term aggregation results" $ withTestEnv $ do
16+ _ <- insertData
17+ let terms = TermsAgg $ mkTermsAggregation "user"
18+ let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
19+ searchExpectAggs search
20+ searchValidBucketAgg search "users" toTerms
21+
22+ it "return sub-aggregation results" $ withTestEnv $ do
23+ _ <- insertData
24+ let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation "age"
25+ agg = TermsAgg $ (mkTermsAggregation "user") { termAggs = Just subaggs}
26+ search = mkAggregateSearch Nothing $ mkAggregations "users" agg
27+ reply <- searchByIndex testIndex search
28+ let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
29+ usersAggResults = result >>= aggregations >>= toTerms "users"
30+ subAggResults = usersAggResults >>= (listToMaybe . buckets) >>= termsAggs >>= toTerms "age_agg"
31+ subAddResultsExists = isJust subAggResults
32+ liftIO $ subAddResultsExists `shouldBe` True
33+
34+ it "returns cardinality aggregation results" $ withTestEnv $ do
35+ _ <- insertData
36+ let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user"
37+ let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality
38+ let search' = search { Database.V1.Bloodhound.from = From 0, size = Size 0 }
39+ searchExpectAggs search'
40+ let docCountPair k n = (k, object ["value" .= Number n])
41+ res <- searchTweets search'
42+ liftIO $
43+ fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "users" 1]))
44+
45+ it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do
46+ _ <- insertData
47+ let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
48+ let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
49+ searchExpectAggs search
50+ searchValidBucketAgg search "users" toTerms
51+
52+ -- One of these fails with 1.7.3
53+ it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
54+ _ <- insertData
55+ searchTermsAggHint [Map, Ordinals]
56+
57+ it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
58+ _ <- insertData
59+ searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
60+
61+ it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
62+ _ <- insertData
63+ searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
64+ -- One of the above.
65+
66+ it "can execute value_count aggregations" $ withTestEnv $ do
67+ _ <- insertData
68+ _ <- insertOther
69+ let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
70+ mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
71+ let search = mkAggregateSearch Nothing ags
72+ let docCountPair k n = (k, object ["value" .= Number n])
73+ res <- searchTweets search
74+ liftIO $
75+ fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
76+ , docCountPair "bogus_count" 0
77+ ]))
78+
79+ it "can execute date_range aggregations" $ withTestEnv $ do
80+ let now = fromGregorian 2015 3 14
81+ let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0
82+ let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0
83+ let oldDoc = exampleTweet { postDate = ltAMonthAgo }
84+ let newDoc = exampleTweet { postDate = ltAWeekAgo }
85+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings oldDoc (DocId "1")
86+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings newDoc (DocId "2")
87+ _ <- refreshIndex testIndex
88+ let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth])
89+ let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek])
90+ let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek])
91+ let ags = mkAggregations "date_ranges" (DateRangeAgg agg)
92+ let search = mkAggregateSearch Nothing ags
93+ res <- searchTweets search
94+ liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right 2
95+ let bucks = do magrs <- fmapL show (aggregations <$> res)
96+ agrs <- note "no aggregations returned" magrs
97+ rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs
98+ parseEither parseJSON rawBucks
99+ let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0
100+ let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0
101+ liftIO $ buckets <$> bucks `shouldBe` Right [ DateRangeResult "2015-02-14T00:00:00.000Z-*"
102+ (Just fromMonthT)
103+ (Just "2015-02-14T00:00:00.000Z")
104+ Nothing
105+ Nothing
106+ 2
107+ Nothing
108+ , DateRangeResult "2015-03-07T00:00:00.000Z-*"
109+ (Just fromWeekT)
110+ (Just "2015-03-07T00:00:00.000Z")
111+ Nothing
112+ Nothing
113+ 1
114+ Nothing
115+ ]
116+
117+ it "returns date histogram aggregation results" $ withTestEnv $ do
118+ _ <- insertData
119+ let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
120+ let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
121+ searchExpectAggs search
122+ searchValidBucketAgg search "byDate" toDateHistogram
123+
124+ it "can execute missing aggregations" $ withTestEnv $ do
125+ _ <- insertData
126+ _ <- insertExtra
127+ let ags = mkAggregations "missing_agg" (MissingAgg (MissingAggregation "extra"))
128+ let search = mkAggregateSearch Nothing ags
129+ let docCountPair k n = (k, object ["doc_count" .= Number n])
130+ res <- searchTweets search
131+ liftIO $
132+ fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "missing_agg" 1]))
tests/Test/ApproxEq.hs → tests/V1/Test/ApproxEq.hsrenamed+1−1
@@ -3,7 +3,7 @@
3
3
4module Test.ApproxEq where
4module Test.ApproxEq where
5
5
6−import Database.Bloodhound
6+import Database.V1.Bloodhound
7
7
8import Test.Import
8import Test.Import
9
9
tests/V1/Test/BulkAPI.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.BulkAPI (spec) where
4+
5+import Test.Common
6+import Test.Import
7+
8+import qualified Data.Vector as V
9+import qualified Lens.Micro.Aeson as LMA
10+
11+newtype BulkTest =
12+ BulkTest Text
13+ deriving (Eq, Show)
14+
15+instance ToJSON BulkTest where
16+ toJSON (BulkTest name') =
17+ object ["name" .= name']
18+
19+instance FromJSON BulkTest where
20+ parseJSON = withObject "BulkTest" parse
21+ where
22+ parse o = do
23+ t <- o .: "name"
24+ BulkTest <$> parseJSON t
25+
26+spec :: Spec
27+spec =
28+ describe "Bulk API" $
29+ it "inserts all documents we request" $ withTestEnv $ do
30+ _ <- insertData
31+ let firstTest = BulkTest "blah"
32+ let secondTest = BulkTest "bloo"
33+ let firstDoc = BulkIndex testIndex
34+ testMapping (DocId "2") (toJSON firstTest)
35+ let secondDoc = BulkCreate testIndex
36+ testMapping (DocId "3") (toJSON secondTest)
37+ let stream = V.fromList [firstDoc, secondDoc]
38+ _ <- bulk stream
39+ _ <- refreshIndex testIndex
40+ fDoc <- getDocument testIndex testMapping (DocId "2")
41+ sDoc <- getDocument testIndex testMapping (DocId "3")
42+ -- note that we cannot query for fourthDoc and fifthDoc since we
43+ -- do not know their autogenerated ids.
44+ let maybeFirst =
45+ eitherDecode
46+ $ responseBody fDoc
47+ :: Either String (EsResult BulkTest)
48+ let maybeSecond =
49+ eitherDecode
50+ $ responseBody sDoc
51+ :: Either String (EsResult BulkTest)
52+ liftIO $ do
53+ fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
54+ fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
55+ -- Since we can't get the docs by doc id, we check for their existence in
56+ -- a match all query.
57+ let query = MatchAllQuery Nothing
58+ let search = mkSearch (Just query) Nothing
59+ resp <- searchByIndex testIndex search
60+ parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))
61+ case parsed of
62+ Left e ->
63+ liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)
64+ (Right sr) -> do
65+ liftIO $
66+ hitsTotal (searchHits sr) `shouldBe` 3
67+ let nameList :: [Text]
68+ nameList =
69+ hits (searchHits sr)
70+ ^.. traverse
71+ . to hitSource
72+ . _Just
73+ . LMA.key "name"
74+ . _String
75+ liftIO $
76+ nameList
77+ `shouldBe` ["blah","bloo"]
tests/V1/Test/Common.hsnew file+289
@@ -0,0 +1,289 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+
4+module Test.Common where
5+
6+import Test.Import
7+
8+import qualified Data.Map as M
9+import qualified Data.Version as Vers
10+import qualified Network.HTTP.Types.Status as NHTS
11+
12+testServer :: Server
13+testServer = Server "http://localhost:9200"
14+testIndex :: IndexName
15+testIndex = IndexName "bloodhound-tests-twitter-1"
16+testMapping :: MappingName
17+testMapping = MappingName "tweet"
18+
19+withTestEnv :: BH IO a -> IO a
20+withTestEnv = withBH defaultManagerSettings testServer
21+
22+data Location = Location { lat :: Double
23+ , lon :: Double } deriving (Eq, Show)
24+
25+data Tweet = Tweet { user :: Text
26+ , postDate :: UTCTime
27+ , message :: Text
28+ , age :: Int
29+ , location :: Location
30+ , extra :: Maybe Text }
31+ deriving (Eq, Show)
32+
33+$(deriveJSON defaultOptions ''Location)
34+$(deriveJSON defaultOptions ''Tweet)
35+
36+data ParentMapping = ParentMapping deriving (Eq, Show)
37+
38+instance ToJSON ParentMapping where
39+ toJSON ParentMapping =
40+ object ["properties" .=
41+ object [ "user" .= object ["type" .= ("string" :: Text)
42+ ]
43+ -- Serializing the date as a date is breaking other tests, mysteriously.
44+ -- , "postDate" .= object [ "type" .= ("date" :: Text)
45+ -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
46+ , "message" .= object ["type" .= ("string" :: Text)]
47+ , "age" .= object ["type" .= ("integer" :: Text)]
48+ , "location" .= object ["type" .= ("geo_point" :: Text)]
49+ , "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: Text)]
50+ ]]
51+
52+es13 :: Vers.Version
53+es13 = Vers.Version [1, 3, 0] []
54+
55+es12 :: Vers.Version
56+es12 = Vers.Version [1, 2, 0] []
57+
58+es11 :: Vers.Version
59+es11 = Vers.Version [1, 1, 0] []
60+
61+es14 :: Vers.Version
62+es14 = Vers.Version [1, 4, 0] []
63+
64+es15 :: Vers.Version
65+es15 = Vers.Version [1, 5, 0] []
66+
67+es16 :: Vers.Version
68+es16 = Vers.Version [1, 6, 0] []
69+
70+es20 :: Vers.Version
71+es20 = Vers.Version [2, 0, 0] []
72+
73+es50 :: Vers.Version
74+es50 = Vers.Version [5, 0, 0] []
75+
76+getServerVersion :: IO (Maybe Vers.Version)
77+getServerVersion = fmap extractVersion <$> withTestEnv getStatus
78+ where
79+ extractVersion = versionNumber . number . version
80+
81+createExampleIndex :: (MonadBH m) => m Reply
82+createExampleIndex =
83+ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
84+
85+deleteExampleIndex :: (MonadBH m) => m Reply
86+deleteExampleIndex =
87+ deleteIndex testIndex
88+
89+validateStatus :: Show body => Response body -> Int -> Expectation
90+validateStatus resp expected =
91+ if actual == expected
92+ then return ()
93+ else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)
94+ where
95+ actual = NHTS.statusCode (responseStatus resp)
96+ body = responseBody resp
97+
98+data ChildMapping = ChildMapping deriving (Eq, Show)
99+
100+instance ToJSON ChildMapping where
101+ toJSON ChildMapping =
102+ object ["_parent" .= object ["type" .= ("parent" :: Text)]
103+ , "properties" .=
104+ object [ "user" .= object ["type" .= ("string" :: Text)
105+ ]
106+ -- Serializing the date as a date is breaking other tests, mysteriously.
107+ -- , "postDate" .= object [ "type" .= ("date" :: Text)
108+ -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
109+ , "message" .= object ["type" .= ("string" :: Text)]
110+ , "age" .= object ["type" .= ("integer" :: Text)]
111+ , "location" .= object ["type" .= ("geo_point" :: Text)]
112+ , "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: Text)]
113+ ]]
114+
115+data TweetMapping = TweetMapping deriving (Eq, Show)
116+
117+instance ToJSON TweetMapping where
118+ toJSON TweetMapping =
119+ object ["tweet" .=
120+ object ["properties" .=
121+ object [ "user" .= object [ "type" .= ("string" :: Text)
122+ ]
123+ -- Serializing the date as a date is breaking other tests, mysteriously.
124+ -- , "postDate" .= object [ "type" .= ("date" :: Text)
125+ -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
126+ , "message" .= object ["type" .= ("string" :: Text)]
127+ , "age" .= object ["type" .= ("integer" :: Text)]
128+ , "location" .= object ["type" .= ("geo_point" :: Text)]
129+ , "extra" .= object ["type" .= ("string" :: Text), "index" .= ("not_analyzed" :: Text)]
130+ ]]]
131+
132+exampleTweet :: Tweet
133+exampleTweet = Tweet { user = "bitemyapp"
134+ , postDate = UTCTime
135+ (ModifiedJulianDay 55000)
136+ (secondsToDiffTime 10)
137+ , message = "Use haskell!"
138+ , age = 10000
139+ , location = Location 40.12 (-71.34)
140+ , extra = Nothing }
141+
142+tweetWithExtra :: Tweet
143+tweetWithExtra = Tweet { user = "bitemyapp"
144+ , postDate = UTCTime
145+ (ModifiedJulianDay 55000)
146+ (secondsToDiffTime 10)
147+ , message = "Use haskell!"
148+ , age = 10000
149+ , location = Location 40.12 (-71.34)
150+ , extra = Just "blah blah" }
151+
152+newAge :: Int
153+newAge = 31337
154+
155+newUser :: Text
156+newUser = "someotherapp"
157+
158+tweetPatch :: Value
159+tweetPatch =
160+ object [ "age" .= newAge
161+ , "user" .= newUser
162+ ]
163+
164+patchedTweet :: Tweet
165+patchedTweet = exampleTweet{age = newAge, user = newUser}
166+
167+otherTweet :: Tweet
168+otherTweet = Tweet { user = "notmyapp"
169+ , postDate = UTCTime
170+ (ModifiedJulianDay 55000)
171+ (secondsToDiffTime 11)
172+ , message = "Use haskell!"
173+ , age = 1000
174+ , location = Location 40.12 (-71.34)
175+ , extra = Nothing }
176+
177+resetIndex :: BH IO ()
178+resetIndex = do
179+ _ <- deleteExampleIndex
180+ _ <- createExampleIndex
181+ _ <- putMapping testIndex testMapping TweetMapping
182+ return ()
183+
184+insertData :: BH IO Reply
185+insertData = do
186+ resetIndex
187+ insertData' defaultIndexDocumentSettings
188+
189+insertData' :: IndexDocumentSettings -> BH IO Reply
190+insertData' ids = do
191+ r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
192+ _ <- refreshIndex testIndex
193+ return r
194+
195+updateData :: BH IO Reply
196+updateData = do
197+ r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1")
198+ _ <- refreshIndex testIndex
199+ return r
200+
201+insertOther :: BH IO ()
202+insertOther = do
203+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
204+ _ <- refreshIndex testIndex
205+ return ()
206+
207+insertExtra :: BH IO ()
208+insertExtra = do
209+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4")
210+ _ <- refreshIndex testIndex
211+ return ()
212+
213+insertWithSpaceInId :: BH IO ()
214+insertWithSpaceInId = do
215+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
216+ _ <- refreshIndex testIndex
217+ return ()
218+
219+searchTweet :: Search -> BH IO (Either EsError Tweet)
220+searchTweet search = do
221+ result <- searchTweets search
222+ let myTweet :: Either EsError Tweet
223+ myTweet = grabFirst result
224+ return myTweet
225+
226+searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
227+searchTweets search = parseEsResponse =<< searchByIndex testIndex search
228+
229+searchExpectNoResults :: Search -> BH IO ()
230+searchExpectNoResults search = do
231+ result <- searchTweets search
232+ let emptyHits = fmap (hits . searchHits) result
233+ liftIO $
234+ emptyHits `shouldBe` Right []
235+
236+searchExpectAggs :: Search -> BH IO ()
237+searchExpectAggs search = do
238+ reply <- searchByIndex testIndex search
239+ let isEmpty x = return (M.null x)
240+ let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
241+ liftIO $
242+ (result >>= aggregations >>= isEmpty) `shouldBe` Just False
243+
244+searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
245+ Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
246+searchValidBucketAgg search aggKey extractor = do
247+ reply <- searchByIndex testIndex search
248+ let bucketDocs = docCount . head . buckets
249+ let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
250+ let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
251+ liftIO $
252+ count `shouldBe` Just 1
253+
254+searchTermsAggHint :: [ExecutionHint] -> BH IO ()
255+searchTermsAggHint hints = do
256+ let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
257+ let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
258+ forM_ hints $ searchExpectAggs . search
259+ forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
260+
261+searchTweetHighlight :: Search
262+ -> BH IO (Either EsError (Maybe HitHighlight))
263+searchTweetHighlight search = do
264+ result <- searchTweets search
265+ let tweetHit :: Either EsError (Maybe (Hit Tweet))
266+ tweetHit = fmap (headMay . hits . searchHits) result
267+ myHighlight :: Either EsError (Maybe HitHighlight)
268+ myHighlight = (join . fmap hitHighlight) <$> tweetHit
269+ return myHighlight
270+
271+searchExpectSource :: Source -> Either EsError Value -> BH IO ()
272+searchExpectSource src expected = do
273+ _ <- insertData
274+ let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
275+ let search = (mkSearch (Just query) Nothing) { source = Just src }
276+ reply <- searchByIndex testIndex search
277+ result <- parseEsResponse reply
278+ let value = grabFirst result
279+ liftIO $
280+ value `shouldBe` expected
281+
282+atleast :: Vers.Version -> IO Bool
283+atleast v = getServerVersion >>= \x -> return $ x >= Just v
284+
285+atmost :: Vers.Version -> IO Bool
286+atmost v = getServerVersion >>= \x -> return $ x <= Just v
287+
288+is :: Vers.Version -> IO Bool
289+is v = getServerVersion >>= \x -> return $ x == Just v
tests/V1/Test/Documents.hsnew file+52
@@ -0,0 +1,52 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Documents where
4+
5+import Test.Common
6+import Test.Import
7+
8+spec :: Spec
9+spec =
10+ describe "document API" $ do
11+ it "indexes, updates, gets, and then deletes the generated document" $ withTestEnv $ do
12+ _ <- insertData
13+ _ <- updateData
14+ docInserted <- getDocument testIndex testMapping (DocId "1")
15+ let newTweet = eitherDecode
16+ (responseBody docInserted) :: Either String (EsResult Tweet)
17+ liftIO $ fmap getSource newTweet `shouldBe` Right (Just patchedTweet)
18+
19+ it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do
20+ _ <- insertWithSpaceInId
21+ docInserted <- getDocument testIndex testMapping (DocId "Hello World")
22+ let newTweet = eitherDecode
23+ (responseBody docInserted) :: Either String (EsResult Tweet)
24+ liftIO $ fmap getSource newTweet `shouldBe` Right (Just exampleTweet)
25+
26+ it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
27+ doc <- getDocument testIndex testMapping (DocId "bogus")
28+ let noTweet = eitherDecode
29+ (responseBody doc) :: Either String (EsResult Tweet)
30+ liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
31+
32+ it "can use optimistic concurrency control" $ withTestEnv $ do
33+ let ev = ExternalDocVersion minBound
34+ let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
35+ resetIndex
36+ res <- insertData' cfg
37+ liftIO $ isCreated res `shouldBe` True
38+ res' <- insertData' cfg
39+ liftIO $ isVersionConflict res' `shouldBe` True
40+
41+ it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do
42+ resetIndex
43+ let validateStatus' stat = liftIO . flip validateStatus stat
44+ _ <- validateStatus' 200 =<< putMapping testIndex (MappingName "child") ChildMapping
45+ _ <- validateStatus' 200 =<< putMapping testIndex (MappingName "parent") ParentMapping
46+ _ <- validateStatus' 201 =<< indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
47+ let parent = (Just . DocumentParent . DocId) "1"
48+ ids = IndexDocumentSettings NoVersionControl parent
49+ _ <- validateStatus' 201 =<< indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
50+ _ <- refreshIndex testIndex
51+ exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
52+ liftIO $ exists `shouldBe` True
tests/V1/Test/Generators.hsnew file+432
@@ -0,0 +1,432 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+
7+module Test.Generators where
8+
9+import Database.V1.Bloodhound
10+
11+import Test.Import
12+
13+import qualified Data.HashMap.Strict as HM
14+import qualified Data.List as L
15+import qualified Data.List.NonEmpty as NE
16+import qualified Data.Map as M
17+import qualified Data.Text as T
18+import qualified Data.Version as Vers
19+import Test.QuickCheck.TH.Generators
20+
21+import Test.ApproxEq
22+
23+instance Arbitrary NominalDiffTime where
24+ arbitrary = fromInteger <$> arbitrary
25+
26+#if !MIN_VERSION_QuickCheck(2,8,0)
27+instance (Arbitrary k, Ord k, Arbitrary v) => Arbitrary (M.Map k v) where
28+ arbitrary = M.fromList <$> arbitrary
29+#endif
30+
31+instance Arbitrary Text where
32+ arbitrary = T.pack <$> arbitrary
33+
34+instance Arbitrary UTCTime where
35+ arbitrary = UTCTime
36+ <$> arbitrary
37+ <*> (fromRational . toRational <$> choose (0::Double, 86400))
38+
39+instance Arbitrary Day where
40+ arbitrary =
41+ ModifiedJulianDay . (2000 +) <$> arbitrary
42+ shrink =
43+ (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay
44+
45+#if !MIN_VERSION_QuickCheck(2,9,0)
46+instance Arbitrary a => Arbitrary (NonEmpty a) where
47+ arbitrary = liftA2 (:|) arbitrary arbitrary
48+#endif
49+
50+arbitraryScore :: Gen Score
51+arbitraryScore = fmap getPositive <$> arbitrary
52+
53+instance (Arbitrary a, Typeable a) => Arbitrary (Hit a) where
54+ arbitrary = Hit <$> arbitrary
55+ <*> arbitrary
56+ <*> arbitrary
57+ <*> arbitraryScore
58+ <*> arbitrary
59+ <*> arbitrary
60+
61+instance (Arbitrary a, Typeable a) => Arbitrary (SearchHits a) where
62+ arbitrary = reduceSize $ do
63+ tot <- getPositive <$> arbitrary
64+ score <- arbitraryScore
65+ hs <- arbitrary
66+ return $ SearchHits tot score hs
67+
68+
69+reduceSize :: Gen a -> Gen a
70+reduceSize f = sized $ \n -> resize (n `div` 2) f
71+
72+arbitraryAlphaNum :: Gen Char
73+arbitraryAlphaNum = oneof [choose ('a', 'z')
74+ ,choose ('A','Z')
75+ , choose ('0', '9')]
76+
77+instance Arbitrary RoutingValue where
78+ arbitrary = RoutingValue . T.pack <$> listOf1 arbitraryAlphaNum
79+
80+instance Arbitrary AliasRouting where
81+ arbitrary = oneof [allAlias
82+ ,one
83+ ,theOther
84+ ,both']
85+ where one = GranularAliasRouting
86+ <$> (Just <$> arbitrary)
87+ <*> pure Nothing
88+ theOther = GranularAliasRouting Nothing
89+ <$> (Just <$> arbitrary)
90+ both' = GranularAliasRouting
91+ <$> (Just <$> arbitrary)
92+ <*> (Just <$> arbitrary)
93+ allAlias = AllAliasRouting <$> arbitrary
94+
95+
96+
97+instance Arbitrary FieldName where
98+ arbitrary =
99+ FieldName
100+ . T.pack
101+ <$> listOf1 arbitraryAlphaNum
102+
103+
104+#if MIN_VERSION_base(4,10,0)
105+-- Test.QuickCheck.Modifiers
106+
107+qcNonEmptyToNonEmpty :: NonEmptyList a -> NonEmpty a
108+qcNonEmptyToNonEmpty (NonEmpty (a : xs)) = (a :| xs)
109+qcNonEmptyToNonEmpty (NonEmpty []) = error "NonEmpty was empty!"
110+
111+instance Arbitrary a => Arbitrary (NonEmpty a) where
112+ arbitrary =
113+ qcNonEmptyToNonEmpty
114+ <$> arbitrary
115+#endif
116+
117+instance Arbitrary RegexpFlags where
118+ arbitrary = oneof [ pure AllRegexpFlags
119+ , pure NoRegexpFlags
120+ , SomeRegexpFlags <$> genUniqueFlags
121+ ]
122+ where genUniqueFlags =
123+ NE.fromList . L.nub
124+ <$> listOf1 arbitrary
125+
126+instance Arbitrary IndexAliasCreate where
127+ arbitrary =
128+ IndexAliasCreate
129+ <$> arbitrary
130+ <*> reduceSize arbitrary
131+
132+instance Arbitrary ReplicaBounds where
133+ arbitrary = oneof [ replicasBounded
134+ , replicasLowerBounded
135+ , pure ReplicasUnbounded
136+ ]
137+ where replicasBounded = do
138+ Positive a <- arbitrary
139+ Positive b <- arbitrary
140+ return (ReplicasBounded a b)
141+ replicasLowerBounded = do
142+ Positive a <- arbitrary
143+ return (ReplicasLowerBounded a)
144+
145+instance Arbitrary NodeAttrName where
146+ arbitrary =
147+ NodeAttrName
148+ . T.pack
149+ <$> listOf1 arbitraryAlphaNum
150+
151+
152+instance Arbitrary NodeAttrFilter where
153+ arbitrary = do
154+ n <- arbitrary
155+ s:ss <- listOf1 (listOf1 arbitraryAlphaNum)
156+ let ts = T.pack <$> s :| ss
157+ return (NodeAttrFilter n ts)
158+
159+instance Arbitrary VersionNumber where
160+ arbitrary = mk . fmap getPositive . getNonEmpty <$> arbitrary
161+ where
162+ mk versions = VersionNumber (Vers.Version versions [])
163+
164+instance Arbitrary TemplateQueryKeyValuePairs where
165+ arbitrary = TemplateQueryKeyValuePairs . HM.fromList <$> arbitrary
166+ shrink (TemplateQueryKeyValuePairs x) = map (TemplateQueryKeyValuePairs . HM.fromList) . shrink $ HM.toList x
167+
168+makeArbitrary ''FilteredQuery
169+instance Arbitrary FilteredQuery where arbitrary = reduceSize arbitraryFilteredQuery
170+makeArbitrary ''Query
171+instance Arbitrary Query where arbitrary = reduceSize arbitraryQuery
172+makeArbitrary ''Filter
173+instance Arbitrary Filter where arbitrary = reduceSize arbitraryFilter
174+makeArbitrary ''IndexName
175+instance Arbitrary IndexName where arbitrary = arbitraryIndexName
176+makeArbitrary ''MappingName
177+instance Arbitrary MappingName where arbitrary = arbitraryMappingName
178+makeArbitrary ''DocId
179+instance Arbitrary DocId where arbitrary = arbitraryDocId
180+makeArbitrary ''Version
181+instance Arbitrary Version where arbitrary = arbitraryVersion
182+makeArbitrary ''BuildHash
183+instance Arbitrary BuildHash where arbitrary = arbitraryBuildHash
184+makeArbitrary ''IndexAliasRouting
185+instance Arbitrary IndexAliasRouting where arbitrary = arbitraryIndexAliasRouting
186+makeArbitrary ''ShardCount
187+instance Arbitrary ShardCount where arbitrary = arbitraryShardCount
188+makeArbitrary ''ReplicaCount
189+instance Arbitrary ReplicaCount where arbitrary = arbitraryReplicaCount
190+makeArbitrary ''TemplateName
191+instance Arbitrary TemplateName where arbitrary = arbitraryTemplateName
192+makeArbitrary ''TemplatePattern
193+instance Arbitrary TemplatePattern where arbitrary = arbitraryTemplatePattern
194+makeArbitrary ''QueryString
195+instance Arbitrary QueryString where arbitrary = arbitraryQueryString
196+makeArbitrary ''CacheName
197+instance Arbitrary CacheName where arbitrary = arbitraryCacheName
198+makeArbitrary ''CacheKey
199+instance Arbitrary CacheKey where arbitrary = arbitraryCacheKey
200+makeArbitrary ''Existence
201+instance Arbitrary Existence where arbitrary = arbitraryExistence
202+makeArbitrary ''CutoffFrequency
203+instance Arbitrary CutoffFrequency where arbitrary = arbitraryCutoffFrequency
204+makeArbitrary ''Analyzer
205+instance Arbitrary Analyzer where arbitrary = arbitraryAnalyzer
206+makeArbitrary ''MaxExpansions
207+instance Arbitrary MaxExpansions where arbitrary = arbitraryMaxExpansions
208+makeArbitrary ''Lenient
209+instance Arbitrary Lenient where arbitrary = arbitraryLenient
210+makeArbitrary ''Tiebreaker
211+instance Arbitrary Tiebreaker where arbitrary = arbitraryTiebreaker
212+makeArbitrary ''Boost
213+instance Arbitrary Boost where arbitrary = arbitraryBoost
214+makeArbitrary ''BoostTerms
215+instance Arbitrary BoostTerms where arbitrary = arbitraryBoostTerms
216+makeArbitrary ''MinimumMatch
217+instance Arbitrary MinimumMatch where arbitrary = arbitraryMinimumMatch
218+makeArbitrary ''DisableCoord
219+instance Arbitrary DisableCoord where arbitrary = arbitraryDisableCoord
220+makeArbitrary ''IgnoreTermFrequency
221+instance Arbitrary IgnoreTermFrequency where arbitrary = arbitraryIgnoreTermFrequency
222+makeArbitrary ''MinimumTermFrequency
223+instance Arbitrary MinimumTermFrequency where arbitrary = arbitraryMinimumTermFrequency
224+makeArbitrary ''MaxQueryTerms
225+instance Arbitrary MaxQueryTerms where arbitrary = arbitraryMaxQueryTerms
226+makeArbitrary ''Fuzziness
227+instance Arbitrary Fuzziness where arbitrary = arbitraryFuzziness
228+makeArbitrary ''PrefixLength
229+instance Arbitrary PrefixLength where arbitrary = arbitraryPrefixLength
230+makeArbitrary ''TypeName
231+instance Arbitrary TypeName where arbitrary = arbitraryTypeName
232+makeArbitrary ''PercentMatch
233+instance Arbitrary PercentMatch where arbitrary = arbitraryPercentMatch
234+makeArbitrary ''StopWord
235+instance Arbitrary StopWord where arbitrary = arbitraryStopWord
236+makeArbitrary ''QueryPath
237+instance Arbitrary QueryPath where arbitrary = arbitraryQueryPath
238+makeArbitrary ''AllowLeadingWildcard
239+instance Arbitrary AllowLeadingWildcard where arbitrary = arbitraryAllowLeadingWildcard
240+makeArbitrary ''LowercaseExpanded
241+instance Arbitrary LowercaseExpanded where arbitrary = arbitraryLowercaseExpanded
242+makeArbitrary ''EnablePositionIncrements
243+instance Arbitrary EnablePositionIncrements where arbitrary = arbitraryEnablePositionIncrements
244+makeArbitrary ''AnalyzeWildcard
245+instance Arbitrary AnalyzeWildcard where arbitrary = arbitraryAnalyzeWildcard
246+makeArbitrary ''GeneratePhraseQueries
247+instance Arbitrary GeneratePhraseQueries where arbitrary = arbitraryGeneratePhraseQueries
248+makeArbitrary ''Locale
249+instance Arbitrary Locale where arbitrary = arbitraryLocale
250+makeArbitrary ''MaxWordLength
251+instance Arbitrary MaxWordLength where arbitrary = arbitraryMaxWordLength
252+makeArbitrary ''MinWordLength
253+instance Arbitrary MinWordLength where arbitrary = arbitraryMinWordLength
254+makeArbitrary ''PhraseSlop
255+instance Arbitrary PhraseSlop where arbitrary = arbitraryPhraseSlop
256+makeArbitrary ''MinDocFrequency
257+instance Arbitrary MinDocFrequency where arbitrary = arbitraryMinDocFrequency
258+makeArbitrary ''MaxDocFrequency
259+instance Arbitrary MaxDocFrequency where arbitrary = arbitraryMaxDocFrequency
260+makeArbitrary ''Regexp
261+instance Arbitrary Regexp where arbitrary = arbitraryRegexp
262+makeArbitrary ''SimpleQueryStringQuery
263+instance Arbitrary SimpleQueryStringQuery where arbitrary = arbitrarySimpleQueryStringQuery
264+makeArbitrary ''FieldOrFields
265+instance Arbitrary FieldOrFields where arbitrary = arbitraryFieldOrFields
266+makeArbitrary ''SimpleQueryFlag
267+instance Arbitrary SimpleQueryFlag where arbitrary = arbitrarySimpleQueryFlag
268+makeArbitrary ''RegexpQuery
269+instance Arbitrary RegexpQuery where arbitrary = arbitraryRegexpQuery
270+makeArbitrary ''QueryStringQuery
271+instance Arbitrary QueryStringQuery where arbitrary = arbitraryQueryStringQuery
272+makeArbitrary ''RangeQuery
273+instance Arbitrary RangeQuery where arbitrary = arbitraryRangeQuery
274+makeArbitrary ''RangeValue
275+instance Arbitrary RangeValue where arbitrary = arbitraryRangeValue
276+makeArbitrary ''PrefixQuery
277+instance Arbitrary PrefixQuery where arbitrary = arbitraryPrefixQuery
278+makeArbitrary ''NestedQuery
279+instance Arbitrary NestedQuery where arbitrary = arbitraryNestedQuery
280+makeArbitrary ''MoreLikeThisFieldQuery
281+instance Arbitrary MoreLikeThisFieldQuery where arbitrary = arbitraryMoreLikeThisFieldQuery
282+makeArbitrary ''MoreLikeThisQuery
283+instance Arbitrary MoreLikeThisQuery where arbitrary = arbitraryMoreLikeThisQuery
284+makeArbitrary ''IndicesQuery
285+instance Arbitrary IndicesQuery where arbitrary = arbitraryIndicesQuery
286+makeArbitrary ''HasParentQuery
287+instance Arbitrary HasParentQuery where arbitrary = arbitraryHasParentQuery
288+makeArbitrary ''HasChildQuery
289+instance Arbitrary HasChildQuery where arbitrary = arbitraryHasChildQuery
290+makeArbitrary ''FuzzyQuery
291+instance Arbitrary FuzzyQuery where arbitrary = arbitraryFuzzyQuery
292+makeArbitrary ''FuzzyLikeFieldQuery
293+instance Arbitrary FuzzyLikeFieldQuery where arbitrary = arbitraryFuzzyLikeFieldQuery
294+makeArbitrary ''FuzzyLikeThisQuery
295+instance Arbitrary FuzzyLikeThisQuery where arbitrary = arbitraryFuzzyLikeThisQuery
296+makeArbitrary ''DisMaxQuery
297+instance Arbitrary DisMaxQuery where arbitrary = arbitraryDisMaxQuery
298+makeArbitrary ''CommonTermsQuery
299+instance Arbitrary CommonTermsQuery where arbitrary = arbitraryCommonTermsQuery
300+makeArbitrary ''DistanceRange
301+instance Arbitrary DistanceRange where arbitrary = arbitraryDistanceRange
302+makeArbitrary ''MultiMatchQuery
303+instance Arbitrary MultiMatchQuery where arbitrary = arbitraryMultiMatchQuery
304+makeArbitrary ''LessThanD
305+instance Arbitrary LessThanD where arbitrary = arbitraryLessThanD
306+makeArbitrary ''LessThanEqD
307+instance Arbitrary LessThanEqD where arbitrary = arbitraryLessThanEqD
308+makeArbitrary ''GreaterThanD
309+instance Arbitrary GreaterThanD where arbitrary = arbitraryGreaterThanD
310+makeArbitrary ''GreaterThanEqD
311+instance Arbitrary GreaterThanEqD where arbitrary = arbitraryGreaterThanEqD
312+makeArbitrary ''LessThan
313+instance Arbitrary LessThan where arbitrary = arbitraryLessThan
314+makeArbitrary ''LessThanEq
315+instance Arbitrary LessThanEq where arbitrary = arbitraryLessThanEq
316+makeArbitrary ''GreaterThan
317+instance Arbitrary GreaterThan where arbitrary = arbitraryGreaterThan
318+makeArbitrary ''GreaterThanEq
319+instance Arbitrary GreaterThanEq where arbitrary = arbitraryGreaterThanEq
320+makeArbitrary ''GeoPoint
321+instance Arbitrary GeoPoint where arbitrary = arbitraryGeoPoint
322+makeArbitrary ''NullValue
323+instance Arbitrary NullValue where arbitrary = arbitraryNullValue
324+makeArbitrary ''MinimumMatchHighLow
325+instance Arbitrary MinimumMatchHighLow where arbitrary = arbitraryMinimumMatchHighLow
326+makeArbitrary ''CommonMinimumMatch
327+instance Arbitrary CommonMinimumMatch where arbitrary = arbitraryCommonMinimumMatch
328+makeArbitrary ''BoostingQuery
329+instance Arbitrary BoostingQuery where arbitrary = arbitraryBoostingQuery
330+makeArbitrary ''BoolQuery
331+instance Arbitrary BoolQuery where arbitrary = arbitraryBoolQuery
332+makeArbitrary ''MatchQuery
333+instance Arbitrary MatchQuery where arbitrary = arbitraryMatchQuery
334+makeArbitrary ''MultiMatchQueryType
335+instance Arbitrary MultiMatchQueryType where arbitrary = arbitraryMultiMatchQueryType
336+makeArbitrary ''BooleanOperator
337+instance Arbitrary BooleanOperator where arbitrary = arbitraryBooleanOperator
338+makeArbitrary ''ZeroTermsQuery
339+instance Arbitrary ZeroTermsQuery where arbitrary = arbitraryZeroTermsQuery
340+makeArbitrary ''MatchQueryType
341+instance Arbitrary MatchQueryType where arbitrary = arbitraryMatchQueryType
342+makeArbitrary ''SearchAliasRouting
343+instance Arbitrary SearchAliasRouting where arbitrary = arbitrarySearchAliasRouting
344+makeArbitrary ''ScoreType
345+instance Arbitrary ScoreType where arbitrary = arbitraryScoreType
346+makeArbitrary ''Distance
347+instance Arbitrary Distance where arbitrary = arbitraryDistance
348+makeArbitrary ''DistanceUnit
349+instance Arbitrary DistanceUnit where arbitrary = arbitraryDistanceUnit
350+makeArbitrary ''DistanceType
351+instance Arbitrary DistanceType where arbitrary = arbitraryDistanceType
352+makeArbitrary ''OptimizeBbox
353+instance Arbitrary OptimizeBbox where arbitrary = arbitraryOptimizeBbox
354+makeArbitrary ''GeoBoundingBoxConstraint
355+instance Arbitrary GeoBoundingBoxConstraint where arbitrary = arbitraryGeoBoundingBoxConstraint
356+makeArbitrary ''GeoFilterType
357+instance Arbitrary GeoFilterType where arbitrary = arbitraryGeoFilterType
358+makeArbitrary ''GeoBoundingBox
359+instance Arbitrary GeoBoundingBox where arbitrary = arbitraryGeoBoundingBox
360+makeArbitrary ''LatLon
361+instance Arbitrary LatLon where arbitrary = arbitraryLatLon
362+makeArbitrary ''RangeExecution
363+instance Arbitrary RangeExecution where arbitrary = arbitraryRangeExecution
364+makeArbitrary ''RegexpFlag
365+instance Arbitrary RegexpFlag where arbitrary = arbitraryRegexpFlag
366+makeArbitrary ''BoolMatch
367+instance Arbitrary BoolMatch where arbitrary = arbitraryBoolMatch
368+makeArbitrary ''Term
369+instance Arbitrary Term where arbitrary = arbitraryTerm
370+makeArbitrary ''IndexSettings
371+instance Arbitrary IndexSettings where arbitrary = arbitraryIndexSettings
372+makeArbitrary ''UpdatableIndexSetting
373+instance Arbitrary UpdatableIndexSetting where
374+ arbitrary = arbitraryUpdatableIndexSetting
375+makeArbitrary ''Bytes
376+instance Arbitrary Bytes where arbitrary = arbitraryBytes
377+makeArbitrary ''AllocationPolicy
378+instance Arbitrary AllocationPolicy where arbitrary = arbitraryAllocationPolicy
379+makeArbitrary ''InitialShardCount
380+instance Arbitrary InitialShardCount where arbitrary = arbitraryInitialShardCount
381+makeArbitrary ''FSType
382+instance Arbitrary FSType where arbitrary = arbitraryFSType
383+makeArbitrary ''CompoundFormat
384+instance Arbitrary CompoundFormat where arbitrary = arbitraryCompoundFormat
385+makeArbitrary ''FsSnapshotRepo
386+instance Arbitrary FsSnapshotRepo where arbitrary = arbitraryFsSnapshotRepo
387+makeArbitrary ''SnapshotRepoName
388+instance Arbitrary SnapshotRepoName where arbitrary = arbitrarySnapshotRepoName
389+makeArbitrary ''TemplateQueryInline
390+instance Arbitrary TemplateQueryInline where arbitrary = arbitraryTemplateQueryInline
391+makeArbitrary ''DirectGeneratorSuggestModeTypes
392+instance Arbitrary DirectGeneratorSuggestModeTypes where arbitrary = arbitraryDirectGeneratorSuggestModeTypes
393+makeArbitrary ''DirectGenerators
394+instance Arbitrary DirectGenerators where arbitrary = arbitraryDirectGenerators
395+makeArbitrary ''PhraseSuggesterCollate
396+instance Arbitrary PhraseSuggesterCollate where arbitrary = arbitraryPhraseSuggesterCollate
397+makeArbitrary ''PhraseSuggesterHighlighter
398+instance Arbitrary PhraseSuggesterHighlighter where arbitrary = arbitraryPhraseSuggesterHighlighter
399+makeArbitrary ''Size
400+instance Arbitrary Size where arbitrary = arbitrarySize
401+makeArbitrary ''PhraseSuggester
402+instance Arbitrary PhraseSuggester where arbitrary = arbitraryPhraseSuggester
403+makeArbitrary ''SuggestType
404+instance Arbitrary SuggestType where arbitrary = arbitrarySuggestType
405+makeArbitrary ''Suggest
406+instance Arbitrary Suggest where arbitrary = arbitrarySuggest
407+
408+
409+makeArbitrary ''Script
410+instance Arbitrary Script where arbitrary = arbitraryScript
411+
412+newtype UpdatableIndexSetting' =
413+ UpdatableIndexSetting' UpdatableIndexSetting
414+ deriving (Show, Eq, ToJSON, FromJSON, ApproxEq, Typeable)
415+
416+instance Arbitrary UpdatableIndexSetting' where
417+ arbitrary = do
418+ settings <- arbitrary
419+ return $ UpdatableIndexSetting' $ case settings of
420+ RoutingAllocationInclude xs ->
421+ RoutingAllocationInclude (dropDuplicateAttrNames xs)
422+ RoutingAllocationExclude xs ->
423+ RoutingAllocationExclude (dropDuplicateAttrNames xs)
424+ RoutingAllocationRequire xs ->
425+ RoutingAllocationRequire (dropDuplicateAttrNames xs)
426+ x -> x
427+ where
428+ dropDuplicateAttrNames =
429+ NE.fromList . L.nubBy sameAttrName . NE.toList
430+ sameAttrName a b =
431+ nodeAttrFilterName a == nodeAttrFilterName b
432+ -- shrink (UpdatableIndexSetting' x) = map UpdatableIndexSetting' (shrink x)
tests/Test/Highlights.hs → tests/V1/Test/Highlights.hsrenamed

The content is the same.

tests/Test/Import.hs → tests/V1/Test/Import.hsrenamed+2−2
@@ -23,7 +23,7 @@ import Data.Text as X (Text)
23import Data.Time.Calendar as X (Day(..), fromGregorian)
23import Data.Time.Calendar as X (Day(..), fromGregorian)
24import Data.Time.Clock as X
24import Data.Time.Clock as X
25import Data.Typeable as X
25import Data.Typeable as X
26−import Database.Bloodhound as X hiding (key)
26+import Database.V1.Bloodhound as X hiding (key)
27import Lens.Micro as X
27import Lens.Micro as X
28import Lens.Micro.Aeson as X
28import Lens.Micro.Aeson as X
29import Network.HTTP.Client as X hiding (Proxy, fileSize)
29import Network.HTTP.Client as X hiding (Proxy, fileSize)
@@ -31,7 +31,7 @@ import System.IO.Temp as X
31import System.PosixCompat.Files as X
31import System.PosixCompat.Files as X
32import Test.Hspec as X
32import Test.Hspec as X
33import Test.Hspec.QuickCheck as X (prop)
33import Test.Hspec.QuickCheck as X (prop)
34−import Test.QuickCheck as X hiding (Result, Success, isSuccess)
34+import Test.QuickCheck as X hiding (Result, Success)
35import Test.QuickCheck.Property.Monoid as X (T (..), eq, prop_Monoid)
35import Test.QuickCheck.Property.Monoid as X (T (..), eq, prop_Monoid)
36import Text.Pretty.Simple as X (pPrint)
36import Text.Pretty.Simple as X (pPrint)
37
37
tests/V1/Test/Indices.hsnew file+78
@@ -0,0 +1,78 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Indices where
4+
5+import Test.Common
6+import Test.Import
7+
8+import qualified Data.List as L
9+import qualified Data.List.NonEmpty as NE
10+
11+spec :: Spec
12+spec = do
13+ describe "Index create/delete API" $ do
14+ it "creates and then deletes the requested index" $ withTestEnv $ do
15+ -- priming state.
16+ _ <- deleteExampleIndex
17+ resp <- createExampleIndex
18+ deleteResp <- deleteExampleIndex
19+ liftIO $ do
20+ validateStatus resp 200
21+ validateStatus deleteResp 200
22+
23+ describe "Index aliases" $ do
24+ let aname = IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias")
25+ let alias = IndexAlias (testIndex) aname
26+ let create = IndexAliasCreate Nothing Nothing
27+ let action = AddAlias alias create
28+ it "handles the simple case of aliasing an existing index" $ do
29+ withTestEnv $ do
30+ resetIndex
31+ resp <- updateIndexAliases (action :| [])
32+ liftIO $ validateStatus resp 200
33+ let cleanup = withTestEnv (updateIndexAliases (RemoveAlias alias :| []))
34+ (do aliases <- withTestEnv getIndexAliases
35+ let expected = IndexAliasSummary alias create
36+ case aliases of
37+ Right (IndexAliasesSummary summs) ->
38+ L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected
39+ Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup
40+
41+ describe "Index Listing" $ do
42+ it "returns a list of index names" $ withTestEnv $ do
43+ _ <- createExampleIndex
44+ ixns <- listIndices
45+ liftIO (ixns `shouldContain` [testIndex])
46+
47+ describe "Index Settings" $ do
48+ it "persists settings" $ withTestEnv $ do
49+ _ <- deleteExampleIndex
50+ _ <- createExampleIndex
51+ let updates = BlocksWrite False :| []
52+ updateResp <- updateIndexSettings updates testIndex
53+ liftIO $ validateStatus updateResp 200
54+ getResp <- getIndexSettings testIndex
55+ liftIO $
56+ getResp `shouldBe` Right (IndexSettingsSummary
57+ testIndex
58+ (IndexSettings (ShardCount 1) (ReplicaCount 0))
59+ (NE.toList updates))
60+
61+ it "allows total fields to be set" $ when' (atleast es50) $ withTestEnv $ do
62+ _ <- deleteExampleIndex
63+ _ <- createExampleIndex
64+ let updates = FailOnMergeFailure True :| []
65+ updateResp <- updateIndexSettings updates testIndex
66+ liftIO $ validateStatus updateResp 200
67+ getResp <- getIndexSettings testIndex
68+ liftIO $
69+ getResp `shouldBe` Right (IndexSettingsSummary
70+ testIndex
71+ (IndexSettings (ShardCount 1) (ReplicaCount 0))
72+ (NE.toList updates))
73+
74+ describe "Index Optimization" $ do
75+ it "returns a successful response upon completion" $ withTestEnv $ do
76+ _ <- createExampleIndex
77+ resp <- optimizeIndex (IndexList (testIndex :| [])) defaultIndexOptimizationSettings
78+ liftIO $ validateStatus resp 200
tests/V1/Test/JSON.hsnew file+202
@@ -0,0 +1,202 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+
4+module Test.JSON (spec) where
5+
6+import Test.Import
7+
8+import qualified Data.ByteString.Lazy.Char8 as BL8
9+import qualified Data.List as L
10+import Data.List.NonEmpty (NonEmpty(..))
11+import qualified Data.List.NonEmpty as NE
12+import qualified Data.HashMap.Strict as HM
13+import qualified Data.Text as T
14+import qualified Data.Vector as V
15+
16+import Test.ApproxEq
17+import Test.Generators
18+
19+propJSON :: forall a
20+ . ( Arbitrary a
21+ , ToJSON a
22+ , FromJSON a
23+ , Show a
24+ , Eq a
25+ , Typeable a
26+ )
27+ => Proxy a -> Spec
28+propJSON _ = prop testName $ \(a :: a) ->
29+ let jsonStr = "via " <> BL8.unpack (encode a)
30+ in counterexample jsonStr (parseEither parseJSON (toJSON a)
31+ === Right a)
32+ where testName = show ty <> " FromJSON/ToJSON roundtrips"
33+ ty = typeOf (undefined :: a)
34+
35+propApproxJSON :: forall a
36+ . ( Arbitrary a
37+ , ToJSON a
38+ , FromJSON a
39+ , Show a
40+ , ApproxEq a
41+ , Typeable a
42+ )
43+ => Proxy a -> Spec
44+propApproxJSON _ = prop testName $ \(a :: a) ->
45+ let jsonStr = "via " <> BL8.unpack (encode a)
46+ in counterexample jsonStr (parseEither parseJSON (toJSON a)
47+ ==~ Right a)
48+ where testName = show ty <> " FromJSON/ToJSON roundtrips"
49+ ty = typeOf (undefined :: a)
50+
51+spec :: Spec
52+spec = do
53+ describe "ToJSON RegexpFlags" $ do
54+ it "generates the correct JSON for AllRegexpFlags" $
55+ toJSON AllRegexpFlags `shouldBe` String "ALL"
56+
57+ it "generates the correct JSON for NoRegexpFlags" $
58+ toJSON NoRegexpFlags `shouldBe` String "NONE"
59+
60+ it "generates the correct JSON for SomeRegexpFlags" $
61+ let flags = AnyString :| [ Automaton
62+ , Complement
63+ , Empty
64+ , Intersection
65+ , Interval ]
66+ in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
67+
68+ prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
69+ let String str = toJSON flags
70+ flagStrs = T.splitOn "|" str
71+ in noDuplicates flagStrs
72+
73+ describe "omitNulls" $ do
74+ it "checks that omitNulls drops list elements when it should" $
75+ let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
76+ , "test2" .= (toJSON ("some value" :: Text))]
77+ in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
78+
79+ it "checks that omitNulls doesn't drop list elements when it shouldn't" $
80+ let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
81+ , "test2" .= (toJSON ("some value" :: Text))]
82+ in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))
83+ , ("test2", String "some value")])
84+ it "checks that omitNulls drops non list elements when it should" $
85+ let dropped = omitNulls $ [ "test1" .= (toJSON Null)
86+ , "test2" .= (toJSON ("some value" :: Text))]
87+ in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
88+ it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
89+ let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
90+ , "test2" .= (toJSON ("some value" :: Text))]
91+ in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)
92+ , ("test2", String "some value")])
93+
94+ describe "Exact isomorphism JSON instances" $ do
95+ propJSON (Proxy :: Proxy Version)
96+ propJSON (Proxy :: Proxy IndexName)
97+ propJSON (Proxy :: Proxy MappingName)
98+ propJSON (Proxy :: Proxy DocId)
99+ propJSON (Proxy :: Proxy IndexAliasRouting)
100+ propJSON (Proxy :: Proxy RoutingValue)
101+ propJSON (Proxy :: Proxy ShardCount)
102+ propJSON (Proxy :: Proxy ReplicaCount)
103+ propJSON (Proxy :: Proxy TemplateName)
104+ propJSON (Proxy :: Proxy TemplatePattern)
105+ propJSON (Proxy :: Proxy QueryString)
106+ propJSON (Proxy :: Proxy FieldName)
107+ propJSON (Proxy :: Proxy CacheName)
108+ propJSON (Proxy :: Proxy CacheKey)
109+ propJSON (Proxy :: Proxy Existence)
110+ propJSON (Proxy :: Proxy CutoffFrequency)
111+ propJSON (Proxy :: Proxy Analyzer)
112+ propJSON (Proxy :: Proxy MaxExpansions)
113+ propJSON (Proxy :: Proxy Lenient)
114+ propJSON (Proxy :: Proxy Tiebreaker)
115+ propJSON (Proxy :: Proxy Boost)
116+ propJSON (Proxy :: Proxy BoostTerms)
117+ propJSON (Proxy :: Proxy MinimumMatch)
118+ propJSON (Proxy :: Proxy DisableCoord)
119+ propJSON (Proxy :: Proxy IgnoreTermFrequency)
120+ propJSON (Proxy :: Proxy MinimumTermFrequency)
121+ propJSON (Proxy :: Proxy MaxQueryTerms)
122+ propJSON (Proxy :: Proxy Fuzziness)
123+ propJSON (Proxy :: Proxy PrefixLength)
124+ propJSON (Proxy :: Proxy TypeName)
125+ propJSON (Proxy :: Proxy PercentMatch)
126+ propJSON (Proxy :: Proxy StopWord)
127+ propJSON (Proxy :: Proxy QueryPath)
128+ propJSON (Proxy :: Proxy AllowLeadingWildcard)
129+ propJSON (Proxy :: Proxy LowercaseExpanded)
130+ propJSON (Proxy :: Proxy EnablePositionIncrements)
131+ propJSON (Proxy :: Proxy AnalyzeWildcard)
132+ propJSON (Proxy :: Proxy GeneratePhraseQueries)
133+ propJSON (Proxy :: Proxy Locale)
134+ propJSON (Proxy :: Proxy MaxWordLength)
135+ propJSON (Proxy :: Proxy MinWordLength)
136+ propJSON (Proxy :: Proxy PhraseSlop)
137+ propJSON (Proxy :: Proxy MinDocFrequency)
138+ propJSON (Proxy :: Proxy MaxDocFrequency)
139+ propJSON (Proxy :: Proxy Filter)
140+ propJSON (Proxy :: Proxy Query)
141+ propJSON (Proxy :: Proxy SimpleQueryStringQuery)
142+ propJSON (Proxy :: Proxy FieldOrFields)
143+ propJSON (Proxy :: Proxy SimpleQueryFlag)
144+ propJSON (Proxy :: Proxy RegexpQuery)
145+ propJSON (Proxy :: Proxy QueryStringQuery)
146+ propJSON (Proxy :: Proxy RangeQuery)
147+ propJSON (Proxy :: Proxy PrefixQuery)
148+ propJSON (Proxy :: Proxy NestedQuery)
149+ propJSON (Proxy :: Proxy MoreLikeThisFieldQuery)
150+ propJSON (Proxy :: Proxy MoreLikeThisQuery)
151+ propJSON (Proxy :: Proxy IndicesQuery)
152+ propJSON (Proxy :: Proxy HasParentQuery)
153+ propJSON (Proxy :: Proxy HasChildQuery)
154+ propJSON (Proxy :: Proxy FuzzyQuery)
155+ propJSON (Proxy :: Proxy FuzzyLikeFieldQuery)
156+ propJSON (Proxy :: Proxy FuzzyLikeThisQuery)
157+ propJSON (Proxy :: Proxy DisMaxQuery)
158+ propJSON (Proxy :: Proxy CommonTermsQuery)
159+ propJSON (Proxy :: Proxy CommonMinimumMatch)
160+ propJSON (Proxy :: Proxy BoostingQuery)
161+ propJSON (Proxy :: Proxy BoolQuery)
162+ propJSON (Proxy :: Proxy MatchQuery)
163+ propJSON (Proxy :: Proxy MultiMatchQueryType)
164+ propJSON (Proxy :: Proxy BooleanOperator)
165+ propJSON (Proxy :: Proxy ZeroTermsQuery)
166+ propJSON (Proxy :: Proxy MatchQueryType)
167+ propJSON (Proxy :: Proxy AliasRouting)
168+ propJSON (Proxy :: Proxy IndexAliasCreate)
169+ propJSON (Proxy :: Proxy SearchAliasRouting)
170+ propJSON (Proxy :: Proxy ScoreType)
171+ propJSON (Proxy :: Proxy Distance)
172+ propJSON (Proxy :: Proxy DistanceUnit)
173+ propJSON (Proxy :: Proxy DistanceType)
174+ propJSON (Proxy :: Proxy OptimizeBbox)
175+ propJSON (Proxy :: Proxy GeoBoundingBoxConstraint)
176+ propJSON (Proxy :: Proxy GeoFilterType)
177+ propJSON (Proxy :: Proxy GeoBoundingBox)
178+ propJSON (Proxy :: Proxy LatLon)
179+ propJSON (Proxy :: Proxy RangeExecution)
180+ prop "RegexpFlags FromJSON/ToJSON roundtrips, removing dups " $ \rfs ->
181+ let expected = case rfs of
182+ SomeRegexpFlags fs -> SomeRegexpFlags (NE.fromList (L.nub (NE.toList fs)))
183+ x -> x
184+ in parseEither parseJSON (toJSON rfs) === Right expected
185+ propJSON (Proxy :: Proxy BoolMatch)
186+ propJSON (Proxy :: Proxy Term)
187+ propJSON (Proxy :: Proxy MultiMatchQuery)
188+ propJSON (Proxy :: Proxy IndexSettings)
189+ propJSON (Proxy :: Proxy CompoundFormat)
190+ propJSON (Proxy :: Proxy TemplateQueryInline)
191+ propJSON (Proxy :: Proxy Suggest)
192+ propJSON (Proxy :: Proxy DirectGenerators)
193+ propJSON (Proxy :: Proxy DirectGeneratorSuggestModeTypes)
194+
195+ describe "Approximate isomorphism JSON instances" $ do
196+ propApproxJSON (Proxy :: Proxy UpdatableIndexSetting')
197+ propApproxJSON (Proxy :: Proxy ReplicaCount)
198+ propApproxJSON (Proxy :: Proxy ReplicaBounds)
199+ propApproxJSON (Proxy :: Proxy Bytes)
200+ propApproxJSON (Proxy :: Proxy AllocationPolicy)
201+ propApproxJSON (Proxy :: Proxy InitialShardCount)
202+ propApproxJSON (Proxy :: Proxy FSType)
tests/V1/Test/Query.hsnew file+115
@@ -0,0 +1,115 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Query where
4+
5+import Test.Common
6+import Test.Import
7+
8+import qualified Data.HashMap.Strict as HM
9+
10+spec :: Spec
11+spec =
12+ describe "query API" $ do
13+ it "returns document for term query and identity filter" $ withTestEnv $ do
14+ _ <- insertData
15+ let query = TermQuery (Term "user" "bitemyapp") Nothing
16+ let filter' = IdentityFilter
17+ let search = mkSearch (Just query) (Just filter')
18+ myTweet <- searchTweet search
19+ liftIO $
20+ myTweet `shouldBe` Right exampleTweet
21+
22+ it "handles constant score queries" $ withTestEnv $ do
23+ _ <- insertData
24+ let query = TermsQuery "user" ("bitemyapp" :| [])
25+ let cfQuery = ConstantScoreQuery query (Boost 1.0)
26+ let filter' = IdentityFilter
27+ let search = mkSearch (Just cfQuery) (Just filter')
28+ myTweet <- searchTweet search
29+ liftIO $
30+ myTweet `shouldBe` Right exampleTweet
31+
32+ it "returns document for terms query and identity filter" $ withTestEnv $ do
33+ _ <- insertData
34+ let query = TermsQuery "user" ("bitemyapp" :| [])
35+ let filter' = IdentityFilter
36+ let search = mkSearch (Just query) (Just filter')
37+ myTweet <- searchTweet search
38+ liftIO $
39+ myTweet `shouldBe` Right exampleTweet
40+
41+ it "returns document for match query" $ withTestEnv $ do
42+ _ <- insertData
43+ let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
44+ let search = mkSearch (Just query) Nothing
45+ myTweet <- searchTweet search
46+ liftIO $
47+ myTweet `shouldBe` Right exampleTweet
48+
49+ it "returns document for multi-match query" $ withTestEnv $ do
50+ _ <- insertData
51+ let flds = [FieldName "user", FieldName "message"]
52+ let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
53+ let search = mkSearch (Just query) Nothing
54+ myTweet <- searchTweet search
55+ liftIO $
56+ myTweet `shouldBe` Right exampleTweet
57+
58+ it "returns document for multi-match query with a custom tiebreaker" $ withTestEnv $ do
59+ _ <- insertData
60+ let tiebreaker = Just $ Tiebreaker 0.3
61+ flds = [FieldName "user", FieldName "message"]
62+ multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")
63+ query = QueryMultiMatchQuery $ multiQuery' { multiMatchQueryTiebreaker = tiebreaker }
64+ search = mkSearch (Just query) Nothing
65+ myTweet <- searchTweet search
66+ liftIO $
67+ myTweet `shouldBe` Right exampleTweet
68+
69+ it "returns document for bool query" $ withTestEnv $ do
70+ _ <- insertData
71+ let innerQuery = QueryMatchQuery $
72+ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
73+ let query = QueryBoolQuery $
74+ mkBoolQuery [innerQuery] [] []
75+ let search = mkSearch (Just query) Nothing
76+ myTweet <- searchTweet search
77+ liftIO $
78+ myTweet `shouldBe` Right exampleTweet
79+
80+ it "returns document for boosting query" $ withTestEnv $ do
81+ _ <- insertData
82+ let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
83+ let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
84+ let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
85+ let search = mkSearch (Just query) Nothing
86+ myTweet <- searchTweet search
87+ liftIO $
88+ myTweet `shouldBe` Right exampleTweet
89+
90+ it "returns document for common terms query" $ withTestEnv $ do
91+ _ <- insertData
92+ let query = QueryCommonTermsQuery $
93+ CommonTermsQuery (FieldName "user")
94+ (QueryString "bitemyapp")
95+ (CutoffFrequency 0.0001)
96+ Or Or Nothing Nothing Nothing Nothing
97+ let search = mkSearch (Just query) Nothing
98+ myTweet <- searchTweet search
99+ liftIO $
100+ myTweet `shouldBe` Right exampleTweet
101+
102+ it "returns document for for inline template query" $ withTestEnv $ do
103+ _ <- insertData
104+ let innerQuery = QueryMatchQuery $
105+ mkMatchQuery (FieldName "{{userKey}}")
106+ (QueryString "{{bitemyappKey}}")
107+ templateParams = TemplateQueryKeyValuePairs $ HM.fromList
108+ [ ("userKey", "user")
109+ , ("bitemyappKey", "bitemyapp")
110+ ]
111+ templateQuery = QueryTemplateQueryInline $
112+ TemplateQueryInline innerQuery templateParams
113+ search = mkSearch (Just templateQuery) Nothing
114+ myTweet <- searchTweet search
115+ liftIO $ myTweet `shouldBe` Right exampleTweet
tests/Test/Snapshots.hs → tests/V1/Test/Snapshots.hsrenamed

The content is the same.

tests/V1/Test/Sorting.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Sorting where
4+
5+import Test.Common
6+import Test.Import
7+
8+spec :: Spec
9+spec =
10+ describe "sorting" $
11+ it "returns documents in the right order" $ withTestEnv $ do
12+ _ <- insertData
13+ _ <- insertOther
14+ let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
15+ let search = Search Nothing
16+ Nothing (Just [sortSpec]) Nothing Nothing
17+ False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
18+ Nothing
19+ result <- searchTweets search
20+ let myTweet = grabFirst result
21+ liftIO $
22+ myTweet `shouldBe` Right otherTweet
tests/Test/SourceFiltering.hs → tests/V1/Test/SourceFiltering.hsrenamed

The content is the same.

tests/V1/Test/Suggest.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Suggest where
4+
5+import Test.Common
6+import Test.Import
7+
8+spec :: Spec
9+spec =
10+ describe "Suggest" $
11+ it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do
12+ _ <- insertData
13+ let phraseSuggester = mkPhraseSuggester (FieldName "message")
14+ namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
15+ search' = mkSearch Nothing Nothing
16+ search = search' { suggestBody = Just namedSuggester }
17+ expectedText = Just "use haskell"
18+ resp <- searchByIndex testIndex search
19+ parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))
20+ case parsed of
21+ Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)
22+ Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText
tests/Test/Templates.hs → tests/V1/Test/Templates.hsrenamed

The content is the same.

tests/V1/tests.hsnew file+117
@@ -0,0 +1,117 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeOperators #-}
7+{-# OPTIONS_GHC -fno-warn-orphans #-}
8+#if __GLASGOW_HASKELL__ < 800
9+{-# OPTIONS_GHC -fcontext-stack=100 #-}
10+#endif
11+#if __GLASGOW_HASKELL__ >= 802
12+{-# LANGUAGE MonoLocalBinds #-}
13+#endif
14+module Main where
15+
16+import Test.Common
17+import Test.Import
18+
19+import Prelude
20+
21+import qualified Test.Aggregation as Aggregation
22+import qualified Test.BulkAPI as Bulk
23+import qualified Test.Documents as Documents
24+import qualified Test.Highlights as Highlights
25+import qualified Test.Indices as Indices
26+import qualified Test.JSON as JSON
27+import qualified Test.Query as Query
28+import qualified Test.Snapshots as Snapshots
29+import qualified Test.Sorting as Sorting
30+import qualified Test.SourceFiltering as SourceFiltering
31+import qualified Test.Suggest as Suggest
32+import qualified Test.Templates as Templates
33+
34+main :: IO ()
35+main = hspec $ do
36+ Aggregation.spec
37+ Bulk.spec
38+ Documents.spec
39+ Highlights.spec
40+ Indices.spec
41+ JSON.spec
42+ Query.spec
43+ Snapshots.spec
44+ Sorting.spec
45+ SourceFiltering.spec
46+ Suggest.spec
47+ Templates.spec
48+
49+ describe "error parsing" $ do
50+ it "can parse EsErrors for < 2.0" $ when' (atmost es16) $ withTestEnv $ do
51+ res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
52+ let errorResp = eitherDecode (responseBody res)
53+ liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]"))
54+
55+ it "can parse EsErrors for >= 2.0" $ when' (atleast es20) $ withTestEnv $ do
56+ res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
57+ let errorResp = eitherDecode (responseBody res)
58+ liftIO (errorResp `shouldBe` Right (EsError 404 "no such index"))
59+
60+ describe "Monoid (SearchHits a)" $
61+ prop "abides the monoid laws" $ eq $
62+ prop_Monoid (T :: T (SearchHits ()))
63+
64+ describe "mkDocVersion" $
65+ prop "can never construct an out of range docVersion" $ \i ->
66+ let res = mkDocVersion i
67+ in case res of
68+ Nothing -> property True
69+ Just dv -> (dv >= minBound) .&&.
70+ (dv <= maxBound) .&&.
71+ docVersionNumber dv === i
72+
73+ describe "getNodesInfo" $
74+ it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
75+ res <- getNodesInfo LocalNode
76+ liftIO $ case res of
77+ -- This is really just a smoke test for response
78+ -- parsing. Node info is so variable, there's not much I can
79+ -- assert here.
80+ Right NodesInfo {..} -> length nodesInfo `shouldBe` 1
81+ Left e -> expectationFailure ("Expected NodesInfo but got " <> show e)
82+
83+ describe "getNodesStats" $
84+ it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
85+ res <- getNodesStats LocalNode
86+ liftIO $ case res of
87+ -- This is really just a smoke test for response
88+ -- parsing. Node stats is so variable, there's not much I can
89+ -- assert here.
90+ Right NodesStats {..} -> length nodesStats `shouldBe` 1
91+ Left e -> expectationFailure ("Expected NodesStats but got " <> show e)
92+
93+ describe "Enum DocVersion" $
94+ it "follows the laws of Enum, Bounded" $ do
95+ evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
96+ evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
97+ evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
98+ evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
99+ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
100+ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
101+ enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
102+
103+ describe "Scan & Scroll API" $
104+ it "returns documents using the scan&scroll API" $ withTestEnv $ do
105+ _ <- insertData
106+ _ <- insertOther
107+ let search =
108+ (mkSearch
109+ (Just $ MatchAllQuery Nothing) Nothing)
110+ { size = Size 1 }
111+ regular_search <- searchTweet search
112+ scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]
113+ let scan_search = map hitSource scan_search'
114+ liftIO $
115+ regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
116+ liftIO $
117+ scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]
tests/Test/Aggregation.hs → tests/V5/Test/Aggregation.hsrenamed+3−3
@@ -7,7 +7,7 @@ import Test.Import
7
7
8import Control.Error (fmapL, note)
8import Control.Error (fmapL, note)
9import qualified Data.Map as M
9import qualified Data.Map as M
10−import qualified Database.Bloodhound
10+import qualified Database.V5.Bloodhound
11
11
12spec :: Spec
12spec :: Spec
13spec =
13spec =
@@ -35,7 +35,7 @@ spec =
35 _ <- insertData
35 _ <- insertData
36 let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user"
36 let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user"
37 let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality
37 let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality
38− let search' = search { Database.Bloodhound.from = From 0, size = Size 0 }
38+ let search' = search { Database.V5.Bloodhound.from = From 0, size = Size 0 }
39 searchExpectAggs search'
39 searchExpectAggs search'
40 let docCountPair k n = (k, object ["value" .= Number n])
40 let docCountPair k n = (k, object ["value" .= Number n])
41 res <- searchTweets search'
41 res <- searchTweets search'
@@ -46,7 +46,7 @@ spec =
46 _ <- insertData
46 _ <- insertData
47 let stats = StatsAgg $ mkStatsAggregation $ FieldName "age"
47 let stats = StatsAgg $ mkStatsAggregation $ FieldName "age"
48 let search = mkAggregateSearch Nothing $ mkAggregations "users" stats
48 let search = mkAggregateSearch Nothing $ mkAggregations "users" stats
49− let search' = search { Database.Bloodhound.from = From 0, size = Size 0 }
49+ let search' = search { Database.V5.Bloodhound.from = From 0, size = Size 0 }
50 searchExpectAggs search'
50 searchExpectAggs search'
51 let statsAggRes k n = (k, object [ "max" .= Number n
51 let statsAggRes k n = (k, object [ "max" .= Number n
52 , "avg" .= Number n
52 , "avg" .= Number n
tests/V5/Test/ApproxEq.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+module Test.ApproxEq where
5+
6+import Database.V5.Bloodhound
7+
8+import Test.Import
9+
10+import qualified Data.List.NonEmpty as NE
11+
12+-- | Typeclass for "equal where it matters". Use this to specify
13+-- less-strict equivalence for things such as lists that can wind up
14+-- in an unpredictable order
15+class ApproxEq a where
16+ (=~) :: a -> a -> Bool
17+
18+ showApproxEq :: a -> String
19+ default showApproxEq :: (Show a) => a -> String
20+ showApproxEq = show
21+
22+(==~) :: (ApproxEq a) => a -> a -> Property
23+a ==~ b = counterexample (showApproxEq a ++ " !=~ " ++ showApproxEq b) (a =~ b)
24+
25+instance ApproxEq NominalDiffTime where (=~) = (==)
26+instance ApproxEq Bool where (=~) = (==)
27+instance ApproxEq Int where (=~) = (==)
28+instance (Eq a, Show a) => ApproxEq (Maybe a) where (=~) = (==)
29+instance ApproxEq Char where
30+ (=~) = (==)
31+
32+instance ApproxEq NodeAttrFilter where (=~) = (==)
33+instance ApproxEq NodeAttrName where (=~) = (==)
34+instance (Eq a, Show a) => ApproxEq (NonEmpty a) where (=~) = (==)
35+instance (ApproxEq l, Show l, ApproxEq r, Show r) => ApproxEq (Either l r) where
36+ Left a =~ Left b = a =~ b
37+ Right a =~ Right b = a =~ b
38+ _ =~ _ = False
39+ showApproxEq (Left x) = "Left " <> showApproxEq x
40+ showApproxEq (Right x) = "Right " <> showApproxEq x
41+instance (ApproxEq a, Show a) => ApproxEq [a] where
42+ as =~ bs = and (zipWith (=~) as bs)
43+instance ApproxEq ReplicaCount where (=~) = (==)
44+instance ApproxEq ReplicaBounds where (=~) = (==)
45+instance ApproxEq Bytes where (=~) = (==)
46+instance ApproxEq AllocationPolicy where (=~) = (==)
47+instance ApproxEq InitialShardCount where (=~) = (==)
48+instance ApproxEq FSType where (=~) = (==)
49+
50+-- | Due to the way nodeattrfilters get serialized here, they may come
51+-- out in a different order, but they are morally equivalent
52+instance ApproxEq UpdatableIndexSetting where
53+ RoutingAllocationInclude a =~ RoutingAllocationInclude b =
54+ NE.sort a =~ NE.sort b
55+ RoutingAllocationExclude a =~ RoutingAllocationExclude b =
56+ NE.sort a =~ NE.sort b
57+ RoutingAllocationRequire a =~ RoutingAllocationRequire b =
58+ NE.sort a =~ NE.sort b
59+ a =~ b = a == b
60+ showApproxEq (RoutingAllocationInclude xs) = show (RoutingAllocationInclude (NE.sort xs))
61+ showApproxEq (RoutingAllocationExclude xs) = show (RoutingAllocationExclude (NE.sort xs))
62+ showApproxEq (RoutingAllocationRequire xs) = show (RoutingAllocationRequire (NE.sort xs))
63+ showApproxEq x = show x
tests/Test/BulkAPI.hs → tests/V5/Test/BulkAPI.hsrenamed

The content is the same.

tests/Test/Common.hs → tests/V5/Test/Common.hsrenamed

The content is the same.

tests/Test/Documents.hs → tests/V5/Test/Documents.hsrenamed

The content is the same.

tests/Test/Generators.hs → tests/V5/Test/Generators.hsrenamed+4−9
@@ -5,7 +5,7 @@
5
5
6module Test.Generators where
6module Test.Generators where
7
7
8−import Database.Bloodhound
8+import Database.V5.Bloodhound
9
9
10import Test.Import
10import Test.Import
11
11
@@ -55,7 +55,6 @@ instance (Arbitrary a, Typeable a) => Arbitrary (Hit a) where
55 <*> arbitrary
55 <*> arbitrary
56 <*> arbitraryScore
56 <*> arbitraryScore
57 <*> arbitrary
57 <*> arbitrary
58− <*> return Nothing
59 <*> arbitrary
58 <*> arbitrary
60 <*> arbitrary
59 <*> arbitrary
61
60
@@ -184,7 +183,7 @@ instance Arbitrary Query where
184
183
185instance Arbitrary Filter where
184instance Arbitrary Filter where
186 arbitrary =
185 arbitrary =
187− Filter <$> arbitrary
186+ Filter <$> arbitrary
188 shrink (Filter q) =
187 shrink (Filter q) =
189 Filter <$> shrink q
188 Filter <$> shrink q
190
189
@@ -211,13 +210,9 @@ instance Arbitrary NodeAttrName where
211instance Arbitrary NodeAttrFilter where
210instance Arbitrary NodeAttrFilter where
212 arbitrary = do
211 arbitrary = do
213 n <- arbitrary
212 n <- arbitrary
214− xs <- listOf1 (listOf1 arbitraryAlphaNum)
213+ s:ss <- listOf1 (listOf1 arbitraryAlphaNum)
215− let (s, ss) = unpackConsPartial xs
216− ts = T.pack <$> s :| ss
214+ let ts = T.pack <$> s :| ss
217 return (NodeAttrFilter n ts)
215 return (NodeAttrFilter n ts)
218− where -- listOf1 means this shouldn't blow up.
219− unpackConsPartial (x : xs) = (x, xs)
220− unpackConsPartial _ = error "unpackConsPartial failed but shouldn't have"
221
216
222instance Arbitrary VersionNumber where
217instance Arbitrary VersionNumber where
223 arbitrary = do
218 arbitrary = do
tests/V5/Test/Highlights.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Highlights where
4+
5+import Test.Common
6+import Test.Import
7+
8+import qualified Data.Map as M
9+
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+
19+spec :: Spec
20+spec =
21+ describe "Highlights API" $ do
22+ it "returns highlight from query when there should be one" $ withTestEnv $ do
23+ myHighlight <- initHighlights "message"
24+ liftIO $
25+ myHighlight `shouldBe`
26+ Right (Just (M.fromList [("message", ["Use <em>haskell</em>!"])]))
27+
28+ it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do
29+ myHighlight <- initHighlights "user"
30+ liftIO $
31+ myHighlight `shouldBe`
32+ Right Nothing
tests/V5/Test/Import.hsnew file+58
@@ -0,0 +1,58 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Import
4+ ( module X
5+ , module Test.Import
6+ ) where
7+
8+
9+import Control.Applicative as X
10+import Control.Exception as X (evaluate)
11+import Control.Monad as X
12+import Control.Monad.Catch as X
13+import Control.Monad.Reader as X
14+import Data.Aeson as X
15+import Data.Aeson.TH as X
16+import Data.Aeson.Types as X (parseEither)
17+import Data.Maybe as X
18+import Data.List.NonEmpty as X (NonEmpty(..))
19+import Data.Monoid as X
20+import Data.Ord as X (comparing)
21+import Data.Proxy as X
22+import Data.Text as X (Text)
23+import Data.Time.Calendar as X (Day(..), fromGregorian)
24+import Data.Time.Clock as X
25+import Data.Typeable as X
26+import Database.V5.Bloodhound as X hiding (key)
27+import Lens.Micro as X
28+import Lens.Micro.Aeson as X
29+import Network.HTTP.Client as X hiding (Proxy, fileSize)
30+import System.IO.Temp as X
31+import System.PosixCompat.Files as X
32+import Test.Hspec as X
33+import Test.Hspec.QuickCheck as X (prop)
34+import Test.QuickCheck as X hiding (Result, Success)
35+import Test.QuickCheck.Property.Monoid as X (T (..), eq, prop_Monoid)
36+import Text.Pretty.Simple as X (pPrint)
37+
38+import qualified Data.List as L
39+
40+noDuplicates :: Eq a => [a] -> Bool
41+noDuplicates xs = L.nub xs == xs
42+
43+getSource :: EsResult a -> Maybe a
44+getSource = fmap _source . foundResult
45+
46+grabFirst :: Either EsError (SearchResult a) -> Either EsError a
47+grabFirst r =
48+ case fmap (hitSource . head . hits . searchHits) r of
49+ (Left e) -> Left e
50+ (Right Nothing) -> Left (EsError 500 "Source was missing")
51+ (Right (Just x)) -> Right x
52+
53+when' :: Monad m => m Bool -> m () -> m ()
54+when' b f = b >>= \x -> when x f
55+
56+headMay :: [a] -> Maybe a
57+headMay (x : _) = Just x
58+headMay _ = Nothing
tests/Test/Indices.hs → tests/V5/Test/Indices.hsrenamed

The content is the same.

tests/Test/JSON.hs → tests/V5/Test/JSON.hsrenamed

The content is the same.

tests/Test/Query.hs → tests/V5/Test/Query.hsrenamed−9
@@ -46,15 +46,6 @@ spec =
46 liftIO $
46 liftIO $
47 myTweet `shouldBe` Right exampleTweet
47 myTweet `shouldBe` Right exampleTweet
48
48
49− it "returns document for match query with fuzziness" $ withTestEnv $ do
50− _ <- insertData
51− let match = mkMatchQuery (FieldName "user") (QueryString "bidemyapp")
52− let query = QueryMatchQuery $ match { matchQueryFuzziness = Just FuzzinessAuto }
53− let search = mkSearch (Just query) Nothing
54− myTweet <- searchTweet search
55− liftIO $
56− myTweet `shouldBe` Right exampleTweet
57−
58 it "returns document for multi-match query" $ withTestEnv $ do
49 it "returns document for multi-match query" $ withTestEnv $ do
59 _ <- insertData
50 _ <- insertData
60 let flds = [FieldName "user", FieldName "message"]
51 let flds = [FieldName "user", FieldName "message"]
tests/Test/Script.hs → tests/V5/Test/Script.hsrenamed

The content is the same.

tests/V5/Test/Snapshots.hsnew file+201
@@ -0,0 +1,201 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+module Test.Snapshots (spec) where
5+
6+import Test.Common
7+import Test.Import
8+
9+import Data.Maybe (fromMaybe)
10+import qualified Data.List as L
11+import qualified Data.HashMap.Strict as HM
12+import qualified Data.Text as T
13+import qualified Data.Vector as V
14+import qualified Network.HTTP.Types.Method as NHTM
15+import qualified Network.URI as URI
16+
17+import Test.Generators ()
18+
19+spec :: Spec
20+spec = do
21+ describe "FsSnapshotRepo" $
22+ prop "SnapshotRepo laws" $ \fsr ->
23+ fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)
24+
25+ describe "Snapshot repos" $ do
26+ it "always parses all snapshot repos API" $ when' canSnapshot $ withTestEnv $ do
27+ res <- getSnapshotRepos AllSnapshotRepos
28+ liftIO $ case res of
29+ Left e -> expectationFailure ("Expected a right but got Left " <> show e)
30+ Right _ -> return ()
31+
32+ it "finds an existing list of repos" $ when' canSnapshot $ withTestEnv $ do
33+ let r1n = SnapshotRepoName "bloodhound-repo1"
34+ let r2n = SnapshotRepoName "bloodhound-repo2"
35+ withSnapshotRepo r1n $ \r1 ->
36+ withSnapshotRepo r2n $ \r2 -> do
37+ repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))
38+ liftIO $ case repos of
39+ Right xs -> do
40+ let srt = L.sortBy (comparing gSnapshotRepoName)
41+ srt xs `shouldBe` srt [r1, r2]
42+ Left e -> expectationFailure (show e)
43+
44+ it "creates and updates with updateSnapshotRepo" $ when' canSnapshot $ withTestEnv $ do
45+ let r1n = SnapshotRepoName "bloodhound-repo1"
46+ withSnapshotRepo r1n $ \r1 -> do
47+ let Just (String dir) = HM.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))
48+ let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing
49+ resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression
50+ liftIO (validateStatus resp 200)
51+ Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))
52+ liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)
53+
54+ -- verify came around in 1.4 it seems
55+ it "can verify existing repos" $ when' canSnapshot $ when' (atleast es14) $ withTestEnv $ do
56+ let r1n = SnapshotRepoName "bloodhound-repo1"
57+ withSnapshotRepo r1n $ \_ -> do
58+ res <- verifySnapshotRepo r1n
59+ liftIO $ case res of
60+ Right (SnapshotVerification vs)
61+ | null vs -> expectationFailure "Expected nonempty set of verifying nodes"
62+ | otherwise -> return ()
63+ Left e -> expectationFailure (show e)
64+
65+ describe "Snapshots" $ do
66+ it "always parses all snapshots API" $ when' canSnapshot $ withTestEnv $ do
67+ let r1n = SnapshotRepoName "bloodhound-repo1"
68+ withSnapshotRepo r1n $ \_ -> do
69+ res <- getSnapshots r1n AllSnapshots
70+ liftIO $ case res of
71+ Left e -> expectationFailure ("Expected a right but got Left " <> show e)
72+ Right _ -> return ()
73+
74+ it "can parse a snapshot that it created" $ when' canSnapshot $ withTestEnv $ do
75+ let r1n = SnapshotRepoName "bloodhound-repo1"
76+ withSnapshotRepo r1n $ \_ -> do
77+ let s1n = SnapshotName "example-snapshot"
78+ withSnapshot r1n s1n $ do
79+ res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))
80+ liftIO $ case res of
81+ Right [snap]
82+ | snapInfoState snap == SnapshotSuccess &&
83+ snapInfoName snap == s1n -> return ()
84+ | otherwise -> expectationFailure (show snap)
85+ Right [] -> expectationFailure "There were no snapshots"
86+ Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))
87+ Left e -> expectationFailure (show e)
88+
89+ describe "Snapshot restore" $ do
90+ it "can restore a snapshot that we create" $ when' canSnapshot $ withTestEnv $ do
91+ let r1n = SnapshotRepoName "bloodhound-repo1"
92+ withSnapshotRepo r1n $ \_ -> do
93+ let s1n = SnapshotName "example-snapshot"
94+ withSnapshot r1n s1n $ do
95+ let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True }
96+ -- have to close an index to restore it
97+ resp1 <- closeIndex testIndex
98+ liftIO (validateStatus resp1 200)
99+ resp2 <- restoreSnapshot r1n s1n settings
100+ liftIO (validateStatus resp2 200)
101+
102+ it "can restore and rename" $ when' canSnapshot $ withTestEnv $ do
103+ let r1n = SnapshotRepoName "bloodhound-repo1"
104+ withSnapshotRepo r1n $ \_ -> do
105+ let s1n = SnapshotName "example-snapshot"
106+ withSnapshot r1n s1n $ do
107+ let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"
108+ let replace = RRTLit "restored-" :| [RRSubWholeMatch]
109+ let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"
110+ oldEnoughForOverrides <- liftIO (atleast es15)
111+ let overrides = RestoreIndexSettings { restoreOverrideReplicas = Just (ReplicaCount 0) }
112+ let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True
113+ , snapRestoreRenamePattern = Just pat
114+ , snapRestoreRenameReplacement = Just replace
115+ , snapRestoreIndexSettingsOverrides = if oldEnoughForOverrides
116+ then Just overrides
117+ else Nothing
118+ }
119+ -- have to close an index to restore it
120+ let go = do
121+ resp <- restoreSnapshot r1n s1n settings
122+ liftIO (validateStatus resp 200)
123+ exists <- indexExists expectedIndex
124+ liftIO (exists `shouldBe` True)
125+ go `finally` deleteIndex expectedIndex
126+
127+-- | Get configured repo paths for snapshotting. Note that by default
128+-- this is not enabled and if we are over es 1.5, we won't be able to
129+-- test snapshotting. Note that this can and should be part of the
130+-- client functionality in a much less ad-hoc incarnation.
131+getRepoPaths :: IO [FilePath]
132+getRepoPaths = withTestEnv $ do
133+ bhe <- getBHEnv
134+ let Server s = bhServer bhe
135+ let tUrl = s <> "/" <> "_nodes"
136+ initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl))
137+ let req = setRequestIgnoreStatus $ initReq { method = NHTM.methodGet }
138+ Right (Object o) <- parseEsResponse =<< liftIO (httpLbs req (bhManager bhe))
139+ return $ fromMaybe mempty $ do
140+ Object nodes <- HM.lookup "nodes" o
141+ Object firstNode <- snd <$> headMay (HM.toList nodes)
142+ Object settings <- HM.lookup "settings" firstNode
143+ Object path <- HM.lookup "path" settings
144+ Array repo <- HM.lookup "repo" path
145+ return [ T.unpack t | String t <- V.toList repo]
146+
147+-- | 1.5 and earlier don't care about repo paths
148+canSnapshot :: IO Bool
149+canSnapshot = do
150+ caresAboutRepos <- atleast es16
151+ repoPaths <- getRepoPaths
152+ return (not caresAboutRepos || not (null repoPaths))
153+
154+withSnapshotRepo
155+ :: ( MonadMask m
156+ , MonadBH m
157+ )
158+ => SnapshotRepoName
159+ -> (GenericSnapshotRepo -> m a)
160+ -> m a
161+withSnapshotRepo srn@(SnapshotRepoName n) f = do
162+ repoPaths <- liftIO getRepoPaths
163+ -- we'll use the first repo path if available, otherwise system temp
164+ -- dir. Note that this will fail on ES > 1.6, so be sure you use
165+ -- @when' canSnapshot@.
166+ case repoPaths of
167+ (firstRepoPath:_) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f
168+ [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f
169+ where
170+ alloc dir = do
171+ liftIO (setFileMode dir mode)
172+ let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing
173+ resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo
174+ liftIO (validateStatus resp 200)
175+ return (toGSnapshotRepo repo)
176+ mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes
177+ free GenericSnapshotRepo {..} = do
178+ resp <- deleteSnapshotRepo gSnapshotRepoName
179+ liftIO (validateStatus resp 200)
180+
181+
182+withSnapshot
183+ :: ( MonadMask m
184+ , MonadBH m
185+ )
186+ => SnapshotRepoName
187+ -> SnapshotName
188+ -> m a
189+ -> m a
190+withSnapshot srn sn = bracket_ alloc free
191+ where
192+ alloc = do
193+ resp <- createSnapshot srn sn createSettings
194+ liftIO (validateStatus resp 200)
195+ -- We'll make this synchronous for testing purposes
196+ createSettings = defaultSnapshotCreateSettings { snapWaitForCompletion = True
197+ , snapIndices = Just (IndexList (testIndex :| []))
198+ -- We don't actually need to back up any data
199+ }
200+ free =
201+ deleteSnapshot srn sn
tests/Test/Sorting.hs → tests/V5/Test/Sorting.hsrenamed+1−1
@@ -14,7 +14,7 @@ spec =
14 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
14 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
15 let search = Search Nothing
15 let search = Search Nothing
16 Nothing (Just [sortSpec]) Nothing Nothing
16 Nothing (Just [sortSpec]) Nothing Nothing
17− False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
17+ False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
18 Nothing Nothing
18 Nothing Nothing
19 result <- searchTweets search
19 result <- searchTweets search
20 let myTweet = grabFirst result
20 let myTweet = grabFirst result
tests/V5/Test/SourceFiltering.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.SourceFiltering where
4+
5+import Test.Common
6+import Test.Import
7+
8+import qualified Data.HashMap.Strict as HM
9+
10+spec :: Spec
11+spec =
12+ describe "Source filtering" $ do
13+
14+ it "doesn't include source when sources are disabled" $ withTestEnv $
15+ searchExpectSource
16+ NoSource
17+ (Left (EsError 500 "Source was missing"))
18+
19+ it "includes a source" $ withTestEnv $
20+ searchExpectSource
21+ (SourcePatterns (PopPattern (Pattern "message")))
22+ (Right (Object (HM.fromList [("message", String "Use haskell!")])))
23+
24+ it "includes sources" $ withTestEnv $
25+ searchExpectSource
26+ (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))
27+ (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))
28+
29+ it "includes source patterns" $ withTestEnv $
30+ searchExpectSource
31+ (SourcePatterns (PopPattern (Pattern "*ge")))
32+ (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))
33+
34+ it "excludes source patterns" $ withTestEnv $
35+ searchExpectSource
36+ (SourceIncludeExclude (Include [])
37+ (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"]))
38+ (Right (Object (HM.fromList [("user",String "bitemyapp")])))
tests/Test/Suggest.hs → tests/V5/Test/Suggest.hsrenamed

The content is the same.

tests/V5/Test/Templates.hsnew file+26
@@ -0,0 +1,26 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Templates where
4+
5+import Test.Common
6+import Test.Import
7+
8+spec :: Spec
9+spec =
10+ describe "template API" $ do
11+ it "can create a template" $ withTestEnv $ do
12+ let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
13+ resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
14+ liftIO $ validateStatus resp 200
15+
16+ it "can detect if a template exists" $ withTestEnv $ do
17+ exists <- templateExists (TemplateName "tweet-tpl")
18+ liftIO $ exists `shouldBe` True
19+
20+ it "can delete a template" $ withTestEnv $ do
21+ resp <- deleteTemplate (TemplateName "tweet-tpl")
22+ liftIO $ validateStatus resp 200
23+
24+ it "can detect if a template doesn't exist" $ withTestEnv $ do
25+ exists <- templateExists (TemplateName "tweet-tpl")
26+ liftIO $ exists `shouldBe` False
tests/tests.hs → tests/V5/tests.hsrenamed−17
@@ -18,7 +18,6 @@ import Test.Import
18
18
19import Prelude
19import Prelude
20
20
21−import qualified Data.Aeson as Aeson
22import qualified Test.Aggregation as Aggregation
21import qualified Test.Aggregation as Aggregation
23import qualified Test.BulkAPI as Bulk
22import qualified Test.BulkAPI as Bulk
24import qualified Test.Documents as Documents
23import qualified Test.Documents as Documents
@@ -118,19 +117,3 @@ main = hspec $ do
118 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
117 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
119 liftIO $
118 liftIO $
120 scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]
119 scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]
121−
122− describe "Search After API" $
123− it "returns document for search after query" $ withTestEnv $ do
124− _ <- insertData
125− _ <- insertOther
126− let
127− sortSpec = DefaultSortSpec $ mkSort (FieldName "user") Ascending
128− searchAfterKey = [Aeson.toJSON ("bitemyapp" :: String)]
129− search = Search Nothing
130− Nothing (Just [sortSpec]) Nothing Nothing
131− False (From 0) (Size 10) SearchTypeQueryThenFetch (Just searchAfterKey)
132− Nothing Nothing Nothing Nothing
133− result <- searchTweets search
134− let myTweet = grabFirst result
135− liftIO $
136− myTweet `shouldBe` Right otherTweet