git.iko.soy/typeable/bloodhound
on master help sign in
.gitignore+1
since splitsnapshots
unifiedsplit
@@ -19,3 +19,4 @@ 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
.hlint.yamlnew file+66
@@ -0,0 +1,66 @@
1+# HLint configuration file
2+# https://github.com/ndmitchell/hlint
3+##########################
4+
5+# This file contains a template configuration file, which is typically
6+# placed as .hlint.yaml in the root of your project
7+
8+
9+# Specify additional command line arguments
10+#
11+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
12+
13+
14+# Control which extensions/flags/modules/functions can be used
15+#
16+# - extensions:
17+# - default: false # all extension are banned by default
18+# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
19+# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
20+#
21+# - flags:
22+# - {name: -w, within: []} # -w is allowed nowhere
23+#
24+# - modules:
25+# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
26+# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
27+#
28+# - functions:
29+# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
30+
31+
32+# Add custom hints for this project
33+#
34+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
35+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
36+
37+
38+# Turn on hints that are off by default
39+#
40+# Ban "module X(module X) where", to require a real export list
41+# - warn: {name: Use explicit module export list}
42+#
43+# Replace a $ b $ c with a . b $ c
44+# - group: {name: dollar, enabled: true}
45+#
46+# Generalise map to fmap, ++ to <>
47+# - group: {name: generalise, enabled: true}
48+
49+
50+# Ignore some builtin hints
51+- ignore: {name: "Use <$>"}
52+- ignore: {name: "Use lambda-case"}
53+# When we don't use camelCase it's to match ES.
54+# Possibly this is a mistake.
55+- ignore: {name: "Use camelCase"}
56+- ignore: {name: "Eta reduce"}
57+# - ignore: {name: Use let}
58+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
59+
60+
61+# Define some custom infix operators
62+# - fixity: infixr 3 ~^#^~
63+
64+
65+# To generate a suitable file for HLint do:
66+# $ hlint --default > .hlint.yaml
.travis.yml+9−21
@@ -1,36 +1,24 @@
1sudo: false
1sudo: false
2language: generic
2language: generic
3
3
4+jdk:
5+ - oraclejdk11
6+
4addons:
7addons:
5 apt:
8 apt:
6 packages:
9 packages:
7 - libgmp-dev
10 - libgmp-dev
8− - oracle-java8-installer
9
11
10env:
12env:
11− global:
12− - JAVA_HOME=/usr/lib/jvm/java-8-oracle
13− matrix:
13+ matrix:
14− - GHCVER=7.8 ESVER=1.3.6 STACK_YAML=stack-7.8.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
15− - GHCVER=7.8 ESVER=1.4.1 STACK_YAML=stack-7.8.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
16− - GHCVER=7.10 ESVER=1.5.2 STACK_YAML=stack-7.10.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
17− - GHCVER=7.10 ESVER=1.6.0 STACK_YAML=stack-7.10.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
18− - GHCVER=7.10 ESVER=1.7.6 STACK_YAML=stack-7.10.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
19− - GHCVER=8.0 ESVER=1.7.6 STACK_YAML=stack-8.0.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
20− - 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"
21− - GHCVER=8.2 ESVER=1.7.6 STACK_YAML=stack.yaml ESFLAG=ES1 DLINK=https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch
22− - 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"
23− - 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"
24− allow_failures:
25− - 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"
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"
26
15
27install:
16install:
28 # stack
17 # stack
29 - mkdir -p ~/.local/bin
18 - mkdir -p ~/.local/bin
30− - travis_retry curl -L https://github.com/commercialhaskell/stack/releases/download/v1.6.1/stack-1.6.1-linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
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'
31 - export PATH=~/.local/bin:$PATH
20 - export PATH=~/.local/bin:$PATH
32 - stack --no-terminal --version
21 - stack --no-terminal --version
33−
34 # elasticsearch
22 # elasticsearch
35 - wget --no-check-certificate $DLINK-$ESVER.tar.gz
23 - wget --no-check-certificate $DLINK-$ESVER.tar.gz
36 - tar xzf elasticsearch-$ESVER.tar.gz
24 - tar xzf elasticsearch-$ESVER.tar.gz
@@ -42,11 +30,11 @@ script:
42 - stack setup --no-terminal
30 - stack setup --no-terminal
43 - stack update --no-terminal
31 - stack update --no-terminal
44 - stack build -j2 --fast --no-terminal
32 - stack build -j2 --fast --no-terminal
45− - travis_wait 45 sleep 1800 &
33+ - travis_wait 60 sleep 1800 &
46− - stack test --fast --no-terminal bloodhound:bloodhound-tests --test-arguments="--qc-max-success 500" --flag bloodhound:$ESFLAG
34+ - stack test --fast --no-terminal bloodhound:bloodhound-tests --test-arguments="--qc-max-success 500"
47
35
48cache:
36cache:
49− timeout: 2000
37+ timeout: 1500
50 directories:
38 directories:
51 - $HOME/.cabal
39 - $HOME/.cabal
52 - $HOME/.ghc
40 - $HOME/.ghc
DSL.org+1−1
@@ -1,4 +1,4 @@
1−* ElasticSearch DSL
1+* Elasticsearch DSL
2
2
3** Grouping
3** Grouping
4
4
Makefile+101−34
@@ -1,62 +1,129 @@
1−stack = STACK_YAML='stack.yaml' stack
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
2
5
6+stack = STACK_YAML='stack.yaml' stack
7+ghc_perf_options = --ghc-options '+RTS -A128M -RTS'
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
3build:
20build:
4− stack build
21+ $(stack) $(build)
22+
23+## build with validation options (Wall, Werror)
24+build-validate:
25+ $(stack) build --fast --ghc-options '-Wall -Werror +RTS -A128M -RTS'
5
26
27+## run ghci
6ghci:
28ghci:
7− stack ghci
29+ $(stack) $(ghci)
8
30
31+## run tests
9test: echo-warn
32test: echo-warn
10− stack test
33+ $(stack) $(test)
11
34
35+## run tests with forced re-run via "-r"
12test-rerun: echo-warn
36test-rerun: echo-warn
13− stack test --test-arguments "-r"
37+ $(stack) $(test) --test-arguments "-r"
14
38
39+## run ghci with test stanza
15test-ghci:
40test-ghci:
16− stack ghci bloodhound:test:bloodhound-tests
41+ $(stack) $(ghci) bloodhound:test:bloodhound-tests
17
42
43+## run ghcid
18ghcid:
44ghcid:
19 ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"
45 ghcid -c "$(stack) ghci bloodhound:lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is bloodhound:test:bloodhound-tests"
20
46
21−mod-build:
47+## run ghcid with validate options (Werror, etc.)
22− stack build --ghc-options '+RTS -A128M -RTS'
48+ghcid-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"
23
50
24−echo-warn:
51+## run weeder
25− echo "Make certain you have an elasticsearch instance on localhost:9200 !"
52+weeder:
26−
53+ weeder . --build
27−7.8-build:
28− STACK_YAML="stack-7.8.yaml" stack build
29
54
30−7.8-test: echo-warn
55+## run hlint
31− STACK_YAML="stack-7.8.yaml" stack test
56+hlint:
57+ hlint .
32
58
33−7.10-build:
59+## hlint watch with `sos`
34− STACK_YAML="stack-7.10.yaml" stack build
60+hlint-watch:
61+ sos src/ -c "hlint ." -p "src/(.*)\.hs"
35
62
36−7.10-test: echo-warn
63+# mod-build:
37− STACK_YAML="stack-7.10.yaml" stack test
64+# stack build --ghc-options '+RTS -A128M -RTS'
38
65
39−7.10-test-ES1:
66+echo-warn:
40− STACK_YAML="stack-7.10.yaml" stack test --fast bloodhound:tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES1
67+ @echo "Make certain you have an elasticsearch instance on localhost:9200 !"
41
68
69+## Test with GHC 8.0 and ES 5.x
42−7.10-test-ES5:
70+test-8.0:
43− STACK_YAML="stack-7.10.yaml" stack test --fast bloodhound:tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES5
71+ STACK_YAML="stack-8.0.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500"
44
72
73+## Test with GHC 8.2 and ES 5.x
45−8.0-test-ES1:
74+test-8.2:
46− STACK_YAML="stack.yaml" stack test --fast bloodhound:tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES1
75+ STACK_YAML="stack.yaml" stack test --fast bloodhound:test:bloodhound-tests --test-arguments="--qc-max-success 500"
47
76
48−8.0-test-ES5:
77+## Build with the GHC 8.0 Stack YAML
49− STACK_YAML="stack-8.0.yaml" stack test --fast bloodhound:tests --test-arguments="--qc-max-success 500" --flag bloodhound:ES5
78+build-8.0:
79+ $(stack-8.0) $(build)
50
80
81+## Build with the GHC 8.2 Stack YAML
51−8.0-build:
82+build-8.2:
52− STACK_YAML="stack-8.0.yaml" stack build
83+ $(stack-8.2) $(build)
53
84
85+## Build with the GHC 8.4 Stack YAML
54−8.2-build:
86+build-8.4:
55− STACK_YAML="stack-8.2.yaml" stack build
87+ $(stack-8.4) $(build)
56
88
57−module-touch:
89+## Build with the GHC 8.6 Stack YAML
58− touch src/Database/V1/Bloodhound/Types.hs
90+build-8.6:
59− touch src/Database/V5/Bloodhound/Types.hs
91+ $(stack-8.6) $(build)
60
92
93+## Upload the package to Hackage
61upload:
94upload:
62 stack upload --no-signature .
95 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)
README.md+7−7
@@ -22,17 +22,17 @@ Version compatibility
22---------------------
22---------------------
23
23
24As of version 0.13.0.0, Bloodhound has 2 separate module trees for
24As of version 0.13.0.0, Bloodhound has 2 separate module trees for
25−ElasticSearch versions 1 and 5. Import the module that is appropriate
25+Elasticsearch versions 1 and 5. Import the module that is appropriate
26for your use case. If you would like to add support for another major
26for your use case. If you would like to add support for another major
27version, open a ticket expressing your intend and follow the pattern
27version, open a ticket expressing your intend and follow the pattern
28used for other versions. We weighed the idea of sharing code between
28used for other versions. We weighed the idea of sharing code between
29versions but it just got too messy, especially considering the
29versions but it just got too messy, especially considering the
30−instability of the ElasticSearch API. We switched to a model which
30+instability of the Elasticsearch API. We switched to a model which
31would allow the persons responsible for a particular protocol version
31would allow the persons responsible for a particular protocol version
32to maintain that version while avoiding conflict with other versions.
32to maintain that version while avoiding conflict with other versions.
33
33
34See our [TravisCI](https://travis-ci.org/bitemyapp/bloodhound) for a
34See our [TravisCI](https://travis-ci.org/bitemyapp/bloodhound) for a
35−listing of ElasticSearch version we test against.
35+listing of Elasticsearch version we test against.
36
36
37
37
38Stability
38Stability
@@ -43,15 +43,15 @@ Bloodhound is stable for production use. I will strive to avoid breaking API com
43Testing
43Testing
44---------
44---------
45
45
46−The TravisCI tests are run using [Stack](http://docs.haskellstack.org/en/stable/README.html). You should use Stack instead of `cabal` to build and test Bloodhound to avoid compatibility problems. You will also need to have an ElasticSearch instance running at `localhost:9200` in order to execute some of the tests. See the "Version compatibility" section above for a list of ElasticSearch versions that are officially validated against in TravisCI.
46+The TravisCI tests are run using [Stack](http://docs.haskellstack.org/en/stable/README.html). You should use Stack instead of `cabal` to build and test Bloodhound to avoid compatibility problems. You will also need to have an Elasticsearch instance running at `localhost:9200` in order to execute some of the tests. See the "Version compatibility" section above for a list of Elasticsearch versions that are officially validated against in TravisCI.
47
47
48Steps to run the tests locally:
48Steps to run the tests locally:
49− 1. Dig through the [past releases] (https://www.elastic.co/downloads/past-releases) section of the ElasticSearch download page and install the desired ElasticSearch versions.
49+ 1. Dig through the [past releases] (https://www.elastic.co/downloads/past-releases) section of the Elasticsearch download page and install the desired Elasticsearch versions.
50 2. Install [Stack] (http://docs.haskellstack.org/en/stable/README.html#how-to-install)
50 2. Install [Stack] (http://docs.haskellstack.org/en/stable/README.html#how-to-install)
51 3. In your local Bloodhound directory, run `stack setup && stack build`
51 3. In your local Bloodhound directory, run `stack setup && stack build`
52− 4. Start the desired version of ElasticSearch at `localhost:9200`, which should be the default.
52+ 4. Start the desired version of Elasticsearch at `localhost:9200`, which should be the default.
53 5. Run `stack test` in your local Bloodhound directory.
53 5. Run `stack test` in your local Bloodhound directory.
54− 6. The unit tests will pass if you re-execute `stack test`. If you want to start with a clean slate, stop your ElasticSearch instance, delete the `data/` folder in the ElasticSearch installation, restart ElasticSearch, and re-run `stack test`.
54+ 6. The unit tests will pass if you re-execute `stack test`. If you want to start with a clean slate, stop your Elasticsearch instance, delete the `data/` folder in the Elasticsearch installation, restart Elasticsearch, and re-run `stack test`.
55
55
56
56
57Hackage page and Haddock documentation
57Hackage page and Haddock documentation
bloodhound.cabaldeleted−113
@@ -1,113 +0,0 @@
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: 2015, 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.V1.Bloodhound
41− Database.V1.Bloodhound.Client
42− Database.V1.Bloodhound.Types
43− Database.V1.Bloodhound.Types.Class
44− Database.V1.Bloodhound.Types.Internal
45− other-modules: Bloodhound.Import
46− Database.Bloodhound.Common.Script
47− Database.V5.Bloodhound.Internal.Analysis
48− Database.V5.Bloodhound.Internal.Client
49− Database.V5.Bloodhound.Internal.Newtypes
50− Database.V5.Bloodhound.Internal.Query
51− Database.V5.Bloodhound.Internal.StringlyTyped
52− hs-source-dirs: src
53− build-depends: base >= 4.3 && <5,
54− bytestring >= 0.10.0 && <0.11,
55− containers >= 0.5.0.0 && <0.6,
56− aeson >= 0.11.1 && <1.3,
57− http-client >= 0.4.30 && <0.6,
58− network-uri >= 2.6 && <2.7,
59− semigroups >= 0.15 && <0.19,
60− time >= 1.4 && <1.9,
61− text >= 0.11 && <1.3,
62− mtl >= 1.0 && <2.3,
63− transformers >= 0.2 && <0.6,
64− http-types >= 0.8 && <0.13,
65− vector >= 0.10.9 && <0.13,
66− scientific >= 0.3.0.0 && <0.4.0.0,
67− bifunctors,
68− exceptions,
69− data-default-class,
70− blaze-builder,
71− unordered-containers,
72− mtl-compat,
73− hashable
74− default-language: Haskell2010
75−
76−test-suite bloodhound-tests
77− ghc-options: -Wall -fno-warn-orphans
78− type: exitcode-stdio-1.0
79− main-is: tests.hs
80− if flag(ES1)
81− hs-source-dirs: tests/V1
82− else
83− hs-source-dirs: tests/V5
84− other-modules: Test.ApproxEq
85− Test.Generators
86− Test.JSON
87− build-depends: base,
88− bloodhound,
89− bytestring,
90− http-client,
91− http-types,
92− containers,
93− hspec >= 1.8,
94− text,
95− time,
96− aeson,
97− semigroups,
98− QuickCheck,
99− vector,
100− unordered-containers >= 0.2.5.0 && <0.3,
101− mtl,
102− pretty-simple,
103− quickcheck-arbitrary-template,
104− quickcheck-properties,
105− generics-sop >=0.2 && <0.4,
106− errors,
107− exceptions,
108− temporary,
109− unix-compat,
110− network-uri,
111− microlens,
112− microlens-aeson
113− default-language: Haskell2010
changelog.md+29−2
@@ -1,8 +1,23 @@
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+
10.16.0.0
100.16.0.0
2========
11========
3- @bitemyapp
12- @bitemyapp
4− - Reorganized modules internally, ripped out Generic,
13+ - Reorganized V5 modules internally, ripped out Generic,
5− rewrote part of the test suite
14+ 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
20+ - Reorganized V1 modules, mirroring the work done on V5.
6- @andrewthad
21- @andrewthad
7 - Added support for autogenerated elasticsearch ids in the bulk API
22 - Added support for autogenerated elasticsearch ids in the bulk API
8 - Added support for token filters
23 - Added support for token filters
@@ -11,6 +26,18 @@
11 - Added support for scripts fields and function score queries
26 - Added support for scripts fields and function score queries
12- @bermanjosh
27- @bermanjosh
13 - Added support for direct generators
28 - Added support for direct generators
29+- @rvl
30+ - Add [character filters][] to the `AnalyzerDefinition` type.
31+ - Add the "stemmer" and "stop" [token filters][] to `TokenFilterDefinition`.
32+- @ahodgen
33+ - 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+
38+[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
40+[Fuzziness]: https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#fuzziness
14
41
150.15.0.2
420.15.0.2
16========
43========
docker-compose.ymlnew file+35
@@ -0,0 +1,35 @@
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/Dockerfilenew file+3
@@ -0,0 +1,3 @@
1+FROM docker.elastic.co/elasticsearch/elasticsearch:5.6.0
2+
3+COPY config /usr/share/elasticsearch/config/
elasticsearch/config/elasticsearch.ymlnew file+3
@@ -0,0 +1,3 @@
1+xpack.security.enabled: false
2+cluster.name: "docker-cluster"
3+network.host: 0.0.0.0
examples/README.md+1−1
@@ -1,6 +1,6 @@
1# Bloodhound Examples
1# Bloodhound Examples
2
2
3These examples can be built via `stack build`.
3These examples can be built via `stack build`.
4−To run them start an ElasticSearch 5.x server at `localhost:9200`
4+To run them start an Elasticsearch 5.x server at `localhost:9200`
5
5
6Run with `stack exec tweet-example`
6Run with `stack exec tweet-example`
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.V5.Bloodhound
17+import Database.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))) [toJSON TweetMapping]
86+ let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [object ["tweet" .= 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
examples/package.yaml−1
@@ -17,7 +17,6 @@ dependencies:
17- http-client
17- http-client
18- vector
18- vector
19- semigroups
19- semigroups
20−- transformers
21ghc-options:
20ghc-options:
22- -Wall
21- -Wall
23- -threaded
22- -threaded
package.yamlnew file+74
@@ -0,0 +1,74 @@
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/Bloodhound/Import.hs+47−56
@@ -7,65 +7,46 @@ module Bloodhound.Import
7 , parseReadText
7 , parseReadText
8 , readMay
8 , readMay
9 , showText
9 , showText
10+ , deleteSeveral
11+ , oPath
12+ , tshow
10 ) where
13 ) where
11
14
12−import Control.Applicative as X (Alternative(..), optional)
15+import Control.Applicative as X (Alternative (..), optional)
13−import Control.Exception as X (Exception)
16+import Control.Exception as X (Exception)
14−import Control.Monad as X ( MonadPlus(..)
17+import Control.Monad as X (MonadPlus (..), forM, (<=<))
15− , (<=<)
16− , forM
17− )
18−import Control.Monad.Fix as X (MonadFix)
19−import Control.Monad.IO.Class as X (MonadIO(..))
20−import Control.Monad.Catch as X ( MonadCatch
18+import Control.Monad.Catch as X (MonadCatch, MonadMask,
21− , MonadMask
22− , MonadThrow
19+ MonadThrow)
23− )
24−import Control.Monad.Except as X (MonadError)
20+import Control.Monad.Except as X (MonadError)
21+import Control.Monad.Fix as X (MonadFix)
22+import Control.Monad.IO.Class as X (MonadIO (..))
25−import Control.Monad.Reader as X ( MonadReader (..)
23+import Control.Monad.Reader as X (MonadReader (..),
26− , MonadTrans (..)
24+ MonadTrans (..), ReaderT (..))
27− , ReaderT (..)
28− )
29−import Control.Monad.State as X (MonadState)
25+import Control.Monad.State as X (MonadState)
30−import Control.Monad.Writer as X (MonadWriter)
26+import Control.Monad.Writer as X (MonadWriter)
31−import Data.Aeson as X
27+import Data.Aeson as X
32−import Data.Aeson.Types as X ( Pair
28+import Data.Aeson.Types as X (Pair, Parser, emptyObject,
33− , Parser
34− , emptyObject
35− , parseEither
29+ parseEither, parseMaybe,
36− , parseMaybe
37− , typeMismatch
30+ typeMismatch)
38− )
39−import Data.Bifunctor as X (first)
31+import Data.Bifunctor as X (first)
40−import Data.Char as X (isNumber)
32+import Data.Char as X (isNumber)
41−import Data.Hashable as X (Hashable)
33+import Data.Hashable as X (Hashable)
34+import qualified Data.HashMap.Strict as HM
42−import Data.List as X ( foldl'
35+import Data.List as X (foldl', intercalate, nub)
43− , intercalate
44− , nub
45− )
46−import Data.List.NonEmpty as X ( NonEmpty (..)
36+import Data.List.NonEmpty as X (NonEmpty (..), toList)
47− , toList
48− )
49−import Data.Maybe as X ( catMaybes
37+import Data.Maybe as X (catMaybes, fromMaybe,
50− , fromMaybe
51− , isNothing
52− , maybeToList
38+ isNothing, maybeToList)
53− )
54−import Data.Scientific as X (Scientific)
39+import Data.Scientific as X (Scientific)
55−import Data.Semigroup as X (Semigroup(..))
40+import Data.Semigroup as X (Semigroup (..))
56−import Data.Text as X (Text)
41+import Data.Text as X (Text)
57−import Data.Time.Calendar as X ( Day(..)
42+import Data.Time.Calendar as X (Day (..), showGregorian)
58− , showGregorian
59− )
60−import Data.Time.Clock as X ( NominalDiffTime
43+import Data.Time.Clock as X (NominalDiffTime, UTCTime)
61− , UTCTime
62− )
63−import Data.Time.Clock.POSIX as X
44+import Data.Time.Clock.POSIX as X
64
45
65−import qualified Data.ByteString.Lazy as BL
46+import qualified Data.ByteString.Lazy as BL
66−import qualified Data.Text as T
47+import qualified Data.Text as T
67−import qualified Data.Traversable as DT
48+import qualified Data.Traversable as DT
68−import qualified Data.Vector as V
49+import qualified Data.Vector as V
69import qualified Network.HTTP.Types.Method as NHTM
50import qualified Network.HTTP.Types.Method as NHTM
70
51
71type LByteString = BL.ByteString
52type LByteString = BL.ByteString
@@ -92,3 +73,13 @@ omitNulls = object . filter notNull where
92parseNEJSON :: (FromJSON a) => [Value] -> Parser (NonEmpty a)
73parseNEJSON :: (FromJSON a) => [Value] -> Parser (NonEmpty a)
93parseNEJSON [] = fail "Expected non-empty list"
74parseNEJSON [] = fail "Expected non-empty list"
94parseNEJSON (x:xs) = DT.mapM parseJSON (x :| xs)
75parseNEJSON (x:xs) = DT.mapM parseJSON (x :| xs)
76+
77+deleteSeveral :: (Eq k, Hashable k) => [k] -> HM.HashMap k v -> HM.HashMap k v
78+deleteSeveral ks hm = foldr HM.delete hm ks
79+
80+oPath :: ToJSON a => NonEmpty Text -> a -> Value
81+oPath (k :| []) v = object [k .= v]
82+oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]
83+
84+tshow :: Show a => a -> Text
85+tshow = T.pack . show
src/Database/Bloodhound.hsnew file+10
@@ -0,0 +1,10 @@
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/V5/Bloodhound/Client.hs → src/Database/Bloodhound/Client.hsrenamed+65−51
@@ -5,7 +5,7 @@
5-------------------------------------------------------------------------------
5-------------------------------------------------------------------------------
6-- |
6-- |
7-- Module : Database.Bloodhound.Client
7-- Module : Database.Bloodhound.Client
8−-- Copyright : (C) 2014 Chris Allen
8+-- Copyright : (C) 2014, 2018 Chris Allen
9-- License : BSD-style (see the file LICENSE)
9-- License : BSD-style (see the file LICENSE)
10-- Maintainer : Chris Allen <cma@bitemyapp.com>
10-- Maintainer : Chris Allen <cma@bitemyapp.com>
11-- Stability : provisional
11-- Stability : provisional
@@ -15,7 +15,7 @@
15--
15--
16-------------------------------------------------------------------------------
16-------------------------------------------------------------------------------
17
17
18−module Database.V5.Bloodhound.Client
18+module Database.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
@@ -26,6 +26,7 @@ module Database.V5.Bloodhound.Client
26 -- ** Indices
26 -- ** Indices
27 , createIndex
27 , createIndex
28 , createIndexWith
28 , createIndexWith
29+ , flushIndex
29 , deleteIndex
30 , deleteIndex
30 , updateIndexSettings
31 , updateIndexSettings
31 , getIndexSettings
32 , getIndexSettings
@@ -124,12 +125,12 @@ import qualified Network.HTTP.Types.URI as NHTU
124import qualified Network.URI as URI
125import qualified Network.URI as URI
125import Prelude hiding (filter, head)
126import Prelude hiding (filter, head)
126
127
127−import Database.V5.Bloodhound.Types
128+import Database.Bloodhound.Types
128
129
129-- $setup
130-- $setup
130-- >>> :set -XOverloadedStrings
131-- >>> :set -XOverloadedStrings
131-- >>> :set -XDeriveGeneric
132-- >>> :set -XDeriveGeneric
132−-- >>> import Database.V5.Bloodhound
133+-- >>> import Database.Bloodhound
133-- >>> import Network.HTTP.Client
134-- >>> import Network.HTTP.Client
134-- >>> let testServer = (Server "http://localhost:9200")
135-- >>> let testServer = (Server "http://localhost:9200")
135-- >>> let runBH' = withBH defaultManagerSettings testServer
136-- >>> let runBH' = withBH defaultManagerSettings testServer
@@ -317,7 +318,7 @@ instance FromJSON GSRs where
317 parseJSON = withObject "Collection of GenericSnapshotRepo" parse
318 parseJSON = withObject "Collection of GenericSnapshotRepo" parse
318 where
319 where
319 parse = fmap GSRs . mapM (uncurry go) . HM.toList
320 parse = fmap GSRs . mapM (uncurry go) . HM.toList
320− go rawName = withObject "GenericSnapshotRepo" $ \o -> do
321+ go rawName = withObject "GenericSnapshotRepo" $ \o ->
321 GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type"
322 GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type"
322 <*> o .: "settings"
323 <*> o .: "settings"
323
324
@@ -346,7 +347,7 @@ updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo =
346
347
347
348
348-- | Verify if a snapshot repo is working. __NOTE:__ this API did not
349-- | Verify if a snapshot repo is working. __NOTE:__ this API did not
349−-- make it into ElasticSearch until 1.4. If you use an older version,
350+-- make it into Elasticsearch until 1.4. If you use an older version,
350-- you will get an error here.
351-- you will get an error here.
351verifySnapshotRepo
352verifySnapshotRepo
352 :: ( MonadBH m
353 :: ( MonadBH m
@@ -522,19 +523,25 @@ createIndex indexSettings (IndexName indexName) =
522createIndexWith :: MonadBH m
523createIndexWith :: MonadBH m
523 => [UpdatableIndexSetting]
524 => [UpdatableIndexSetting]
524 -> Int -- ^ shard count
525 -> Int -- ^ shard count
525− -> IndexName
526+ -> IndexName
526 -> m Reply
527 -> m Reply
527createIndexWith updates shards (IndexName indexName) =
528createIndexWith updates shards (IndexName indexName) =
528 bindM2 put url (return (Just body))
529 bindM2 put url (return (Just body))
529 where url = joinPath [indexName]
530 where url = joinPath [indexName]
530 body = encode $ object
531 body = encode $ object
531− ["settings" .= deepMerge
532+ ["settings" .= deepMerge
532 ( HM.singleton "index.number_of_shards" (toJSON shards) :
533 ( HM.singleton "index.number_of_shards" (toJSON shards) :
533 [u | Object u <- toJSON <$> updates]
534 [u | Object u <- toJSON <$> updates]
534 )
535 )
535 ]
536 ]
536
537
538+-- | 'flushIndex' will flush an index given a 'Server' and an 'IndexName'.
539+flushIndex :: MonadBH m => IndexName -> m Reply
540+flushIndex (IndexName indexName) = do
541+ path <- joinPath [indexName, "_flush"]
542+ post path Nothing
543+
537−-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
544+-- | 'deleteIndex' will delete an index given a 'Server' and an 'IndexName'.
538--
545--
539-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
546-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
540-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
547-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
@@ -555,19 +562,21 @@ deleteIndex (IndexName indexName) =
555updateIndexSettings :: MonadBH m => NonEmpty UpdatableIndexSetting -> IndexName -> m Reply
562updateIndexSettings :: MonadBH m => NonEmpty UpdatableIndexSetting -> IndexName -> m Reply
556updateIndexSettings updates (IndexName indexName) =
563updateIndexSettings updates (IndexName indexName) =
557 bindM2 put url (return body)
564 bindM2 put url (return body)
565+ where
558− where url = joinPath [indexName, "_settings"]
566+ url = joinPath [indexName, "_settings"]
559− body = Just (encode jsonBody)
567+ body = Just (encode jsonBody)
560− jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])
568+ jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])
561
569
562
570
563getIndexSettings :: (MonadBH m, MonadThrow m) => IndexName
571getIndexSettings :: (MonadBH m, MonadThrow m) => IndexName
564 -> m (Either EsError IndexSettingsSummary)
572 -> m (Either EsError IndexSettingsSummary)
565−getIndexSettings (IndexName indexName) = do
573+getIndexSettings (IndexName indexName) =
566 parseEsResponse =<< get =<< url
574 parseEsResponse =<< get =<< url
575+ where
567− where url = joinPath [indexName, "_settings"]
576+ url = joinPath [indexName, "_settings"]
568
577
569−-- | 'forceMergeIndex'
578+-- | 'forceMergeIndex'
570−--
579+--
571-- 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
572-- 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
573-- 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
@@ -629,20 +638,25 @@ existentialQuery url = do
629-- responses from elasticsearch should fall into these two
638-- responses from elasticsearch should fall into these two
630-- categories. If they don't, a 'EsProtocolException' will be
639-- categories. If they don't, a 'EsProtocolException' will be
631-- thrown. If you encounter this, please report the full body it
640-- thrown. If you encounter this, please report the full body it
632−-- reports along with your ElasticSearch verison.
641+-- reports along with your Elasticsearch verison.
633−parseEsResponse :: (MonadThrow m, FromJSON a) => Reply
642+parseEsResponse :: ( MonadThrow m
643+ , FromJSON a
644+ )
645+ => Reply
634 -> m (Either EsError a)
646 -> m (Either EsError a)
635parseEsResponse reply
647parseEsResponse reply
636 | respIsTwoHunna reply = case eitherDecode body of
648 | respIsTwoHunna reply = case eitherDecode body of
637 Right a -> return (Right a)
649 Right a -> return (Right a)
650+ Left err ->
638− Left _ -> tryParseError
651+ tryParseError err
639− | otherwise = tryParseError
652+ | otherwise = tryParseError "Non-200 status code"
640 where body = responseBody reply
653 where body = responseBody reply
654+ tryParseError originalError
641− tryParseError = case eitherDecode body of
655+ = case eitherDecode body of
642− Right e -> return (Left e)
656+ Right e -> return (Left e)
643− -- this case should not be possible
657+ -- Failed to parse the error message.
644− Left _ -> explode
658+ Left err -> explode ("Original error was: " <> originalError <> " Error parse failure was: " <> err)
645− explode = throwM (EsProtocolException body)
659+ explode errorMsg = throwM (EsProtocolException (T.pack errorMsg) body)
646
660
647-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
661-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
648-- in IO
662-- in IO
@@ -702,16 +716,15 @@ listIndices =
702 parse . responseBody =<< get =<< url
716 parse . responseBody =<< get =<< url
703 where
717 where
704 url = joinPath ["_cat/indices?format=json"]
718 url = joinPath ["_cat/indices?format=json"]
705− parse body = maybe (throwM (EsProtocolException body)) return $ do
719+ parse body = either (\msg -> (throwM (EsProtocolException (T.pack msg) body))) return $ do
706− vals <- decode body
720+ vals <- eitherDecode body
707− forM vals $ \val -> do
721+ forM vals $ \val ->
708 case val of
722 case val of
709− Object obj -> do
723+ Object obj ->
710− indexVal <- HM.lookup "index" obj
724+ case HM.lookup "index" obj of
711− case indexVal of
712− String txt -> Just (IndexName txt)
725+ (Just (String txt)) -> Right (IndexName txt)
713− _ -> Nothing
726+ v -> Left $ "indexVal in listIndices failed on non-string, was: " <> show v
714− _ -> Nothing
727+ v -> Left $ "One of the values parsed in listIndices wasn't an object, it was: " <> show v
715
728
716-- | 'updateIndexAliases' updates the server's index alias
729-- | 'updateIndexAliases' updates the server's index alias
717-- table. Operations are atomic. Explained in further detail at
730-- table. Operations are atomic. Explained in further detail at
@@ -811,7 +824,7 @@ versionCtlParams cfg =
811-- Elasticsearch. The document itself is simply something we can
824-- Elasticsearch. The document itself is simply something we can
812-- convert into a JSON 'Value'. The 'DocId' will function as the
825-- convert into a JSON 'Value'. The 'DocId' will function as the
813-- primary key for the document. You are encouraged to generate
826-- primary key for the document. You are encouraged to generate
814−-- your own id's and not rely on ElasticSearch's automatic id
827+-- your own id's and not rely on Elasticsearch's automatic id
815-- generation. Read more about it here:
828-- generation. Read more about it here:
816-- https://github.com/bitemyapp/bloodhound/issues/107
829-- https://github.com/bitemyapp/bloodhound/issues/107
817--
830--
@@ -861,10 +874,11 @@ deleteDocument (IndexName indexName)
861-- >>> _ <- runBH' $ bulk stream
874-- >>> _ <- runBH' $ bulk stream
862-- >>> _ <- runBH' $ refreshIndex testIndex
875-- >>> _ <- runBH' $ refreshIndex testIndex
863bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
876bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
864−bulk bulkOps = do
877+bulk bulkOps =
865 bindM2 post url (return body)
878 bindM2 post url (return body)
879+ where
866− where url = joinPath ["_bulk"]
880+ url = joinPath ["_bulk"]
867− body = Just $ encodeBulkOperations bulkOps
881+ body = Just $ encodeBulkOperations bulkOps
868
882
869-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
883-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
870-- into an 'L.ByteString'
884-- into an 'L.ByteString'
@@ -882,7 +896,7 @@ encodeBulkOperations stream = collapsed where
882 toLazyByteString $ mappend mashedTaters (byteString "\n")
896 toLazyByteString $ mappend mashedTaters (byteString "\n")
883
897
884mash :: Builder -> V.Vector L.ByteString -> Builder
898mash :: Builder -> V.Vector L.ByteString -> Builder
885−mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))
899+mash = V.foldl' (\b x -> b <> byteString "\n" <> lazyByteString x)
886
900
887mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
901mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
888mkBulkStreamValue operation indexName mappingName docId =
902mkBulkStreamValue operation indexName mappingName docId =
@@ -1021,10 +1035,10 @@ searchByType (IndexName indexName)
1021-- search results. Note that the search is put into 'SearchTypeScan'
1035-- search results. Note that the search is put into 'SearchTypeScan'
1022-- mode and thus results will not be sorted. Combine this with
1036-- mode and thus results will not be sorted. Combine this with
1023-- 'advanceScroll' to efficiently stream through the full result set
1037-- 'advanceScroll' to efficiently stream through the full result set
1024−getInitialScroll ::
1038+getInitialScroll ::
1025− (FromJSON a, MonadThrow m, MonadBH m) => IndexName ->
1039+ (FromJSON a, MonadThrow m, MonadBH m) => IndexName ->
1026− MappingName ->
1040+ MappingName ->
1027− Search ->
1041+ Search ->
1028 m (Either EsError (SearchResult a))
1042 m (Either EsError (SearchResult a))
1029getInitialScroll (IndexName indexName) (MappingName mappingName) search' = do
1043getInitialScroll (IndexName indexName) (MappingName mappingName) search' = do
1030 let url = addQuery params <$> joinPath [indexName, mappingName, "_search"]
1044 let url = addQuery params <$> joinPath [indexName, mappingName, "_search"]
@@ -1049,7 +1063,7 @@ getInitialSortedScroll (IndexName indexName) (MappingName mappingName) search =
1049 resp' <- bindM2 dispatchSearch url (return search)
1063 resp' <- bindM2 dispatchSearch url (return search)
1050 parseEsResponse resp'
1064 parseEsResponse resp'
1051
1065
1052−scroll' :: (FromJSON a, MonadBH m, MonadThrow m) => Maybe ScrollId ->
1066+scroll' :: (FromJSON a, MonadBH m, MonadThrow m) => Maybe ScrollId ->
1053 m ([Hit a], Maybe ScrollId)
1067 m ([Hit a], Maybe ScrollId)
1054scroll' Nothing = return ([], Nothing)
1068scroll' Nothing = return ([], Nothing)
1055scroll' (Just sid) = do
1069scroll' (Just sid) = do
@@ -1076,13 +1090,13 @@ advanceScroll (ScrollId sid) scroll = do
1076 where scrollTime = showText secs <> "s"
1090 where scrollTime = showText secs <> "s"
1077 secs :: Integer
1091 secs :: Integer
1078 secs = round scroll
1092 secs = round scroll
1079−
1093+
1080 scrollObject = object [ "scroll" .= scrollTime
1094 scrollObject = object [ "scroll" .= scrollTime
1081 , "scroll_id" .= sid
1095 , "scroll_id" .= sid
1082 ]
1096 ]
1083
1097
1084−simpleAccumulator ::
1098+simpleAccumulator ::
1085− (FromJSON a, MonadBH m, MonadThrow m) =>
1099+ (FromJSON a, MonadBH m, MonadThrow m) =>
1086 [Hit a] ->
1100 [Hit a] ->
1087 ([Hit a], Maybe ScrollId) ->
1101 ([Hit a], Maybe ScrollId) ->
1088 m ([Hit a], Maybe ScrollId)
1102 m ([Hit a], Maybe ScrollId)
@@ -1120,9 +1134,9 @@ scanSearch indexName mappingName search = do
1120--
1134--
1121-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
1135-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
1122-- >>> mkSearch (Just query) Nothing
1136-- >>> mkSearch (Just query) Nothing
1123−-- 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}
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}
1124mkSearch :: Maybe Query -> Maybe Filter -> Search
1138mkSearch :: Maybe Query -> Maybe Filter -> Search
1125−mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing Nothing
1139+mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing Nothing Nothing
1126
1140
1127-- | '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
1128-- the 'Query' and the 'Aggregation'.
1142-- the 'Query' and the 'Aggregation'.
@@ -1132,7 +1146,7 @@ mkSearch query filter = Search query filter Nothing Nothing Nothing False (From
1132-- 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})
1133-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
1147-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
1134mkAggregateSearch :: Maybe Query -> Aggregations -> Search
1148mkAggregateSearch :: Maybe Query -> Aggregations -> Search
1135−mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch 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 Nothing
1136
1150
1137-- | '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
1138-- the 'Query' and the 'Aggregation'.
1152-- the 'Query' and the 'Aggregation'.
@@ -1141,7 +1155,7 @@ mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSear
1141-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
1155-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
1142-- >>> let search = mkHighlightSearch (Just query) testHighlight
1156-- >>> let search = mkHighlightSearch (Just query) testHighlight
1143mkHighlightSearch :: Maybe Query -> Highlights -> Search
1157mkHighlightSearch :: Maybe Query -> Highlights -> Search
1144−mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch 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 Nothing
1145
1159
1146-- | '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
1147-- 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/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.V5.Bloodhound.Internal.Newtypes
10+import Database.Bloodhound.Internal.Newtypes
11
11
12newtype ScriptFields =
12newtype ScriptFields =
13 ScriptFields (HM.HashMap ScriptFieldName ScriptFieldValue)
13 ScriptFields (HM.HashMap ScriptFieldName ScriptFieldValue)
src/Database/Bloodhound/Internal/Aggregation.hsnew file+479
@@ -0,0 +1,479 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
4+
5+module Database.Bloodhound.Internal.Aggregation where
6+
7+import Bloodhound.Import
8+
9+import qualified Data.Aeson as Aeson
10+import qualified Data.HashMap.Strict as HM
11+import qualified Data.Map.Strict as M
12+import qualified Data.Text as T
13+
14+import Database.Bloodhound.Internal.Client
15+import Database.Bloodhound.Internal.Highlight (HitHighlight)
16+import Database.Bloodhound.Internal.Newtypes
17+import Database.Bloodhound.Internal.Query
18+import Database.Bloodhound.Internal.Sort
19+
20+type Aggregations = M.Map Text Aggregation
21+
22+emptyAggregations :: Aggregations
23+emptyAggregations = M.empty
24+
25+mkAggregations :: Text -> Aggregation -> Aggregations
26+mkAggregations name aggregation = M.insert name aggregation emptyAggregations
27+
28+data Aggregation = TermsAgg TermsAggregation
29+ | CardinalityAgg CardinalityAggregation
30+ | MaxAgg MaxAggregation
31+ | DateHistogramAgg DateHistogramAggregation
32+ | ValueCountAgg ValueCountAggregation
33+ | FilterAgg FilterAggregation
34+ | DateRangeAgg DateRangeAggregation
35+ | MissingAgg MissingAggregation
36+ | TopHitsAgg TopHitsAggregation
37+ | StatsAgg StatisticsAggregation
38+ deriving (Eq, Show)
39+
40+instance ToJSON Aggregation where
41+ toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =
42+ omitNulls ["terms" .= omitNulls [ toJSON' term,
43+ "include" .= include,
44+ "exclude" .= exclude,
45+ "order" .= order,
46+ "min_doc_count" .= minDocCount,
47+ "size" .= size,
48+ "shard_size" .= shardSize,
49+ "collect_mode" .= collectMode,
50+ "execution_hint" .= executionHint
51+ ],
52+ "aggs" .= termAggs ]
53+ where
54+ toJSON' x = case x of { Left y -> "field" .= y; Right y -> "script" .= y }
55+
56+ toJSON (CardinalityAgg (CardinalityAggregation field precisionThreshold)) =
57+ object ["cardinality" .= omitNulls [ "field" .= field,
58+ "precisionThreshold" .= precisionThreshold
59+ ]
60+ ]
61+
62+ toJSON (MaxAgg (MaxAggregation field)) =
63+ object ["max" .= omitNulls [ "field" .= field ]]
64+
65+ toJSON (DateHistogramAgg
66+ (DateHistogramAggregation field interval format
67+ preZone postZone preOffset postOffset dateHistoAggs)) =
68+ omitNulls ["date_histogram" .= omitNulls [ "field" .= field,
69+ "interval" .= interval,
70+ "format" .= format,
71+ "pre_zone" .= preZone,
72+ "post_zone" .= postZone,
73+ "pre_offset" .= preOffset,
74+ "post_offset" .= postOffset
75+ ],
76+ "aggs" .= dateHistoAggs ]
77+ toJSON (ValueCountAgg a) = object ["value_count" .= v]
78+ where v = case a of
79+ (FieldValueCount (FieldName n)) ->
80+ object ["field" .= n]
81+ (ScriptValueCount s) ->
82+ object ["script" .= s]
83+ toJSON (FilterAgg (FilterAggregation filt ags)) =
84+ omitNulls [ "filter" .= filt
85+ , "aggs" .= ags]
86+ toJSON (DateRangeAgg a) = object [ "date_range" .= a
87+ ]
88+ toJSON (MissingAgg (MissingAggregation{..})) =
89+ object ["missing" .= object ["field" .= maField]]
90+
91+ toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =
92+ omitNulls ["top_hits" .= omitNulls [ "size" .= msize
93+ , "from" .= mfrom
94+ , "sort" .= msort
95+ ]
96+ ]
97+
98+ toJSON (StatsAgg (StatisticsAggregation typ field)) =
99+ object [stType .= omitNulls [ "field" .= field ]]
100+ where
101+ stType | typ == Basic = "stats"
102+ | otherwise = "extended_stats"
103+
104+data TopHitsAggregation = TopHitsAggregation
105+ { taFrom :: Maybe From
106+ , taSize :: Maybe Size
107+ , taSort :: Maybe Sort
108+ } deriving (Eq, Show)
109+
110+data MissingAggregation = MissingAggregation
111+ { maField :: Text
112+ } deriving (Eq, Show)
113+
114+data TermsAggregation = TermsAggregation
115+ { term :: Either Text Text
116+ , termInclude :: Maybe TermInclusion
117+ , termExclude :: Maybe TermInclusion
118+ , termOrder :: Maybe TermOrder
119+ , termMinDocCount :: Maybe Int
120+ , termSize :: Maybe Int
121+ , termShardSize :: Maybe Int
122+ , termCollectMode :: Maybe CollectionMode
123+ , termExecutionHint :: Maybe ExecutionHint
124+ , termAggs :: Maybe Aggregations
125+ } deriving (Eq, Show)
126+
127+data CardinalityAggregation = CardinalityAggregation
128+ { cardinalityField :: FieldName,
129+ precisionThreshold :: Maybe Int
130+ } deriving (Eq, Show)
131+
132+data MaxAggregation = MaxAggregation
133+ { maxField :: FieldName
134+ } deriving (Eq, Show)
135+
136+data DateHistogramAggregation = DateHistogramAggregation
137+ { dateField :: FieldName
138+ , dateInterval :: Interval
139+ , dateFormat :: Maybe Text
140+ -- pre and post deprecated in 1.5
141+ , datePreZone :: Maybe Text
142+ , datePostZone :: Maybe Text
143+ , datePreOffset :: Maybe Text
144+ , datePostOffset :: Maybe Text
145+ , dateAggs :: Maybe Aggregations
146+ } deriving (Eq, Show)
147+
148+data DateRangeAggregation = DateRangeAggregation
149+ { draField :: FieldName
150+ , draFormat :: Maybe Text
151+ , draRanges :: NonEmpty DateRangeAggRange
152+ } deriving (Eq, Show)
153+
154+instance ToJSON DateRangeAggregation where
155+ toJSON DateRangeAggregation {..} =
156+ omitNulls [ "field" .= draField
157+ , "format" .= draFormat
158+ , "ranges" .= toList draRanges
159+ ]
160+
161+data DateRangeAggRange =
162+ DateRangeFrom DateMathExpr
163+ | DateRangeTo DateMathExpr
164+ | DateRangeFromAndTo DateMathExpr DateMathExpr
165+ deriving (Eq, Show)
166+
167+instance ToJSON DateRangeAggRange where
168+ toJSON (DateRangeFrom e) = object [ "from" .= e ]
169+ toJSON (DateRangeTo e) = object [ "to" .= e ]
170+ toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]
171+
172+-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.
173+data ValueCountAggregation =
174+ FieldValueCount FieldName
175+ | ScriptValueCount Script
176+ deriving (Eq, Show)
177+
178+-- | 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.
179+data FilterAggregation = FilterAggregation
180+ { faFilter :: Filter
181+ , faAggs :: Maybe Aggregations }
182+ deriving (Eq, Show)
183+
184+data StatisticsAggregation = StatisticsAggregation
185+ { statsType :: StatsType
186+ , statsField :: FieldName }
187+ deriving (Eq, Show)
188+
189+data StatsType
190+ = Basic
191+ | Extended
192+ deriving (Eq, Show)
193+
194+mkTermsAggregation :: Text -> TermsAggregation
195+mkTermsAggregation t =
196+ TermsAggregation (Left t)
197+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
198+
199+mkTermsScriptAggregation :: Text -> TermsAggregation
200+mkTermsScriptAggregation t = TermsAggregation (Right t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
201+
202+mkDateHistogram :: FieldName -> Interval -> DateHistogramAggregation
203+mkDateHistogram t i = DateHistogramAggregation t i Nothing Nothing Nothing Nothing Nothing Nothing
204+
205+mkCardinalityAggregation :: FieldName -> CardinalityAggregation
206+mkCardinalityAggregation t = CardinalityAggregation t Nothing
207+
208+mkStatsAggregation :: FieldName -> StatisticsAggregation
209+mkStatsAggregation = StatisticsAggregation Basic
210+
211+mkExtendedStatsAggregation :: FieldName -> StatisticsAggregation
212+mkExtendedStatsAggregation = StatisticsAggregation Extended
213+
214+type AggregationResults = M.Map Text Value
215+
216+class BucketAggregation a where
217+ key :: a -> BucketValue
218+ docCount :: a -> Int
219+ aggs :: a -> Maybe AggregationResults
220+
221+data Bucket a = Bucket
222+ { buckets :: [a]
223+ } deriving (Read, Show)
224+
225+instance (FromJSON a) => FromJSON (Bucket a) where
226+ parseJSON (Object v) = Bucket <$>
227+ v .: "buckets"
228+ parseJSON _ = mempty
229+
230+data BucketValue = TextValue Text
231+ | ScientificValue Scientific
232+ | BoolValue Bool deriving (Read, Show)
233+
234+instance FromJSON BucketValue where
235+ parseJSON (String t) = return $ TextValue t
236+ parseJSON (Number s) = return $ ScientificValue s
237+ parseJSON (Bool b) = return $ BoolValue b
238+ parseJSON _ = mempty
239+
240+data TermInclusion = TermInclusion Text
241+ | TermPattern Text Text deriving (Eq, Show)
242+
243+instance ToJSON TermInclusion where
244+ toJSON (TermInclusion x) = toJSON x
245+ toJSON (TermPattern pattern flags) =
246+ omitNulls [ "pattern" .= pattern
247+ , "flags" .= flags]
248+
249+data TermOrder = TermOrder
250+ { termSortField :: Text
251+ , termSortOrder :: SortOrder } deriving (Eq, Show)
252+
253+instance ToJSON TermOrder where
254+ toJSON (TermOrder termSortField termSortOrder) =
255+ object [termSortField .= termSortOrder]
256+
257+data CollectionMode = BreadthFirst
258+ | DepthFirst deriving (Eq, Show)
259+
260+instance ToJSON CollectionMode where
261+ toJSON BreadthFirst = "breadth_first"
262+ toJSON DepthFirst = "depth_first"
263+
264+data ExecutionHint = Ordinals
265+ | GlobalOrdinals
266+ | GlobalOrdinalsHash
267+ | GlobalOrdinalsLowCardinality
268+ | Map deriving (Eq, Show)
269+
270+instance ToJSON ExecutionHint where
271+ toJSON Ordinals = "ordinals"
272+ toJSON GlobalOrdinals = "global_ordinals"
273+ toJSON GlobalOrdinalsHash = "global_ordinals_hash"
274+ toJSON GlobalOrdinalsLowCardinality = "global_ordinals_low_cardinality"
275+ toJSON Map = "map"
276+
277+-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#date-math> for more information.
278+data DateMathExpr =
279+ DateMathExpr DateMathAnchor [DateMathModifier]
280+ deriving (Eq, Show)
281+
282+instance ToJSON DateMathExpr where
283+ toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))
284+ where fmtA DMNow = "now"
285+ fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"
286+ fmtMod (AddTime n u) = "+" <> showText n <> fmtU u
287+ fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u
288+ fmtMod (RoundDownTo u) = "/" <> fmtU u
289+ fmtU DMYear = "y"
290+ fmtU DMMonth = "M"
291+ fmtU DMWeek = "w"
292+ fmtU DMDay = "d"
293+ fmtU DMHour = "h"
294+ fmtU DMMinute = "m"
295+ fmtU DMSecond = "s"
296+
297+-- | Starting point for a date range. This along with the 'DateMathModifiers' gets you the date ES will start from.
298+data DateMathAnchor =
299+ DMNow
300+ | DMDate Day
301+ deriving (Eq, Show)
302+
303+data DateMathModifier =
304+ AddTime Int DateMathUnit
305+ | SubtractTime Int DateMathUnit
306+ | RoundDownTo DateMathUnit
307+ deriving (Eq, Show)
308+
309+data DateMathUnit =
310+ DMYear
311+ | DMMonth
312+ | DMWeek
313+ | DMDay
314+ | DMHour
315+ | DMMinute
316+ | DMSecond
317+ deriving (Eq, Show)
318+
319+data TermsResult = TermsResult
320+ { termKey :: BucketValue
321+ , termsDocCount :: Int
322+ , termsAggs :: Maybe AggregationResults
323+ } deriving (Read, Show)
324+
325+instance FromJSON TermsResult where
326+ parseJSON (Object v) = TermsResult <$>
327+ v .: "key" <*>
328+ v .: "doc_count" <*>
329+ (pure $ getNamedSubAgg v ["key", "doc_count"])
330+ parseJSON _ = mempty
331+
332+instance BucketAggregation TermsResult where
333+ key = termKey
334+ docCount = termsDocCount
335+ aggs = termsAggs
336+
337+data DateHistogramResult = DateHistogramResult
338+ { dateKey :: Int
339+ , dateKeyStr :: Maybe Text
340+ , dateDocCount :: Int
341+ , dateHistogramAggs :: Maybe AggregationResults
342+ } deriving (Show)
343+
344+instance FromJSON DateHistogramResult where
345+ parseJSON (Object v) = DateHistogramResult <$>
346+ v .: "key" <*>
347+ v .:? "key_as_string" <*>
348+ v .: "doc_count" <*>
349+ (pure $ getNamedSubAgg v [ "key"
350+ , "doc_count"
351+ , "key_as_string"
352+ ]
353+ )
354+ parseJSON _ = mempty
355+
356+instance BucketAggregation DateHistogramResult where
357+ key = TextValue . showText . dateKey
358+ docCount = dateDocCount
359+ aggs = dateHistogramAggs
360+
361+data DateRangeResult = DateRangeResult
362+ { dateRangeKey :: Text
363+ , dateRangeFrom :: Maybe UTCTime
364+ , dateRangeFromAsString :: Maybe Text
365+ , dateRangeTo :: Maybe UTCTime
366+ , dateRangeToAsString :: Maybe Text
367+ , dateRangeDocCount :: Int
368+ , dateRangeAggs :: Maybe AggregationResults
369+ } deriving (Eq, Show)
370+
371+instance FromJSON DateRangeResult where
372+ parseJSON = withObject "DateRangeResult" parse
373+ where parse v = DateRangeResult <$>
374+ v .: "key" <*>
375+ (fmap posixMS <$> v .:? "from") <*>
376+ v .:? "from_as_string" <*>
377+ (fmap posixMS <$> v .:? "to") <*>
378+ v .:? "to_as_string" <*>
379+ v .: "doc_count" <*>
380+ (pure $ getNamedSubAgg v [ "key"
381+ , "from"
382+ , "from_as_string"
383+ , "to"
384+ , "to_as_string"
385+ , "doc_count"
386+ ]
387+ )
388+
389+instance BucketAggregation DateRangeResult where
390+ key = TextValue . dateRangeKey
391+ docCount = dateRangeDocCount
392+ aggs = dateRangeAggs
393+
394+toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
395+toTerms = toAggResult
396+
397+toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
398+toDateHistogram = toAggResult
399+
400+toMissing :: Text -> AggregationResults -> Maybe MissingResult
401+toMissing = toAggResult
402+
403+toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)
404+toTopHits = toAggResult
405+
406+toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a
407+toAggResult t a = M.lookup t a >>= deserialize
408+ where deserialize = parseMaybe parseJSON
409+
410+-- Try to get an AggregationResults when we don't know the
411+-- field name. We filter out the known keys to try to minimize the noise.
412+getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
413+getNamedSubAgg o knownKeys = maggRes
414+ where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
415+ maggRes
416+ | HM.null unknownKeys = Nothing
417+ | otherwise = Just . M.fromList $ HM.toList unknownKeys
418+
419+data MissingResult = MissingResult
420+ { missingDocCount :: Int
421+ } deriving (Show)
422+
423+instance FromJSON MissingResult where
424+ parseJSON = withObject "MissingResult" parse
425+ where parse v = MissingResult <$> v .: "doc_count"
426+
427+data TopHitResult a = TopHitResult
428+ { tarHits :: (SearchHits a)
429+ } deriving Show
430+
431+instance (FromJSON a) => FromJSON (TopHitResult a) where
432+ parseJSON (Object v) = TopHitResult <$>
433+ v .: "hits"
434+ parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"
435+
436+data SearchHits a =
437+ SearchHits { hitsTotal :: Int
438+ , maxScore :: Score
439+ , hits :: [Hit a] } deriving (Eq, Show)
440+
441+
442+instance (FromJSON a) => FromJSON (SearchHits a) where
443+ parseJSON (Object v) = SearchHits <$>
444+ v .: "total" <*>
445+ v .: "max_score" <*>
446+ v .: "hits"
447+ parseJSON _ = empty
448+
449+instance Semigroup (SearchHits a) where
450+ (SearchHits ta ma ha) <> (SearchHits tb mb hb) =
451+ SearchHits (ta + tb) (max ma mb) (ha <> hb)
452+
453+instance Monoid (SearchHits a) where
454+ mempty = SearchHits 0 Nothing mempty
455+ mappend = (<>)
456+
457+type SearchAfterKey = [Aeson.Value]
458+
459+data Hit a =
460+ Hit { hitIndex :: IndexName
461+ , hitType :: MappingName
462+ , hitDocId :: DocId
463+ , hitScore :: Score
464+ , hitSource :: Maybe a
465+ , hitSort :: Maybe SearchAfterKey
466+ , hitFields :: Maybe HitFields
467+ , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
468+
469+instance (FromJSON a) => FromJSON (Hit a) where
470+ parseJSON (Object v) = Hit <$>
471+ v .: "_index" <*>
472+ v .: "_type" <*>
473+ v .: "_id" <*>
474+ v .: "_score" <*>
475+ v .:? "_source" <*>
476+ v .:? "sort" <*>
477+ v .:? "fields" <*>
478+ v .:? "highlight"
479+ parseJSON _ = empty
src/Database/V5/Bloodhound/Internal/Analysis.hs → src/Database/Bloodhound/Internal/Analysis.hsrenamed+82−17
@@ -1,29 +1,29 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3
3
4−module Database.V5.Bloodhound.Internal.Analysis where
4+module Database.Bloodhound.Internal.Analysis where
5+
6+import Bloodhound.Import
5
7
6−import Data.Aeson
7−import Data.Aeson.Types (Parser)
8import qualified Data.Map.Strict as M
8import qualified Data.Map.Strict as M
9−import Data.Maybe (catMaybes)
10−import Data.Text (Text)
11import qualified Data.Text as T
9import qualified Data.Text as T
12
10
13−import Database.V5.Bloodhound.Internal.Newtypes
11+import Database.Bloodhound.Internal.Newtypes
14−import Database.V5.Bloodhound.Internal.StringlyTyped
12+import Database.Bloodhound.Internal.StringlyTyped
15
13
16data Analysis = Analysis
14data Analysis = Analysis
17 { analysisAnalyzer :: M.Map Text AnalyzerDefinition
15 { analysisAnalyzer :: M.Map Text AnalyzerDefinition
18 , analysisTokenizer :: M.Map Text TokenizerDefinition
16 , analysisTokenizer :: M.Map Text TokenizerDefinition
19 , analysisTokenFilter :: M.Map Text TokenFilterDefinition
17 , analysisTokenFilter :: M.Map Text TokenFilterDefinition
18+ , analysisCharFilter :: M.Map Text CharFilterDefinition
20 } deriving (Eq, Show)
19 } deriving (Eq, Show)
21
20
22instance ToJSON Analysis where
21instance ToJSON Analysis where
23− toJSON (Analysis analyzer tokenizer tokenFilter) = object
22+ toJSON (Analysis analyzer tokenizer tokenFilter charFilter) = object
24 [ "analyzer" .= analyzer
23 [ "analyzer" .= analyzer
25 , "tokenizer" .= tokenizer
24 , "tokenizer" .= tokenizer
26 , "filter" .= tokenFilter
25 , "filter" .= tokenFilter
26+ , "char_filter" .= charFilter
27 ]
27 ]
28
28
29instance FromJSON Analysis where
29instance FromJSON Analysis where
@@ -31,6 +31,7 @@ instance FromJSON Analysis where
31 <$> m .: "analyzer"
31 <$> m .: "analyzer"
32 <*> m .:? "tokenizer" .!= M.empty
32 <*> m .:? "tokenizer" .!= M.empty
33 <*> m .:? "filter" .!= M.empty
33 <*> m .:? "filter" .!= M.empty
34+ <*> m .:? "char_filter" .!= M.empty
34
35
35newtype Tokenizer =
36newtype Tokenizer =
36 Tokenizer Text
37 Tokenizer Text
@@ -39,21 +40,60 @@ newtype Tokenizer =
39data AnalyzerDefinition = AnalyzerDefinition
40data AnalyzerDefinition = AnalyzerDefinition
40 { analyzerDefinitionTokenizer :: Maybe Tokenizer
41 { analyzerDefinitionTokenizer :: Maybe Tokenizer
41 , analyzerDefinitionFilter :: [TokenFilter]
42 , analyzerDefinitionFilter :: [TokenFilter]
43+ , analyzerDefinitionCharFilter :: [CharFilter]
42 } deriving (Eq,Show)
44 } deriving (Eq,Show)
43
45
44instance ToJSON AnalyzerDefinition where
46instance ToJSON AnalyzerDefinition where
45− toJSON (AnalyzerDefinition tokenizer tokenFilter) = object $ catMaybes
47+ toJSON (AnalyzerDefinition tokenizer tokenFilter charFilter) =
48+ object $ catMaybes
46 [ fmap ("tokenizer" .=) tokenizer
49 [ fmap ("tokenizer" .=) tokenizer
47 , Just $ "filter" .= tokenFilter
50 , Just $ "filter" .= tokenFilter
51+ , Just $ "char_filter" .= charFilter
48 ]
52 ]
49
53
50instance FromJSON AnalyzerDefinition where
54instance FromJSON AnalyzerDefinition where
51 parseJSON = withObject "AnalyzerDefinition" $ \m -> AnalyzerDefinition
55 parseJSON = withObject "AnalyzerDefinition" $ \m -> AnalyzerDefinition
52 <$> m .:? "tokenizer"
56 <$> m .:? "tokenizer"
53 <*> m .:? "filter" .!= []
57 <*> m .:? "filter" .!= []
58+ <*> m .:? "char_filter" .!= []
59+
60+-- | Character filters are used to preprocess the stream of characters
61+-- before it is passed to the tokenizer.
62+data CharFilterDefinition
63+ = CharFilterDefinitionMapping (M.Map Text Text)
64+ | CharFilterDefinitionPatternReplace
65+ { charFilterDefinitionPatternReplacePattern :: Text
66+ , charFilterDefinitionPatternReplaceReplacement :: Text
67+ , charFilterDefinitionPatternReplaceFlags :: Maybe Text
68+ }
69+ deriving (Eq, Show)
54
70
71+instance ToJSON CharFilterDefinition where
72+ toJSON (CharFilterDefinitionMapping ms) = object
73+ [ "type" .= ("mapping" :: Text)
74+ , "mappings" .= [a <> " => " <> b | (a, b) <- M.toList ms] ]
75+ toJSON (CharFilterDefinitionPatternReplace pat repl flags) = object $
76+ [ "type" .= ("pattern_replace" :: Text)
77+ , "pattern" .= pat
78+ , "replacement" .= repl
79+ ] ++ maybe [] (\f -> ["flags" .= f]) flags
80+
81+instance FromJSON CharFilterDefinition where
82+ parseJSON = withObject "CharFilterDefinition" $ \m -> do
83+ t <- m .: "type"
84+ case (t :: Text) of
85+ "mapping" -> CharFilterDefinitionMapping . M.fromList <$> ms
86+ where
87+ ms = m .: "mappings" >>= mapM parseMapping
88+ parseMapping kv = case T.splitOn "=>" kv of
89+ (k:vs) -> pure (T.strip k, T.strip $ T.concat vs)
90+ _ -> fail "mapping is not of the format key => value"
91+ "pattern_replace" -> CharFilterDefinitionPatternReplace
92+ <$> m .: "pattern" <*> m .: "replacement" <*> m .:? "flags"
93+ _ -> fail ("unrecognized character filter type: " ++ T.unpack t)
94+
55−data TokenizerDefinition
95+newtype TokenizerDefinition =
56− = TokenizerDefinitionNgram Ngram
96+ TokenizerDefinitionNgram Ngram
57 deriving (Eq,Show)
97 deriving (Eq,Show)
58
98
59instance ToJSON TokenizerDefinition where
99instance ToJSON TokenizerDefinition where
@@ -70,8 +110,8 @@ instance FromJSON TokenizerDefinition where
70 typ <- m .: "type" :: Parser Text
110 typ <- m .: "type" :: Parser Text
71 case typ of
111 case typ of
72 "ngram" -> fmap TokenizerDefinitionNgram $ Ngram
112 "ngram" -> fmap TokenizerDefinitionNgram $ Ngram
73− <$> (fmap unStringlyTypedInt (m .: "min_gram"))
113+ <$> fmap unStringlyTypedInt (m .: "min_gram")
74− <*> (fmap unStringlyTypedInt (m .: "max_gram"))
114+ <*> fmap unStringlyTypedInt (m .: "max_gram")
75 <*> m .: "token_chars"
115 <*> m .: "token_chars"
76 _ -> fail "invalid TokenizerDefinition"
116 _ -> fail "invalid TokenizerDefinition"
77
117
@@ -114,6 +154,8 @@ data TokenFilterDefinition
114 | TokenFilterDefinitionReverse
154 | TokenFilterDefinitionReverse
115 | TokenFilterDefinitionSnowball Language
155 | TokenFilterDefinitionSnowball Language
116 | TokenFilterDefinitionShingle Shingle
156 | TokenFilterDefinitionShingle Shingle
157+ | TokenFilterDefinitionStemmer Language
158+ | TokenFilterDefinitionStop (Either Language [StopWord])
117 deriving (Eq, Show)
159 deriving (Eq, Show)
118
160
119instance ToJSON TokenFilterDefinition where
161instance ToJSON TokenFilterDefinition where
@@ -145,6 +187,16 @@ instance ToJSON TokenFilterDefinition where
145 , "token_separator" .= shingleTokenSeparator s
187 , "token_separator" .= shingleTokenSeparator s
146 , "filler_token" .= shingleFillerToken s
188 , "filler_token" .= shingleFillerToken s
147 ]
189 ]
190+ TokenFilterDefinitionStemmer lang -> object
191+ [ "type" .= ("stemmer" :: Text)
192+ , "language" .= languageToText lang
193+ ]
194+ TokenFilterDefinitionStop stop -> object
195+ [ "type" .= ("stop" :: Text)
196+ , "stopwords" .= case stop of
197+ Left lang -> String $ "_" <> languageToText lang <> "_"
198+ Right stops -> toJSON stops
199+ ]
148
200
149instance FromJSON TokenFilterDefinition where
201instance FromJSON TokenFilterDefinition where
150 parseJSON = withObject "TokenFilterDefinition" $ \m -> do
202 parseJSON = withObject "TokenFilterDefinition" $ \m -> do
@@ -165,13 +217,26 @@ instance FromJSON TokenFilterDefinition where
165 <*> (fmap.fmap) unStringlyTypedBool (m .:? "output_unigrams_if_no_shingles") .!= False
217 <*> (fmap.fmap) unStringlyTypedBool (m .:? "output_unigrams_if_no_shingles") .!= False
166 <*> m .:? "token_separator" .!= " "
218 <*> m .:? "token_separator" .!= " "
167 <*> m .:? "filler_token" .!= "_"
219 <*> m .:? "filler_token" .!= "_"
220+ "stemmer" -> TokenFilterDefinitionStemmer
221+ <$> m .: "language"
222+ "stop" -> do
223+ stop <- m .: "stopwords"
224+ stop' <- case stop of
225+ String lang ->
226+ fmap Left
227+ . parseJSON
228+ . String
229+ . T.drop 1
230+ . T.dropEnd 1 $ lang
231+ _ -> Right <$> parseJSON stop
232+ return (TokenFilterDefinitionStop stop')
168 _ -> fail ("unrecognized token filter type: " ++ T.unpack t)
233 _ -> fail ("unrecognized token filter type: " ++ T.unpack t)
169
234
170-- | The set of languages that can be passed to various analyzers,
235-- | The set of languages that can be passed to various analyzers,
171−-- filters, etc. in ElasticSearch. Most data types in this module
236+-- filters, etc. in Elasticsearch. Most data types in this module
172-- that have a 'Language' field are actually only actually to
237-- that have a 'Language' field are actually only actually to
173-- handle a subset of these languages. Consult the official
238-- handle a subset of these languages. Consult the official
174−-- ElasticSearch documentation to see what is actually supported.
239+-- Elasticsearch documentation to see what is actually supported.
175data Language
240data Language
176 = Arabic
241 = Arabic
177 | Armenian
242 | Armenian
@@ -214,11 +279,11 @@ data Language
214 deriving (Eq, Show)
279 deriving (Eq, Show)
215
280
216instance ToJSON Language where
281instance ToJSON Language where
217− toJSON = Data.Aeson.String . languageToText
282+ toJSON = String . languageToText
218
283
219instance FromJSON Language where
284instance FromJSON Language where
220 parseJSON = withText "Language" $ \t -> case languageFromText t of
285 parseJSON = withText "Language" $ \t -> case languageFromText t of
221− Nothing -> fail "not a supported ElasticSearch language"
286+ Nothing -> fail "not a supported Elasticsearch language"
222 Just lang -> return lang
287 Just lang -> return lang
223
288
224languageToText :: Language -> Text
289languageToText :: Language -> Text
src/Database/V5/Bloodhound/Internal/Client.hs → src/Database/Bloodhound/Internal/Client.hsrenamed+446−94
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
@@ -5,24 +6,29 @@
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE UndecidableInstances #-}
7{-# LANGUAGE UndecidableInstances #-}
7
8
8−module Database.V5.Bloodhound.Internal.Client where
9+module Database.Bloodhound.Internal.Client where
9
10
10import Bloodhound.Import
11import Bloodhound.Import
11
12
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
12import qualified Data.Text as T
18import qualified Data.Text as T
19+import qualified Data.Traversable as DT
13import qualified Data.HashMap.Strict as HM
20import qualified Data.HashMap.Strict as HM
21+import qualified Data.SemVer as SemVer
14import qualified Data.Vector as V
22import qualified Data.Vector as V
15−import qualified Data.Version as Vers
16import GHC.Enum
23import GHC.Enum
17import Network.HTTP.Client
24import Network.HTTP.Client
18−import qualified Text.ParserCombinators.ReadP as RP
19import Text.Read (Read(..))
25import Text.Read (Read(..))
20import qualified Text.Read as TR
26import qualified Text.Read as TR
21
27
22−import Database.V5.Bloodhound.Internal.Analysis
28+import Database.Bloodhound.Internal.Analysis
23−import Database.V5.Bloodhound.Internal.Newtypes
29+import Database.Bloodhound.Internal.Newtypes
24−import Database.V5.Bloodhound.Internal.Query
30+import Database.Bloodhound.Internal.Query
25−import Database.V5.Bloodhound.Internal.StringlyTyped
31+import Database.Bloodhound.Internal.StringlyTyped
26
32
27{-| Common environment for Elasticsearch calls. Connections will be
33{-| Common environment for Elasticsearch calls. Connections will be
28 pipelined according to the provided HTTP connection manager.
34 pipelined according to the provided HTTP connection manager.
@@ -71,6 +77,11 @@ newtype BH m a = BH {
71 , MonadFix
77 , MonadFix
72 , MonadThrow
78 , MonadThrow
73 , MonadCatch
79 , MonadCatch
80+#if defined(MIN_VERSION_GLASGOW_HASKELL)
81+#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)
82+ , MonadFail
83+#endif
84+#endif
74 , MonadMask)
85 , MonadMask)
75
86
76instance MonadTrans BH where
87instance MonadTrans BH where
@@ -97,7 +108,7 @@ data Version = Version { number :: VersionNumber
97
108
98-- | Traditional software versioning number
109-- | Traditional software versioning number
99newtype VersionNumber = VersionNumber
110newtype VersionNumber = VersionNumber
100− { versionNumber :: Vers.Version }
111+ { versionNumber :: SemVer.Version }
101 deriving (Eq, Ord, Show)
112 deriving (Eq, Ord, Show)
102
113
103{-| 'Status' is a data type for describing the JSON body returned by
114{-| 'Status' is a data type for describing the JSON body returned by
@@ -114,6 +125,15 @@ data Status = Status
114 , tagline :: Text }
125 , tagline :: Text }
115 deriving (Eq, Show)
126 deriving (Eq, Show)
116
127
128+instance FromJSON Status where
129+ parseJSON (Object v) = Status <$>
130+ v .: "name" <*>
131+ v .: "cluster_name" <*>
132+ v .: "cluster_uuid" <*>
133+ v .: "version" <*>
134+ v .: "tagline"
135+ parseJSON _ = empty
136+
117{-| 'IndexSettings' is used to configure the shards and replicas when
137{-| 'IndexSettings' is used to configure the shards and replicas when
118 you create an Elasticsearch Index.
138 you create an Elasticsearch Index.
119
139
@@ -125,6 +145,20 @@ data IndexSettings = IndexSettings
125 , indexReplicas :: ReplicaCount }
145 , indexReplicas :: ReplicaCount }
126 deriving (Eq, Show)
146 deriving (Eq, Show)
127
147
148+instance ToJSON IndexSettings where
149+ toJSON (IndexSettings s r) = object ["settings" .=
150+ object ["index" .=
151+ object ["number_of_shards" .= s, "number_of_replicas" .= r]
152+ ]
153+ ]
154+
155+instance FromJSON IndexSettings where
156+ parseJSON = withObject "IndexSettings" parse
157+ where parse o = do s <- o .: "settings"
158+ i <- s .: "index"
159+ IndexSettings <$> i .: "number_of_shards"
160+ <*> i .: "number_of_replicas"
161+
128{-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and
162{-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and
129 2 replicas. -}
163 2 replicas. -}
130defaultIndexSettings :: IndexSettings
164defaultIndexSettings :: IndexSettings
@@ -148,7 +182,7 @@ data ForceMergeIndexSettings =
148
182
149
183
150{-| 'defaultForceMergeIndexSettings' implements the default settings that
184{-| 'defaultForceMergeIndexSettings' implements the default settings that
151− ElasticSearch uses for index optimization. 'maxNumSegments' is Nothing,
185+ Elasticsearch uses for index optimization. 'maxNumSegments' is Nothing,
152 'onlyExpungeDeletes' is False, and flushAfterOptimize is True.
186 'onlyExpungeDeletes' is False, and flushAfterOptimize is True.
153-}
187-}
154defaultForceMergeIndexSettings :: ForceMergeIndexSettings
188defaultForceMergeIndexSettings :: ForceMergeIndexSettings
@@ -212,11 +246,146 @@ data UpdatableIndexSetting = NumberOfReplicas ReplicaCount
212 -- ^ Analysis is not a dynamic setting and can only be performed on a closed index.
246 -- ^ Analysis is not a dynamic setting and can only be performed on a closed index.
213 deriving (Eq, Show)
247 deriving (Eq, Show)
214
248
249+attrFilterJSON :: NonEmpty NodeAttrFilter -> Value
250+attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)
251+ | NodeAttrFilter (NodeAttrName n) vs <- toList fs]
252+
253+parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)
254+parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse
255+ where parse o = case HM.toList o of
256+ [] -> fail "Expected non-empty list of NodeAttrFilters"
257+ x:xs -> DT.mapM (uncurry parse') (x :| xs)
258+ parse' n = withText "Text" $ \t ->
259+ case T.splitOn "," t of
260+ fv:fvs -> return (NodeAttrFilter (NodeAttrName n) (fv :| fvs))
261+ [] -> fail "Expected non-empty list of filter values"
262+
263+instance ToJSON UpdatableIndexSetting where
264+ toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x
265+ toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x
266+ toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x)
267+ toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x
268+ toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x
269+ toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x
270+ toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x
271+ toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x)
272+ toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x
273+ toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x
274+ toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x)
275+ toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x)
276+ toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs)
277+ toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs)
278+ toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs)
279+ toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x
280+ toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x
281+ toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x
282+ toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x)
283+ toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x
284+ toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x
285+ toJSON (CompressionSetting x) = oPath ("index" :| ["codec"]) x
286+ toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x
287+ toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x
288+ toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x
289+ toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x
290+ toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x
291+ toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x
292+ toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x
293+ toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping","total_fields","limit"]) x
294+ toJSON (AnalysisSetting x) = oPath ("index" :| ["analysis"]) x
295+
296+instance FromJSON UpdatableIndexSetting where
297+ parseJSON = withObject "UpdatableIndexSetting" parse
298+ where parse o = numberOfReplicas `taggedAt` ["index", "number_of_replicas"]
299+ <|> autoExpandReplicas `taggedAt` ["index", "auto_expand_replicas"]
300+ <|> refreshInterval `taggedAt` ["index", "refresh_interval"]
301+ <|> indexConcurrency `taggedAt` ["index", "concurrency"]
302+ <|> failOnMergeFailure `taggedAt` ["index", "fail_on_merge_failure"]
303+ <|> translogFlushThresholdOps `taggedAt` ["index", "translog", "flush_threshold_ops"]
304+ <|> translogFlushThresholdSize `taggedAt` ["index", "translog", "flush_threshold_size"]
305+ <|> translogFlushThresholdPeriod `taggedAt` ["index", "translog", "flush_threshold_period"]
306+ <|> translogDisableFlush `taggedAt` ["index", "translog", "disable_flush"]
307+ <|> cacheFilterMaxSize `taggedAt` ["index", "cache", "filter", "max_size"]
308+ <|> cacheFilterExpire `taggedAt` ["index", "cache", "filter", "expire"]
309+ <|> gatewaySnapshotInterval `taggedAt` ["index", "gateway", "snapshot_interval"]
310+ <|> routingAllocationInclude `taggedAt` ["index", "routing", "allocation", "include"]
311+ <|> routingAllocationExclude `taggedAt` ["index", "routing", "allocation", "exclude"]
312+ <|> routingAllocationRequire `taggedAt` ["index", "routing", "allocation", "require"]
313+ <|> routingAllocationEnable `taggedAt` ["index", "routing", "allocation", "enable"]
314+ <|> routingAllocationShardsPerNode `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"]
315+ <|> recoveryInitialShards `taggedAt` ["index", "recovery", "initial_shards"]
316+ <|> gcDeletes `taggedAt` ["index", "gc_deletes"]
317+ <|> ttlDisablePurge `taggedAt` ["index", "ttl", "disable_purge"]
318+ <|> translogFSType `taggedAt` ["index", "translog", "fs", "type"]
319+ <|> compressionSetting `taggedAt` ["index", "codec"]
320+ <|> compoundFormat `taggedAt` ["index", "compound_format"]
321+ <|> compoundOnFlush `taggedAt` ["index", "compound_on_flush"]
322+ <|> warmerEnabled `taggedAt` ["index", "warmer", "enabled"]
323+ <|> blocksReadOnly `taggedAt` ["blocks", "read_only"]
324+ <|> blocksRead `taggedAt` ["blocks", "read"]
325+ <|> blocksWrite `taggedAt` ["blocks", "write"]
326+ <|> blocksMetaData `taggedAt` ["blocks", "metadata"]
327+ <|> mappingTotalFieldsLimit `taggedAt` ["index", "mapping", "total_fields", "limit"]
328+ <|> analysisSetting `taggedAt` ["index", "analysis"]
329+ where taggedAt f ks = taggedAt' f (Object o) ks
330+ taggedAt' f v [] =
331+ f =<< (parseJSON v <|> parseJSON (unStringlyTypeJSON v))
332+ taggedAt' f v (k:ks) =
333+ withObject "Object" (\o -> do v' <- o .: k
334+ taggedAt' f v' ks) v
335+ numberOfReplicas = pure . NumberOfReplicas
336+ autoExpandReplicas = pure . AutoExpandReplicas
337+ refreshInterval = pure . RefreshInterval . ndtJSON
338+ indexConcurrency = pure . IndexConcurrency
339+ failOnMergeFailure = pure . FailOnMergeFailure
340+ translogFlushThresholdOps = pure . TranslogFlushThresholdOps
341+ translogFlushThresholdSize = pure . TranslogFlushThresholdSize
342+ translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON
343+ translogDisableFlush = pure . TranslogDisableFlush
344+ cacheFilterMaxSize = pure . CacheFilterMaxSize
345+ cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON
346+ gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON
347+ routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter
348+ routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter
349+ routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter
350+ routingAllocationEnable = pure . RoutingAllocationEnable
351+ routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode
352+ recoveryInitialShards = pure . RecoveryInitialShards
353+ gcDeletes = pure . GCDeletes . ndtJSON
354+ ttlDisablePurge = pure . TTLDisablePurge
355+ translogFSType = pure . TranslogFSType
356+ compressionSetting = pure . CompressionSetting
357+ compoundFormat = pure . IndexCompoundFormat
358+ compoundOnFlush = pure . IndexCompoundOnFlush
359+ warmerEnabled = pure . WarmerEnabled
360+ blocksReadOnly = pure . BlocksReadOnly
361+ blocksRead = pure . BlocksRead
362+ blocksWrite = pure . BlocksWrite
363+ blocksMetaData = pure . BlocksMetaData
364+ mappingTotalFieldsLimit = pure . MappingTotalFieldsLimit
365+ analysisSetting = pure . AnalysisSetting
366+
215data ReplicaBounds = ReplicasBounded Int Int
367data ReplicaBounds = ReplicasBounded Int Int
216 | ReplicasLowerBounded Int
368 | ReplicasLowerBounded Int
217 | ReplicasUnbounded
369 | ReplicasUnbounded
218 deriving (Eq, Show)
370 deriving (Eq, Show)
219
371
372+
373+instance ToJSON ReplicaBounds where
374+ toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b)
375+ toJSON (ReplicasLowerBounded a) = String (showText a <> "-all")
376+ toJSON ReplicasUnbounded = Bool False
377+
378+instance FromJSON ReplicaBounds where
379+ parseJSON v = withText "ReplicaBounds" parseText v
380+ <|> withBool "ReplicaBounds" parseBool v
381+ where parseText t = case T.splitOn "-" t of
382+ [a, "all"] -> ReplicasLowerBounded <$> parseReadText a
383+ [a, b] -> ReplicasBounded <$> parseReadText a
384+ <*> parseReadText b
385+ _ -> fail ("Could not parse ReplicaBounds: " <> show t)
386+ parseBool False = pure ReplicasUnbounded
387+ parseBool _ = fail "ReplicasUnbounded cannot be represented with True"
388+
220data Compression
389data Compression
221 = CompressionDefault
390 = CompressionDefault
222 -- ^ Compress with LZ4
391 -- ^ Compress with LZ4
@@ -267,6 +436,16 @@ kilobytes n = Bytes (1000 * n)
267data FSType = FSSimple
436data FSType = FSSimple
268 | FSBuffered deriving (Eq, Show)
437 | FSBuffered deriving (Eq, Show)
269
438
439+instance ToJSON FSType where
440+ toJSON FSSimple = "simple"
441+ toJSON FSBuffered = "buffered"
442+
443+instance FromJSON FSType where
444+ parseJSON = withText "FSType" parse
445+ where parse "simple" = pure FSSimple
446+ parse "buffered" = pure FSBuffered
447+ parse t = fail ("Invalid FSType: " <> show t)
448+
270data InitialShardCount = QuorumShards
449data InitialShardCount = QuorumShards
271 | QuorumMinus1Shards
450 | QuorumMinus1Shards
272 | FullShards
451 | FullShards
@@ -274,6 +453,22 @@ data InitialShardCount = QuorumShards
274 | ExplicitShards Int
453 | ExplicitShards Int
275 deriving (Eq, Show)
454 deriving (Eq, Show)
276
455
456+instance FromJSON InitialShardCount where
457+ parseJSON v = withText "InitialShardCount" parseText v
458+ <|> ExplicitShards <$> parseJSON v
459+ where parseText "quorum" = pure QuorumShards
460+ parseText "quorum-1" = pure QuorumMinus1Shards
461+ parseText "full" = pure FullShards
462+ parseText "full-1" = pure FullMinus1Shards
463+ parseText _ = mzero
464+
465+instance ToJSON InitialShardCount where
466+ toJSON QuorumShards = String "quorum"
467+ toJSON QuorumMinus1Shards = String "quorum-1"
468+ toJSON FullShards = String "full"
469+ toJSON FullMinus1Shards = String "full-1"
470+ toJSON (ExplicitShards x) = toJSON x
471+
277data NodeAttrFilter = NodeAttrFilter
472data NodeAttrFilter = NodeAttrFilter
278 { nodeAttrFilterName :: NodeAttrName
473 { nodeAttrFilterName :: NodeAttrName
279 , nodeAttrFilterValues :: NonEmpty Text }
474 , nodeAttrFilterValues :: NonEmpty Text }
@@ -286,12 +481,52 @@ data CompoundFormat = CompoundFileFormat Bool
286 -- ^ percentage between 0 and 1 where 0 is false, 1 is true
481 -- ^ percentage between 0 and 1 where 0 is false, 1 is true
287 deriving (Eq, Show)
482 deriving (Eq, Show)
288
483
289−newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }
484+instance ToJSON CompoundFormat where
485+ toJSON (CompoundFileFormat x) = Bool x
486+ toJSON (MergeSegmentVsTotalIndex x) = toJSON x
290
487
488+instance FromJSON CompoundFormat where
489+ parseJSON v = CompoundFileFormat <$> parseJSON v
490+ <|> MergeSegmentVsTotalIndex <$> parseJSON v
491+
492+newtype NominalDiffTimeJSON =
493+ NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }
494+
495+instance ToJSON NominalDiffTimeJSON where
496+ toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s")
497+
498+instance FromJSON NominalDiffTimeJSON where
499+ parseJSON = withText "NominalDiffTime" parse
500+ where parse t = case T.takeEnd 1 t of
501+ "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t)
502+ _ -> fail "Invalid or missing NominalDiffTime unit (expected s)"
503+
291−data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName
504+data IndexSettingsSummary = IndexSettingsSummary
505+ { sSummaryIndexName :: IndexName
292− , sSummaryFixedSettings :: IndexSettings
506+ , sSummaryFixedSettings :: IndexSettings
293− , sSummaryUpdateable :: [UpdatableIndexSetting]}
507+ , sSummaryUpdateable :: [UpdatableIndexSetting]}
294− deriving (Eq, Show)
508+ deriving (Eq, Show)
509+
510+parseSettings :: Object -> Parser [UpdatableIndexSetting]
511+parseSettings o = do
512+ o' <- o .: "index"
513+ -- slice the index object into singleton hashmaps and try to parse each
514+ parses <- forM (HM.toList o') $ \(k, v) -> do
515+ -- blocks are now nested into the "index" key, which is not how they're serialized
516+ let atRoot = Object (HM.singleton k v)
517+ let atIndex = Object (HM.singleton "index" atRoot)
518+ optional (parseJSON atRoot <|> parseJSON atIndex)
519+ return (catMaybes parses)
520+
521+instance FromJSON IndexSettingsSummary where
522+ parseJSON = withObject "IndexSettingsSummary" parse
523+ where parse o = case HM.toList o of
524+ [(ixn, v@(Object o'))] -> IndexSettingsSummary (IndexName ixn)
525+ <$> parseJSON v
526+ <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")
527+ _ -> fail "Expected single-key object with index name"
528+ redundant (NumberOfReplicas _) = True
529+ redundant _ = False
295
530
296{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -}
531{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -}
297type Reply = Network.HTTP.Client.Response LByteString
532type Reply = Network.HTTP.Client.Response LByteString
@@ -310,8 +545,9 @@ data FieldType = GeoPointType
310 | ShortType
545 | ShortType
311 | ByteType deriving (Eq, Show)
546 | ByteType deriving (Eq, Show)
312
547
313−data FieldDefinition =
548+newtype FieldDefinition = FieldDefinition
314− FieldDefinition { fieldType :: FieldType } deriving (Eq, Show)
549+ { fieldType :: FieldType
550+ } deriving (Eq, Show)
315
551
316{-| An 'IndexTemplate' defines a template that will automatically be
552{-| An 'IndexTemplate' defines a template that will automatically be
317 applied to new indices created. The templates include both
553 applied to new indices created. The templates include both
@@ -327,6 +563,17 @@ data IndexTemplate =
327 , templateMappings :: [Value]
563 , templateMappings :: [Value]
328 }
564 }
329
565
566+instance ToJSON IndexTemplate where
567+ toJSON (IndexTemplate p s m) = merge
568+ (object [ "template" .= p
569+ , "mappings" .= foldl' merge (object []) m
570+ ])
571+ (toJSON s)
572+ where
573+ merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2
574+ merge o Null = o
575+ merge _ _ = undefined
576+
330data MappingField =
577data MappingField =
331 MappingField { mappingFieldName :: FieldName
578 MappingField { mappingFieldName :: FieldName
332 , fieldDefinition :: FieldDefinition }
579 , fieldDefinition :: FieldDefinition }
@@ -355,15 +602,29 @@ data AllocationPolicy = AllocAll
355 -- ^ No shard allocation is allowed
602 -- ^ No shard allocation is allowed
356 deriving (Eq, Show)
603 deriving (Eq, Show)
357
604
605+instance ToJSON AllocationPolicy where
606+ toJSON AllocAll = String "all"
607+ toJSON AllocPrimaries = String "primaries"
608+ toJSON AllocNewPrimaries = String "new_primaries"
609+ toJSON AllocNone = String "none"
610+
611+instance FromJSON AllocationPolicy where
612+ parseJSON = withText "AllocationPolicy" parse
613+ where parse "all" = pure AllocAll
614+ parse "primaries" = pure AllocPrimaries
615+ parse "new_primaries" = pure AllocNewPrimaries
616+ parse "none" = pure AllocNone
617+ parse t = fail ("Invlaid AllocationPolicy: " <> show t)
618+
358{-| 'BulkOperation' is a sum type for expressing the four kinds of bulk
619{-| 'BulkOperation' is a sum type for expressing the four kinds of bulk
359 operation index, create, delete, and update. 'BulkIndex' behaves like an
620 operation index, create, delete, and update. 'BulkIndex' behaves like an
360 "upsert", 'BulkCreate' will fail if a document already exists at the DocId.
621 "upsert", 'BulkCreate' will fail if a document already exists at the DocId.
361 Consult the <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html#docs-bulk Bulk API documentation>
622 Consult the <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html#docs-bulk Bulk API documentation>
362 for further explanation.
623 for further explanation.
363− Warning: Bulk operations suffixed with @Auto@ rely on ElasticSearch to
624+ Warning: Bulk operations suffixed with @Auto@ rely on Elasticsearch to
364 generate the id. Often, people use auto-generated identifiers when
625 generate the id. Often, people use auto-generated identifiers when
365− ElasticSearch is the only place that their data is stored. Do not let
626+ Elasticsearch is the only place that their data is stored. Do not let
366− ElasticSearch be the only place your data is stored. It does not guarantee
627+ Elasticsearch be the only place your data is stored. It does not guarantee
367 durability, and it may silently discard data.
628 durability, and it may silently discard data.
368 This <https://github.com/elastic/elasticsearch/issues/10708 issue> is
629 This <https://github.com/elastic/elasticsearch/issues/10708 issue> is
369 discussed further on github.
630 discussed further on github.
@@ -401,6 +662,24 @@ data EsResultFound a =
401 , _source :: a }
662 , _source :: a }
402 deriving (Eq, Show)
663 deriving (Eq, Show)
403
664
665+instance (FromJSON a) => FromJSON (EsResult a) where
666+ parseJSON jsonVal@(Object v) = do
667+ found <- v .:? "found" .!= False
668+ fr <- if found
669+ then parseJSON jsonVal
670+ else return Nothing
671+ EsResult <$> v .: "_index" <*>
672+ v .: "_type" <*>
673+ v .: "_id" <*>
674+ pure fr
675+ parseJSON _ = empty
676+
677+instance (FromJSON a) => FromJSON (EsResultFound a) where
678+ parseJSON (Object v) = EsResultFound <$>
679+ v .: "_version" <*>
680+ v .: "_source"
681+ parseJSON _ = empty
682+
404{-| 'EsError' is the generic type that will be returned when there was a
683{-| 'EsError' is the generic type that will be returned when there was a
405 problem. If you can't parse the expected response, its a good idea to
684 problem. If you can't parse the expected response, its a good idea to
406 try parsing this.
685 try parsing this.
@@ -410,16 +689,24 @@ data EsError =
410 , errorMessage :: Text }
689 , errorMessage :: Text }
411 deriving (Eq, Show)
690 deriving (Eq, Show)
412
691
692+instance FromJSON EsError where
693+ parseJSON (Object v) = EsError <$>
694+ v .: "status" <*>
695+ (v .: "error" <|> (v .: "error" >>= (.: "reason")))
696+ parseJSON _ = empty
697+
413{-| 'EsProtocolException' will be thrown if Bloodhound cannot parse a response
698{-| 'EsProtocolException' will be thrown if Bloodhound cannot parse a response
414−returned by the ElasticSearch server. If you encounter this error, please
699+returned by the Elasticsearch server. If you encounter this error, please
415verify that your domain data types and FromJSON instances are working properly
700verify that your domain data types and FromJSON instances are working properly
416(for example, the 'a' of '[Hit a]' in 'SearchResult.searchHits.hits'). If you're
701(for example, the 'a' of '[Hit a]' in 'SearchResult.searchHits.hits'). If you're
417sure that your mappings are correct, then this error may be an indication of an
702sure that your mappings are correct, then this error may be an indication of an
418−incompatibility between Bloodhound and ElasticSearch. Please open a bug report
703+incompatibility between Bloodhound and Elasticsearch. Please open a bug report
419and be sure to include the exception body.
704and be sure to include the exception body.
420-}
705-}
421−data EsProtocolException = EsProtocolException { esProtoExBody :: LByteString }
706+data EsProtocolException = EsProtocolException
707+ { esProtoExMessage :: !Text
708+ , esProtoExBody :: !LByteString
422− deriving (Eq, Show)
709+ } deriving (Eq, Show)
423
710
424instance Exception EsProtocolException
711instance Exception EsProtocolException
425
712
@@ -445,6 +732,13 @@ newtype SearchAliasRouting =
445 SearchAliasRouting (NonEmpty RoutingValue)
732 SearchAliasRouting (NonEmpty RoutingValue)
446 deriving (Eq, Show)
733 deriving (Eq, Show)
447
734
735+instance ToJSON SearchAliasRouting where
736+ toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs))
737+
738+instance FromJSON SearchAliasRouting where
739+ parseJSON = withText "SearchAliasRouting" parse
740+ where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)
741+
448newtype IndexAliasRouting =
742newtype IndexAliasRouting =
449 IndexAliasRouting RoutingValue
743 IndexAliasRouting RoutingValue
450 deriving (Eq, Show, ToJSON, FromJSON)
744 deriving (Eq, Show, ToJSON, FromJSON)
@@ -457,6 +751,55 @@ newtype IndexAliasesSummary =
457 IndexAliasesSummary { indexAliasesSummary :: [IndexAliasSummary] }
751 IndexAliasesSummary { indexAliasesSummary :: [IndexAliasSummary] }
458 deriving (Eq, Show)
752 deriving (Eq, Show)
459
753
754+instance FromJSON IndexAliasesSummary where
755+ parseJSON = withObject "IndexAliasesSummary" parse
756+ where parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (HM.toList o)
757+ go ixn = withObject "index aliases" $ \ia -> do
758+ aliases <- ia .:? "aliases" .!= mempty
759+ forM (HM.toList aliases) $ \(aName, v) -> do
760+ let indexAlias = IndexAlias (IndexName ixn) (IndexAliasName (IndexName aName))
761+ IndexAliasSummary indexAlias <$> parseJSON v
762+
763+
764+instance ToJSON IndexAliasAction where
765+ toJSON (AddAlias ia opts) = object ["add" .= (iaObj <> optsObj)]
766+ where Object iaObj = toJSON ia
767+ Object optsObj = toJSON opts
768+ toJSON (RemoveAlias ia) = object ["remove" .= iaObj]
769+ where Object iaObj = toJSON ia
770+
771+instance ToJSON IndexAlias where
772+ toJSON IndexAlias {..} = object ["index" .= srcIndex
773+ , "alias" .= indexAlias
774+ ]
775+
776+instance ToJSON IndexAliasCreate where
777+ toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj)
778+ where filterObj = maybe mempty (HM.singleton "filter" . toJSON) aliasCreateFilter
779+ Object routingObj = maybe (Object mempty) toJSON aliasCreateRouting
780+
781+instance ToJSON AliasRouting where
782+ toJSON (AllAliasRouting v) = object ["routing" .= v]
783+ toJSON (GranularAliasRouting srch idx) = object (catMaybes prs)
784+ where prs = [("search_routing" .=) <$> srch
785+ ,("index_routing" .=) <$> idx]
786+
787+instance FromJSON AliasRouting where
788+ parseJSON = withObject "AliasRouting" parse
789+ where parse o = parseAll o <|> parseGranular o
790+ parseAll o = AllAliasRouting <$> o .: "routing"
791+ parseGranular o = do
792+ sr <- o .:? "search_routing"
793+ ir <- o .:? "index_routing"
794+ if isNothing sr && isNothing ir
795+ then fail "Both search_routing and index_routing can't be blank"
796+ else return (GranularAliasRouting sr ir)
797+
798+instance FromJSON IndexAliasCreate where
799+ parseJSON v = withObject "IndexAliasCreate" parse v
800+ where parse o = IndexAliasCreate <$> optional (parseJSON v)
801+ <*> o .:? "filter"
802+
460{-| 'IndexAliasSummary' is a summary of an index alias configured for a server. -}
803{-| 'IndexAliasSummary' is a summary of an index alias configured for a server. -}
461data IndexAliasSummary = IndexAliasSummary
804data IndexAliasSummary = IndexAliasSummary
462 { indexAliasSummaryAlias :: IndexAlias
805 { indexAliasSummaryAlias :: IndexAlias
@@ -473,10 +816,32 @@ newtype DocVersion = DocVersion {
473-- | Smart constructor for in-range doc version
816-- | Smart constructor for in-range doc version
474mkDocVersion :: Int -> Maybe DocVersion
817mkDocVersion :: Int -> Maybe DocVersion
475mkDocVersion i
818mkDocVersion i
476− | i >= (docVersionNumber minBound) && i <= (docVersionNumber maxBound) =
819+ | i >= docVersionNumber minBound
820+ && i <= docVersionNumber maxBound =
477 Just $ DocVersion i
821 Just $ DocVersion i
478 | otherwise = Nothing
822 | otherwise = Nothing
479
823
824+instance Bounded DocVersion where
825+ minBound = DocVersion 1
826+ maxBound = DocVersion 9200000000000000000 -- 9.2e+18
827+
828+instance Enum DocVersion where
829+ succ x
830+ | x /= maxBound = DocVersion (succ $ docVersionNumber x)
831+ | otherwise = succError "DocVersion"
832+ pred x
833+ | x /= minBound = DocVersion (pred $ docVersionNumber x)
834+ | otherwise = predError "DocVersion"
835+ toEnum i =
836+ fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i
837+ fromEnum = docVersionNumber
838+ enumFrom = boundedEnumFrom
839+ enumFromThen = boundedEnumFromThen
840+
841+instance FromJSON DocVersion where
842+ parseJSON v = do
843+ i <- parseJSON v
844+ maybe (fail "DocVersion out of range") return $ mkDocVersion i
480
845
481{-| 'ExternalDocVersion' is a convenience wrapper if your code uses its
846{-| 'ExternalDocVersion' is a convenience wrapper if your code uses its
482own version numbers instead of ones from ES.
847own version numbers instead of ones from ES.
@@ -576,36 +941,6 @@ newtype TemplateName = TemplateName Text deriving (Eq, Show, ToJSON, FromJSON)
576-}
941-}
577newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, ToJSON, FromJSON)
942newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, ToJSON, FromJSON)
578
943
579−-- This insanity is because ES *sometimes* returns Replica/Shard counts as strings
580−instance FromJSON ReplicaCount where
581− parseJSON v = parseAsInt v
582− <|> parseAsString v
583− where parseAsInt = fmap ReplicaCount . parseJSON
584− parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)
585−
586−instance FromJSON ShardCount where
587− parseJSON v = parseAsInt v
588− <|> parseAsString v
589− where parseAsInt = fmap ShardCount . parseJSON
590− parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText)
591−
592−instance Bounded DocVersion where
593− minBound = DocVersion 1
594− maxBound = DocVersion 9200000000000000000 -- 9.2e+18
595−
596−instance Enum DocVersion where
597− succ x
598− | x /= maxBound = DocVersion (succ $ docVersionNumber x)
599− | otherwise = succError "DocVersion"
600− pred x
601− | x /= minBound = DocVersion (pred $ docVersionNumber x)
602− | otherwise = predError "DocVersion"
603− toEnum i =
604− fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i
605− fromEnum = docVersionNumber
606− enumFrom = boundedEnumFrom
607− enumFromThen = boundedEnumFromThen
608−
609-- | Username type used for HTTP Basic authentication. See 'basicAuthHook'.
944-- | Username type used for HTTP Basic authentication. See 'basicAuthHook'.
610newtype EsUsername = EsUsername { esUsername :: Text } deriving (Read, Show, Eq)
945newtype EsUsername = EsUsername { esUsername :: Text } deriving (Read, Show, Eq)
611
946
@@ -699,7 +1034,7 @@ newtype FullNodeId = FullNodeId { fullNodeId :: Text }
699
1034
700
1035
701-- | A human-readable node name that is supplied by the user in the
1036-- | A human-readable node name that is supplied by the user in the
702−-- node config or automatically generated by ElasticSearch.
1037+-- node config or automatically generated by Elasticsearch.
703newtype NodeName = NodeName { nodeName :: Text }
1038newtype NodeName = NodeName { nodeName :: Text }
704 deriving (Eq, Ord, Show, FromJSON)
1039 deriving (Eq, Ord, Show, FromJSON)
705
1040
@@ -974,7 +1309,7 @@ data NodeIndicesStats = NodeIndicesStats {
974 , nodeIndicesStatsDocsCount :: Int
1309 , nodeIndicesStatsDocsCount :: Int
975 } deriving (Eq, Show)
1310 } deriving (Eq, Show)
976
1311
977−-- | A quirky address format used throughout ElasticSearch. An example
1312+-- | A quirky address format used throughout Elasticsearch. An example
978-- would be inet[/1.1.1.1:9200]. inet may be a placeholder for a
1313-- would be inet[/1.1.1.1:9200]. inet may be a placeholder for a
979-- <https://en.wikipedia.org/wiki/Fully_qualified_domain_name FQDN>.
1314-- <https://en.wikipedia.org/wiki/Fully_qualified_domain_name FQDN>.
980newtype EsAddress = EsAddress { esAddress :: Text }
1315newtype EsAddress = EsAddress { esAddress :: Text }
@@ -1094,15 +1429,20 @@ data NodeJVMInfo = NodeJVMInfo {
1094 , nodeJVMInfoMemoryInfo :: JVMMemoryInfo
1429 , nodeJVMInfoMemoryInfo :: JVMMemoryInfo
1095 , nodeJVMInfoStartTime :: UTCTime
1430 , nodeJVMInfoStartTime :: UTCTime
1096 , nodeJVMInfoVMVendor :: Text
1431 , nodeJVMInfoVMVendor :: Text
1097− , nodeJVMVMVersion :: VersionNumber
1432+ , nodeJVMVMVersion :: VMVersion
1098 -- ^ JVM doesn't seme to follow normal version conventions
1433 -- ^ JVM doesn't seme to follow normal version conventions
1099 , nodeJVMVMName :: Text
1434 , nodeJVMVMName :: Text
1100− , nodeJVMVersion :: VersionNumber
1435+ , nodeJVMVersion :: JVMVersion
1101 , nodeJVMPID :: PID
1436 , nodeJVMPID :: PID
1102 } deriving (Eq, Show)
1437 } deriving (Eq, Show)
1103
1438
1104−-- | Handles quirks in the way JVM versions are rendered (1.7.0_101 -> 1.7.0.101)
1439+-- | We cannot parse JVM version numbers and we're not going to try.
1440+newtype JVMVersion =
1105−newtype JVMVersion = JVMVersion { unJVMVersion :: VersionNumber }
1441+ JVMVersion { unJVMVersion :: Text }
1442+ deriving (Eq, Show)
1443+
1444+instance FromJSON JVMVersion where
1445+ parseJSON = withText "JVMVersion" (pure . JVMVersion)
1106
1446
1107data JVMMemoryInfo = JVMMemoryInfo {
1447data JVMMemoryInfo = JVMMemoryInfo {
1108 jvmMemoryInfoDirectMax :: Bytes
1448 jvmMemoryInfoDirectMax :: Bytes
@@ -1112,6 +1452,18 @@ data JVMMemoryInfo = JVMMemoryInfo {
1112 , jvmMemoryInfoHeapInit :: Bytes
1452 , jvmMemoryInfoHeapInit :: Bytes
1113 } deriving (Eq, Show)
1453 } deriving (Eq, Show)
1114
1454
1455+-- VM version numbers don't appear to be SemVer
1456+-- so we're special casing this jawn.
1457+newtype VMVersion =
1458+ VMVersion { unVMVersion :: Text }
1459+ deriving (Eq, Show)
1460+
1461+instance ToJSON VMVersion where
1462+ toJSON = toJSON . unVMVersion
1463+
1464+instance FromJSON VMVersion where
1465+ parseJSON = withText "VMVersion" (pure . VMVersion)
1466+
1115newtype JVMMemoryPool = JVMMemoryPool {
1467newtype JVMMemoryPool = JVMMemoryPool {
1116 jvmMemoryPool :: Text
1468 jvmMemoryPool :: Text
1117 } deriving (Eq, Show, FromJSON)
1469 } deriving (Eq, Show, FromJSON)
@@ -1225,13 +1577,13 @@ data SnapshotRestoreSettings = SnapshotRestoreSettings {
1225 -- revert back to the server default during the restore process.
1577 -- revert back to the server default during the restore process.
1226 } deriving (Eq, Show)
1578 } deriving (Eq, Show)
1227
1579
1228−data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings {
1580+newtype SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings
1229− repoUpdateVerify :: Bool
1581+ { repoUpdateVerify :: Bool
1230− -- ^ After creation/update, synchronously check that nodes can
1582+ -- ^ After creation/update, synchronously check that nodes can
1231− -- write to this repo. Defaults to True. You may use False if you
1583+ -- write to this repo. Defaults to True. You may use False if you
1232− -- need a faster response and plan on verifying manually later
1584+ -- need a faster response and plan on verifying manually later
1233− -- with 'verifySnapshotRepo'.
1585+ -- with 'verifySnapshotRepo'.
1234− } deriving (Eq, Show)
1586+ } deriving (Eq, Show)
1235
1587
1236
1588
1237-- | Reasonable defaults for repo creation/update
1589-- | Reasonable defaults for repo creation/update
@@ -1242,7 +1594,7 @@ defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True
1242
1594
1243
1595
1244-- | A filesystem-based snapshot repo that ships with
1596-- | A filesystem-based snapshot repo that ships with
1245−-- ElasticSearch. This is an instance of 'SnapshotRepo' so it can be
1597+-- Elasticsearch. This is an instance of 'SnapshotRepo' so it can be
1246-- used with 'updateSnapshotRepo'
1598-- used with 'updateSnapshotRepo'
1247data FsSnapshotRepo = FsSnapshotRepo {
1599data FsSnapshotRepo = FsSnapshotRepo {
1248 fsrName :: SnapshotRepoName
1600 fsrName :: SnapshotRepoName
@@ -1271,7 +1623,7 @@ instance SnapshotRepo FsSnapshotRepo where
1271 fromGSnapshotRepo GenericSnapshotRepo {..}
1623 fromGSnapshotRepo GenericSnapshotRepo {..}
1272 | gSnapshotRepoType == fsRepoType = do
1624 | gSnapshotRepoType == fsRepoType = do
1273 let o = gSnapshotRepoSettingsObject gSnapshotRepoSettings
1625 let o = gSnapshotRepoSettingsObject gSnapshotRepoSettings
1274− parseRepo $ do
1626+ parseRepo $
1275 FsSnapshotRepo gSnapshotRepoName <$> o .: "location"
1627 FsSnapshotRepo gSnapshotRepoName <$> o .: "location"
1276 <*> o .:? "compress" .!= False
1628 <*> o .:? "compress" .!= False
1277 <*> o .:? "chunk_size"
1629 <*> o .:? "chunk_size"
@@ -1370,12 +1722,6 @@ data SnapshotInfo = SnapshotInfo {
1370 } deriving (Eq, Show)
1722 } deriving (Eq, Show)
1371
1723
1372
1724
1373−instance FromJSON POSIXMS where
1374− parseJSON = withScientific "POSIXMS" (return . parse)
1375− where parse n =
1376− let n' = truncate n :: Integer
1377− in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))
1378−
1379instance FromJSON SnapshotInfo where
1725instance FromJSON SnapshotInfo where
1380 parseJSON = withObject "SnapshotInfo" parse
1726 parseJSON = withObject "SnapshotInfo" parse
1381 where
1727 where
@@ -1412,7 +1758,7 @@ newtype RestoreRenamePattern =
1412
1758
1413-- | A single token in a index renaming scheme for a restore. These
1759-- | A single token in a index renaming scheme for a restore. These
1414-- are concatenated into a string before being sent to
1760-- are concatenated into a string before being sent to
1415−-- ElasticSearch. Check out these Java
1761+-- Elasticsearch. Check out these Java
1416-- <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.
1762-- <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.
1417data RestoreRenameToken = RRTLit Text
1763data RestoreRenameToken = RRTLit Text
1418 -- ^ Just a literal string of characters
1764 -- ^ Just a literal string of characters
@@ -1437,7 +1783,8 @@ instance Bounded RRGroupRefNum where
1437-- | Only allows valid group number references (1-9).
1783-- | Only allows valid group number references (1-9).
1438mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum
1784mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum
1439mkRRGroupRefNum i
1785mkRRGroupRefNum i
1440− | i >= (rrGroupRefNum minBound) && i <= (rrGroupRefNum maxBound) =
1786+ | i >= rrGroupRefNum minBound
1787+ && i <= rrGroupRefNum maxBound =
1441 Just $ RRGroupRefNum i
1788 Just $ RRGroupRefNum i
1442 | otherwise = Nothing
1789 | otherwise = Nothing
1443
1790
@@ -1471,9 +1818,9 @@ defaultSnapshotRestoreSettings = SnapshotRestoreSettings {
1471-- | Index settings that can be overridden. The docs only mention you
1818-- | Index settings that can be overridden. The docs only mention you
1472-- can update number of replicas, but there may be more. You
1819-- can update number of replicas, but there may be more. You
1473-- definitely cannot override shard count.
1820-- definitely cannot override shard count.
1474−data RestoreIndexSettings = RestoreIndexSettings {
1821+newtype RestoreIndexSettings = RestoreIndexSettings
1475− restoreOverrideReplicas :: Maybe ReplicaCount
1822+ { restoreOverrideReplicas :: Maybe ReplicaCount
1476− } deriving (Eq, Show)
1823+ } deriving (Eq, Show)
1477
1824
1478
1825
1479instance ToJSON RestoreIndexSettings where
1826instance ToJSON RestoreIndexSettings where
@@ -1813,7 +2160,7 @@ instance FromJSON NodeBreakersStats where
1813 <*> o .: "fielddata"
2160 <*> o .: "fielddata"
1814
2161
1815parseNodeStats :: FullNodeId -> Object -> Parser NodeStats
2162parseNodeStats :: FullNodeId -> Object -> Parser NodeStats
1816−parseNodeStats fnid o = do
2163+parseNodeStats fnid o =
1817 NodeStats <$> o .: "name"
2164 NodeStats <$> o .: "name"
1818 <*> pure fnid
2165 <*> pure fnid
1819 <*> o .:? "breakers"
2166 <*> o .:? "breakers"
@@ -1871,7 +2218,7 @@ instance FromJSON BoundTransportAddress where
1871instance FromJSON NodeOSInfo where
2218instance FromJSON NodeOSInfo where
1872 parseJSON = withObject "NodeOSInfo" parse
2219 parseJSON = withObject "NodeOSInfo" parse
1873 where
2220 where
1874− parse o = do
2221+ parse o =
1875 NodeOSInfo <$> (unMS <$> o .: "refresh_interval_in_millis")
2222 NodeOSInfo <$> (unMS <$> o .: "refresh_interval_in_millis")
1876 <*> o .: "name"
2223 <*> o .: "name"
1877 <*> o .: "arch"
2224 <*> o .: "arch"
@@ -1909,14 +2256,9 @@ instance FromJSON NodeJVMInfo where
1909 <*> o .: "vm_vendor"
2256 <*> o .: "vm_vendor"
1910 <*> o .: "vm_version"
2257 <*> o .: "vm_version"
1911 <*> o .: "vm_name"
2258 <*> o .: "vm_name"
1912− <*> (unJVMVersion <$> o .: "version")
2259+ <*> o .: "version"
1913 <*> o .: "pid"
2260 <*> o .: "pid"
1914
2261
1915−instance FromJSON JVMVersion where
1916− parseJSON (String t) =
1917− JVMVersion <$> parseJSON (String (T.replace "_" "." t))
1918− parseJSON v = JVMVersion <$> parseJSON v
1919−
1920instance FromJSON JVMMemoryInfo where
2262instance FromJSON JVMMemoryInfo where
1921 parseJSON = withObject "JVMMemoryInfo" parse
2263 parseJSON = withObject "JVMMemoryInfo" parse
1922 where
2264 where
@@ -1990,6 +2332,16 @@ data Interval = Year
1990 | Minute
2332 | Minute
1991 | Second deriving (Eq, Show)
2333 | Second deriving (Eq, Show)
1992
2334
2335+instance ToJSON Interval where
2336+ toJSON Year = "year"
2337+ toJSON Quarter = "quarter"
2338+ toJSON Month = "month"
2339+ toJSON Week = "week"
2340+ toJSON Day = "day"
2341+ toJSON Hour = "hour"
2342+ toJSON Minute = "minute"
2343+ toJSON Second = "second"
2344+
1993parseStringInterval :: (Monad m) => String -> m NominalDiffTime
2345parseStringInterval :: (Monad m) => String -> m NominalDiffTime
1994parseStringInterval s = case span isNumber s of
2346parseStringInterval s = case span isNumber s of
1995 ("", _) -> fail "Invalid interval"
2347 ("", _) -> fail "Invalid interval"
@@ -2068,12 +2420,12 @@ instance FromJSON Version where
2068 <*> o .: "lucene_version"
2420 <*> o .: "lucene_version"
2069
2421
2070instance ToJSON VersionNumber where
2422instance ToJSON VersionNumber where
2071− toJSON = toJSON . Vers.showVersion . versionNumber
2423+ toJSON = toJSON . SemVer.toText . versionNumber
2072
2424
2073instance FromJSON VersionNumber where
2425instance FromJSON VersionNumber where
2074− parseJSON = withText "VersionNumber" (parse . T.unpack)
2426+ parseJSON = withText "VersionNumber" parse
2075 where
2427 where
2076− parse s = case filter (null . snd)(RP.readP_to_S Vers.parseVersion s) of
2428+ parse t =
2429+ case SemVer.fromText t of
2430+ (Left err) -> fail err
2077− [(v, _)] -> pure (VersionNumber v)
2431+ (Right v) -> return (VersionNumber v)
2078− [] -> fail ("Invalid version string " ++ s)
2079− xs -> fail ("Ambiguous version string " ++ s ++ " (" ++ intercalate ", " (Vers.showVersion . fst <$> xs) ++ ")")
src/Database/Bloodhound/Internal/Highlight.hsnew file+164
@@ -0,0 +1,164 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+module Database.Bloodhound.Internal.Highlight where
5+
6+import Bloodhound.Import
7+
8+import qualified Data.Map.Strict as M
9+
10+import Database.Bloodhound.Internal.Newtypes
11+import Database.Bloodhound.Internal.Query
12+
13+type HitHighlight = M.Map Text [Text]
14+
15+data Highlights = Highlights
16+ { globalsettings :: Maybe HighlightSettings
17+ , highlightFields :: [FieldHighlight]
18+ } deriving (Eq, Show)
19+
20+instance ToJSON Highlights where
21+ toJSON (Highlights global fields) =
22+ omitNulls (("fields" .= fields)
23+ : highlightSettingsPairs global)
24+
25+data FieldHighlight =
26+ FieldHighlight FieldName (Maybe HighlightSettings)
27+ deriving (Eq, Show)
28+
29+
30+instance ToJSON FieldHighlight where
31+ toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
32+ object [ fName .= fSettings ]
33+ toJSON (FieldHighlight (FieldName fName) Nothing) =
34+ object [ fName .= emptyObject ]
35+
36+data HighlightSettings =
37+ Plain PlainHighlight
38+ | Postings PostingsHighlight
39+ | FastVector FastVectorHighlight
40+ deriving (Eq, Show)
41+
42+
43+instance ToJSON HighlightSettings where
44+ toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
45+
46+data PlainHighlight =
47+ PlainHighlight { plainCommon :: Maybe CommonHighlight
48+ , plainNonPost :: Maybe NonPostings }
49+ deriving (Eq, Show)
50+
51+ -- This requires that index_options are set to 'offset' in the mapping.
52+data PostingsHighlight =
53+ PostingsHighlight (Maybe CommonHighlight)
54+ deriving (Eq, Show)
55+
56+-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
57+data FastVectorHighlight = FastVectorHighlight
58+ { fvCommon :: Maybe CommonHighlight
59+ , fvNonPostSettings :: Maybe NonPostings
60+ , boundaryChars :: Maybe Text
61+ , boundaryMaxScan :: Maybe Int
62+ , fragmentOffset :: Maybe Int
63+ , matchedFields :: [Text]
64+ , phraseLimit :: Maybe Int
65+ } deriving (Eq, Show)
66+
67+data CommonHighlight = CommonHighlight
68+ { order :: Maybe Text
69+ , forceSource :: Maybe Bool
70+ , tag :: Maybe HighlightTag
71+ , encoder :: Maybe HighlightEncoder
72+ , noMatchSize :: Maybe Int
73+ , highlightQuery :: Maybe Query
74+ , requireFieldMatch :: Maybe Bool
75+ } deriving (Eq, Show)
76+
77+-- Settings that are only applicable to FastVector and Plain highlighters.
78+data NonPostings =
79+ NonPostings { fragmentSize :: Maybe Int
80+ , numberOfFragments :: Maybe Int
81+ } deriving (Eq, Show)
82+
83+data HighlightEncoder = DefaultEncoder
84+ | HTMLEncoder
85+ deriving (Eq, Show)
86+
87+instance ToJSON HighlightEncoder where
88+ toJSON DefaultEncoder = String "default"
89+ toJSON HTMLEncoder = String "html"
90+
91+-- NOTE: Should the tags use some kind of HTML type, rather than Text?
92+data HighlightTag =
93+ TagSchema Text
94+ -- Only uses more than the first value in the lists if fvh
95+ | CustomTags ([Text], [Text])
96+ deriving (Eq, Show)
97+
98+highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
99+highlightSettingsPairs Nothing = []
100+highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
101+highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
102+highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
103+
104+
105+plainHighPairs :: Maybe PlainHighlight -> [Pair]
106+plainHighPairs Nothing = []
107+plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
108+ [ "type" .= String "plain"]
109+ ++ commonHighlightPairs plCom
110+ ++ nonPostingsToPairs plNonPost
111+
112+postHighPairs :: Maybe PostingsHighlight -> [Pair]
113+postHighPairs Nothing = []
114+postHighPairs (Just (PostingsHighlight pCom)) =
115+ ("type" .= String "postings")
116+ : commonHighlightPairs pCom
117+
118+fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
119+fastVectorHighPairs Nothing = []
120+fastVectorHighPairs
121+ (Just
122+ (FastVectorHighlight fvCom fvNonPostSettings' fvBoundChars
123+ fvBoundMaxScan fvFragOff fvMatchedFields
124+ fvPhraseLim)) =
125+ [ "type" .= String "fvh"
126+ , "boundary_chars" .= fvBoundChars
127+ , "boundary_max_scan" .= fvBoundMaxScan
128+ , "fragment_offset" .= fvFragOff
129+ , "matched_fields" .= fvMatchedFields
130+ , "phraseLimit" .= fvPhraseLim]
131+ ++ commonHighlightPairs fvCom
132+ ++ nonPostingsToPairs fvNonPostSettings'
133+
134+commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
135+commonHighlightPairs Nothing = []
136+commonHighlightPairs (Just (CommonHighlight chScore chForceSource
137+ chTag chEncoder chNoMatchSize
138+ chHighlightQuery chRequireFieldMatch)) =
139+ [ "order" .= chScore
140+ , "force_source" .= chForceSource
141+ , "encoder" .= chEncoder
142+ , "no_match_size" .= chNoMatchSize
143+ , "highlight_query" .= chHighlightQuery
144+ , "require_fieldMatch" .= chRequireFieldMatch
145+ ]
146+ ++ highlightTagToPairs chTag
147+
148+
149+nonPostingsToPairs :: Maybe NonPostings -> [Pair]
150+nonPostingsToPairs Nothing = []
151+nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
152+ [ "fragment_size" .= npFragSize
153+ , "number_of_fragments" .= npNumOfFrags
154+ ]
155+
156+highlightTagToPairs :: Maybe HighlightTag -> [Pair]
157+highlightTagToPairs (Just (TagSchema _)) =
158+ [ "scheme" .= String "default"
159+ ]
160+highlightTagToPairs (Just (CustomTags (pre, post))) =
161+ [ "pre_tags" .= pre
162+ , "post_tags" .= post
163+ ]
164+highlightTagToPairs Nothing = []
src/Database/V5/Bloodhound/Internal/Newtypes.hs → src/Database/Bloodhound/Internal/Newtypes.hsrenamed+45−9
@@ -1,10 +1,24 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3
3
4−module Database.V5.Bloodhound.Internal.Newtypes where
4+module Database.Bloodhound.Internal.Newtypes where
5
5
6import Bloodhound.Import
6import Bloodhound.Import
7
7
8+import qualified Data.Map.Strict as M
9+
10+newtype From = From Int deriving (Eq, Show, ToJSON)
11+newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON)
12+
13+-- Used with scripts
14+newtype HitFields =
15+ HitFields (M.Map Text [Value])
16+ deriving (Eq, Show)
17+
18+instance FromJSON HitFields where
19+ parseJSON x
20+ = HitFields <$> parseJSON x
21+
8-- Slight misnomer.
22-- Slight misnomer.
9type Score = Maybe Double
23type Score = Maybe Double
10
24
@@ -96,8 +110,6 @@ newtype MinimumTermFrequency =
96 MinimumTermFrequency Int deriving (Eq, Show, FromJSON, ToJSON)
110 MinimumTermFrequency Int deriving (Eq, Show, FromJSON, ToJSON)
97newtype MaxQueryTerms =
111newtype MaxQueryTerms =
98 MaxQueryTerms Int deriving (Eq, Show, FromJSON, ToJSON)
112 MaxQueryTerms Int deriving (Eq, Show, FromJSON, ToJSON)
99−newtype Fuzziness =
100− Fuzziness Double deriving (Eq, Show, FromJSON, ToJSON)
101
113
102{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -}
114{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -}
103newtype PrefixLength =
115newtype PrefixLength =
@@ -146,6 +158,12 @@ newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, FromJSON, ToJS
146-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ
158-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ
147newtype POSIXMS = POSIXMS { posixMS :: UTCTime }
159newtype POSIXMS = POSIXMS { posixMS :: UTCTime }
148
160
161+instance FromJSON POSIXMS where
162+ parseJSON = withScientific "POSIXMS" (return . parse)
163+ where parse n =
164+ let n' = truncate n :: Integer
165+ in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))
166+
149newtype Boost =
167newtype Boost =
150 Boost Double
168 Boost Double
151 deriving (Eq, Show, ToJSON, FromJSON)
169 deriving (Eq, Show, ToJSON, FromJSON)
@@ -154,15 +172,28 @@ newtype BoostTerms =
154 BoostTerms Double
172 BoostTerms Double
155 deriving (Eq, Show, ToJSON, FromJSON)
173 deriving (Eq, Show, ToJSON, FromJSON)
156
174
175+{-| 'ReplicaCount' is part of 'IndexSettings' -}
176+newtype ReplicaCount =
177+ ReplicaCount Int
178+ deriving (Eq, Show, ToJSON)
179+
157{-| 'ShardCount' is part of 'IndexSettings' -}
180{-| 'ShardCount' is part of 'IndexSettings' -}
158newtype ShardCount =
181newtype ShardCount =
159 ShardCount Int
182 ShardCount Int
160 deriving (Eq, Show, ToJSON)
183 deriving (Eq, Show, ToJSON)
161
184
162−{-| 'ReplicaCount' is part of 'IndexSettings' -}
185+-- This insanity is because ES *sometimes* returns Replica/Shard counts as strings
163−newtype ReplicaCount =
186+instance FromJSON ReplicaCount where
164− ReplicaCount Int
187+ parseJSON v = parseAsInt v
165− deriving (Eq, Show, ToJSON)
188+ <|> parseAsString v
189+ where parseAsInt = fmap ReplicaCount . parseJSON
190+ parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)
191+
192+instance FromJSON ShardCount where
193+ parseJSON v = parseAsInt v
194+ <|> parseAsString v
195+ where parseAsInt = fmap ShardCount . parseJSON
196+ parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText)
166
197
167{-| 'IndexName' is used to describe which index to query/create/delete -}
198{-| 'IndexName' is used to describe which index to query/create/delete -}
168newtype IndexName =
199newtype IndexName =
@@ -195,7 +226,12 @@ unMS (MS t) = t
195instance FromJSON MS where
226instance FromJSON MS where
196 parseJSON = withScientific "MS" (return . MS . parse)
227 parseJSON = withScientific "MS" (return . MS . parse)
197 where
228 where
198− parse n = fromInteger ((truncate n) * 1000)
229+ parse n = fromInteger (truncate n * 1000)
199
230
200newtype TokenFilter =
231newtype TokenFilter =
232+ TokenFilter Text
233+ deriving (Eq, Show, FromJSON, ToJSON)
234+
235+newtype CharFilter =
236+ CharFilter Text
201− TokenFilter Text deriving (Eq, Show, FromJSON, ToJSON)
237+ deriving (Eq, Show, FromJSON, ToJSON)
src/Database/V5/Bloodhound/Internal/Query.hs → src/Database/Bloodhound/Internal/Query.hsrenamed+1206−1108
@@ -2,9 +2,9 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE RecordWildCards #-}
4
4
5−module Database.V5.Bloodhound.Internal.Query
5+module Database.Bloodhound.Internal.Query
6 ( module X
6 ( module X
7− , module Database.V5.Bloodhound.Internal.Query
7+ , module Database.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.V5.Bloodhound.Internal.Newtypes
18+import Database.Bloodhound.Internal.Newtypes
19
19
20data Query =
20data Query =
21 TermQuery Term (Maybe Boost)
21 TermQuery Term (Maybe Boost)
@@ -47,8 +47,181 @@ data Query =
47 | QueryExistsQuery FieldName
47 | QueryExistsQuery FieldName
48 | QueryTemplateQueryInline TemplateQueryInline
48 | QueryTemplateQueryInline TemplateQueryInline
49 | QueryMatchNoneQuery
49 | QueryMatchNoneQuery
50+ | QueryWildcardQuery WildcardQuery
50 deriving (Eq, Show)
51 deriving (Eq, Show)
51
52
53+instance ToJSON Query where
54+ toJSON (TermQuery (Term termQueryField termQueryValue) boost) =
55+ object [ "term" .=
56+ object [termQueryField .= object merged]]
57+ where
58+ base = [ "value" .= termQueryValue ]
59+ boosted = maybe [] (return . ("boost" .=)) boost
60+ merged = mappend base boosted
61+
62+ toJSON (TermsQuery fieldName terms) =
63+ object [ "terms" .= object conjoined ]
64+ where conjoined = [fieldName .= terms]
65+
66+ toJSON (IdsQuery idsQueryMappingName docIds) =
67+ object [ "ids" .= object conjoined ]
68+ where conjoined = [ "type" .= idsQueryMappingName
69+ , "values" .= fmap toJSON docIds ]
70+
71+ toJSON (QueryQueryStringQuery qQueryStringQuery) =
72+ object [ "query_string" .= qQueryStringQuery ]
73+
74+ toJSON (QueryMatchQuery matchQuery) =
75+ object [ "match" .= matchQuery ]
76+
77+ toJSON (QueryMultiMatchQuery multiMatchQuery) =
78+ toJSON multiMatchQuery
79+
80+ toJSON (QueryBoolQuery boolQuery) =
81+ object [ "bool" .= boolQuery ]
82+
83+ toJSON (QueryBoostingQuery boostingQuery) =
84+ object [ "boosting" .= boostingQuery ]
85+
86+ toJSON (QueryCommonTermsQuery commonTermsQuery) =
87+ object [ "common" .= commonTermsQuery ]
88+
89+ toJSON (ConstantScoreQuery query boost) =
90+ object ["constant_score" .= object ["query" .= query
91+ , "boost" .= boost]]
92+
93+ toJSON (QueryFunctionScoreQuery functionScoreQuery) =
94+ object [ "function_score" .= functionScoreQuery ]
95+
96+ toJSON (QueryDisMaxQuery disMaxQuery) =
97+ object [ "dis_max" .= disMaxQuery ]
98+
99+ toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) =
100+ object [ "fuzzy_like_this" .= fuzzyQuery ]
101+
102+ toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) =
103+ object [ "fuzzy_like_this_field" .= fuzzyFieldQuery ]
104+
105+ toJSON (QueryFuzzyQuery fuzzyQuery) =
106+ object [ "fuzzy" .= fuzzyQuery ]
107+
108+ toJSON (QueryHasChildQuery childQuery) =
109+ object [ "has_child" .= childQuery ]
110+
111+ toJSON (QueryHasParentQuery parentQuery) =
112+ object [ "has_parent" .= parentQuery ]
113+
114+ toJSON (QueryIndicesQuery qIndicesQuery) =
115+ object [ "indices" .= qIndicesQuery ]
116+
117+ toJSON (MatchAllQuery boost) =
118+ object [ "match_all" .= omitNulls [ "boost" .= boost ] ]
119+
120+ toJSON (QueryMoreLikeThisQuery query) =
121+ object [ "more_like_this" .= query ]
122+
123+ toJSON (QueryMoreLikeThisFieldQuery query) =
124+ object [ "more_like_this_field" .= query ]
125+
126+ toJSON (QueryNestedQuery query) =
127+ object [ "nested" .= query ]
128+
129+ toJSON (QueryPrefixQuery query) =
130+ object [ "prefix" .= query ]
131+
132+ toJSON (QueryRangeQuery query) =
133+ object [ "range" .= query ]
134+
135+ toJSON (QueryRegexpQuery query) =
136+ object [ "regexp" .= query ]
137+
138+ toJSON (QuerySimpleQueryStringQuery query) =
139+ object [ "simple_query_string" .= query ]
140+
141+ toJSON (QueryExistsQuery (FieldName fieldName)) =
142+ object ["exists" .= object
143+ ["field" .= fieldName]
144+ ]
145+ toJSON QueryMatchNoneQuery =
146+ object ["match_none" .= object []]
147+
148+ toJSON (QueryTemplateQueryInline templateQuery) =
149+ object [ "template" .= templateQuery ]
150+
151+ toJSON (QueryWildcardQuery query) =
152+ object [ "wildcard" .= query ]
153+
154+instance FromJSON Query where
155+ parseJSON v = withObject "Query" parse v
156+ where parse o = termQuery `taggedWith` "term"
157+ <|> termsQuery `taggedWith` "terms"
158+ <|> idsQuery `taggedWith` "ids"
159+ <|> queryQueryStringQuery `taggedWith` "query_string"
160+ <|> queryMatchQuery `taggedWith` "match"
161+ <|> queryMultiMatchQuery
162+ <|> queryBoolQuery `taggedWith` "bool"
163+ <|> queryBoostingQuery `taggedWith` "boosting"
164+ <|> queryCommonTermsQuery `taggedWith` "common"
165+ <|> constantScoreQuery `taggedWith` "constant_score"
166+ <|> queryFunctionScoreQuery `taggedWith` "function_score"
167+ <|> queryDisMaxQuery `taggedWith` "dis_max"
168+ <|> queryFuzzyLikeThisQuery `taggedWith` "fuzzy_like_this"
169+ <|> queryFuzzyLikeFieldQuery `taggedWith` "fuzzy_like_this_field"
170+ <|> queryFuzzyQuery `taggedWith` "fuzzy"
171+ <|> queryHasChildQuery `taggedWith` "has_child"
172+ <|> queryHasParentQuery `taggedWith` "has_parent"
173+ <|> queryIndicesQuery `taggedWith` "indices"
174+ <|> matchAllQuery `taggedWith` "match_all"
175+ <|> queryMoreLikeThisQuery `taggedWith` "more_like_this"
176+ <|> queryMoreLikeThisFieldQuery `taggedWith` "more_like_this_field"
177+ <|> queryNestedQuery `taggedWith` "nested"
178+ <|> queryPrefixQuery `taggedWith` "prefix"
179+ <|> queryRangeQuery `taggedWith` "range"
180+ <|> queryRegexpQuery `taggedWith` "regexp"
181+ <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"
182+ <|> queryTemplateQueryInline `taggedWith` "template"
183+ <|> queryWildcardQuery `taggedWith` "wildcard"
184+ where taggedWith parser k = parser =<< o .: k
185+ termQuery = fieldTagged $ \(FieldName fn) o ->
186+ TermQuery <$> (Term fn <$> o .: "value") <*> o .:? "boost"
187+ termsQuery o = case HM.toList o of
188+ [(fn, vs)] -> do vals <- parseJSON vs
189+ case vals of
190+ x:xs -> return (TermsQuery fn (x :| xs))
191+ _ -> fail "Expected non empty list of values"
192+ _ -> fail "Expected object with 1 field-named key"
193+ idsQuery o = IdsQuery <$> o .: "type"
194+ <*> o .: "values"
195+ queryQueryStringQuery = pure . QueryQueryStringQuery
196+ queryMatchQuery = pure . QueryMatchQuery
197+ queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v
198+ queryBoolQuery = pure . QueryBoolQuery
199+ queryBoostingQuery = pure . QueryBoostingQuery
200+ queryCommonTermsQuery = pure . QueryCommonTermsQuery
201+ constantScoreQuery o = case HM.lookup "query" o of
202+ Just x -> ConstantScoreQuery <$> parseJSON x
203+ <*> o .: "boost"
204+ _ -> fail "Does not appear to be a ConstantScoreQuery"
205+ queryFunctionScoreQuery = pure . QueryFunctionScoreQuery
206+ queryDisMaxQuery = pure . QueryDisMaxQuery
207+ queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery
208+ queryFuzzyLikeFieldQuery = pure . QueryFuzzyLikeFieldQuery
209+ queryFuzzyQuery = pure . QueryFuzzyQuery
210+ queryHasChildQuery = pure . QueryHasChildQuery
211+ queryHasParentQuery = pure . QueryHasParentQuery
212+ queryIndicesQuery = pure . QueryIndicesQuery
213+ matchAllQuery o = MatchAllQuery <$> o .:? "boost"
214+ queryMoreLikeThisQuery = pure . QueryMoreLikeThisQuery
215+ queryMoreLikeThisFieldQuery = pure . QueryMoreLikeThisFieldQuery
216+ queryNestedQuery = pure . QueryNestedQuery
217+ queryPrefixQuery = pure . QueryPrefixQuery
218+ queryRangeQuery = pure . QueryRangeQuery
219+ queryRegexpQuery = pure . QueryRegexpQuery
220+ querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery
221+ -- queryExistsQuery o = QueryExistsQuery <$> o .: "field"
222+ queryTemplateQueryInline = pure . QueryTemplateQueryInline
223+ queryWildcardQuery = pure . QueryWildcardQuery
224+
52-- | As of Elastic 2.0, 'Filters' are just 'Queries' housed in a
225-- | As of Elastic 2.0, 'Filters' are just 'Queries' housed in a
53-- Bool Query, and flagged in a different context.
226-- Bool Query, and flagged in a different context.
54newtype Filter = Filter { unFilter :: Query }
227newtype Filter = Filter { unFilter :: Query }
@@ -67,11 +240,61 @@ data RegexpQuery =
67 , regexpQueryBoost :: Maybe Boost
240 , regexpQueryBoost :: Maybe Boost
68 } deriving (Eq, Show)
241 } deriving (Eq, Show)
69
242
243+instance ToJSON RegexpQuery where
244+ toJSON (RegexpQuery (FieldName rqQueryField)
245+ (Regexp regexpQueryQuery) rqQueryFlags
246+ rqQueryBoost) =
247+ object [ rqQueryField .= omitNulls base ]
248+ where base = [ "value" .= regexpQueryQuery
249+ , "flags" .= rqQueryFlags
250+ , "boost" .= rqQueryBoost ]
251+
252+instance FromJSON RegexpQuery where
253+ parseJSON = withObject "RegexpQuery" parse
254+ where parse = fieldTagged $ \fn o ->
255+ RegexpQuery fn
256+ <$> o .: "value"
257+ <*> o .: "flags"
258+ <*> o .:? "boost"
259+
260+data WildcardQuery =
261+ WildcardQuery { wildcardQueryField :: FieldName
262+ , wildcardQuery :: Text
263+ , wildcardQueryBoost :: Maybe Boost
264+ } deriving (Eq, Show)
265+
266+instance ToJSON WildcardQuery where
267+ toJSON (WildcardQuery (FieldName wcQueryField)
268+ (wcQueryQuery) wcQueryBoost) =
269+ object [ wcQueryField .= omitNulls base ]
270+ where base = [ "value" .= wcQueryQuery
271+ , "boost" .= wcQueryBoost ]
272+
273+instance FromJSON WildcardQuery where
274+ parseJSON = withObject "WildcardQuery" parse
275+ where parse = fieldTagged $ \fn o ->
276+ WildcardQuery fn
277+ <$> o .: "value"
278+ <*> o .:? "boost"
279+
70data RangeQuery =
280data RangeQuery =
71 RangeQuery { rangeQueryField :: FieldName
281 RangeQuery { rangeQueryField :: FieldName
72 , rangeQueryRange :: RangeValue
282 , rangeQueryRange :: RangeValue
73 , rangeQueryBoost :: Boost } deriving (Eq, Show)
283 , rangeQueryBoost :: Boost } deriving (Eq, Show)
74
284
285+instance ToJSON RangeQuery where
286+ toJSON (RangeQuery (FieldName fieldName) range boost) =
287+ object [ fieldName .= object conjoined ]
288+ where
289+ conjoined = ("boost" .= boost) : rangeValueToPair range
290+
291+instance FromJSON RangeQuery where
292+ parseJSON = withObject "RangeQuery" parse
293+ where parse = fieldTagged $ \fn o ->
294+ RangeQuery fn
295+ <$> parseJSON (Object o)
296+ <*> o .: "boost"
297+
75mkRangeQuery :: FieldName -> RangeValue -> RangeQuery
298mkRangeQuery :: FieldName -> RangeValue -> RangeQuery
76mkRangeQuery f r = RangeQuery f r (Boost 1.0)
299mkRangeQuery f r = RangeQuery f r (Boost 1.0)
77
300
@@ -86,8 +309,32 @@ data SimpleQueryStringQuery =
86 , simpleQueryStringLocale :: Maybe Locale
309 , simpleQueryStringLocale :: Maybe Locale
87 } deriving (Eq, Show)
310 } deriving (Eq, Show)
88
311
312+
313+instance ToJSON SimpleQueryStringQuery where
314+ toJSON SimpleQueryStringQuery {..} =
315+ omitNulls (base ++ maybeAdd)
316+ where base = [ "query" .= simpleQueryStringQuery ]
317+ maybeAdd = [ "fields" .= simpleQueryStringField
318+ , "default_operator" .= simpleQueryStringOperator
319+ , "analyzer" .= simpleQueryStringAnalyzer
320+ , "flags" .= simpleQueryStringFlags
321+ , "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded
322+ , "locale" .= simpleQueryStringLocale ]
323+
324+instance FromJSON SimpleQueryStringQuery where
325+ parseJSON = withObject "SimpleQueryStringQuery" parse
326+ where parse o = SimpleQueryStringQuery <$> o .: "query"
327+ <*> o .:? "fields"
328+ <*> o .:? "default_operator"
329+ <*> o .:? "analyzer"
330+ <*> (parseFlags <$> o .:? "flags")
331+ <*> o .:? "lowercase_expanded_terms"
332+ <*> o .:? "locale"
333+ parseFlags (Just (x:xs)) = Just (x :| xs)
334+ parseFlags _ = Nothing
335+
89data SimpleQueryFlag =
336data SimpleQueryFlag =
90− SimpleQueryAll
337+ SimpleQueryAll
91 | SimpleQueryNone
338 | SimpleQueryNone
92 | SimpleQueryAnd
339 | SimpleQueryAnd
93 | SimpleQueryOr
340 | SimpleQueryOr
@@ -100,51 +347,169 @@ data SimpleQueryFlag =
100 | SimpleQueryNear
347 | SimpleQueryNear
101 | SimpleQuerySlop deriving (Eq, Show)
348 | SimpleQuerySlop deriving (Eq, Show)
102
349
350+instance ToJSON SimpleQueryFlag where
351+ toJSON SimpleQueryAll = "ALL"
352+ toJSON SimpleQueryNone = "NONE"
353+ toJSON SimpleQueryAnd = "AND"
354+ toJSON SimpleQueryOr = "OR"
355+ toJSON SimpleQueryPrefix = "PREFIX"
356+ toJSON SimpleQueryPhrase = "PHRASE"
357+ toJSON SimpleQueryPrecedence = "PRECEDENCE"
358+ toJSON SimpleQueryEscape = "ESCAPE"
359+ toJSON SimpleQueryWhitespace = "WHITESPACE"
360+ toJSON SimpleQueryFuzzy = "FUZZY"
361+ toJSON SimpleQueryNear = "NEAR"
362+ toJSON SimpleQuerySlop = "SLOP"
363+
364+instance FromJSON SimpleQueryFlag where
365+ parseJSON = withText "SimpleQueryFlag" parse
366+ where parse "ALL" = pure SimpleQueryAll
367+ parse "NONE" = pure SimpleQueryNone
368+ parse "AND" = pure SimpleQueryAnd
369+ parse "OR" = pure SimpleQueryOr
370+ parse "PREFIX" = pure SimpleQueryPrefix
371+ parse "PHRASE" = pure SimpleQueryPhrase
372+ parse "PRECEDENCE" = pure SimpleQueryPrecedence
373+ parse "ESCAPE" = pure SimpleQueryEscape
374+ parse "WHITESPACE" = pure SimpleQueryWhitespace
375+ parse "FUZZY" = pure SimpleQueryFuzzy
376+ parse "NEAR" = pure SimpleQueryNear
377+ parse "SLOP" = pure SimpleQuerySlop
378+ parse f = fail ("Unexpected SimpleQueryFlag: " <> show f)
379+
103−-- use_dis_max and tie_breaker when fields are plural?
380+-- use_dis_max and tie_breaker when fields are plural?
104−data QueryStringQuery =
381+data QueryStringQuery =
105− QueryStringQuery
382+ QueryStringQuery
106− { queryStringQuery :: QueryString
383+ { queryStringQuery :: QueryString
107− , queryStringDefaultField :: Maybe FieldName
384+ , queryStringDefaultField :: Maybe FieldName
108− , queryStringOperator :: Maybe BooleanOperator
385+ , queryStringOperator :: Maybe BooleanOperator
109− , queryStringAnalyzer :: Maybe Analyzer
386+ , queryStringAnalyzer :: Maybe Analyzer
110− , queryStringAllowLeadingWildcard :: Maybe AllowLeadingWildcard
387+ , queryStringAllowLeadingWildcard :: Maybe AllowLeadingWildcard
111− , queryStringLowercaseExpanded :: Maybe LowercaseExpanded
388+ , queryStringLowercaseExpanded :: Maybe LowercaseExpanded
112− , queryStringEnablePositionIncrements :: Maybe EnablePositionIncrements
389+ , queryStringEnablePositionIncrements :: Maybe EnablePositionIncrements
113− , queryStringFuzzyMaxExpansions :: Maybe MaxExpansions
390+ , queryStringFuzzyMaxExpansions :: Maybe MaxExpansions
114− , queryStringFuzziness :: Maybe Fuzziness
391+ , queryStringFuzziness :: Maybe Fuzziness
115− , queryStringFuzzyPrefixLength :: Maybe PrefixLength
392+ , queryStringFuzzyPrefixLength :: Maybe PrefixLength
116− , queryStringPhraseSlop :: Maybe PhraseSlop
393+ , queryStringPhraseSlop :: Maybe PhraseSlop
117− , queryStringBoost :: Maybe Boost
394+ , queryStringBoost :: Maybe Boost
118− , queryStringAnalyzeWildcard :: Maybe AnalyzeWildcard
395+ , queryStringAnalyzeWildcard :: Maybe AnalyzeWildcard
119− , queryStringGeneratePhraseQueries :: Maybe GeneratePhraseQueries
396+ , queryStringGeneratePhraseQueries :: Maybe GeneratePhraseQueries
120− , queryStringMinimumShouldMatch :: Maybe MinimumMatch
397+ , queryStringMinimumShouldMatch :: Maybe MinimumMatch
121− , queryStringLenient :: Maybe Lenient
398+ , queryStringLenient :: Maybe Lenient
122− , queryStringLocale :: Maybe Locale
399+ , queryStringLocale :: Maybe Locale
123− } deriving (Eq, Show)
400+ } deriving (Eq, Show)
124−
401+
402+
403+instance ToJSON QueryStringQuery where
404+ toJSON (QueryStringQuery qsQueryString
405+ qsDefaultField qsOperator
406+ qsAnalyzer qsAllowWildcard
407+ qsLowercaseExpanded qsEnablePositionIncrements
408+ qsFuzzyMaxExpansions qsFuzziness
409+ qsFuzzyPrefixLength qsPhraseSlop
410+ qsBoost qsAnalyzeWildcard
411+ qsGeneratePhraseQueries qsMinimumShouldMatch
412+ qsLenient qsLocale) =
413+ omitNulls base
414+ where
415+ base = [ "query" .= qsQueryString
416+ , "default_field" .= qsDefaultField
417+ , "default_operator" .= qsOperator
418+ , "analyzer" .= qsAnalyzer
419+ , "allow_leading_wildcard" .= qsAllowWildcard
420+ , "lowercase_expanded_terms" .= qsLowercaseExpanded
421+ , "enable_position_increments" .= qsEnablePositionIncrements
422+ , "fuzzy_max_expansions" .= qsFuzzyMaxExpansions
423+ , "fuzziness" .= qsFuzziness
424+ , "fuzzy_prefix_length" .= qsFuzzyPrefixLength
425+ , "phrase_slop" .= qsPhraseSlop
426+ , "boost" .= qsBoost
427+ , "analyze_wildcard" .= qsAnalyzeWildcard
428+ , "auto_generate_phrase_queries" .= qsGeneratePhraseQueries
429+ , "minimum_should_match" .= qsMinimumShouldMatch
430+ , "lenient" .= qsLenient
431+ , "locale" .= qsLocale ]
432+
433+instance FromJSON QueryStringQuery where
434+ parseJSON = withObject "QueryStringQuery" parse
435+ where parse o = QueryStringQuery
436+ <$> o .: "query"
437+ <*> o .:? "default_field"
438+ <*> o .:? "default_operator"
439+ <*> o .:? "analyzer"
440+ <*> o .:? "allow_leading_wildcard"
441+ <*> o .:? "lowercase_expanded_terms"
442+ <*> o .:? "enable_position_increments"
443+ <*> o .:? "fuzzy_max_expansions"
444+ <*> o .:? "fuzziness"
445+ <*> o .:? "fuzzy_prefix_length"
446+ <*> o .:? "phrase_slop"
447+ <*> o .:? "boost"
448+ <*> o .:? "analyze_wildcard"
449+ <*> o .:? "auto_generate_phrase_queries"
450+ <*> o .:? "minimum_should_match"
451+ <*> o .:? "lenient"
452+ <*> o .:? "locale"
453+
125−mkQueryStringQuery :: QueryString -> QueryStringQuery
454+mkQueryStringQuery :: QueryString -> QueryStringQuery
126−mkQueryStringQuery qs =
455+mkQueryStringQuery qs =
127− QueryStringQuery qs Nothing Nothing
456+ QueryStringQuery qs Nothing Nothing
128− Nothing Nothing Nothing Nothing
457+ Nothing Nothing Nothing Nothing
129− Nothing Nothing Nothing Nothing
458+ Nothing Nothing Nothing Nothing
130− Nothing Nothing Nothing Nothing
459+ Nothing Nothing Nothing Nothing
131 Nothing Nothing
460 Nothing Nothing
132
461
133data FieldOrFields = FofField FieldName
462data FieldOrFields = FofField FieldName
134 | FofFields (NonEmpty FieldName) deriving (Eq, Show)
463 | FofFields (NonEmpty FieldName) deriving (Eq, Show)
135
464
465+instance ToJSON FieldOrFields where
466+ toJSON (FofField fieldName) =
467+ toJSON fieldName
468+ toJSON (FofFields fieldNames) =
469+ toJSON fieldNames
470+
471+instance FromJSON FieldOrFields where
472+ parseJSON v = FofField <$> parseJSON v
473+ <|> FofFields <$> (parseNEJSON =<< parseJSON v)
474+
136data PrefixQuery =
475data PrefixQuery =
137 PrefixQuery
476 PrefixQuery
138 { prefixQueryField :: FieldName
477 { prefixQueryField :: FieldName
139 , prefixQueryPrefixValue :: Text
478 , prefixQueryPrefixValue :: Text
140 , prefixQueryBoost :: Maybe Boost } deriving (Eq, Show)
479 , prefixQueryBoost :: Maybe Boost } deriving (Eq, Show)
141
480
481+instance ToJSON PrefixQuery where
482+ toJSON (PrefixQuery (FieldName fieldName) queryValue boost) =
483+ object [ fieldName .= omitNulls base ]
484+ where base = [ "value" .= queryValue
485+ , "boost" .= boost ]
486+
487+instance FromJSON PrefixQuery where
488+ parseJSON = withObject "PrefixQuery" parse
489+ where parse = fieldTagged $ \fn o ->
490+ PrefixQuery fn
491+ <$> o .: "value"
492+ <*> o .:? "boost"
493+
142data NestedQuery =
494data NestedQuery =
143 NestedQuery
495 NestedQuery
144 { nestedQueryPath :: QueryPath
496 { nestedQueryPath :: QueryPath
145 , nestedQueryScoreType :: ScoreType
497 , nestedQueryScoreType :: ScoreType
146 , nestedQuery :: Query } deriving (Eq, Show)
498 , nestedQuery :: Query } deriving (Eq, Show)
147
499
500+instance ToJSON NestedQuery where
501+ toJSON (NestedQuery nqPath nqScoreType nqQuery) =
502+ object [ "path" .= nqPath
503+ , "score_mode" .= nqScoreType
504+ , "query" .= nqQuery ]
505+
506+instance FromJSON NestedQuery where
507+ parseJSON = withObject "NestedQuery" parse
508+ where parse o = NestedQuery
509+ <$> o .: "path"
510+ <*> o .: "score_mode"
511+ <*> o .: "query"
512+
148data MoreLikeThisFieldQuery =
513data MoreLikeThisFieldQuery =
149 MoreLikeThisFieldQuery
514 MoreLikeThisFieldQuery
150 { moreLikeThisFieldText :: Text
515 { moreLikeThisFieldText :: Text
@@ -163,6 +528,45 @@ data MoreLikeThisFieldQuery =
163 , moreLikeThisFieldAnalyzer :: Maybe Analyzer
528 , moreLikeThisFieldAnalyzer :: Maybe Analyzer
164 } deriving (Eq, Show)
529 } deriving (Eq, Show)
165
530
531+
532+instance ToJSON MoreLikeThisFieldQuery where
533+ toJSON (MoreLikeThisFieldQuery text (FieldName fieldName)
534+ percent mtf mqt stopwords mindf maxdf
535+ minwl maxwl boostTerms boost analyzer) =
536+ object [ fieldName .= omitNulls base ]
537+ where base = [ "like_text" .= text
538+ , "percent_terms_to_match" .= percent
539+ , "min_term_freq" .= mtf
540+ , "max_query_terms" .= mqt
541+ , "stop_words" .= stopwords
542+ , "min_doc_freq" .= mindf
543+ , "max_doc_freq" .= maxdf
544+ , "min_word_length" .= minwl
545+ , "max_word_length" .= maxwl
546+ , "boost_terms" .= boostTerms
547+ , "boost" .= boost
548+ , "analyzer" .= analyzer ]
549+
550+instance FromJSON MoreLikeThisFieldQuery where
551+ parseJSON = withObject "MoreLikeThisFieldQuery" parse
552+ where parse = fieldTagged $ \fn o ->
553+ MoreLikeThisFieldQuery
554+ <$> o .: "like_text"
555+ <*> pure fn
556+ <*> o .:? "percent_terms_to_match"
557+ <*> o .:? "min_term_freq"
558+ <*> o .:? "max_query_terms"
559+ -- <*> (optionalNE =<< o .:? "stop_words")
560+ <*> o .:? "stop_words"
561+ <*> o .:? "min_doc_freq"
562+ <*> o .:? "max_doc_freq"
563+ <*> o .:? "min_word_length"
564+ <*> o .:? "max_word_length"
565+ <*> o .:? "boost_terms"
566+ <*> o .:? "boost"
567+ <*> o .:? "analyzer"
568+ -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)
569+
166data MoreLikeThisQuery =
570data MoreLikeThisQuery =
167 MoreLikeThisQuery
571 MoreLikeThisQuery
168 { moreLikeThisText :: Text
572 { moreLikeThisText :: Text
@@ -181,6 +585,46 @@ data MoreLikeThisQuery =
181 , moreLikeThisAnalyzer :: Maybe Analyzer
585 , moreLikeThisAnalyzer :: Maybe Analyzer
182 } deriving (Eq, Show)
586 } deriving (Eq, Show)
183
587
588+
589+instance ToJSON MoreLikeThisQuery where
590+ toJSON (MoreLikeThisQuery text fields percent
591+ mtf mqt stopwords mindf maxdf
592+ minwl maxwl boostTerms boost analyzer) =
593+ omitNulls base
594+ where base = [ "like_text" .= text
595+ , "fields" .= fields
596+ , "percent_terms_to_match" .= percent
597+ , "min_term_freq" .= mtf
598+ , "max_query_terms" .= mqt
599+ , "stop_words" .= stopwords
600+ , "min_doc_freq" .= mindf
601+ , "max_doc_freq" .= maxdf
602+ , "min_word_length" .= minwl
603+ , "max_word_length" .= maxwl
604+ , "boost_terms" .= boostTerms
605+ , "boost" .= boost
606+ , "analyzer" .= analyzer ]
607+
608+instance FromJSON MoreLikeThisQuery where
609+ parseJSON = withObject "MoreLikeThisQuery" parse
610+ where parse o = MoreLikeThisQuery
611+ <$> o .: "like_text"
612+ -- <*> (optionalNE =<< o .:? "fields")
613+ <*> o .:? "fields"
614+ <*> o .:? "percent_terms_to_match"
615+ <*> o .:? "min_term_freq"
616+ <*> o .:? "max_query_terms"
617+ -- <*> (optionalNE =<< o .:? "stop_words")
618+ <*> o .:? "stop_words"
619+ <*> o .:? "min_doc_freq"
620+ <*> o .:? "max_doc_freq"
621+ <*> o .:? "min_word_length"
622+ <*> o .:? "max_word_length"
623+ <*> o .:? "boost_terms"
624+ <*> o .:? "boost"
625+ <*> o .:? "analyzer"
626+ -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)
627+
184data IndicesQuery =
628data IndicesQuery =
185 IndicesQuery
629 IndicesQuery
186 { indicesQueryIndices :: [IndexName]
630 { indicesQueryIndices :: [IndexName]
@@ -188,23 +632,77 @@ data IndicesQuery =
188 -- default "all"
632 -- default "all"
189 , indicesQueryNoMatch :: Maybe Query } deriving (Eq, Show)
633 , indicesQueryNoMatch :: Maybe Query } deriving (Eq, Show)
190
634
635+
636+instance ToJSON IndicesQuery where
637+ toJSON (IndicesQuery indices query noMatch) =
638+ omitNulls [ "indices" .= indices
639+ , "no_match_query" .= noMatch
640+ , "query" .= query ]
641+
642+instance FromJSON IndicesQuery where
643+ parseJSON = withObject "IndicesQuery" parse
644+ where parse o = IndicesQuery
645+ <$> o .:? "indices" .!= []
646+ <*> o .: "query"
647+ <*> o .:? "no_match_query"
648+
191data HasParentQuery =
649data HasParentQuery =
192 HasParentQuery
650 HasParentQuery
193 { hasParentQueryType :: TypeName
651 { hasParentQueryType :: TypeName
194 , hasParentQuery :: Query
652 , hasParentQuery :: Query
195 , hasParentQueryScoreType :: Maybe ScoreType } deriving (Eq, Show)
653 , hasParentQueryScoreType :: Maybe ScoreType } deriving (Eq, Show)
196
654
655+instance ToJSON HasParentQuery where
656+ toJSON (HasParentQuery queryType query scoreType) =
657+ omitNulls [ "parent_type" .= queryType
658+ , "score_type" .= scoreType
659+ , "query" .= query ]
660+
661+instance FromJSON HasParentQuery where
662+ parseJSON = withObject "HasParentQuery" parse
663+ where parse o = HasParentQuery
664+ <$> o .: "parent_type"
665+ <*> o .: "query"
666+ <*> o .:? "score_type"
667+
197data HasChildQuery =
668data HasChildQuery =
198 HasChildQuery
669 HasChildQuery
199 { hasChildQueryType :: TypeName
670 { hasChildQueryType :: TypeName
200 , hasChildQuery :: Query
671 , hasChildQuery :: Query
201 , hasChildQueryScoreType :: Maybe ScoreType } deriving (Eq, Show)
672 , hasChildQueryScoreType :: Maybe ScoreType } deriving (Eq, Show)
202
673
674+instance ToJSON HasChildQuery where
675+ toJSON (HasChildQuery queryType query scoreType) =
676+ omitNulls [ "query" .= query
677+ , "score_type" .= scoreType
678+ , "type" .= queryType ]
679+
680+instance FromJSON HasChildQuery where
681+ parseJSON = withObject "HasChildQuery" parse
682+ where parse o = HasChildQuery
683+ <$> o .: "type"
684+ <*> o .: "query"
685+ <*> o .:? "score_type"
686+
203−data ScoreType =
687+data ScoreType =
204− ScoreTypeMax
688+ ScoreTypeMax
205− | ScoreTypeSum
689+ | ScoreTypeSum
206− | ScoreTypeAvg
690+ | ScoreTypeAvg
207− | ScoreTypeNone deriving (Eq, Show)
691+ | ScoreTypeNone deriving (Eq, Show)
692+
693+instance ToJSON ScoreType where
694+ toJSON ScoreTypeMax = "max"
695+ toJSON ScoreTypeAvg = "avg"
696+ toJSON ScoreTypeSum = "sum"
697+ toJSON ScoreTypeNone = "none"
698+
699+instance FromJSON ScoreType where
700+ parseJSON = withText "ScoreType" parse
701+ where parse "max" = pure ScoreTypeMax
702+ parse "avg" = pure ScoreTypeAvg
703+ parse "sum" = pure ScoreTypeSum
704+ parse "none" = pure ScoreTypeNone
705+ parse t = fail ("Unexpected ScoreType: " <> show t)
208
706
209data FuzzyQuery =
707data FuzzyQuery =
210 FuzzyQuery { fuzzyQueryField :: FieldName
708 FuzzyQuery { fuzzyQueryField :: FieldName
@@ -215,6 +713,27 @@ data FuzzyQuery =
215 , fuzzyQueryBoost :: Maybe Boost
713 , fuzzyQueryBoost :: Maybe Boost
216 } deriving (Eq, Show)
714 } deriving (Eq, Show)
217
715
716+
717+instance ToJSON FuzzyQuery where
718+ toJSON (FuzzyQuery (FieldName fieldName) queryText
719+ prefixLength maxEx fuzziness boost) =
720+ object [ fieldName .= omitNulls base ]
721+ where base = [ "value" .= queryText
722+ , "fuzziness" .= fuzziness
723+ , "prefix_length" .= prefixLength
724+ , "boost" .= boost
725+ , "max_expansions" .= maxEx ]
726+
727+instance FromJSON FuzzyQuery where
728+ parseJSON = withObject "FuzzyQuery" parse
729+ where parse = fieldTagged $ \fn o ->
730+ FuzzyQuery fn
731+ <$> o .: "value"
732+ <*> o .: "prefix_length"
733+ <*> o .: "max_expansions"
734+ <*> o .: "fuzziness"
735+ <*> o .:? "boost"
736+
218data FuzzyLikeFieldQuery =
737data FuzzyLikeFieldQuery =
219 FuzzyLikeFieldQuery
738 FuzzyLikeFieldQuery
220 { fuzzyLikeField :: FieldName
739 { fuzzyLikeField :: FieldName
@@ -228,6 +747,32 @@ data FuzzyLikeFieldQuery =
228 , fuzzyLikeFieldAnalyzer :: Maybe Analyzer
747 , fuzzyLikeFieldAnalyzer :: Maybe Analyzer
229 } deriving (Eq, Show)
748 } deriving (Eq, Show)
230
749
750+
751+instance ToJSON FuzzyLikeFieldQuery where
752+ toJSON (FuzzyLikeFieldQuery (FieldName fieldName)
753+ fieldText maxTerms ignoreFreq fuzziness prefixLength
754+ boost analyzer) =
755+ object [ fieldName .=
756+ omitNulls [ "like_text" .= fieldText
757+ , "max_query_terms" .= maxTerms
758+ , "ignore_tf" .= ignoreFreq
759+ , "fuzziness" .= fuzziness
760+ , "prefix_length" .= prefixLength
761+ , "analyzer" .= analyzer
762+ , "boost" .= boost ]]
763+
764+instance FromJSON FuzzyLikeFieldQuery where
765+ parseJSON = withObject "FuzzyLikeFieldQuery" parse
766+ where parse = fieldTagged $ \fn o ->
767+ FuzzyLikeFieldQuery fn
768+ <$> o .: "like_text"
769+ <*> o .: "max_query_terms"
770+ <*> o .: "ignore_tf"
771+ <*> o .: "fuzziness"
772+ <*> o .: "prefix_length"
773+ <*> o .: "boost"
774+ <*> o .:? "analyzer"
775+
231data FuzzyLikeThisQuery =
776data FuzzyLikeThisQuery =
232 FuzzyLikeThisQuery
777 FuzzyLikeThisQuery
233 { fuzzyLikeFields :: [FieldName]
778 { fuzzyLikeFields :: [FieldName]
@@ -240,6 +785,32 @@ data FuzzyLikeThisQuery =
240 , fuzzyLikeAnalyzer :: Maybe Analyzer
785 , fuzzyLikeAnalyzer :: Maybe Analyzer
241 } deriving (Eq, Show)
786 } deriving (Eq, Show)
242
787
788+
789+instance ToJSON FuzzyLikeThisQuery where
790+ toJSON (FuzzyLikeThisQuery fields text maxTerms
791+ ignoreFreq fuzziness prefixLength boost analyzer) =
792+ omitNulls base
793+ where base = [ "fields" .= fields
794+ , "like_text" .= text
795+ , "max_query_terms" .= maxTerms
796+ , "ignore_tf" .= ignoreFreq
797+ , "fuzziness" .= fuzziness
798+ , "prefix_length" .= prefixLength
799+ , "analyzer" .= analyzer
800+ , "boost" .= boost ]
801+
802+instance FromJSON FuzzyLikeThisQuery where
803+ parseJSON = withObject "FuzzyLikeThisQuery" parse
804+ where parse o = FuzzyLikeThisQuery
805+ <$> o .:? "fields" .!= []
806+ <*> o .: "like_text"
807+ <*> o .: "max_query_terms"
808+ <*> o .: "ignore_tf"
809+ <*> o .: "fuzziness"
810+ <*> o .: "prefix_length"
811+ <*> o .: "boost"
812+ <*> o .:? "analyzer"
813+
243data DisMaxQuery =
814data DisMaxQuery =
244 DisMaxQuery { disMaxQueries :: [Query]
815 DisMaxQuery { disMaxQueries :: [Query]
245 -- default 0.0
816 -- default 0.0
@@ -247,41 +818,136 @@ data DisMaxQuery =
247 , disMaxBoost :: Maybe Boost
818 , disMaxBoost :: Maybe Boost
248 } deriving (Eq, Show)
819 } deriving (Eq, Show)
249
820
821+
822+instance ToJSON DisMaxQuery where
823+ toJSON (DisMaxQuery queries tiebreaker boost) =
824+ omitNulls base
825+ where base = [ "queries" .= queries
826+ , "boost" .= boost
827+ , "tie_breaker" .= tiebreaker ]
828+
829+instance FromJSON DisMaxQuery where
830+ parseJSON = withObject "DisMaxQuery" parse
831+ where parse o = DisMaxQuery
832+ <$> o .:? "queries" .!= []
833+ <*> o .: "tie_breaker"
834+ <*> o .:? "boost"
835+
250−data MatchQuery =
836+data MatchQuery = MatchQuery
251− MatchQuery { matchQueryField :: FieldName
837+ { matchQueryField :: FieldName
252− , matchQueryQueryString :: QueryString
838+ , matchQueryQueryString :: QueryString
253− , matchQueryOperator :: BooleanOperator
839+ , matchQueryOperator :: BooleanOperator
254− , matchQueryZeroTerms :: ZeroTermsQuery
840+ , matchQueryZeroTerms :: ZeroTermsQuery
255− , matchQueryCutoffFrequency :: Maybe CutoffFrequency
841+ , matchQueryCutoffFrequency :: Maybe CutoffFrequency
256− , matchQueryMatchType :: Maybe MatchQueryType
842+ , matchQueryMatchType :: Maybe MatchQueryType
257− , matchQueryAnalyzer :: Maybe Analyzer
843+ , matchQueryAnalyzer :: Maybe Analyzer
258− , matchQueryMaxExpansions :: Maybe MaxExpansions
844+ , matchQueryMaxExpansions :: Maybe MaxExpansions
259− , matchQueryLenient :: Maybe Lenient
845+ , matchQueryLenient :: Maybe Lenient
260− , matchQueryBoost :: Maybe Boost
846+ , matchQueryBoost :: Maybe Boost
261− , matchQueryMinimumShouldMatch :: Maybe Text
847+ , matchQueryMinimumShouldMatch :: Maybe Text
848+ , matchQueryFuzziness :: Maybe Fuzziness
262− } deriving (Eq, Show)
849+ } deriving (Eq, Show)
850+
851+
852+instance ToJSON MatchQuery where
853+ toJSON (MatchQuery (FieldName fieldName)
854+ (QueryString mqQueryString) booleanOperator
855+ zeroTermsQuery cutoffFrequency matchQueryType
856+ analyzer maxExpansions lenient boost
857+ minShouldMatch mqFuzziness
858+ ) =
859+ object [ fieldName .= omitNulls base ]
860+ where base = [ "query" .= mqQueryString
861+ , "operator" .= booleanOperator
862+ , "zero_terms_query" .= zeroTermsQuery
863+ , "cutoff_frequency" .= cutoffFrequency
864+ , "type" .= matchQueryType
865+ , "analyzer" .= analyzer
866+ , "max_expansions" .= maxExpansions
867+ , "lenient" .= lenient
868+ , "boost" .= boost
869+ , "minimum_should_match" .= minShouldMatch
870+ , "fuzziness" .= mqFuzziness
871+ ]
872+
873+instance FromJSON MatchQuery where
874+ parseJSON = withObject "MatchQuery" parse
875+ where parse = fieldTagged $ \fn o ->
876+ MatchQuery fn
877+ <$> o .: "query"
878+ <*> o .: "operator"
879+ <*> o .: "zero_terms_query"
880+ <*> o .:? "cutoff_frequency"
881+ <*> o .:? "type"
882+ <*> o .:? "analyzer"
883+ <*> o .:? "max_expansions"
884+ <*> o .:? "lenient"
885+ <*> o .:? "boost"
886+ <*> o .:? "minimum_should_match"
887+ <*> o .:? "fuzziness"
263
888
264{-| 'mkMatchQuery' is a convenience function that defaults the less common parameters,
889{-| 'mkMatchQuery' is a convenience function that defaults the less common parameters,
265 enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery'
890 enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery'
266-}
891-}
267mkMatchQuery :: FieldName -> QueryString -> MatchQuery
892mkMatchQuery :: FieldName -> QueryString -> MatchQuery
268−mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing Nothing
893+mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
269
894
270data MatchQueryType =
895data MatchQueryType =
271− MatchPhrase
896+ MatchPhrase
272 | MatchPhrasePrefix deriving (Eq, Show)
897 | MatchPhrasePrefix deriving (Eq, Show)
273
898
899+instance ToJSON MatchQueryType where
900+ toJSON MatchPhrase = "phrase"
901+ toJSON MatchPhrasePrefix = "phrase_prefix"
902+
903+instance FromJSON MatchQueryType where
904+ parseJSON = withText "MatchQueryType" parse
905+ where parse "phrase" = pure MatchPhrase
906+ parse "phrase_prefix" = pure MatchPhrasePrefix
907+ parse t = fail ("Unexpected MatchQueryType: " <> show t)
908+
274−data MultiMatchQuery =
909+data MultiMatchQuery = MultiMatchQuery
275− MultiMatchQuery { multiMatchQueryFields :: [FieldName]
910+ { multiMatchQueryFields :: [FieldName]
276− , multiMatchQueryString :: QueryString
911+ , multiMatchQueryString :: QueryString
277− , multiMatchQueryOperator :: BooleanOperator
912+ , multiMatchQueryOperator :: BooleanOperator
278− , multiMatchQueryZeroTerms :: ZeroTermsQuery
913+ , multiMatchQueryZeroTerms :: ZeroTermsQuery
279− , multiMatchQueryTiebreaker :: Maybe Tiebreaker
914+ , multiMatchQueryTiebreaker :: Maybe Tiebreaker
280− , multiMatchQueryType :: Maybe MultiMatchQueryType
915+ , multiMatchQueryType :: Maybe MultiMatchQueryType
281− , multiMatchQueryCutoffFrequency :: Maybe CutoffFrequency
916+ , multiMatchQueryCutoffFrequency :: Maybe CutoffFrequency
282− , multiMatchQueryAnalyzer :: Maybe Analyzer
917+ , multiMatchQueryAnalyzer :: Maybe Analyzer
283− , multiMatchQueryMaxExpansions :: Maybe MaxExpansions
918+ , multiMatchQueryMaxExpansions :: Maybe MaxExpansions
284− , multiMatchQueryLenient :: Maybe Lenient } deriving (Eq, Show)
919+ , multiMatchQueryLenient :: Maybe Lenient
920+ } deriving (Eq, Show)
921+
922+instance ToJSON MultiMatchQuery where
923+ toJSON (MultiMatchQuery fields (QueryString query) boolOp
924+ ztQ tb mmqt cf analyzer maxEx lenient) =
925+ object ["multi_match" .= omitNulls base]
926+ where base = [ "fields" .= fmap toJSON fields
927+ , "query" .= query
928+ , "operator" .= boolOp
929+ , "zero_terms_query" .= ztQ
930+ , "tie_breaker" .= tb
931+ , "type" .= mmqt
932+ , "cutoff_frequency" .= cf
933+ , "analyzer" .= analyzer
934+ , "max_expansions" .= maxEx
935+ , "lenient" .= lenient ]
936+
937+instance FromJSON MultiMatchQuery where
938+ parseJSON = withObject "MultiMatchQuery" parse
939+ where parse raw = do o <- raw .: "multi_match"
940+ MultiMatchQuery
941+ <$> o .:? "fields" .!= []
942+ <*> o .: "query"
943+ <*> o .: "operator"
944+ <*> o .: "zero_terms_query"
945+ <*> o .:? "tie_breaker"
946+ <*> o .:? "type"
947+ <*> o .:? "cutoff_frequency"
948+ <*> o .:? "analyzer"
949+ <*> o .:? "max_expansions"
950+ <*> o .:? "lenient"
285
951
286{-| 'mkMultiMatchQuery' is a convenience function that defaults the less common parameters,
952{-| 'mkMultiMatchQuery' is a convenience function that defaults the less common parameters,
287 enabling you to provide only the list of 'FieldName's and 'QueryString' to
953 enabling you to provide only the list of 'FieldName's and 'QueryString' to
@@ -294,12 +960,28 @@ mkMultiMatchQuery matchFields query =
294 Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing
960 Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing
295
961
296data MultiMatchQueryType =
962data MultiMatchQueryType =
297− MultiMatchBestFields
963+ MultiMatchBestFields
298 | MultiMatchMostFields
964 | MultiMatchMostFields
299 | MultiMatchCrossFields
965 | MultiMatchCrossFields
300 | MultiMatchPhrase
966 | MultiMatchPhrase
301 | MultiMatchPhrasePrefix deriving (Eq, Show)
967 | MultiMatchPhrasePrefix deriving (Eq, Show)
302
968
969+instance ToJSON MultiMatchQueryType where
970+ toJSON MultiMatchBestFields = "best_fields"
971+ toJSON MultiMatchMostFields = "most_fields"
972+ toJSON MultiMatchCrossFields = "cross_fields"
973+ toJSON MultiMatchPhrase = "phrase"
974+ toJSON MultiMatchPhrasePrefix = "phrase_prefix"
975+
976+instance FromJSON MultiMatchQueryType where
977+ parseJSON = withText "MultiMatchPhrasePrefix" parse
978+ where parse "best_fields" = pure MultiMatchBestFields
979+ parse "most_fields" = pure MultiMatchMostFields
980+ parse "cross_fields" = pure MultiMatchCrossFields
981+ parse "phrase" = pure MultiMatchPhrase
982+ parse "phrase_prefix" = pure MultiMatchPhrasePrefix
983+ parse t = fail ("Unexpected MultiMatchPhrasePrefix: " <> show t)
984+
303data BoolQuery =
985data BoolQuery =
304 BoolQuery { boolQueryMustMatch :: [Query]
986 BoolQuery { boolQueryMustMatch :: [Query]
305 , boolQueryFilter :: [Filter]
987 , boolQueryFilter :: [Filter]
@@ -310,6 +992,29 @@ data BoolQuery =
310 , boolQueryDisableCoord :: Maybe DisableCoord
992 , boolQueryDisableCoord :: Maybe DisableCoord
311 } deriving (Eq, Show)
993 } deriving (Eq, Show)
312
994
995+
996+instance ToJSON BoolQuery where
997+ toJSON (BoolQuery mustM filterM' notM shouldM bqMin boost disableCoord) =
998+ omitNulls base
999+ where base = [ "must" .= mustM
1000+ , "filter" .= filterM'
1001+ , "must_not" .= notM
1002+ , "should" .= shouldM
1003+ , "minimum_should_match" .= bqMin
1004+ , "boost" .= boost
1005+ , "disable_coord" .= disableCoord ]
1006+
1007+instance FromJSON BoolQuery where
1008+ parseJSON = withObject "BoolQuery" parse
1009+ where parse o = BoolQuery
1010+ <$> o .:? "must" .!= []
1011+ <*> o .:? "filter" .!= []
1012+ <*> o .:? "must_not" .!= []
1013+ <*> o .:? "should" .!= []
1014+ <*> o .:? "minimum_should_match"
1015+ <*> o .:? "boost"
1016+ <*> o .:? "disable_coord"
1017+
313mkBoolQuery :: [Query] -> [Filter] -> [Query] -> [Query] -> BoolQuery
1018mkBoolQuery :: [Query] -> [Filter] -> [Query] -> [Query] -> BoolQuery
314mkBoolQuery must filt mustNot should =
1019mkBoolQuery must filt mustNot should =
315 BoolQuery must filt mustNot should Nothing Nothing Nothing
1020 BoolQuery must filt mustNot should Nothing Nothing Nothing
@@ -319,6 +1024,19 @@ data BoostingQuery =
319 , negativeQuery :: Query
1024 , negativeQuery :: Query
320 , negativeBoost :: Boost } deriving (Eq, Show)
1025 , negativeBoost :: Boost } deriving (Eq, Show)
321
1026
1027+instance ToJSON BoostingQuery where
1028+ toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) =
1029+ object [ "positive" .= bqPositiveQuery
1030+ , "negative" .= bqNegativeQuery
1031+ , "negative_boost" .= bqNegativeBoost ]
1032+
1033+instance FromJSON BoostingQuery where
1034+ parseJSON = withObject "BoostingQuery" parse
1035+ where parse o = BoostingQuery
1036+ <$> o .: "positive"
1037+ <*> o .: "negative"
1038+ <*> o .: "negative_boost"
1039+
322data CommonTermsQuery =
1040data CommonTermsQuery =
323 CommonTermsQuery { commonField :: FieldName
1041 CommonTermsQuery { commonField :: FieldName
324 , commonQuery :: QueryString
1042 , commonQuery :: QueryString
@@ -331,27 +1049,112 @@ data CommonTermsQuery =
331 , commonDisableCoord :: Maybe DisableCoord
1049 , commonDisableCoord :: Maybe DisableCoord
332 } deriving (Eq, Show)
1050 } deriving (Eq, Show)
333
1051
334−data CommonMinimumMatch =
335− CommonMinimumMatchHighLow MinimumMatchHighLow
336− | CommonMinimumMatch MinimumMatch
337− deriving (Eq, Show)
338
1052
1053+instance ToJSON CommonTermsQuery where
1054+ toJSON (CommonTermsQuery (FieldName fieldName)
1055+ (QueryString query) cf lfo hfo msm
1056+ boost analyzer disableCoord) =
1057+ object [fieldName .= omitNulls base ]
1058+ where base = [ "query" .= query
1059+ , "cutoff_frequency" .= cf
1060+ , "low_freq_operator" .= lfo
1061+ , "minimum_should_match" .= msm
1062+ , "boost" .= boost
1063+ , "analyzer" .= analyzer
1064+ , "disable_coord" .= disableCoord
1065+ , "high_freq_operator" .= hfo ]
1066+
1067+instance FromJSON CommonTermsQuery where
1068+ parseJSON = withObject "CommonTermsQuery" parse
1069+ where parse = fieldTagged $ \fn o ->
1070+ CommonTermsQuery fn
1071+ <$> o .: "query"
1072+ <*> o .: "cutoff_frequency"
1073+ <*> o .: "low_freq_operator"
1074+ <*> o .: "high_freq_operator"
1075+ <*> o .:? "minimum_should_match"
1076+ <*> o .:? "boost"
1077+ <*> o .:? "analyzer"
1078+ <*> o .:? "disable_coord"
1079+
1080+data CommonMinimumMatch =
1081+ CommonMinimumMatchHighLow MinimumMatchHighLow
1082+ | CommonMinimumMatch MinimumMatch
1083+ deriving (Eq, Show)
1084+
1085+
1086+instance ToJSON CommonMinimumMatch where
1087+ toJSON (CommonMinimumMatch mm) = toJSON mm
1088+ toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) =
1089+ object [ "low_freq" .= lowF
1090+ , "high_freq" .= highF ]
1091+
1092+instance FromJSON CommonMinimumMatch where
1093+ parseJSON v = parseMinimum v
1094+ <|> parseMinimumHighLow v
1095+ where parseMinimum = fmap CommonMinimumMatch . parseJSON
1096+ parseMinimumHighLow = fmap CommonMinimumMatchHighLow . withObject "CommonMinimumMatchHighLow" (\o ->
1097+ MinimumMatchHighLow
1098+ <$> o .: "low_freq"
1099+ <*> o .: "high_freq")
1100+
339−data MinimumMatchHighLow =
1101+data MinimumMatchHighLow =
340− MinimumMatchHighLow { lowFreq :: MinimumMatch
1102+ MinimumMatchHighLow { lowFreq :: MinimumMatch
341 , highFreq :: MinimumMatch } deriving (Eq, Show)
1103 , highFreq :: MinimumMatch } deriving (Eq, Show)
342
1104
343−data ZeroTermsQuery = ZeroTermsNone
1105+data ZeroTermsQuery =
1106+ ZeroTermsNone
344− | ZeroTermsAll deriving (Eq, Show)
1107+ | ZeroTermsAll deriving (Eq, Show)
1108+
1109+instance ToJSON ZeroTermsQuery where
1110+ toJSON ZeroTermsNone = String "none"
1111+ toJSON ZeroTermsAll = String "all"
1112+
1113+instance FromJSON ZeroTermsQuery where
1114+ parseJSON = withText "ZeroTermsQuery" parse
1115+ where parse "none" = pure ZeroTermsNone
1116+ parse "all" = pure ZeroTermsAll
1117+ parse q = fail ("Unexpected ZeroTermsQuery: " <> show q)
345
1118
346data RangeExecution = RangeExecutionIndex
1119data RangeExecution = RangeExecutionIndex
347 | RangeExecutionFielddata deriving (Eq, Show)
1120 | RangeExecutionFielddata deriving (Eq, Show)
348
1121
1122+-- index for smaller ranges, fielddata for longer ranges
1123+instance ToJSON RangeExecution where
1124+ toJSON RangeExecutionIndex = "index"
1125+ toJSON RangeExecutionFielddata = "fielddata"
1126+
1127+
1128+instance FromJSON RangeExecution where
1129+ parseJSON = withText "RangeExecution" parse
1130+ where parse "index" = pure RangeExecutionIndex
1131+ parse "fielddata" = pure RangeExecutionFielddata
1132+ parse t = error ("Unrecognized RangeExecution " <> show t)
1133+
349newtype Regexp = Regexp Text deriving (Eq, Show, FromJSON)
1134newtype Regexp = Regexp Text deriving (Eq, Show, FromJSON)
350
1135
351data RegexpFlags = AllRegexpFlags
1136data RegexpFlags = AllRegexpFlags
352 | NoRegexpFlags
1137 | NoRegexpFlags
353 | SomeRegexpFlags (NonEmpty RegexpFlag) deriving (Eq, Show)
1138 | SomeRegexpFlags (NonEmpty RegexpFlag) deriving (Eq, Show)
354
1139
1140+instance ToJSON RegexpFlags where
1141+ toJSON AllRegexpFlags = String "ALL"
1142+ toJSON NoRegexpFlags = String "NONE"
1143+ toJSON (SomeRegexpFlags (h :| fs)) = String $ T.intercalate "|" flagStrs
1144+ where flagStrs = map flagStr . nub $ h:fs
1145+ flagStr AnyString = "ANYSTRING"
1146+ flagStr Automaton = "AUTOMATON"
1147+ flagStr Complement = "COMPLEMENT"
1148+ flagStr Empty = "EMPTY"
1149+ flagStr Intersection = "INTERSECTION"
1150+ flagStr Interval = "INTERVAL"
1151+
1152+instance FromJSON RegexpFlags where
1153+ parseJSON = withText "RegexpFlags" parse
1154+ where parse "ALL" = pure AllRegexpFlags
1155+ parse "NONE" = pure NoRegexpFlags
1156+ parse t = SomeRegexpFlags <$> parseNEJSON (String <$> T.splitOn "|" t)
1157+
355data RegexpFlag = AnyString
1158data RegexpFlag = AnyString
356 | Automaton
1159 | Automaton
357 | Complement
1160 | Complement
@@ -359,6 +1162,16 @@ data RegexpFlag = AnyString
359 | Intersection
1162 | Intersection
360 | Interval deriving (Eq, Show)
1163 | Interval deriving (Eq, Show)
361
1164
1165+instance FromJSON RegexpFlag where
1166+ parseJSON = withText "RegexpFlag" parse
1167+ where parse "ANYSTRING" = pure AnyString
1168+ parse "AUTOMATON" = pure Automaton
1169+ parse "COMPLEMENT" = pure Complement
1170+ parse "EMPTY" = pure Empty
1171+ parse "INTERSECTION" = pure Intersection
1172+ parse "INTERVAL" = pure Interval
1173+ parse f = fail ("Unknown RegexpFlag: " <> show f)
1174+
362newtype LessThan = LessThan Double deriving (Eq, Show)
1175newtype LessThan = LessThan Double deriving (Eq, Show)
363newtype LessThanEq = LessThanEq Double deriving (Eq, Show)
1176newtype LessThanEq = LessThanEq Double deriving (Eq, Show)
364newtype GreaterThan = GreaterThan Double deriving (Eq, Show)
1177newtype GreaterThan = GreaterThan Double deriving (Eq, Show)
@@ -387,6 +1200,78 @@ data RangeValue = RangeDateLte LessThanEqD
387 | RangeDoubleGtLte GreaterThan LessThanEq
1200 | RangeDoubleGtLte GreaterThan LessThanEq
388 deriving (Eq, Show)
1201 deriving (Eq, Show)
389
1202
1203+
1204+parseRangeValue :: ( FromJSON t4
1205+ , FromJSON t3
1206+ , FromJSON t2
1207+ , FromJSON t1
1208+ )
1209+ => (t3 -> t5)
1210+ -> (t1 -> t6)
1211+ -> (t4 -> t7)
1212+ -> (t2 -> t8)
1213+ -> (t5 -> t6 -> b)
1214+ -> (t7 -> t6 -> b)
1215+ -> (t5 -> t8 -> b)
1216+ -> (t7 -> t8 -> b)
1217+ -> (t5 -> b)
1218+ -> (t6 -> b)
1219+ -> (t7 -> b)
1220+ -> (t8 -> b)
1221+ -> Parser b
1222+ -> Object
1223+ -> Parser b
1224+parseRangeValue mkGt mkLt mkGte mkLte
1225+ fGtLt fGteLt fGtLte fGteLte
1226+ fGt fLt fGte fLte nada o = do
1227+ lt <- o .:? "lt"
1228+ lte <- o .:? "lte"
1229+ gt <- o .:? "gt"
1230+ gte <- o .:? "gte"
1231+ case (lt, lte, gt, gte) of
1232+ (Just a, _, Just b, _) ->
1233+ return (fGtLt (mkGt b) (mkLt a))
1234+ (Just a, _, _, Just b) ->
1235+ return (fGteLt (mkGte b) (mkLt a))
1236+ (_, Just a, Just b, _) ->
1237+ return (fGtLte (mkGt b) (mkLte a))
1238+ (_, Just a, _, Just b) ->
1239+ return (fGteLte (mkGte b) (mkLte a))
1240+ (_, _, Just a, _) ->
1241+ return (fGt (mkGt a))
1242+ (Just a, _, _, _) ->
1243+ return (fLt (mkLt a))
1244+ (_, _, _, Just a) ->
1245+ return (fGte (mkGte a))
1246+ (_, Just a, _, _) ->
1247+ return (fLte (mkLte a))
1248+ (Nothing, Nothing, Nothing, Nothing) ->
1249+ nada
1250+
1251+
1252+instance FromJSON RangeValue where
1253+ parseJSON = withObject "RangeValue" parse
1254+ where parse o = parseDate o
1255+ <|> parseDouble o
1256+ parseDate o =
1257+ parseRangeValue
1258+ GreaterThanD LessThanD
1259+ GreaterThanEqD LessThanEqD
1260+ RangeDateGtLt RangeDateGteLt
1261+ RangeDateGtLte RangeDateGteLte
1262+ RangeDateGt RangeDateLt
1263+ RangeDateGte RangeDateLte
1264+ mzero o
1265+ parseDouble o =
1266+ parseRangeValue
1267+ GreaterThan LessThan
1268+ GreaterThanEq LessThanEq
1269+ RangeDoubleGtLt RangeDoubleGteLt
1270+ RangeDoubleGtLte RangeDoubleGteLte
1271+ RangeDoubleGt RangeDoubleLt
1272+ RangeDoubleGte RangeDoubleLte
1273+ mzero o
1274+
390rangeValueToPair :: RangeValue -> [Pair]
1275rangeValueToPair :: RangeValue -> [Pair]
391rangeValueToPair rv = case rv of
1276rangeValueToPair rv = case rv of
392 RangeDateLte (LessThanEqD t) -> ["lte" .= t]
1277 RangeDateLte (LessThanEqD t) -> ["lte" .= t]
@@ -409,21 +1294,82 @@ rangeValueToPair rv = case rv of
409data Term = Term { termField :: Text
1294data Term = Term { termField :: Text
410 , termValue :: Text } deriving (Eq, Show)
1295 , termValue :: Text } deriving (Eq, Show)
411
1296
1297+instance ToJSON Term where
1298+ toJSON (Term field value) = object ["term" .= object
1299+ [field .= value]]
1300+
1301+instance FromJSON Term where
1302+ parseJSON = withObject "Term" parse
1303+ where parse o = do termObj <- o .: "term"
1304+ case HM.toList termObj of
1305+ [(fn, v)] -> Term fn <$> parseJSON v
1306+ _ -> fail "Expected object with 1 field-named key"
1307+
412data BoolMatch = MustMatch Term Cache
1308data BoolMatch = MustMatch Term Cache
413 | MustNotMatch Term Cache
1309 | MustNotMatch Term Cache
414 | ShouldMatch [Term] Cache deriving (Eq, Show)
1310 | ShouldMatch [Term] Cache deriving (Eq, Show)
415
1311
1312+
1313+instance ToJSON BoolMatch where
1314+ toJSON (MustMatch term cache) = object ["must" .= term,
1315+ "_cache" .= cache]
1316+ toJSON (MustNotMatch term cache) = object ["must_not" .= term,
1317+ "_cache" .= cache]
1318+ toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms,
1319+ "_cache" .= cache]
1320+
1321+instance FromJSON BoolMatch where
1322+ parseJSON = withObject "BoolMatch" parse
1323+ where parse o = mustMatch `taggedWith` "must"
1324+ <|> mustNotMatch `taggedWith` "must_not"
1325+ <|> shouldMatch `taggedWith` "should"
1326+ where taggedWith parser k = parser =<< o .: k
1327+ mustMatch t = MustMatch t <$> o .:? "_cache" .!= defaultCache
1328+ mustNotMatch t = MustNotMatch t <$> o .:? "_cache" .!= defaultCache
1329+ shouldMatch t = ShouldMatch t <$> o .:? "_cache" .!= defaultCache
1330+
416-- "memory" or "indexed"
1331-- "memory" or "indexed"
417data GeoFilterType = GeoFilterMemory
1332data GeoFilterType = GeoFilterMemory
418 | GeoFilterIndexed deriving (Eq, Show)
1333 | GeoFilterIndexed deriving (Eq, Show)
419
1334
1335+instance ToJSON GeoFilterType where
1336+ toJSON GeoFilterMemory = String "memory"
1337+ toJSON GeoFilterIndexed = String "indexed"
1338+
1339+instance FromJSON GeoFilterType where
1340+ parseJSON = withText "GeoFilterType" parse
1341+ where parse "memory" = pure GeoFilterMemory
1342+ parse "indexed" = pure GeoFilterIndexed
1343+ parse t = fail ("Unrecognized GeoFilterType: " <> show t)
1344+
420data LatLon = LatLon { lat :: Double
1345data LatLon = LatLon { lat :: Double
421 , lon :: Double } deriving (Eq, Show)
1346 , lon :: Double } deriving (Eq, Show)
422
1347
1348+instance ToJSON LatLon where
1349+ toJSON (LatLon lLat lLon) =
1350+ object ["lat" .= lLat
1351+ , "lon" .= lLon]
1352+
1353+instance FromJSON LatLon where
1354+ parseJSON = withObject "LatLon" parse
1355+ where parse o = LatLon <$> o .: "lat"
1356+ <*> o .: "lon"
1357+
423data GeoBoundingBox =
1358data GeoBoundingBox =
424 GeoBoundingBox { topLeft :: LatLon
1359 GeoBoundingBox { topLeft :: LatLon
425 , bottomRight :: LatLon } deriving (Eq, Show)
1360 , bottomRight :: LatLon } deriving (Eq, Show)
426
1361
1362+instance ToJSON GeoBoundingBox where
1363+ toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) =
1364+ object ["top_left" .= gbbTopLeft
1365+ , "bottom_right" .= gbbBottomRight]
1366+
1367+instance FromJSON GeoBoundingBox where
1368+ parseJSON = withObject "GeoBoundingBox" parse
1369+ where parse o = GeoBoundingBox
1370+ <$> o .: "top_left"
1371+ <*> o .: "bottom_right"
1372+
427data GeoBoundingBoxConstraint =
1373data GeoBoundingBoxConstraint =
428 GeoBoundingBoxConstraint { geoBBField :: FieldName
1374 GeoBoundingBoxConstraint { geoBBField :: FieldName
429 , constraintBox :: GeoBoundingBox
1375 , constraintBox :: GeoBoundingBox
@@ -431,947 +1377,39 @@ data GeoBoundingBoxConstraint =
431 , geoType :: GeoFilterType
1377 , geoType :: GeoFilterType
432 } deriving (Eq, Show)
1378 } deriving (Eq, Show)
433
1379
1380+instance ToJSON GeoBoundingBoxConstraint where
1381+ toJSON (GeoBoundingBoxConstraint
1382+ (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') =
1383+ object [gbbcGeoBBField .= gbbcConstraintBox
1384+ , "_cache" .= cache
1385+ , "type" .= type']
1386+
1387+instance FromJSON GeoBoundingBoxConstraint where
1388+ parseJSON = withObject "GeoBoundingBoxConstraint" parse
1389+ where parse o = case HM.toList (deleteSeveral ["type", "_cache"] o) of
1390+ [(fn, v)] -> GeoBoundingBoxConstraint (FieldName fn)
1391+ <$> parseJSON v
1392+ <*> o .:? "_cache" .!= defaultCache
1393+ <*> o .: "type"
1394+ _ -> fail "Could not find field name for GeoBoundingBoxConstraint"
1395+
434data GeoPoint =
1396data GeoPoint =
435 GeoPoint { geoField :: FieldName
1397 GeoPoint { geoField :: FieldName
436 , latLon :: LatLon} deriving (Eq, Show)
1398 , latLon :: LatLon} deriving (Eq, Show)
437
1399
438−data DistanceUnit = Miles
439− | Yards
440− | Feet
441− | Inches
442− | Kilometers
443− | Meters
444− | Centimeters
445− | Millimeters
446− | NauticalMiles deriving (Eq, Show)
447−
448−data DistanceType = Arc
449− | SloppyArc -- doesn't exist <1.0
450− | Plane deriving (Eq, Show)
451−
452−data OptimizeBbox = OptimizeGeoFilterType GeoFilterType
453− | NoOptimizeBbox deriving (Eq, Show)
454−
455−data Distance =
456− Distance { coefficient :: Double
457− , unit :: DistanceUnit } deriving (Eq, Show)
458−
459−data DistanceRange =
460− DistanceRange { distanceFrom :: Distance
461− , distanceTo :: Distance } deriving (Eq, Show)
462−
463−type TemplateQueryKey = Text
464−type TemplateQueryValue = Text
465−
466−newtype TemplateQueryKeyValuePairs =
467− TemplateQueryKeyValuePairs (HM.HashMap TemplateQueryKey TemplateQueryValue)
468− deriving (Eq, Show)
469−
470−instance ToJSON TemplateQueryKeyValuePairs where
1400+instance ToJSON GeoPoint where
471− toJSON (TemplateQueryKeyValuePairs x) =
1401+ toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) =
472− Object $ HM.map toJSON x
1402+ object [ geoPointField .= geoPointLatLon ]
473−
474−instance FromJSON TemplateQueryKeyValuePairs where
475− parseJSON (Object o) =
476− pure . TemplateQueryKeyValuePairs $ HM.mapMaybe getValue o
477− where getValue (String x) = Just x
478− getValue _ = Nothing
479− parseJSON _ =
480− fail "error parsing TemplateQueryKeyValuePairs"
481−
482−data TemplateQueryInline =
483− TemplateQueryInline { inline :: Query
484− , params :: TemplateQueryKeyValuePairs
485− }
486− deriving (Eq, Show)
487−
488−instance ToJSON TemplateQueryInline where
489− toJSON TemplateQueryInline{..} = object [ "inline" .= inline
490− , "params" .= params
491− ]
492−
493−instance FromJSON TemplateQueryInline where
494− parseJSON = withObject "TemplateQueryInline" parse
495− where parse o = TemplateQueryInline
496− <$> o .: "inline"
497− <*> o .: "params"
498−
499−{-| 'BooleanOperator' is the usual And/Or operators with an ES compatible
500− JSON encoding baked in. Used all over the place.
501−-}
502−data BooleanOperator = And | Or deriving (Eq, Show)
503
1403
504−{-| 'Cache' is for telling ES whether it should cache a 'Filter' not.
1404+data DistanceUnit = Miles
505− 'Query's cannot be cached.
1405+ | Yards
506−-}
1406+ | Feet
507−type Cache = Bool -- caching on/off
1407+ | Inches
508−defaultCache :: Cache
1408+ | Kilometers
509−defaultCache = False
1409+ | Meters
510−
1410+ | Centimeters
511−
1411+ | Millimeters
512−data FunctionScoreQuery =
1412+ | NauticalMiles deriving (Eq, Show)
513− FunctionScoreQuery { functionScoreQuery :: Maybe Query
514− , functionScoreBoost :: Maybe Boost
515− , functionScoreFunctions :: FunctionScoreFunctions
516− , functionScoreMaxBoost :: Maybe Boost
517− , functionScoreBoostMode :: Maybe BoostMode
518− , functionScoreMinScore :: Score
519− , functionScoreScoreMode :: Maybe ScoreMode
520− } deriving (Eq, Show)
521−
522−instance ToJSON FunctionScoreQuery where
523− toJSON (FunctionScoreQuery query boost fns maxBoost boostMode minScore scoreMode) =
524− omitNulls base
525− where base = functionScoreFunctionsPair fns :
526− [ "query" .= query
527− , "boost" .= boost
528− , "max_boost" .= maxBoost
529− , "boost_mode" .= boostMode
530− , "min_score" .= minScore
531− , "score_mode" .= scoreMode ]
532−
533−instance FromJSON FunctionScoreQuery where
534− parseJSON = withObject "FunctionScoreQuery" parse
535− where parse o = FunctionScoreQuery
536− <$> o .:? "query"
537− <*> o .:? "boost"
538− <*> (singleFunction o
539− <|> multipleFunctions `taggedWith` "functions")
540− <*> o .:? "max_boost"
541− <*> o .:? "boost_mode"
542− <*> o .:? "min_score"
543− <*> o .:? "score_mode"
544− where taggedWith parser k = parser =<< o .: k
545− singleFunction = fmap FunctionScoreSingle . parseFunctionScoreFunction
546− multipleFunctions = pure . FunctionScoreMultiple
547−
548−data FunctionScoreFunctions =
549− FunctionScoreSingle FunctionScoreFunction
550− | FunctionScoreMultiple (NonEmpty ComponentFunctionScoreFunction) deriving (Eq, Show)
551−
552−data ComponentFunctionScoreFunction =
553− ComponentFunctionScoreFunction { componentScoreFunctionFilter :: Maybe Filter
554− , componentScoreFunction :: FunctionScoreFunction
555− , componentScoreFunctionWeight :: Maybe Weight
556− } deriving (Eq, Show)
557−
558−instance ToJSON ComponentFunctionScoreFunction where
559− toJSON (ComponentFunctionScoreFunction filter' fn weight) =
560− omitNulls base
561− where base = functionScoreFunctionPair fn :
562− [ "filter" .= filter'
563− , "weight" .= weight ]
564−
565−instance FromJSON ComponentFunctionScoreFunction where
566− parseJSON = withObject "ComponentFunctionScoreFunction" parse
567− where parse o = ComponentFunctionScoreFunction
568− <$> o .:? "filter"
569− <*> parseFunctionScoreFunction o
570− <*> o .:? "weight"
571−
572−functionScoreFunctionsPair :: FunctionScoreFunctions -> (Text, Value)
573−functionScoreFunctionsPair (FunctionScoreSingle fn)
574− = functionScoreFunctionPair fn
575−functionScoreFunctionsPair (FunctionScoreMultiple componentFns) =
576− ("functions", toJSON componentFns)
577−
578−
579−instance ToJSON Query where
580− toJSON (TermQuery (Term termQueryField termQueryValue) boost) =
581− object [ "term" .=
582− object [termQueryField .= object merged]]
583− where
584− base = [ "value" .= termQueryValue ]
585− boosted = maybe [] (return . ("boost" .=)) boost
586− merged = mappend base boosted
587−
588− toJSON (TermsQuery fieldName terms) =
589− object [ "terms" .= object conjoined ]
590− where conjoined = [fieldName .= terms]
591−
592− toJSON (IdsQuery idsQueryMappingName docIds) =
593− object [ "ids" .= object conjoined ]
594− where conjoined = [ "type" .= idsQueryMappingName
595− , "values" .= fmap toJSON docIds ]
596−
597− toJSON (QueryQueryStringQuery qQueryStringQuery) =
598− object [ "query_string" .= qQueryStringQuery ]
599−
600− toJSON (QueryMatchQuery matchQuery) =
601− object [ "match" .= matchQuery ]
602−
603− toJSON (QueryMultiMatchQuery multiMatchQuery) =
604− toJSON multiMatchQuery
605−
606− toJSON (QueryBoolQuery boolQuery) =
607− object [ "bool" .= boolQuery ]
608−
609− toJSON (QueryBoostingQuery boostingQuery) =
610− object [ "boosting" .= boostingQuery ]
611−
612− toJSON (QueryCommonTermsQuery commonTermsQuery) =
613− object [ "common" .= commonTermsQuery ]
614−
615− toJSON (ConstantScoreQuery query boost) =
616− object ["constant_score" .= object ["query" .= query
617− , "boost" .= boost]]
618−
619− toJSON (QueryFunctionScoreQuery functionScoreQuery) =
620− object [ "function_score" .= functionScoreQuery ]
621−
622− toJSON (QueryDisMaxQuery disMaxQuery) =
623− object [ "dis_max" .= disMaxQuery ]
624−
625− toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) =
626− object [ "fuzzy_like_this" .= fuzzyQuery ]
627−
628− toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) =
629− object [ "fuzzy_like_this_field" .= fuzzyFieldQuery ]
630−
631− toJSON (QueryFuzzyQuery fuzzyQuery) =
632− object [ "fuzzy" .= fuzzyQuery ]
633−
634− toJSON (QueryHasChildQuery childQuery) =
635− object [ "has_child" .= childQuery ]
636−
637− toJSON (QueryHasParentQuery parentQuery) =
638− object [ "has_parent" .= parentQuery ]
639−
640− toJSON (QueryIndicesQuery qIndicesQuery) =
641− object [ "indices" .= qIndicesQuery ]
642−
643− toJSON (MatchAllQuery boost) =
644− object [ "match_all" .= omitNulls [ "boost" .= boost ] ]
645−
646− toJSON (QueryMoreLikeThisQuery query) =
647− object [ "more_like_this" .= query ]
648−
649− toJSON (QueryMoreLikeThisFieldQuery query) =
650− object [ "more_like_this_field" .= query ]
651−
652− toJSON (QueryNestedQuery query) =
653− object [ "nested" .= query ]
654−
655− toJSON (QueryPrefixQuery query) =
656− object [ "prefix" .= query ]
657−
658− toJSON (QueryRangeQuery query) =
659− object [ "range" .= query ]
660−
661− toJSON (QueryRegexpQuery query) =
662− object [ "regexp" .= query ]
663−
664− toJSON (QuerySimpleQueryStringQuery query) =
665− object [ "simple_query_string" .= query ]
666−
667− toJSON (QueryExistsQuery (FieldName fieldName)) =
668− object ["exists" .= object
669− ["field" .= fieldName]
670− ]
671− toJSON QueryMatchNoneQuery =
672− object ["match_none" .= object []]
673−
674− toJSON (QueryTemplateQueryInline templateQuery) =
675− object [ "template" .= templateQuery ]
676−
677−instance FromJSON Query where
678− parseJSON v = withObject "Query" parse v
679− where parse o = termQuery `taggedWith` "term"
680− <|> termsQuery `taggedWith` "terms"
681− <|> idsQuery `taggedWith` "ids"
682− <|> queryQueryStringQuery `taggedWith` "query_string"
683− <|> queryMatchQuery `taggedWith` "match"
684− <|> queryMultiMatchQuery
685− <|> queryBoolQuery `taggedWith` "bool"
686− <|> queryBoostingQuery `taggedWith` "boosting"
687− <|> queryCommonTermsQuery `taggedWith` "common"
688− <|> constantScoreQuery `taggedWith` "constant_score"
689− <|> queryFunctionScoreQuery `taggedWith` "function_score"
690− <|> queryDisMaxQuery `taggedWith` "dis_max"
691− <|> queryFuzzyLikeThisQuery `taggedWith` "fuzzy_like_this"
692− <|> queryFuzzyLikeFieldQuery `taggedWith` "fuzzy_like_this_field"
693− <|> queryFuzzyQuery `taggedWith` "fuzzy"
694− <|> queryHasChildQuery `taggedWith` "has_child"
695− <|> queryHasParentQuery `taggedWith` "has_parent"
696− <|> queryIndicesQuery `taggedWith` "indices"
697− <|> matchAllQuery `taggedWith` "match_all"
698− <|> queryMoreLikeThisQuery `taggedWith` "more_like_this"
699− <|> queryMoreLikeThisFieldQuery `taggedWith` "more_like_this_field"
700− <|> queryNestedQuery `taggedWith` "nested"
701− <|> queryPrefixQuery `taggedWith` "prefix"
702− <|> queryRangeQuery `taggedWith` "range"
703− <|> queryRegexpQuery `taggedWith` "regexp"
704− <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"
705− <|> queryTemplateQueryInline `taggedWith` "template"
706− where taggedWith parser k = parser =<< o .: k
707− termQuery = fieldTagged $ \(FieldName fn) o ->
708− TermQuery <$> (Term fn <$> o .: "value") <*> o .:? "boost"
709− termsQuery o = case HM.toList o of
710− [(fn, vs)] -> do vals <- parseJSON vs
711− case vals of
712− x:xs -> return (TermsQuery fn (x :| xs))
713− _ -> fail "Expected non empty list of values"
714− _ -> fail "Expected object with 1 field-named key"
715− idsQuery o = IdsQuery <$> o .: "type"
716− <*> o .: "values"
717− queryQueryStringQuery = pure . QueryQueryStringQuery
718− queryMatchQuery = pure . QueryMatchQuery
719− queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v
720− queryBoolQuery = pure . QueryBoolQuery
721− queryBoostingQuery = pure . QueryBoostingQuery
722− queryCommonTermsQuery = pure . QueryCommonTermsQuery
723− constantScoreQuery o = case HM.lookup "query" o of
724− Just x -> ConstantScoreQuery <$> parseJSON x
725− <*> o .: "boost"
726− _ -> fail "Does not appear to be a ConstantScoreQuery"
727− queryFunctionScoreQuery = pure . QueryFunctionScoreQuery
728− queryDisMaxQuery = pure . QueryDisMaxQuery
729− queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery
730− queryFuzzyLikeFieldQuery = pure . QueryFuzzyLikeFieldQuery
731− queryFuzzyQuery = pure . QueryFuzzyQuery
732− queryHasChildQuery = pure . QueryHasChildQuery
733− queryHasParentQuery = pure . QueryHasParentQuery
734− queryIndicesQuery = pure . QueryIndicesQuery
735− matchAllQuery o = MatchAllQuery <$> o .:? "boost"
736− queryMoreLikeThisQuery = pure . QueryMoreLikeThisQuery
737− queryMoreLikeThisFieldQuery = pure . QueryMoreLikeThisFieldQuery
738− queryNestedQuery = pure . QueryNestedQuery
739− queryPrefixQuery = pure . QueryPrefixQuery
740− queryRangeQuery = pure . QueryRangeQuery
741− queryRegexpQuery = pure . QueryRegexpQuery
742− querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery
743− -- queryExistsQuery o = QueryExistsQuery <$> o .: "field"
744− queryTemplateQueryInline = pure . QueryTemplateQueryInline
745−
746−fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a
747−fieldTagged f o = case HM.toList o of
748− [(k, Object o')] -> f (FieldName k) o'
749− _ -> fail "Expected object with 1 field-named key"
750−
751−instance ToJSON SimpleQueryStringQuery where
752− toJSON SimpleQueryStringQuery {..} =
753− omitNulls (base ++ maybeAdd)
754− where base = [ "query" .= simpleQueryStringQuery ]
755− maybeAdd = [ "fields" .= simpleQueryStringField
756− , "default_operator" .= simpleQueryStringOperator
757− , "analyzer" .= simpleQueryStringAnalyzer
758− , "flags" .= simpleQueryStringFlags
759− , "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded
760− , "locale" .= simpleQueryStringLocale ]
761−
762−instance FromJSON SimpleQueryStringQuery where
763− parseJSON = withObject "SimpleQueryStringQuery" parse
764− where parse o = SimpleQueryStringQuery <$> o .: "query"
765− <*> o .:? "fields"
766− <*> o .:? "default_operator"
767− <*> o .:? "analyzer"
768− <*> (parseFlags <$> o .:? "flags")
769− <*> o .:? "lowercase_expanded_terms"
770− <*> o .:? "locale"
771− parseFlags (Just (x:xs)) = Just (x :| xs)
772− parseFlags _ = Nothing
773−
774−instance ToJSON FieldOrFields where
775− toJSON (FofField fieldName) =
776− toJSON fieldName
777− toJSON (FofFields fieldNames) =
778− toJSON fieldNames
779−
780−instance FromJSON FieldOrFields where
781− parseJSON v = FofField <$> parseJSON v
782− <|> FofFields <$> (parseNEJSON =<< parseJSON v)
783−
784−instance ToJSON SimpleQueryFlag where
785− toJSON SimpleQueryAll = "ALL"
786− toJSON SimpleQueryNone = "NONE"
787− toJSON SimpleQueryAnd = "AND"
788− toJSON SimpleQueryOr = "OR"
789− toJSON SimpleQueryPrefix = "PREFIX"
790− toJSON SimpleQueryPhrase = "PHRASE"
791− toJSON SimpleQueryPrecedence = "PRECEDENCE"
792− toJSON SimpleQueryEscape = "ESCAPE"
793− toJSON SimpleQueryWhitespace = "WHITESPACE"
794− toJSON SimpleQueryFuzzy = "FUZZY"
795− toJSON SimpleQueryNear = "NEAR"
796− toJSON SimpleQuerySlop = "SLOP"
797−
798−instance FromJSON SimpleQueryFlag where
799− parseJSON = withText "SimpleQueryFlag" parse
800− where parse "ALL" = pure SimpleQueryAll
801− parse "NONE" = pure SimpleQueryNone
802− parse "AND" = pure SimpleQueryAnd
803− parse "OR" = pure SimpleQueryOr
804− parse "PREFIX" = pure SimpleQueryPrefix
805− parse "PHRASE" = pure SimpleQueryPhrase
806− parse "PRECEDENCE" = pure SimpleQueryPrecedence
807− parse "ESCAPE" = pure SimpleQueryEscape
808− parse "WHITESPACE" = pure SimpleQueryWhitespace
809− parse "FUZZY" = pure SimpleQueryFuzzy
810− parse "NEAR" = pure SimpleQueryNear
811− parse "SLOP" = pure SimpleQuerySlop
812− parse f = fail ("Unexpected SimpleQueryFlag: " <> show f)
813−
814−instance ToJSON RegexpQuery where
815− toJSON (RegexpQuery (FieldName rqQueryField)
816− (Regexp regexpQueryQuery) rqQueryFlags
817− rqQueryBoost) =
818− object [ rqQueryField .= omitNulls base ]
819− where base = [ "value" .= regexpQueryQuery
820− , "flags" .= rqQueryFlags
821− , "boost" .= rqQueryBoost ]
822−
823−instance FromJSON RegexpQuery where
824− parseJSON = withObject "RegexpQuery" parse
825− where parse = fieldTagged $ \fn o ->
826− RegexpQuery fn
827− <$> o .: "value"
828− <*> o .: "flags"
829− <*> o .:? "boost"
830−
831−instance ToJSON QueryStringQuery where
832− toJSON (QueryStringQuery qsQueryString
833− qsDefaultField qsOperator
834− qsAnalyzer qsAllowWildcard
835− qsLowercaseExpanded qsEnablePositionIncrements
836− qsFuzzyMaxExpansions qsFuzziness
837− qsFuzzyPrefixLength qsPhraseSlop
838− qsBoost qsAnalyzeWildcard
839− qsGeneratePhraseQueries qsMinimumShouldMatch
840− qsLenient qsLocale) =
841− omitNulls base
842− where
843− base = [ "query" .= qsQueryString
844− , "default_field" .= qsDefaultField
845− , "default_operator" .= qsOperator
846− , "analyzer" .= qsAnalyzer
847− , "allow_leading_wildcard" .= qsAllowWildcard
848− , "lowercase_expanded_terms" .= qsLowercaseExpanded
849− , "enable_position_increments" .= qsEnablePositionIncrements
850− , "fuzzy_max_expansions" .= qsFuzzyMaxExpansions
851− , "fuzziness" .= qsFuzziness
852− , "fuzzy_prefix_length" .= qsFuzzyPrefixLength
853− , "phrase_slop" .= qsPhraseSlop
854− , "boost" .= qsBoost
855− , "analyze_wildcard" .= qsAnalyzeWildcard
856− , "auto_generate_phrase_queries" .= qsGeneratePhraseQueries
857− , "minimum_should_match" .= qsMinimumShouldMatch
858− , "lenient" .= qsLenient
859− , "locale" .= qsLocale ]
860−
861−instance FromJSON QueryStringQuery where
862− parseJSON = withObject "QueryStringQuery" parse
863− where parse o = QueryStringQuery
864− <$> o .: "query"
865− <*> o .:? "default_field"
866− <*> o .:? "default_operator"
867− <*> o .:? "analyzer"
868− <*> o .:? "allow_leading_wildcard"
869− <*> o .:? "lowercase_expanded_terms"
870− <*> o .:? "enable_position_increments"
871− <*> o .:? "fuzzy_max_expansions"
872− <*> o .:? "fuzziness"
873− <*> o .:? "fuzzy_prefix_length"
874− <*> o .:? "phrase_slop"
875− <*> o .:? "boost"
876− <*> o .:? "analyze_wildcard"
877− <*> o .:? "auto_generate_phrase_queries"
878− <*> o .:? "minimum_should_match"
879− <*> o .:? "lenient"
880− <*> o .:? "locale"
881−
882−instance ToJSON RangeQuery where
883− toJSON (RangeQuery (FieldName fieldName) range boost) =
884− object [ fieldName .= object conjoined ]
885− where conjoined = [ "boost" .= boost ] ++ (rangeValueToPair range)
886−
887−instance FromJSON RangeQuery where
888− parseJSON = withObject "RangeQuery" parse
889− where parse = fieldTagged $ \fn o ->
890− RangeQuery fn
891− <$> parseJSON (Object o)
892− <*> o .: "boost"
893−
894−instance FromJSON RangeValue where
895− parseJSON = withObject "RangeValue" parse
896− where parse o = parseDate o
897− <|> parseDouble o
898− parseDate o = do lt <- o .:? "lt"
899− lte <- o .:? "lte"
900− gt <- o .:? "gt"
901− gte <- o .:? "gte"
902− case (lt, lte, gt, gte) of
903− (Just a, _, Just b, _) -> return (RangeDateGtLt (GreaterThanD b) (LessThanD a))
904− (Just a, _, _, Just b)-> return (RangeDateGteLt (GreaterThanEqD b) (LessThanD a))
905− (_, Just a, Just b, _)-> return (RangeDateGtLte (GreaterThanD b) (LessThanEqD a))
906− (_, Just a, _, Just b)-> return (RangeDateGteLte (GreaterThanEqD b) (LessThanEqD a))
907− (_, _, Just a, _)-> return (RangeDateGt (GreaterThanD a))
908− (Just a, _, _, _)-> return (RangeDateLt (LessThanD a))
909− (_, _, _, Just a)-> return (RangeDateGte (GreaterThanEqD a))
910− (_, Just a, _, _)-> return (RangeDateLte (LessThanEqD a))
911− (Nothing, Nothing, Nothing, Nothing) -> mzero
912− parseDouble o = do lt <- o .:? "lt"
913− lte <- o .:? "lte"
914− gt <- o .:? "gt"
915− gte <- o .:? "gte"
916− case (lt, lte, gt, gte) of
917− (Just a, _, Just b, _) -> return (RangeDoubleGtLt (GreaterThan b) (LessThan a))
918− (Just a, _, _, Just b)-> return (RangeDoubleGteLt (GreaterThanEq b) (LessThan a))
919− (_, Just a, Just b, _)-> return (RangeDoubleGtLte (GreaterThan b) (LessThanEq a))
920− (_, Just a, _, Just b)-> return (RangeDoubleGteLte (GreaterThanEq b) (LessThanEq a))
921− (_, _, Just a, _)-> return (RangeDoubleGt (GreaterThan a))
922− (Just a, _, _, _)-> return (RangeDoubleLt (LessThan a))
923− (_, _, _, Just a)-> return (RangeDoubleGte (GreaterThanEq a))
924− (_, Just a, _, _)-> return (RangeDoubleLte (LessThanEq a))
925− (Nothing, Nothing, Nothing, Nothing) -> mzero
926−
927−instance ToJSON PrefixQuery where
928− toJSON (PrefixQuery (FieldName fieldName) queryValue boost) =
929− object [ fieldName .= omitNulls base ]
930− where base = [ "value" .= queryValue
931− , "boost" .= boost ]
932−
933−instance FromJSON PrefixQuery where
934− parseJSON = withObject "PrefixQuery" parse
935− where parse = fieldTagged $ \fn o ->
936− PrefixQuery fn
937− <$> o .: "value"
938− <*> o .:? "boost"
939−
940−instance ToJSON NestedQuery where
941− toJSON (NestedQuery nqPath nqScoreType nqQuery) =
942− object [ "path" .= nqPath
943− , "score_mode" .= nqScoreType
944− , "query" .= nqQuery ]
945−
946−instance FromJSON NestedQuery where
947− parseJSON = withObject "NestedQuery" parse
948− where parse o = NestedQuery
949− <$> o .: "path"
950− <*> o .: "score_mode"
951− <*> o .: "query"
952−
953−instance ToJSON MoreLikeThisFieldQuery where
954− toJSON (MoreLikeThisFieldQuery text (FieldName fieldName)
955− percent mtf mqt stopwords mindf maxdf
956− minwl maxwl boostTerms boost analyzer) =
957− object [ fieldName .= omitNulls base ]
958− where base = [ "like_text" .= text
959− , "percent_terms_to_match" .= percent
960− , "min_term_freq" .= mtf
961− , "max_query_terms" .= mqt
962− , "stop_words" .= stopwords
963− , "min_doc_freq" .= mindf
964− , "max_doc_freq" .= maxdf
965− , "min_word_length" .= minwl
966− , "max_word_length" .= maxwl
967− , "boost_terms" .= boostTerms
968− , "boost" .= boost
969− , "analyzer" .= analyzer ]
970−
971−instance FromJSON MoreLikeThisFieldQuery where
972− parseJSON = withObject "MoreLikeThisFieldQuery" parse
973− where parse = fieldTagged $ \fn o ->
974− MoreLikeThisFieldQuery
975− <$> o .: "like_text"
976− <*> pure fn
977− <*> o .:? "percent_terms_to_match"
978− <*> o .:? "min_term_freq"
979− <*> o .:? "max_query_terms"
980− -- <*> (optionalNE =<< o .:? "stop_words")
981− <*> o .:? "stop_words"
982− <*> o .:? "min_doc_freq"
983− <*> o .:? "max_doc_freq"
984− <*> o .:? "min_word_length"
985− <*> o .:? "max_word_length"
986− <*> o .:? "boost_terms"
987− <*> o .:? "boost"
988− <*> o .:? "analyzer"
989− -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)
990−
991−instance ToJSON MoreLikeThisQuery where
992− toJSON (MoreLikeThisQuery text fields percent
993− mtf mqt stopwords mindf maxdf
994− minwl maxwl boostTerms boost analyzer) =
995− omitNulls base
996− where base = [ "like_text" .= text
997− , "fields" .= fields
998− , "percent_terms_to_match" .= percent
999− , "min_term_freq" .= mtf
1000− , "max_query_terms" .= mqt
1001− , "stop_words" .= stopwords
1002− , "min_doc_freq" .= mindf
1003− , "max_doc_freq" .= maxdf
1004− , "min_word_length" .= minwl
1005− , "max_word_length" .= maxwl
1006− , "boost_terms" .= boostTerms
1007− , "boost" .= boost
1008− , "analyzer" .= analyzer ]
1009−
1010−instance FromJSON MoreLikeThisQuery where
1011− parseJSON = withObject "MoreLikeThisQuery" parse
1012− where parse o = MoreLikeThisQuery
1013− <$> o .: "like_text"
1014− -- <*> (optionalNE =<< o .:? "fields")
1015− <*> o .:? "fields"
1016− <*> o .:? "percent_terms_to_match"
1017− <*> o .:? "min_term_freq"
1018− <*> o .:? "max_query_terms"
1019− -- <*> (optionalNE =<< o .:? "stop_words")
1020− <*> o .:? "stop_words"
1021− <*> o .:? "min_doc_freq"
1022− <*> o .:? "max_doc_freq"
1023− <*> o .:? "min_word_length"
1024− <*> o .:? "max_word_length"
1025− <*> o .:? "boost_terms"
1026− <*> o .:? "boost"
1027− <*> o .:? "analyzer"
1028− -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)
1029−
1030−instance ToJSON IndicesQuery where
1031− toJSON (IndicesQuery indices query noMatch) =
1032− omitNulls [ "indices" .= indices
1033− , "no_match_query" .= noMatch
1034− , "query" .= query ]
1035−
1036−instance FromJSON IndicesQuery where
1037− parseJSON = withObject "IndicesQuery" parse
1038− where parse o = IndicesQuery
1039− <$> o .:? "indices" .!= []
1040− <*> o .: "query"
1041− <*> o .:? "no_match_query"
1042−
1043−instance ToJSON HasParentQuery where
1044− toJSON (HasParentQuery queryType query scoreType) =
1045− omitNulls [ "parent_type" .= queryType
1046− , "score_type" .= scoreType
1047− , "query" .= query ]
1048−
1049−instance FromJSON HasParentQuery where
1050− parseJSON = withObject "HasParentQuery" parse
1051− where parse o = HasParentQuery
1052− <$> o .: "parent_type"
1053− <*> o .: "query"
1054− <*> o .:? "score_type"
1055−
1056−instance ToJSON HasChildQuery where
1057− toJSON (HasChildQuery queryType query scoreType) =
1058− omitNulls [ "query" .= query
1059− , "score_type" .= scoreType
1060− , "type" .= queryType ]
1061−
1062−instance FromJSON HasChildQuery where
1063− parseJSON = withObject "HasChildQuery" parse
1064− where parse o = HasChildQuery
1065− <$> o .: "type"
1066− <*> o .: "query"
1067− <*> o .:? "score_type"
1068−
1069−instance ToJSON FuzzyQuery where
1070− toJSON (FuzzyQuery (FieldName fieldName) queryText
1071− prefixLength maxEx fuzziness boost) =
1072− object [ fieldName .= omitNulls base ]
1073− where base = [ "value" .= queryText
1074− , "fuzziness" .= fuzziness
1075− , "prefix_length" .= prefixLength
1076− , "boost" .= boost
1077− , "max_expansions" .= maxEx ]
1078−
1079−instance FromJSON FuzzyQuery where
1080− parseJSON = withObject "FuzzyQuery" parse
1081− where parse = fieldTagged $ \fn o ->
1082− FuzzyQuery fn
1083− <$> o .: "value"
1084− <*> o .: "prefix_length"
1085− <*> o .: "max_expansions"
1086− <*> o .: "fuzziness"
1087− <*> o .:? "boost"
1088−
1089−instance ToJSON FuzzyLikeFieldQuery where
1090− toJSON (FuzzyLikeFieldQuery (FieldName fieldName)
1091− fieldText maxTerms ignoreFreq fuzziness prefixLength
1092− boost analyzer) =
1093− object [ fieldName .=
1094− omitNulls [ "like_text" .= fieldText
1095− , "max_query_terms" .= maxTerms
1096− , "ignore_tf" .= ignoreFreq
1097− , "fuzziness" .= fuzziness
1098− , "prefix_length" .= prefixLength
1099− , "analyzer" .= analyzer
1100− , "boost" .= boost ]]
1101−
1102−instance FromJSON FuzzyLikeFieldQuery where
1103− parseJSON = withObject "FuzzyLikeFieldQuery" parse
1104− where parse = fieldTagged $ \fn o ->
1105− FuzzyLikeFieldQuery fn
1106− <$> o .: "like_text"
1107− <*> o .: "max_query_terms"
1108− <*> o .: "ignore_tf"
1109− <*> o .: "fuzziness"
1110− <*> o .: "prefix_length"
1111− <*> o .: "boost"
1112− <*> o .:? "analyzer"
1113−
1114−instance ToJSON FuzzyLikeThisQuery where
1115− toJSON (FuzzyLikeThisQuery fields text maxTerms
1116− ignoreFreq fuzziness prefixLength boost analyzer) =
1117− omitNulls base
1118− where base = [ "fields" .= fields
1119− , "like_text" .= text
1120− , "max_query_terms" .= maxTerms
1121− , "ignore_tf" .= ignoreFreq
1122− , "fuzziness" .= fuzziness
1123− , "prefix_length" .= prefixLength
1124− , "analyzer" .= analyzer
1125− , "boost" .= boost ]
1126−
1127−instance FromJSON FuzzyLikeThisQuery where
1128− parseJSON = withObject "FuzzyLikeThisQuery" parse
1129− where parse o = FuzzyLikeThisQuery
1130− <$> o .:? "fields" .!= []
1131− <*> o .: "like_text"
1132− <*> o .: "max_query_terms"
1133− <*> o .: "ignore_tf"
1134− <*> o .: "fuzziness"
1135− <*> o .: "prefix_length"
1136− <*> o .: "boost"
1137− <*> o .:? "analyzer"
1138−
1139−instance ToJSON DisMaxQuery where
1140− toJSON (DisMaxQuery queries tiebreaker boost) =
1141− omitNulls base
1142− where base = [ "queries" .= queries
1143− , "boost" .= boost
1144− , "tie_breaker" .= tiebreaker ]
1145−
1146−instance FromJSON DisMaxQuery where
1147− parseJSON = withObject "DisMaxQuery" parse
1148− where parse o = DisMaxQuery
1149− <$> o .:? "queries" .!= []
1150− <*> o .: "tie_breaker"
1151− <*> o .:? "boost"
1152−
1153−instance ToJSON CommonTermsQuery where
1154− toJSON (CommonTermsQuery (FieldName fieldName)
1155− (QueryString query) cf lfo hfo msm
1156− boost analyzer disableCoord) =
1157− object [fieldName .= omitNulls base ]
1158− where base = [ "query" .= query
1159− , "cutoff_frequency" .= cf
1160− , "low_freq_operator" .= lfo
1161− , "minimum_should_match" .= msm
1162− , "boost" .= boost
1163− , "analyzer" .= analyzer
1164− , "disable_coord" .= disableCoord
1165− , "high_freq_operator" .= hfo ]
1166−
1167−instance FromJSON CommonTermsQuery where
1168− parseJSON = withObject "CommonTermsQuery" parse
1169− where parse = fieldTagged $ \fn o ->
1170− CommonTermsQuery fn
1171− <$> o .: "query"
1172− <*> o .: "cutoff_frequency"
1173− <*> o .: "low_freq_operator"
1174− <*> o .: "high_freq_operator"
1175− <*> o .:? "minimum_should_match"
1176− <*> o .:? "boost"
1177− <*> o .:? "analyzer"
1178− <*> o .:? "disable_coord"
1179−
1180−instance ToJSON CommonMinimumMatch where
1181− toJSON (CommonMinimumMatch mm) = toJSON mm
1182− toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) =
1183− object [ "low_freq" .= lowF
1184− , "high_freq" .= highF ]
1185−
1186−instance FromJSON CommonMinimumMatch where
1187− parseJSON v = parseMinimum v
1188− <|> parseMinimumHighLow v
1189− where parseMinimum = fmap CommonMinimumMatch . parseJSON
1190− parseMinimumHighLow = fmap CommonMinimumMatchHighLow . withObject "CommonMinimumMatchHighLow" (\o ->
1191− MinimumMatchHighLow
1192− <$> o .: "low_freq"
1193− <*> o .: "high_freq")
1194−
1195−
1196−instance ToJSON BoostingQuery where
1197− toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) =
1198− object [ "positive" .= bqPositiveQuery
1199− , "negative" .= bqNegativeQuery
1200− , "negative_boost" .= bqNegativeBoost ]
1201−
1202−instance FromJSON BoostingQuery where
1203− parseJSON = withObject "BoostingQuery" parse
1204− where parse o = BoostingQuery
1205− <$> o .: "positive"
1206− <*> o .: "negative"
1207− <*> o .: "negative_boost"
1208−
1209−instance ToJSON BoolQuery where
1210− toJSON (BoolQuery mustM filterM' notM shouldM bqMin boost disableCoord) =
1211− omitNulls base
1212− where base = [ "must" .= mustM
1213− , "filter" .= filterM'
1214− , "must_not" .= notM
1215− , "should" .= shouldM
1216− , "minimum_should_match" .= bqMin
1217− , "boost" .= boost
1218− , "disable_coord" .= disableCoord ]
1219−
1220−instance FromJSON BoolQuery where
1221− parseJSON = withObject "BoolQuery" parse
1222− where parse o = BoolQuery
1223− <$> o .:? "must" .!= []
1224− <*> o .:? "filter" .!= []
1225− <*> o .:? "must_not" .!= []
1226− <*> o .:? "should" .!= []
1227− <*> o .:? "minimum_should_match"
1228− <*> o .:? "boost"
1229− <*> o .:? "disable_coord"
1230−
1231−instance ToJSON MatchQuery where
1232− toJSON (MatchQuery (FieldName fieldName)
1233− (QueryString mqQueryString) booleanOperator
1234− zeroTermsQuery cutoffFrequency matchQueryType
1235− analyzer maxExpansions lenient boost
1236− minShouldMatch
1237− ) =
1238− object [ fieldName .= omitNulls base ]
1239− where base = [ "query" .= mqQueryString
1240− , "operator" .= booleanOperator
1241− , "zero_terms_query" .= zeroTermsQuery
1242− , "cutoff_frequency" .= cutoffFrequency
1243− , "type" .= matchQueryType
1244− , "analyzer" .= analyzer
1245− , "max_expansions" .= maxExpansions
1246− , "lenient" .= lenient
1247− , "boost" .= boost
1248− , "minimum_should_match" .= minShouldMatch
1249− ]
1250−
1251−instance FromJSON MatchQuery where
1252− parseJSON = withObject "MatchQuery" parse
1253− where parse = fieldTagged $ \fn o ->
1254− MatchQuery fn
1255− <$> o .: "query"
1256− <*> o .: "operator"
1257− <*> o .: "zero_terms_query"
1258− <*> o .:? "cutoff_frequency"
1259− <*> o .:? "type"
1260− <*> o .:? "analyzer"
1261− <*> o .:? "max_expansions"
1262− <*> o .:? "lenient"
1263− <*> o .:? "boost"
1264− <*> o .:? "minimum_should_match"
1265−
1266−instance ToJSON MultiMatchQuery where
1267− toJSON (MultiMatchQuery fields (QueryString query) boolOp
1268− ztQ tb mmqt cf analyzer maxEx lenient) =
1269− object ["multi_match" .= omitNulls base]
1270− where base = [ "fields" .= fmap toJSON fields
1271− , "query" .= query
1272− , "operator" .= boolOp
1273− , "zero_terms_query" .= ztQ
1274− , "tie_breaker" .= tb
1275− , "type" .= mmqt
1276− , "cutoff_frequency" .= cf
1277− , "analyzer" .= analyzer
1278− , "max_expansions" .= maxEx
1279− , "lenient" .= lenient ]
1280−
1281−instance FromJSON MultiMatchQuery where
1282− parseJSON = withObject "MultiMatchQuery" parse
1283− where parse raw = do o <- raw .: "multi_match"
1284− MultiMatchQuery
1285− <$> o .:? "fields" .!= []
1286− <*> o .: "query"
1287− <*> o .: "operator"
1288− <*> o .: "zero_terms_query"
1289− <*> o .:? "tie_breaker"
1290− <*> o .:? "type"
1291− <*> o .:? "cutoff_frequency"
1292− <*> o .:? "analyzer"
1293− <*> o .:? "max_expansions"
1294− <*> o .:? "lenient"
1295−
1296−instance ToJSON MultiMatchQueryType where
1297− toJSON MultiMatchBestFields = "best_fields"
1298− toJSON MultiMatchMostFields = "most_fields"
1299− toJSON MultiMatchCrossFields = "cross_fields"
1300− toJSON MultiMatchPhrase = "phrase"
1301− toJSON MultiMatchPhrasePrefix = "phrase_prefix"
1302−
1303−instance FromJSON MultiMatchQueryType where
1304− parseJSON = withText "MultiMatchPhrasePrefix" parse
1305− where parse "best_fields" = pure MultiMatchBestFields
1306− parse "most_fields" = pure MultiMatchMostFields
1307− parse "cross_fields" = pure MultiMatchCrossFields
1308− parse "phrase" = pure MultiMatchPhrase
1309− parse "phrase_prefix" = pure MultiMatchPhrasePrefix
1310− parse t = fail ("Unexpected MultiMatchPhrasePrefix: " <> show t)
1311−
1312−instance ToJSON BooleanOperator where
1313− toJSON And = String "and"
1314− toJSON Or = String "or"
1315−
1316−instance FromJSON BooleanOperator where
1317− parseJSON = withText "BooleanOperator" parse
1318− where parse "and" = pure And
1319− parse "or" = pure Or
1320− parse o = fail ("Unexpected BooleanOperator: " <> show o)
1321−
1322−instance ToJSON ZeroTermsQuery where
1323− toJSON ZeroTermsNone = String "none"
1324− toJSON ZeroTermsAll = String "all"
1325−
1326−instance FromJSON ZeroTermsQuery where
1327− parseJSON = withText "ZeroTermsQuery" parse
1328− where parse "none" = pure ZeroTermsNone
1329− parse "all" = pure ZeroTermsAll
1330− parse q = fail ("Unexpected ZeroTermsQuery: " <> show q)
1331−
1332−instance ToJSON MatchQueryType where
1333− toJSON MatchPhrase = "phrase"
1334− toJSON MatchPhrasePrefix = "phrase_prefix"
1335−
1336−instance FromJSON MatchQueryType where
1337− parseJSON = withText "MatchQueryType" parse
1338− where parse "phrase" = pure MatchPhrase
1339− parse "phrase_prefix" = pure MatchPhrasePrefix
1340− parse t = fail ("Unexpected MatchQueryType: " <> show t)
1341−
1342−instance ToJSON ScoreType where
1343− toJSON ScoreTypeMax = "max"
1344− toJSON ScoreTypeAvg = "avg"
1345− toJSON ScoreTypeSum = "sum"
1346− toJSON ScoreTypeNone = "none"
1347−
1348−instance FromJSON ScoreType where
1349− parseJSON = withText "ScoreType" parse
1350− where parse "max" = pure ScoreTypeMax
1351− parse "avg" = pure ScoreTypeAvg
1352− parse "sum" = pure ScoreTypeSum
1353− parse "none" = pure ScoreTypeNone
1354− parse t = fail ("Unexpected ScoreType: " <> show t)
1355−
1356−instance ToJSON Distance where
1357− toJSON (Distance dCoefficient dUnit) =
1358− String boltedTogether where
1359− coefText = showText dCoefficient
1360− (String unitText) = toJSON dUnit
1361− boltedTogether = mappend coefText unitText
1362−
1363−instance FromJSON Distance where
1364− parseJSON = withText "Distance" parse
1365− where parse t = Distance <$> parseCoeff nT
1366− <*> parseJSON (String unitT)
1367− where (nT, unitT) = T.span validForNumber t
1368− -- may be a better way to do this
1369− validForNumber '-' = True
1370− validForNumber '.' = True
1371− validForNumber 'e' = True
1372− validForNumber c = isNumber c
1373− parseCoeff "" = fail "Empty string cannot be parsed as number"
1374− parseCoeff s = return (read (T.unpack s))
1375
1413
1376instance ToJSON DistanceUnit where
1414instance ToJSON DistanceUnit where
1377 toJSON Miles = String "mi"
1415 toJSON Miles = String "mi"
@@ -1384,7 +1422,6 @@ instance ToJSON DistanceUnit where
1384 toJSON Millimeters = String "mm"
1422 toJSON Millimeters = String "mm"
1385 toJSON NauticalMiles = String "nmi"
1423 toJSON NauticalMiles = String "nmi"
1386
1424
1387−
1388instance FromJSON DistanceUnit where
1425instance FromJSON DistanceUnit where
1389 parseJSON = withText "DistanceUnit" parse
1426 parseJSON = withText "DistanceUnit" parse
1390 where parse "mi" = pure Miles
1427 where parse "mi" = pure Miles
@@ -1398,6 +1435,10 @@ instance FromJSON DistanceUnit where
1398 parse "nmi" = pure NauticalMiles
1435 parse "nmi" = pure NauticalMiles
1399 parse u = fail ("Unrecognized DistanceUnit: " <> show u)
1436 parse u = fail ("Unrecognized DistanceUnit: " <> show u)
1400
1437
1438+data DistanceType = Arc
1439+ | SloppyArc -- doesn't exist <1.0
1440+ | Plane deriving (Eq, Show)
1441+
1401instance ToJSON DistanceType where
1442instance ToJSON DistanceType where
1402 toJSON Arc = String "arc"
1443 toJSON Arc = String "arc"
1403 toJSON SloppyArc = String "sloppy_arc"
1444 toJSON SloppyArc = String "sloppy_arc"
@@ -1410,6 +1451,9 @@ instance FromJSON DistanceType where
1410 parse "plane" = pure Plane
1451 parse "plane" = pure Plane
1411 parse t = fail ("Unrecognized DistanceType: " <> show t)
1452 parse t = fail ("Unrecognized DistanceType: " <> show t)
1412
1453
1454+data OptimizeBbox = OptimizeGeoFilterType GeoFilterType
1455+ | NoOptimizeBbox deriving (Eq, Show)
1456+
1413
1457
1414instance ToJSON OptimizeBbox where
1458instance ToJSON OptimizeBbox where
1415 toJSON NoOptimizeBbox = String "none"
1459 toJSON NoOptimizeBbox = String "none"
@@ -1422,121 +1466,175 @@ instance FromJSON OptimizeBbox where
1422 parseNoOptimize _ = mzero
1466 parseNoOptimize _ = mzero
1423 parseOptimize = fmap OptimizeGeoFilterType . parseJSON
1467 parseOptimize = fmap OptimizeGeoFilterType . parseJSON
1424
1468
1425−instance ToJSON GeoBoundingBoxConstraint where
1469+data Distance =
1426− toJSON (GeoBoundingBoxConstraint
1470+ Distance { coefficient :: Double
1427− (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') =
1471+ , unit :: DistanceUnit } deriving (Eq, Show)
1428− object [gbbcGeoBBField .= gbbcConstraintBox
1429− , "_cache" .= cache
1430− , "type" .= type']
1431
1472
1432−deleteSeveral :: (Eq k, Hashable k) => [k] -> HM.HashMap k v -> HM.HashMap k v
1433−deleteSeveral ks hm = foldr HM.delete hm ks
1434
1473
1435−instance FromJSON GeoBoundingBoxConstraint where
1474+instance ToJSON Distance where
1436− parseJSON = withObject "GeoBoundingBoxConstraint" parse
1475+ toJSON (Distance dCoefficient dUnit) =
1437− where parse o = case HM.toList (deleteSeveral ["type", "_cache"] o) of
1476+ String boltedTogether where
1438− [(fn, v)] -> GeoBoundingBoxConstraint (FieldName fn)
1477+ coefText = showText dCoefficient
1439− <$> parseJSON v
1478+ (String unitText) = toJSON dUnit
1440− <*> o .:? "_cache" .!= defaultCache
1479+ boltedTogether = mappend coefText unitText
1441− <*> o .: "type"
1442− _ -> fail "Could not find field name for GeoBoundingBoxConstraint"
1443
1480
1444−instance ToJSON GeoFilterType where
1481+instance FromJSON Distance where
1445− toJSON GeoFilterMemory = String "memory"
1482+ parseJSON = withText "Distance" parse
1446− toJSON GeoFilterIndexed = String "indexed"
1483+ where parse t = Distance <$> parseCoeff nT
1484+ <*> parseJSON (String unitT)
1485+ where (nT, unitT) = T.span validForNumber t
1486+ -- may be a better way to do this
1487+ validForNumber '-' = True
1488+ validForNumber '.' = True
1489+ validForNumber 'e' = True
1490+ validForNumber c = isNumber c
1491+ parseCoeff "" = fail "Empty string cannot be parsed as number"
1492+ parseCoeff s = return (read (T.unpack s))
1447
1493
1448−instance FromJSON GeoFilterType where
1494+data DistanceRange =
1449− parseJSON = withText "GeoFilterType" parse
1495+ DistanceRange { distanceFrom :: Distance
1450− where parse "memory" = pure GeoFilterMemory
1496+ , distanceTo :: Distance } deriving (Eq, Show)
1451− parse "indexed" = pure GeoFilterIndexed
1452− parse t = fail ("Unrecognized GeoFilterType: " <> show t)
1453
1497
1454−instance ToJSON GeoBoundingBox where
1498+type TemplateQueryKey = Text
1455− toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) =
1499+type TemplateQueryValue = Text
1456− object ["top_left" .= gbbTopLeft
1457− , "bottom_right" .= gbbBottomRight]
1458
1500
1459−instance FromJSON GeoBoundingBox where
1501+newtype TemplateQueryKeyValuePairs =
1460− parseJSON = withObject "GeoBoundingBox" parse
1502+ TemplateQueryKeyValuePairs (HM.HashMap TemplateQueryKey TemplateQueryValue)
1461− where parse o = GeoBoundingBox
1503+ deriving (Eq, Show)
1462− <$> o .: "top_left"
1463− <*> o .: "bottom_right"
1464
1504
1465−instance ToJSON LatLon where
1505+instance ToJSON TemplateQueryKeyValuePairs where
1466− toJSON (LatLon lLat lLon) =
1506+ toJSON (TemplateQueryKeyValuePairs x) =
1467− object ["lat" .= lLat
1507+ Object $ HM.map toJSON x
1468− , "lon" .= lLon]
1469
1508
1470−instance FromJSON LatLon where
1509+instance FromJSON TemplateQueryKeyValuePairs where
1471− parseJSON = withObject "LatLon" parse
1510+ parseJSON (Object o) =
1472− where parse o = LatLon <$> o .: "lat"
1511+ pure . TemplateQueryKeyValuePairs $ HM.mapMaybe getValue o
1473− <*> o .: "lon"
1512+ where getValue (String x) = Just x
1513+ getValue _ = Nothing
1514+ parseJSON _ =
1515+ fail "error parsing TemplateQueryKeyValuePairs"
1474
1516
1475−-- index for smaller ranges, fielddata for longer ranges
1517+data TemplateQueryInline =
1476−instance ToJSON RangeExecution where
1518+ TemplateQueryInline { inline :: Query
1477− toJSON RangeExecutionIndex = "index"
1519+ , params :: TemplateQueryKeyValuePairs
1478− toJSON RangeExecutionFielddata = "fielddata"
1520+ }
1521+ deriving (Eq, Show)
1479
1522
1523+instance ToJSON TemplateQueryInline where
1524+ toJSON TemplateQueryInline{..} = object [ "inline" .= inline
1525+ , "params" .= params
1526+ ]
1480
1527
1481−instance FromJSON RangeExecution where
1528+instance FromJSON TemplateQueryInline where
1482− parseJSON = withText "RangeExecution" parse
1529+ parseJSON = withObject "TemplateQueryInline" parse
1483− where parse "index" = pure RangeExecutionIndex
1530+ where parse o = TemplateQueryInline
1484− parse "fielddata" = pure RangeExecutionFielddata
1531+ <$> o .: "inline"
1485− parse t = error ("Unrecognized RangeExecution " <> show t)
1532+ <*> o .: "params"
1486
1533
1487−instance ToJSON RegexpFlags where
1534+{-| 'BooleanOperator' is the usual And/Or operators with an ES compatible
1488− toJSON AllRegexpFlags = String "ALL"
1535+ JSON encoding baked in. Used all over the place.
1489− toJSON NoRegexpFlags = String "NONE"
1536+-}
1490− toJSON (SomeRegexpFlags (h :| fs)) = String $ T.intercalate "|" flagStrs
1537+data BooleanOperator = And | Or deriving (Eq, Show)
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
1538
1499−instance FromJSON RegexpFlags where
1539+instance ToJSON BooleanOperator where
1500− parseJSON = withText "RegexpFlags" parse
1540+ toJSON And = String "and"
1501− where parse "ALL" = pure AllRegexpFlags
1541+ toJSON Or = String "or"
1502− parse "NONE" = pure NoRegexpFlags
1503− parse t = SomeRegexpFlags <$> parseNEJSON (String <$> T.splitOn "|" t)
1504
1542
1505−instance FromJSON RegexpFlag where
1543+instance FromJSON BooleanOperator where
1506− parseJSON = withText "RegexpFlag" parse
1544+ parseJSON = withText "BooleanOperator" parse
1507− where parse "ANYSTRING" = pure AnyString
1545+ where parse "and" = pure And
1508− parse "AUTOMATON" = pure Automaton
1546+ parse "or" = pure Or
1509− parse "COMPLEMENT" = pure Complement
1547+ parse o = fail ("Unexpected BooleanOperator: " <> show o)
1510− parse "EMPTY" = pure Empty
1511− parse "INTERSECTION" = pure Intersection
1512− parse "INTERVAL" = pure Interval
1513− parse f = fail ("Unknown RegexpFlag: " <> show f)
1514
1548
1515−instance ToJSON Term where
1549+{-| 'Cache' is for telling ES whether it should cache a 'Filter' not.
1516− toJSON (Term field value) = object ["term" .= object
1550+ 'Query's cannot be cached.
1517− [field .= value]]
1551+-}
1552+type Cache = Bool -- caching on/off
1553+defaultCache :: Cache
1554+defaultCache = False
1518
1555
1519−instance FromJSON Term where
1520− parseJSON = withObject "Term" parse
1521− where parse o = do termObj <- o .: "term"
1522− case HM.toList termObj of
1523− [(fn, v)] -> Term fn <$> parseJSON v
1524− _ -> fail "Expected object with 1 field-named key"
1525
1556
1526−instance ToJSON BoolMatch where
1557+data FunctionScoreQuery =
1527− toJSON (MustMatch term cache) = object ["must" .= term,
1558+ FunctionScoreQuery { functionScoreQuery :: Maybe Query
1528− "_cache" .= cache]
1559+ , functionScoreBoost :: Maybe Boost
1529− toJSON (MustNotMatch term cache) = object ["must_not" .= term,
1560+ , functionScoreFunctions :: FunctionScoreFunctions
1530− "_cache" .= cache]
1561+ , functionScoreMaxBoost :: Maybe Boost
1531− toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms,
1562+ , functionScoreBoostMode :: Maybe BoostMode
1532− "_cache" .= cache]
1563+ , functionScoreMinScore :: Score
1564+ , functionScoreScoreMode :: Maybe ScoreMode
1565+ } deriving (Eq, Show)
1533
1566
1534−instance FromJSON BoolMatch where
1567+instance ToJSON FunctionScoreQuery where
1568+ toJSON (FunctionScoreQuery query boost fns maxBoost boostMode minScore scoreMode) =
1569+ omitNulls base
1570+ where base = functionScoreFunctionsPair fns :
1571+ [ "query" .= query
1572+ , "boost" .= boost
1573+ , "max_boost" .= maxBoost
1574+ , "boost_mode" .= boostMode
1575+ , "min_score" .= minScore
1576+ , "score_mode" .= scoreMode ]
1577+
1578+instance FromJSON FunctionScoreQuery where
1535− parseJSON = withObject "BoolMatch" parse
1579+ parseJSON = withObject "FunctionScoreQuery" parse
1536− where parse o = mustMatch `taggedWith` "must"
1580+ where parse o = FunctionScoreQuery
1537− <|> mustNotMatch `taggedWith` "must_not"
1581+ <$> o .:? "query"
1538− <|> shouldMatch `taggedWith` "should"
1582+ <*> o .:? "boost"
1583+ <*> (singleFunction o
1584+ <|> multipleFunctions `taggedWith` "functions")
1585+ <*> o .:? "max_boost"
1586+ <*> o .:? "boost_mode"
1587+ <*> o .:? "min_score"
1588+ <*> o .:? "score_mode"
1539 where taggedWith parser k = parser =<< o .: k
1589 where taggedWith parser k = parser =<< o .: k
1540− mustMatch t = MustMatch t <$> o .:? "_cache" .!= defaultCache
1590+ singleFunction = fmap FunctionScoreSingle . parseFunctionScoreFunction
1541− mustNotMatch t = MustNotMatch t <$> o .:? "_cache" .!= defaultCache
1591+ multipleFunctions = pure . FunctionScoreMultiple
1542− shouldMatch t = ShouldMatch t <$> o .:? "_cache" .!= defaultCache
1592+
1593+data FunctionScoreFunctions =
1594+ FunctionScoreSingle FunctionScoreFunction
1595+ | FunctionScoreMultiple (NonEmpty ComponentFunctionScoreFunction) deriving (Eq, Show)
1596+
1597+data ComponentFunctionScoreFunction =
1598+ ComponentFunctionScoreFunction { componentScoreFunctionFilter :: Maybe Filter
1599+ , componentScoreFunction :: FunctionScoreFunction
1600+ , componentScoreFunctionWeight :: Maybe Weight
1601+ } deriving (Eq, Show)
1602+
1603+instance ToJSON ComponentFunctionScoreFunction where
1604+ toJSON (ComponentFunctionScoreFunction filter' fn weight) =
1605+ omitNulls base
1606+ where base = functionScoreFunctionPair fn :
1607+ [ "filter" .= filter'
1608+ , "weight" .= weight ]
1609+
1610+instance FromJSON ComponentFunctionScoreFunction where
1611+ parseJSON = withObject "ComponentFunctionScoreFunction" parse
1612+ where parse o = ComponentFunctionScoreFunction
1613+ <$> o .:? "filter"
1614+ <*> parseFunctionScoreFunction o
1615+ <*> o .:? "weight"
1616+
1617+functionScoreFunctionsPair :: FunctionScoreFunctions -> (Text, Value)
1618+functionScoreFunctionsPair (FunctionScoreSingle fn)
1619+ = functionScoreFunctionPair fn
1620+functionScoreFunctionsPair (FunctionScoreMultiple componentFns) =
1621+ ("functions", toJSON componentFns)
1622+
1623+fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a
1624+fieldTagged f o = case HM.toList o of
1625+ [(k, Object o')] -> f (FieldName k) o'
1626+ _ -> 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.hsnew file+107
@@ -0,0 +1,107 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
4+
5+module Database.Bloodhound.Internal.Sort where
6+
7+import Bloodhound.Import
8+
9+import Database.Bloodhound.Internal.Newtypes
10+import Database.Bloodhound.Internal.Query
11+
12+{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.
13+
14+http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option
15+-}
16+data SortMode = SortMin
17+ | SortMax
18+ | SortSum
19+ | SortAvg deriving (Eq, Show)
20+
21+instance ToJSON SortMode where
22+ toJSON SortMin = String "min"
23+ toJSON SortMax = String "max"
24+ toJSON SortSum = String "sum"
25+ toJSON SortAvg = String "avg"
26+
27+{-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so
28+ that you can concisely describe the usual kind of 'SortSpec's you want.
29+-}
30+mkSort :: FieldName -> SortOrder -> DefaultSort
31+mkSort fieldName sOrder = DefaultSort fieldName sOrder Nothing Nothing Nothing Nothing
32+
33+{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order
34+ dependent with later sorts acting as tie-breakers for earlier sorts.
35+-}
36+type Sort = [SortSpec]
37+
38+{-| The two main kinds of 'SortSpec' are 'DefaultSortSpec' and
39+ 'GeoDistanceSortSpec'. The latter takes a 'SortOrder', 'GeoPoint', and
40+ 'DistanceUnit' to express "nearness" to a single geographical point as a
41+ sort specification.
42+
43+<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
44+-}
45+data SortSpec =
46+ DefaultSortSpec DefaultSort
47+ | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit
48+ deriving (Eq, Show)
49+
50+instance ToJSON SortSpec where
51+ toJSON (DefaultSortSpec
52+ (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped
53+ dsSortMode dsMissingSort dsNestedFilter)) =
54+ object [dsSortFieldName .= omitNulls base] where
55+ base = [ "order" .= dsSortOrder
56+ , "unmapped_type" .= dsIgnoreUnmapped
57+ , "mode" .= dsSortMode
58+ , "missing" .= dsMissingSort
59+ , "nested_filter" .= dsNestedFilter ]
60+
61+ toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) =
62+ object [ "unit" .= units
63+ , field .= gdsLatLon
64+ , "order" .= gdsSortOrder ]
65+
66+{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a
67+ 'mkSort' convenience function for when you want to specify only the most
68+ common parameters.
69+
70+ The `ignoreUnmapped`, when `Just` field is used to set the elastic 'unmapped_type'
71+
72+<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
73+-}
74+data DefaultSort =
75+ DefaultSort { sortFieldName :: FieldName
76+ , sortOrder :: SortOrder
77+ -- default False
78+ , ignoreUnmapped :: Maybe Text
79+ , sortMode :: Maybe SortMode
80+ , missingSort :: Maybe Missing
81+ , nestedFilter :: Maybe Filter } deriving (Eq, Show)
82+
83+{-| 'SortOrder' is 'Ascending' or 'Descending', as you might expect. These get
84+ encoded into "asc" or "desc" when turned into JSON.
85+
86+<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
87+-}
88+data SortOrder = Ascending
89+ | Descending deriving (Eq, Show)
90+
91+instance ToJSON SortOrder where
92+ toJSON Ascending = String "asc"
93+ toJSON Descending = String "desc"
94+
95+{-| 'Missing' prescribes how to handle missing fields. A missing field can be
96+ sorted last, first, or using a custom value as a substitute.
97+
98+<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_missing_values>
99+-}
100+data Missing = LastMissing
101+ | FirstMissing
102+ | CustomMissing Text deriving (Eq, Show)
103+
104+instance ToJSON Missing where
105+ toJSON LastMissing = String "_last"
106+ toJSON FirstMissing = String "_first"
107+ toJSON (CustomMissing txt) = String txt
src/Database/V5/Bloodhound/Internal/StringlyTyped.hs → src/Database/Bloodhound/Internal/StringlyTyped.hsrenamed+3−3
@@ -1,11 +1,11 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2
2
3−module Database.V5.Bloodhound.Internal.StringlyTyped where
3+module Database.Bloodhound.Internal.StringlyTyped where
4+
5+import Bloodhound.Import
4
6
5−import Data.Aeson
6import qualified Data.Text as T
7import qualified Data.Text as T
7
8
8−import Bloodhound.Import
9
9
10-- This whole module is a sin bucket to deal with Elasticsearch badness.
10-- This whole module is a sin bucket to deal with Elasticsearch badness.
11newtype StringlyTypedDouble = StringlyTypedDouble
11newtype StringlyTypedDouble = StringlyTypedDouble
src/Database/Bloodhound/Internal/Suggest.hsnew file+270
@@ -0,0 +1,270 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+module Database.Bloodhound.Internal.Suggest where
6+
7+import Bloodhound.Import
8+
9+import qualified Data.HashMap.Strict as HM
10+
11+import Database.Bloodhound.Internal.Newtypes
12+import Database.Bloodhound.Internal.Query (TemplateQueryInline(..), params)
13+
14+data Suggest = Suggest
15+ { suggestText :: Text
16+ , suggestName :: Text
17+ , suggestType :: SuggestType
18+ } deriving (Eq, Show)
19+
20+instance ToJSON Suggest where
21+ toJSON Suggest{..} =
22+ object [ "text" .= suggestText
23+ , suggestName .= suggestType
24+ ]
25+
26+instance FromJSON Suggest where
27+ parseJSON (Object o) = do
28+ suggestText' <- o .: "text"
29+ let dropTextList =
30+ HM.toList
31+ $ HM.filterWithKey (\x _ -> x /= "text") o
32+ suggestName' <-
33+ case dropTextList of
34+ [(x, _)] -> return x
35+ _ -> fail "error parsing Suggest field name"
36+ suggestType' <- o .: suggestName'
37+ return $ Suggest suggestText' suggestName' suggestType'
38+ parseJSON x = typeMismatch "Suggest" x
39+
40+data SuggestType =
41+ SuggestTypePhraseSuggester PhraseSuggester
42+ deriving (Eq, Show)
43+
44+instance ToJSON SuggestType where
45+ toJSON (SuggestTypePhraseSuggester x) =
46+ object [ "phrase" .= x ]
47+
48+instance FromJSON SuggestType where
49+ parseJSON = withObject "SuggestType" parse
50+ where parse o = phraseSuggester `taggedWith` "phrase"
51+ where taggedWith parser k = parser =<< o .: k
52+ phraseSuggester = pure . SuggestTypePhraseSuggester
53+
54+data PhraseSuggester = PhraseSuggester
55+ { phraseSuggesterField :: FieldName
56+ , phraseSuggesterGramSize :: Maybe Int
57+ , phraseSuggesterRealWordErrorLikelihood :: Maybe Int
58+ , phraseSuggesterConfidence :: Maybe Int
59+ , phraseSuggesterMaxErrors :: Maybe Int
60+ , phraseSuggesterSeparator :: Maybe Text
61+ , phraseSuggesterSize :: Maybe Size
62+ , phraseSuggesterAnalyzer :: Maybe Analyzer
63+ , phraseSuggesterShardSize :: Maybe Int
64+ , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
65+ , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
66+ , phraseSuggesterCandidateGenerators :: [DirectGenerators]
67+ } deriving (Eq, Show)
68+
69+instance ToJSON PhraseSuggester where
70+ toJSON PhraseSuggester{..} =
71+ omitNulls [ "field" .= phraseSuggesterField
72+ , "gram_size" .= phraseSuggesterGramSize
73+ , "real_word_error_likelihood" .=
74+ phraseSuggesterRealWordErrorLikelihood
75+ , "confidence" .= phraseSuggesterConfidence
76+ , "max_errors" .= phraseSuggesterMaxErrors
77+ , "separator" .= phraseSuggesterSeparator
78+ , "size" .= phraseSuggesterSize
79+ , "analyzer" .= phraseSuggesterAnalyzer
80+ , "shard_size" .= phraseSuggesterShardSize
81+ , "highlight" .= phraseSuggesterHighlight
82+ , "collate" .= phraseSuggesterCollate
83+ , "direct_generator" .=
84+ phraseSuggesterCandidateGenerators
85+ ]
86+
87+instance FromJSON PhraseSuggester where
88+ parseJSON = withObject "PhraseSuggester" parse
89+ where parse o = PhraseSuggester
90+ <$> o .: "field"
91+ <*> o .:? "gram_size"
92+ <*> o .:? "real_word_error_likelihood"
93+ <*> o .:? "confidence"
94+ <*> o .:? "max_errors"
95+ <*> o .:? "separator"
96+ <*> o .:? "size"
97+ <*> o .:? "analyzer"
98+ <*> o .:? "shard_size"
99+ <*> o .:? "highlight"
100+ <*> o .:? "collate"
101+ <*> o .:? "direct_generator" .!= []
102+
103+mkPhraseSuggester :: FieldName -> PhraseSuggester
104+mkPhraseSuggester fName =
105+ PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
106+ Nothing Nothing Nothing Nothing []
107+
108+data PhraseSuggesterHighlighter =
109+ PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
110+ , phraseSuggesterHighlighterPostTag :: Text
111+ }
112+ deriving (Eq, Show)
113+
114+instance ToJSON PhraseSuggesterHighlighter where
115+ toJSON PhraseSuggesterHighlighter{..} =
116+ object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
117+ , "post_tag" .= phraseSuggesterHighlighterPostTag
118+ ]
119+
120+instance FromJSON PhraseSuggesterHighlighter where
121+ parseJSON = withObject "PhraseSuggesterHighlighter" parse
122+ where parse o = PhraseSuggesterHighlighter
123+ <$> o .: "pre_tag"
124+ <*> o .: "post_tag"
125+
126+data PhraseSuggesterCollate = PhraseSuggesterCollate
127+ { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
128+ , phraseSuggesterCollatePrune :: Bool
129+ } deriving (Eq, Show)
130+
131+instance ToJSON PhraseSuggesterCollate where
132+ toJSON PhraseSuggesterCollate{..} =
133+ object [ "query" .= object
134+ [ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
135+ ]
136+ , "params" .= (params phraseSuggesterCollateTemplateQuery)
137+ , "prune" .= phraseSuggesterCollatePrune
138+ ]
139+
140+instance FromJSON PhraseSuggesterCollate where
141+ parseJSON (Object o) = do
142+ query' <- o .: "query"
143+ inline' <- query' .: "inline"
144+ params' <- o .: "params"
145+ prune' <- o .:? "prune" .!= False
146+ return $ PhraseSuggesterCollate
147+ (TemplateQueryInline inline' params') prune'
148+ parseJSON x = typeMismatch "PhraseSuggesterCollate" x
149+
150+data SuggestOptions =
151+ SuggestOptions { suggestOptionsText :: Text
152+ , suggestOptionsScore :: Double
153+ , suggestOptionsFreq :: Maybe Int
154+ , suggestOptionsHighlighted :: Maybe Text
155+ }
156+ deriving (Eq, Read, Show)
157+
158+instance FromJSON SuggestOptions where
159+ parseJSON = withObject "SuggestOptions" parse
160+ where
161+ parse o = SuggestOptions
162+ <$> o .: "text"
163+ <*> o .: "score"
164+ <*> o .:? "freq"
165+ <*> o .:? "highlighted"
166+
167+data SuggestResponse =
168+ SuggestResponse { suggestResponseText :: Text
169+ , suggestResponseOffset :: Int
170+ , suggestResponseLength :: Int
171+ , suggestResponseOptions :: [SuggestOptions]
172+ }
173+ deriving (Eq, Read, Show)
174+
175+instance FromJSON SuggestResponse where
176+ parseJSON = withObject "SuggestResponse" parse
177+ where parse o = SuggestResponse
178+ <$> o .: "text"
179+ <*> o .: "offset"
180+ <*> o .: "length"
181+ <*> o .: "options"
182+
183+data NamedSuggestionResponse = NamedSuggestionResponse
184+ { nsrName :: Text
185+ , nsrResponses :: [SuggestResponse]
186+ } deriving (Eq, Read, Show)
187+
188+instance FromJSON NamedSuggestionResponse where
189+ parseJSON (Object o) = do
190+ suggestionName' <- case HM.toList o of
191+ [(x, _)] -> return x
192+ _ -> fail "error parsing NamedSuggestionResponse name"
193+ suggestionResponses' <- o .: suggestionName'
194+ return $ NamedSuggestionResponse suggestionName' suggestionResponses'
195+
196+ parseJSON x = typeMismatch "NamedSuggestionResponse" x
197+
198+data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing
199+ | DirectGeneratorSuggestModePopular
200+ | DirectGeneratorSuggestModeAlways
201+ deriving (Eq, Show)
202+
203+instance ToJSON DirectGeneratorSuggestModeTypes where
204+ toJSON DirectGeneratorSuggestModeMissing = "missing"
205+ toJSON DirectGeneratorSuggestModePopular = "popular"
206+ toJSON DirectGeneratorSuggestModeAlways = "always"
207+
208+instance FromJSON DirectGeneratorSuggestModeTypes where
209+ parseJSON = withText "DirectGeneratorSuggestModeTypes" parse
210+ where
211+ parse "missing" =
212+ pure DirectGeneratorSuggestModeMissing
213+ parse "popular" =
214+ pure DirectGeneratorSuggestModePopular
215+ parse "always" =
216+ pure DirectGeneratorSuggestModeAlways
217+ parse f =
218+ fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f)
219+
220+data DirectGenerators = DirectGenerators
221+ { directGeneratorsField :: FieldName
222+ , directGeneratorsSize :: Maybe Int
223+ , directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes
224+ , directGeneratorMaxEdits :: Maybe Double
225+ , directGeneratorPrefixLength :: Maybe Int
226+ , directGeneratorMinWordLength :: Maybe Int
227+ , directGeneratorMaxInspections :: Maybe Int
228+ , directGeneratorMinDocFreq :: Maybe Double
229+ , directGeneratorMaxTermFreq :: Maybe Double
230+ , directGeneratorPreFilter :: Maybe Text
231+ , directGeneratorPostFilter :: Maybe Text
232+ } deriving (Eq, Show)
233+
234+instance ToJSON DirectGenerators where
235+ toJSON DirectGenerators{..} =
236+ omitNulls [ "field" .= directGeneratorsField
237+ , "size" .= directGeneratorsSize
238+ , "suggest_mode" .= directGeneratorSuggestMode
239+ , "max_edits" .= directGeneratorMaxEdits
240+ , "prefix_length" .= directGeneratorPrefixLength
241+ , "min_word_length" .= directGeneratorMinWordLength
242+ , "max_inspections" .= directGeneratorMaxInspections
243+ , "min_doc_freq" .= directGeneratorMinDocFreq
244+ , "max_term_freq" .= directGeneratorMaxTermFreq
245+ , "pre_filter" .= directGeneratorPreFilter
246+ , "post_filter" .= directGeneratorPostFilter
247+ ]
248+
249+instance FromJSON DirectGenerators where
250+ parseJSON = withObject "DirectGenerators" parse
251+ where parse o = DirectGenerators
252+ <$> o .: "field"
253+ <*> o .:? "size"
254+ <*> o .: "suggest_mode"
255+ <*> o .:? "max_edits"
256+ <*> o .:? "prefix_length"
257+ <*> o .:? "min_word_length"
258+ <*> o .:? "max_inspections"
259+ <*> o .:? "min_doc_freq"
260+ <*> o .:? "max_term_freq"
261+ <*> o .:? "pre_filter"
262+ <*> o .:? "post_filter"
263+
264+mkDirectGenerators :: FieldName -> DirectGenerators
265+mkDirectGenerators fn =
266+ DirectGenerators
267+ fn
268+ Nothing
269+ DirectGeneratorSuggestModeMissing
270+ Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
src/Database/Bloodhound/Types.hsnew file+542
@@ -0,0 +1,542 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE NamedFieldPuns #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+-------------------------------------------------------------------------------
11+-- |
12+-- Module : Database.Bloodhound.Types
13+-- Copyright : (C) 2014, 2018 Chris Allen
14+-- License : BSD-style (see the file LICENSE)
15+-- Maintainer : Chris Allen <cma@bitemyapp.com
16+-- Stability : provisional
17+-- Portability : RecordWildCards
18+--
19+-- Data types for describing actions and data structures performed to interact
20+-- with Elasticsearch. The two main buckets your queries against Elasticsearch
21+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like
22+-- traditional database constraints and often have preferable performance
23+-- properties. 'Query's support human-written textual queries, such as fuzzy
24+-- queries.
25+-------------------------------------------------------------------------------
26+
27+
28+
29+module Database.Bloodhound.Types
30+ ( defaultCache
31+ , defaultIndexSettings
32+ , defaultIndexDocumentSettings
33+ , mkSort
34+ , showText
35+ , unpackId
36+ , mkMatchQuery
37+ , mkMultiMatchQuery
38+ , mkBoolQuery
39+ , mkRangeQuery
40+ , mkQueryStringQuery
41+ , mkAggregations
42+ , mkTermsAggregation
43+ , mkTermsScriptAggregation
44+ , mkDateHistogram
45+ , mkCardinalityAggregation
46+ , mkDocVersion
47+ , mkStatsAggregation
48+ , mkExtendedStatsAggregation
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+ , Compression(..)
75+ , ReplicaBounds(..)
76+ , Bytes(..)
77+ , gigabytes
78+ , megabytes
79+ , kilobytes
80+ , FSType(..)
81+ , InitialShardCount(..)
82+ , NodeAttrFilter(..)
83+ , NodeAttrName(..)
84+ , CompoundFormat(..)
85+ , IndexTemplate(..)
86+ , Server(..)
87+ , Reply
88+ , EsResult(..)
89+ , EsResultFound(..)
90+ , EsError(..)
91+ , EsProtocolException(..)
92+ , IndexAlias(..)
93+ , IndexAliasName(..)
94+ , IndexAliasAction(..)
95+ , IndexAliasCreate(..)
96+ , IndexAliasSummary(..)
97+ , IndexAliasesSummary(..)
98+ , AliasRouting(..)
99+ , SearchAliasRouting(..)
100+ , IndexAliasRouting(..)
101+ , RoutingValue(..)
102+ , DocVersion
103+ , ExternalDocVersion(..)
104+ , VersionControl(..)
105+ , DocumentParent(..)
106+ , IndexDocumentSettings(..)
107+ , Query(..)
108+ , Search(..)
109+ , SearchType(..)
110+ , SearchResult(..)
111+ , ScrollId(..)
112+ , SearchHits(..)
113+ , TrackSortScores
114+ , From(..)
115+ , Size(..)
116+ , Source(..)
117+ , PatternOrPatterns(..)
118+ , Include(..)
119+ , Exclude(..)
120+ , Pattern(..)
121+ , ShardResult(..)
122+ , Hit(..)
123+ , HitFields(..)
124+ , Filter(..)
125+ , BoolMatch(..)
126+ , Term(..)
127+ , GeoPoint(..)
128+ , GeoBoundingBoxConstraint(..)
129+ , GeoBoundingBox(..)
130+ , GeoFilterType(..)
131+ , Distance(..)
132+ , DistanceUnit(..)
133+ , DistanceType(..)
134+ , DistanceRange(..)
135+ , OptimizeBbox(..)
136+ , LatLon(..)
137+ , RangeValue(..)
138+ , RangeExecution(..)
139+ , LessThan(..)
140+ , LessThanEq(..)
141+ , GreaterThan(..)
142+ , GreaterThanEq(..)
143+ , LessThanD(..)
144+ , LessThanEqD(..)
145+ , GreaterThanD(..)
146+ , GreaterThanEqD(..)
147+ , Regexp(..)
148+ , RegexpFlags(..)
149+ , RegexpFlag(..)
150+ , FieldName(..)
151+ , ScriptFields(..)
152+ , ScriptFieldName
153+ , ScriptFieldValue
154+ , Script(..)
155+ , ScriptLanguage(..)
156+ , ScriptInline(..)
157+ , ScriptId(..)
158+ , ScriptParams(..)
159+ , ScriptParamName
160+ , ScriptParamValue
161+ , IndexName(..)
162+ , IndexSelection(..)
163+ , NodeSelection(..)
164+ , NodeSelector(..)
165+ , ForceMergeIndexSettings(..)
166+ , defaultForceMergeIndexSettings
167+ , TemplateName(..)
168+ , TemplatePattern(..)
169+ , MappingName(..)
170+ , DocId(..)
171+ , CacheName(..)
172+ , CacheKey(..)
173+ , BulkOperation(..)
174+ , ReplicaCount(..)
175+ , ShardCount(..)
176+ , Sort
177+ , SortMode(..)
178+ , SortOrder(..)
179+ , SortSpec(..)
180+ , DefaultSort(..)
181+ , Missing(..)
182+ , OpenCloseIndex(..)
183+ , Method
184+ , Boost(..)
185+ , MatchQuery(..)
186+ , MultiMatchQuery(..)
187+ , BoolQuery(..)
188+ , BoostingQuery(..)
189+ , CommonTermsQuery(..)
190+ , FunctionScoreQuery(..)
191+ , BoostMode(..)
192+ , ScoreMode(..)
193+ , FunctionScoreFunctions(..)
194+ , ComponentFunctionScoreFunction(..)
195+ , FunctionScoreFunction(..)
196+ , Weight(..)
197+ , Seed(..)
198+ , FieldValueFactor(..)
199+ , Factor(..)
200+ , FactorModifier(..)
201+ , FactorMissingFieldValue(..)
202+ , DisMaxQuery(..)
203+ , FuzzyLikeThisQuery(..)
204+ , FuzzyLikeFieldQuery(..)
205+ , FuzzyQuery(..)
206+ , HasChildQuery(..)
207+ , HasParentQuery(..)
208+ , IndicesQuery(..)
209+ , MoreLikeThisQuery(..)
210+ , MoreLikeThisFieldQuery(..)
211+ , NestedQuery(..)
212+ , PrefixQuery(..)
213+ , QueryStringQuery(..)
214+ , SimpleQueryStringQuery(..)
215+ , RangeQuery(..)
216+ , RegexpQuery(..)
217+ , QueryString(..)
218+ , TemplateQueryInline(..)
219+ , TemplateQueryKeyValuePairs(..)
220+ , WildcardQuery(..)
221+ , BooleanOperator(..)
222+ , ZeroTermsQuery(..)
223+ , CutoffFrequency(..)
224+ , Analyzer(..)
225+ , Tokenizer(..)
226+ , TokenFilter(..)
227+ , CharFilter(..)
228+ , MaxExpansions(..)
229+ , Lenient(..)
230+ , MatchQueryType(..)
231+ , MultiMatchQueryType(..)
232+ , Tiebreaker(..)
233+ , MinimumMatch(..)
234+ , DisableCoord(..)
235+ , CommonMinimumMatch(..)
236+ , MinimumMatchHighLow(..)
237+ , PrefixLength(..)
238+ , Fuzziness(..)
239+ , IgnoreTermFrequency(..)
240+ , MaxQueryTerms(..)
241+ , ScoreType(..)
242+ , Score
243+ , Cache
244+ , TypeName(..)
245+ , BoostTerms(..)
246+ , MaxWordLength(..)
247+ , MinWordLength(..)
248+ , MaxDocFrequency(..)
249+ , MinDocFrequency(..)
250+ , PhraseSlop(..)
251+ , StopWord(..)
252+ , QueryPath(..)
253+ , MinimumTermFrequency(..)
254+ , PercentMatch(..)
255+ , FieldDefinition(..)
256+ , MappingField(..)
257+ , Mapping(..)
258+ , AllowLeadingWildcard(..)
259+ , LowercaseExpanded(..)
260+ , GeneratePhraseQueries(..)
261+ , Locale(..)
262+ , AnalyzeWildcard(..)
263+ , EnablePositionIncrements(..)
264+ , SimpleQueryFlag(..)
265+ , FieldOrFields(..)
266+ , Monoid(..)
267+ , ToJSON(..)
268+ , Interval(..)
269+ , TimeInterval(..)
270+ , ExecutionHint(..)
271+ , CollectionMode(..)
272+ , TermOrder(..)
273+ , TermInclusion(..)
274+ , SnapshotRepoSelection(..)
275+ , GenericSnapshotRepo(..)
276+ , SnapshotRepo(..)
277+ , SnapshotRepoConversionError(..)
278+ , SnapshotRepoType(..)
279+ , GenericSnapshotRepoSettings(..)
280+ , SnapshotRepoUpdateSettings(..)
281+ , defaultSnapshotRepoUpdateSettings
282+ , SnapshotRepoName(..)
283+ , SnapshotRepoPattern(..)
284+ , SnapshotVerification(..)
285+ , SnapshotNodeVerification(..)
286+ , FullNodeId(..)
287+ , NodeName(..)
288+ , ClusterName(..)
289+ , NodesInfo(..)
290+ , NodesStats(..)
291+ , NodeStats(..)
292+ , NodeBreakersStats(..)
293+ , NodeBreakerStats(..)
294+ , NodeHTTPStats(..)
295+ , NodeTransportStats(..)
296+ , NodeFSStats(..)
297+ , NodeDataPathStats(..)
298+ , NodeFSTotalStats(..)
299+ , NodeNetworkStats(..)
300+ , NodeThreadPoolsStats(..)
301+ , NodeThreadPoolStats(..)
302+ , NodeJVMStats(..)
303+ , JVMBufferPoolStats(..)
304+ , JVMGCStats(..)
305+ , JVMPoolStats(..)
306+ , NodeProcessStats(..)
307+ , NodeOSStats(..)
308+ , LoadAvgs(..)
309+ , NodeIndicesStats(..)
310+ , EsAddress(..)
311+ , PluginName(..)
312+ , NodeInfo(..)
313+ , NodePluginInfo(..)
314+ , NodeHTTPInfo(..)
315+ , NodeTransportInfo(..)
316+ , BoundTransportAddress(..)
317+ , NodeNetworkInfo(..)
318+ , MacAddress(..)
319+ , NetworkInterfaceName(..)
320+ , NodeNetworkInterface(..)
321+ , NodeThreadPoolsInfo(..)
322+ , NodeThreadPoolInfo(..)
323+ , ThreadPoolSize(..)
324+ , ThreadPoolType(..)
325+ , NodeJVMInfo(..)
326+ , JVMMemoryPool(..)
327+ , JVMGCCollector(..)
328+ , JVMMemoryInfo(..)
329+ , PID(..)
330+ , NodeOSInfo(..)
331+ , CPUInfo(..)
332+ , NodeProcessInfo(..)
333+ , FsSnapshotRepo(..)
334+ , SnapshotCreateSettings(..)
335+ , defaultSnapshotCreateSettings
336+ , SnapshotSelection(..)
337+ , SnapshotPattern(..)
338+ , SnapshotInfo(..)
339+ , SnapshotShardFailure(..)
340+ , ShardId(..)
341+ , SnapshotName(..)
342+ , SnapshotState(..)
343+ , SnapshotRestoreSettings(..)
344+ , defaultSnapshotRestoreSettings
345+ , RestoreRenamePattern(..)
346+ , RestoreRenameToken(..)
347+ , RRGroupRefNum
348+ , rrGroupRefNum
349+ , mkRRGroupRefNum
350+ , RestoreIndexSettings(..)
351+ , Suggest(..)
352+ , SuggestType(..)
353+ , PhraseSuggester(..)
354+ , PhraseSuggesterHighlighter(..)
355+ , PhraseSuggesterCollate(..)
356+ , mkPhraseSuggester
357+ , SuggestOptions(..)
358+ , SuggestResponse(..)
359+ , NamedSuggestionResponse(..)
360+ , DirectGenerators(..)
361+ , mkDirectGenerators
362+ , DirectGeneratorSuggestModeTypes (..)
363+
364+ , Aggregation(..)
365+ , Aggregations
366+ , AggregationResults
367+ , BucketValue(..)
368+ , Bucket(..)
369+ , BucketAggregation(..)
370+ , TermsAggregation(..)
371+ , MissingAggregation(..)
372+ , ValueCountAggregation(..)
373+ , FilterAggregation(..)
374+ , CardinalityAggregation(..)
375+ , MaxAggregation(..)
376+ , DateHistogramAggregation(..)
377+ , DateRangeAggregation(..)
378+ , DateRangeAggRange(..)
379+ , DateMathExpr(..)
380+ , DateMathAnchor(..)
381+ , DateMathModifier(..)
382+ , DateMathUnit(..)
383+ , TopHitsAggregation(..)
384+ , StatisticsAggregation(..)
385+ , SearchAfterKey
386+
387+ , Highlights(..)
388+ , FieldHighlight(..)
389+ , HighlightSettings(..)
390+ , PlainHighlight(..)
391+ , PostingsHighlight(..)
392+ , FastVectorHighlight(..)
393+ , CommonHighlight(..)
394+ , NonPostings(..)
395+ , HighlightEncoder(..)
396+ , HighlightTag(..)
397+ , HitHighlight
398+
399+ , MissingResult(..)
400+ , TermsResult(..)
401+ , DateHistogramResult(..)
402+ , DateRangeResult(..)
403+ , TopHitResult(..)
404+
405+ , EsUsername(..)
406+ , EsPassword(..)
407+
408+ , Analysis(..)
409+ , AnalyzerDefinition(..)
410+ , TokenizerDefinition(..)
411+ , TokenFilterDefinition(..)
412+ , CharFilterDefinition(..)
413+ , Ngram(..)
414+ , TokenChar(..)
415+ , Shingle(..)
416+ , Language(..)
417+ ) where
418+
419+import Bloodhound.Import
420+
421+import Database.Bloodhound.Internal.Aggregation
422+import Database.Bloodhound.Internal.Analysis
423+import Database.Bloodhound.Internal.Client
424+import Database.Bloodhound.Internal.Highlight
425+import Database.Bloodhound.Internal.Newtypes
426+import Database.Bloodhound.Internal.Query
427+import Database.Bloodhound.Internal.Sort
428+import Database.Bloodhound.Internal.Suggest
429+
430+{-| 'unpackId' is a silly convenience function that gets used once.
431+-}
432+unpackId :: DocId -> Text
433+unpackId (DocId docId) = docId
434+
435+type TrackSortScores = Bool
436+
437+data Search = Search { queryBody :: Maybe Query
438+ , filterBody :: Maybe Filter
439+ , sortBody :: Maybe Sort
440+ , aggBody :: Maybe Aggregations
441+ , highlight :: Maybe Highlights
442+ -- default False
443+ , trackSortScores :: TrackSortScores
444+ , from :: From
445+ , size :: Size
446+ , searchType :: SearchType
447+ , searchAfterKey :: Maybe SearchAfterKey
448+ , fields :: Maybe [FieldName]
449+ , scriptFields :: Maybe ScriptFields
450+ , source :: Maybe Source
451+ , suggestBody :: Maybe Suggest -- ^ Only one Suggestion request / response per Search is supported.
452+ } deriving (Eq, Show)
453+
454+
455+instance ToJSON Search where
456+ toJSON (Search mquery sFilter sort searchAggs
457+ highlight sTrackSortScores sFrom sSize _ sAfter sFields
458+ sScriptFields sSource sSuggest) =
459+ omitNulls [ "query" .= query'
460+ , "sort" .= sort
461+ , "aggregations" .= searchAggs
462+ , "highlight" .= highlight
463+ , "from" .= sFrom
464+ , "size" .= sSize
465+ , "track_scores" .= sTrackSortScores
466+ , "search_after" .= sAfter
467+ , "fields" .= sFields
468+ , "script_fields" .= sScriptFields
469+ , "_source" .= sSource
470+ , "suggest" .= sSuggest]
471+
472+ where query' = case sFilter of
473+ Nothing -> mquery
474+ Just x ->
475+ Just
476+ . QueryBoolQuery
477+ $ mkBoolQuery (maybeToList mquery)
478+ [x] [] []
479+
480+data SearchType = SearchTypeQueryThenFetch
481+ | SearchTypeDfsQueryThenFetch
482+ deriving (Eq, Show)
483+
484+data Source =
485+ NoSource
486+ | SourcePatterns PatternOrPatterns
487+ | SourceIncludeExclude Include Exclude
488+ deriving (Eq, Show)
489+
490+instance ToJSON Source where
491+ toJSON NoSource = toJSON False
492+ toJSON (SourcePatterns patterns) = toJSON patterns
493+ toJSON (SourceIncludeExclude incl excl) = object [ "includes" .= incl, "excludes" .= excl ]
494+
495+data PatternOrPatterns = PopPattern Pattern
496+ | PopPatterns [Pattern] deriving (Eq, Read, Show)
497+
498+instance ToJSON PatternOrPatterns where
499+ toJSON (PopPattern pattern) = toJSON pattern
500+ toJSON (PopPatterns patterns) = toJSON patterns
501+
502+data Include = Include [Pattern] deriving (Eq, Read, Show)
503+data Exclude = Exclude [Pattern] deriving (Eq, Read, Show)
504+
505+instance ToJSON Include where
506+ toJSON (Include patterns) = toJSON patterns
507+
508+instance ToJSON Exclude where
509+ toJSON (Exclude patterns) = toJSON patterns
510+
511+newtype Pattern = Pattern Text deriving (Eq, Read, Show)
512+
513+instance ToJSON Pattern where
514+ toJSON (Pattern pattern) = toJSON pattern
515+
516+data SearchResult a =
517+ SearchResult { took :: Int
518+ , timedOut :: Bool
519+ , shards :: ShardResult
520+ , searchHits :: SearchHits a
521+ , aggregations :: Maybe AggregationResults
522+ , scrollId :: Maybe ScrollId
523+ -- ^ Only one Suggestion request / response per
524+ -- Search is supported.
525+ , suggest :: Maybe NamedSuggestionResponse
526+ }
527+ deriving (Eq, Show)
528+
529+instance (FromJSON a) => FromJSON (SearchResult a) where
530+ parseJSON (Object v) = SearchResult <$>
531+ v .: "took" <*>
532+ v .: "timed_out" <*>
533+ v .: "_shards" <*>
534+ v .: "hits" <*>
535+ v .:? "aggregations" <*>
536+ v .:? "_scroll_id" <*>
537+ v .:? "suggest"
538+ parseJSON _ = empty
539+
540+newtype ScrollId =
541+ ScrollId Text
542+ deriving (Eq, Show, Ord, ToJSON, FromJSON)
src/Database/V1/Bloodhound.hsdeleted−10
@@ -1,10 +0,0 @@
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.hsdeleted−923
@@ -1,923 +0,0 @@
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 url = joinPath []
227−
228−-- | 'getSnapshotRepos' gets the definitions of a subset of the
229−-- defined snapshot repos.
230−getSnapshotRepos
231− :: ( MonadBH m
232− , MonadThrow m
233− )
234− => SnapshotRepoSelection
235− -> m (Either EsError [GenericSnapshotRepo])
236−getSnapshotRepos sel = fmap (fmap unGSRs) . parseEsResponse =<< get =<< url
237− where
238− url = joinPath ["_snapshot", selectorSeg]
239− selectorSeg = case sel of
240− AllSnapshotRepos -> "_all"
241− SnapshotRepoList (p :| ps) -> T.intercalate "," (renderPat <$> (p:ps))
242− renderPat (RepoPattern t) = t
243− renderPat (ExactRepo (SnapshotRepoName t)) = t
244−
245−
246−-- | Wrapper to extract the list of 'GenericSnapshotRepo' in the
247−-- format they're returned in
248−newtype GSRs = GSRs { unGSRs :: [GenericSnapshotRepo] }
249−
250−
251−instance FromJSON GSRs where
252− parseJSON = withObject "Collection of GenericSnapshotRepo" parse
253− where
254− parse = fmap GSRs . mapM (uncurry go) . HM.toList
255− go rawName = withObject "GenericSnapshotRepo" $ \o -> do
256− GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type"
257− <*> o .: "settings"
258−
259−
260−-- | Create or update a snapshot repo
261−updateSnapshotRepo
262− :: ( MonadBH m
263− , SnapshotRepo repo
264− )
265− => SnapshotRepoUpdateSettings
266− -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure
267− -> repo
268− -> m Reply
269−updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo =
270− bindM2 put url (return (Just body))
271− where
272− url = addQuery params <$> joinPath ["_snapshot", snapshotRepoName gSnapshotRepoName]
273− params
274− | repoUpdateVerify = []
275− | otherwise = [("verify", Just "false")]
276− body = encode $ object [ "type" .= gSnapshotRepoType
277− , "settings" .= gSnapshotRepoSettings
278− ]
279− GenericSnapshotRepo {..} = toGSnapshotRepo repo
280−
281−
282−
283−-- | Verify if a snapshot repo is working. __NOTE:__ this API did not
284−-- make it into ElasticSearch until 1.4. If you use an older version,
285−-- you will get an error here.
286−verifySnapshotRepo
287− :: ( MonadBH m
288− , MonadThrow m
289− )
290− => SnapshotRepoName
291− -> m (Either EsError SnapshotVerification)
292−verifySnapshotRepo (SnapshotRepoName n) =
293− parseEsResponse =<< bindM2 post url (return Nothing)
294− where
295− url = joinPath ["_snapshot", n, "_verify"]
296−
297−
298−deleteSnapshotRepo :: MonadBH m => SnapshotRepoName -> m Reply
299−deleteSnapshotRepo (SnapshotRepoName n) = delete =<< url
300− where
301− url = joinPath ["_snapshot", n]
302−
303−
304−-- | Create and start a snapshot
305−createSnapshot
306− :: (MonadBH m)
307− => SnapshotRepoName
308− -> SnapshotName
309− -> SnapshotCreateSettings
310− -> m Reply
311−createSnapshot (SnapshotRepoName repoName)
312− (SnapshotName snapName)
313− SnapshotCreateSettings {..} =
314− bindM2 put url (return (Just body))
315− where
316− url = addQuery params <$> joinPath ["_snapshot", repoName, snapName]
317− params = [("wait_for_completion", Just (boolQP snapWaitForCompletion))]
318− body = encode $ object prs
319− prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapIndices
320− , Just ("ignore_unavailable" .= snapIgnoreUnavailable)
321− , Just ("ignore_global_state" .= snapIncludeGlobalState)
322− , Just ("partial" .= snapPartial)
323− ]
324−
325−
326−indexSelectionName :: IndexSelection -> Text
327−indexSelectionName AllIndexes = "_all"
328−indexSelectionName (IndexList (i :| is)) = T.intercalate "," (renderIndex <$> (i:is))
329− where
330− renderIndex (IndexName n) = n
331−
332−
333−-- | Get info about known snapshots given a pattern and repo name.
334−getSnapshots
335− :: ( MonadBH m
336− , MonadThrow m
337− )
338− => SnapshotRepoName
339− -> SnapshotSelection
340− -> m (Either EsError [SnapshotInfo])
341−getSnapshots (SnapshotRepoName repoName) sel =
342− fmap (fmap unSIs) . parseEsResponse =<< get =<< url
343− where
344− url = joinPath ["_snapshot", repoName, snapPath]
345− snapPath = case sel of
346− AllSnapshots -> "_all"
347− SnapshotList (s :| ss) -> T.intercalate "," (renderPath <$> (s:ss))
348− renderPath (SnapPattern t) = t
349− renderPath (ExactSnap (SnapshotName t)) = t
350−
351−
352−newtype SIs = SIs { unSIs :: [SnapshotInfo] }
353−
354−
355−instance FromJSON SIs where
356− parseJSON = withObject "Collection of SnapshotInfo" parse
357− where
358− parse o = SIs <$> o .: "snapshots"
359−
360−
361−-- | Delete a snapshot. Cancels if it is running.
362−deleteSnapshot :: MonadBH m => SnapshotRepoName -> SnapshotName -> m Reply
363−deleteSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) =
364− delete =<< url
365− where
366− url = joinPath ["_snapshot", repoName, snapName]
367−
368−
369−-- | Restore a snapshot to the cluster See
370−-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/modules-snapshots.html#_restore>
371−-- for more details.
372−restoreSnapshot
373− :: MonadBH m
374− => SnapshotRepoName
375− -> SnapshotName
376− -> SnapshotRestoreSettings
377− -- ^ Start with 'defaultSnapshotRestoreSettings' and customize
378− -- from there for reasonable defaults.
379− -> m Reply
380−restoreSnapshot (SnapshotRepoName repoName)
381− (SnapshotName snapName)
382− SnapshotRestoreSettings {..} = bindM2 post url (return (Just body))
383− where
384− url = addQuery params <$> joinPath ["_snapshot", repoName, snapName, "_restore"]
385− params = [("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion))]
386− body = encode (object prs)
387−
388−
389− prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapRestoreIndices
390− , Just ("ignore_unavailable" .= snapRestoreIgnoreUnavailable)
391− , Just ("include_global_state" .= snapRestoreIncludeGlobalState)
392− , ("rename_pattern" .=) <$> snapRestoreRenamePattern
393− , ("rename_replacement" .=) . renderTokens <$> snapRestoreRenameReplacement
394− , Just ("include_aliases" .= snapRestoreIncludeAliases)
395− , ("index_settings" .= ) <$> snapRestoreIndexSettingsOverrides
396− , ("ignore_index_settings" .= ) <$> snapRestoreIgnoreIndexSettings
397− ]
398− renderTokens (t :| ts) = mconcat (renderToken <$> (t:ts))
399− renderToken (RRTLit t) = t
400− renderToken RRSubWholeMatch = "$0"
401− renderToken (RRSubGroup g) = T.pack (show (rrGroupRefNum g))
402−
403−
404−getNodesInfo
405− :: ( MonadBH m
406− , MonadThrow m
407− )
408− => NodeSelection
409− -> m (Either EsError NodesInfo)
410−getNodesInfo sel = parseEsResponse =<< get =<< url
411− where
412− url = joinPath ["_nodes", selectionSeg]
413− selectionSeg = case sel of
414− LocalNode -> "_local"
415− NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l:ls))
416− AllNodes -> "_all"
417− selToSeg (NodeByName (NodeName n)) = n
418− selToSeg (NodeByFullNodeId (FullNodeId i)) = i
419− selToSeg (NodeByHost (Server s)) = s
420− selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v
421−
422−getNodesStats
423− :: ( MonadBH m
424− , MonadThrow m
425− )
426− => NodeSelection
427− -> m (Either EsError NodesStats)
428−getNodesStats sel = parseEsResponse =<< get =<< url
429− where
430− url = joinPath ["_nodes", selectionSeg, "stats"]
431− selectionSeg = case sel of
432− LocalNode -> "_local"
433− NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l:ls))
434− AllNodes -> "_all"
435− selToSeg (NodeByName (NodeName n)) = n
436− selToSeg (NodeByFullNodeId (FullNodeId i)) = i
437− selToSeg (NodeByHost (Server s)) = s
438− selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v
439−
440−-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
441−createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply
442−createIndex indexSettings (IndexName indexName) =
443− bindM2 put url (return body)
444− where url = joinPath [indexName]
445− body = Just $ encode indexSettings
446−
447−
448−-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
449−deleteIndex :: MonadBH m => IndexName -> m Reply
450−deleteIndex (IndexName indexName) =
451− delete =<< joinPath [indexName]
452−
453−-- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index
454−updateIndexSettings :: MonadBH m => NonEmpty UpdatableIndexSetting -> IndexName -> m Reply
455−updateIndexSettings updates (IndexName indexName) =
456− bindM2 put url (return body)
457− where url = joinPath [indexName, "_settings"]
458− body = Just (encode jsonBody)
459− jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])
460−
461−
462−getIndexSettings :: (MonadBH m, MonadThrow m) => IndexName
463− -> m (Either EsError IndexSettingsSummary)
464−getIndexSettings (IndexName indexName) = do
465− parseEsResponse =<< get =<< url
466− where url = joinPath [indexName, "_settings"]
467−
468−
469−-- | 'optimizeIndex' will optimize a single index, list of indexes or
470−-- all indexes. Note that this call will block until finishing but
471−-- will continue even if the request times out. Concurrent requests to
472−-- optimize an index while another is performing will block until the
473−-- previous one finishes. For more information see
474−-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-optimize.html>. Nothing
475−-- worthwhile comes back in the reply body, so matching on the status
476−-- should suffice.
477−--
478−-- 'optimizeIndex' with a maxNumSegments of 1 and onlyExpungeDeletes
479−-- to True is the main way to release disk space back to the OS being
480−-- held by deleted documents.
481−--
482−-- Note that this API was deprecated in ElasticSearch 2.1 for the
483−-- almost completely identical forcemerge API. Adding support to that
484−-- API would be trivial but due to the significant breaking changes,
485−-- this library cannot currently be used with >= 2.0, so that feature was omitted.
486−optimizeIndex :: MonadBH m => IndexSelection -> IndexOptimizationSettings -> m Reply
487−optimizeIndex ixs IndexOptimizationSettings {..} =
488− bindM2 post url (return body)
489− where url = addQuery params <$> joinPath [indexName, "_optimize"]
490− params = catMaybes [ ("max_num_segments",) . Just . showText <$> maxNumSegments
491− , Just ("only_expunge_deletes", Just (boolQP onlyExpungeDeletes))
492− , Just ("flush", Just (boolQP flushAfterOptimize))
493− ]
494− indexName = indexSelectionName ixs
495− body = Nothing
496−
497−
498−deepMerge :: [Object] -> Object
499−deepMerge = LS.foldl' go mempty
500− where go acc = LS.foldl' go' acc . HM.toList
501− go' acc (k, v) = HM.insertWith merge k v acc
502− merge (Object a) (Object b) = Object (deepMerge [a, b])
503− merge _ b = b
504−
505−
506−statusCodeIs :: (Int, Int) -> Reply -> Bool
507−statusCodeIs r resp = inRange r $ NHTS.statusCode (responseStatus resp)
508−
509−respIsTwoHunna :: Reply -> Bool
510−respIsTwoHunna = statusCodeIs (200, 299)
511−
512−existentialQuery :: MonadBH m => Text -> m (Reply, Bool)
513−existentialQuery url = do
514− reply <- head url
515− return (reply, respIsTwoHunna reply)
516−
517−
518−-- | Tries to parse a response body as the expected type @a@ and
519−-- failing that tries to parse it as an EsError. All well-formed, JSON
520−-- responses from elasticsearch should fall into these two
521−-- categories. If they don't, a 'EsProtocolException' will be
522−-- thrown. If you encounter this, please report the full body it
523−-- reports along with your ElasticSearch verison.
524−parseEsResponse :: (MonadThrow m, FromJSON a) => Reply
525− -> m (Either EsError a)
526−parseEsResponse reply
527− | respIsTwoHunna reply = case eitherDecode body of
528− Right a -> return (Right a)
529− Left _ -> tryParseError
530− | otherwise = tryParseError
531− where body = responseBody reply
532− tryParseError = case eitherDecode body of
533− Right e -> return (Left e)
534− -- this case should not be possible
535− Left _ -> explode
536− explode = throwM (EsProtocolException body)
537−
538−-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
539−-- in IO
540−indexExists :: MonadBH m => IndexName -> m Bool
541−indexExists (IndexName indexName) = do
542− (_, exists) <- existentialQuery =<< joinPath [indexName]
543− return exists
544−
545−-- | 'refreshIndex' will force a refresh on an index. You must
546−-- do this if you want to read what you wrote.
547−refreshIndex :: MonadBH m => IndexName -> m Reply
548−refreshIndex (IndexName indexName) =
549− bindM2 post url (return Nothing)
550− where url = joinPath [indexName, "_refresh"]
551−
552−-- | Block until the index becomes available for indexing
553−-- documents. This is useful for integration tests in which
554−-- indices are rapidly created and deleted.
555−waitForYellowIndex :: MonadBH m => IndexName -> m Reply
556−waitForYellowIndex (IndexName indexName) = get =<< url
557− where url = addQuery q <$> joinPath ["_cluster","health",indexName]
558− q = [("wait_for_status",Just "yellow"),("timeout",Just "10s")]
559−
560−stringifyOCIndex :: OpenCloseIndex -> Text
561−stringifyOCIndex oci = case oci of
562− OpenIndex -> "_open"
563− CloseIndex -> "_close"
564−
565−openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply
566−openOrCloseIndexes oci (IndexName indexName) =
567− bindM2 post url (return Nothing)
568− where ociString = stringifyOCIndex oci
569− url = joinPath [indexName, ociString]
570−
571−-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
572−-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
573−openIndex :: MonadBH m => IndexName -> m Reply
574−openIndex = openOrCloseIndexes OpenIndex
575−
576−-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
577−-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
578−closeIndex :: MonadBH m => IndexName -> m Reply
579−closeIndex = openOrCloseIndexes CloseIndex
580−
581−-- | 'listIndices' returns a list of all index names on a given 'Server'
582−listIndices :: (MonadThrow m, MonadBH m) => m [IndexName]
583−listIndices =
584− parse . responseBody =<< get =<< url
585− where
586− url = joinPath ["_cat/indices?format=json"]
587− parse body = maybe (throwM (EsProtocolException body)) return $ do
588− vals <- decode body
589− forM vals $ \val -> do
590− case val of
591− Object obj -> do
592− indexVal <- HM.lookup "index" obj
593− case indexVal of
594− String txt -> Just (IndexName txt)
595− _ -> Nothing
596− _ -> Nothing
597−
598−-- | 'updateIndexAliases' updates the server's index alias
599−-- table. Operations are atomic. Explained in further detail at
600−-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-aliases.html>
601−updateIndexAliases :: MonadBH m => NonEmpty IndexAliasAction -> m Reply
602−updateIndexAliases actions = bindM2 post url (return body)
603− where url = joinPath ["_aliases"]
604− body = Just (encode bodyJSON)
605− bodyJSON = object [ "actions" .= toList actions]
606−
607−-- | Get all aliases configured on the server.
608−getIndexAliases :: (MonadBH m, MonadThrow m)
609− => m (Either EsError IndexAliasesSummary)
610−getIndexAliases = parseEsResponse =<< get =<< url
611− where url = joinPath ["_aliases"]
612−
613−-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.
614−-- Explained in further detail at
615−-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>
616−putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply
617−putTemplate indexTemplate (TemplateName templateName) =
618− bindM2 put url (return body)
619− where url = joinPath ["_template", templateName]
620− body = Just $ encode indexTemplate
621−
622−-- | 'templateExists' checks to see if a template exists.
623−templateExists :: MonadBH m => TemplateName -> m Bool
624−templateExists (TemplateName templateName) = do
625− (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
626− return exists
627−
628−-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
629−deleteTemplate :: MonadBH m => TemplateName -> m Reply
630−deleteTemplate (TemplateName templateName) =
631− delete =<< joinPath ["_template", templateName]
632−
633−-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
634−-- for documents in indexes.
635−putMapping :: (MonadBH m, ToJSON a) => IndexName
636− -> MappingName -> a -> m Reply
637−putMapping (IndexName indexName) (MappingName mappingName) mapping =
638− bindM2 put url (return body)
639− where url = joinPath [indexName, "_mapping", mappingName]
640− -- "_mapping" and mappingName above were originally transposed
641− -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
642− body = Just $ encode mapping
643−
644−-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
645−-- Mappings are schemas for documents in indexes.
646−deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
647−deleteMapping (IndexName indexName)
648− (MappingName mappingName) =
649− -- "_mapping" and mappingName below were originally transposed
650− -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
651− delete =<< joinPath [indexName, "_mapping", mappingName]
652−
653−versionCtlParams :: IndexDocumentSettings -> [(Text, Maybe Text)]
654−versionCtlParams cfg =
655− case idsVersionControl cfg of
656− NoVersionControl -> []
657− InternalVersion v -> versionParams v "internal"
658− ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"
659− ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"
660− ForceVersion (ExternalDocVersion v) -> versionParams v "force"
661− where
662− vt = showText . docVersionNumber
663− versionParams v t = [ ("version", Just $ vt v)
664− , ("version_type", Just t)
665− ]
666−
667−-- | 'indexDocument' is the primary way to save a single document in
668−-- Elasticsearch. The document itself is simply something we can
669−-- convert into a JSON 'Value'. The 'DocId' will function as the
670−-- primary key for the document.
671−indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
672− -> IndexDocumentSettings -> doc -> DocId -> m Reply
673−indexDocument (IndexName indexName)
674− (MappingName mappingName) cfg document (DocId docId) =
675− bindM2 put url (return body)
676− where url = addQuery params <$> joinPath [indexName, mappingName, docId]
677− parentParams = case idsParent cfg of
678− Nothing -> []
679− Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]
680− params = versionCtlParams cfg ++ parentParams
681− body = Just (encode document)
682−
683−-- | 'updateDocument' provides a way to perform an partial update of a
684−-- an already indexed document.
685−updateDocument :: (ToJSON patch, MonadBH m) => IndexName -> MappingName
686− -> IndexDocumentSettings -> patch -> DocId -> m Reply
687−updateDocument (IndexName indexName)
688− (MappingName mappingName) cfg patch (DocId docId) =
689− bindM2 post url (return body)
690− where url = addQuery (versionCtlParams cfg) <$>
691− joinPath [indexName, mappingName, docId, "_update"]
692− body = Just (encode $ object ["doc" .= toJSON patch])
693−
694−-- | 'deleteDocument' is the primary way to delete a single document.
695−deleteDocument :: MonadBH m => IndexName -> MappingName
696− -> DocId -> m Reply
697−deleteDocument (IndexName indexName)
698− (MappingName mappingName) (DocId docId) =
699− delete =<< joinPath [indexName, mappingName, docId]
700−
701−-- | 'bulk' uses
702−-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>
703−-- to perform bulk operations. The 'BulkOperation' data type encodes the
704−-- index\/update\/delete\/create operations. You pass a 'V.Vector' of 'BulkOperation's
705−-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch
706−-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
707−bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
708−bulk bulkOps = bindM2 post url (return body)
709− where url = joinPath ["_bulk"]
710− body = Just $ encodeBulkOperations bulkOps
711−
712−-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
713−-- into an 'L.ByteString'
714−encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
715−encodeBulkOperations stream = collapsed where
716− blobs = fmap encodeBulkOperation stream
717− mashedTaters = mash (mempty :: Builder) blobs
718− collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
719−
720−mash :: Builder -> V.Vector L.ByteString -> Builder
721−mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))
722−
723−mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
724−mkBulkStreamValue operation indexName mappingName docId =
725− object [operation .=
726− object [ "_index" .= indexName
727− , "_type" .= mappingName
728− , "_id" .= docId]]
729−
730−-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
731−-- into an 'L.ByteString'
732−encodeBulkOperation :: BulkOperation -> L.ByteString
733−encodeBulkOperation (BulkIndex (IndexName indexName)
734− (MappingName mappingName)
735− (DocId docId) value) = blob
736− where metadata = mkBulkStreamValue "index" indexName mappingName docId
737− blob = encode metadata `mappend` "\n" `mappend` encode value
738−
739−encodeBulkOperation (BulkCreate (IndexName indexName)
740− (MappingName mappingName)
741− (DocId docId) value) = blob
742− where metadata = mkBulkStreamValue "create" indexName mappingName docId
743− blob = encode metadata `mappend` "\n" `mappend` encode value
744−
745−encodeBulkOperation (BulkDelete (IndexName indexName)
746− (MappingName mappingName)
747− (DocId docId)) = blob
748− where metadata = mkBulkStreamValue "delete" indexName mappingName docId
749− blob = encode metadata
750−
751−encodeBulkOperation (BulkUpdate (IndexName indexName)
752− (MappingName mappingName)
753− (DocId docId) value) = blob
754− where metadata = mkBulkStreamValue "update" indexName mappingName docId
755− doc = object ["doc" .= value]
756− blob = encode metadata `mappend` "\n" `mappend` encode doc
757−
758−-- | 'getDocument' is a straight-forward way to fetch a single document from
759−-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
760−-- The 'DocId' is the primary key for your Elasticsearch document.
761−getDocument :: MonadBH m => IndexName -> MappingName
762− -> DocId -> m Reply
763−getDocument (IndexName indexName)
764− (MappingName mappingName) (DocId docId) =
765− get =<< joinPath [indexName, mappingName, docId]
766−
767−-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
768−-- in IO
769−documentExists :: MonadBH m => IndexName -> MappingName
770− -> Maybe DocumentParent -> DocId -> m Bool
771−documentExists (IndexName indexName) (MappingName mappingName)
772− parent (DocId docId) = do
773− (_, exists) <- existentialQuery =<< url
774− return exists
775− where url = addQuery params <$> joinPath [indexName, mappingName, docId]
776− parentParam = fmap (\(DocumentParent (DocId p)) -> p) parent
777− params = LS.filter (\(_, v) -> isJust v) [("parent", parentParam)]
778−
779−dispatchSearch :: MonadBH m => Text -> Search -> m Reply
780−dispatchSearch url search = post url' (Just (encode search))
781− where url' = appendSearchTypeParam url (searchType search)
782−
783−-- | 'searchAll', given a 'Search', will perform that search against all indexes
784−-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
785−searchAll :: MonadBH m => Search -> m Reply
786−searchAll = bindM2 dispatchSearch url . return
787− where url = joinPath ["_search"]
788−
789−-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
790−-- against all mappings within an index on an Elasticsearch server.
791−searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
792−searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
793− where url = joinPath [indexName, "_search"]
794−
795−-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
796−-- search against a specific mapping within an index on an Elasticsearch server.
797−searchByType :: MonadBH m => IndexName -> MappingName -> Search
798− -> m Reply
799−searchByType (IndexName indexName)
800− (MappingName mappingName) = bindM2 dispatchSearch url . return
801− where url = joinPath [indexName, mappingName, "_search"]
802−
803−-- | For a given search, request a scroll for efficient streaming of
804−-- search results. Note that the search is put into 'SearchTypeScan'
805−-- mode and thus results will not be sorted. Combine this with
806−-- 'advanceScroll' to efficiently stream through the full result set
807−getInitialScroll :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId)
808−getInitialScroll (IndexName indexName) (MappingName mappingName) search = do
809− let url = joinPath [indexName, mappingName, "_search"]
810− search' = search { searchType = SearchTypeScan }
811− resp' <- bindM2 dispatchSearch url (return search')
812− let msr = decode' $ responseBody resp' :: Maybe (SearchResult ())
813− msid = maybe Nothing scrollId msr
814− return msid
815−
816−scroll' :: (FromJSON a, MonadBH m, MonadThrow m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId)
817−scroll' Nothing = return ([], Nothing)
818−scroll' (Just sid) = do
819− res <- advanceScroll sid 60
820− case res of
821− Right SearchResult {..} -> return (hits searchHits, scrollId)
822− Left _ -> return ([], Nothing)
823−
824−-- | Use the given scroll to fetch the next page of documents. If there are no
825−-- further pages, 'SearchResult.searchHits.hits' will be '[]'.
826−advanceScroll
827− :: ( FromJSON a
828− , MonadBH m
829− , MonadThrow m
830− )
831− => ScrollId
832− -> NominalDiffTime
833− -- ^ 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.
834− -> m (Either EsError (SearchResult a))
835−advanceScroll (ScrollId sid) scroll = do
836− url <- joinPath ["_search/scroll?scroll=" <> scrollTime]
837− parseEsResponse =<< post url (Just . L.fromStrict $ T.encodeUtf8 sid)
838− where scrollTime = showText secs <> "s"
839− secs :: Integer
840− secs = round scroll
841−
842−simpleAccumulator :: (FromJSON a, MonadBH m, MonadThrow m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId)
843−simpleAccumulator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)
844−simpleAccumulator oldHits ([], _) = return (oldHits, Nothing)
845−simpleAccumulator oldHits (newHits, msid) = do
846− (newHits', msid') <- scroll' msid
847− simpleAccumulator (oldHits ++ newHits) (newHits', msid')
848−
849−-- | 'scanSearch' uses the 'scan&scroll' API of elastic,
850−-- for a given 'IndexName' and 'MappingName'. Note that this will
851−-- consume the entire search result set and will be doing O(n) list
852−-- appends so this may not be suitable for large result sets. In that
853−-- case, 'getInitialScroll' and 'advanceScroll' are good low level
854−-- tools. You should be able to hook them up trivially to conduit,
855−-- pipes, or your favorite streaming IO abstraction of choice. Note
856−-- that ordering on the search would destroy performance and thus is
857−-- ignored.
858−scanSearch :: (FromJSON a, MonadBH m, MonadThrow m) => IndexName -> MappingName -> Search -> m [Hit a]
859−scanSearch indexName mappingName search = do
860− msid <- getInitialScroll indexName mappingName search
861− (hits, msid') <- scroll' msid
862− (totalHits, _) <- simpleAccumulator [] (hits, msid')
863− return totalHits
864−
865−-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
866−-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
867−-- syntax if you want to add things like aggregations or highlights while still using
868−-- this helper function.
869−mkSearch :: Maybe Query -> Maybe Filter -> Search
870−mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
871−
872−-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
873−-- the 'Query' and the 'Aggregation'.
874−mkAggregateSearch :: Maybe Query -> Aggregations -> Search
875−mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing Nothing
876−
877−-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
878−-- the 'Query' and the 'Aggregation'.
879−mkHighlightSearch :: Maybe Query -> Highlights -> Search
880−mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing Nothing
881−
882−-- | 'pageSearch' is a helper function that takes a search and assigns the from
883−-- and size fields for the search. The from parameter defines the offset
884−-- from the first result you want to fetch. The size parameter allows you to
885−-- configure the maximum amount of hits to be returned.
886−pageSearch :: From -- ^ The result offset
887− -> Size -- ^ The number of results to return
888− -> Search -- ^ The current seach
889− -> Search -- ^ The paged search
890−pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
891−
892−parseUrl' :: MonadThrow m => Text -> m Request
893−parseUrl' t = parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack t))
894−
895−-- | Was there an optimistic concurrency control conflict when
896−-- indexing a document?
897−isVersionConflict :: Reply -> Bool
898−isVersionConflict = statusCheck (== 409)
899−
900−isSuccess :: Reply -> Bool
901−isSuccess = statusCheck (inRange (200, 299))
902−
903−isCreated :: Reply -> Bool
904−isCreated = statusCheck (== 201)
905−
906−statusCheck :: (Int -> Bool) -> Reply -> Bool
907−statusCheck prd = prd . NHTS.statusCode . responseStatus
908−
909−-- | This is a hook that can be set via the 'bhRequestHook' function
910−-- that will authenticate all requests using an HTTP Basic
911−-- Authentication header. Note that it is *strongly* recommended that
912−-- this option only be used over an SSL connection.
913−--
914−-- >> (mkBHEnv myServer myManager) { bhRequestHook = basicAuthHook (EsUsername "myuser") (EsPassword "mypass") }
915−basicAuthHook :: Monad m => EsUsername -> EsPassword -> Request -> m Request
916−basicAuthHook (EsUsername u) (EsPassword p) = return . applyBasicAuth u' p'
917− where u' = T.encodeUtf8 u
918− p' = T.encodeUtf8 p
919−
920−
921−boolQP :: Bool -> Text
922−boolQP True = "true"
923−boolQP False = "false"
src/Database/V1/Bloodhound/Types.hsdeleted−5580
@@ -1,5580 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−-- {-# LANGUAGE NoMonomorphismRestriction #-}
8−{-# LANGUAGE NamedFieldPuns #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE RecordWildCards #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−
13−-------------------------------------------------------------------------------
14−-- |
15−-- Module : Database.Bloodhound.Types
16−-- Copyright : (C) 2014, 2015, 2016 Chris Allen
17−-- License : BSD-style (see the file LICENSE)
18−-- Maintainer : Chris Allen <cma@bitemyapp.com
19−-- Stability : provisional
20−-- Portability : DeriveGeneric, RecordWildCards
21−--
22−-- Data types for describing actions and data structures performed to interact
23−-- with Elasticsearch. The two main buckets your queries against Elasticsearch
24−-- will fall into are 'Query's and 'Filter's. 'Filter's are more like
25−-- traditional database constraints and often have preferable performance
26−-- properties. 'Query's support human-written textual queries, such as fuzzy
27−-- queries.
28−-------------------------------------------------------------------------------
29−
30−
31−
32−module Database.V1.Bloodhound.Types
33− ( defaultCache
34− , defaultIndexSettings
35− , defaultIndexDocumentSettings
36− , mkSort
37− , showText
38− , unpackId
39− , mkMatchQuery
40− , mkMultiMatchQuery
41− , mkBoolQuery
42− , mkRangeQuery
43− , mkQueryStringQuery
44− , mkAggregations
45− , mkTermsAggregation
46− , mkTermsScriptAggregation
47− , mkDateHistogram
48− , mkCardinalityAggregation
49− , mkDocVersion
50− , docVersionNumber
51− , toMissing
52− , toTerms
53− , toDateHistogram
54− , toTopHits
55− , omitNulls
56− , BH(..)
57− , runBH
58− , BHEnv
59− , bhServer
60− , bhManager
61− , bhRequestHook
62− , mkBHEnv
63− , MonadBH(..)
64− , Version(..)
65− , VersionNumber(..)
66− , MaybeNA(..)
67− , BuildHash(..)
68− , Status(..)
69− , Existence(..)
70− , NullValue(..)
71− , IndexSettings(..)
72− , UpdatableIndexSetting(..)
73− , IndexSettingsSummary(..)
74− , AllocationPolicy(..)
75− , ReplicaBounds(..)
76− , Bytes(..)
77− , gigabytes
78− , megabytes
79− , kilobytes
80− , FSType(..)
81− , InitialShardCount(..)
82− , NodeAttrFilter(..)
83− , NodeAttrName(..)
84− , CompoundFormat(..)
85− , IndexTemplate(..)
86− , Server(..)
87− , Reply
88− , EsResult(..)
89− , EsResultFound(..)
90− , EsError(..)
91− , EsProtocolException(..)
92− , IndexAlias(..)
93− , IndexAliasName(..)
94− , IndexAliasAction(..)
95− , IndexAliasCreate(..)
96− , IndexAliasSummary(..)
97− , IndexAliasesSummary(..)
98− , AliasRouting(..)
99− , SearchAliasRouting(..)
100− , IndexAliasRouting(..)
101− , RoutingValue(..)
102− , DocVersion
103− , ExternalDocVersion(..)
104− , VersionControl(..)
105− , DocumentParent(..)
106− , IndexDocumentSettings(..)
107− , Query(..)
108− , Search(..)
109− , SearchType(..)
110− , SearchResult(..)
111− , ScrollId(..)
112− , SearchHits(..)
113− , TrackSortScores
114− , From(..)
115− , Size(..)
116− , Source(..)
117− , PatternOrPatterns(..)
118− , Include(..)
119− , Exclude(..)
120− , Pattern(..)
121− , ShardResult(..)
122− , Hit(..)
123− , Filter(..)
124− , Seminearring(..)
125− , BoolMatch(..)
126− , Term(..)
127− , GeoPoint(..)
128− , GeoBoundingBoxConstraint(..)
129− , GeoBoundingBox(..)
130− , GeoFilterType(..)
131− , Distance(..)
132− , DistanceUnit(..)
133− , DistanceType(..)
134− , DistanceRange(..)
135− , OptimizeBbox(..)
136− , LatLon(..)
137− , RangeValue(..)
138− , RangeExecution(..)
139− , LessThan(..)
140− , LessThanEq(..)
141− , GreaterThan(..)
142− , GreaterThanEq(..)
143− , LessThanD(..)
144− , LessThanEqD(..)
145− , GreaterThanD(..)
146− , GreaterThanEqD(..)
147− , Regexp(..)
148− , RegexpFlags(..)
149− , RegexpFlag(..)
150− , FieldName(..)
151− , Script(..)
152− , IndexName(..)
153− , IndexSelection(..)
154− , NodeSelection(..)
155− , NodeSelector(..)
156− , IndexOptimizationSettings(..)
157− , defaultIndexOptimizationSettings
158− , TemplateName(..)
159− , TemplatePattern(..)
160− , MappingName(..)
161− , DocId(..)
162− , CacheName(..)
163− , CacheKey(..)
164− , BulkOperation(..)
165− , ReplicaCount(..)
166− , ShardCount(..)
167− , Sort
168− , SortMode(..)
169− , SortOrder(..)
170− , SortSpec(..)
171− , DefaultSort(..)
172− , Missing(..)
173− , OpenCloseIndex(..)
174− , Method
175− , Boost(..)
176− , MatchQuery(..)
177− , MultiMatchQuery(..)
178− , BoolQuery(..)
179− , BoostingQuery(..)
180− , CommonTermsQuery(..)
181− , DisMaxQuery(..)
182− , FilteredQuery(..)
183− , FuzzyLikeThisQuery(..)
184− , FuzzyLikeFieldQuery(..)
185− , FuzzyQuery(..)
186− , HasChildQuery(..)
187− , HasParentQuery(..)
188− , IndicesQuery(..)
189− , MoreLikeThisQuery(..)
190− , MoreLikeThisFieldQuery(..)
191− , NestedQuery(..)
192− , PrefixQuery(..)
193− , QueryStringQuery(..)
194− , SimpleQueryStringQuery(..)
195− , RangeQuery(..)
196− , RegexpQuery(..)
197− , QueryString(..)
198− , TemplateQueryInline(..)
199− , TemplateQueryKeyValuePairs(..)
200− , BooleanOperator(..)
201− , ZeroTermsQuery(..)
202− , CutoffFrequency(..)
203− , Analyzer(..)
204− , MaxExpansions(..)
205− , Lenient(..)
206− , MatchQueryType(..)
207− , MultiMatchQueryType(..)
208− , Tiebreaker(..)
209− , MinimumMatch(..)
210− , DisableCoord(..)
211− , CommonMinimumMatch(..)
212− , MinimumMatchHighLow(..)
213− , PrefixLength(..)
214− , Fuzziness(..)
215− , IgnoreTermFrequency(..)
216− , MaxQueryTerms(..)
217− , ScoreType(..)
218− , Score
219− , Cache
220− , TypeName(..)
221− , BoostTerms(..)
222− , MaxWordLength(..)
223− , MinWordLength(..)
224− , MaxDocFrequency(..)
225− , MinDocFrequency(..)
226− , PhraseSlop(..)
227− , StopWord(..)
228− , QueryPath(..)
229− , MinimumTermFrequency(..)
230− , PercentMatch(..)
231− , FieldDefinition(..)
232− , MappingField(..)
233− , Mapping(..)
234− , AllowLeadingWildcard(..)
235− , LowercaseExpanded(..)
236− , GeneratePhraseQueries(..)
237− , Locale(..)
238− , AnalyzeWildcard(..)
239− , EnablePositionIncrements(..)
240− , SimpleQueryFlag(..)
241− , FieldOrFields(..)
242− , Monoid(..)
243− , ToJSON(..)
244− , Interval(..)
245− , TimeInterval(..)
246− , ExecutionHint(..)
247− , CollectionMode(..)
248− , TermOrder(..)
249− , TermInclusion(..)
250− , SnapshotRepoSelection(..)
251− , GenericSnapshotRepo(..)
252− , SnapshotRepo(..)
253− , SnapshotRepoConversionError(..)
254− , SnapshotRepoType(..)
255− , GenericSnapshotRepoSettings(..)
256− , SnapshotRepoUpdateSettings(..)
257− , defaultSnapshotRepoUpdateSettings
258− , SnapshotRepoName(..)
259− , SnapshotRepoPattern(..)
260− , SnapshotVerification(..)
261− , SnapshotNodeVerification(..)
262− , FullNodeId(..)
263− , NodeName(..)
264− , ClusterName(..)
265− , NodesInfo(..)
266− , NodesStats(..)
267− , NodeStats(..)
268− , NodeBreakersStats(..)
269− , NodeBreakerStats(..)
270− , NodeHTTPStats(..)
271− , NodeTransportStats(..)
272− , NodeFSStats(..)
273− , NodeDataPathStats(..)
274− , NodeFSTotalStats(..)
275− , NodeNetworkStats(..)
276− , NodeThreadPoolsStats(..)
277− , NodeThreadPoolStats(..)
278− , NodeJVMStats(..)
279− , JVMBufferPoolStats(..)
280− , JVMGCStats(..)
281− , JVMPoolStats(..)
282− , NodeProcessStats(..)
283− , NodeOSStats(..)
284− , LoadAvgs(..)
285− , NodeIndicesStats(..)
286− , EsAddress(..)
287− , PluginName(..)
288− , NodeInfo(..)
289− , NodePluginInfo(..)
290− , NodeHTTPInfo(..)
291− , NodeTransportInfo(..)
292− , BoundTransportAddress(..)
293− , NodeNetworkInfo(..)
294− , MacAddress(..)
295− , NetworkInterfaceName(..)
296− , NodeNetworkInterface(..)
297− , NodeThreadPoolsInfo(..)
298− , NodeThreadPoolInfo(..)
299− , ThreadPoolSize(..)
300− , ThreadPoolType(..)
301− , NodeJVMInfo(..)
302− , JVMMemoryPool(..)
303− , JVMGCCollector(..)
304− , JVMMemoryInfo(..)
305− , PID(..)
306− , NodeOSInfo(..)
307− , CPUInfo(..)
308− , NodeProcessInfo(..)
309− , FsSnapshotRepo(..)
310− , SnapshotCreateSettings(..)
311− , defaultSnapshotCreateSettings
312− , SnapshotSelection(..)
313− , SnapshotPattern(..)
314− , SnapshotInfo(..)
315− , SnapshotShardFailure(..)
316− , ShardId(..)
317− , SnapshotName(..)
318− , SnapshotState(..)
319− , SnapshotRestoreSettings(..)
320− , defaultSnapshotRestoreSettings
321− , RestoreRenamePattern(..)
322− , RestoreRenameToken(..)
323− , RRGroupRefNum
324− , rrGroupRefNum
325− , mkRRGroupRefNum
326− , RestoreIndexSettings(..)
327− , Suggest(..)
328− , SuggestType(..)
329− , PhraseSuggester(..)
330− , PhraseSuggesterHighlighter(..)
331− , PhraseSuggesterCollate(..)
332− , mkPhraseSuggester
333− , SuggestOptions(..)
334− , SuggestResponse(..)
335− , NamedSuggestionResponse(..)
336− , DirectGenerators(..)
337− , mkDirectGenerators
338− , DirectGeneratorSuggestModeTypes (..)
339−
340− , Aggregation(..)
341− , Aggregations
342− , AggregationResults
343− , BucketValue(..)
344− , Bucket(..)
345− , BucketAggregation(..)
346− , TermsAggregation(..)
347− , MissingAggregation(..)
348− , ValueCountAggregation(..)
349− , FilterAggregation(..)
350− , CardinalityAggregation(..)
351− , DateHistogramAggregation(..)
352− , DateRangeAggregation(..)
353− , DateRangeAggRange(..)
354− , DateMathExpr(..)
355− , DateMathAnchor(..)
356− , DateMathModifier(..)
357− , DateMathUnit(..)
358− , TopHitsAggregation(..)
359−
360− , Highlights(..)
361− , FieldHighlight(..)
362− , HighlightSettings(..)
363− , PlainHighlight(..)
364− , PostingsHighlight(..)
365− , FastVectorHighlight(..)
366− , CommonHighlight(..)
367− , NonPostings(..)
368− , HighlightEncoder(..)
369− , HighlightTag(..)
370− , HitHighlight
371−
372− , MissingResult(..)
373− , TermsResult(..)
374− , DateHistogramResult(..)
375− , DateRangeResult(..)
376− , TopHitResult(..)
377−
378− , EsUsername(..)
379− , EsPassword(..)
380− ) where
381−
382−import Control.Applicative as A
383−import Control.Arrow (first)
384−import Control.Monad.Catch
385−import Control.Monad.Except
386−import Control.Monad.Reader (MonadReader (..),
387− ReaderT (..))
388−import Control.Monad.State (MonadState)
389−import Control.Monad.Writer (MonadWriter)
390−import Data.Aeson
391−import Data.Aeson.Types (Pair, Parser,
392− emptyObject,
393− parseEither, parseMaybe,
394− typeMismatch)
395−import qualified Data.ByteString.Lazy.Char8 as L
396−import Data.Char
397−import Data.Hashable (Hashable)
398−import qualified Data.HashMap.Strict as HM
399−import Data.List (foldl', intercalate,
400− nub)
401−import Data.List.NonEmpty (NonEmpty (..), toList)
402−import qualified Data.Map.Strict as M
403−import Data.Maybe
404−import Data.Scientific (Scientific)
405−import Data.Semigroup
406−import Data.Text (Text)
407−import qualified Data.Text as T
408−import Data.Time.Calendar
409−import Data.Time.Clock (NominalDiffTime,
410− UTCTime)
411−import Data.Time.Clock.POSIX
412−import qualified Data.Traversable as DT
413−import Data.Typeable (Typeable)
414−import qualified Data.Vector as V
415−import qualified Data.Version as Vers
416−import GHC.Enum
417−import GHC.Generics (Generic)
418−import Network.HTTP.Client
419−import qualified Network.HTTP.Types.Method as NHTM
420−import qualified Text.ParserCombinators.ReadP as RP
421−import qualified Text.Read as TR
422−
423−import Database.V1.Bloodhound.Types.Class
424−import Database.V1.Bloodhound.Types.Internal
425−
426−-- $setup
427−-- >>> :set -XOverloadedStrings
428−-- >>> import Data.Aeson
429−-- >>> import Database.V1.Bloodhound
430−-- >>> let testServer = (Server "http://localhost:9200")
431−-- >>> let testIndex = IndexName "twitter"
432−-- >>> let testMapping = MappingName "tweet"
433−-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
434−
435−-- defaultIndexSettings is exported by Database.Bloodhound as well
436−-- no trailing slashes in servers, library handles building the path.
437−
438−-- | Create a 'BHEnv' with all optional fields defaulted. HTTP hook
439−-- will be a noop. You can use the exported fields to customize it further, e.g.:
440−--
441−-- >> (mkBHEnv myServer myManager) { bhRequestHook = customHook }
442−mkBHEnv :: Server -> Manager -> BHEnv
443−mkBHEnv s m = BHEnv s m return
444−
445−newtype BH m a = BH {
446− unBH :: ReaderT BHEnv m a
447− } deriving ( Functor
448− , A.Applicative
449− , Monad
450− , MonadIO
451− , MonadState s
452− , MonadWriter w
453− , MonadError e
454− , Alternative
455− , MonadPlus
456− , MonadFix
457− , MonadThrow
458− , MonadCatch
459− , MonadMask)
460−
461−instance MonadTrans BH where
462− lift = BH . lift
463−
464−instance (MonadReader r m) => MonadReader r (BH m) where
465− ask = lift ask
466− local f (BH (ReaderT m)) = BH $ ReaderT $ \r ->
467− local f (m r)
468−
469−instance (Functor m, Applicative m, MonadIO m) => MonadBH (BH m) where
470− getBHEnv = BH getBHEnv
471−
472−runBH :: BHEnv -> BH m a -> m a
473−runBH e f = runReaderT (unBH f) e
474−
475−{-| 'Version' is embedded in 'Status' -}
476−data Version = Version { number :: VersionNumber
477− , build_hash :: BuildHash
478− , build_timestamp :: UTCTime
479− , build_snapshot :: Bool
480− , lucene_version :: VersionNumber } deriving (Eq, Read, Show, Generic, Typeable)
481−
482−-- | Traditional software versioning number
483−newtype VersionNumber = VersionNumber { versionNumber :: Vers.Version
484− } deriving (Eq, Read, Show, Generic, Typeable, Ord)
485−
486−{-| 'Status' is a data type for describing the JSON body returned by
487− Elasticsearch when you query its status. This was deprecated in 1.2.0.
488−
489− <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-status.html#indices-status>
490−-}
491−
492−data Status = Status { ok :: Maybe Bool
493− , status :: Int
494− , name :: Text
495− , version :: Version
496− , tagline :: Text } deriving (Eq, Read, Show, Generic)
497−
498−{-| 'IndexSettings' is used to configure the shards and replicas when you create
499− an Elasticsearch Index.
500−
501− <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-create-index.html>
502−-}
503−
504−data IndexSettings =
505− IndexSettings { indexShards :: ShardCount
506− , indexReplicas :: ReplicaCount } deriving (Eq, Read, Show, Generic, Typeable)
507−
508−{-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and 2 replicas. -}
509−defaultIndexSettings :: IndexSettings
510−defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
511−
512−
513−{-| 'IndexOptimizationSettings' is used to configure index optimization. See
514− <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-optimize.html>
515− for more info.
516−-}
517−data IndexOptimizationSettings =
518− IndexOptimizationSettings { maxNumSegments :: Maybe Int
519− -- ^ 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.
520− , onlyExpungeDeletes :: Bool
521− -- ^ 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.
522− , flushAfterOptimize :: Bool
523− -- ^ Should a flush be performed after the optimize.
524− } deriving (Eq, Show, Generic, Typeable)
525−
526−
527−{-| 'defaultIndexOptimizationSettings' implements the default settings that
528− ElasticSearch uses for index optimization. 'maxNumSegments' is Nothing,
529− 'onlyExpungeDeletes' is False, and flushAfterOptimize is True.
530−-}
531−defaultIndexOptimizationSettings :: IndexOptimizationSettings
532−defaultIndexOptimizationSettings = IndexOptimizationSettings Nothing False True
533−
534−{-| 'UpdatableIndexSetting' are settings which may be updated after an index is created.
535−
536− <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-update-settings.html>
537−-}
538−data UpdatableIndexSetting = NumberOfReplicas ReplicaCount
539− -- ^ The number of replicas each shard has.
540− | AutoExpandReplicas ReplicaBounds
541− | BlocksReadOnly Bool
542− -- ^ Set to True to have the index read only. False to allow writes and metadata changes.
543− | BlocksRead Bool
544− -- ^ Set to True to disable read operations against the index.
545− | BlocksWrite Bool
546− -- ^ Set to True to disable write operations against the index.
547− | BlocksMetaData Bool
548− -- ^ Set to True to disable metadata operations against the index.
549− | RefreshInterval NominalDiffTime
550− -- ^ The async refresh interval of a shard
551− | IndexConcurrency Int
552− | FailOnMergeFailure Bool
553− | TranslogFlushThresholdOps Int
554− -- ^ When to flush on operations.
555− | TranslogFlushThresholdSize Bytes
556− -- ^ When to flush based on translog (bytes) size.
557− | TranslogFlushThresholdPeriod NominalDiffTime
558− -- ^ When to flush based on a period of not flushing.
559− | TranslogDisableFlush Bool
560− -- ^ Disables flushing. Note, should be set for a short interval and then enabled.
561− | CacheFilterMaxSize (Maybe Bytes)
562− -- ^ The maximum size of filter cache (per segment in shard).
563− | CacheFilterExpire (Maybe NominalDiffTime)
564− -- ^ The expire after access time for filter cache.
565− | GatewaySnapshotInterval NominalDiffTime
566− -- ^ The gateway snapshot interval (only applies to shared gateways).
567− | RoutingAllocationInclude (NonEmpty NodeAttrFilter)
568− -- ^ A node matching any rule will be allowed to host shards from the index.
569− | RoutingAllocationExclude (NonEmpty NodeAttrFilter)
570− -- ^ A node matching any rule will NOT be allowed to host shards from the index.
571− | RoutingAllocationRequire (NonEmpty NodeAttrFilter)
572− -- ^ Only nodes matching all rules will be allowed to host shards from the index.
573− | RoutingAllocationEnable AllocationPolicy
574− -- ^ Enables shard allocation for a specific index.
575− | RoutingAllocationShardsPerNode ShardCount
576− -- ^ Controls the total number of shards (replicas and primaries) allowed to be allocated on a single node.
577− | RecoveryInitialShards InitialShardCount
578− -- ^ When using local gateway a particular shard is recovered only if there can be allocated quorum shards in the cluster.
579− | GCDeletes NominalDiffTime
580− | TTLDisablePurge Bool
581− -- ^ Disables temporarily the purge of expired docs.
582− | TranslogFSType FSType
583− | IndexCompoundFormat CompoundFormat
584− | IndexCompoundOnFlush Bool
585− | WarmerEnabled Bool
586− deriving (Eq, Show, Generic, Typeable)
587−
588−data AllocationPolicy = AllocAll
589− -- ^ Allows shard allocation for all shards.
590− | AllocPrimaries
591− -- ^ Allows shard allocation only for primary shards.
592− | AllocNewPrimaries
593− -- ^ Allows shard allocation only for primary shards for new indices.
594− | AllocNone
595− -- ^ No shard allocation is allowed
596− deriving (Eq, Read, Show, Generic, Typeable)
597−
598−data ReplicaBounds = ReplicasBounded Int Int
599− | ReplicasLowerBounded Int
600− | ReplicasUnbounded
601− deriving (Eq, Read, Show, Generic, Typeable)
602−
603−-- | A measure of bytes used for various configurations. You may want
604−-- to use smart constructors like 'gigabytes' for larger values.
605−--
606−-- >>> gigabytes 9
607−-- Bytes 9000000000
608−--
609−-- >>> megabytes 9
610−-- Bytes 9000000
611−--
612−-- >>> kilobytes 9
613−-- Bytes 9000
614−newtype Bytes = Bytes Int deriving (Eq, Read, Show, Generic, Typeable, Ord, ToJSON, FromJSON)
615−
616−gigabytes :: Int -> Bytes
617−gigabytes n = megabytes (1000 * n)
618−
619−
620−megabytes :: Int -> Bytes
621−megabytes n = kilobytes (1000 * n)
622−
623−
624−kilobytes :: Int -> Bytes
625−kilobytes n = Bytes (1000 * n)
626−
627−
628−data FSType = FSSimple
629− | FSBuffered deriving (Eq, Read, Show, Generic, Typeable, Ord)
630−
631−data InitialShardCount = QuorumShards
632− | QuorumMinus1Shards
633− | FullShards
634− | FullMinus1Shards
635− | ExplicitShards Int
636− deriving (Eq, Read, Show, Generic, Typeable)
637−
638−data NodeAttrFilter = NodeAttrFilter { nodeAttrFilterName :: NodeAttrName
639− , nodeAttrFilterValues :: NonEmpty Text}
640− deriving (Eq, Read, Show, Generic, Ord, Typeable)
641−
642−newtype NodeAttrName = NodeAttrName Text deriving (Eq, Read, Show, Ord, Generic, Typeable)
643−
644−data CompoundFormat = CompoundFileFormat Bool
645− | MergeSegmentVsTotalIndex Double
646− -- ^ percentage between 0 and 1 where 0 is false, 1 is true
647− deriving (Eq, Read, Show, Generic, Typeable)
648−
649−newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }
650−
651−data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName
652− , sSummaryFixedSettings :: IndexSettings
653− , sSummaryUpdateable :: [UpdatableIndexSetting]}
654− deriving (Eq, Show, Generic, Typeable)
655−
656−{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -}
657−type Reply = Network.HTTP.Client.Response L.ByteString
658−type Method = NHTM.Method
659−
660−{-| 'OpenCloseIndex' is a sum type for opening and closing indices.
661−
662− <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
663−-}
664−data OpenCloseIndex = OpenIndex | CloseIndex deriving (Eq, Read, Show, Generic, Typeable)
665−
666−data FieldType = GeoPointType
667− | GeoShapeType
668− | FloatType
669− | IntegerType
670− | LongType
671− | ShortType
672− | ByteType deriving (Eq, Read, Show, Generic, Typeable)
673−
674−data FieldDefinition =
675− FieldDefinition { fieldType :: FieldType } deriving (Eq, Read, Show, Generic, Typeable)
676−
677−{-| An 'IndexTemplate' defines a template that will automatically be
678− applied to new indices created. The templates include both
679− 'IndexSettings' and mappings, and a simple 'TemplatePattern' that
680− controls if the template will be applied to the index created.
681− Specify mappings as follows: @[toJSON TweetMapping, ...]@
682−
683− https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html
684−-}
685−data IndexTemplate =
686− IndexTemplate { templatePattern :: TemplatePattern
687− , templateSettings :: Maybe IndexSettings
688− , templateMappings :: [Value]
689− }
690−
691−data MappingField =
692− MappingField { mappingFieldName :: FieldName
693− , fieldDefinition :: FieldDefinition } deriving (Eq, Read, Show, Generic, Typeable)
694−
695−{-| Support for type reification of 'Mapping's is currently incomplete, for
696− now the mapping API verbiage expects a 'ToJSON'able blob.
697−
698− Indexes have mappings, mappings are schemas for the documents contained in the
699− index. I'd recommend having only one mapping per index, always having a mapping,
700− and keeping different kinds of documents separated if possible.
701−-}
702−data Mapping = Mapping { typeName :: TypeName
703− , mappingFields :: [MappingField] } deriving (Eq, Read, Show, Generic, Typeable)
704−
705−{-| 'BulkOperation' is a sum type for expressing the four kinds of bulk
706− operation index, create, delete, and update. 'BulkIndex' behaves like an
707− "upsert", 'BulkCreate' will fail if a document already exists at the DocId.
708−
709− <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html#docs-bulk>
710−-}
711−data BulkOperation =
712− BulkIndex IndexName MappingName DocId Value
713− | BulkCreate IndexName MappingName DocId Value
714− | BulkDelete IndexName MappingName DocId
715− | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Read, Show, Generic, Typeable)
716−
717−{-| 'EsResult' describes the standard wrapper JSON document that you see in
718− successful Elasticsearch lookups or lookups that couldn't find the document.
719−-}
720−data EsResult a = EsResult { _index :: Text
721− , _type :: Text
722− , _id :: Text
723− , foundResult :: Maybe (EsResultFound a)} deriving (Eq, Read, Show, Generic, Typeable)
724−
725−{-| 'EsResultFound' contains the document and its metadata inside of an
726− 'EsResult' when the document was successfully found.
727−-}
728−data EsResultFound a = EsResultFound { _version :: DocVersion
729− , _source :: a } deriving (Eq, Read, Show, Generic, Typeable)
730−
731−{-| 'EsError' is the generic type that will be returned when there was a
732− problem. If you can't parse the expected response, its a good idea to
733− try parsing this.
734−-}
735−data EsError = EsError { errorStatus :: Int
736− , errorMessage :: Text } deriving (Eq, Read, Show, Generic, Typeable)
737−
738−{-| 'EsProtocolException' will be thrown if Bloodhound cannot parse a response
739−returned by the ElasticSearch server. If you encounter this error, please
740−verify that your domain data types and FromJSON instances are working properly
741−(for example, the 'a' of '[Hit a]' in 'SearchResult.searchHits.hits'). If you're
742−sure that your mappings are correct, then this error may be an indication of an
743−incompatibility between Bloodhound and ElasticSearch. Please open a bug report
744−and be sure to include the exception body.
745−-}
746−data EsProtocolException = EsProtocolException { esProtoExBody :: L.ByteString }
747− deriving (Eq, Read, Show, Generic, Typeable)
748−
749−instance Exception EsProtocolException
750−
751−data IndexAlias = IndexAlias { srcIndex :: IndexName
752− , indexAlias :: IndexAliasName } deriving (Eq, Read, Show, Generic, Typeable)
753−
754−newtype IndexAliasName = IndexAliasName { indexAliasName :: IndexName } deriving (Eq, Read, Show, Generic, ToJSON)
755−
756−data IndexAliasAction = AddAlias IndexAlias IndexAliasCreate
757− | RemoveAlias IndexAlias deriving (Read, Show, Eq, Generic, Typeable)
758−
759−data IndexAliasCreate = IndexAliasCreate { aliasCreateRouting :: Maybe AliasRouting
760− , aliasCreateFilter :: Maybe Filter}
761− deriving (Read, Show, Eq, Generic, Typeable)
762−
763−data AliasRouting = AllAliasRouting RoutingValue
764− | GranularAliasRouting (Maybe SearchAliasRouting) (Maybe IndexAliasRouting)
765− deriving (Read, Show, Eq, Generic, Typeable)
766−
767−newtype SearchAliasRouting = SearchAliasRouting (NonEmpty RoutingValue) deriving (Read, Show, Eq, Generic, Typeable)
768−
769−newtype IndexAliasRouting = IndexAliasRouting RoutingValue deriving (Read, Show, Eq, Generic, ToJSON, FromJSON, Typeable)
770−
771−newtype RoutingValue = RoutingValue { routingValue :: Text } deriving (Read, Show, Eq, Generic, ToJSON, FromJSON, Typeable)
772−
773−newtype IndexAliasesSummary = IndexAliasesSummary { indexAliasesSummary :: [IndexAliasSummary] } deriving (Read, Show, Eq, Generic, Typeable)
774−
775−{-| 'IndexAliasSummary' is a summary of an index alias configured for a server. -}
776−data IndexAliasSummary = IndexAliasSummary { indexAliasSummaryAlias :: IndexAlias
777− , indexAliasSummaryCreate :: IndexAliasCreate} deriving (Read, Show, Eq, Generic, Typeable)
778−
779−{-| 'DocVersion' is an integer version number for a document between 1
780−and 9.2e+18 used for <<https://www.elastic.co/guide/en/elasticsearch/guide/current/optimistic-concurrency-control.html optimistic concurrency control>>.
781−-}
782−newtype DocVersion = DocVersion {
783− docVersionNumber :: Int
784− } deriving (Eq, Read, Show, Generic, Ord, ToJSON)
785−
786−-- | Smart constructor for in-range doc version
787−mkDocVersion :: Int -> Maybe DocVersion
788−mkDocVersion i
789− | i >= (docVersionNumber minBound) && i <= (docVersionNumber maxBound) =
790− Just $ DocVersion i
791− | otherwise = Nothing
792−
793−
794−{-| 'ExternalDocVersion' is a convenience wrapper if your code uses its
795−own version numbers instead of ones from ES.
796−-}
797−newtype ExternalDocVersion = ExternalDocVersion DocVersion
798− deriving (Eq, Read, Show, Generic, Ord, Bounded, Enum, ToJSON)
799−
800−{-| 'VersionControl' is specified when indexing documents as a
801−optimistic concurrency control.
802−-}
803−data VersionControl = NoVersionControl
804− -- ^ Don't send a version. This is a pure overwrite.
805− | InternalVersion DocVersion
806− -- ^ Use the default ES versioning scheme. Only
807− -- index the document if the version is the same
808− -- as the one specified. Only applicable to
809− -- updates, as you should be getting Version from
810− -- a search result.
811− | ExternalGT ExternalDocVersion
812− -- ^ Use your own version numbering. Only index
813− -- the document if the version is strictly higher
814− -- OR the document doesn't exist. The given
815− -- version will be used as the new version number
816− -- for the stored document. N.B. All updates must
817− -- increment this number, meaning there is some
818− -- global, external ordering of updates.
819− | ExternalGTE ExternalDocVersion
820− -- ^ Use your own version numbering. Only index
821− -- the document if the version is equal or higher
822− -- than the stored version. Will succeed if there
823− -- is no existing document. The given version will
824− -- be used as the new version number for the
825− -- stored document. Use with care, as this could
826− -- result in data loss.
827− | ForceVersion ExternalDocVersion
828− -- ^ The document will always be indexed and the
829− -- given version will be the new version. This is
830− -- typically used for correcting errors. Use with
831− -- care, as this could result in data loss.
832− deriving (Read, Show, Eq, Generic, Ord)
833−
834−{-| 'DocumentParent' is used to specify a parent document.
835−-}
836−newtype DocumentParent = DocumentParent DocId
837− deriving (Eq, Read, Show, Generic, Typeable)
838−
839−{-| 'IndexDocumentSettings' are special settings supplied when indexing
840−a document. For the best backwards compatiblity when new fields are
841−added, you should probably prefer to start with 'defaultIndexDocumentSettings'
842−-}
843−data IndexDocumentSettings =
844− IndexDocumentSettings { idsVersionControl :: VersionControl
845− , idsParent :: Maybe DocumentParent
846− } deriving (Eq, Read, Show, Generic, Typeable)
847−
848−{-| Reasonable default settings. Chooses no version control and no parent.
849−-}
850−defaultIndexDocumentSettings :: IndexDocumentSettings
851−defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing
852−
853−{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order
854− dependent with later sorts acting as tie-breakers for earlier sorts.
855−-}
856−type Sort = [SortSpec]
857−
858−{-| The two main kinds of 'SortSpec' are 'DefaultSortSpec' and
859− 'GeoDistanceSortSpec'. The latter takes a 'SortOrder', 'GeoPoint', and
860− 'DistanceUnit' to express "nearness" to a single geographical point as a
861− sort specification.
862−
863−<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
864−-}
865−data SortSpec = DefaultSortSpec DefaultSort
866− | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit deriving (Eq, Read, Show, Generic, Typeable)
867−
868−{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a
869− 'mkSort' convenience function for when you want to specify only the most
870− common parameters.
871−
872−<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
873−-}
874−data DefaultSort =
875− DefaultSort { sortFieldName :: FieldName
876− , sortOrder :: SortOrder
877− -- default False
878− , ignoreUnmapped :: Bool
879− , sortMode :: Maybe SortMode
880− , missingSort :: Maybe Missing
881− , nestedFilter :: Maybe Filter } deriving (Eq, Read, Show, Generic, Typeable)
882−
883−{-| 'SortOrder' is 'Ascending' or 'Descending', as you might expect. These get
884− encoded into "asc" or "desc" when turned into JSON.
885−
886−<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
887−-}
888−data SortOrder = Ascending
889− | Descending deriving (Eq, Read, Show, Generic, Typeable)
890−
891−{-| 'Missing' prescribes how to handle missing fields. A missing field can be
892− sorted last, first, or using a custom value as a substitute.
893−
894−<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_missing_values>
895−-}
896−data Missing = LastMissing
897− | FirstMissing
898− | CustomMissing Text deriving (Eq, Read, Show, Generic, Typeable)
899−
900−{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.
901−
902−http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option
903−-}
904−data SortMode = SortMin
905− | SortMax
906− | SortSum
907− | SortAvg deriving (Eq, Read, Show, Generic, Typeable)
908−
909−{-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so
910− that you can concisely describe the usual kind of 'SortSpec's you want.
911−-}
912−mkSort :: FieldName -> SortOrder -> DefaultSort
913−mkSort fieldName sOrder = DefaultSort fieldName sOrder False Nothing Nothing Nothing
914−
915−{-| 'Cache' is for telling ES whether it should cache a 'Filter' not.
916− 'Query's cannot be cached.
917−-}
918−type Cache = Bool -- caching on/off
919−defaultCache :: Cache
920−defaultCache = False
921−
922−{-| 'PrefixValue' is used in 'PrefixQuery' as the main query component.
923−-}
924−type PrefixValue = Text
925−
926−{-| 'BooleanOperator' is the usual And/Or operators with an ES compatible
927− JSON encoding baked in. Used all over the place.
928−-}
929−data BooleanOperator = And | Or deriving (Eq, Read, Show, Generic, Typeable)
930−
931−{-| 'ShardCount' is part of 'IndexSettings'
932−-}
933−newtype ShardCount = ShardCount Int deriving (Eq, Read, Show, Generic, ToJSON, Typeable)
934−
935−{-| 'ReplicaCount' is part of 'IndexSettings'
936−-}
937−newtype ReplicaCount = ReplicaCount Int deriving (Eq, Read, Show, Generic, ToJSON, Typeable)
938−
939−{-| 'IndexName' is used to describe which index to query/create/delete
940−-}
941−newtype IndexName = IndexName Text deriving (Eq, Generic, Read, Show, ToJSON, FromJSON, Typeable)
942−
943−{-| 'IndexSelection' is used for APIs which take a single index, a list of
944− indexes, or the special @_all@ index.
945−-}
946−--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.
947−data IndexSelection = IndexList (NonEmpty IndexName)
948− | AllIndexes deriving (Eq, Generic, Show, Typeable)
949−
950−{-| '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.
951−-}
952−data NodeSelection = LocalNode
953− -- ^ Whatever node receives this request
954− | NodeList (NonEmpty NodeSelector)
955− | AllNodes deriving (Eq, Generic, Show, Typeable)
956−
957−
958−-- | An exact match or pattern to identify a node. Note that All of
959−-- these options support wildcarding, so your node name, server, attr
960−-- name can all contain * characters to be a fuzzy match.
961−data NodeSelector = NodeByName NodeName
962− | NodeByFullNodeId FullNodeId
963− | NodeByHost Server
964− -- ^ e.g. 10.0.0.1 or even 10.0.0.*
965− | NodeByAttribute NodeAttrName Text
966− -- ^ NodeAttrName can be a pattern, e.g. rack*. The value can too.
967− deriving (Eq, Generic, Show, Typeable)
968−
969−{-| 'TemplateName' is used to describe which template to query/create/delete
970−-}
971−newtype TemplateName = TemplateName Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
972−
973−{-| 'TemplatePattern' represents a pattern which is matched against index names
974−-}
975−newtype TemplatePattern = TemplatePattern Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
976−
977−{-| 'MappingName' is part of mappings which are how ES describes and schematizes
978− the data in the indices.
979−-}
980−newtype MappingName = MappingName Text deriving (Eq, Generic, Read, Show, ToJSON, FromJSON, Typeable)
981−
982−{-| 'DocId' is a generic wrapper value for expressing unique Document IDs.
983− Can be set by the user or created by ES itself. Often used in client
984− functions for poking at specific documents.
985−-}
986−newtype DocId = DocId Text deriving (Eq, Generic, Read, Show, ToJSON, FromJSON, Typeable)
987−
988−{-| 'QueryString' is used to wrap query text bodies, be they human written or not.
989−-}
990−newtype QueryString = QueryString Text deriving (Eq, Generic, Read, Show, ToJSON, FromJSON, Typeable)
991−
992−{-| 'FieldName' is used all over the place wherever a specific field within
993− a document needs to be specified, usually in 'Query's or 'Filter's.
994−-}
995−newtype FieldName = FieldName Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
996−
997−
998−{-| 'Script' is often used in place of 'FieldName' to specify more
999−complex ways of extracting a value from a document.
1000−-}
1001−newtype Script = Script { scriptText :: Text } deriving (Eq, Read, Show, Generic, Typeable)
1002−
1003−{-| 'CacheName' is used in 'RegexpFilter' for describing the
1004− 'CacheKey' keyed caching behavior.
1005−-}
1006−newtype CacheName = CacheName Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1007−
1008−{-| 'CacheKey' is used in 'RegexpFilter' to key regex caching.
1009−-}
1010−newtype CacheKey =
1011− CacheKey Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1012−newtype Existence =
1013− Existence Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1014−newtype NullValue =
1015− NullValue Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1016−newtype CutoffFrequency =
1017− CutoffFrequency Double deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1018−newtype Analyzer =
1019− Analyzer Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1020−newtype MaxExpansions =
1021− MaxExpansions Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1022−
1023−{-| 'Lenient', if set to true, will cause format based failures to be
1024− ignored. I don't know what the bloody default is, Elasticsearch
1025− documentation didn't say what it was. Let me know if you figure it out.
1026−-}
1027−newtype Lenient =
1028− Lenient Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1029−newtype Tiebreaker =
1030− Tiebreaker Double deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1031−newtype Boost =
1032− Boost Double deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1033−newtype BoostTerms =
1034− BoostTerms Double deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1035−
1036−{-| 'MinimumMatch' controls how many should clauses in the bool query should
1037− match. Can be an absolute value (2) or a percentage (30%) or a
1038− combination of both.
1039−-}
1040−newtype MinimumMatch =
1041− MinimumMatch Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1042−newtype DisableCoord =
1043− DisableCoord Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1044−newtype IgnoreTermFrequency =
1045− IgnoreTermFrequency Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1046−newtype MinimumTermFrequency =
1047− MinimumTermFrequency Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1048−newtype MaxQueryTerms =
1049− MaxQueryTerms Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1050−newtype Fuzziness =
1051− Fuzziness Double deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1052−
1053−{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -}
1054−newtype PrefixLength =
1055− PrefixLength Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1056−newtype TypeName =
1057− TypeName Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1058−newtype PercentMatch =
1059− PercentMatch Double deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1060−newtype StopWord =
1061− StopWord Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1062−newtype QueryPath =
1063− QueryPath Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1064−
1065−{-| Allowing a wildcard at the beginning of a word (eg "*ing") is particularly
1066− heavy, because all terms in the index need to be examined, just in case
1067− they match. Leading wildcards can be disabled by setting
1068− 'AllowLeadingWildcard' to false. -}
1069−newtype AllowLeadingWildcard =
1070− AllowLeadingWildcard Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1071−newtype LowercaseExpanded =
1072− LowercaseExpanded Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1073−newtype EnablePositionIncrements =
1074− EnablePositionIncrements Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1075−
1076−{-| By default, wildcard terms in a query are not analyzed.
1077− Setting 'AnalyzeWildcard' to true enables best-effort analysis.
1078−-}
1079−newtype AnalyzeWildcard = AnalyzeWildcard Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1080−
1081−{-| 'GeneratePhraseQueries' defaults to false.
1082−-}
1083−newtype GeneratePhraseQueries =
1084− GeneratePhraseQueries Bool deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1085−
1086−{-| 'Locale' is used for string conversions - defaults to ROOT.
1087−-}
1088−newtype Locale = Locale Text deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1089−newtype MaxWordLength = MaxWordLength Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1090−newtype MinWordLength = MinWordLength Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1091−
1092−{-| 'PhraseSlop' sets the default slop for phrases, 0 means exact
1093− phrase matches. Default is 0.
1094−-}
1095−newtype PhraseSlop = PhraseSlop Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1096−newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1097−newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1098−
1099−-- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ
1100−newtype POSIXMS = POSIXMS { posixMS :: UTCTime }
1101−
1102−{-| 'unpackId' is a silly convenience function that gets used once.
1103−-}
1104−unpackId :: DocId -> Text
1105−unpackId (DocId docId) = docId
1106−
1107−type TrackSortScores = Bool
1108−newtype From = From Int deriving (Eq, Read, Show, Generic, ToJSON)
1109−newtype Size = Size Int deriving (Eq, Read, Show, Generic, ToJSON, FromJSON, Typeable)
1110−
1111−data Search = Search { queryBody :: Maybe Query
1112− , filterBody :: Maybe Filter
1113− , sortBody :: Maybe Sort
1114− , aggBody :: Maybe Aggregations
1115− , highlight :: Maybe Highlights
1116− -- default False
1117− , trackSortScores :: TrackSortScores
1118− , from :: From
1119− , size :: Size
1120− , searchType :: SearchType
1121− , fields :: Maybe [FieldName]
1122− , source :: Maybe Source
1123− , suggestBody :: Maybe Suggest -- ^ Only one Suggestion request / response per Search is supported.
1124− } deriving (Eq, Read, Show, Generic, Typeable)
1125−
1126−data SearchType = SearchTypeQueryThenFetch
1127− | SearchTypeDfsQueryThenFetch
1128− | SearchTypeCount
1129− | SearchTypeScan
1130− | SearchTypeQueryAndFetch
1131− | SearchTypeDfsQueryAndFetch
1132− deriving (Eq, Read, Show, Generic, Typeable)
1133−
1134−data Source =
1135− NoSource
1136− | SourcePatterns PatternOrPatterns
1137− | SourceIncludeExclude Include Exclude
1138− deriving (Read, Show, Eq, Generic, Typeable)
1139−
1140−data PatternOrPatterns = PopPattern Pattern
1141− | PopPatterns [Pattern] deriving (Eq, Read, Show, Generic, Typeable)
1142−
1143−data Include = Include [Pattern] deriving (Eq, Read, Show, Generic, Typeable)
1144−data Exclude = Exclude [Pattern] deriving (Eq, Read, Show, Generic, Typeable)
1145−
1146−newtype Pattern = Pattern Text deriving (Eq, Read, Show, Generic, Typeable)
1147−
1148−data Highlights = Highlights { globalsettings :: Maybe HighlightSettings
1149− , highlightFields :: [FieldHighlight]
1150− } deriving (Read, Show, Eq, Generic, Typeable)
1151−
1152−data FieldHighlight = FieldHighlight FieldName (Maybe HighlightSettings)
1153− deriving (Read, Show, Eq, Generic, Typeable)
1154−
1155−
1156−data HighlightSettings = Plain PlainHighlight
1157− | Postings PostingsHighlight
1158− | FastVector FastVectorHighlight
1159− deriving (Read, Show, Eq, Generic, Typeable)
1160−data PlainHighlight =
1161− PlainHighlight { plainCommon :: Maybe CommonHighlight
1162− , plainNonPost :: Maybe NonPostings } deriving (Read, Show, Eq, Generic, Typeable)
1163−
1164− -- This requires that index_options are set to 'offset' in the mapping.
1165−data PostingsHighlight = PostingsHighlight (Maybe CommonHighlight) deriving (Read, Show, Eq, Generic, Typeable)
1166−
1167−-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
1168−data FastVectorHighlight =
1169− FastVectorHighlight { fvCommon :: Maybe CommonHighlight
1170− , fvNonPostSettings :: Maybe NonPostings
1171− , boundaryChars :: Maybe Text
1172− , boundaryMaxScan :: Maybe Int
1173− , fragmentOffset :: Maybe Int
1174− , matchedFields :: [Text]
1175− , phraseLimit :: Maybe Int
1176− } deriving (Read, Show, Eq, Generic, Typeable)
1177−
1178−data CommonHighlight =
1179− CommonHighlight { order :: Maybe Text
1180− , forceSource :: Maybe Bool
1181− , tag :: Maybe HighlightTag
1182− , encoder :: Maybe HighlightEncoder
1183− , noMatchSize :: Maybe Int
1184− , highlightQuery :: Maybe Query
1185− , requireFieldMatch :: Maybe Bool
1186− } deriving (Read, Show, Eq, Generic, Typeable)
1187−
1188−-- Settings that are only applicable to FastVector and Plain highlighters.
1189−data NonPostings =
1190− NonPostings { fragmentSize :: Maybe Int
1191− , numberOfFragments :: Maybe Int} deriving (Read, Show, Eq, Generic, Typeable)
1192−
1193−data HighlightEncoder = DefaultEncoder
1194− | HTMLEncoder
1195− deriving (Read, Show, Eq, Generic, Typeable)
1196−
1197−-- NOTE: Should the tags use some kind of HTML type, rather than Text?
1198−data HighlightTag = TagSchema Text
1199− | CustomTags ([Text], [Text]) -- Only uses more than the first value in the lists if fvh
1200− deriving (Read, Show, Eq, Generic, Typeable)
1201−
1202−
1203−data Query =
1204− TermQuery Term (Maybe Boost)
1205− | TermsQuery Text (NonEmpty Text)
1206− | QueryMatchQuery MatchQuery
1207− | QueryMultiMatchQuery MultiMatchQuery
1208− | QueryBoolQuery BoolQuery
1209− | QueryBoostingQuery BoostingQuery
1210− | QueryCommonTermsQuery CommonTermsQuery
1211− | ConstantScoreFilter Filter Boost
1212− | ConstantScoreQuery Query Boost
1213− | QueryDisMaxQuery DisMaxQuery
1214− | QueryFilteredQuery FilteredQuery
1215− | QueryFuzzyLikeThisQuery FuzzyLikeThisQuery
1216− | QueryFuzzyLikeFieldQuery FuzzyLikeFieldQuery
1217− | QueryFuzzyQuery FuzzyQuery
1218− | QueryHasChildQuery HasChildQuery
1219− | QueryHasParentQuery HasParentQuery
1220− | IdsQuery MappingName [DocId]
1221− | QueryIndicesQuery IndicesQuery
1222− | MatchAllQuery (Maybe Boost)
1223− | QueryMoreLikeThisQuery MoreLikeThisQuery
1224− | QueryMoreLikeThisFieldQuery MoreLikeThisFieldQuery
1225− | QueryNestedQuery NestedQuery
1226− | QueryPrefixQuery PrefixQuery
1227− | QueryQueryStringQuery QueryStringQuery
1228− | QuerySimpleQueryStringQuery SimpleQueryStringQuery
1229− | QueryRangeQuery RangeQuery
1230− | QueryRegexpQuery RegexpQuery
1231− | QueryTemplateQueryInline TemplateQueryInline
1232− deriving (Eq, Read, Show, Generic, Typeable)
1233−
1234−data RegexpQuery =
1235− RegexpQuery { regexpQueryField :: FieldName
1236− , regexpQuery :: Regexp
1237− , regexpQueryFlags :: RegexpFlags
1238− , regexpQueryBoost :: Maybe Boost
1239− } deriving (Eq, Read, Show, Generic, Typeable)
1240−
1241−data RangeQuery =
1242− RangeQuery { rangeQueryField :: FieldName
1243− , rangeQueryRange :: RangeValue
1244− , rangeQueryBoost :: Boost } deriving (Eq, Read, Show, Generic, Typeable)
1245−
1246−mkRangeQuery :: FieldName -> RangeValue -> RangeQuery
1247−mkRangeQuery f r = RangeQuery f r (Boost 1.0)
1248−
1249−data SimpleQueryStringQuery =
1250− SimpleQueryStringQuery
1251− { simpleQueryStringQuery :: QueryString
1252− , simpleQueryStringField :: Maybe FieldOrFields
1253− , simpleQueryStringOperator :: Maybe BooleanOperator
1254− , simpleQueryStringAnalyzer :: Maybe Analyzer
1255− , simpleQueryStringFlags :: Maybe (NonEmpty SimpleQueryFlag)
1256− , simpleQueryStringLowercaseExpanded :: Maybe LowercaseExpanded
1257− , simpleQueryStringLocale :: Maybe Locale
1258− } deriving (Eq, Read, Show, Generic, Typeable)
1259−
1260−data SimpleQueryFlag =
1261− SimpleQueryAll
1262− | SimpleQueryNone
1263− | SimpleQueryAnd
1264− | SimpleQueryOr
1265− | SimpleQueryPrefix
1266− | SimpleQueryPhrase
1267− | SimpleQueryPrecedence
1268− | SimpleQueryEscape
1269− | SimpleQueryWhitespace
1270− | SimpleQueryFuzzy
1271− | SimpleQueryNear
1272− | SimpleQuerySlop deriving (Eq, Read, Show, Generic, Typeable)
1273−
1274−-- use_dis_max and tie_breaker when fields are plural?
1275−data QueryStringQuery =
1276− QueryStringQuery
1277− { queryStringQuery :: QueryString
1278− , queryStringDefaultField :: Maybe FieldName
1279− , queryStringOperator :: Maybe BooleanOperator
1280− , queryStringAnalyzer :: Maybe Analyzer
1281− , queryStringAllowLeadingWildcard :: Maybe AllowLeadingWildcard
1282− , queryStringLowercaseExpanded :: Maybe LowercaseExpanded
1283− , queryStringEnablePositionIncrements :: Maybe EnablePositionIncrements
1284− , queryStringFuzzyMaxExpansions :: Maybe MaxExpansions
1285− , queryStringFuzziness :: Maybe Fuzziness
1286− , queryStringFuzzyPrefixLength :: Maybe PrefixLength
1287− , queryStringPhraseSlop :: Maybe PhraseSlop
1288− , queryStringBoost :: Maybe Boost
1289− , queryStringAnalyzeWildcard :: Maybe AnalyzeWildcard
1290− , queryStringGeneratePhraseQueries :: Maybe GeneratePhraseQueries
1291− , queryStringMinimumShouldMatch :: Maybe MinimumMatch
1292− , queryStringLenient :: Maybe Lenient
1293− , queryStringLocale :: Maybe Locale
1294− } deriving (Eq, Read, Show, Generic, Typeable)
1295−
1296−mkQueryStringQuery :: QueryString -> QueryStringQuery
1297−mkQueryStringQuery qs =
1298− QueryStringQuery qs Nothing Nothing
1299− Nothing Nothing Nothing Nothing
1300− Nothing Nothing Nothing Nothing
1301− Nothing Nothing Nothing Nothing
1302− Nothing Nothing
1303−
1304−data FieldOrFields = FofField FieldName
1305− | FofFields (NonEmpty FieldName) deriving (Eq, Read, Show, Generic, Typeable)
1306−
1307−data PrefixQuery =
1308− PrefixQuery
1309− { prefixQueryField :: FieldName
1310− , prefixQueryPrefixValue :: Text
1311− , prefixQueryBoost :: Maybe Boost } deriving (Eq, Read, Show, Generic, Typeable)
1312−
1313−data NestedQuery =
1314− NestedQuery
1315− { nestedQueryPath :: QueryPath
1316− , nestedQueryScoreType :: ScoreType
1317− , nestedQuery :: Query } deriving (Eq, Read, Show, Generic, Typeable)
1318−
1319−data MoreLikeThisFieldQuery =
1320− MoreLikeThisFieldQuery
1321− { moreLikeThisFieldText :: Text
1322− , moreLikeThisFieldFields :: FieldName
1323− -- default 0.3 (30%)
1324− , moreLikeThisFieldPercentMatch :: Maybe PercentMatch
1325− , moreLikeThisFieldMinimumTermFreq :: Maybe MinimumTermFrequency
1326− , moreLikeThisFieldMaxQueryTerms :: Maybe MaxQueryTerms
1327− , moreLikeThisFieldStopWords :: Maybe (NonEmpty StopWord)
1328− , moreLikeThisFieldMinDocFrequency :: Maybe MinDocFrequency
1329− , moreLikeThisFieldMaxDocFrequency :: Maybe MaxDocFrequency
1330− , moreLikeThisFieldMinWordLength :: Maybe MinWordLength
1331− , moreLikeThisFieldMaxWordLength :: Maybe MaxWordLength
1332− , moreLikeThisFieldBoostTerms :: Maybe BoostTerms
1333− , moreLikeThisFieldBoost :: Maybe Boost
1334− , moreLikeThisFieldAnalyzer :: Maybe Analyzer
1335− } deriving (Eq, Read, Show, Generic, Typeable)
1336−
1337−data MoreLikeThisQuery =
1338− MoreLikeThisQuery
1339− { moreLikeThisText :: Text
1340− , moreLikeThisFields :: Maybe (NonEmpty FieldName)
1341− -- default 0.3 (30%)
1342− , moreLikeThisPercentMatch :: Maybe PercentMatch
1343− , moreLikeThisMinimumTermFreq :: Maybe MinimumTermFrequency
1344− , moreLikeThisMaxQueryTerms :: Maybe MaxQueryTerms
1345− , moreLikeThisStopWords :: Maybe (NonEmpty StopWord)
1346− , moreLikeThisMinDocFrequency :: Maybe MinDocFrequency
1347− , moreLikeThisMaxDocFrequency :: Maybe MaxDocFrequency
1348− , moreLikeThisMinWordLength :: Maybe MinWordLength
1349− , moreLikeThisMaxWordLength :: Maybe MaxWordLength
1350− , moreLikeThisBoostTerms :: Maybe BoostTerms
1351− , moreLikeThisBoost :: Maybe Boost
1352− , moreLikeThisAnalyzer :: Maybe Analyzer
1353− } deriving (Eq, Read, Show, Generic, Typeable)
1354−
1355−data IndicesQuery =
1356− IndicesQuery
1357− { indicesQueryIndices :: [IndexName]
1358− , indicesQuery :: Query
1359− -- default "all"
1360− , indicesQueryNoMatch :: Maybe Query } deriving (Eq, Read, Show, Generic, Typeable)
1361−
1362−data HasParentQuery =
1363− HasParentQuery
1364− { hasParentQueryType :: TypeName
1365− , hasParentQuery :: Query
1366− , hasParentQueryScoreType :: Maybe ScoreType } deriving (Eq, Read, Show, Generic, Typeable)
1367−
1368−data HasChildQuery =
1369− HasChildQuery
1370− { hasChildQueryType :: TypeName
1371− , hasChildQuery :: Query
1372− , hasChildQueryScoreType :: Maybe ScoreType } deriving (Eq, Read, Show, Generic, Typeable)
1373−
1374−data ScoreType =
1375− ScoreTypeMax
1376− | ScoreTypeSum
1377− | ScoreTypeAvg
1378− | ScoreTypeNone deriving (Eq, Read, Show, Generic, Typeable)
1379−
1380−data FuzzyQuery =
1381− FuzzyQuery { fuzzyQueryField :: FieldName
1382− , fuzzyQueryValue :: Text
1383− , fuzzyQueryPrefixLength :: PrefixLength
1384− , fuzzyQueryMaxExpansions :: MaxExpansions
1385− , fuzzyQueryFuzziness :: Fuzziness
1386− , fuzzyQueryBoost :: Maybe Boost
1387− } deriving (Eq, Read, Show, Generic, Typeable)
1388−
1389−data FuzzyLikeFieldQuery =
1390− FuzzyLikeFieldQuery
1391− { fuzzyLikeField :: FieldName
1392− -- anaphora is good for the soul.
1393− , fuzzyLikeFieldText :: Text
1394− , fuzzyLikeFieldMaxQueryTerms :: MaxQueryTerms
1395− , fuzzyLikeFieldIgnoreTermFrequency :: IgnoreTermFrequency
1396− , fuzzyLikeFieldFuzziness :: Fuzziness
1397− , fuzzyLikeFieldPrefixLength :: PrefixLength
1398− , fuzzyLikeFieldBoost :: Boost
1399− , fuzzyLikeFieldAnalyzer :: Maybe Analyzer
1400− } deriving (Eq, Read, Show, Generic, Typeable)
1401−
1402−data FuzzyLikeThisQuery =
1403− FuzzyLikeThisQuery
1404− { fuzzyLikeFields :: [FieldName]
1405− , fuzzyLikeText :: Text
1406− , fuzzyLikeMaxQueryTerms :: MaxQueryTerms
1407− , fuzzyLikeIgnoreTermFrequency :: IgnoreTermFrequency
1408− , fuzzyLikeFuzziness :: Fuzziness
1409− , fuzzyLikePrefixLength :: PrefixLength
1410− , fuzzyLikeBoost :: Boost
1411− , fuzzyLikeAnalyzer :: Maybe Analyzer
1412− } deriving (Eq, Read, Show, Generic, Typeable)
1413−
1414−data FilteredQuery =
1415− FilteredQuery
1416− { filteredQuery :: Query
1417− , filteredFilter :: Filter } deriving (Eq, Read, Show, Generic, Typeable)
1418−
1419−data DisMaxQuery =
1420− DisMaxQuery { disMaxQueries :: [Query]
1421− -- default 0.0
1422− , disMaxTiebreaker :: Tiebreaker
1423− , disMaxBoost :: Maybe Boost
1424− } deriving (Eq, Read, Show, Generic, Typeable)
1425−
1426−data MatchQuery =
1427− MatchQuery { matchQueryField :: FieldName
1428− , matchQueryQueryString :: QueryString
1429− , matchQueryOperator :: BooleanOperator
1430− , matchQueryZeroTerms :: ZeroTermsQuery
1431− , matchQueryCutoffFrequency :: Maybe CutoffFrequency
1432− , matchQueryMatchType :: Maybe MatchQueryType
1433− , matchQueryAnalyzer :: Maybe Analyzer
1434− , matchQueryMaxExpansions :: Maybe MaxExpansions
1435− , matchQueryLenient :: Maybe Lenient
1436− , matchQueryBoost :: Maybe Boost } deriving (Eq, Read, Show, Generic, Typeable)
1437−
1438−{-| 'mkMatchQuery' is a convenience function that defaults the less common parameters,
1439− enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery'
1440−-}
1441−mkMatchQuery :: FieldName -> QueryString -> MatchQuery
1442−mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing
1443−
1444−data MatchQueryType =
1445− MatchPhrase
1446− | MatchPhrasePrefix deriving (Eq, Read, Show, Generic, Typeable)
1447−
1448−data MultiMatchQuery =
1449− MultiMatchQuery { multiMatchQueryFields :: [FieldName]
1450− , multiMatchQueryString :: QueryString
1451− , multiMatchQueryOperator :: BooleanOperator
1452− , multiMatchQueryZeroTerms :: ZeroTermsQuery
1453− , multiMatchQueryTiebreaker :: Maybe Tiebreaker
1454− , multiMatchQueryType :: Maybe MultiMatchQueryType
1455− , multiMatchQueryCutoffFrequency :: Maybe CutoffFrequency
1456− , multiMatchQueryAnalyzer :: Maybe Analyzer
1457− , multiMatchQueryMaxExpansions :: Maybe MaxExpansions
1458− , multiMatchQueryLenient :: Maybe Lenient } deriving (Eq, Read, Show, Generic, Typeable)
1459−
1460−{-| 'mkMultiMatchQuery' is a convenience function that defaults the less common parameters,
1461− enabling you to provide only the list of 'FieldName's and 'QueryString' to
1462− make a 'MultiMatchQuery'.
1463−-}
1464−
1465−mkMultiMatchQuery :: [FieldName] -> QueryString -> MultiMatchQuery
1466−mkMultiMatchQuery matchFields query =
1467− MultiMatchQuery matchFields query
1468− Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing
1469−
1470−data MultiMatchQueryType =
1471− MultiMatchBestFields
1472− | MultiMatchMostFields
1473− | MultiMatchCrossFields
1474− | MultiMatchPhrase
1475− | MultiMatchPhrasePrefix deriving (Eq, Read, Show, Generic, Typeable)
1476−
1477−data BoolQuery =
1478− BoolQuery { boolQueryMustMatch :: [Query]
1479− , boolQueryMustNotMatch :: [Query]
1480− , boolQueryShouldMatch :: [Query]
1481− , boolQueryMinimumShouldMatch :: Maybe MinimumMatch
1482− , boolQueryBoost :: Maybe Boost
1483− , boolQueryDisableCoord :: Maybe DisableCoord
1484− } deriving (Eq, Read, Show, Generic, Typeable)
1485−
1486−mkBoolQuery :: [Query] -> [Query] -> [Query] -> BoolQuery
1487−mkBoolQuery must mustNot should =
1488− BoolQuery must mustNot should Nothing Nothing Nothing
1489−
1490−data BoostingQuery =
1491− BoostingQuery { positiveQuery :: Query
1492− , negativeQuery :: Query
1493− , negativeBoost :: Boost } deriving (Eq, Read, Show, Generic, Typeable)
1494−
1495−data CommonTermsQuery =
1496− CommonTermsQuery { commonField :: FieldName
1497− , commonQuery :: QueryString
1498− , commonCutoffFrequency :: CutoffFrequency
1499− , commonLowFreqOperator :: BooleanOperator
1500− , commonHighFreqOperator :: BooleanOperator
1501− , commonMinimumShouldMatch :: Maybe CommonMinimumMatch
1502− , commonBoost :: Maybe Boost
1503− , commonAnalyzer :: Maybe Analyzer
1504− , commonDisableCoord :: Maybe DisableCoord
1505− } deriving (Eq, Read, Show, Generic, Typeable)
1506−
1507−data CommonMinimumMatch =
1508− CommonMinimumMatchHighLow MinimumMatchHighLow
1509− | CommonMinimumMatch MinimumMatch
1510− deriving (Eq, Read, Show, Generic, Typeable)
1511−
1512−data MinimumMatchHighLow =
1513− MinimumMatchHighLow { lowFreq :: MinimumMatch
1514− , highFreq :: MinimumMatch } deriving (Eq, Read, Show, Generic, Typeable)
1515−
1516−data Filter = AndFilter [Filter] Cache
1517− | OrFilter [Filter] Cache
1518− | NotFilter Filter Cache
1519− | IdentityFilter
1520− | BoolFilter BoolMatch
1521− | ExistsFilter FieldName -- always cached
1522− | GeoBoundingBoxFilter GeoBoundingBoxConstraint
1523− | GeoDistanceFilter GeoPoint Distance DistanceType OptimizeBbox Cache
1524− | GeoDistanceRangeFilter GeoPoint DistanceRange
1525− | GeoPolygonFilter FieldName [LatLon]
1526− | IdsFilter MappingName [DocId]
1527− | LimitFilter Int
1528− | MissingFilter FieldName Existence NullValue
1529− | PrefixFilter FieldName PrefixValue Cache
1530− | QueryFilter Query Cache
1531− | RangeFilter FieldName RangeValue RangeExecution Cache
1532− | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey
1533− | TermFilter Term Cache
1534− deriving (Eq, Read, Show, Generic, Typeable)
1535−
1536−data ZeroTermsQuery = ZeroTermsNone
1537− | ZeroTermsAll deriving (Eq, Read, Show, Generic, Typeable)
1538−
1539−data RangeExecution = RangeExecutionIndex
1540− | RangeExecutionFielddata deriving (Eq, Read, Show, Generic, Typeable)
1541−
1542−newtype Regexp = Regexp Text deriving (Eq, Read, Show, Generic, Typeable, FromJSON)
1543−
1544−data RegexpFlags = AllRegexpFlags
1545− | NoRegexpFlags
1546− | SomeRegexpFlags (NonEmpty RegexpFlag) deriving (Eq, Read, Show, Generic, Typeable)
1547−
1548−data RegexpFlag = AnyString
1549− | Automaton
1550− | Complement
1551− | Empty
1552− | Intersection
1553− | Interval deriving (Eq, Read, Show, Generic, Typeable)
1554−
1555−newtype LessThan = LessThan Double deriving (Eq, Read, Show, Generic, Typeable)
1556−newtype LessThanEq = LessThanEq Double deriving (Eq, Read, Show, Generic, Typeable)
1557−newtype GreaterThan = GreaterThan Double deriving (Eq, Read, Show, Generic, Typeable)
1558−newtype GreaterThanEq = GreaterThanEq Double deriving (Eq, Read, Show, Generic, Typeable)
1559−
1560−newtype LessThanD = LessThanD UTCTime deriving (Eq, Read, Show, Generic, Typeable)
1561−newtype LessThanEqD = LessThanEqD UTCTime deriving (Eq, Read, Show, Generic, Typeable)
1562−newtype GreaterThanD = GreaterThanD UTCTime deriving (Eq, Read, Show, Generic, Typeable)
1563−newtype GreaterThanEqD = GreaterThanEqD UTCTime deriving (Eq, Read, Show, Generic, Typeable)
1564−
1565−data RangeValue = RangeDateLte LessThanEqD
1566− | RangeDateLt LessThanD
1567− | RangeDateGte GreaterThanEqD
1568− | RangeDateGt GreaterThanD
1569− | RangeDateGtLt GreaterThanD LessThanD
1570− | RangeDateGteLte GreaterThanEqD LessThanEqD
1571− | RangeDateGteLt GreaterThanEqD LessThanD
1572− | RangeDateGtLte GreaterThanD LessThanEqD
1573− | RangeDoubleLte LessThanEq
1574− | RangeDoubleLt LessThan
1575− | RangeDoubleGte GreaterThanEq
1576− | RangeDoubleGt GreaterThan
1577− | RangeDoubleGtLt GreaterThan LessThan
1578− | RangeDoubleGteLte GreaterThanEq LessThanEq
1579− | RangeDoubleGteLt GreaterThanEq LessThan
1580− | RangeDoubleGtLte GreaterThan LessThanEq
1581− deriving (Eq, Read, Show, Generic, Typeable)
1582−
1583−rangeValueToPair :: RangeValue -> [Pair]
1584−rangeValueToPair rv = case rv of
1585− RangeDateLte (LessThanEqD t) -> ["lte" .= t]
1586− RangeDateGte (GreaterThanEqD t) -> ["gte" .= t]
1587− RangeDateLt (LessThanD t) -> ["lt" .= t]
1588− RangeDateGt (GreaterThanD t) -> ["gt" .= t]
1589− RangeDateGteLte (GreaterThanEqD l) (LessThanEqD g) -> ["gte" .= l, "lte" .= g]
1590− RangeDateGtLte (GreaterThanD l) (LessThanEqD g) -> ["gt" .= l, "lte" .= g]
1591− RangeDateGteLt (GreaterThanEqD l) (LessThanD g) -> ["gte" .= l, "lt" .= g]
1592− RangeDateGtLt (GreaterThanD l) (LessThanD g) -> ["gt" .= l, "lt" .= g]
1593− RangeDoubleLte (LessThanEq t) -> ["lte" .= t]
1594− RangeDoubleGte (GreaterThanEq t) -> ["gte" .= t]
1595− RangeDoubleLt (LessThan t) -> ["lt" .= t]
1596− RangeDoubleGt (GreaterThan t) -> ["gt" .= t]
1597− RangeDoubleGteLte (GreaterThanEq l) (LessThanEq g) -> ["gte" .= l, "lte" .= g]
1598− RangeDoubleGtLte (GreaterThan l) (LessThanEq g) -> ["gt" .= l, "lte" .= g]
1599− RangeDoubleGteLt (GreaterThanEq l) (LessThan g) -> ["gte" .= l, "lt" .= g]
1600− RangeDoubleGtLt (GreaterThan l) (LessThan g) -> ["gt" .= l, "lt" .= g]
1601−
1602−data Term = Term { termField :: Text
1603− , termValue :: Text } deriving (Eq, Read, Show, Generic, Typeable)
1604−
1605−data BoolMatch = MustMatch Term Cache
1606− | MustNotMatch Term Cache
1607− | ShouldMatch [Term] Cache deriving (Eq, Read, Show, Generic, Typeable)
1608−
1609−-- "memory" or "indexed"
1610−data GeoFilterType = GeoFilterMemory
1611− | GeoFilterIndexed deriving (Eq, Read, Show, Generic, Typeable)
1612−
1613−data LatLon = LatLon { lat :: Double
1614− , lon :: Double } deriving (Eq, Read, Show, Generic, Typeable)
1615−
1616−data GeoBoundingBox =
1617− GeoBoundingBox { topLeft :: LatLon
1618− , bottomRight :: LatLon } deriving (Eq, Read, Show, Generic, Typeable)
1619−
1620−data GeoBoundingBoxConstraint =
1621− GeoBoundingBoxConstraint { geoBBField :: FieldName
1622− , constraintBox :: GeoBoundingBox
1623− , bbConstraintcache :: Cache
1624− , geoType :: GeoFilterType
1625− } deriving (Eq, Read, Show, Generic, Typeable)
1626−
1627−data GeoPoint =
1628− GeoPoint { geoField :: FieldName
1629− , latLon :: LatLon} deriving (Eq, Read, Show, Generic, Typeable)
1630−
1631−data DistanceUnit = Miles
1632− | Yards
1633− | Feet
1634− | Inches
1635− | Kilometers
1636− | Meters
1637− | Centimeters
1638− | Millimeters
1639− | NauticalMiles deriving (Eq, Read, Show, Generic, Typeable)
1640−
1641−data DistanceType = Arc
1642− | SloppyArc -- doesn't exist <1.0
1643− | Plane deriving (Eq, Read, Show, Generic, Typeable)
1644−
1645−data OptimizeBbox = OptimizeGeoFilterType GeoFilterType
1646− | NoOptimizeBbox deriving (Eq, Read, Show, Generic, Typeable)
1647−
1648−data Distance =
1649− Distance { coefficient :: Double
1650− , unit :: DistanceUnit } deriving (Eq, Read, Show, Generic, Typeable)
1651−
1652−data DistanceRange =
1653− DistanceRange { distanceFrom :: Distance
1654− , distanceTo :: Distance } deriving (Eq, Read, Show, Generic, Typeable)
1655−
1656−type TemplateQueryKey = Text
1657−type TemplateQueryValue = Text
1658−
1659−newtype TemplateQueryKeyValuePairs = TemplateQueryKeyValuePairs (HM.HashMap TemplateQueryKey TemplateQueryValue)
1660− deriving (Eq, Read, Show, Generic, Typeable)
1661−
1662−instance ToJSON TemplateQueryKeyValuePairs where
1663− toJSON (TemplateQueryKeyValuePairs x) = Object $ HM.map toJSON x
1664−
1665−instance FromJSON TemplateQueryKeyValuePairs where
1666− parseJSON (Object o) = pure . TemplateQueryKeyValuePairs $ HM.mapMaybe getValue o
1667− where getValue (String x) = Just x
1668− getValue _ = Nothing
1669− parseJSON _ = fail "error parsing TemplateQueryKeyValuePairs"
1670−
1671−data TemplateQueryInline =
1672− TemplateQueryInline { inline :: Query
1673− , params :: TemplateQueryKeyValuePairs
1674− }
1675− deriving (Eq, Read, Show, Generic, Typeable)
1676−
1677−instance ToJSON TemplateQueryInline where
1678− toJSON TemplateQueryInline{..} = object [ "query" .= inline
1679− , "params" .= params
1680− ]
1681−
1682−instance FromJSON TemplateQueryInline where
1683− parseJSON = withObject "TemplateQueryInline" parse
1684− where parse o = TemplateQueryInline
1685− <$> o .: "query"
1686− <*> o .: "params"
1687−
1688−data SearchResult a =
1689− SearchResult { took :: Int
1690− , timedOut :: Bool
1691− , shards :: ShardResult
1692− , searchHits :: SearchHits a
1693− , aggregations :: Maybe AggregationResults
1694− , scrollId :: Maybe ScrollId
1695− , suggest :: Maybe NamedSuggestionResponse -- ^ Only one Suggestion request / response per Search is supported.
1696− }
1697− deriving (Eq, Read, Show, Generic, Typeable)
1698−
1699−newtype ScrollId = ScrollId Text deriving (Eq, Read, Show, Generic, Ord, ToJSON, FromJSON)
1700−
1701−type Score = Maybe Double
1702−
1703−data SearchHits a =
1704− SearchHits { hitsTotal :: Int
1705− , maxScore :: Score
1706− , hits :: [Hit a] } deriving (Eq, Read, Show, Generic, Typeable)
1707−
1708−instance Semigroup (SearchHits a) where
1709− (SearchHits ta ma ha) <> (SearchHits tb mb hb) = SearchHits (ta + tb) (max ma mb) (ha <> hb)
1710−
1711−instance Monoid (SearchHits a) where
1712− mempty = SearchHits 0 Nothing mempty
1713− mappend = (<>)
1714−
1715−data Hit a =
1716− Hit { hitIndex :: IndexName
1717− , hitType :: MappingName
1718− , hitDocId :: DocId
1719− , hitScore :: Score
1720− , hitSource :: Maybe a
1721− , hitHighlight :: Maybe HitHighlight } deriving (Eq, Read, Show, Generic, Typeable)
1722−
1723−data ShardResult =
1724− ShardResult { shardTotal :: Int
1725− , shardsSuccessful :: Int
1726− , shardsFailed :: Int } deriving (Eq, Read, Show, Generic, Typeable)
1727−
1728−type HitHighlight = M.Map Text [Text]
1729−
1730−showText :: Show a => a -> Text
1731−showText = T.pack . show
1732−
1733−readMay :: Read a => String -> Maybe a
1734−readMay s = case reads s of
1735− (a, ""):_ -> Just a
1736− _ -> Nothing
1737−
1738−parseReadText :: Read a => Text -> Parser a
1739−parseReadText = maybe mzero return . readMay . T.unpack
1740−
1741−type Aggregations = M.Map Text Aggregation
1742−
1743−emptyAggregations :: Aggregations
1744−emptyAggregations = M.empty
1745−
1746−mkAggregations :: Text -> Aggregation -> Aggregations
1747−mkAggregations name aggregation = M.insert name aggregation emptyAggregations
1748−
1749−data TermOrder = TermOrder{ termSortField :: Text
1750− , termSortOrder :: SortOrder } deriving (Eq, Read, Show, Generic, Typeable)
1751−
1752−data TermInclusion = TermInclusion Text
1753− | TermPattern Text Text deriving (Eq, Read, Show, Generic, Typeable)
1754−
1755−data CollectionMode = BreadthFirst
1756− | DepthFirst deriving (Eq, Read, Show, Generic, Typeable)
1757−
1758−data ExecutionHint = Ordinals
1759− | GlobalOrdinals
1760− | GlobalOrdinalsHash
1761− | GlobalOrdinalsLowCardinality
1762− | Map deriving (Eq, Read, Show, Generic, Typeable)
1763−
1764−data TimeInterval = Weeks
1765− | Days
1766− | Hours
1767− | Minutes
1768− | Seconds deriving Eq
1769−
1770−data Interval = Year
1771− | Quarter
1772− | Month
1773− | Week
1774− | Day
1775− | Hour
1776− | Minute
1777− | Second
1778− | FractionalInterval Float TimeInterval deriving (Eq, Read, Show, Generic, Typeable)
1779−
1780−data Aggregation = TermsAgg TermsAggregation
1781− | CardinalityAgg CardinalityAggregation
1782− | DateHistogramAgg DateHistogramAggregation
1783− | ValueCountAgg ValueCountAggregation
1784− | FilterAgg FilterAggregation
1785− | DateRangeAgg DateRangeAggregation
1786− | MissingAgg MissingAggregation
1787− | TopHitsAgg TopHitsAggregation
1788− deriving (Eq, Read, Show, Generic, Typeable)
1789−
1790−data TopHitsAggregation = TopHitsAggregation
1791− { taFrom :: Maybe From
1792− , taSize :: Maybe Size
1793− , taSort :: Maybe Sort
1794− } deriving (Eq, Read, Show)
1795−
1796−data MissingAggregation = MissingAggregation
1797− { maField :: Text
1798− } deriving (Eq, Read, Show, Generic, Typeable)
1799−
1800−data TermsAggregation = TermsAggregation { term :: Either Text Text
1801− , termInclude :: Maybe TermInclusion
1802− , termExclude :: Maybe TermInclusion
1803− , termOrder :: Maybe TermOrder
1804− , termMinDocCount :: Maybe Int
1805− , termSize :: Maybe Int
1806− , termShardSize :: Maybe Int
1807− , termCollectMode :: Maybe CollectionMode
1808− , termExecutionHint :: Maybe ExecutionHint
1809− , termAggs :: Maybe Aggregations
1810− } deriving (Eq, Read, Show, Generic, Typeable)
1811−
1812−data CardinalityAggregation = CardinalityAggregation { cardinalityField :: FieldName,
1813− precisionThreshold :: Maybe Int
1814− } deriving (Eq, Read, Show, Generic, Typeable)
1815−
1816−data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
1817− , dateInterval :: Interval
1818− , dateFormat :: Maybe Text
1819− -- pre and post deprecated in 1.5
1820− , datePreZone :: Maybe Text
1821− , datePostZone :: Maybe Text
1822− , datePreOffset :: Maybe Text
1823− , datePostOffset :: Maybe Text
1824− , dateAggs :: Maybe Aggregations
1825− } deriving (Eq, Read, Show, Generic, Typeable)
1826−
1827−
1828−data DateRangeAggregation = DateRangeAggregation { draField :: FieldName
1829− , draFormat :: Maybe Text
1830− , draRanges :: NonEmpty DateRangeAggRange
1831− } deriving (Eq, Read, Show, Generic, Typeable)
1832−
1833−data DateRangeAggRange = DateRangeFrom DateMathExpr
1834− | DateRangeTo DateMathExpr
1835− | DateRangeFromAndTo DateMathExpr DateMathExpr deriving (Eq, Read, Show, Generic, Typeable)
1836−
1837−-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#date-math> for more information.
1838−data DateMathExpr = DateMathExpr DateMathAnchor [DateMathModifier] deriving (Eq, Read, Show, Generic, Typeable)
1839−
1840−
1841−-- | Starting point for a date range. This along with the 'DateMathModifiers' gets you the date ES will start from.
1842−data DateMathAnchor = DMNow
1843− | DMDate Day deriving (Eq, Read, Show, Generic, Typeable)
1844−
1845−data DateMathModifier = AddTime Int DateMathUnit
1846− | SubtractTime Int DateMathUnit
1847− | RoundDownTo DateMathUnit deriving (Eq, Read, Show, Generic, Typeable)
1848−
1849−data DateMathUnit = DMYear
1850− | DMMonth
1851− | DMWeek
1852− | DMDay
1853− | DMHour
1854− | DMMinute
1855− | DMSecond deriving (Eq, Read, Show, Generic, Typeable)
1856−
1857−-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.
1858−data ValueCountAggregation = FieldValueCount FieldName
1859− | ScriptValueCount Script deriving (Eq, Read, Show, Generic, Typeable)
1860−
1861−-- | 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.
1862−data FilterAggregation = FilterAggregation { faFilter :: Filter
1863− , faAggs :: Maybe Aggregations} deriving (Eq, Read, Show, Generic, Typeable)
1864−
1865−mkTermsAggregation :: Text -> TermsAggregation
1866−mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
1867−
1868−mkTermsScriptAggregation :: Text -> TermsAggregation
1869−mkTermsScriptAggregation t = TermsAggregation (Right t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
1870−
1871−mkDateHistogram :: FieldName -> Interval -> DateHistogramAggregation
1872−mkDateHistogram t i = DateHistogramAggregation t i Nothing Nothing Nothing Nothing Nothing Nothing
1873−
1874−mkCardinalityAggregation :: FieldName -> CardinalityAggregation
1875−mkCardinalityAggregation t = CardinalityAggregation t Nothing
1876−
1877−instance ToJSON Version where
1878− toJSON Version {..} = object ["number" .= number
1879− ,"build_hash" .= build_hash
1880− ,"build_timestamp" .= build_timestamp
1881− ,"build_snapshot" .= build_snapshot
1882− ,"lucene_version" .= lucene_version]
1883−
1884−instance FromJSON Version where
1885− parseJSON = withObject "Version" parse
1886− where parse o = Version
1887− <$> o .: "number"
1888− <*> o .: "build_hash"
1889− <*> o .: "build_timestamp"
1890− <*> o .: "build_snapshot"
1891− <*> o .: "lucene_version"
1892−
1893−instance ToJSON VersionNumber where
1894− toJSON = toJSON . Vers.showVersion . versionNumber
1895−
1896−instance FromJSON VersionNumber where
1897− parseJSON = withText "VersionNumber" (parse . T.unpack)
1898− where
1899− parse s = case filter (null . snd)(RP.readP_to_S Vers.parseVersion s) of
1900− [(v, _)] -> pure (VersionNumber v)
1901− [] -> fail ("Invalid version string " ++ s)
1902− xs -> fail ("Ambiguous version string " ++ s ++ " (" ++ intercalate ", " (Vers.showVersion . fst <$> xs) ++ ")")
1903−
1904−instance ToJSON TermOrder where
1905− toJSON (TermOrder termSortField termSortOrder) = object [termSortField .= termSortOrder]
1906−
1907−instance ToJSON TermInclusion where
1908− toJSON (TermInclusion x) = toJSON x
1909− toJSON (TermPattern pattern flags) = omitNulls [ "pattern" .= pattern,
1910− "flags" .= flags]
1911−
1912−instance ToJSON CollectionMode where
1913− toJSON BreadthFirst = "breadth_first"
1914− toJSON DepthFirst = "depth_first"
1915−
1916−instance ToJSON ExecutionHint where
1917− toJSON Ordinals = "ordinals"
1918− toJSON GlobalOrdinals = "global_ordinals"
1919− toJSON GlobalOrdinalsHash = "global_ordinals_hash"
1920− toJSON GlobalOrdinalsLowCardinality = "global_ordinals_low_cardinality"
1921− toJSON Map = "map"
1922−
1923−instance ToJSON Interval where
1924− toJSON Year = "year"
1925− toJSON Quarter = "quarter"
1926− toJSON Month = "month"
1927− toJSON Week = "week"
1928− toJSON Day = "day"
1929− toJSON Hour = "hour"
1930− toJSON Minute = "minute"
1931− toJSON Second = "second"
1932− toJSON (FractionalInterval fraction interval) = toJSON $ show fraction ++ show interval
1933−
1934−instance Show TimeInterval where
1935− show Weeks = "w"
1936− show Days = "d"
1937− show Hours = "h"
1938− show Minutes = "m"
1939− show Seconds = "s"
1940−
1941−instance Read TimeInterval where
1942− readPrec = f =<< TR.get
1943− where
1944− f 'w' = return Weeks
1945− f 'd' = return Days
1946− f 'h' = return Hours
1947− f 'm' = return Minutes
1948− f 's' = return Seconds
1949− f _ = fail "TimeInterval expected one of w, d, h, m, s"
1950−
1951−instance ToJSON Aggregation where
1952− toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =
1953− omitNulls ["terms" .= omitNulls [ toJSON' term,
1954− "include" .= include,
1955− "exclude" .= exclude,
1956− "order" .= order,
1957− "min_doc_count" .= minDocCount,
1958− "size" .= size,
1959− "shard_size" .= shardSize,
1960− "collect_mode" .= collectMode,
1961− "execution_hint" .= executionHint
1962− ],
1963− "aggs" .= termAggs ]
1964− where
1965− toJSON' x = case x of { Left y -> "field" .= y; Right y -> "script" .= y }
1966−
1967− toJSON (CardinalityAgg (CardinalityAggregation field precisionThreshold)) =
1968− object ["cardinality" .= omitNulls [ "field" .= field,
1969− "precisionThreshold" .= precisionThreshold
1970− ]
1971− ]
1972−
1973− toJSON (DateHistogramAgg (DateHistogramAggregation field interval format preZone postZone preOffset postOffset dateHistoAggs)) =
1974− omitNulls ["date_histogram" .= omitNulls [ "field" .= field,
1975− "interval" .= interval,
1976− "format" .= format,
1977− "pre_zone" .= preZone,
1978− "post_zone" .= postZone,
1979− "pre_offset" .= preOffset,
1980− "post_offset" .= postOffset
1981− ],
1982− "aggs" .= dateHistoAggs ]
1983− toJSON (ValueCountAgg a) = object ["value_count" .= v]
1984− where v = case a of
1985− (FieldValueCount (FieldName n)) -> object ["field" .= n]
1986− (ScriptValueCount (Script s)) -> object ["script" .= s]
1987− toJSON (FilterAgg (FilterAggregation filt ags)) =
1988− omitNulls [ "filter" .= filt
1989− , "aggs" .= ags]
1990− toJSON (DateRangeAgg a) = object [ "date_range" .= a
1991− ]
1992− toJSON (MissingAgg (MissingAggregation{..})) =
1993− object ["missing" .= object ["field" .= maField]]
1994−
1995− toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =
1996− omitNulls ["top_hits" .= omitNulls [ "size" .= msize
1997− , "from" .= mfrom
1998− , "sort" .= msort
1999− ]
2000− ]
2001−
2002−instance ToJSON DateRangeAggregation where
2003− toJSON DateRangeAggregation {..} =
2004− omitNulls [ "field" .= draField
2005− , "format" .= draFormat
2006− , "ranges" .= toList draRanges
2007− ]
2008−
2009−instance ToJSON DateRangeAggRange where
2010− toJSON (DateRangeFrom e) = object [ "from" .= e ]
2011− toJSON (DateRangeTo e) = object [ "to" .= e ]
2012− toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]
2013−
2014−instance ToJSON DateMathExpr where
2015− toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))
2016− where fmtA DMNow = "now"
2017− fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"
2018− fmtMod (AddTime n u) = "+" <> showText n <> fmtU u
2019− fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u
2020− fmtMod (RoundDownTo u) = "/" <> fmtU u
2021− fmtU DMYear = "y"
2022− fmtU DMMonth = "M"
2023− fmtU DMWeek = "w"
2024− fmtU DMDay = "d"
2025− fmtU DMHour = "h"
2026− fmtU DMMinute = "m"
2027− fmtU DMSecond = "s"
2028−
2029−
2030−type AggregationResults = M.Map Text Value
2031−
2032−class BucketAggregation a where
2033− key :: a -> BucketValue
2034− docCount :: a -> Int
2035− aggs :: a -> Maybe AggregationResults
2036−
2037−
2038−data Bucket a = Bucket { buckets :: [a]} deriving (Read, Show)
2039−
2040−data BucketValue = TextValue Text
2041− | ScientificValue Scientific
2042− | BoolValue Bool deriving (Read, Show)
2043−
2044−data MissingResult = MissingResult { missingDocCount :: Int } deriving (Show)
2045−
2046−data TopHitResult a = TopHitResult { tarHits :: (SearchHits a)
2047− } deriving Show
2048−
2049−data TermsResult = TermsResult { termKey :: BucketValue
2050− , termsDocCount :: Int
2051− , termsAggs :: Maybe AggregationResults } deriving (Read, Show)
2052−
2053−data DateHistogramResult = DateHistogramResult { dateKey :: Int
2054− , dateKeyStr :: Maybe Text
2055− , dateDocCount :: Int
2056− , dateHistogramAggs :: Maybe AggregationResults } deriving (Read, Show)
2057−
2058−data DateRangeResult = DateRangeResult { dateRangeKey :: Text
2059− , dateRangeFrom :: Maybe UTCTime
2060− , dateRangeFromAsString :: Maybe Text
2061− , dateRangeTo :: Maybe UTCTime
2062− , dateRangeToAsString :: Maybe Text
2063− , dateRangeDocCount :: Int
2064− , dateRangeAggs :: Maybe AggregationResults } deriving (Read, Show, Eq, Generic, Typeable)
2065−
2066−toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
2067−toTerms = toAggResult
2068−
2069−toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
2070−toDateHistogram = toAggResult
2071−
2072−toMissing :: Text -> AggregationResults -> Maybe MissingResult
2073−toMissing = toAggResult
2074−
2075−toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)
2076−toTopHits = toAggResult
2077−
2078−toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a
2079−toAggResult t a = M.lookup t a >>= deserialize
2080− where deserialize = parseMaybe parseJSON
2081−
2082−instance BucketAggregation TermsResult where
2083− key = termKey
2084− docCount = termsDocCount
2085− aggs = termsAggs
2086−
2087−instance BucketAggregation DateHistogramResult where
2088− key = TextValue . showText . dateKey
2089− docCount = dateDocCount
2090− aggs = dateHistogramAggs
2091−
2092−instance BucketAggregation DateRangeResult where
2093− key = TextValue . dateRangeKey
2094− docCount = dateRangeDocCount
2095− aggs = dateRangeAggs
2096−
2097−instance (FromJSON a) => FromJSON (Bucket a) where
2098− parseJSON (Object v) = Bucket <$>
2099− v .: "buckets"
2100− parseJSON _ = mempty
2101−
2102−instance FromJSON BucketValue where
2103− parseJSON (String t) = return $ TextValue t
2104− parseJSON (Number s) = return $ ScientificValue s
2105− parseJSON (Bool b) = return $ BoolValue b
2106− parseJSON _ = mempty
2107−
2108−instance FromJSON MissingResult where
2109− parseJSON = withObject "MissingResult" parse
2110− where parse v = MissingResult <$> v .: "doc_count"
2111−
2112−instance FromJSON TermsResult where
2113− parseJSON (Object v) = TermsResult <$>
2114− v .: "key" <*>
2115− v .: "doc_count" <*>
2116− (pure $ getNamedSubAgg v ["key", "doc_count"])
2117− parseJSON _ = mempty
2118−
2119−instance FromJSON DateHistogramResult where
2120− parseJSON (Object v) = DateHistogramResult <$>
2121− v .: "key" <*>
2122− v .:? "key_as_string" <*>
2123− v .: "doc_count" <*>
2124− (pure $ getNamedSubAgg v [ "key"
2125− , "doc_count"
2126− , "key_as_string"
2127− ]
2128− )
2129− parseJSON _ = mempty
2130−
2131−instance FromJSON DateRangeResult where
2132− parseJSON = withObject "DateRangeResult" parse
2133− where parse v = DateRangeResult <$>
2134− v .: "key" <*>
2135− (fmap posixMS <$> v .:? "from") <*>
2136− v .:? "from_as_string" <*>
2137− (fmap posixMS <$> v .:? "to") <*>
2138− v .:? "to_as_string" <*>
2139− v .: "doc_count" <*>
2140− (pure $ getNamedSubAgg v [ "key"
2141− , "from"
2142− , "from_as_string"
2143− , "to"
2144− , "to_as_string"
2145− , "doc_count"
2146− ]
2147− )
2148−
2149−instance FromJSON POSIXMS where
2150− parseJSON = withScientific "POSIXMS" (return . parse)
2151− where parse n = let n' = truncate n :: Integer
2152− in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))
2153−
2154−instance (FromJSON a) => FromJSON (TopHitResult a) where
2155− parseJSON (Object v) = TopHitResult <$>
2156− v .: "hits"
2157− parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"
2158−
2159−instance Semigroup Filter where
2160− a <> b = AndFilter [a, b] defaultCache
2161−
2162−instance Monoid Filter where
2163− mempty = IdentityFilter
2164− mappend = (<>)
2165−
2166−instance Seminearring Filter where
2167− a <||> b = OrFilter [a, b] defaultCache
2168−
2169−instance ToJSON Filter where
2170− toJSON (AndFilter filters cache) =
2171− object ["and" .=
2172− object [ "filters" .= fmap toJSON filters
2173− , "_cache" .= cache]]
2174−
2175− toJSON (OrFilter filters cache) =
2176− object ["or" .=
2177− object [ "filters" .= fmap toJSON filters
2178− , "_cache" .= cache]]
2179−
2180− toJSON (NotFilter notFilter cache) =
2181− object ["not" .=
2182− object ["filter" .= notFilter
2183− , "_cache" .= cache]]
2184−
2185− toJSON (IdentityFilter) =
2186− object ["match_all" .= object []]
2187−
2188− toJSON (TermFilter (Term termFilterField termFilterValue) cache) =
2189− object ["term" .= object base]
2190− where base = [termFilterField .= termFilterValue,
2191− "_cache" .= cache]
2192−
2193− toJSON (ExistsFilter (FieldName fieldName)) =
2194− object ["exists" .= object
2195− ["field" .= fieldName]]
2196−
2197− toJSON (BoolFilter boolMatch) =
2198− object ["bool" .= boolMatch]
2199−
2200− toJSON (GeoBoundingBoxFilter bbConstraint) =
2201− object ["geo_bounding_box" .= bbConstraint]
2202−
2203− toJSON (GeoDistanceFilter (GeoPoint (FieldName distanceGeoField) geoDistLatLon)
2204− distance distanceType optimizeBbox cache) =
2205− object ["geo_distance" .=
2206− object ["distance" .= distance
2207− , "distance_type" .= distanceType
2208− , "optimize_bbox" .= optimizeBbox
2209− , distanceGeoField .= geoDistLatLon
2210− , "_cache" .= cache]]
2211−
2212− toJSON (GeoDistanceRangeFilter (GeoPoint (FieldName gddrField) drLatLon)
2213− (DistanceRange geoDistRangeDistFrom drDistanceTo)) =
2214− object ["geo_distance_range" .=
2215− object ["from" .= geoDistRangeDistFrom
2216− , "to" .= drDistanceTo
2217− , gddrField .= drLatLon]]
2218−
2219− toJSON (GeoPolygonFilter (FieldName geoPolygonFilterField) latLons) =
2220− object ["geo_polygon" .=
2221− object [geoPolygonFilterField .=
2222− object ["points" .= fmap toJSON latLons]]]
2223−
2224− toJSON (IdsFilter (MappingName mappingName) values) =
2225− object ["ids" .=
2226− object ["type" .= mappingName
2227− , "values" .= fmap unpackId values]]
2228−
2229− toJSON (LimitFilter limit) =
2230− object ["limit" .= object ["value" .= limit]]
2231−
2232− toJSON (MissingFilter (FieldName fieldName) (Existence existence) (NullValue nullValue)) =
2233− object ["missing" .=
2234− object [ "field" .= fieldName
2235− , "existence" .= existence
2236− , "null_value" .= nullValue]]
2237−
2238− toJSON (PrefixFilter (FieldName fieldName) fieldValue cache) =
2239− object ["prefix" .=
2240− object [fieldName .= fieldValue
2241− , "_cache" .= cache]]
2242−
2243− toJSON (QueryFilter query False) =
2244− object ["query" .= toJSON query ]
2245− toJSON (QueryFilter query True) =
2246− object ["fquery" .=
2247− object [ "query" .= toJSON query
2248− , "_cache" .= True ]]
2249−
2250− toJSON (RangeFilter (FieldName fieldName) rangeValue rangeExecution cache) =
2251− object ["range" .=
2252− object [ fieldName .= object (rangeValueToPair rangeValue)
2253− , "execution" .= rangeExecution
2254− , "_cache" .= cache]]
2255−
2256− toJSON (RegexpFilter (FieldName fieldName)
2257− (Regexp regexText) flags (CacheName cacheName) cache (CacheKey cacheKey)) =
2258− object ["regexp" .=
2259− object [fieldName .=
2260− object ["value" .= regexText
2261− , "flags" .= flags]
2262− , "_name" .= cacheName
2263− , "_cache" .= cache
2264− , "_cache_key" .= cacheKey]]
2265−
2266−instance FromJSON Filter where
2267− parseJSON = withObject "Filter" parse
2268− where parse o = andFilter `taggedWith` "and"
2269− <|> orFilter `taggedWith` "or"
2270− <|> notFilter `taggedWith` "not"
2271− <|> identityFilter `taggedWith` "match_all"
2272− <|> boolFilter `taggedWith` "bool"
2273− <|> existsFilter `taggedWith` "exists"
2274− <|> geoBoundingBoxFilter `taggedWith` "geo_bounding_box"
2275− <|> geoDistanceFilter `taggedWith` "geo_distance"
2276− <|> geoDistanceRangeFilter `taggedWith` "geo_distance_range"
2277− <|> geoPolygonFilter `taggedWith` "geo_polygon"
2278− <|> idsFilter `taggedWith` "ids"
2279− <|> limitFilter `taggedWith` "limit"
2280− <|> missingFilter `taggedWith` "missing"
2281− <|> prefixFilter `taggedWith` "prefix"
2282− <|> queryFilter `taggedWith` "query"
2283− <|> fqueryFilter `taggedWith` "fquery"
2284− <|> rangeFilter `taggedWith` "range"
2285− <|> regexpFilter `taggedWith` "regexp"
2286− <|> termFilter `taggedWith` "term"
2287− where taggedWith parser k = parser =<< o .: k
2288− andFilter o = AndFilter <$> o .: "filters"
2289− <*> o .:? "_cache" .!= defaultCache
2290− orFilter o = OrFilter <$> o .: "filters"
2291− <*> o .:? "_cache" .!= defaultCache
2292− notFilter o = NotFilter <$> o .: "filter"
2293− <*> o .: "_cache" .!= defaultCache
2294− identityFilter :: Object -> Parser Filter
2295− identityFilter m
2296− | HM.null m = pure IdentityFilter
2297− | otherwise = fail ("Identityfilter expected empty object but got " <> show m)
2298− boolFilter = pure . BoolFilter
2299− existsFilter o = ExistsFilter <$> o .: "field"
2300− geoBoundingBoxFilter = pure . GeoBoundingBoxFilter
2301− geoDistanceFilter o = do
2302− case HM.toList (deleteSeveral ["distance", "distance_type", "optimize_bbox", "_cache"] o) of
2303− [(fn, v)] -> do
2304− gp <- GeoPoint (FieldName fn) <$> parseJSON v
2305− GeoDistanceFilter gp <$> o .: "distance"
2306− <*> o .: "distance_type"
2307− <*> o .: "optimize_bbox"
2308− <*> o .:? "_cache" .!= defaultCache
2309− _ -> fail "Could not find GeoDistanceFilter field name"
2310− geoDistanceRangeFilter o = do
2311− case HM.toList (deleteSeveral ["from", "to"] o) of
2312− [(fn, v)] -> do
2313− gp <- GeoPoint (FieldName fn) <$> parseJSON v
2314− rng <- DistanceRange <$> o .: "from" <*> o .: "to"
2315− return (GeoDistanceRangeFilter gp rng)
2316− _ -> fail "Could not find GeoDistanceRangeFilter field name"
2317− geoPolygonFilter = fieldTagged $ \fn o -> GeoPolygonFilter fn <$> o .: "points"
2318− idsFilter o = IdsFilter <$> o .: "type"
2319− <*> o .: "values"
2320− limitFilter o = LimitFilter <$> o .: "value"
2321− missingFilter o = MissingFilter <$> o .: "field"
2322− <*> o .: "existence"
2323− <*> o .: "null_value"
2324− prefixFilter o = case HM.toList (HM.delete "_cache" o) of
2325− [(fn, String v)] -> PrefixFilter (FieldName fn) v <$> o .:? "_cache" .!= defaultCache
2326− _ -> fail "Could not parse PrefixFilter"
2327−
2328− queryFilter q = pure (QueryFilter q False)
2329− fqueryFilter o = QueryFilter <$> o .: "query" <*> pure True
2330− rangeFilter o = case HM.toList (deleteSeveral ["execution", "_cache"] o) of
2331− [(fn, v)] -> RangeFilter (FieldName fn)
2332− <$> parseJSON v
2333− <*> o .: "execution"
2334− <*> o .:? "_cache" .!= defaultCache
2335− _ -> fail "Could not find field name for RangeFilter"
2336− regexpFilter o = case HM.toList (deleteSeveral ["_name", "_cache", "_cache_key"] o) of
2337− [(fn, Object o')] -> RegexpFilter (FieldName fn)
2338− <$> o' .: "value"
2339− <*> o' .: "flags"
2340− <*> o .: "_name"
2341− <*> o .:? "_cache" .!= defaultCache
2342− <*> o .: "_cache_key"
2343− _ -> fail "Could not find field name for RegexpFilter"
2344− termFilter o = case HM.toList (HM.delete "_cache" o) of
2345− [(termField, String termVal)] -> TermFilter (Term termField termVal)
2346− <$> o .:? "_cache" .!= defaultCache
2347− _ -> fail "Could not find term field for TermFilter"
2348−
2349−fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a
2350−fieldTagged f o = case HM.toList o of
2351− [(k, Object o')] -> f (FieldName k) o'
2352− _ -> fail "Expected object with 1 field-named key"
2353−
2354−-- Try to get an AggregationResults when we don't know the
2355−-- field name. We filter out the known keys to try to minimize the noise.
2356−getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
2357−getNamedSubAgg o knownKeys = maggRes
2358− where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
2359− maggRes
2360− | HM.null unknownKeys = Nothing
2361− | otherwise = Just . M.fromList $ HM.toList unknownKeys
2362−
2363−instance ToJSON GeoPoint where
2364− toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) =
2365− object [ geoPointField .= geoPointLatLon ]
2366−
2367−
2368−instance ToJSON Query where
2369− toJSON (TermQuery (Term termQueryField termQueryValue) boost) =
2370− object [ "term" .=
2371− object [termQueryField .= object merged]]
2372− where
2373− base = [ "value" .= termQueryValue ]
2374− boosted = maybe [] (return . ("boost" .=)) boost
2375− merged = mappend base boosted
2376−
2377− toJSON (TermsQuery fieldName terms) =
2378− object [ "terms" .= object conjoined ]
2379− where conjoined = [fieldName .= terms]
2380−
2381− toJSON (IdsQuery idsQueryMappingName docIds) =
2382− object [ "ids" .= object conjoined ]
2383− where conjoined = [ "type" .= idsQueryMappingName
2384− , "values" .= fmap toJSON docIds ]
2385−
2386− toJSON (QueryQueryStringQuery qQueryStringQuery) =
2387− object [ "query_string" .= qQueryStringQuery ]
2388−
2389− toJSON (QueryMatchQuery matchQuery) =
2390− object [ "match" .= matchQuery ]
2391−
2392− toJSON (QueryMultiMatchQuery multiMatchQuery) =
2393− toJSON multiMatchQuery
2394−
2395− toJSON (QueryBoolQuery boolQuery) =
2396− object [ "bool" .= boolQuery ]
2397−
2398− toJSON (QueryBoostingQuery boostingQuery) =
2399− object [ "boosting" .= boostingQuery ]
2400−
2401− toJSON (QueryCommonTermsQuery commonTermsQuery) =
2402− object [ "common" .= commonTermsQuery ]
2403−
2404− toJSON (ConstantScoreFilter csFilter boost) =
2405− object ["constant_score" .= object ["filter" .= csFilter
2406− , "boost" .= boost]]
2407−
2408− toJSON (ConstantScoreQuery query boost) =
2409− object ["constant_score" .= object ["query" .= query
2410− , "boost" .= boost]]
2411−
2412− toJSON (QueryDisMaxQuery disMaxQuery) =
2413− object [ "dis_max" .= disMaxQuery ]
2414−
2415− toJSON (QueryFilteredQuery qFilteredQuery) =
2416− object [ "filtered" .= qFilteredQuery ]
2417−
2418− toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) =
2419− object [ "fuzzy_like_this" .= fuzzyQuery ]
2420−
2421− toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) =
2422− object [ "fuzzy_like_this_field" .= fuzzyFieldQuery ]
2423−
2424− toJSON (QueryFuzzyQuery fuzzyQuery) =
2425− object [ "fuzzy" .= fuzzyQuery ]
2426−
2427− toJSON (QueryHasChildQuery childQuery) =
2428− object [ "has_child" .= childQuery ]
2429−
2430− toJSON (QueryHasParentQuery parentQuery) =
2431− object [ "has_parent" .= parentQuery ]
2432−
2433− toJSON (QueryIndicesQuery qIndicesQuery) =
2434− object [ "indices" .= qIndicesQuery ]
2435−
2436− toJSON (MatchAllQuery boost) =
2437− object [ "match_all" .= omitNulls [ "boost" .= boost ] ]
2438−
2439− toJSON (QueryMoreLikeThisQuery query) =
2440− object [ "more_like_this" .= query ]
2441−
2442− toJSON (QueryMoreLikeThisFieldQuery query) =
2443− object [ "more_like_this_field" .= query ]
2444−
2445− toJSON (QueryNestedQuery query) =
2446− object [ "nested" .= query ]
2447−
2448− toJSON (QueryPrefixQuery query) =
2449− object [ "prefix" .= query ]
2450−
2451− toJSON (QueryRangeQuery query) =
2452− object [ "range" .= query ]
2453−
2454− toJSON (QueryRegexpQuery query) =
2455− object [ "regexp" .= query ]
2456−
2457− toJSON (QuerySimpleQueryStringQuery query) =
2458− object [ "simple_query_string" .= query ]
2459−
2460− toJSON (QueryTemplateQueryInline templateQuery) =
2461− object [ "template" .= templateQuery ]
2462−
2463−instance FromJSON Query where
2464− parseJSON v = withObject "Query" parse v
2465− where parse o = termQuery `taggedWith` "term"
2466− <|> termsQuery `taggedWith` "terms"
2467− <|> idsQuery `taggedWith` "ids"
2468− <|> queryQueryStringQuery `taggedWith` "query_string"
2469− <|> queryMatchQuery `taggedWith` "match"
2470− <|> queryMultiMatchQuery
2471− <|> queryBoolQuery `taggedWith` "bool"
2472− <|> queryBoostingQuery `taggedWith` "boosting"
2473− <|> queryCommonTermsQuery `taggedWith` "common"
2474− <|> constantScoreFilter `taggedWith` "constant_score"
2475− <|> constantScoreQuery `taggedWith` "constant_score"
2476− <|> queryDisMaxQuery `taggedWith` "dis_max"
2477− <|> queryFilteredQuery `taggedWith` "filtered"
2478− <|> queryFuzzyLikeThisQuery `taggedWith` "fuzzy_like_this"
2479− <|> queryFuzzyLikeFieldQuery `taggedWith` "fuzzy_like_this_field"
2480− <|> queryFuzzyQuery `taggedWith` "fuzzy"
2481− <|> queryHasChildQuery `taggedWith` "has_child"
2482− <|> queryHasParentQuery `taggedWith` "has_parent"
2483− <|> queryIndicesQuery `taggedWith` "indices"
2484− <|> matchAllQuery `taggedWith` "match_all"
2485− <|> queryMoreLikeThisQuery `taggedWith` "more_like_this"
2486− <|> queryMoreLikeThisFieldQuery `taggedWith` "more_like_this_field"
2487− <|> queryNestedQuery `taggedWith` "nested"
2488− <|> queryPrefixQuery `taggedWith` "prefix"
2489− <|> queryRangeQuery `taggedWith` "range"
2490− <|> queryRegexpQuery `taggedWith` "regexp"
2491− <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"
2492− <|> queryTemplateQueryInline `taggedWith` "template"
2493− where taggedWith parser k = parser =<< o .: k
2494− termQuery = fieldTagged $ \(FieldName fn) o ->
2495− TermQuery <$> (Term fn <$> o .: "value") <*> o .:? "boost"
2496− termsQuery o = case HM.toList o of
2497− [(fn, vs)] -> do vals <- parseJSON vs
2498− case vals of
2499− x:xs -> return (TermsQuery fn (x :| xs))
2500− _ -> fail "Expected non empty list of values"
2501− _ -> fail "Expected object with 1 field-named key"
2502− idsQuery o = IdsQuery <$> o .: "type"
2503− <*> o .: "values"
2504− queryQueryStringQuery = pure . QueryQueryStringQuery
2505− queryMatchQuery = pure . QueryMatchQuery
2506− queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v
2507− queryBoolQuery = pure . QueryBoolQuery
2508− queryBoostingQuery = pure . QueryBoostingQuery
2509− queryCommonTermsQuery = pure . QueryCommonTermsQuery
2510− constantScoreFilter o = case HM.lookup "filter" o of
2511− Just x -> ConstantScoreFilter <$> parseJSON x
2512− <*> o .: "boost"
2513− _ -> fail "Does not appear to be a ConstantScoreFilter"
2514− constantScoreQuery o = case HM.lookup "query" o of
2515− Just x -> ConstantScoreQuery <$> parseJSON x
2516− <*> o .: "boost"
2517− _ -> fail "Does not appear to be a ConstantScoreQuery"
2518− queryDisMaxQuery = pure . QueryDisMaxQuery
2519− queryFilteredQuery = pure . QueryFilteredQuery
2520− queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery
2521− queryFuzzyLikeFieldQuery = pure . QueryFuzzyLikeFieldQuery
2522− queryFuzzyQuery = pure . QueryFuzzyQuery
2523− queryHasChildQuery = pure . QueryHasChildQuery
2524− queryHasParentQuery = pure . QueryHasParentQuery
2525− queryIndicesQuery = pure . QueryIndicesQuery
2526− matchAllQuery o = MatchAllQuery <$> o .:? "boost"
2527− queryMoreLikeThisQuery = pure . QueryMoreLikeThisQuery
2528− queryMoreLikeThisFieldQuery = pure . QueryMoreLikeThisFieldQuery
2529− queryNestedQuery = pure . QueryNestedQuery
2530− queryPrefixQuery = pure . QueryPrefixQuery
2531− queryRangeQuery = pure . QueryRangeQuery
2532− queryRegexpQuery = pure . QueryRegexpQuery
2533− querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery
2534− queryTemplateQueryInline = pure . QueryTemplateQueryInline
2535−
2536−
2537−omitNulls :: [(Text, Value)] -> Value
2538−omitNulls = object . filter notNull where
2539− notNull (_, Null) = False
2540− notNull (_, Array a) = (not . V.null) a
2541− notNull _ = True
2542−
2543−
2544−instance ToJSON SimpleQueryStringQuery where
2545− toJSON SimpleQueryStringQuery {..} =
2546− omitNulls (base ++ maybeAdd)
2547− where base = [ "query" .= simpleQueryStringQuery ]
2548− maybeAdd = [ "fields" .= simpleQueryStringField
2549− , "default_operator" .= simpleQueryStringOperator
2550− , "analyzer" .= simpleQueryStringAnalyzer
2551− , "flags" .= simpleQueryStringFlags
2552− , "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded
2553− , "locale" .= simpleQueryStringLocale ]
2554−
2555−instance FromJSON SimpleQueryStringQuery where
2556− parseJSON = withObject "SimpleQueryStringQuery" parse
2557− where parse o = SimpleQueryStringQuery <$> o .: "query"
2558− <*> o .:? "fields"
2559− <*> o .:? "default_operator"
2560− <*> o .:? "analyzer"
2561− <*> (parseFlags <$> o .:? "flags")
2562− <*> o .:? "lowercase_expanded_terms"
2563− <*> o .:? "locale"
2564− parseFlags (Just (x:xs)) = Just (x :| xs)
2565− parseFlags _ = Nothing
2566−
2567−instance ToJSON FieldOrFields where
2568− toJSON (FofField fieldName) =
2569− toJSON fieldName
2570− toJSON (FofFields fieldNames) =
2571− toJSON fieldNames
2572−
2573−instance FromJSON FieldOrFields where
2574− parseJSON v = FofField <$> parseJSON v
2575− <|> FofFields <$> (parseNEJSON =<< parseJSON v)
2576−
2577−instance ToJSON SimpleQueryFlag where
2578− toJSON SimpleQueryAll = "ALL"
2579− toJSON SimpleQueryNone = "NONE"
2580− toJSON SimpleQueryAnd = "AND"
2581− toJSON SimpleQueryOr = "OR"
2582− toJSON SimpleQueryPrefix = "PREFIX"
2583− toJSON SimpleQueryPhrase = "PHRASE"
2584− toJSON SimpleQueryPrecedence = "PRECEDENCE"
2585− toJSON SimpleQueryEscape = "ESCAPE"
2586− toJSON SimpleQueryWhitespace = "WHITESPACE"
2587− toJSON SimpleQueryFuzzy = "FUZZY"
2588− toJSON SimpleQueryNear = "NEAR"
2589− toJSON SimpleQuerySlop = "SLOP"
2590−
2591−instance FromJSON SimpleQueryFlag where
2592− parseJSON = withText "SimpleQueryFlag" parse
2593− where parse "ALL" = pure SimpleQueryAll
2594− parse "NONE" = pure SimpleQueryNone
2595− parse "AND" = pure SimpleQueryAnd
2596− parse "OR" = pure SimpleQueryOr
2597− parse "PREFIX" = pure SimpleQueryPrefix
2598− parse "PHRASE" = pure SimpleQueryPhrase
2599− parse "PRECEDENCE" = pure SimpleQueryPrecedence
2600− parse "ESCAPE" = pure SimpleQueryEscape
2601− parse "WHITESPACE" = pure SimpleQueryWhitespace
2602− parse "FUZZY" = pure SimpleQueryFuzzy
2603− parse "NEAR" = pure SimpleQueryNear
2604− parse "SLOP" = pure SimpleQuerySlop
2605− parse f = fail ("Unexpected SimpleQueryFlag: " <> show f)
2606−
2607−instance ToJSON RegexpQuery where
2608− toJSON (RegexpQuery (FieldName rqQueryField)
2609− (Regexp regexpQueryQuery) rqQueryFlags
2610− rqQueryBoost) =
2611− object [ rqQueryField .= omitNulls base ]
2612− where base = [ "value" .= regexpQueryQuery
2613− , "flags" .= rqQueryFlags
2614− , "boost" .= rqQueryBoost ]
2615−
2616−instance FromJSON RegexpQuery where
2617− parseJSON = withObject "RegexpQuery" parse
2618− where parse = fieldTagged $ \fn o ->
2619− RegexpQuery fn
2620− <$> o .: "value"
2621− <*> o .: "flags"
2622− <*> o .:? "boost"
2623−
2624−instance ToJSON QueryStringQuery where
2625− toJSON (QueryStringQuery qsQueryString
2626− qsDefaultField qsOperator
2627− qsAnalyzer qsAllowWildcard
2628− qsLowercaseExpanded qsEnablePositionIncrements
2629− qsFuzzyMaxExpansions qsFuzziness
2630− qsFuzzyPrefixLength qsPhraseSlop
2631− qsBoost qsAnalyzeWildcard
2632− qsGeneratePhraseQueries qsMinimumShouldMatch
2633− qsLenient qsLocale) =
2634− omitNulls base
2635− where
2636− base = [ "query" .= qsQueryString
2637− , "default_field" .= qsDefaultField
2638− , "default_operator" .= qsOperator
2639− , "analyzer" .= qsAnalyzer
2640− , "allow_leading_wildcard" .= qsAllowWildcard
2641− , "lowercase_expanded_terms" .= qsLowercaseExpanded
2642− , "enable_position_increments" .= qsEnablePositionIncrements
2643− , "fuzzy_max_expansions" .= qsFuzzyMaxExpansions
2644− , "fuzziness" .= qsFuzziness
2645− , "fuzzy_prefix_length" .= qsFuzzyPrefixLength
2646− , "phrase_slop" .= qsPhraseSlop
2647− , "boost" .= qsBoost
2648− , "analyze_wildcard" .= qsAnalyzeWildcard
2649− , "auto_generate_phrase_queries" .= qsGeneratePhraseQueries
2650− , "minimum_should_match" .= qsMinimumShouldMatch
2651− , "lenient" .= qsLenient
2652− , "locale" .= qsLocale ]
2653−
2654−instance FromJSON QueryStringQuery where
2655− parseJSON = withObject "QueryStringQuery" parse
2656− where parse o = QueryStringQuery
2657− <$> o .: "query"
2658− <*> o .:? "default_field"
2659− <*> o .:? "default_operator"
2660− <*> o .:? "analyzer"
2661− <*> o .:? "allow_leading_wildcard"
2662− <*> o .:? "lowercase_expanded_terms"
2663− <*> o .:? "enable_position_increments"
2664− <*> o .:? "fuzzy_max_expansions"
2665− <*> o .:? "fuzziness"
2666− <*> o .:? "fuzzy_prefix_length"
2667− <*> o .:? "phrase_slop"
2668− <*> o .:? "boost"
2669− <*> o .:? "analyze_wildcard"
2670− <*> o .:? "auto_generate_phrase_queries"
2671− <*> o .:? "minimum_should_match"
2672− <*> o .:? "lenient"
2673− <*> o .:? "locale"
2674−
2675−instance ToJSON RangeQuery where
2676− toJSON (RangeQuery (FieldName fieldName) range boost) =
2677− object [ fieldName .= object conjoined ]
2678− where conjoined = [ "boost" .= boost ] ++ (rangeValueToPair range)
2679−
2680−instance FromJSON RangeQuery where
2681− parseJSON = withObject "RangeQuery" parse
2682− where parse = fieldTagged $ \fn o ->
2683− RangeQuery fn
2684− <$> parseJSON (Object o)
2685− <*> o .: "boost"
2686−
2687−instance FromJSON RangeValue where
2688− parseJSON = withObject "RangeValue" parse
2689− where parse o = parseDate o
2690− <|> parseDouble o
2691− parseDate o = do lt <- o .:? "lt"
2692− lte <- o .:? "lte"
2693− gt <- o .:? "gt"
2694− gte <- o .:? "gte"
2695− case (lt, lte, gt, gte) of
2696− (Just a, _, Just b, _) -> return (RangeDateGtLt (GreaterThanD b) (LessThanD a))
2697− (Just a, _, _, Just b)-> return (RangeDateGteLt (GreaterThanEqD b) (LessThanD a))
2698− (_, Just a, Just b, _)-> return (RangeDateGtLte (GreaterThanD b) (LessThanEqD a))
2699− (_, Just a, _, Just b)-> return (RangeDateGteLte (GreaterThanEqD b) (LessThanEqD a))
2700− (_, _, Just a, _)-> return (RangeDateGt (GreaterThanD a))
2701− (Just a, _, _, _)-> return (RangeDateLt (LessThanD a))
2702− (_, _, _, Just a)-> return (RangeDateGte (GreaterThanEqD a))
2703− (_, Just a, _, _)-> return (RangeDateLte (LessThanEqD a))
2704− (Nothing, Nothing, Nothing, Nothing) -> mzero
2705− parseDouble o = do lt <- o .:? "lt"
2706− lte <- o .:? "lte"
2707− gt <- o .:? "gt"
2708− gte <- o .:? "gte"
2709− case (lt, lte, gt, gte) of
2710− (Just a, _, Just b, _) -> return (RangeDoubleGtLt (GreaterThan b) (LessThan a))
2711− (Just a, _, _, Just b)-> return (RangeDoubleGteLt (GreaterThanEq b) (LessThan a))
2712− (_, Just a, Just b, _)-> return (RangeDoubleGtLte (GreaterThan b) (LessThanEq a))
2713− (_, Just a, _, Just b)-> return (RangeDoubleGteLte (GreaterThanEq b) (LessThanEq a))
2714− (_, _, Just a, _)-> return (RangeDoubleGt (GreaterThan a))
2715− (Just a, _, _, _)-> return (RangeDoubleLt (LessThan a))
2716− (_, _, _, Just a)-> return (RangeDoubleGte (GreaterThanEq a))
2717− (_, Just a, _, _)-> return (RangeDoubleLte (LessThanEq a))
2718− (Nothing, Nothing, Nothing, Nothing) -> mzero
2719−
2720−instance ToJSON PrefixQuery where
2721− toJSON (PrefixQuery (FieldName fieldName) queryValue boost) =
2722− object [ fieldName .= omitNulls base ]
2723− where base = [ "value" .= queryValue
2724− , "boost" .= boost ]
2725−
2726−instance FromJSON PrefixQuery where
2727− parseJSON = withObject "PrefixQuery" parse
2728− where parse = fieldTagged $ \fn o ->
2729− PrefixQuery fn
2730− <$> o .: "value"
2731− <*> o .:? "boost"
2732−
2733−instance ToJSON NestedQuery where
2734− toJSON (NestedQuery nqPath nqScoreType nqQuery) =
2735− object [ "path" .= nqPath
2736− , "score_mode" .= nqScoreType
2737− , "query" .= nqQuery ]
2738−
2739−instance FromJSON NestedQuery where
2740− parseJSON = withObject "NestedQuery" parse
2741− where parse o = NestedQuery
2742− <$> o .: "path"
2743− <*> o .: "score_mode"
2744− <*> o .: "query"
2745−
2746−instance ToJSON MoreLikeThisFieldQuery where
2747− toJSON (MoreLikeThisFieldQuery text (FieldName fieldName)
2748− percent mtf mqt stopwords mindf maxdf
2749− minwl maxwl boostTerms boost analyzer) =
2750− object [ fieldName .= omitNulls base ]
2751− where base = [ "like_text" .= text
2752− , "percent_terms_to_match" .= percent
2753− , "min_term_freq" .= mtf
2754− , "max_query_terms" .= mqt
2755− , "stop_words" .= stopwords
2756− , "min_doc_freq" .= mindf
2757− , "max_doc_freq" .= maxdf
2758− , "min_word_length" .= minwl
2759− , "max_word_length" .= maxwl
2760− , "boost_terms" .= boostTerms
2761− , "boost" .= boost
2762− , "analyzer" .= analyzer ]
2763−
2764−instance FromJSON MoreLikeThisFieldQuery where
2765− parseJSON = withObject "MoreLikeThisFieldQuery" parse
2766− where parse = fieldTagged $ \fn o ->
2767− MoreLikeThisFieldQuery
2768− <$> o .: "like_text"
2769− <*> pure fn
2770− <*> o .:? "percent_terms_to_match"
2771− <*> o .:? "min_term_freq"
2772− <*> o .:? "max_query_terms"
2773− -- <*> (optionalNE =<< o .:? "stop_words")
2774− <*> o .:? "stop_words"
2775− <*> o .:? "min_doc_freq"
2776− <*> o .:? "max_doc_freq"
2777− <*> o .:? "min_word_length"
2778− <*> o .:? "max_word_length"
2779− <*> o .:? "boost_terms"
2780− <*> o .:? "boost"
2781− <*> o .:? "analyzer"
2782− -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)
2783−
2784−instance ToJSON MoreLikeThisQuery where
2785− toJSON (MoreLikeThisQuery text fields percent
2786− mtf mqt stopwords mindf maxdf
2787− minwl maxwl boostTerms boost analyzer) =
2788− omitNulls base
2789− where base = [ "like_text" .= text
2790− , "fields" .= fields
2791− , "percent_terms_to_match" .= percent
2792− , "min_term_freq" .= mtf
2793− , "max_query_terms" .= mqt
2794− , "stop_words" .= stopwords
2795− , "min_doc_freq" .= mindf
2796− , "max_doc_freq" .= maxdf
2797− , "min_word_length" .= minwl
2798− , "max_word_length" .= maxwl
2799− , "boost_terms" .= boostTerms
2800− , "boost" .= boost
2801− , "analyzer" .= analyzer ]
2802−
2803−instance FromJSON MoreLikeThisQuery where
2804− parseJSON = withObject "MoreLikeThisQuery" parse
2805− where parse o = MoreLikeThisQuery
2806− <$> o .: "like_text"
2807− -- <*> (optionalNE =<< o .:? "fields")
2808− <*> o .:? "fields"
2809− <*> o .:? "percent_terms_to_match"
2810− <*> o .:? "min_term_freq"
2811− <*> o .:? "max_query_terms"
2812− -- <*> (optionalNE =<< o .:? "stop_words")
2813− <*> o .:? "stop_words"
2814− <*> o .:? "min_doc_freq"
2815− <*> o .:? "max_doc_freq"
2816− <*> o .:? "min_word_length"
2817− <*> o .:? "max_word_length"
2818− <*> o .:? "boost_terms"
2819− <*> o .:? "boost"
2820− <*> o .:? "analyzer"
2821− -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)
2822−
2823−instance ToJSON IndicesQuery where
2824− toJSON (IndicesQuery indices query noMatch) =
2825− omitNulls [ "indices" .= indices
2826− , "no_match_query" .= noMatch
2827− , "query" .= query ]
2828−
2829−instance FromJSON IndicesQuery where
2830− parseJSON = withObject "IndicesQuery" parse
2831− where parse o = IndicesQuery
2832− <$> o .:? "indices" .!= []
2833− <*> o .: "query"
2834− <*> o .:? "no_match_query"
2835−
2836−instance ToJSON HasParentQuery where
2837− toJSON (HasParentQuery queryType query scoreType) =
2838− omitNulls [ "parent_type" .= queryType
2839− , "score_type" .= scoreType
2840− , "query" .= query ]
2841−
2842−instance FromJSON HasParentQuery where
2843− parseJSON = withObject "HasParentQuery" parse
2844− where parse o = HasParentQuery
2845− <$> o .: "parent_type"
2846− <*> o .: "query"
2847− <*> o .:? "score_type"
2848−
2849−instance ToJSON HasChildQuery where
2850− toJSON (HasChildQuery queryType query scoreType) =
2851− omitNulls [ "query" .= query
2852− , "score_type" .= scoreType
2853− , "type" .= queryType ]
2854−
2855−instance FromJSON HasChildQuery where
2856− parseJSON = withObject "HasChildQuery" parse
2857− where parse o = HasChildQuery
2858− <$> o .: "type"
2859− <*> o .: "query"
2860− <*> o .:? "score_type"
2861−
2862−instance ToJSON FuzzyQuery where
2863− toJSON (FuzzyQuery (FieldName fieldName) queryText
2864− prefixLength maxEx fuzziness boost) =
2865− object [ fieldName .= omitNulls base ]
2866− where base = [ "value" .= queryText
2867− , "fuzziness" .= fuzziness
2868− , "prefix_length" .= prefixLength
2869− , "boost" .= boost
2870− , "max_expansions" .= maxEx ]
2871−
2872−instance FromJSON FuzzyQuery where
2873− parseJSON = withObject "FuzzyQuery" parse
2874− where parse = fieldTagged $ \fn o ->
2875− FuzzyQuery fn
2876− <$> o .: "value"
2877− <*> o .: "prefix_length"
2878− <*> o .: "max_expansions"
2879− <*> o .: "fuzziness"
2880− <*> o .:? "boost"
2881−
2882−instance ToJSON FuzzyLikeFieldQuery where
2883− toJSON (FuzzyLikeFieldQuery (FieldName fieldName)
2884− fieldText maxTerms ignoreFreq fuzziness prefixLength
2885− boost analyzer) =
2886− object [ fieldName .=
2887− omitNulls [ "like_text" .= fieldText
2888− , "max_query_terms" .= maxTerms
2889− , "ignore_tf" .= ignoreFreq
2890− , "fuzziness" .= fuzziness
2891− , "prefix_length" .= prefixLength
2892− , "analyzer" .= analyzer
2893− , "boost" .= boost ]]
2894−
2895−instance FromJSON FuzzyLikeFieldQuery where
2896− parseJSON = withObject "FuzzyLikeFieldQuery" parse
2897− where parse = fieldTagged $ \fn o ->
2898− FuzzyLikeFieldQuery fn
2899− <$> o .: "like_text"
2900− <*> o .: "max_query_terms"
2901− <*> o .: "ignore_tf"
2902− <*> o .: "fuzziness"
2903− <*> o .: "prefix_length"
2904− <*> o .: "boost"
2905− <*> o .:? "analyzer"
2906−
2907−instance ToJSON FuzzyLikeThisQuery where
2908− toJSON (FuzzyLikeThisQuery fields text maxTerms
2909− ignoreFreq fuzziness prefixLength boost analyzer) =
2910− omitNulls base
2911− where base = [ "fields" .= fields
2912− , "like_text" .= text
2913− , "max_query_terms" .= maxTerms
2914− , "ignore_tf" .= ignoreFreq
2915− , "fuzziness" .= fuzziness
2916− , "prefix_length" .= prefixLength
2917− , "analyzer" .= analyzer
2918− , "boost" .= boost ]
2919−
2920−instance FromJSON FuzzyLikeThisQuery where
2921− parseJSON = withObject "FuzzyLikeThisQuery" parse
2922− where parse o = FuzzyLikeThisQuery
2923− <$> o .:? "fields" .!= []
2924− <*> o .: "like_text"
2925− <*> o .: "max_query_terms"
2926− <*> o .: "ignore_tf"
2927− <*> o .: "fuzziness"
2928− <*> o .: "prefix_length"
2929− <*> o .: "boost"
2930− <*> o .:? "analyzer"
2931−
2932−instance ToJSON FilteredQuery where
2933− toJSON (FilteredQuery query fFilter) =
2934− object [ "query" .= query
2935− , "filter" .= fFilter ]
2936−
2937−instance FromJSON FilteredQuery where
2938− parseJSON = withObject "FilteredQuery" parse
2939− where parse o = FilteredQuery
2940− <$> o .: "query"
2941− <*> o .: "filter"
2942−
2943−instance ToJSON DisMaxQuery where
2944− toJSON (DisMaxQuery queries tiebreaker boost) =
2945− omitNulls base
2946− where base = [ "queries" .= queries
2947− , "boost" .= boost
2948− , "tie_breaker" .= tiebreaker ]
2949−
2950−instance FromJSON DisMaxQuery where
2951− parseJSON = withObject "DisMaxQuery" parse
2952− where parse o = DisMaxQuery
2953− <$> o .:? "queries" .!= []
2954− <*> o .: "tie_breaker"
2955− <*> o .:? "boost"
2956−
2957−instance ToJSON CommonTermsQuery where
2958− toJSON (CommonTermsQuery (FieldName fieldName)
2959− (QueryString query) cf lfo hfo msm
2960− boost analyzer disableCoord) =
2961− object [fieldName .= omitNulls base ]
2962− where base = [ "query" .= query
2963− , "cutoff_frequency" .= cf
2964− , "low_freq_operator" .= lfo
2965− , "minimum_should_match" .= msm
2966− , "boost" .= boost
2967− , "analyzer" .= analyzer
2968− , "disable_coord" .= disableCoord
2969− , "high_freq_operator" .= hfo ]
2970−
2971−instance FromJSON CommonTermsQuery where
2972− parseJSON = withObject "CommonTermsQuery" parse
2973− where parse = fieldTagged $ \fn o ->
2974− CommonTermsQuery fn
2975− <$> o .: "query"
2976− <*> o .: "cutoff_frequency"
2977− <*> o .: "low_freq_operator"
2978− <*> o .: "high_freq_operator"
2979− <*> o .:? "minimum_should_match"
2980− <*> o .:? "boost"
2981− <*> o .:? "analyzer"
2982− <*> o .:? "disable_coord"
2983−
2984−instance ToJSON CommonMinimumMatch where
2985− toJSON (CommonMinimumMatch mm) = toJSON mm
2986− toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) =
2987− object [ "low_freq" .= lowF
2988− , "high_freq" .= highF ]
2989−
2990−instance FromJSON CommonMinimumMatch where
2991− parseJSON v = parseMinimum v
2992− <|> parseMinimumHighLow v
2993− where parseMinimum = fmap CommonMinimumMatch . parseJSON
2994− parseMinimumHighLow = fmap CommonMinimumMatchHighLow . withObject "CommonMinimumMatchHighLow" (\o ->
2995− MinimumMatchHighLow
2996− <$> o .: "low_freq"
2997− <*> o .: "high_freq")
2998−
2999−
3000−instance ToJSON BoostingQuery where
3001− toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) =
3002− object [ "positive" .= bqPositiveQuery
3003− , "negative" .= bqNegativeQuery
3004− , "negative_boost" .= bqNegativeBoost ]
3005−
3006−instance FromJSON BoostingQuery where
3007− parseJSON = withObject "BoostingQuery" parse
3008− where parse o = BoostingQuery
3009− <$> o .: "positive"
3010− <*> o .: "negative"
3011− <*> o .: "negative_boost"
3012−
3013−instance ToJSON BoolQuery where
3014− toJSON (BoolQuery mustM notM shouldM bqMin boost disableCoord) =
3015− omitNulls base
3016− where base = [ "must" .= mustM
3017− , "must_not" .= notM
3018− , "should" .= shouldM
3019− , "minimum_should_match" .= bqMin
3020− , "boost" .= boost
3021− , "disable_coord" .= disableCoord ]
3022−
3023−instance FromJSON BoolQuery where
3024− parseJSON = withObject "BoolQuery" parse
3025− where parse o = BoolQuery
3026− <$> o .:? "must" .!= []
3027− <*> o .:? "must_not" .!= []
3028− <*> o .:? "should" .!= []
3029− <*> o .:? "minimum_should_match"
3030− <*> o .:? "boost"
3031− <*> o .:? "disable_coord"
3032−
3033−instance ToJSON MatchQuery where
3034− toJSON (MatchQuery (FieldName fieldName)
3035− (QueryString mqQueryString) booleanOperator
3036− zeroTermsQuery cutoffFrequency matchQueryType
3037− analyzer maxExpansions lenient boost) =
3038− object [ fieldName .= omitNulls base ]
3039− where base = [ "query" .= mqQueryString
3040− , "operator" .= booleanOperator
3041− , "zero_terms_query" .= zeroTermsQuery
3042− , "cutoff_frequency" .= cutoffFrequency
3043− , "type" .= matchQueryType
3044− , "analyzer" .= analyzer
3045− , "max_expansions" .= maxExpansions
3046− , "lenient" .= lenient
3047− , "boost" .= boost ]
3048−
3049−instance FromJSON MatchQuery where
3050− parseJSON = withObject "MatchQuery" parse
3051− where parse = fieldTagged $ \fn o ->
3052− MatchQuery fn
3053− <$> o .: "query"
3054− <*> o .: "operator"
3055− <*> o .: "zero_terms_query"
3056− <*> o .:? "cutoff_frequency"
3057− <*> o .:? "type"
3058− <*> o .:? "analyzer"
3059− <*> o .:? "max_expansions"
3060− <*> o .:? "lenient"
3061− <*> o .:? "boost"
3062−
3063−instance ToJSON MultiMatchQuery where
3064− toJSON (MultiMatchQuery fields (QueryString query) boolOp
3065− ztQ tb mmqt cf analyzer maxEx lenient) =
3066− object ["multi_match" .= omitNulls base]
3067− where base = [ "fields" .= fmap toJSON fields
3068− , "query" .= query
3069− , "operator" .= boolOp
3070− , "zero_terms_query" .= ztQ
3071− , "tie_breaker" .= tb
3072− , "type" .= mmqt
3073− , "cutoff_frequency" .= cf
3074− , "analyzer" .= analyzer
3075− , "max_expansions" .= maxEx
3076− , "lenient" .= lenient ]
3077−
3078−instance FromJSON MultiMatchQuery where
3079− parseJSON = withObject "MultiMatchQuery" parse
3080− where parse raw = do o <- raw .: "multi_match"
3081− MultiMatchQuery
3082− <$> o .:? "fields" .!= []
3083− <*> o .: "query"
3084− <*> o .: "operator"
3085− <*> o .: "zero_terms_query"
3086− <*> o .:? "tie_breaker"
3087− <*> o .:? "type"
3088− <*> o .:? "cutoff_frequency"
3089− <*> o .:? "analyzer"
3090− <*> o .:? "max_expansions"
3091− <*> o .:? "lenient"
3092−
3093−instance ToJSON MultiMatchQueryType where
3094− toJSON MultiMatchBestFields = "best_fields"
3095− toJSON MultiMatchMostFields = "most_fields"
3096− toJSON MultiMatchCrossFields = "cross_fields"
3097− toJSON MultiMatchPhrase = "phrase"
3098− toJSON MultiMatchPhrasePrefix = "phrase_prefix"
3099−
3100−instance FromJSON MultiMatchQueryType where
3101− parseJSON = withText "MultiMatchPhrasePrefix" parse
3102− where parse "best_fields" = pure MultiMatchBestFields
3103− parse "most_fields" = pure MultiMatchMostFields
3104− parse "cross_fields" = pure MultiMatchCrossFields
3105− parse "phrase" = pure MultiMatchPhrase
3106− parse "phrase_prefix" = pure MultiMatchPhrasePrefix
3107− parse t = fail ("Unexpected MultiMatchPhrasePrefix: " <> show t)
3108−
3109−instance ToJSON BooleanOperator where
3110− toJSON And = String "and"
3111− toJSON Or = String "or"
3112−
3113−instance FromJSON BooleanOperator where
3114− parseJSON = withText "BooleanOperator" parse
3115− where parse "and" = pure And
3116− parse "or" = pure Or
3117− parse o = fail ("Unexpected BooleanOperator: " <> show o)
3118−
3119−instance ToJSON ZeroTermsQuery where
3120− toJSON ZeroTermsNone = String "none"
3121− toJSON ZeroTermsAll = String "all"
3122−
3123−instance FromJSON ZeroTermsQuery where
3124− parseJSON = withText "ZeroTermsQuery" parse
3125− where parse "none" = pure ZeroTermsNone
3126− parse "all" = pure ZeroTermsAll
3127− parse q = fail ("Unexpected ZeroTermsQuery: " <> show q)
3128−
3129−instance ToJSON MatchQueryType where
3130− toJSON MatchPhrase = "phrase"
3131− toJSON MatchPhrasePrefix = "phrase_prefix"
3132−
3133−instance FromJSON MatchQueryType where
3134− parseJSON = withText "MatchQueryType" parse
3135− where parse "phrase" = pure MatchPhrase
3136− parse "phrase_prefix" = pure MatchPhrasePrefix
3137− parse t = fail ("Unexpected MatchQueryType: " <> show t)
3138−
3139−instance FromJSON Status where
3140− parseJSON (Object v) = Status <$>
3141− v .:? "ok" <*>
3142− (v .:? "status" .!= 200) <*>
3143− v .: "name" <*>
3144− v .: "version" <*>
3145− v .: "tagline"
3146− parseJSON _ = empty
3147−
3148−
3149−instance ToJSON IndexSettings where
3150− toJSON (IndexSettings s r) = object ["settings" .=
3151− object ["index" .=
3152− object ["number_of_shards" .= s, "number_of_replicas" .= r]
3153− ]
3154− ]
3155−
3156−instance FromJSON IndexSettings where
3157− parseJSON = withObject "IndexSettings" parse
3158− where parse o = do s <- o .: "settings"
3159− i <- s .: "index"
3160− IndexSettings <$> i .: "number_of_shards"
3161− <*> i .: "number_of_replicas"
3162−
3163−instance ToJSON UpdatableIndexSetting where
3164− toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x
3165− toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x
3166− toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x)
3167− toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x
3168− toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x
3169− toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x
3170− toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x
3171− toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x)
3172− toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x
3173− toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x
3174− toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x)
3175− toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x)
3176− toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs)
3177− toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs)
3178− toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs)
3179− toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x
3180− toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x
3181− toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x
3182− toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x)
3183− toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x
3184− toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x
3185− toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x
3186− toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x
3187− toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x
3188− toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x
3189− toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x
3190− toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x
3191− toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x
3192−
3193−instance FromJSON UpdatableIndexSetting where
3194− parseJSON = withObject "UpdatableIndexSetting" parse
3195− where parse o = numberOfReplicas `taggedAt` ["index", "number_of_replicas"]
3196− <|> autoExpandReplicas `taggedAt` ["index", "auto_expand_replicas"]
3197− <|> refreshInterval `taggedAt` ["index", "refresh_interval"]
3198− <|> indexConcurrency `taggedAt` ["index", "concurrency"]
3199− <|> failOnMergeFailure `taggedAt` ["index", "fail_on_merge_failure"]
3200− <|> translogFlushThresholdOps `taggedAt` ["index", "translog", "flush_threshold_ops"]
3201− <|> translogFlushThresholdSize `taggedAt` ["index", "translog", "flush_threshold_size"]
3202− <|> translogFlushThresholdPeriod `taggedAt` ["index", "translog", "flush_threshold_period"]
3203− <|> translogDisableFlush `taggedAt` ["index", "translog", "disable_flush"]
3204− <|> cacheFilterMaxSize `taggedAt` ["index", "cache", "filter", "max_size"]
3205− <|> cacheFilterExpire `taggedAt` ["index", "cache", "filter", "expire"]
3206− <|> gatewaySnapshotInterval `taggedAt` ["index", "gateway", "snapshot_interval"]
3207− <|> routingAllocationInclude `taggedAt` ["index", "routing", "allocation", "include"]
3208− <|> routingAllocationExclude `taggedAt` ["index", "routing", "allocation", "exclude"]
3209− <|> routingAllocationRequire `taggedAt` ["index", "routing", "allocation", "require"]
3210− <|> routingAllocationEnable `taggedAt` ["index", "routing", "allocation", "enable"]
3211− <|> routingAllocationShardsPerNode `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"]
3212− <|> recoveryInitialShards `taggedAt` ["index", "recovery", "initial_shards"]
3213− <|> gcDeletes `taggedAt` ["index", "gc_deletes"]
3214− <|> ttlDisablePurge `taggedAt` ["index", "ttl", "disable_purge"]
3215− <|> translogFSType `taggedAt` ["index", "translog", "fs", "type"]
3216− <|> compoundFormat `taggedAt` ["index", "compound_format"]
3217− <|> compoundOnFlush `taggedAt` ["index", "compound_on_flush"]
3218− <|> warmerEnabled `taggedAt` ["index", "warmer", "enabled"]
3219− <|> blocksReadOnly `taggedAt` ["blocks", "read_only"]
3220− <|> blocksRead `taggedAt` ["blocks", "read"]
3221− <|> blocksWrite `taggedAt` ["blocks", "write"]
3222− <|> blocksMetaData `taggedAt` ["blocks", "metadata"]
3223− where taggedAt f ks = taggedAt' f (Object o) ks
3224− taggedAt' f v [] = f =<< (parseJSON v <|> (parseJSON (unStringlyTypeJSON v)))
3225− taggedAt' f v (k:ks) = withObject "Object" (\o -> do v' <- o .: k
3226− taggedAt' f v' ks) v
3227− numberOfReplicas = pure . NumberOfReplicas
3228− autoExpandReplicas = pure . AutoExpandReplicas
3229− refreshInterval = pure . RefreshInterval . ndtJSON
3230− indexConcurrency = pure . IndexConcurrency
3231− failOnMergeFailure = pure . FailOnMergeFailure
3232− translogFlushThresholdOps = pure . TranslogFlushThresholdOps
3233− translogFlushThresholdSize = pure . TranslogFlushThresholdSize
3234− translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON
3235− translogDisableFlush = pure . TranslogDisableFlush
3236− cacheFilterMaxSize = pure . CacheFilterMaxSize
3237− cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON
3238− gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON
3239− routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter
3240− routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter
3241− routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter
3242− routingAllocationEnable = pure . RoutingAllocationEnable
3243− routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode
3244− recoveryInitialShards = pure . RecoveryInitialShards
3245− gcDeletes = pure . GCDeletes . ndtJSON
3246− ttlDisablePurge = pure . TTLDisablePurge
3247− translogFSType = pure . TranslogFSType
3248− compoundFormat = pure . IndexCompoundFormat
3249− compoundOnFlush = pure . IndexCompoundOnFlush
3250− warmerEnabled = pure . WarmerEnabled
3251− blocksReadOnly = pure . BlocksReadOnly
3252− blocksRead = pure . BlocksRead
3253− blocksWrite = pure . BlocksWrite
3254− blocksMetaData = pure . BlocksMetaData
3255−
3256−instance FromJSON IndexSettingsSummary where
3257− parseJSON = withObject "IndexSettingsSummary" parse
3258− where parse o = case HM.toList o of
3259− [(ixn, v@(Object o'))] -> IndexSettingsSummary (IndexName ixn)
3260− <$> parseJSON v
3261− <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")
3262− _ -> fail "Expected single-key object with index name"
3263− redundant (NumberOfReplicas _) = True
3264− redundant _ = False
3265−
3266−-- | For some reason in several settings APIs, all leaf values get returned
3267−-- as strings. This function attepmts to recover from this for all
3268−-- non-recursive JSON types. If nothing can be done, the value is left alone.
3269−unStringlyTypeJSON :: Value -> Value
3270−unStringlyTypeJSON (String "true") = Bool True
3271−unStringlyTypeJSON (String "false") = Bool False
3272−unStringlyTypeJSON (String "null") = Null
3273−unStringlyTypeJSON v@(String t) = case readMay (T.unpack t) of
3274− Just n -> Number n
3275− Nothing -> v
3276−unStringlyTypeJSON v = v
3277−
3278−
3279−parseSettings :: Object -> Parser [UpdatableIndexSetting]
3280−parseSettings o = do
3281− o' <- o .: "index"
3282− -- slice the index object into singleton hashmaps and try to parse each
3283− parses <- forM (HM.toList o') $ \(k, v) -> do
3284− -- blocks are now nested into the "index" key, which is not how they're serialized
3285− let atRoot = Object (HM.singleton k v)
3286− let atIndex = Object (HM.singleton "index" atRoot)
3287− optional (parseJSON atRoot <|> parseJSON atIndex)
3288− return (catMaybes parses)
3289−
3290−oPath :: ToJSON a => NonEmpty Text -> a -> Value
3291−oPath (k :| []) v = object [k .= v]
3292−oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]
3293−
3294−attrFilterJSON :: NonEmpty NodeAttrFilter -> Value
3295−attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)
3296− | NodeAttrFilter (NodeAttrName n) vs <- toList fs]
3297−
3298−parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)
3299−parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse
3300− where parse o = case HM.toList o of
3301− [] -> fail "Expected non-empty list of NodeAttrFilters"
3302− x:xs -> DT.mapM (uncurry parse') (x :| xs)
3303− parse' n = withText "Text" $ \t ->
3304− case T.splitOn "," t of
3305− fv:fvs -> return (NodeAttrFilter (NodeAttrName n) (fv :| fvs))
3306− [] -> fail "Expected non-empty list of filter values"
3307−
3308−instance ToJSON ReplicaBounds where
3309− toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b)
3310− toJSON (ReplicasLowerBounded a) = String (showText a <> "-all")
3311− toJSON ReplicasUnbounded = Bool False
3312−
3313−instance FromJSON ReplicaBounds where
3314− parseJSON v = withText "ReplicaBounds" parseText v
3315− <|> withBool "ReplicaBounds" parseBool v
3316− where parseText t = case T.splitOn "-" t of
3317− [a, "all"] -> ReplicasLowerBounded <$> parseReadText a
3318− [a, b] -> ReplicasBounded <$> parseReadText a
3319− <*> parseReadText b
3320− _ -> fail ("Could not parse ReplicaBounds: " <> show t)
3321− parseBool False = pure ReplicasUnbounded
3322− parseBool _ = fail "ReplicasUnbounded cannot be represented with True"
3323−
3324−instance ToJSON AllocationPolicy where
3325− toJSON AllocAll = String "all"
3326− toJSON AllocPrimaries = String "primaries"
3327− toJSON AllocNewPrimaries = String "new_primaries"
3328− toJSON AllocNone = String "none"
3329−
3330−instance FromJSON AllocationPolicy where
3331− parseJSON = withText "AllocationPolicy" parse
3332− where parse "all" = pure AllocAll
3333− parse "primaries" = pure AllocPrimaries
3334− parse "new_primaries" = pure AllocNewPrimaries
3335− parse "none" = pure AllocNone
3336− parse t = fail ("Invlaid AllocationPolicy: " <> show t)
3337−
3338−instance ToJSON InitialShardCount where
3339− toJSON QuorumShards = String "quorum"
3340− toJSON QuorumMinus1Shards = String "quorum-1"
3341− toJSON FullShards = String "full"
3342− toJSON FullMinus1Shards = String "full-1"
3343− toJSON (ExplicitShards x) = toJSON x
3344−
3345−instance FromJSON InitialShardCount where
3346− parseJSON v = withText "InitialShardCount" parseText v
3347− <|> ExplicitShards <$> parseJSON v
3348− where parseText "quorum" = pure QuorumShards
3349− parseText "quorum-1" = pure QuorumMinus1Shards
3350− parseText "full" = pure FullShards
3351− parseText "full-1" = pure FullMinus1Shards
3352− parseText _ = mzero
3353−
3354−instance ToJSON FSType where
3355− toJSON FSSimple = "simple"
3356− toJSON FSBuffered = "buffered"
3357−
3358−instance FromJSON FSType where
3359− parseJSON = withText "FSType" parse
3360− where parse "simple" = pure FSSimple
3361− parse "buffered" = pure FSBuffered
3362− parse t = fail ("Invalid FSType: " <> show t)
3363−
3364−instance ToJSON CompoundFormat where
3365− toJSON (CompoundFileFormat x) = Bool x
3366− toJSON (MergeSegmentVsTotalIndex x) = toJSON x
3367−
3368−instance FromJSON CompoundFormat where
3369− parseJSON v = CompoundFileFormat <$> parseJSON v
3370− <|> MergeSegmentVsTotalIndex <$> parseJSON v
3371−
3372−instance ToJSON NominalDiffTimeJSON where
3373− toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s")
3374−
3375−instance FromJSON NominalDiffTimeJSON where
3376− parseJSON = withText "NominalDiffTime" parse
3377− where parse t = case T.takeEnd 1 t of
3378− "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t)
3379− _ -> fail "Invalid or missing NominalDiffTime unit (expected s)"
3380−
3381−instance ToJSON IndexTemplate where
3382− toJSON (IndexTemplate p s m) = merge
3383− (object [ "template" .= p
3384− , "mappings" .= foldl' merge (object []) m
3385− ])
3386− (toJSON s)
3387− where
3388− merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2
3389− merge o Null = o
3390− merge _ _ = undefined
3391−
3392−instance (FromJSON a) => FromJSON (EsResult a) where
3393− parseJSON jsonVal@(Object v) = do
3394− found <- v .:? "found" .!= False
3395− fr <- if found
3396− then parseJSON jsonVal
3397− else return Nothing
3398− EsResult <$> v .: "_index" <*>
3399− v .: "_type" <*>
3400− v .: "_id" <*>
3401− pure fr
3402− parseJSON _ = empty
3403−
3404−instance (FromJSON a) => FromJSON (EsResultFound a) where
3405− parseJSON (Object v) = EsResultFound <$>
3406− v .: "_version" <*>
3407− v .: "_source"
3408− parseJSON _ = empty
3409−
3410−instance FromJSON EsError where
3411− parseJSON (Object v) = EsError <$>
3412− v .: "status" <*>
3413− (v .: "error" <|> (v .: "error" >>= (.: "reason")))
3414− parseJSON _ = empty
3415−
3416−instance FromJSON IndexAliasesSummary where
3417− parseJSON = withObject "IndexAliasesSummary" parse
3418− where parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (HM.toList o)
3419− go ixn = withObject "index aliases" $ \ia -> do
3420− aliases <- ia .:? "aliases" .!= mempty
3421− forM (HM.toList aliases) $ \(aName, v) -> do
3422− let indexAlias = IndexAlias (IndexName ixn) (IndexAliasName (IndexName aName))
3423− IndexAliasSummary indexAlias <$> parseJSON v
3424−
3425−
3426−instance ToJSON IndexAliasAction where
3427− toJSON (AddAlias ia opts) = object ["add" .= (iaObj <> optsObj)]
3428− where Object iaObj = toJSON ia
3429− Object optsObj = toJSON opts
3430− toJSON (RemoveAlias ia) = object ["remove" .= iaObj]
3431− where Object iaObj = toJSON ia
3432−
3433−instance ToJSON IndexAlias where
3434− toJSON IndexAlias {..} = object ["index" .= srcIndex
3435− , "alias" .= indexAlias
3436− ]
3437−
3438−instance ToJSON IndexAliasCreate where
3439− toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj)
3440− where filterObj = maybe mempty (HM.singleton "filter" . toJSON) aliasCreateFilter
3441− Object routingObj = maybe (Object mempty) toJSON aliasCreateRouting
3442−
3443−instance ToJSON AliasRouting where
3444− toJSON (AllAliasRouting v) = object ["routing" .= v]
3445− toJSON (GranularAliasRouting srch idx) = object (catMaybes prs)
3446− where prs = [("search_routing" .=) <$> srch
3447− ,("index_routing" .=) <$> idx]
3448−
3449−instance FromJSON AliasRouting where
3450− parseJSON = withObject "AliasRouting" parse
3451− where parse o = parseAll o <|> parseGranular o
3452− parseAll o = AllAliasRouting <$> o .: "routing"
3453− parseGranular o = do
3454− sr <- o .:? "search_routing"
3455− ir <- o .:? "index_routing"
3456− if isNothing sr && isNothing ir
3457− then fail "Both search_routing and index_routing can't be blank"
3458− else return (GranularAliasRouting sr ir)
3459−
3460−instance FromJSON IndexAliasCreate where
3461− parseJSON v = withObject "IndexAliasCreate" parse v
3462− where parse o = IndexAliasCreate <$> optional (parseJSON v)
3463− <*> o .:? "filter"
3464−
3465−instance ToJSON SearchAliasRouting where
3466− toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs))
3467−
3468−instance FromJSON SearchAliasRouting where
3469− parseJSON = withText "SearchAliasRouting" parse
3470− where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)
3471−
3472−instance ToJSON Search where
3473− toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _ sFields sSource sSuggest) =
3474− omitNulls [ "query" .= query
3475− , "filter" .= sFilter
3476− , "sort" .= sort
3477− , "aggregations" .= searchAggs
3478− , "highlight" .= highlight
3479− , "from" .= sFrom
3480− , "size" .= sSize
3481− , "track_scores" .= sTrackSortScores
3482− , "fields" .= sFields
3483− , "_source" .= sSource
3484− , "suggest" .= sSuggest]
3485−
3486−
3487−instance ToJSON Source where
3488− toJSON NoSource = toJSON False
3489− toJSON (SourcePatterns patterns) = toJSON patterns
3490− toJSON (SourceIncludeExclude incl excl) = object [ "include" .= incl, "exclude" .= excl ]
3491−
3492−instance ToJSON PatternOrPatterns where
3493− toJSON (PopPattern pattern) = toJSON pattern
3494− toJSON (PopPatterns patterns) = toJSON patterns
3495−
3496−instance ToJSON Include where
3497− toJSON (Include patterns) = toJSON patterns
3498−
3499−instance ToJSON Exclude where
3500− toJSON (Exclude patterns) = toJSON patterns
3501−
3502−instance ToJSON Pattern where
3503− toJSON (Pattern pattern) = toJSON pattern
3504−
3505−
3506−instance ToJSON FieldHighlight where
3507− toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
3508− object [ fName .= fSettings ]
3509− toJSON (FieldHighlight (FieldName fName) Nothing) =
3510− object [ fName .= emptyObject ]
3511−
3512−instance ToJSON Highlights where
3513− toJSON (Highlights global fields) =
3514− omitNulls (("fields" .= fields)
3515− : highlightSettingsPairs global)
3516−
3517−instance ToJSON HighlightSettings where
3518− toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
3519−
3520−highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
3521−highlightSettingsPairs Nothing = []
3522−highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
3523−highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
3524−highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
3525−
3526−
3527−plainHighPairs :: Maybe PlainHighlight -> [Pair]
3528−plainHighPairs Nothing = []
3529−plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
3530− [ "type" .= String "plain"]
3531− ++ commonHighlightPairs plCom
3532− ++ nonPostingsToPairs plNonPost
3533−
3534−postHighPairs :: Maybe PostingsHighlight -> [Pair]
3535−postHighPairs Nothing = []
3536−postHighPairs (Just (PostingsHighlight pCom)) =
3537− ("type" .= String "postings")
3538− : commonHighlightPairs pCom
3539−
3540−fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
3541−fastVectorHighPairs Nothing = []
3542−fastVectorHighPairs (Just
3543− (FastVectorHighlight fvCom fvNonPostSettings fvBoundChars
3544− fvBoundMaxScan fvFragOff fvMatchedFields
3545− fvPhraseLim)) =
3546− [ "type" .= String "fvh"
3547− , "boundary_chars" .= fvBoundChars
3548− , "boundary_max_scan" .= fvBoundMaxScan
3549− , "fragment_offset" .= fvFragOff
3550− , "matched_fields" .= fvMatchedFields
3551− , "phraseLimit" .= fvPhraseLim]
3552− ++ commonHighlightPairs fvCom
3553− ++ nonPostingsToPairs fvNonPostSettings
3554−
3555−deleteSeveral :: (Eq k, Hashable k) => [k] -> HM.HashMap k v -> HM.HashMap k v
3556−deleteSeveral ks hm = foldr HM.delete hm ks
3557−
3558−commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
3559−commonHighlightPairs Nothing = []
3560−commonHighlightPairs (Just (CommonHighlight chScore chForceSource chTag chEncoder
3561− chNoMatchSize chHighlightQuery
3562− chRequireFieldMatch)) =
3563− [ "order" .= chScore
3564− , "force_source" .= chForceSource
3565− , "encoder" .= chEncoder
3566− , "no_match_size" .= chNoMatchSize
3567− , "highlight_query" .= chHighlightQuery
3568− , "require_fieldMatch" .= chRequireFieldMatch]
3569− ++ highlightTagToPairs chTag
3570−
3571−
3572−nonPostingsToPairs :: Maybe NonPostings -> [Pair]
3573−nonPostingsToPairs Nothing = []
3574−nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
3575− [ "fragment_size" .= npFragSize
3576− , "number_of_fragments" .= npNumOfFrags]
3577−
3578−parseNEJSON :: (FromJSON a) => [Value] -> Parser (NonEmpty a)
3579−parseNEJSON [] = fail "Expected non-empty list"
3580−parseNEJSON (x:xs) = DT.mapM parseJSON (x :| xs)
3581−
3582−
3583−instance ToJSON HighlightEncoder where
3584− toJSON DefaultEncoder = String "default"
3585− toJSON HTMLEncoder = String "html"
3586−
3587−highlightTagToPairs :: Maybe HighlightTag -> [Pair]
3588−highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"]
3589−highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre
3590− , "post_tags" .= post]
3591−highlightTagToPairs Nothing = []
3592−
3593−instance ToJSON SortSpec where
3594− toJSON (DefaultSortSpec
3595− (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped
3596− dsSortMode dsMissingSort dsNestedFilter)) =
3597− object [dsSortFieldName .= omitNulls base] where
3598− base = [ "order" .= dsSortOrder
3599− , "ignore_unmapped" .= dsIgnoreUnmapped
3600− , "mode" .= dsSortMode
3601− , "missing" .= dsMissingSort
3602− , "nested_filter" .= dsNestedFilter ]
3603−
3604− toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) =
3605− object [ "unit" .= units
3606− , field .= gdsLatLon
3607− , "order" .= gdsSortOrder ]
3608−
3609−
3610−instance ToJSON SortOrder where
3611− toJSON Ascending = String "asc"
3612− toJSON Descending = String "desc"
3613−
3614−
3615−instance ToJSON SortMode where
3616− toJSON SortMin = String "min"
3617− toJSON SortMax = String "max"
3618− toJSON SortSum = String "sum"
3619− toJSON SortAvg = String "avg"
3620−
3621−
3622−instance ToJSON Missing where
3623− toJSON LastMissing = String "_last"
3624− toJSON FirstMissing = String "_first"
3625− toJSON (CustomMissing txt) = String txt
3626−
3627−
3628−instance ToJSON ScoreType where
3629− toJSON ScoreTypeMax = "max"
3630− toJSON ScoreTypeAvg = "avg"
3631− toJSON ScoreTypeSum = "sum"
3632− toJSON ScoreTypeNone = "none"
3633−
3634−instance FromJSON ScoreType where
3635− parseJSON = withText "ScoreType" parse
3636− where parse "max" = pure ScoreTypeMax
3637− parse "avg" = pure ScoreTypeAvg
3638− parse "sum" = pure ScoreTypeSum
3639− parse "none" = pure ScoreTypeNone
3640− parse t = fail ("Unexpected ScoreType: " <> show t)
3641−
3642−instance ToJSON Distance where
3643− toJSON (Distance dCoefficient dUnit) =
3644− String boltedTogether where
3645− coefText = showText dCoefficient
3646− (String unitText) = toJSON dUnit
3647− boltedTogether = mappend coefText unitText
3648−
3649−instance FromJSON Distance where
3650− parseJSON = withText "Distance" parse
3651− where parse t = Distance <$> parseCoeff nT
3652− <*> parseJSON (String unitT)
3653− where (nT, unitT) = T.span validForNumber t
3654− -- may be a better way to do this
3655− validForNumber '-' = True
3656− validForNumber '.' = True
3657− validForNumber 'e' = True
3658− validForNumber c = isNumber c
3659− parseCoeff "" = fail "Empty string cannot be parsed as number"
3660− parseCoeff s = return (read (T.unpack s))
3661−
3662−instance ToJSON DistanceUnit where
3663− toJSON Miles = String "mi"
3664− toJSON Yards = String "yd"
3665− toJSON Feet = String "ft"
3666− toJSON Inches = String "in"
3667− toJSON Kilometers = String "km"
3668− toJSON Meters = String "m"
3669− toJSON Centimeters = String "cm"
3670− toJSON Millimeters = String "mm"
3671− toJSON NauticalMiles = String "nmi"
3672−
3673−
3674−instance FromJSON DistanceUnit where
3675− parseJSON = withText "DistanceUnit" parse
3676− where parse "mi" = pure Miles
3677− parse "yd" = pure Yards
3678− parse "ft" = pure Feet
3679− parse "in" = pure Inches
3680− parse "km" = pure Kilometers
3681− parse "m" = pure Meters
3682− parse "cm" = pure Centimeters
3683− parse "mm" = pure Millimeters
3684− parse "nmi" = pure NauticalMiles
3685− parse u = fail ("Unrecognized DistanceUnit: " <> show u)
3686−
3687−instance ToJSON DistanceType where
3688− toJSON Arc = String "arc"
3689− toJSON SloppyArc = String "sloppy_arc"
3690− toJSON Plane = String "plane"
3691−
3692−instance FromJSON DistanceType where
3693− parseJSON = withText "DistanceType" parse
3694− where parse "arc" = pure Arc
3695− parse "sloppy_arc" = pure SloppyArc
3696− parse "plane" = pure Plane
3697− parse t = fail ("Unrecognized DistanceType: " <> show t)
3698−
3699−
3700−instance ToJSON OptimizeBbox where
3701− toJSON NoOptimizeBbox = String "none"
3702− toJSON (OptimizeGeoFilterType gft) = toJSON gft
3703−
3704−instance FromJSON OptimizeBbox where
3705− parseJSON v = withText "NoOptimizeBbox" parseNoOptimize v
3706− <|> parseOptimize v
3707− where parseNoOptimize "none" = pure NoOptimizeBbox
3708− parseNoOptimize _ = mzero
3709− parseOptimize = fmap OptimizeGeoFilterType . parseJSON
3710−
3711−instance ToJSON GeoBoundingBoxConstraint where
3712− toJSON (GeoBoundingBoxConstraint
3713− (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') =
3714− object [gbbcGeoBBField .= gbbcConstraintBox
3715− , "_cache" .= cache
3716− , "type" .= type']
3717−
3718−instance FromJSON GeoBoundingBoxConstraint where
3719− parseJSON = withObject "GeoBoundingBoxConstraint" parse
3720− where parse o = case HM.toList (deleteSeveral ["type", "_cache"] o) of
3721− [(fn, v)] -> GeoBoundingBoxConstraint (FieldName fn)
3722− <$> parseJSON v
3723− <*> o .:? "_cache" .!= defaultCache
3724− <*> o .: "type"
3725− _ -> fail "Could not find field name for GeoBoundingBoxConstraint"
3726−
3727−instance ToJSON GeoFilterType where
3728− toJSON GeoFilterMemory = String "memory"
3729− toJSON GeoFilterIndexed = String "indexed"
3730−
3731−instance FromJSON GeoFilterType where
3732− parseJSON = withText "GeoFilterType" parse
3733− where parse "memory" = pure GeoFilterMemory
3734− parse "indexed" = pure GeoFilterIndexed
3735− parse t = fail ("Unrecognized GeoFilterType: " <> show t)
3736−
3737−instance ToJSON GeoBoundingBox where
3738− toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) =
3739− object ["top_left" .= gbbTopLeft
3740− , "bottom_right" .= gbbBottomRight]
3741−
3742−instance FromJSON GeoBoundingBox where
3743− parseJSON = withObject "GeoBoundingBox" parse
3744− where parse o = GeoBoundingBox
3745− <$> o .: "top_left"
3746− <*> o .: "bottom_right"
3747−
3748−instance ToJSON LatLon where
3749− toJSON (LatLon lLat lLon) =
3750− object ["lat" .= lLat
3751− , "lon" .= lLon]
3752−
3753−instance FromJSON LatLon where
3754− parseJSON = withObject "LatLon" parse
3755− where parse o = LatLon <$> o .: "lat"
3756− <*> o .: "lon"
3757−
3758−-- index for smaller ranges, fielddata for longer ranges
3759−instance ToJSON RangeExecution where
3760− toJSON RangeExecutionIndex = "index"
3761− toJSON RangeExecutionFielddata = "fielddata"
3762−
3763−
3764−instance FromJSON RangeExecution where
3765− parseJSON = withText "RangeExecution" parse
3766− where parse "index" = pure RangeExecutionIndex
3767− parse "fielddata" = pure RangeExecutionFielddata
3768− parse t = error ("Unrecognized RangeExecution " <> show t)
3769−
3770−instance ToJSON RegexpFlags where
3771− toJSON AllRegexpFlags = String "ALL"
3772− toJSON NoRegexpFlags = String "NONE"
3773− toJSON (SomeRegexpFlags (h :| fs)) = String $ T.intercalate "|" flagStrs
3774− where flagStrs = map flagStr . nub $ h:fs
3775− flagStr AnyString = "ANYSTRING"
3776− flagStr Automaton = "AUTOMATON"
3777− flagStr Complement = "COMPLEMENT"
3778− flagStr Empty = "EMPTY"
3779− flagStr Intersection = "INTERSECTION"
3780− flagStr Interval = "INTERVAL"
3781−
3782−instance FromJSON RegexpFlags where
3783− parseJSON = withText "RegexpFlags" parse
3784− where parse "ALL" = pure AllRegexpFlags
3785− parse "NONE" = pure NoRegexpFlags
3786− parse t = SomeRegexpFlags <$> parseNEJSON (String <$> T.splitOn "|" t)
3787−
3788−instance FromJSON RegexpFlag where
3789− parseJSON = withText "RegexpFlag" parse
3790− where parse "ANYSTRING" = pure AnyString
3791− parse "AUTOMATON" = pure Automaton
3792− parse "COMPLEMENT" = pure Complement
3793− parse "EMPTY" = pure Empty
3794− parse "INTERSECTION" = pure Intersection
3795− parse "INTERVAL" = pure Interval
3796− parse f = fail ("Unknown RegexpFlag: " <> show f)
3797−
3798−instance ToJSON Term where
3799− toJSON (Term field value) = object ["term" .= object
3800− [field .= value]]
3801−
3802−instance FromJSON Term where
3803− parseJSON = withObject "Term" parse
3804− where parse o = do termObj <- o .: "term"
3805− case HM.toList termObj of
3806− [(fn, v)] -> Term fn <$> parseJSON v
3807− _ -> fail "Expected object with 1 field-named key"
3808−
3809−instance ToJSON BoolMatch where
3810− toJSON (MustMatch term cache) = object ["must" .= term,
3811− "_cache" .= cache]
3812− toJSON (MustNotMatch term cache) = object ["must_not" .= term,
3813− "_cache" .= cache]
3814− toJSON (ShouldMatch terms cache) = object ["should" .= fmap toJSON terms,
3815− "_cache" .= cache]
3816−
3817−instance FromJSON BoolMatch where
3818− parseJSON = withObject "BoolMatch" parse
3819− where parse o = mustMatch `taggedWith` "must"
3820− <|> mustNotMatch `taggedWith` "must_not"
3821− <|> shouldMatch `taggedWith` "should"
3822− where taggedWith parser k = parser =<< o .: k
3823− mustMatch t = MustMatch t <$> o .:? "_cache" .!= defaultCache
3824− mustNotMatch t = MustNotMatch t <$> o .:? "_cache" .!= defaultCache
3825− shouldMatch t = ShouldMatch t <$> o .:? "_cache" .!= defaultCache
3826−
3827−instance (FromJSON a) => FromJSON (SearchResult a) where
3828− parseJSON (Object v) = SearchResult <$>
3829− v .: "took" <*>
3830− v .: "timed_out" <*>
3831− v .: "_shards" <*>
3832− v .: "hits" <*>
3833− v .:? "aggregations" <*>
3834− v .:? "_scroll_id" <*>
3835− v .:? "suggest"
3836− parseJSON _ = empty
3837−
3838−instance (FromJSON a) => FromJSON (SearchHits a) where
3839− parseJSON (Object v) = SearchHits <$>
3840− v .: "total" <*>
3841− v .: "max_score" <*>
3842− v .: "hits"
3843− parseJSON _ = empty
3844−
3845−instance (FromJSON a) => FromJSON (Hit a) where
3846− parseJSON (Object v) = Hit <$>
3847− v .: "_index" <*>
3848− v .: "_type" <*>
3849− v .: "_id" <*>
3850− v .: "_score" <*>
3851− v .:? "_source" <*>
3852− v .:? "highlight"
3853− parseJSON _ = empty
3854−
3855−instance FromJSON ShardResult where
3856− parseJSON (Object v) = ShardResult <$>
3857− v .: "total" <*>
3858− v .: "successful" <*>
3859− v .: "failed"
3860− parseJSON _ = empty
3861−
3862−
3863−instance FromJSON DocVersion where
3864− parseJSON v = do
3865− i <- parseJSON v
3866− maybe (fail "DocVersion out of range") return $ mkDocVersion i
3867−
3868−-- This insanity is because ES *sometimes* returns Replica/Shard counts as strings
3869−instance FromJSON ReplicaCount where
3870− parseJSON v = parseAsInt v
3871− <|> parseAsString v
3872− where parseAsInt = fmap ReplicaCount . parseJSON
3873− parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)
3874−
3875−instance FromJSON ShardCount where
3876− parseJSON v = parseAsInt v
3877− <|> parseAsString v
3878− where parseAsInt = fmap ShardCount . parseJSON
3879− parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText)
3880−
3881−instance Bounded DocVersion where
3882− minBound = DocVersion 1
3883− maxBound = DocVersion 9200000000000000000 -- 9.2e+18
3884−
3885−instance Enum DocVersion where
3886− succ x
3887− | x /= maxBound = DocVersion (succ $ docVersionNumber x)
3888− | otherwise = succError "DocVersion"
3889− pred x
3890− | x /= minBound = DocVersion (pred $ docVersionNumber x)
3891− | otherwise = predError "DocVersion"
3892− toEnum i =
3893− fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i
3894− fromEnum = docVersionNumber
3895− enumFrom = boundedEnumFrom
3896− enumFromThen = boundedEnumFromThen
3897−
3898−-- | Username type used for HTTP Basic authentication. See 'basicAuthHook'.
3899−newtype EsUsername = EsUsername { esUsername :: Text } deriving (Read, Show, Eq)
3900−
3901−-- | Password type used for HTTP Basic authentication. See 'basicAuthHook'.
3902−newtype EsPassword = EsPassword { esPassword :: Text } deriving (Read, Show, Eq)
3903−
3904−
3905−data SnapshotRepoSelection = SnapshotRepoList (NonEmpty SnapshotRepoPattern)
3906− | AllSnapshotRepos deriving (Eq, Generic, Show, Typeable)
3907−
3908−
3909−-- | Either specifies an exact repo name or one with globs in it,
3910−-- e.g. @RepoPattern "foo*"@ __NOTE__: Patterns are not supported on ES < 1.7
3911−data SnapshotRepoPattern = ExactRepo SnapshotRepoName
3912− | RepoPattern Text
3913− deriving (Eq, Generic, Show, Typeable)
3914−
3915−-- | The unique name of a snapshot repository.
3916−newtype SnapshotRepoName = SnapshotRepoName { snapshotRepoName :: Text }
3917− deriving (Eq, Ord, Generic, Show, Typeable, ToJSON, FromJSON)
3918−
3919−
3920−-- | A generic representation of a snapshot repo. This is what gets
3921−-- sent to and parsed from the server. For repo types enabled by
3922−-- plugins that aren't exported by this library, consider making a
3923−-- custom type which implements 'SnapshotRepo'. If it is a common repo
3924−-- type, consider submitting a pull request to have it included in the
3925−-- library proper
3926−data GenericSnapshotRepo = GenericSnapshotRepo {
3927− gSnapshotRepoName :: SnapshotRepoName
3928− , gSnapshotRepoType :: SnapshotRepoType
3929− , gSnapshotRepoSettings :: GenericSnapshotRepoSettings
3930− } deriving (Eq, Generic, Show, Typeable)
3931−
3932−
3933−instance SnapshotRepo GenericSnapshotRepo where
3934− toGSnapshotRepo = id
3935− fromGSnapshotRepo = Right
3936−
3937−
3938−newtype SnapshotRepoType = SnapshotRepoType { snapshotRepoType :: Text }
3939− deriving (Eq, Ord, Generic, Show, Typeable, ToJSON, FromJSON)
3940−
3941−
3942−-- | Opaque representation of snapshot repo settings. Instances of
3943−-- 'SnapshotRepo' will produce this.
3944−newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings { gSnapshotRepoSettingsObject :: Object }
3945− deriving (Eq, Generic, Show, Typeable, ToJSON)
3946−
3947−
3948− -- Regardless of whether you send strongly typed json, my version of
3949− -- ES sends back stringly typed json in the settings, e.g. booleans
3950− -- as strings, so we'll try to convert them.
3951−instance FromJSON GenericSnapshotRepoSettings where
3952− parseJSON = fmap (GenericSnapshotRepoSettings . fmap unStringlyTypeJSON). parseJSON
3953−
3954−-- | The result of running 'verifySnapshotRepo'.
3955−newtype SnapshotVerification = SnapshotVerification { snapshotNodeVerifications :: [SnapshotNodeVerification] }
3956− deriving (Eq, Generic, Show, Typeable)
3957−
3958−
3959−instance FromJSON SnapshotVerification where
3960− parseJSON = withObject "SnapshotVerification" parse
3961− where
3962− parse o = do
3963− o2 <- o .: "nodes"
3964− SnapshotVerification <$> mapM (uncurry parse') (HM.toList o2)
3965− parse' rawFullId = withObject "SnapshotNodeVerification" $ \o ->
3966− SnapshotNodeVerification (FullNodeId rawFullId) <$> o .: "name"
3967−
3968−
3969−-- | A node that has verified a snapshot
3970−data SnapshotNodeVerification = SnapshotNodeVerification {
3971− snvFullId :: FullNodeId
3972− , snvNodeName :: NodeName
3973− } deriving (Eq, Generic, Show, Typeable)
3974−
3975−
3976−-- | Unique, automatically-generated name assigned to nodes that are
3977−-- usually returned in node-oriented APIs.
3978−newtype FullNodeId = FullNodeId { fullNodeId :: Text }
3979− deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)
3980−
3981−
3982−-- | A human-readable node name that is supplied by the user in the
3983−-- node config or automatically generated by ElasticSearch.
3984−newtype NodeName = NodeName { nodeName :: Text }
3985− deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)
3986−
3987−newtype ClusterName = ClusterName { clusterName :: Text }
3988− deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)
3989−
3990−data NodesInfo = NodesInfo {
3991− nodesInfo :: [NodeInfo]
3992− , nodesClusterName :: ClusterName
3993− } deriving (Eq, Show, Generic, Typeable)
3994−
3995−data NodesStats = NodesStats {
3996− nodesStats :: [NodeStats]
3997− , nodesStatsClusterName :: ClusterName
3998− } deriving (Eq, Show, Generic, Typeable)
3999−
4000−data NodeStats = NodeStats {
4001− nodeStatsName :: NodeName
4002− , nodeStatsFullId :: FullNodeId
4003− , nodeStatsBreakersStats :: Maybe NodeBreakersStats
4004− , nodeStatsHTTP :: NodeHTTPStats
4005− , nodeStatsTransport :: NodeTransportStats
4006− , nodeStatsFS :: NodeFSStats
4007− , nodeStatsNetwork :: NodeNetworkStats
4008− , nodeStatsThreadPool :: NodeThreadPoolsStats
4009− , nodeStatsJVM :: NodeJVMStats
4010− , nodeStatsProcess :: NodeProcessStats
4011− , nodeStatsOS :: NodeOSStats
4012− , nodeStatsIndices :: NodeIndicesStats
4013− } deriving (Eq, Show, Generic, Typeable)
4014−
4015−data NodeBreakersStats = NodeBreakersStats {
4016− nodeStatsParentBreaker :: NodeBreakerStats
4017− , nodeStatsRequestBreaker :: NodeBreakerStats
4018− , nodeStatsFieldDataBreaker :: NodeBreakerStats
4019− } deriving (Eq, Show, Generic, Typeable)
4020−
4021−data NodeBreakerStats = NodeBreakerStats {
4022− nodeBreakersTripped :: Int
4023− , nodeBreakersOverhead :: Double
4024− , nodeBreakersEstSize :: Bytes
4025− , nodeBreakersLimitSize :: Bytes
4026− } deriving (Eq, Show, Generic, Typeable)
4027−
4028−data NodeHTTPStats = NodeHTTPStats {
4029− nodeHTTPTotalOpened :: Int
4030− , nodeHTTPCurrentOpen :: Int
4031− } deriving (Eq, Show, Generic, Typeable)
4032−
4033−data NodeTransportStats = NodeTransportStats {
4034− nodeTransportTXSize :: Bytes
4035− , nodeTransportCount :: Int
4036− , nodeTransportRXSize :: Bytes
4037− , nodeTransportRXCount :: Int
4038− , nodeTransportServerOpen :: Int
4039− } deriving (Eq, Show, Generic, Typeable)
4040−
4041−data NodeFSStats = NodeFSStats {
4042− nodeFSDataPaths :: [NodeDataPathStats]
4043− , nodeFSTotal :: NodeFSTotalStats
4044− , nodeFSTimestamp :: UTCTime
4045− } deriving (Eq, Show, Generic, Typeable)
4046−
4047−data NodeDataPathStats = NodeDataPathStats {
4048− nodeDataPathDiskServiceTime :: Maybe Double
4049− , nodeDataPathDiskQueue :: Maybe Double
4050− , nodeDataPathIOSize :: Maybe Bytes
4051− , nodeDataPathWriteSize :: Maybe Bytes
4052− , nodeDataPathReadSize :: Maybe Bytes
4053− , nodeDataPathIOOps :: Maybe Int
4054− , nodeDataPathWrites :: Maybe Int
4055− , nodeDataPathReads :: Maybe Int
4056− , nodeDataPathAvailable :: Bytes
4057− , nodeDataPathFree :: Bytes
4058− , nodeDataPathTotal :: Bytes
4059− , nodeDataPathType :: Maybe Text
4060− , nodeDataPathDevice :: Text
4061− , nodeDataPathMount :: Text
4062− , nodeDataPathPath :: Text
4063− } deriving (Eq, Show, Generic, Typeable)
4064−
4065−data NodeFSTotalStats = NodeFSTotalStats {
4066− nodeFSTotalDiskServiceTime :: Maybe Double
4067− , nodeFSTotalDiskQueue :: Maybe Double
4068− , nodeFSTotalIOSize :: Maybe Bytes
4069− , nodeFSTotalWriteSize :: Maybe Bytes
4070− , nodeFSTotalReadSize :: Maybe Bytes
4071− , nodeFSTotalIOOps :: Maybe Int
4072− , nodeFSTotalWrites :: Maybe Int
4073− , nodeFSTotalReads :: Maybe Int
4074− , nodeFSTotalAvailable :: Bytes
4075− , nodeFSTotalFree :: Bytes
4076− , nodeFSTotalTotal :: Bytes
4077− } deriving (Eq, Show, Generic, Typeable)
4078−
4079−data NodeNetworkStats = NodeNetworkStats {
4080− nodeNetTCPOutRSTs :: Int
4081− , nodeNetTCPInErrs :: Int
4082− , nodeNetTCPAttemptFails :: Int
4083− , nodeNetTCPEstabResets :: Int
4084− , nodeNetTCPRetransSegs :: Int
4085− , nodeNetTCPOutSegs :: Int
4086− , nodeNetTCPInSegs :: Int
4087− , nodeNetTCPCurrEstab :: Int
4088− , nodeNetTCPPassiveOpens :: Int
4089− , nodeNetTCPActiveOpens :: Int
4090− } deriving (Eq, Show, Generic, Typeable)
4091−
4092−data NodeThreadPoolsStats = NodeThreadPoolsStats {
4093− nodeThreadPoolsStatsSnapshot :: NodeThreadPoolStats
4094− , nodeThreadPoolsStatsBulk :: NodeThreadPoolStats
4095− , nodeThreadPoolsStatsMerge :: NodeThreadPoolStats
4096− , nodeThreadPoolsStatsGet :: NodeThreadPoolStats
4097− , nodeThreadPoolsStatsManagement :: NodeThreadPoolStats
4098− , nodeThreadPoolsStatsFetchShardStore :: Maybe NodeThreadPoolStats
4099− , nodeThreadPoolsStatsOptimize :: NodeThreadPoolStats
4100− , nodeThreadPoolsStatsFlush :: NodeThreadPoolStats
4101− , nodeThreadPoolsStatsSearch :: NodeThreadPoolStats
4102− , nodeThreadPoolsStatsWarmer :: NodeThreadPoolStats
4103− , nodeThreadPoolsStatsGeneric :: NodeThreadPoolStats
4104− , nodeThreadPoolsStatsSuggest :: NodeThreadPoolStats
4105− , nodeThreadPoolsStatsRefresh :: NodeThreadPoolStats
4106− , nodeThreadPoolsStatsIndex :: NodeThreadPoolStats
4107− , nodeThreadPoolsStatsListener :: Maybe NodeThreadPoolStats
4108− , nodeThreadPoolsStatsFetchShardStarted :: Maybe NodeThreadPoolStats
4109− , nodeThreadPoolsStatsPercolate :: NodeThreadPoolStats
4110− } deriving (Eq, Show, Generic, Typeable)
4111−
4112−data NodeThreadPoolStats = NodeThreadPoolStats {
4113− nodeThreadPoolCompleted :: Int
4114− , nodeThreadPoolLargest :: Int
4115− , nodeThreadPoolRejected :: Int
4116− , nodeThreadPoolActive :: Int
4117− , nodeThreadPoolQueue :: Int
4118− , nodeThreadPoolThreads :: Int
4119− } deriving (Eq, Show, Generic, Typeable)
4120−
4121−data NodeJVMStats = NodeJVMStats {
4122− nodeJVMStatsMappedBufferPool :: JVMBufferPoolStats
4123− , nodeJVMStatsDirectBufferPool :: JVMBufferPoolStats
4124− , nodeJVMStatsGCOldCollector :: JVMGCStats
4125− , nodeJVMStatsGCYoungCollector :: JVMGCStats
4126− , nodeJVMStatsPeakThreadsCount :: Int
4127− , nodeJVMStatsThreadsCount :: Int
4128− , nodeJVMStatsOldPool :: JVMPoolStats
4129− , nodeJVMStatsSurvivorPool :: JVMPoolStats
4130− , nodeJVMStatsYoungPool :: JVMPoolStats
4131− , nodeJVMStatsNonHeapCommitted :: Bytes
4132− , nodeJVMStatsNonHeapUsed :: Bytes
4133− , nodeJVMStatsHeapMax :: Bytes
4134− , nodeJVMStatsHeapCommitted :: Bytes
4135− , nodeJVMStatsHeapUsedPercent :: Int
4136− , nodeJVMStatsHeapUsed :: Bytes
4137− , nodeJVMStatsUptime :: NominalDiffTime
4138− , nodeJVMStatsTimestamp :: UTCTime
4139− } deriving (Eq, Show, Generic, Typeable)
4140−
4141−data JVMBufferPoolStats = JVMBufferPoolStats {
4142− jvmBufferPoolStatsTotalCapacity :: Bytes
4143− , jvmBufferPoolStatsUsed :: Bytes
4144− , jvmBufferPoolStatsCount :: Int
4145− } deriving (Eq, Show, Generic, Typeable)
4146−
4147−data JVMGCStats = JVMGCStats {
4148− jvmGCStatsCollectionTime :: NominalDiffTime
4149− , jvmGCStatsCollectionCount :: Int
4150− } deriving (Eq, Show, Generic, Typeable)
4151−
4152−data JVMPoolStats = JVMPoolStats {
4153− jvmPoolStatsPeakMax :: Bytes
4154− , jvmPoolStatsPeakUsed :: Bytes
4155− , jvmPoolStatsMax :: Bytes
4156− , jvmPoolStatsUsed :: Bytes
4157− } deriving (Eq, Show, Generic, Typeable)
4158−
4159−data NodeProcessStats = NodeProcessStats {
4160− nodeProcessMemTotalVirtual :: Bytes
4161− , nodeProcessMemShare :: Bytes
4162− , nodeProcessMemResident :: Bytes
4163− , nodeProcessCPUTotal :: NominalDiffTime
4164− , nodeProcessCPUUser :: NominalDiffTime
4165− , nodeProcessCPUSys :: NominalDiffTime
4166− , nodeProcessCPUPercent :: Int
4167− , nodeProcessOpenFDs :: Int
4168− , nodeProcessTimestamp :: UTCTime
4169− } deriving (Eq, Show, Generic, Typeable)
4170−
4171−data NodeOSStats = NodeOSStats {
4172− nodeOSSwapFree :: Bytes
4173− , nodeOSSwapUsed :: Bytes
4174− , nodeOSMemActualUsed :: Bytes
4175− , nodeOSMemActualFree :: Bytes
4176− , nodeOSMemUsedPercent :: Int
4177− , nodeOSMemFreePercent :: Int
4178− , nodeOSMemUsed :: Bytes
4179− , nodeOSMemFree :: Bytes
4180− , nodeOSCPUStolen :: Int
4181− , nodeOSCPUUsage :: Int
4182− , nodeOSCPUIdle :: Int
4183− , nodeOSCPUUser :: Int
4184− , nodeOSCPUSys :: Int
4185− , nodeOSLoad :: Maybe LoadAvgs
4186− , nodeOSUptime :: NominalDiffTime
4187− , nodeOSTimestamp :: UTCTime
4188− } deriving (Eq, Show, Generic, Typeable)
4189−
4190−data LoadAvgs = LoadAvgs {
4191− loadAvg1Min :: Double
4192− , loadAvg5Min :: Double
4193− , loadAvg15Min :: Double
4194− } deriving (Eq, Show, Generic, Typeable)
4195−
4196−data NodeIndicesStats = NodeIndicesStats {
4197− nodeIndicesStatsRecoveryThrottleTime :: Maybe NominalDiffTime
4198− , nodeIndicesStatsRecoveryCurrentAsTarget :: Maybe Int
4199− , nodeIndicesStatsRecoveryCurrentAsSource :: Maybe Int
4200− , nodeIndicesStatsQueryCacheMisses :: Maybe Int
4201− , nodeIndicesStatsQueryCacheHits :: Maybe Int
4202− , nodeIndicesStatsQueryCacheEvictions :: Maybe Int
4203− , nodeIndicesStatsQueryCacheSize :: Maybe Bytes
4204− , nodeIndicesStatsSuggestCurrent :: Int
4205− , nodeIndicesStatsSuggestTime :: NominalDiffTime
4206− , nodeIndicesStatsSuggestTotal :: Int
4207− , nodeIndicesStatsTranslogSize :: Bytes
4208− , nodeIndicesStatsTranslogOps :: Int
4209− , nodeIndicesStatsSegFixedBitSetMemory :: Maybe Bytes
4210− , nodeIndicesStatsSegVersionMapMemory :: Bytes
4211− , nodeIndicesStatsSegIndexWriterMaxMemory :: Maybe Bytes
4212− , nodeIndicesStatsSegIndexWriterMemory :: Bytes
4213− , nodeIndicesStatsSegMemory :: Bytes
4214− , nodeIndicesStatsSegCount :: Int
4215− , nodeIndicesStatsCompletionSize :: Bytes
4216− , nodeIndicesStatsPercolateQueries :: Int
4217− , nodeIndicesStatsPercolateMemory :: Bytes
4218− , nodeIndicesStatsPercolateCurrent :: Int
4219− , nodeIndicesStatsPercolateTime :: NominalDiffTime
4220− , nodeIndicesStatsPercolateTotal :: Int
4221− , nodeIndicesStatsFieldDataEvictions :: Int
4222− , nodeIndicesStatsFieldDataMemory :: Bytes
4223− , nodeIndicesStatsIDCacheMemory :: Bytes
4224− , nodeIndicesStatsFilterCacheEvictions :: Int
4225− , nodeIndicesStatsFilterCacheMemory :: Bytes
4226− , nodeIndicesStatsWarmerTotalTime :: NominalDiffTime
4227− , nodeIndicesStatsWarmerTotal :: Int
4228− , nodeIndicesStatsWarmerCurrent :: Int
4229− , nodeIndicesStatsFlushTotalTime :: NominalDiffTime
4230− , nodeIndicesStatsFlushTotal :: Int
4231− , nodeIndicesStatsRefreshTotalTime :: NominalDiffTime
4232− , nodeIndicesStatsRefreshTotal :: Int
4233− , nodeIndicesStatsMergesTotalSize :: Bytes
4234− , nodeIndicesStatsMergesTotalDocs :: Int
4235− , nodeIndicesStatsMergesTotalTime :: NominalDiffTime
4236− , nodeIndicesStatsMergesTotal :: Int
4237− , nodeIndicesStatsMergesCurrentSize :: Bytes
4238− , nodeIndicesStatsMergesCurrentDocs :: Int
4239− , nodeIndicesStatsMergesCurrent :: Int
4240− , nodeIndicesStatsSearchFetchCurrent :: Int
4241− , nodeIndicesStatsSearchFetchTime :: NominalDiffTime
4242− , nodeIndicesStatsSearchFetchTotal :: Int
4243− , nodeIndicesStatsSearchQueryCurrent :: Int
4244− , nodeIndicesStatsSearchQueryTime :: NominalDiffTime
4245− , nodeIndicesStatsSearchQueryTotal :: Int
4246− , nodeIndicesStatsSearchOpenContexts :: Int
4247− , nodeIndicesStatsGetCurrent :: Int
4248− , nodeIndicesStatsGetMissingTime :: NominalDiffTime
4249− , nodeIndicesStatsGetMissingTotal :: Int
4250− , nodeIndicesStatsGetExistsTime :: NominalDiffTime
4251− , nodeIndicesStatsGetExistsTotal :: Int
4252− , nodeIndicesStatsGetTime :: NominalDiffTime
4253− , nodeIndicesStatsGetTotal :: Int
4254− , nodeIndicesStatsIndexingThrottleTime :: Maybe NominalDiffTime
4255− , nodeIndicesStatsIndexingIsThrottled :: Maybe Bool
4256− , nodeIndicesStatsIndexingNoopUpdateTotal :: Maybe Int
4257− , nodeIndicesStatsIndexingDeleteCurrent :: Int
4258− , nodeIndicesStatsIndexingDeleteTime :: NominalDiffTime
4259− , nodeIndicesStatsIndexingDeleteTotal :: Int
4260− , nodeIndicesStatsIndexingIndexCurrent :: Int
4261− , nodeIndicesStatsIndexingIndexTime :: NominalDiffTime
4262− , nodeIndicesStatsIndexingTotal :: Int
4263− , nodeIndicesStatsStoreThrottleTime :: NominalDiffTime
4264− , nodeIndicesStatsStoreSize :: Bytes
4265− , nodeIndicesStatsDocsDeleted :: Int
4266− , nodeIndicesStatsDocsCount :: Int
4267− } deriving (Eq, Show, Generic, Typeable)
4268−
4269−-- | A quirky address format used throughout ElasticSearch. An example
4270−-- would be inet[/1.1.1.1:9200]. inet may be a placeholder for a
4271−-- <https://en.wikipedia.org/wiki/Fully_qualified_domain_name FQDN>.
4272−newtype EsAddress = EsAddress { esAddress :: Text }
4273− deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)
4274−
4275−-- | Typically a 7 character hex string.
4276−newtype BuildHash = BuildHash { buildHash :: Text }
4277− deriving (Eq, Ord, Generic, Read, Show, Typeable, FromJSON, ToJSON)
4278−
4279−newtype PluginName = PluginName { pluginName :: Text }
4280− deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)
4281−
4282−data NodeInfo = NodeInfo {
4283− nodeInfoHTTPAddress :: EsAddress
4284− , nodeInfoBuild :: BuildHash
4285− , nodeInfoESVersion :: VersionNumber
4286− , nodeInfoIP :: Server
4287− , nodeInfoHost :: Server
4288− , nodeInfoTransportAddress :: EsAddress
4289− , nodeInfoName :: NodeName
4290− , nodeInfoFullId :: FullNodeId
4291− , nodeInfoPlugins :: [NodePluginInfo]
4292− , nodeInfoHTTP :: NodeHTTPInfo
4293− , nodeInfoTransport :: NodeTransportInfo
4294− , nodeInfoNetwork :: NodeNetworkInfo
4295− , nodeInfoThreadPool :: NodeThreadPoolsInfo
4296− , nodeInfoJVM :: NodeJVMInfo
4297− , nodeInfoProcess :: NodeProcessInfo
4298− , nodeInfoOS :: NodeOSInfo
4299− , nodeInfoSettings :: Object
4300− -- ^ The members of the settings objects are not consistent,
4301− -- dependent on plugins, etc.
4302− } deriving (Eq, Show, Generic, Typeable)
4303−
4304−data NodePluginInfo = NodePluginInfo {
4305− nodePluginSite :: Bool
4306− -- ^ Is this a site plugin?
4307− , nodePluginJVM :: Bool
4308− -- ^ Is this plugin running on the JVM
4309− , nodePluginDescription :: Text
4310− , nodePluginVersion :: MaybeNA VersionNumber
4311− , nodePluginName :: PluginName
4312− } deriving (Eq, Show, Generic, Typeable)
4313−
4314−data NodeHTTPInfo = NodeHTTPInfo {
4315− nodeHTTPMaxContentLength :: Bytes
4316− , nodeHTTPTransportAddress :: BoundTransportAddress
4317− } deriving (Eq, Show, Generic, Typeable)
4318−
4319−data NodeTransportInfo = NodeTransportInfo {
4320− nodeTransportProfiles :: [BoundTransportAddress]
4321− , nodeTransportAddress :: BoundTransportAddress
4322− } deriving (Eq, Show, Generic, Typeable)
4323−
4324−data BoundTransportAddress = BoundTransportAddress {
4325− publishAddress :: EsAddress
4326− , boundAddress :: EsAddress
4327− } deriving (Eq, Show, Generic, Typeable)
4328−
4329−data NodeNetworkInfo = NodeNetworkInfo {
4330− nodeNetworkPrimaryInterface :: NodeNetworkInterface
4331− , nodeNetworkRefreshInterval :: NominalDiffTime
4332− } deriving (Eq, Show, Generic, Typeable)
4333−
4334−newtype MacAddress = MacAddress { macAddress :: Text }
4335− deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)
4336−
4337−newtype NetworkInterfaceName = NetworkInterfaceName { networkInterfaceName :: Text }
4338− deriving (Eq, Ord, Generic, Show, Typeable, FromJSON)
4339−
4340−data NodeNetworkInterface = NodeNetworkInterface {
4341− nodeNetIfaceMacAddress :: MacAddress
4342− , nodeNetIfaceName :: NetworkInterfaceName
4343− , nodeNetIfaceAddress :: Server
4344− } deriving (Eq, Show, Generic, Typeable)
4345−
4346−data NodeThreadPoolsInfo = NodeThreadPoolsInfo {
4347− nodeThreadPoolsRefresh :: NodeThreadPoolInfo
4348− , nodeThreadPoolsManagement :: NodeThreadPoolInfo
4349− , nodeThreadPoolsPercolate :: NodeThreadPoolInfo
4350− , nodeThreadPoolsListener :: Maybe NodeThreadPoolInfo
4351− , nodeThreadPoolsFetchShardStarted :: Maybe NodeThreadPoolInfo
4352− , nodeThreadPoolsSearch :: NodeThreadPoolInfo
4353− , nodeThreadPoolsFlush :: NodeThreadPoolInfo
4354− , nodeThreadPoolsWarmer :: NodeThreadPoolInfo
4355− , nodeThreadPoolsOptimize :: NodeThreadPoolInfo
4356− , nodeThreadPoolsBulk :: NodeThreadPoolInfo
4357− , nodeThreadPoolsSuggest :: NodeThreadPoolInfo
4358− , nodeThreadPoolsMerge :: NodeThreadPoolInfo
4359− , nodeThreadPoolsSnapshot :: NodeThreadPoolInfo
4360− , nodeThreadPoolsGet :: NodeThreadPoolInfo
4361− , nodeThreadPoolsFetchShardStore :: Maybe NodeThreadPoolInfo
4362− , nodeThreadPoolsIndex :: NodeThreadPoolInfo
4363− , nodeThreadPoolsGeneric :: NodeThreadPoolInfo
4364− } deriving (Eq, Show, Generic, Typeable)
4365−
4366−data NodeThreadPoolInfo = NodeThreadPoolInfo {
4367− nodeThreadPoolQueueSize :: ThreadPoolSize
4368− , nodeThreadPoolKeepalive :: Maybe NominalDiffTime
4369− , nodeThreadPoolMin :: Maybe Int
4370− , nodeThreadPoolMax :: Maybe Int
4371− , nodeThreadPoolType :: ThreadPoolType
4372− } deriving (Eq, Show, Generic, Typeable)
4373−
4374−data ThreadPoolSize = ThreadPoolBounded Int
4375− | ThreadPoolUnbounded
4376− deriving (Eq, Show, Generic, Typeable)
4377−
4378−data ThreadPoolType = ThreadPoolScaling
4379− | ThreadPoolFixed
4380− | ThreadPoolCached
4381− deriving (Eq, Show, Generic, Typeable)
4382−
4383−data NodeJVMInfo = NodeJVMInfo {
4384− nodeJVMInfoMemoryPools :: [JVMMemoryPool]
4385− , nodeJVMInfoMemoryPoolsGCCollectors :: [JVMGCCollector]
4386− , nodeJVMInfoMemoryInfo :: JVMMemoryInfo
4387− , nodeJVMInfoStartTime :: UTCTime
4388− , nodeJVMInfoVMVendor :: Text
4389− , nodeJVMVMVersion :: VersionNumber
4390− -- ^ JVM doesn't seme to follow normal version conventions
4391− , nodeJVMVMName :: Text
4392− , nodeJVMVersion :: VersionNumber
4393− , nodeJVMPID :: PID
4394− } deriving (Eq, Show, Generic, Typeable)
4395−
4396−-- | Handles quirks in the way JVM versions are rendered (1.7.0_101 -> 1.7.0.101)
4397−newtype JVMVersion = JVMVersion { unJVMVersion :: VersionNumber }
4398−
4399−data JVMMemoryInfo = JVMMemoryInfo {
4400− jvmMemoryInfoDirectMax :: Bytes
4401− , jvmMemoryInfoNonHeapMax :: Bytes
4402− , jvmMemoryInfoNonHeapInit :: Bytes
4403− , jvmMemoryInfoHeapMax :: Bytes
4404− , jvmMemoryInfoHeapInit :: Bytes
4405− } deriving (Eq, Show, Generic, Typeable)
4406−
4407−newtype JVMMemoryPool = JVMMemoryPool {
4408− jvmMemoryPool :: Text
4409− } deriving (Eq, Show, Generic, Typeable, FromJSON)
4410−
4411−newtype JVMGCCollector = JVMGCCollector {
4412− jvmGCCollector :: Text
4413− } deriving (Eq, Show, Generic, Typeable, FromJSON)
4414−
4415−newtype PID = PID {
4416− pid :: Int
4417− } deriving (Eq, Show, Generic, Typeable, FromJSON)
4418−
4419−data NodeOSInfo = NodeOSInfo {
4420− nodeOSSwap :: Bytes
4421− , nodeOSMem :: Bytes
4422− , nodeOSCPUInfo :: CPUInfo
4423− , nodeOSAvailableProcessors :: Int
4424− , nodeOSRefreshInterval :: NominalDiffTime
4425− } deriving (Eq, Show, Generic, Typeable)
4426−
4427−data CPUInfo = CPUInfo {
4428− cpuCacheSize :: Bytes
4429− , cpuCoresPerSocket :: Int
4430− , cpuTotalSockets :: Int
4431− , cpuTotalCores :: Int
4432− , cpuMHZ :: Int
4433− , cpuModel :: Text
4434− , cpuVendor :: Text
4435− } deriving (Eq, Show, Generic, Typeable)
4436−
4437−data NodeProcessInfo = NodeProcessInfo {
4438− nodeProcessMLockAll :: Bool
4439− -- ^ See <https://www.elastic.co/guide/en/elasticsearch/reference/current/setup-configuration.html>
4440− , nodeProcessMaxFileDescriptors :: Int
4441− , nodeProcessId :: PID
4442− , nodeProcessRefreshInterval :: NominalDiffTime
4443− } deriving (Eq, Show, Generic, Typeable)
4444−
4445−data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings {
4446− repoUpdateVerify :: Bool
4447− -- ^ After creation/update, synchronously check that nodes can
4448− -- write to this repo. Defaults to True. You may use False if you
4449− -- need a faster response and plan on verifying manually later
4450− -- with 'verifySnapshotRepo'.
4451− } deriving (Eq, Show, Generic, Typeable)
4452−
4453−
4454−-- | Reasonable defaults for repo creation/update
4455−--
4456−-- * repoUpdateVerify True
4457−defaultSnapshotRepoUpdateSettings :: SnapshotRepoUpdateSettings
4458−defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True
4459−
4460−
4461−-- | A filesystem-based snapshot repo that ships with
4462−-- ElasticSearch. This is an instance of 'SnapshotRepo' so it can be
4463−-- used with 'updateSnapshotRepo'
4464−data FsSnapshotRepo = FsSnapshotRepo {
4465− fsrName :: SnapshotRepoName
4466− , fsrLocation :: FilePath
4467− , fsrCompressMetadata :: Bool
4468− , fsrChunkSize :: Maybe Bytes
4469− -- ^ Size by which to split large files during snapshotting.
4470− , fsrMaxRestoreBytesPerSec :: Maybe Bytes
4471− -- ^ Throttle node restore rate. If not supplied, defaults to 40mb/sec
4472− , fsrMaxSnapshotBytesPerSec :: Maybe Bytes
4473− -- ^ Throttle node snapshot rate. If not supplied, defaults to 40mb/sec
4474− } deriving (Eq, Generic, Show, Typeable)
4475−
4476−
4477−instance SnapshotRepo FsSnapshotRepo where
4478− toGSnapshotRepo FsSnapshotRepo {..} =
4479− GenericSnapshotRepo fsrName fsRepoType (GenericSnapshotRepoSettings settings)
4480− where
4481− Object settings = object $ [ "location" .= fsrLocation
4482− , "compress" .= fsrCompressMetadata
4483− ] ++ optionalPairs
4484− optionalPairs = catMaybes [ ("chunk_size" .=) <$> fsrChunkSize
4485− , ("max_restore_bytes_per_sec" .=) <$> fsrMaxRestoreBytesPerSec
4486− , ("max_snapshot_bytes_per_sec" .=) <$> fsrMaxSnapshotBytesPerSec
4487− ]
4488− fromGSnapshotRepo GenericSnapshotRepo {..}
4489− | gSnapshotRepoType == fsRepoType = do
4490− let o = gSnapshotRepoSettingsObject gSnapshotRepoSettings
4491− parseRepo $ do
4492− FsSnapshotRepo gSnapshotRepoName <$> o .: "location"
4493− <*> o .:? "compress" .!= False
4494− <*> o .:? "chunk_size"
4495− <*> o .:? "max_restore_bytes_per_sec"
4496− <*> o .:? "max_snapshot_bytes_per_sec"
4497− | otherwise = Left (RepoTypeMismatch fsRepoType gSnapshotRepoType)
4498−
4499−
4500−parseRepo :: Parser a -> Either SnapshotRepoConversionError a
4501−parseRepo parser = case parseEither (const parser) () of
4502− Left e -> Left (OtherRepoConversionError (T.pack e))
4503− Right a -> Right a
4504−
4505−
4506−fsRepoType :: SnapshotRepoType
4507−fsRepoType = SnapshotRepoType "fs"
4508−
4509−-- | Law: fromGSnapshotRepo (toGSnapshotRepo r) == Right r
4510−class SnapshotRepo r where
4511− toGSnapshotRepo :: r -> GenericSnapshotRepo
4512− fromGSnapshotRepo :: GenericSnapshotRepo -> Either SnapshotRepoConversionError r
4513−
4514−
4515−data SnapshotRepoConversionError = RepoTypeMismatch SnapshotRepoType SnapshotRepoType
4516− -- ^ Expected type and actual type
4517− | OtherRepoConversionError Text
4518− deriving (Show, Eq, Generic, Typeable)
4519−
4520−
4521−instance Exception SnapshotRepoConversionError
4522−
4523−
4524−data SnapshotCreateSettings = SnapshotCreateSettings {
4525− snapWaitForCompletion :: Bool
4526− -- ^ Should the API call return immediately after initializing
4527− -- the snapshot or wait until completed? Note that if this is
4528− -- enabled it could wait a long time, so you should adjust your
4529− -- 'ManagerSettings' accordingly to set long timeouts or
4530− -- explicitly handle timeouts.
4531− , snapIndices :: Maybe IndexSelection
4532− -- ^ Nothing will snapshot all indices. Just [] is permissable and
4533− -- will essentially be a no-op snapshot.
4534− , snapIgnoreUnavailable :: Bool
4535− -- ^ If set to True, any matched indices that don't exist will be
4536− -- ignored. Otherwise it will be an error and fail.
4537− , snapIncludeGlobalState :: Bool
4538− , snapPartial :: Bool
4539− -- ^ If some indices failed to snapshot (e.g. if not all primary
4540− -- shards are available), should the process proceed?
4541− } deriving (Eq, Generic, Show, Typeable)
4542−
4543−
4544−-- | Reasonable defaults for snapshot creation
4545−--
4546−-- * snapWaitForCompletion False
4547−-- * snapIndices Nothing
4548−-- * snapIgnoreUnavailable False
4549−-- * snapIncludeGlobalState True
4550−-- * snapPartial False
4551−defaultSnapshotCreateSettings :: SnapshotCreateSettings
4552−defaultSnapshotCreateSettings = SnapshotCreateSettings {
4553− snapWaitForCompletion = False
4554− , snapIndices = Nothing
4555− , snapIgnoreUnavailable = False
4556− , snapIncludeGlobalState = True
4557− , snapPartial = False
4558− }
4559−
4560−
4561−data SnapshotSelection = SnapshotList (NonEmpty SnapshotPattern)
4562− | AllSnapshots deriving (Eq, Generic, Show, Typeable)
4563−
4564−
4565−-- | Either specifies an exact snapshot name or one with globs in it,
4566−-- e.g. @SnapPattern "foo*"@ __NOTE__: Patterns are not supported on
4567−-- ES < 1.7
4568−data SnapshotPattern = ExactSnap SnapshotName
4569− | SnapPattern Text
4570− deriving (Eq, Generic, Show, Typeable)
4571−
4572−
4573−-- | General information about the state of a snapshot. Has some
4574−-- redundancies with 'SnapshotStatus'
4575−data SnapshotInfo = SnapshotInfo {
4576− snapInfoShards :: ShardResult
4577− , snapInfoFailures :: [SnapshotShardFailure]
4578− , snapInfoDuration :: NominalDiffTime
4579− , snapInfoEndTime :: UTCTime
4580− , snapInfoStartTime :: UTCTime
4581− , snapInfoState :: SnapshotState
4582− , snapInfoIndices :: [IndexName]
4583− , snapInfoName :: SnapshotName
4584− } deriving (Eq, Generic, Show, Typeable)
4585−
4586−
4587−instance FromJSON SnapshotInfo where
4588− parseJSON = withObject "SnapshotInfo" parse
4589− where
4590− parse o = SnapshotInfo <$> o .: "shards"
4591− <*> o .: "failures"
4592− <*> (unMS <$> o .: "duration_in_millis")
4593− <*> (posixMS <$> o .: "end_time_in_millis")
4594− <*> (posixMS <$> o .: "start_time_in_millis")
4595− <*> o .: "state"
4596− <*> o .: "indices"
4597− <*> o .: "snapshot"
4598−
4599−data SnapshotShardFailure = SnapshotShardFailure {
4600− snapShardFailureIndex :: IndexName
4601− , snapShardFailureNodeId :: Maybe NodeName -- I'm not 100% sure this isn't actually 'FullNodeId'
4602− , snapShardFailureReason :: Text
4603− , snapShardFailureShardId :: ShardId
4604− } deriving (Eq, Show, Generic, Typeable)
4605−
4606−
4607−instance FromJSON SnapshotShardFailure where
4608− parseJSON = withObject "SnapshotShardFailure" parse
4609− where
4610− parse o = SnapshotShardFailure <$> o .: "index"
4611− <*> o .:? "node_id"
4612− <*> o .: "reason"
4613− <*> o .: "shard_id"
4614−
4615−
4616−newtype ShardId = ShardId { shardId :: Int }
4617− deriving (Eq, Show, Generic, Typeable, FromJSON)
4618−
4619−-- | Milliseconds
4620−newtype MS = MS NominalDiffTime
4621−
4622−
4623−-- keeps the unexported constructor warnings at bay
4624−unMS :: MS -> NominalDiffTime
4625−unMS (MS t) = t
4626−
4627−
4628−instance FromJSON MS where
4629− parseJSON = withScientific "MS" (return . MS . parse)
4630− where
4631− parse n = fromInteger ((truncate n) * 1000)
4632−
4633−
4634−data SnapshotState = SnapshotInit
4635− | SnapshotStarted
4636− | SnapshotSuccess
4637− | SnapshotFailed
4638− | SnapshotAborted
4639− | SnapshotMissing
4640− | SnapshotWaiting
4641− deriving (Show, Eq, Generic, Typeable)
4642−
4643−instance FromJSON SnapshotState where
4644− parseJSON = withText "SnapshotState" parse
4645− where
4646− parse "INIT" = return SnapshotInit
4647− parse "STARTED" = return SnapshotStarted
4648− parse "SUCCESS" = return SnapshotSuccess
4649− parse "FAILED" = return SnapshotFailed
4650− parse "ABORTED" = return SnapshotAborted
4651− parse "MISSING" = return SnapshotMissing
4652− parse "WAITING" = return SnapshotWaiting
4653− parse t = fail ("Invalid snapshot state " <> T.unpack t)
4654−
4655−
4656−newtype SnapshotName = SnapshotName { snapshotName :: Text }
4657− deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON)
4658−
4659−
4660−data SnapshotRestoreSettings = SnapshotRestoreSettings {
4661− snapRestoreWaitForCompletion :: Bool
4662− -- ^ Should the API call return immediately after initializing
4663− -- the restore or wait until completed? Note that if this is
4664− -- enabled, it could wait a long time, so you should adjust your
4665− -- 'ManagerSettings' accordingly to set long timeouts or
4666− -- explicitly handle timeouts.
4667− , snapRestoreIndices :: Maybe IndexSelection
4668− -- ^ Nothing will restore all indices in the snapshot. Just [] is
4669− -- permissable and will essentially be a no-op restore.
4670− , snapRestoreIgnoreUnavailable :: Bool
4671− -- ^ If set to True, any indices that do not exist will be ignored
4672− -- during snapshot rather than failing the restore.
4673− , snapRestoreIncludeGlobalState :: Bool
4674− -- ^ If set to false, will ignore any global state in the snapshot
4675− -- and will not restore it.
4676− , snapRestoreRenamePattern :: Maybe RestoreRenamePattern
4677− -- ^ A regex pattern for matching indices. Used with
4678− -- 'snapRestoreRenameReplacement', the restore can reference the
4679− -- matched index and create a new index name upon restore.
4680− , snapRestoreRenameReplacement :: Maybe (NonEmpty RestoreRenameToken)
4681− -- ^ Expression of how index renames should be constructed.
4682− , snapRestorePartial :: Bool
4683− -- ^ If some indices fail to restore, should the process proceed?
4684− , snapRestoreIncludeAliases :: Bool
4685− -- ^ Should the restore also restore the aliases captured in the
4686− -- snapshot.
4687− , snapRestoreIndexSettingsOverrides :: Maybe RestoreIndexSettings
4688− -- ^ Settings to apply during the restore process. __NOTE:__ This
4689− -- option is not supported in ES < 1.5 and should be set to
4690− -- Nothing in that case.
4691− , snapRestoreIgnoreIndexSettings :: Maybe (NonEmpty Text)
4692− -- ^ This type could be more rich but it isn't clear which
4693− -- settings are allowed to be ignored during restore, so we're
4694− -- going with including this feature in a basic form rather than
4695− -- omitting it. One example here would be
4696− -- "index.refresh_interval". Any setting specified here will
4697− -- revert back to the server default during the restore process.
4698− } deriving (Eq, Generic, Show, Typeable)
4699−
4700−-- | Regex-stype pattern, e.g. "index_(.+)" to match index names
4701−newtype RestoreRenamePattern = RestoreRenamePattern { rrPattern :: Text }
4702− deriving (Show, Eq, Generic, Typeable, Ord, ToJSON)
4703−
4704−
4705−-- | A single token in a index renaming scheme for a restore. These
4706−-- are concatenated into a string before being sent to
4707−-- ElasticSearch. Check out these Java
4708−-- <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.
4709−data RestoreRenameToken = RRTLit Text
4710− -- ^ Just a literal string of characters
4711− | RRSubWholeMatch
4712− -- ^ Equivalent to $0. The entire matched pattern, not any subgroup
4713− | RRSubGroup RRGroupRefNum
4714− -- ^ A specific reference to a group number
4715− deriving (Show, Eq, Generic, Typeable)
4716−
4717−
4718−-- | A group number for regex matching. Only values from 1-9 are
4719−-- supported. Construct with 'mkRRGroupRefNum'
4720−newtype RRGroupRefNum = RRGroupRefNum { rrGroupRefNum :: Int }
4721− deriving (Show, Eq, Generic, Typeable, Ord)
4722−
4723−instance Bounded RRGroupRefNum where
4724− minBound = RRGroupRefNum 1
4725− maxBound = RRGroupRefNum 9
4726−
4727−
4728−-- | Only allows valid group number references (1-9).
4729−mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum
4730−mkRRGroupRefNum i
4731− | i >= (rrGroupRefNum minBound) && i <= (rrGroupRefNum maxBound) =
4732− Just $ RRGroupRefNum i
4733− | otherwise = Nothing
4734−
4735−
4736−-- | Reasonable defaults for snapshot restores
4737−--
4738−-- * snapRestoreWaitForCompletion False
4739−-- * snapRestoreIndices Nothing
4740−-- * snapRestoreIgnoreUnavailable False
4741−-- * snapRestoreIncludeGlobalState True
4742−-- * snapRestoreRenamePattern Nothing
4743−-- * snapRestoreRenameReplacement Nothing
4744−-- * snapRestorePartial False
4745−-- * snapRestoreIncludeAliases True
4746−-- * snapRestoreIndexSettingsOverrides Nothing
4747−-- * snapRestoreIgnoreIndexSettings Nothing
4748−defaultSnapshotRestoreSettings :: SnapshotRestoreSettings
4749−defaultSnapshotRestoreSettings = SnapshotRestoreSettings {
4750− snapRestoreWaitForCompletion = False
4751− , snapRestoreIndices = Nothing
4752− , snapRestoreIgnoreUnavailable = False
4753− , snapRestoreIncludeGlobalState = True
4754− , snapRestoreRenamePattern = Nothing
4755− , snapRestoreRenameReplacement = Nothing
4756− , snapRestorePartial = False
4757− , snapRestoreIncludeAliases = True
4758− , snapRestoreIndexSettingsOverrides = Nothing
4759− , snapRestoreIgnoreIndexSettings = Nothing
4760− }
4761−
4762−
4763−-- | Index settings that can be overridden. The docs only mention you
4764−-- can update number of replicas, but there may be more. You
4765−-- definitely cannot override shard count.
4766−data RestoreIndexSettings = RestoreIndexSettings {
4767− restoreOverrideReplicas :: Maybe ReplicaCount
4768− } deriving (Show, Eq, Generic, Typeable)
4769−
4770−
4771−instance ToJSON RestoreIndexSettings where
4772− toJSON RestoreIndexSettings {..} = object prs
4773− where
4774− prs = catMaybes [("index.number_of_replicas" .=) <$> restoreOverrideReplicas]
4775−
4776−
4777−instance FromJSON NodesInfo where
4778− parseJSON = withObject "NodesInfo" parse
4779− where
4780− parse o = do
4781− nodes <- o .: "nodes"
4782− infos <- forM (HM.toList nodes) $ \(fullNID, v) -> do
4783− node <- parseJSON v
4784− parseNodeInfo (FullNodeId fullNID) node
4785− cn <- o .: "cluster_name"
4786− return (NodesInfo infos cn)
4787−
4788−instance FromJSON NodesStats where
4789− parseJSON = withObject "NodesStats" parse
4790− where
4791− parse o = do
4792− nodes <- o .: "nodes"
4793− stats <- forM (HM.toList nodes) $ \(fullNID, v) -> do
4794− node <- parseJSON v
4795− parseNodeStats (FullNodeId fullNID) node
4796− cn <- o .: "cluster_name"
4797− return (NodesStats stats cn)
4798−
4799−instance FromJSON NodeBreakerStats where
4800− parseJSON = withObject "NodeBreakerStats" parse
4801− where
4802− parse o = NodeBreakerStats <$> o .: "tripped"
4803− <*> o .: "overhead"
4804− <*> o .: "estimated_size_in_bytes"
4805− <*> o .: "limit_size_in_bytes"
4806−
4807−instance FromJSON NodeHTTPStats where
4808− parseJSON = withObject "NodeHTTPStats" parse
4809− where
4810− parse o = NodeHTTPStats <$> o .: "total_opened"
4811− <*> o .: "current_open"
4812−
4813−instance FromJSON NodeTransportStats where
4814− parseJSON = withObject "NodeTransportStats" parse
4815− where
4816− parse o = NodeTransportStats <$> o .: "tx_size_in_bytes"
4817− <*> o .: "tx_count"
4818− <*> o .: "rx_size_in_bytes"
4819− <*> o .: "rx_count"
4820− <*> o .: "server_open"
4821−
4822−instance FromJSON NodeFSStats where
4823− parseJSON = withObject "NodeFSStats" parse
4824− where
4825− parse o = NodeFSStats <$> o .: "data"
4826− <*> o .: "total"
4827− <*> (posixMS <$> o .: "timestamp")
4828−
4829−instance FromJSON NodeDataPathStats where
4830− parseJSON = withObject "NodeDataPathStats" parse
4831− where
4832− parse o =
4833− NodeDataPathStats <$> (fmap unStringlyTypedDouble <$> o .:? "disk_service_time")
4834− <*> (fmap unStringlyTypedDouble <$> o .:? "disk_queue")
4835− <*> o .:? "disk_io_size_in_bytes"
4836− <*> o .:? "disk_write_size_in_bytes"
4837− <*> o .:? "disk_read_size_in_bytes"
4838− <*> o .:? "disk_io_op"
4839− <*> o .:? "disk_writes"
4840− <*> o .:? "disk_reads"
4841− <*> o .: "available_in_bytes"
4842− <*> o .: "free_in_bytes"
4843− <*> o .: "total_in_bytes"
4844− <*> o .:? "type"
4845− <*> o .: "dev"
4846− <*> o .: "mount"
4847− <*> o .: "path"
4848−
4849−newtype StringlyTypedDouble = StringlyTypedDouble { unStringlyTypedDouble :: Double }
4850−
4851−
4852−instance FromJSON StringlyTypedDouble where
4853− parseJSON = fmap StringlyTypedDouble . parseJSON . unStringlyTypeJSON
4854−
4855−
4856−instance FromJSON NodeFSTotalStats where
4857− parseJSON = withObject "NodeFSTotalStats" parse
4858− where
4859− parse o = NodeFSTotalStats <$> (fmap unStringlyTypedDouble <$> o .:? "disk_service_time")
4860− <*> (fmap unStringlyTypedDouble <$> o .:? "disk_queue")
4861− <*> o .:? "disk_io_size_in_bytes"
4862− <*> o .:? "disk_write_size_in_bytes"
4863− <*> o .:? "disk_read_size_in_bytes"
4864− <*> o .:? "disk_io_op"
4865− <*> o .:? "disk_writes"
4866− <*> o .:? "disk_reads"
4867− <*> o .: "available_in_bytes"
4868− <*> o .: "free_in_bytes"
4869− <*> o .: "total_in_bytes"
4870−
4871−instance FromJSON NodeNetworkStats where
4872− parseJSON = withObject "NodeNetworkStats" parse
4873− where
4874− parse o = do
4875− tcp <- o .: "tcp"
4876− NodeNetworkStats <$> tcp .: "out_rsts"
4877− <*> tcp .: "in_errs"
4878− <*> tcp .: "attempt_fails"
4879− <*> tcp .: "estab_resets"
4880− <*> tcp .: "retrans_segs"
4881− <*> tcp .: "out_segs"
4882− <*> tcp .: "in_segs"
4883− <*> tcp .: "curr_estab"
4884− <*> tcp .: "passive_opens"
4885− <*> tcp .: "active_opens"
4886−
4887−instance FromJSON NodeThreadPoolsStats where
4888− parseJSON = withObject "NodeThreadPoolsStats" parse
4889− where
4890− parse o = NodeThreadPoolsStats <$> o .: "snapshot"
4891− <*> o .: "bulk"
4892− <*> o .: "merge"
4893− <*> o .: "get"
4894− <*> o .: "management"
4895− <*> o .:? "fetch_shard_store"
4896− <*> o .: "optimize"
4897− <*> o .: "flush"
4898− <*> o .: "search"
4899− <*> o .: "warmer"
4900− <*> o .: "generic"
4901− <*> o .: "suggest"
4902− <*> o .: "refresh"
4903− <*> o .: "index"
4904− <*> o .:? "listener"
4905− <*> o .:? "fetch_shard_started"
4906− <*> o .: "percolate"
4907−instance FromJSON NodeThreadPoolStats where
4908− parseJSON = withObject "NodeThreadPoolStats" parse
4909− where
4910− parse o = NodeThreadPoolStats <$> o .: "completed"
4911− <*> o .: "largest"
4912− <*> o .: "rejected"
4913− <*> o .: "active"
4914− <*> o .: "queue"
4915− <*> o .: "threads"
4916−
4917−instance FromJSON NodeJVMStats where
4918− parseJSON = withObject "NodeJVMStats" parse
4919− where
4920− parse o = do
4921− bufferPools <- o .: "buffer_pools"
4922− mapped <- bufferPools .: "mapped"
4923− direct <- bufferPools .: "direct"
4924− gc <- o .: "gc"
4925− collectors <- gc .: "collectors"
4926− oldC <- collectors .: "old"
4927− youngC <- collectors .: "young"
4928− threads <- o .: "threads"
4929− mem <- o .: "mem"
4930− pools <- mem .: "pools"
4931− oldM <- pools .: "old"
4932− survivorM <- pools .: "survivor"
4933− youngM <- pools .: "young"
4934− NodeJVMStats <$> pure mapped
4935− <*> pure direct
4936− <*> pure oldC
4937− <*> pure youngC
4938− <*> threads .: "peak_count"
4939− <*> threads .: "count"
4940− <*> pure oldM
4941− <*> pure survivorM
4942− <*> pure youngM
4943− <*> mem .: "non_heap_committed_in_bytes"
4944− <*> mem .: "non_heap_used_in_bytes"
4945− <*> mem .: "heap_max_in_bytes"
4946− <*> mem .: "heap_committed_in_bytes"
4947− <*> mem .: "heap_used_percent"
4948− <*> mem .: "heap_used_in_bytes"
4949− <*> (unMS <$> o .: "uptime_in_millis")
4950− <*> (posixMS <$> o .: "timestamp")
4951−
4952−instance FromJSON JVMBufferPoolStats where
4953− parseJSON = withObject "JVMBufferPoolStats" parse
4954− where
4955− parse o = JVMBufferPoolStats <$> o .: "total_capacity_in_bytes"
4956− <*> o .: "used_in_bytes"
4957− <*> o .: "count"
4958−
4959−instance FromJSON JVMGCStats where
4960− parseJSON = withObject "JVMGCStats" parse
4961− where
4962− parse o = JVMGCStats <$> (unMS <$> o .: "collection_time_in_millis")
4963− <*> o .: "collection_count"
4964−
4965−instance FromJSON JVMPoolStats where
4966− parseJSON = withObject "JVMPoolStats" parse
4967− where
4968− parse o = JVMPoolStats <$> o .: "peak_max_in_bytes"
4969− <*> o .: "peak_used_in_bytes"
4970− <*> o .: "max_in_bytes"
4971− <*> o .: "used_in_bytes"
4972−
4973−instance FromJSON NodeProcessStats where
4974− parseJSON = withObject "NodeProcessStats" parse
4975− where
4976− parse o = do
4977− mem <- o .: "mem"
4978− cpu <- o .: "cpu"
4979− NodeProcessStats <$> mem .: "total_virtual_in_bytes"
4980− <*> mem .: "share_in_bytes"
4981− <*> mem .: "resident_in_bytes"
4982− <*> (unMS <$> cpu .: "total_in_millis")
4983− <*> (unMS <$> cpu .: "user_in_millis")
4984− <*> (unMS <$> cpu .: "sys_in_millis")
4985− <*> cpu .: "percent"
4986− <*> o .: "open_file_descriptors"
4987− <*> (posixMS <$> o .: "timestamp")
4988−
4989−instance FromJSON NodeOSStats where
4990− parseJSON = withObject "NodeOSStats" parse
4991− where
4992− parse o = do
4993− swap <- o .: "swap"
4994− mem <- o .: "mem"
4995− cpu <- o .: "cpu"
4996− load <- o .:? "load_average"
4997− NodeOSStats <$> swap .: "free_in_bytes"
4998− <*> swap .: "used_in_bytes"
4999− <*> mem .: "actual_used_in_bytes"
5000− <*> mem .: "actual_free_in_bytes"
5001− <*> mem .: "used_percent"
5002− <*> mem .: "free_percent"
5003− <*> mem .: "used_in_bytes"
5004− <*> mem .: "free_in_bytes"
5005− <*> cpu .: "stolen"
5006− <*> cpu .: "usage"
5007− <*> cpu .: "idle"
5008− <*> cpu .: "user"
5009− <*> cpu .: "sys"
5010− <*> pure load
5011− <*> (unMS <$> o .: "uptime_in_millis")
5012− <*> (posixMS <$> o .: "timestamp")
5013−
5014−instance FromJSON LoadAvgs where
5015− parseJSON = withArray "LoadAvgs" parse
5016− where
5017− parse v = case V.toList v of
5018− [one, five, fifteen] -> LoadAvgs <$> parseJSON one
5019− <*> parseJSON five
5020− <*> parseJSON fifteen
5021− _ -> fail "Expecting a triple of Doubles"
5022−
5023−instance FromJSON NodeIndicesStats where
5024− parseJSON = withObject "NodeIndicesStats" parse
5025− where
5026− parse o = do
5027− let (.::) mv k = case mv of
5028− Just v -> Just <$> v .: k
5029− Nothing -> pure Nothing
5030− mRecovery <- o .:? "recovery"
5031− mQueryCache <- o .:? "query_cache"
5032− suggest <- o .: "suggest"
5033− translog <- o .: "translog"
5034− segments <- o .: "segments"
5035− completion <- o .: "completion"
5036− percolate <- o .: "percolate"
5037− fielddata <- o .: "fielddata"
5038− idCache <- o .: "id_cache"
5039− filterCache <- o .: "filter_cache"
5040− warmer <- o .: "warmer"
5041− flush <- o .: "flush"
5042− refresh <- o .: "refresh"
5043− merges <- o .: "merges"
5044− search <- o .: "search"
5045− getStats <- o .: "get"
5046− indexing <- o .: "indexing"
5047− store <- o .: "store"
5048− docs <- o .: "docs"
5049− NodeIndicesStats <$> (fmap unMS <$> mRecovery .:: "throttle_time_in_millis")
5050− <*> mRecovery .:: "current_as_target"
5051− <*> mRecovery .:: "current_as_source"
5052− <*> mQueryCache .:: "miss_count"
5053− <*> mQueryCache .:: "hit_count"
5054− <*> mQueryCache .:: "evictions"
5055− <*> mQueryCache .:: "memory_size_in_bytes"
5056− <*> suggest .: "current"
5057− <*> (unMS <$> suggest .: "time_in_millis")
5058− <*> suggest .: "total"
5059− <*> translog .: "size_in_bytes"
5060− <*> translog .: "operations"
5061− <*> segments .:? "fixed_bit_set_memory_in_bytes"
5062− <*> segments .: "version_map_memory_in_bytes"
5063− <*> segments .:? "index_writer_max_memory_in_bytes"
5064− <*> segments .: "index_writer_memory_in_bytes"
5065− <*> segments .: "memory_in_bytes"
5066− <*> segments .: "count"
5067− <*> completion .: "size_in_bytes"
5068− <*> percolate .: "queries"
5069− <*> percolate .: "memory_size_in_bytes"
5070− <*> percolate .: "current"
5071− <*> (unMS <$> percolate .: "time_in_millis")
5072− <*> percolate .: "total"
5073− <*> fielddata .: "evictions"
5074− <*> fielddata .: "memory_size_in_bytes"
5075− <*> idCache .: "memory_size_in_bytes"
5076− <*> filterCache .: "evictions"
5077− <*> filterCache .: "memory_size_in_bytes"
5078− <*> (unMS <$> warmer .: "total_time_in_millis")
5079− <*> warmer .: "total"
5080− <*> warmer .: "current"
5081− <*> (unMS <$> flush .: "total_time_in_millis")
5082− <*> flush .: "total"
5083− <*> (unMS <$> refresh .: "total_time_in_millis")
5084− <*> refresh .: "total"
5085− <*> merges .: "total_size_in_bytes"
5086− <*> merges .: "total_docs"
5087− <*> (unMS <$> merges .: "total_time_in_millis")
5088− <*> merges .: "total"
5089− <*> merges .: "current_size_in_bytes"
5090− <*> merges .: "current_docs"
5091− <*> merges .: "current"
5092− <*> search .: "fetch_current"
5093− <*> (unMS <$> search .: "fetch_time_in_millis")
5094− <*> search .: "fetch_total"
5095− <*> search .: "query_current"
5096− <*> (unMS <$> search .: "query_time_in_millis")
5097− <*> search .: "query_total"
5098− <*> search .: "open_contexts"
5099− <*> getStats .: "current"
5100− <*> (unMS <$> getStats .: "missing_time_in_millis")
5101− <*> getStats .: "missing_total"
5102− <*> (unMS <$> getStats .: "exists_time_in_millis")
5103− <*> getStats .: "exists_total"
5104− <*> (unMS <$> getStats .: "time_in_millis")
5105− <*> getStats .: "total"
5106− <*> (fmap unMS <$> indexing .:? "throttle_time_in_millis")
5107− <*> indexing .:? "is_throttled"
5108− <*> indexing .:? "noop_update_total"
5109− <*> indexing .: "delete_current"
5110− <*> (unMS <$> indexing .: "delete_time_in_millis")
5111− <*> indexing .: "delete_total"
5112− <*> indexing .: "index_current"
5113− <*> (unMS <$> indexing .: "index_time_in_millis")
5114− <*> indexing .: "index_total"
5115− <*> (unMS <$> store .: "throttle_time_in_millis")
5116− <*> store .: "size_in_bytes"
5117− <*> docs .: "deleted"
5118− <*> docs .: "count"
5119−
5120−instance FromJSON NodeBreakersStats where
5121− parseJSON = withObject "NodeBreakersStats" parse
5122− where
5123− parse o = NodeBreakersStats <$> o .: "parent"
5124− <*> o .: "request"
5125− <*> o .: "fielddata"
5126−
5127−parseNodeStats :: FullNodeId -> Object -> Parser NodeStats
5128−parseNodeStats fnid o = do
5129− NodeStats <$> o .: "name"
5130− <*> pure fnid
5131− <*> o .:? "breakers"
5132− <*> o .: "http"
5133− <*> o .: "transport"
5134− <*> o .: "fs"
5135− <*> o .: "network"
5136− <*> o .: "thread_pool"
5137− <*> o .: "jvm"
5138− <*> o .: "process"
5139− <*> o .: "os"
5140− <*> o .: "indices"
5141−
5142−parseNodeInfo :: FullNodeId -> Object -> Parser NodeInfo
5143−parseNodeInfo nid o =
5144− NodeInfo <$> o .: "http_address"
5145− <*> o .: "build"
5146− <*> o .: "version"
5147− <*> o .: "ip"
5148− <*> o .: "host"
5149− <*> o .: "transport_address"
5150− <*> o .: "name"
5151− <*> pure nid
5152− <*> o .: "plugins"
5153− <*> o .: "http"
5154− <*> o .: "transport"
5155− <*> o .: "network"
5156− <*> o .: "thread_pool"
5157− <*> o .: "jvm"
5158− <*> o .: "process"
5159− <*> o .: "os"
5160− <*> o .: "settings"
5161−
5162−instance FromJSON NodePluginInfo where
5163− parseJSON = withObject "NodePluginInfo" parse
5164− where
5165− parse o = NodePluginInfo <$> o .: "site"
5166− <*> o .: "jvm"
5167− <*> o .: "description"
5168− <*> o .: "version"
5169− <*> o .: "name"
5170−
5171−instance FromJSON NodeHTTPInfo where
5172− parseJSON = withObject "NodeHTTPInfo" parse
5173− where
5174− parse o = NodeHTTPInfo <$> o .: "max_content_length_in_bytes"
5175− <*> parseJSON (Object o)
5176−
5177−instance FromJSON BoundTransportAddress where
5178− parseJSON = withObject "BoundTransportAddress" parse
5179− where
5180− parse o = BoundTransportAddress <$> o .: "publish_address"
5181− <*> o .: "bound_address"
5182−
5183−instance FromJSON NodeOSInfo where
5184− parseJSON = withObject "NodeOSInfo" parse
5185− where
5186− parse o = do
5187− swap <- o .: "swap"
5188− mem <- o .: "mem"
5189− NodeOSInfo <$> swap .: "total_in_bytes"
5190− <*> mem .: "total_in_bytes"
5191− <*> o .: "cpu"
5192− <*> o .: "available_processors"
5193− <*> (unMS <$> o .: "refresh_interval_in_millis")
5194−
5195−
5196−instance FromJSON CPUInfo where
5197− parseJSON = withObject "CPUInfo" parse
5198− where
5199− parse o = CPUInfo <$> o .: "cache_size_in_bytes"
5200− <*> o .: "cores_per_socket"
5201− <*> o .: "total_sockets"
5202− <*> o .: "total_cores"
5203− <*> o .: "mhz"
5204− <*> o .: "model"
5205− <*> o .: "vendor"
5206−
5207−instance FromJSON NodeProcessInfo where
5208− parseJSON = withObject "NodeProcessInfo" parse
5209− where
5210− parse o = NodeProcessInfo <$> o .: "mlockall"
5211− <*> o .: "max_file_descriptors"
5212− <*> o .: "id"
5213− <*> (unMS <$> o .: "refresh_interval_in_millis")
5214−
5215−instance FromJSON NodeJVMInfo where
5216− parseJSON = withObject "NodeJVMInfo" parse
5217− where
5218− parse o = NodeJVMInfo <$> o .: "memory_pools"
5219− <*> o .: "gc_collectors"
5220− <*> o .: "mem"
5221− <*> (posixMS <$> o .: "start_time_in_millis")
5222− <*> o .: "vm_vendor"
5223− <*> o .: "vm_version"
5224− <*> o .: "vm_name"
5225− <*> (unJVMVersion <$> o .: "version")
5226− <*> o .: "pid"
5227−
5228−instance FromJSON JVMVersion where
5229− parseJSON (String t) =
5230− JVMVersion <$> parseJSON (String (T.replace "_" "." t))
5231− parseJSON v = JVMVersion <$> parseJSON v
5232−
5233−instance FromJSON JVMMemoryInfo where
5234− parseJSON = withObject "JVMMemoryInfo" parse
5235− where
5236− parse o = JVMMemoryInfo <$> o .: "direct_max_in_bytes"
5237− <*> o .: "non_heap_max_in_bytes"
5238− <*> o .: "non_heap_init_in_bytes"
5239− <*> o .: "heap_max_in_bytes"
5240− <*> o .: "heap_init_in_bytes"
5241−
5242−instance FromJSON NodeThreadPoolsInfo where
5243− parseJSON = withObject "NodeThreadPoolsInfo" parse
5244− where
5245− parse o = NodeThreadPoolsInfo <$> o .: "refresh"
5246− <*> o .: "management"
5247− <*> o .: "percolate"
5248− <*> o .:? "listener"
5249− <*> o .:? "fetch_shard_started"
5250− <*> o .: "search"
5251− <*> o .: "flush"
5252− <*> o .: "warmer"
5253− <*> o .: "optimize"
5254− <*> o .: "bulk"
5255− <*> o .: "suggest"
5256− <*> o .: "merge"
5257− <*> o .: "snapshot"
5258− <*> o .: "get"
5259− <*> o .:? "fetch_shard_store"
5260− <*> o .: "index"
5261− <*> o .: "generic"
5262−
5263−instance FromJSON NodeThreadPoolInfo where
5264− parseJSON = withObject "NodeThreadPoolInfo" parse
5265− where
5266− parse o = do
5267− ka <- maybe (return Nothing) (fmap Just . parseStringInterval) =<< o .:? "keep_alive"
5268− NodeThreadPoolInfo <$> (parseJSON . unStringlyTypeJSON =<< o .: "queue_size")
5269− <*> pure ka
5270− <*> o .:? "min"
5271− <*> o .:? "max"
5272− <*> o .: "type"
5273−
5274−parseStringInterval :: (Monad m) => String -> m NominalDiffTime
5275−parseStringInterval s = case span isNumber s of
5276− ("", _) -> fail "Invalid interval"
5277− (nS, unitS) -> case (readMay nS, readMay unitS) of
5278− (Just n, Just unit) -> return (fromInteger (n * unitNDT unit))
5279− (Nothing, _) -> fail "Invalid interval number"
5280− (_, Nothing) -> fail "Invalid interval unit"
5281− where
5282− unitNDT Seconds = 1
5283− unitNDT Minutes = 60
5284− unitNDT Hours = 60 * 60
5285− unitNDT Days = 24 * 60 * 60
5286− unitNDT Weeks = 7 * 24 * 60 * 60
5287−
5288−instance FromJSON ThreadPoolSize where
5289− parseJSON v = parseAsNumber v <|> parseAsString v
5290− where
5291− parseAsNumber = parseAsInt <=< parseJSON
5292− parseAsInt (-1) = return ThreadPoolUnbounded
5293− parseAsInt n
5294− | n >= 0 = return (ThreadPoolBounded n)
5295− | otherwise = fail "Thread pool size must be >= -1."
5296− parseAsString = withText "ThreadPoolSize" $ \t ->
5297− case first (readMay . T.unpack) (T.span isNumber t) of
5298− (Just n, "k") -> return (ThreadPoolBounded (n * 1000))
5299− (Just n, "") -> return (ThreadPoolBounded n)
5300− _ -> fail ("Invalid thread pool size " <> T.unpack t)
5301−
5302−instance FromJSON ThreadPoolType where
5303− parseJSON = withText "ThreadPoolType" parse
5304− where
5305− parse "scaling" = return ThreadPoolScaling
5306− parse "fixed" = return ThreadPoolFixed
5307− parse "cached" = return ThreadPoolCached
5308− parse e = fail ("Unexpected thread pool type" <> T.unpack e)
5309−
5310−instance FromJSON NodeTransportInfo where
5311− parseJSON = withObject "NodeTransportInfo" parse
5312− where
5313− parse o = NodeTransportInfo <$> (maybe (return mempty) parseProfiles =<< o .:? "profiles")
5314− <*> parseJSON (Object o)
5315− parseProfiles (Object o) | HM.null o = return []
5316− parseProfiles v@(Array _) = parseJSON v
5317− parseProfiles Null = return []
5318− parseProfiles _ = fail "Could not parse profiles"
5319−
5320−instance FromJSON NodeNetworkInfo where
5321− parseJSON = withObject "NodeNetworkInfo" parse
5322− where
5323− parse o = NodeNetworkInfo <$> o .: "primary_interface"
5324− <*> (unMS <$> o .: "refresh_interval_in_millis")
5325−
5326−
5327−instance FromJSON NodeNetworkInterface where
5328− parseJSON = withObject "NodeNetworkInterface" parse
5329− where
5330− parse o = NodeNetworkInterface <$> o .: "mac_address"
5331− <*> o .: "name"
5332− <*> o .: "address"
5333−
5334−newtype MaybeNA a = MaybeNA { unMaybeNA :: Maybe a }
5335− deriving (Show, Eq)
5336−
5337−instance FromJSON a => FromJSON (MaybeNA a) where
5338− parseJSON (String "NA") = pure $ MaybeNA Nothing
5339− parseJSON o = MaybeNA . Just <$> parseJSON o
5340−
5341−
5342−data Suggest = Suggest { suggestText :: Text
5343− , suggestName :: Text
5344− , suggestType :: SuggestType
5345− }
5346− deriving (Show, Generic, Eq, Read, Typeable)
5347−
5348−instance ToJSON Suggest where
5349− toJSON Suggest{..} = object [ "text" .= suggestText
5350− , suggestName .= suggestType
5351− ]
5352−
5353−instance FromJSON Suggest where
5354− parseJSON (Object o) = do
5355− suggestText' <- o .: "text"
5356− let dropTextList = HM.toList $ HM.filterWithKey (\x _ -> x /= "text") o
5357− suggestName' <- case dropTextList of
5358− [(x, _)] -> return x
5359− _ -> fail "error parsing Suggest field name"
5360− suggestType' <- o .: suggestName'
5361− return $ Suggest suggestText' suggestName' suggestType'
5362− parseJSON x = typeMismatch "Suggest" x
5363−
5364−data SuggestType = SuggestTypePhraseSuggester PhraseSuggester
5365− deriving (Show, Generic, Eq, Read, Typeable)
5366−
5367−instance ToJSON SuggestType where
5368− toJSON (SuggestTypePhraseSuggester x) = object ["phrase" .= x]
5369−
5370−instance FromJSON SuggestType where
5371− parseJSON = withObject "SuggestType" parse
5372− where parse o = phraseSuggester `taggedWith` "phrase"
5373− where taggedWith parser k = parser =<< o .: k
5374− phraseSuggester = pure . SuggestTypePhraseSuggester
5375−
5376−data PhraseSuggester =
5377− PhraseSuggester { phraseSuggesterField :: FieldName
5378− , phraseSuggesterGramSize :: Maybe Int
5379− , phraseSuggesterRealWordErrorLikelihood :: Maybe Int
5380− , phraseSuggesterConfidence :: Maybe Int
5381− , phraseSuggesterMaxErrors :: Maybe Int
5382− , phraseSuggesterSeparator :: Maybe Text
5383− , phraseSuggesterSize :: Maybe Size
5384− , phraseSuggesterAnalyzer :: Maybe Analyzer
5385− , phraseSuggesterShardSize :: Maybe Int
5386− , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
5387− , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
5388− , phraseSuggesterCandidateGenerators :: [DirectGenerators]
5389− }
5390− deriving (Show, Generic, Eq, Read, Typeable)
5391−
5392−instance ToJSON PhraseSuggester where
5393− toJSON PhraseSuggester{..} = omitNulls [ "field" .= phraseSuggesterField
5394− , "gram_size" .= phraseSuggesterGramSize
5395− , "real_word_error_likelihood" .= phraseSuggesterRealWordErrorLikelihood
5396− , "confidence" .= phraseSuggesterConfidence
5397− , "max_errors" .= phraseSuggesterMaxErrors
5398− , "separator" .= phraseSuggesterSeparator
5399− , "size" .= phraseSuggesterSize
5400− , "analyzer" .= phraseSuggesterAnalyzer
5401− , "shard_size" .= phraseSuggesterShardSize
5402− , "highlight" .= phraseSuggesterHighlight
5403− , "collate" .= phraseSuggesterCollate
5404− , "direct_generator" .= phraseSuggesterCandidateGenerators
5405− ]
5406−
5407−instance FromJSON PhraseSuggester where
5408− parseJSON = withObject "PhraseSuggester" parse
5409− where parse o = PhraseSuggester
5410− <$> o .: "field"
5411− <*> o .:? "gram_size"
5412− <*> o .:? "real_word_error_likelihood"
5413− <*> o .:? "confidence"
5414− <*> o .:? "max_errors"
5415− <*> o .:? "separator"
5416− <*> o .:? "size"
5417− <*> o .:? "analyzer"
5418− <*> o .:? "shard_size"
5419− <*> o .:? "highlight"
5420− <*> o .:? "collate"
5421− <*> o .:? "direct_generator" .!= []
5422−
5423−mkPhraseSuggester :: FieldName -> PhraseSuggester
5424−mkPhraseSuggester fName =
5425− PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
5426− Nothing Nothing Nothing Nothing []
5427−
5428−data PhraseSuggesterHighlighter =
5429− PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
5430− , phraseSuggesterHighlighterPostTag :: Text
5431− }
5432− deriving (Show, Generic, Eq, Read, Typeable)
5433−
5434−instance ToJSON PhraseSuggesterHighlighter where
5435− toJSON PhraseSuggesterHighlighter{..} =
5436− object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
5437− , "post_tag" .= phraseSuggesterHighlighterPostTag
5438− ]
5439−
5440−instance FromJSON PhraseSuggesterHighlighter where
5441− parseJSON = withObject "PhraseSuggesterHighlighter" parse
5442− where parse o = PhraseSuggesterHighlighter
5443− <$> o .: "pre_tag"
5444− <*> o .: "post_tag"
5445−
5446−data PhraseSuggesterCollate =
5447− PhraseSuggesterCollate { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
5448− , phraseSuggesterCollatePrune :: Bool
5449− }
5450− deriving (Show, Generic, Eq, Read, Typeable)
5451−
5452−instance ToJSON PhraseSuggesterCollate where
5453− toJSON PhraseSuggesterCollate{..} = object [ "query" .= object
5454− [ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
5455− ]
5456− , "params" .= (params phraseSuggesterCollateTemplateQuery)
5457− , "prune" .= phraseSuggesterCollatePrune
5458− ]
5459−
5460−instance FromJSON PhraseSuggesterCollate where
5461− parseJSON (Object o) = do
5462− query' <- o .: "query"
5463− inline' <- query' .: "inline"
5464− params' <- o .: "params"
5465− prune' <- o .:? "prune" .!= False
5466− return $ PhraseSuggesterCollate (TemplateQueryInline inline' params') prune'
5467− parseJSON x = typeMismatch "PhraseSuggesterCollate" x
5468−
5469−data SuggestOptions =
5470− SuggestOptions { suggestOptionsText :: Text
5471− , suggestOptionsScore :: Double
5472− , suggestOptionsFreq :: Maybe Int
5473− , suggestOptionsHighlighted :: Maybe Text
5474− }
5475− deriving (Eq, Read, Show)
5476−
5477−instance FromJSON SuggestOptions where
5478− parseJSON = withObject "SuggestOptions" parse
5479− where parse o = SuggestOptions
5480− <$> o .: "text"
5481− <*> o .: "score"
5482− <*> o .:? "freq"
5483− <*> o .:? "highlighted"
5484−
5485−data SuggestResponse =
5486− SuggestResponse { suggestResponseText :: Text
5487− , suggestResponseOffset :: Int
5488− , suggestResponseLength :: Int
5489− , suggestResponseOptions :: [SuggestOptions]
5490− }
5491− deriving (Eq, Read, Show)
5492−
5493−instance FromJSON SuggestResponse where
5494− parseJSON = withObject "SuggestResponse" parse
5495− where parse o = SuggestResponse
5496− <$> o .: "text"
5497− <*> o .: "offset"
5498− <*> o .: "length"
5499− <*> o .: "options"
5500−
5501−data NamedSuggestionResponse =
5502− NamedSuggestionResponse { nsrName :: Text
5503− , nsrResponses :: [SuggestResponse]
5504− }
5505− deriving (Eq, Read, Show)
5506−
5507−instance FromJSON NamedSuggestionResponse where
5508− parseJSON (Object o) = do
5509− suggestionName' <- case HM.toList o of
5510− [(x, _)] -> return x
5511− _ -> fail "error parsing NamedSuggestionResponse name"
5512− suggestionResponses' <- o .: suggestionName'
5513− return $ NamedSuggestionResponse suggestionName' suggestionResponses'
5514−
5515− parseJSON x = typeMismatch "NamedSuggestionResponse" x
5516−
5517−data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing
5518− | DirectGeneratorSuggestModePopular
5519− | DirectGeneratorSuggestModeAlways
5520− deriving (Show, Eq, Read, Generic, Typeable)
5521−
5522−instance ToJSON DirectGeneratorSuggestModeTypes where
5523− toJSON DirectGeneratorSuggestModeMissing = "missing"
5524− toJSON DirectGeneratorSuggestModePopular = "popular"
5525− toJSON DirectGeneratorSuggestModeAlways = "always"
5526−
5527−instance FromJSON DirectGeneratorSuggestModeTypes where
5528− parseJSON = withText "DirectGeneratorSuggestModeTypes" parse
5529− where parse "missing" = pure DirectGeneratorSuggestModeMissing
5530− parse "popular" = pure DirectGeneratorSuggestModePopular
5531− parse "always" = pure DirectGeneratorSuggestModeAlways
5532− parse f = fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f)
5533−
5534−data DirectGenerators = DirectGenerators
5535− { directGeneratorsField :: FieldName
5536− , directGeneratorsSize :: Maybe Int
5537− , directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes
5538− , directGeneratorMaxEdits :: Maybe Double
5539− , directGeneratorPrefixLength :: Maybe Int
5540− , directGeneratorMinWordLength :: Maybe Int
5541− , directGeneratorMaxInspections :: Maybe Int
5542− , directGeneratorMinDocFreq :: Maybe Double
5543− , directGeneratorMaxTermFreq :: Maybe Double
5544− , directGeneratorPreFilter :: Maybe Text
5545− , directGeneratorPostFilter :: Maybe Text
5546− }
5547− deriving (Show, Eq, Read, Generic, Typeable)
5548−
5549−
5550−instance ToJSON DirectGenerators where
5551− toJSON DirectGenerators{..} = omitNulls [ "field" .= directGeneratorsField
5552− , "size" .= directGeneratorsSize
5553− , "suggest_mode" .= directGeneratorSuggestMode
5554− , "max_edits" .= directGeneratorMaxEdits
5555− , "prefix_length" .= directGeneratorPrefixLength
5556− , "min_word_length" .= directGeneratorMinWordLength
5557− , "max_inspections" .= directGeneratorMaxInspections
5558− , "min_doc_freq" .= directGeneratorMinDocFreq
5559− , "max_term_freq" .= directGeneratorMaxTermFreq
5560− , "pre_filter" .= directGeneratorPreFilter
5561− , "post_filter" .= directGeneratorPostFilter
5562− ]
5563−
5564−instance FromJSON DirectGenerators where
5565− parseJSON = withObject "DirectGenerators" parse
5566− where parse o = DirectGenerators
5567− <$> o .: "field"
5568− <*> o .:? "size"
5569− <*> o .: "suggest_mode"
5570− <*> o .:? "max_edits"
5571− <*> o .:? "prefix_length"
5572− <*> o .:? "min_word_length"
5573− <*> o .:? "max_inspections"
5574− <*> o .:? "min_doc_freq"
5575− <*> o .:? "max_term_freq"
5576− <*> o .:? "pre_filter"
5577− <*> o .:? "post_filter"
5578−
5579−mkDirectGenerators :: FieldName -> DirectGenerators
5580−mkDirectGenerators fn = DirectGenerators fn Nothing DirectGeneratorSuggestModeMissing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
src/Database/V1/Bloodhound/Types/Class.hsdeleted−17
@@ -1,17 +0,0 @@
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/V1/Bloodhound/Types/Internal.hsdeleted−57
@@ -1,57 +0,0 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−
6−-------------------------------------------------------------------------------
7−-- |
8−-- Module : Database.Bloodhound.Types.Internal
9−-- Copyright : (C) 2014 Chris Allen
10−-- License : BSD-style (see the file LICENSE)
11−-- Maintainer : Chris Allen <cma@bitemyapp.com>
12−-- Stability : provisional
13−-- Portability : DeriveGeneric, RecordWildCards
14−--
15−-- Internal data types for Bloodhound. These types may change without
16−-- notice so import at your own risk.
17−-------------------------------------------------------------------------------
18−module Database.V1.Bloodhound.Types.Internal
19− ( BHEnv(..)
20− , Server(..)
21− , MonadBH(..)
22− ) where
23−
24−
25−import Control.Applicative as A
26−import Control.Monad.Reader
27−import Data.Aeson
28−import Data.Text (Text)
29−import Data.Typeable (Typeable)
30−import GHC.Generics (Generic)
31−import Network.HTTP.Client
32−
33−{-| Common environment for Elasticsearch calls. Connections will be
34− pipelined according to the provided HTTP connection manager.
35−-}
36−data BHEnv = BHEnv { bhServer :: Server
37− , bhManager :: Manager
38− , bhRequestHook :: Request -> IO Request
39− -- ^ Low-level hook that is run before every request is sent. Used to implement custom authentication strategies. Defaults to 'return' with 'mkBHEnv'.
40− }
41−
42−instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) where
43− getBHEnv = ask
44−
45−{-| 'Server' is used with the client functions to point at the ES instance
46−-}
47−newtype Server = Server Text deriving (Eq, Show, Generic, Typeable, FromJSON)
48−
49−{-| All API calls to Elasticsearch operate within
50− MonadBH
51− . The idea is that it can be easily embedded in your
52− own monad transformer stack. A default instance for a ReaderT and
53− alias 'BH' is provided for the simple case.
54−-}
55−class (Functor m, A.Applicative m, MonadIO m) => MonadBH m where
56− getBHEnv :: m BHEnv
57−
src/Database/V5/Bloodhound.hsdeleted−10
@@ -1,10 +0,0 @@
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/V5/Bloodhound/Types.hsdeleted−1820
@@ -1,1820 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE NamedFieldPuns #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE RecordWildCards #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−
10−-------------------------------------------------------------------------------
11−-- |
12−-- Module : Database.Bloodhound.Types
13−-- Copyright : (C) 2014, 2015, 2016 Chris Allen
14−-- License : BSD-style (see the file LICENSE)
15−-- Maintainer : Chris Allen <cma@bitemyapp.com
16−-- Stability : provisional
17−-- Portability : RecordWildCards
18−--
19−-- Data types for describing actions and data structures performed to interact
20−-- with Elasticsearch. The two main buckets your queries against Elasticsearch
21−-- will fall into are 'Query's and 'Filter's. 'Filter's are more like
22−-- traditional database constraints and often have preferable performance
23−-- properties. 'Query's support human-written textual queries, such as fuzzy
24−-- queries.
25−-------------------------------------------------------------------------------
26−
27−
28−
29−module Database.V5.Bloodhound.Types
30− ( defaultCache
31− , defaultIndexSettings
32− , defaultIndexDocumentSettings
33− , mkSort
34− , showText
35− , unpackId
36− , mkMatchQuery
37− , mkMultiMatchQuery
38− , mkBoolQuery
39− , mkRangeQuery
40− , mkQueryStringQuery
41− , mkAggregations
42− , mkTermsAggregation
43− , mkTermsScriptAggregation
44− , mkDateHistogram
45− , mkCardinalityAggregation
46− , mkDocVersion
47− , mkStatsAggregation
48− , mkExtendedStatsAggregation
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− , Compression(..)
75− , ReplicaBounds(..)
76− , Bytes(..)
77− , gigabytes
78− , megabytes
79− , kilobytes
80− , FSType(..)
81− , InitialShardCount(..)
82− , NodeAttrFilter(..)
83− , NodeAttrName(..)
84− , CompoundFormat(..)
85− , IndexTemplate(..)
86− , Server(..)
87− , Reply
88− , EsResult(..)
89− , EsResultFound(..)
90− , EsError(..)
91− , EsProtocolException(..)
92− , IndexAlias(..)
93− , IndexAliasName(..)
94− , IndexAliasAction(..)
95− , IndexAliasCreate(..)
96− , IndexAliasSummary(..)
97− , IndexAliasesSummary(..)
98− , AliasRouting(..)
99− , SearchAliasRouting(..)
100− , IndexAliasRouting(..)
101− , RoutingValue(..)
102− , DocVersion
103− , ExternalDocVersion(..)
104− , VersionControl(..)
105− , DocumentParent(..)
106− , IndexDocumentSettings(..)
107− , Query(..)
108− , Search(..)
109− , SearchType(..)
110− , SearchResult(..)
111− , ScrollId(..)
112− , SearchHits(..)
113− , TrackSortScores
114− , From(..)
115− , Size(..)
116− , Source(..)
117− , PatternOrPatterns(..)
118− , Include(..)
119− , Exclude(..)
120− , Pattern(..)
121− , ShardResult(..)
122− , Hit(..)
123− , HitFields(..)
124− , Filter(..)
125− , Seminearring(..)
126− , BoolMatch(..)
127− , Term(..)
128− , GeoPoint(..)
129− , GeoBoundingBoxConstraint(..)
130− , GeoBoundingBox(..)
131− , GeoFilterType(..)
132− , Distance(..)
133− , DistanceUnit(..)
134− , DistanceType(..)
135− , DistanceRange(..)
136− , OptimizeBbox(..)
137− , LatLon(..)
138− , RangeValue(..)
139− , RangeExecution(..)
140− , LessThan(..)
141− , LessThanEq(..)
142− , GreaterThan(..)
143− , GreaterThanEq(..)
144− , LessThanD(..)
145− , LessThanEqD(..)
146− , GreaterThanD(..)
147− , GreaterThanEqD(..)
148− , Regexp(..)
149− , RegexpFlags(..)
150− , RegexpFlag(..)
151− , FieldName(..)
152− , ScriptFields(..)
153− , ScriptFieldName
154− , ScriptFieldValue
155− , Script(..)
156− , ScriptLanguage(..)
157− , ScriptInline(..)
158− , ScriptId(..)
159− , ScriptParams(..)
160− , ScriptParamName
161− , ScriptParamValue
162− , IndexName(..)
163− , IndexSelection(..)
164− , NodeSelection(..)
165− , NodeSelector(..)
166− , ForceMergeIndexSettings(..)
167− , defaultForceMergeIndexSettings
168− , TemplateName(..)
169− , TemplatePattern(..)
170− , MappingName(..)
171− , DocId(..)
172− , CacheName(..)
173− , CacheKey(..)
174− , BulkOperation(..)
175− , ReplicaCount(..)
176− , ShardCount(..)
177− , Sort
178− , SortMode(..)
179− , SortOrder(..)
180− , SortSpec(..)
181− , DefaultSort(..)
182− , Missing(..)
183− , OpenCloseIndex(..)
184− , Method
185− , Boost(..)
186− , MatchQuery(..)
187− , MultiMatchQuery(..)
188− , BoolQuery(..)
189− , BoostingQuery(..)
190− , CommonTermsQuery(..)
191− , FunctionScoreQuery(..)
192− , BoostMode(..)
193− , ScoreMode(..)
194− , FunctionScoreFunctions(..)
195− , ComponentFunctionScoreFunction(..)
196− , FunctionScoreFunction(..)
197− , Weight(..)
198− , Seed(..)
199− , FieldValueFactor(..)
200− , Factor(..)
201− , FactorModifier(..)
202− , FactorMissingFieldValue(..)
203− , DisMaxQuery(..)
204− , FuzzyLikeThisQuery(..)
205− , FuzzyLikeFieldQuery(..)
206− , FuzzyQuery(..)
207− , HasChildQuery(..)
208− , HasParentQuery(..)
209− , IndicesQuery(..)
210− , MoreLikeThisQuery(..)
211− , MoreLikeThisFieldQuery(..)
212− , NestedQuery(..)
213− , PrefixQuery(..)
214− , QueryStringQuery(..)
215− , SimpleQueryStringQuery(..)
216− , RangeQuery(..)
217− , RegexpQuery(..)
218− , QueryString(..)
219− , TemplateQueryInline(..)
220− , TemplateQueryKeyValuePairs(..)
221− , BooleanOperator(..)
222− , ZeroTermsQuery(..)
223− , CutoffFrequency(..)
224− , Analyzer(..)
225− , Tokenizer(..)
226− , TokenFilter(..)
227− , MaxExpansions(..)
228− , Lenient(..)
229− , MatchQueryType(..)
230− , MultiMatchQueryType(..)
231− , Tiebreaker(..)
232− , MinimumMatch(..)
233− , DisableCoord(..)
234− , CommonMinimumMatch(..)
235− , MinimumMatchHighLow(..)
236− , PrefixLength(..)
237− , Fuzziness(..)
238− , IgnoreTermFrequency(..)
239− , MaxQueryTerms(..)
240− , ScoreType(..)
241− , Score
242− , Cache
243− , TypeName(..)
244− , BoostTerms(..)
245− , MaxWordLength(..)
246− , MinWordLength(..)
247− , MaxDocFrequency(..)
248− , MinDocFrequency(..)
249− , PhraseSlop(..)
250− , StopWord(..)
251− , QueryPath(..)
252− , MinimumTermFrequency(..)
253− , PercentMatch(..)
254− , FieldDefinition(..)
255− , MappingField(..)
256− , Mapping(..)
257− , AllowLeadingWildcard(..)
258− , LowercaseExpanded(..)
259− , GeneratePhraseQueries(..)
260− , Locale(..)
261− , AnalyzeWildcard(..)
262− , EnablePositionIncrements(..)
263− , SimpleQueryFlag(..)
264− , FieldOrFields(..)
265− , Monoid(..)
266− , ToJSON(..)
267− , Interval(..)
268− , TimeInterval(..)
269− , ExecutionHint(..)
270− , CollectionMode(..)
271− , TermOrder(..)
272− , TermInclusion(..)
273− , SnapshotRepoSelection(..)
274− , GenericSnapshotRepo(..)
275− , SnapshotRepo(..)
276− , SnapshotRepoConversionError(..)
277− , SnapshotRepoType(..)
278− , GenericSnapshotRepoSettings(..)
279− , SnapshotRepoUpdateSettings(..)
280− , defaultSnapshotRepoUpdateSettings
281− , SnapshotRepoName(..)
282− , SnapshotRepoPattern(..)
283− , SnapshotVerification(..)
284− , SnapshotNodeVerification(..)
285− , FullNodeId(..)
286− , NodeName(..)
287− , ClusterName(..)
288− , NodesInfo(..)
289− , NodesStats(..)
290− , NodeStats(..)
291− , NodeBreakersStats(..)
292− , NodeBreakerStats(..)
293− , NodeHTTPStats(..)
294− , NodeTransportStats(..)
295− , NodeFSStats(..)
296− , NodeDataPathStats(..)
297− , NodeFSTotalStats(..)
298− , NodeNetworkStats(..)
299− , NodeThreadPoolsStats(..)
300− , NodeThreadPoolStats(..)
301− , NodeJVMStats(..)
302− , JVMBufferPoolStats(..)
303− , JVMGCStats(..)
304− , JVMPoolStats(..)
305− , NodeProcessStats(..)
306− , NodeOSStats(..)
307− , LoadAvgs(..)
308− , NodeIndicesStats(..)
309− , EsAddress(..)
310− , PluginName(..)
311− , NodeInfo(..)
312− , NodePluginInfo(..)
313− , NodeHTTPInfo(..)
314− , NodeTransportInfo(..)
315− , BoundTransportAddress(..)
316− , NodeNetworkInfo(..)
317− , MacAddress(..)
318− , NetworkInterfaceName(..)
319− , NodeNetworkInterface(..)
320− , NodeThreadPoolsInfo(..)
321− , NodeThreadPoolInfo(..)
322− , ThreadPoolSize(..)
323− , ThreadPoolType(..)
324− , NodeJVMInfo(..)
325− , JVMMemoryPool(..)
326− , JVMGCCollector(..)
327− , JVMMemoryInfo(..)
328− , PID(..)
329− , NodeOSInfo(..)
330− , CPUInfo(..)
331− , NodeProcessInfo(..)
332− , FsSnapshotRepo(..)
333− , SnapshotCreateSettings(..)
334− , defaultSnapshotCreateSettings
335− , SnapshotSelection(..)
336− , SnapshotPattern(..)
337− , SnapshotInfo(..)
338− , SnapshotShardFailure(..)
339− , ShardId(..)
340− , SnapshotName(..)
341− , SnapshotState(..)
342− , SnapshotRestoreSettings(..)
343− , defaultSnapshotRestoreSettings
344− , RestoreRenamePattern(..)
345− , RestoreRenameToken(..)
346− , RRGroupRefNum
347− , rrGroupRefNum
348− , mkRRGroupRefNum
349− , RestoreIndexSettings(..)
350− , Suggest(..)
351− , SuggestType(..)
352− , PhraseSuggester(..)
353− , PhraseSuggesterHighlighter(..)
354− , PhraseSuggesterCollate(..)
355− , mkPhraseSuggester
356− , SuggestOptions(..)
357− , SuggestResponse(..)
358− , NamedSuggestionResponse(..)
359− , DirectGenerators(..)
360− , mkDirectGenerators
361− , DirectGeneratorSuggestModeTypes (..)
362−
363− , Aggregation(..)
364− , Aggregations
365− , AggregationResults
366− , BucketValue(..)
367− , Bucket(..)
368− , BucketAggregation(..)
369− , TermsAggregation(..)
370− , MissingAggregation(..)
371− , ValueCountAggregation(..)
372− , FilterAggregation(..)
373− , CardinalityAggregation(..)
374− , DateHistogramAggregation(..)
375− , DateRangeAggregation(..)
376− , DateRangeAggRange(..)
377− , DateMathExpr(..)
378− , DateMathAnchor(..)
379− , DateMathModifier(..)
380− , DateMathUnit(..)
381− , TopHitsAggregation(..)
382− , StatisticsAggregation(..)
383−
384− , Highlights(..)
385− , FieldHighlight(..)
386− , HighlightSettings(..)
387− , PlainHighlight(..)
388− , PostingsHighlight(..)
389− , FastVectorHighlight(..)
390− , CommonHighlight(..)
391− , NonPostings(..)
392− , HighlightEncoder(..)
393− , HighlightTag(..)
394− , HitHighlight
395−
396− , MissingResult(..)
397− , TermsResult(..)
398− , DateHistogramResult(..)
399− , DateRangeResult(..)
400− , TopHitResult(..)
401−
402− , EsUsername(..)
403− , EsPassword(..)
404−
405− , Analysis(..)
406− , AnalyzerDefinition(..)
407− , TokenizerDefinition(..)
408− , TokenFilterDefinition(..)
409− , Ngram(..)
410− , TokenChar(..)
411− , Shingle(..)
412− , Language(..)
413− ) where
414−
415−import Bloodhound.Import
416−
417−import qualified Data.Traversable as DT
418−import qualified Data.HashMap.Strict as HM
419−import qualified Data.Map.Strict as M
420−import qualified Data.Text as T
421−
422−import Database.V5.Bloodhound.Types.Class
423−import Database.V5.Bloodhound.Internal.Analysis
424−import Database.V5.Bloodhound.Internal.Client
425−import Database.V5.Bloodhound.Internal.Newtypes
426−import Database.V5.Bloodhound.Internal.Query
427−import Database.V5.Bloodhound.Internal.StringlyTyped
428−
429−{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order
430− dependent with later sorts acting as tie-breakers for earlier sorts.
431−-}
432−type Sort = [SortSpec]
433−
434−{-| The two main kinds of 'SortSpec' are 'DefaultSortSpec' and
435− 'GeoDistanceSortSpec'. The latter takes a 'SortOrder', 'GeoPoint', and
436− 'DistanceUnit' to express "nearness" to a single geographical point as a
437− sort specification.
438−
439−<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
440−-}
441−data SortSpec = DefaultSortSpec DefaultSort
442− | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit deriving (Eq, Show)
443−
444−{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a
445− 'mkSort' convenience function for when you want to specify only the most
446− common parameters.
447−
448− The `ignoreUnmapped`, when `Just` field is used to set the elastic 'unmapped_type'
449−
450−<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
451−-}
452−data DefaultSort =
453− DefaultSort { sortFieldName :: FieldName
454− , sortOrder :: SortOrder
455− -- default False
456− , ignoreUnmapped :: Maybe Text
457− , sortMode :: Maybe SortMode
458− , missingSort :: Maybe Missing
459− , nestedFilter :: Maybe Filter } deriving (Eq, Show)
460−
461−{-| 'SortOrder' is 'Ascending' or 'Descending', as you might expect. These get
462− encoded into "asc" or "desc" when turned into JSON.
463−
464−<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>
465−-}
466−data SortOrder = Ascending
467− | Descending deriving (Eq, Show)
468−
469−{-| 'Missing' prescribes how to handle missing fields. A missing field can be
470− sorted last, first, or using a custom value as a substitute.
471−
472−<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_missing_values>
473−-}
474−data Missing = LastMissing
475− | FirstMissing
476− | CustomMissing Text deriving (Eq, Show)
477−
478−{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.
479−
480−http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option
481−-}
482−data SortMode = SortMin
483− | SortMax
484− | SortSum
485− | SortAvg deriving (Eq, Show)
486−
487−{-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so
488− that you can concisely describe the usual kind of 'SortSpec's you want.
489−-}
490−mkSort :: FieldName -> SortOrder -> DefaultSort
491−mkSort fieldName sOrder = DefaultSort fieldName sOrder Nothing Nothing Nothing Nothing
492−
493−{-| 'unpackId' is a silly convenience function that gets used once.
494−-}
495−unpackId :: DocId -> Text
496−unpackId (DocId docId) = docId
497−
498−type TrackSortScores = Bool
499−newtype From = From Int deriving (Eq, Show, ToJSON)
500−newtype Size = Size Int deriving (Eq, Show, ToJSON, FromJSON)
501−
502−data Search = Search { queryBody :: Maybe Query
503− , filterBody :: Maybe Filter
504− , sortBody :: Maybe Sort
505− , aggBody :: Maybe Aggregations
506− , highlight :: Maybe Highlights
507− -- default False
508− , trackSortScores :: TrackSortScores
509− , from :: From
510− , size :: Size
511− , searchType :: SearchType
512− , fields :: Maybe [FieldName]
513− , scriptFields :: Maybe ScriptFields
514− , source :: Maybe Source
515− , suggestBody :: Maybe Suggest -- ^ Only one Suggestion request / response per Search is supported.
516− } deriving (Eq, Show)
517−
518−data SearchType = SearchTypeQueryThenFetch
519− | SearchTypeDfsQueryThenFetch
520− deriving (Eq, Show)
521−
522−data Source =
523− NoSource
524− | SourcePatterns PatternOrPatterns
525− | SourceIncludeExclude Include Exclude
526− deriving (Eq, Show)
527−
528−data PatternOrPatterns = PopPattern Pattern
529− | PopPatterns [Pattern] deriving (Eq, Read, Show)
530−
531−data Include = Include [Pattern] deriving (Eq, Read, Show)
532−data Exclude = Exclude [Pattern] deriving (Eq, Read, Show)
533−
534−newtype Pattern = Pattern Text deriving (Eq, Read, Show)
535−
536−data Highlights = Highlights
537− { globalsettings :: Maybe HighlightSettings
538− , highlightFields :: [FieldHighlight]
539− } deriving (Eq, Show)
540−
541−data FieldHighlight =
542− FieldHighlight FieldName (Maybe HighlightSettings)
543− deriving (Eq, Show)
544−
545−
546−data HighlightSettings =
547− Plain PlainHighlight
548− | Postings PostingsHighlight
549− | FastVector FastVectorHighlight
550− deriving (Eq, Show)
551−
552−data PlainHighlight =
553− PlainHighlight { plainCommon :: Maybe CommonHighlight
554− , plainNonPost :: Maybe NonPostings }
555− deriving (Eq, Show)
556−
557− -- This requires that index_options are set to 'offset' in the mapping.
558−data PostingsHighlight =
559− PostingsHighlight (Maybe CommonHighlight)
560− deriving (Eq, Show)
561−
562−-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
563−data FastVectorHighlight =
564− FastVectorHighlight { fvCommon :: Maybe CommonHighlight
565− , fvNonPostSettings :: Maybe NonPostings
566− , boundaryChars :: Maybe Text
567− , boundaryMaxScan :: Maybe Int
568− , fragmentOffset :: Maybe Int
569− , matchedFields :: [Text]
570− , phraseLimit :: Maybe Int
571− } deriving (Eq, Show)
572−
573−data CommonHighlight =
574− CommonHighlight { order :: Maybe Text
575− , forceSource :: Maybe Bool
576− , tag :: Maybe HighlightTag
577− , encoder :: Maybe HighlightEncoder
578− , noMatchSize :: Maybe Int
579− , highlightQuery :: Maybe Query
580− , requireFieldMatch :: Maybe Bool
581− } deriving (Eq, Show)
582−
583−-- Settings that are only applicable to FastVector and Plain highlighters.
584−data NonPostings =
585− NonPostings { fragmentSize :: Maybe Int
586− , numberOfFragments :: Maybe Int
587− } deriving (Eq, Show)
588−
589−data HighlightEncoder = DefaultEncoder
590− | HTMLEncoder
591− deriving (Eq, Show)
592−
593−-- NOTE: Should the tags use some kind of HTML type, rather than Text?
594−data HighlightTag =
595− TagSchema Text
596− -- Only uses more than the first value in the lists if fvh
597− | CustomTags ([Text], [Text])
598− deriving (Eq, Show)
599−
600−data SearchResult a =
601− SearchResult { took :: Int
602− , timedOut :: Bool
603− , shards :: ShardResult
604− , searchHits :: SearchHits a
605− , aggregations :: Maybe AggregationResults
606− , scrollId :: Maybe ScrollId
607− -- ^ Only one Suggestion request / response per Search is supported.
608− , suggest :: Maybe NamedSuggestionResponse
609− }
610− deriving (Eq, Show)
611−
612−newtype ScrollId =
613− ScrollId Text
614− deriving (Eq, Show, Ord, ToJSON, FromJSON)
615−
616−data SearchHits a =
617− SearchHits { hitsTotal :: Int
618− , maxScore :: Score
619− , hits :: [Hit a] } deriving (Eq, Show)
620−
621−instance Semigroup (SearchHits a) where
622− (SearchHits ta ma ha) <> (SearchHits tb mb hb) = SearchHits (ta + tb) (max ma mb) (ha <> hb)
623−
624−instance Monoid (SearchHits a) where
625− mempty = SearchHits 0 Nothing mempty
626− mappend = (<>)
627−
628−data Hit a =
629− Hit { hitIndex :: IndexName
630− , hitType :: MappingName
631− , hitDocId :: DocId
632− , hitScore :: Score
633− , hitSource :: Maybe a
634− , hitFields :: Maybe HitFields
635− , hitHighlight :: Maybe HitHighlight } deriving (Eq, Show)
636−
637−newtype HitFields =
638− HitFields (M.Map Text [Value])
639− deriving (Eq, Show)
640−
641−type HitHighlight = M.Map Text [Text]
642−
643−
644−type Aggregations = M.Map Text Aggregation
645−
646−emptyAggregations :: Aggregations
647−emptyAggregations = M.empty
648−
649−mkAggregations :: Text -> Aggregation -> Aggregations
650−mkAggregations name aggregation = M.insert name aggregation emptyAggregations
651−
652−data TermOrder = TermOrder{ termSortField :: Text
653− , termSortOrder :: SortOrder } deriving (Eq, Show)
654−
655−data TermInclusion = TermInclusion Text
656− | TermPattern Text Text deriving (Eq, Show)
657−
658−data CollectionMode = BreadthFirst
659− | DepthFirst deriving (Eq, Show)
660−
661−data ExecutionHint = Ordinals
662− | GlobalOrdinals
663− | GlobalOrdinalsHash
664− | GlobalOrdinalsLowCardinality
665− | Map deriving (Eq, Show)
666−
667−data Aggregation = TermsAgg TermsAggregation
668− | CardinalityAgg CardinalityAggregation
669− | DateHistogramAgg DateHistogramAggregation
670− | ValueCountAgg ValueCountAggregation
671− | FilterAgg FilterAggregation
672− | DateRangeAgg DateRangeAggregation
673− | MissingAgg MissingAggregation
674− | TopHitsAgg TopHitsAggregation
675− | StatsAgg StatisticsAggregation
676− deriving (Eq, Show)
677−
678−data TopHitsAggregation = TopHitsAggregation
679− { taFrom :: Maybe From
680− , taSize :: Maybe Size
681− , taSort :: Maybe Sort
682− } deriving (Eq, Show)
683−
684−data MissingAggregation = MissingAggregation
685− { maField :: Text
686− } deriving (Eq, Show)
687−
688−data TermsAggregation = TermsAggregation { term :: Either Text Text
689− , termInclude :: Maybe TermInclusion
690− , termExclude :: Maybe TermInclusion
691− , termOrder :: Maybe TermOrder
692− , termMinDocCount :: Maybe Int
693− , termSize :: Maybe Int
694− , termShardSize :: Maybe Int
695− , termCollectMode :: Maybe CollectionMode
696− , termExecutionHint :: Maybe ExecutionHint
697− , termAggs :: Maybe Aggregations
698− } deriving (Eq, Show)
699−
700−data CardinalityAggregation = CardinalityAggregation
701− { cardinalityField :: FieldName,
702− precisionThreshold :: Maybe Int
703− } deriving (Eq, Show)
704−
705−data DateHistogramAggregation = DateHistogramAggregation
706− { dateField :: FieldName
707− , dateInterval :: Interval
708− , dateFormat :: Maybe Text
709− -- pre and post deprecated in 1.5
710− , datePreZone :: Maybe Text
711− , datePostZone :: Maybe Text
712− , datePreOffset :: Maybe Text
713− , datePostOffset :: Maybe Text
714− , dateAggs :: Maybe Aggregations
715− } deriving (Eq, Show)
716−
717−data DateRangeAggregation = DateRangeAggregation
718− { draField :: FieldName
719− , draFormat :: Maybe Text
720− , draRanges :: NonEmpty DateRangeAggRange
721− } deriving (Eq, Show)
722−
723−data DateRangeAggRange =
724− DateRangeFrom DateMathExpr
725− | DateRangeTo DateMathExpr
726− | DateRangeFromAndTo DateMathExpr DateMathExpr
727− deriving (Eq, Show)
728−
729−-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#date-math> for more information.
730−data DateMathExpr =
731− DateMathExpr DateMathAnchor [DateMathModifier]
732− deriving (Eq, Show)
733−
734−
735−-- | Starting point for a date range. This along with the 'DateMathModifiers' gets you the date ES will start from.
736−data DateMathAnchor =
737− DMNow
738− | DMDate Day
739− deriving (Eq, Show)
740−
741−data DateMathModifier =
742− AddTime Int DateMathUnit
743− | SubtractTime Int DateMathUnit
744− | RoundDownTo DateMathUnit
745− deriving (Eq, Show)
746−
747−data DateMathUnit =
748− DMYear
749− | DMMonth
750− | DMWeek
751− | DMDay
752− | DMHour
753− | DMMinute
754− | DMSecond
755− deriving (Eq, Show)
756−
757−-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.
758−data ValueCountAggregation =
759− FieldValueCount FieldName
760− | ScriptValueCount Script
761− deriving (Eq, Show)
762−
763−-- | 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.
764−data FilterAggregation = FilterAggregation
765− { faFilter :: Filter
766− , faAggs :: Maybe Aggregations }
767− deriving (Eq, Show)
768−
769−data StatisticsAggregation = StatisticsAggregation
770− { statsType :: StatsType
771− , statsField :: FieldName }
772− deriving (Eq, Show)
773−
774−data StatsType
775− = Basic
776− | Extended
777− deriving (Eq, Show)
778−
779−mkTermsAggregation :: Text -> TermsAggregation
780−mkTermsAggregation t =
781− TermsAggregation (Left t)
782− Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
783−
784−mkTermsScriptAggregation :: Text -> TermsAggregation
785−mkTermsScriptAggregation t = TermsAggregation (Right t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
786−
787−mkDateHistogram :: FieldName -> Interval -> DateHistogramAggregation
788−mkDateHistogram t i = DateHistogramAggregation t i Nothing Nothing Nothing Nothing Nothing Nothing
789−
790−mkCardinalityAggregation :: FieldName -> CardinalityAggregation
791−mkCardinalityAggregation t = CardinalityAggregation t Nothing
792−
793−mkStatsAggregation :: FieldName -> StatisticsAggregation
794−mkStatsAggregation = StatisticsAggregation Basic
795−
796−mkExtendedStatsAggregation :: FieldName -> StatisticsAggregation
797−mkExtendedStatsAggregation = StatisticsAggregation Extended
798−
799−instance ToJSON TermOrder where
800− toJSON (TermOrder termSortField termSortOrder) = object [termSortField .= termSortOrder]
801−
802−instance ToJSON TermInclusion where
803− toJSON (TermInclusion x) = toJSON x
804− toJSON (TermPattern pattern flags) = omitNulls [ "pattern" .= pattern,
805− "flags" .= flags]
806−
807−instance ToJSON CollectionMode where
808− toJSON BreadthFirst = "breadth_first"
809− toJSON DepthFirst = "depth_first"
810−
811−instance ToJSON ExecutionHint where
812− toJSON Ordinals = "ordinals"
813− toJSON GlobalOrdinals = "global_ordinals"
814− toJSON GlobalOrdinalsHash = "global_ordinals_hash"
815− toJSON GlobalOrdinalsLowCardinality = "global_ordinals_low_cardinality"
816− toJSON Map = "map"
817−
818−instance ToJSON Interval where
819− toJSON Year = "year"
820− toJSON Quarter = "quarter"
821− toJSON Month = "month"
822− toJSON Week = "week"
823− toJSON Day = "day"
824− toJSON Hour = "hour"
825− toJSON Minute = "minute"
826− toJSON Second = "second"
827−
828−instance ToJSON Aggregation where
829− toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =
830− omitNulls ["terms" .= omitNulls [ toJSON' term,
831− "include" .= include,
832− "exclude" .= exclude,
833− "order" .= order,
834− "min_doc_count" .= minDocCount,
835− "size" .= size,
836− "shard_size" .= shardSize,
837− "collect_mode" .= collectMode,
838− "execution_hint" .= executionHint
839− ],
840− "aggs" .= termAggs ]
841− where
842− toJSON' x = case x of { Left y -> "field" .= y; Right y -> "script" .= y }
843−
844− toJSON (CardinalityAgg (CardinalityAggregation field precisionThreshold)) =
845− object ["cardinality" .= omitNulls [ "field" .= field,
846− "precisionThreshold" .= precisionThreshold
847− ]
848− ]
849−
850− toJSON (DateHistogramAgg
851− (DateHistogramAggregation field interval format
852− preZone postZone preOffset postOffset dateHistoAggs)) =
853− omitNulls ["date_histogram" .= omitNulls [ "field" .= field,
854− "interval" .= interval,
855− "format" .= format,
856− "pre_zone" .= preZone,
857− "post_zone" .= postZone,
858− "pre_offset" .= preOffset,
859− "post_offset" .= postOffset
860− ],
861− "aggs" .= dateHistoAggs ]
862− toJSON (ValueCountAgg a) = object ["value_count" .= v]
863− where v = case a of
864− (FieldValueCount (FieldName n)) ->
865− object ["field" .= n]
866− (ScriptValueCount s) ->
867− object ["script" .= s]
868− toJSON (FilterAgg (FilterAggregation filt ags)) =
869− omitNulls [ "filter" .= filt
870− , "aggs" .= ags]
871− toJSON (DateRangeAgg a) = object [ "date_range" .= a
872− ]
873− toJSON (MissingAgg (MissingAggregation{..})) =
874− object ["missing" .= object ["field" .= maField]]
875−
876− toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =
877− omitNulls ["top_hits" .= omitNulls [ "size" .= msize
878− , "from" .= mfrom
879− , "sort" .= msort
880− ]
881− ]
882−
883− toJSON (StatsAgg (StatisticsAggregation typ field)) =
884− object [stType .= omitNulls [ "field" .= field ]]
885− where
886− stType | typ == Basic = "stats"
887− | otherwise = "extended_stats"
888−
889−instance ToJSON DateRangeAggregation where
890− toJSON DateRangeAggregation {..} =
891− omitNulls [ "field" .= draField
892− , "format" .= draFormat
893− , "ranges" .= toList draRanges
894− ]
895−
896−instance ToJSON DateRangeAggRange where
897− toJSON (DateRangeFrom e) = object [ "from" .= e ]
898− toJSON (DateRangeTo e) = object [ "to" .= e ]
899− toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]
900−
901−instance ToJSON DateMathExpr where
902− toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))
903− where fmtA DMNow = "now"
904− fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"
905− fmtMod (AddTime n u) = "+" <> showText n <> fmtU u
906− fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u
907− fmtMod (RoundDownTo u) = "/" <> fmtU u
908− fmtU DMYear = "y"
909− fmtU DMMonth = "M"
910− fmtU DMWeek = "w"
911− fmtU DMDay = "d"
912− fmtU DMHour = "h"
913− fmtU DMMinute = "m"
914− fmtU DMSecond = "s"
915−
916−
917−type AggregationResults = M.Map Text Value
918−
919−class BucketAggregation a where
920− key :: a -> BucketValue
921− docCount :: a -> Int
922− aggs :: a -> Maybe AggregationResults
923−
924−
925−data Bucket a = Bucket { buckets :: [a]} deriving (Read, Show)
926−
927−data BucketValue = TextValue Text
928− | ScientificValue Scientific
929− | BoolValue Bool deriving (Read, Show)
930−
931−data MissingResult = MissingResult { missingDocCount :: Int } deriving (Show)
932−
933−data TopHitResult a = TopHitResult { tarHits :: (SearchHits a)
934− } deriving Show
935−
936−data TermsResult = TermsResult { termKey :: BucketValue
937− , termsDocCount :: Int
938− , termsAggs :: Maybe AggregationResults } deriving (Read, Show)
939−
940−data DateHistogramResult = DateHistogramResult { dateKey :: Int
941− , dateKeyStr :: Maybe Text
942− , dateDocCount :: Int
943− , dateHistogramAggs :: Maybe AggregationResults } deriving (Read, Show)
944−
945−data DateRangeResult =
946− DateRangeResult { dateRangeKey :: Text
947− , dateRangeFrom :: Maybe UTCTime
948− , dateRangeFromAsString :: Maybe Text
949− , dateRangeTo :: Maybe UTCTime
950− , dateRangeToAsString :: Maybe Text
951− , dateRangeDocCount :: Int
952− , dateRangeAggs :: Maybe AggregationResults }
953− deriving (Eq, Show)
954−
955−toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult)
956−toTerms = toAggResult
957−
958−toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult)
959−toDateHistogram = toAggResult
960−
961−toMissing :: Text -> AggregationResults -> Maybe MissingResult
962−toMissing = toAggResult
963−
964−toTopHits :: (FromJSON a) => Text -> AggregationResults -> Maybe (TopHitResult a)
965−toTopHits = toAggResult
966−
967−toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a
968−toAggResult t a = M.lookup t a >>= deserialize
969− where deserialize = parseMaybe parseJSON
970−
971−instance BucketAggregation TermsResult where
972− key = termKey
973− docCount = termsDocCount
974− aggs = termsAggs
975−
976−instance BucketAggregation DateHistogramResult where
977− key = TextValue . showText . dateKey
978− docCount = dateDocCount
979− aggs = dateHistogramAggs
980−
981−instance BucketAggregation DateRangeResult where
982− key = TextValue . dateRangeKey
983− docCount = dateRangeDocCount
984− aggs = dateRangeAggs
985−
986−instance (FromJSON a) => FromJSON (Bucket a) where
987− parseJSON (Object v) = Bucket <$>
988− v .: "buckets"
989− parseJSON _ = mempty
990−
991−instance FromJSON BucketValue where
992− parseJSON (String t) = return $ TextValue t
993− parseJSON (Number s) = return $ ScientificValue s
994− parseJSON (Bool b) = return $ BoolValue b
995− parseJSON _ = mempty
996−
997−instance FromJSON MissingResult where
998− parseJSON = withObject "MissingResult" parse
999− where parse v = MissingResult <$> v .: "doc_count"
1000−
1001−instance FromJSON TermsResult where
1002− parseJSON (Object v) = TermsResult <$>
1003− v .: "key" <*>
1004− v .: "doc_count" <*>
1005− (pure $ getNamedSubAgg v ["key", "doc_count"])
1006− parseJSON _ = mempty
1007−
1008−instance FromJSON DateHistogramResult where
1009− parseJSON (Object v) = DateHistogramResult <$>
1010− v .: "key" <*>
1011− v .:? "key_as_string" <*>
1012− v .: "doc_count" <*>
1013− (pure $ getNamedSubAgg v [ "key"
1014− , "doc_count"
1015− , "key_as_string"
1016− ]
1017− )
1018− parseJSON _ = mempty
1019−
1020−instance FromJSON DateRangeResult where
1021− parseJSON = withObject "DateRangeResult" parse
1022− where parse v = DateRangeResult <$>
1023− v .: "key" <*>
1024− (fmap posixMS <$> v .:? "from") <*>
1025− v .:? "from_as_string" <*>
1026− (fmap posixMS <$> v .:? "to") <*>
1027− v .:? "to_as_string" <*>
1028− v .: "doc_count" <*>
1029− (pure $ getNamedSubAgg v [ "key"
1030− , "from"
1031− , "from_as_string"
1032− , "to"
1033− , "to_as_string"
1034− , "doc_count"
1035− ]
1036− )
1037−
1038−instance (FromJSON a) => FromJSON (TopHitResult a) where
1039− parseJSON (Object v) = TopHitResult <$>
1040− v .: "hits"
1041− parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"
1042−
1043−-- Try to get an AggregationResults when we don't know the
1044−-- field name. We filter out the known keys to try to minimize the noise.
1045−getNamedSubAgg :: Object -> [Text] -> Maybe AggregationResults
1046−getNamedSubAgg o knownKeys = maggRes
1047− where unknownKeys = HM.filterWithKey (\k _ -> k `notElem` knownKeys) o
1048− maggRes
1049− | HM.null unknownKeys = Nothing
1050− | otherwise = Just . M.fromList $ HM.toList unknownKeys
1051−
1052−instance ToJSON GeoPoint where
1053− toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) =
1054− object [ geoPointField .= geoPointLatLon ]
1055−
1056−instance FromJSON Status where
1057− parseJSON (Object v) = Status <$>
1058− v .: "name" <*>
1059− v .: "cluster_name" <*>
1060− v .: "cluster_uuid" <*>
1061− v .: "version" <*>
1062− v .: "tagline"
1063− parseJSON _ = empty
1064−
1065−instance ToJSON IndexSettings where
1066− toJSON (IndexSettings s r) = object ["settings" .=
1067− object ["index" .=
1068− object ["number_of_shards" .= s, "number_of_replicas" .= r]
1069− ]
1070− ]
1071−
1072−instance FromJSON IndexSettings where
1073− parseJSON = withObject "IndexSettings" parse
1074− where parse o = do s <- o .: "settings"
1075− i <- s .: "index"
1076− IndexSettings <$> i .: "number_of_shards"
1077− <*> i .: "number_of_replicas"
1078−
1079−instance ToJSON UpdatableIndexSetting where
1080− toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x
1081− toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x
1082− toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x)
1083− toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x
1084− toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x
1085− toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x
1086− toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x
1087− toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x)
1088− toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x
1089− toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x
1090− toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x)
1091− toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x)
1092− toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs)
1093− toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs)
1094− toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs)
1095− toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x
1096− toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x
1097− toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x
1098− toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x)
1099− toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x
1100− toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x
1101− toJSON (CompressionSetting x) = oPath ("index" :| ["codec"]) x
1102− toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x
1103− toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x
1104− toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x
1105− toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x
1106− toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x
1107− toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x
1108− toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x
1109− toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping","total_fields","limit"]) x
1110− toJSON (AnalysisSetting x) = oPath ("index" :| ["analysis"]) x
1111−
1112−instance FromJSON UpdatableIndexSetting where
1113− parseJSON = withObject "UpdatableIndexSetting" parse
1114− where parse o = numberOfReplicas `taggedAt` ["index", "number_of_replicas"]
1115− <|> autoExpandReplicas `taggedAt` ["index", "auto_expand_replicas"]
1116− <|> refreshInterval `taggedAt` ["index", "refresh_interval"]
1117− <|> indexConcurrency `taggedAt` ["index", "concurrency"]
1118− <|> failOnMergeFailure `taggedAt` ["index", "fail_on_merge_failure"]
1119− <|> translogFlushThresholdOps `taggedAt` ["index", "translog", "flush_threshold_ops"]
1120− <|> translogFlushThresholdSize `taggedAt` ["index", "translog", "flush_threshold_size"]
1121− <|> translogFlushThresholdPeriod `taggedAt` ["index", "translog", "flush_threshold_period"]
1122− <|> translogDisableFlush `taggedAt` ["index", "translog", "disable_flush"]
1123− <|> cacheFilterMaxSize `taggedAt` ["index", "cache", "filter", "max_size"]
1124− <|> cacheFilterExpire `taggedAt` ["index", "cache", "filter", "expire"]
1125− <|> gatewaySnapshotInterval `taggedAt` ["index", "gateway", "snapshot_interval"]
1126− <|> routingAllocationInclude `taggedAt` ["index", "routing", "allocation", "include"]
1127− <|> routingAllocationExclude `taggedAt` ["index", "routing", "allocation", "exclude"]
1128− <|> routingAllocationRequire `taggedAt` ["index", "routing", "allocation", "require"]
1129− <|> routingAllocationEnable `taggedAt` ["index", "routing", "allocation", "enable"]
1130− <|> routingAllocationShardsPerNode `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"]
1131− <|> recoveryInitialShards `taggedAt` ["index", "recovery", "initial_shards"]
1132− <|> gcDeletes `taggedAt` ["index", "gc_deletes"]
1133− <|> ttlDisablePurge `taggedAt` ["index", "ttl", "disable_purge"]
1134− <|> translogFSType `taggedAt` ["index", "translog", "fs", "type"]
1135− <|> compressionSetting `taggedAt` ["index", "codec"]
1136− <|> compoundFormat `taggedAt` ["index", "compound_format"]
1137− <|> compoundOnFlush `taggedAt` ["index", "compound_on_flush"]
1138− <|> warmerEnabled `taggedAt` ["index", "warmer", "enabled"]
1139− <|> blocksReadOnly `taggedAt` ["blocks", "read_only"]
1140− <|> blocksRead `taggedAt` ["blocks", "read"]
1141− <|> blocksWrite `taggedAt` ["blocks", "write"]
1142− <|> blocksMetaData `taggedAt` ["blocks", "metadata"]
1143− <|> mappingTotalFieldsLimit `taggedAt` ["index", "mapping", "total_fields", "limit"]
1144− <|> analysisSetting `taggedAt` ["index", "analysis"]
1145− where taggedAt f ks = taggedAt' f (Object o) ks
1146− taggedAt' f v [] = f =<< (parseJSON v <|> (parseJSON (unStringlyTypeJSON v)))
1147− taggedAt' f v (k:ks) = withObject "Object" (\o -> do v' <- o .: k
1148− taggedAt' f v' ks) v
1149− numberOfReplicas = pure . NumberOfReplicas
1150− autoExpandReplicas = pure . AutoExpandReplicas
1151− refreshInterval = pure . RefreshInterval . ndtJSON
1152− indexConcurrency = pure . IndexConcurrency
1153− failOnMergeFailure = pure . FailOnMergeFailure
1154− translogFlushThresholdOps = pure . TranslogFlushThresholdOps
1155− translogFlushThresholdSize = pure . TranslogFlushThresholdSize
1156− translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON
1157− translogDisableFlush = pure . TranslogDisableFlush
1158− cacheFilterMaxSize = pure . CacheFilterMaxSize
1159− cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON
1160− gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON
1161− routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter
1162− routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter
1163− routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter
1164− routingAllocationEnable = pure . RoutingAllocationEnable
1165− routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode
1166− recoveryInitialShards = pure . RecoveryInitialShards
1167− gcDeletes = pure . GCDeletes . ndtJSON
1168− ttlDisablePurge = pure . TTLDisablePurge
1169− translogFSType = pure . TranslogFSType
1170− compressionSetting = pure . CompressionSetting
1171− compoundFormat = pure . IndexCompoundFormat
1172− compoundOnFlush = pure . IndexCompoundOnFlush
1173− warmerEnabled = pure . WarmerEnabled
1174− blocksReadOnly = pure . BlocksReadOnly
1175− blocksRead = pure . BlocksRead
1176− blocksWrite = pure . BlocksWrite
1177− blocksMetaData = pure . BlocksMetaData
1178− mappingTotalFieldsLimit = pure . MappingTotalFieldsLimit
1179− analysisSetting = pure . AnalysisSetting
1180−
1181−instance FromJSON IndexSettingsSummary where
1182− parseJSON = withObject "IndexSettingsSummary" parse
1183− where parse o = case HM.toList o of
1184− [(ixn, v@(Object o'))] -> IndexSettingsSummary (IndexName ixn)
1185− <$> parseJSON v
1186− <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")
1187− _ -> fail "Expected single-key object with index name"
1188− redundant (NumberOfReplicas _) = True
1189− redundant _ = False
1190−
1191−
1192−parseSettings :: Object -> Parser [UpdatableIndexSetting]
1193−parseSettings o = do
1194− o' <- o .: "index"
1195− -- slice the index object into singleton hashmaps and try to parse each
1196− parses <- forM (HM.toList o') $ \(k, v) -> do
1197− -- blocks are now nested into the "index" key, which is not how they're serialized
1198− let atRoot = Object (HM.singleton k v)
1199− let atIndex = Object (HM.singleton "index" atRoot)
1200− optional (parseJSON atRoot <|> parseJSON atIndex)
1201− return (catMaybes parses)
1202−
1203−oPath :: ToJSON a => NonEmpty Text -> a -> Value
1204−oPath (k :| []) v = object [k .= v]
1205−oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]
1206−
1207−attrFilterJSON :: NonEmpty NodeAttrFilter -> Value
1208−attrFilterJSON fs = object [ n .= T.intercalate "," (toList vs)
1209− | NodeAttrFilter (NodeAttrName n) vs <- toList fs]
1210−
1211−parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)
1212−parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse
1213− where parse o = case HM.toList o of
1214− [] -> fail "Expected non-empty list of NodeAttrFilters"
1215− x:xs -> DT.mapM (uncurry parse') (x :| xs)
1216− parse' n = withText "Text" $ \t ->
1217− case T.splitOn "," t of
1218− fv:fvs -> return (NodeAttrFilter (NodeAttrName n) (fv :| fvs))
1219− [] -> fail "Expected non-empty list of filter values"
1220−
1221−instance ToJSON ReplicaBounds where
1222− toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b)
1223− toJSON (ReplicasLowerBounded a) = String (showText a <> "-all")
1224− toJSON ReplicasUnbounded = Bool False
1225−
1226−instance FromJSON ReplicaBounds where
1227− parseJSON v = withText "ReplicaBounds" parseText v
1228− <|> withBool "ReplicaBounds" parseBool v
1229− where parseText t = case T.splitOn "-" t of
1230− [a, "all"] -> ReplicasLowerBounded <$> parseReadText a
1231− [a, b] -> ReplicasBounded <$> parseReadText a
1232− <*> parseReadText b
1233− _ -> fail ("Could not parse ReplicaBounds: " <> show t)
1234− parseBool False = pure ReplicasUnbounded
1235− parseBool _ = fail "ReplicasUnbounded cannot be represented with True"
1236−
1237−instance ToJSON AllocationPolicy where
1238− toJSON AllocAll = String "all"
1239− toJSON AllocPrimaries = String "primaries"
1240− toJSON AllocNewPrimaries = String "new_primaries"
1241− toJSON AllocNone = String "none"
1242−
1243−instance FromJSON AllocationPolicy where
1244− parseJSON = withText "AllocationPolicy" parse
1245− where parse "all" = pure AllocAll
1246− parse "primaries" = pure AllocPrimaries
1247− parse "new_primaries" = pure AllocNewPrimaries
1248− parse "none" = pure AllocNone
1249− parse t = fail ("Invlaid AllocationPolicy: " <> show t)
1250−
1251−instance ToJSON InitialShardCount where
1252− toJSON QuorumShards = String "quorum"
1253− toJSON QuorumMinus1Shards = String "quorum-1"
1254− toJSON FullShards = String "full"
1255− toJSON FullMinus1Shards = String "full-1"
1256− toJSON (ExplicitShards x) = toJSON x
1257−
1258−instance FromJSON InitialShardCount where
1259− parseJSON v = withText "InitialShardCount" parseText v
1260− <|> ExplicitShards <$> parseJSON v
1261− where parseText "quorum" = pure QuorumShards
1262− parseText "quorum-1" = pure QuorumMinus1Shards
1263− parseText "full" = pure FullShards
1264− parseText "full-1" = pure FullMinus1Shards
1265− parseText _ = mzero
1266−
1267−instance ToJSON FSType where
1268− toJSON FSSimple = "simple"
1269− toJSON FSBuffered = "buffered"
1270−
1271−instance FromJSON FSType where
1272− parseJSON = withText "FSType" parse
1273− where parse "simple" = pure FSSimple
1274− parse "buffered" = pure FSBuffered
1275− parse t = fail ("Invalid FSType: " <> show t)
1276−
1277−instance ToJSON CompoundFormat where
1278− toJSON (CompoundFileFormat x) = Bool x
1279− toJSON (MergeSegmentVsTotalIndex x) = toJSON x
1280−
1281−instance FromJSON CompoundFormat where
1282− parseJSON v = CompoundFileFormat <$> parseJSON v
1283− <|> MergeSegmentVsTotalIndex <$> parseJSON v
1284−
1285−instance ToJSON NominalDiffTimeJSON where
1286− toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s")
1287−
1288−instance FromJSON NominalDiffTimeJSON where
1289− parseJSON = withText "NominalDiffTime" parse
1290− where parse t = case T.takeEnd 1 t of
1291− "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t)
1292− _ -> fail "Invalid or missing NominalDiffTime unit (expected s)"
1293−
1294−instance ToJSON IndexTemplate where
1295− toJSON (IndexTemplate p s m) = merge
1296− (object [ "template" .= p
1297− , "mappings" .= foldl' merge (object []) m
1298− ])
1299− (toJSON s)
1300− where
1301− merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2
1302− merge o Null = o
1303− merge _ _ = undefined
1304−
1305−instance (FromJSON a) => FromJSON (EsResult a) where
1306− parseJSON jsonVal@(Object v) = do
1307− found <- v .:? "found" .!= False
1308− fr <- if found
1309− then parseJSON jsonVal
1310− else return Nothing
1311− EsResult <$> v .: "_index" <*>
1312− v .: "_type" <*>
1313− v .: "_id" <*>
1314− pure fr
1315− parseJSON _ = empty
1316−
1317−instance (FromJSON a) => FromJSON (EsResultFound a) where
1318− parseJSON (Object v) = EsResultFound <$>
1319− v .: "_version" <*>
1320− v .: "_source"
1321− parseJSON _ = empty
1322−
1323−instance FromJSON EsError where
1324− parseJSON (Object v) = EsError <$>
1325− v .: "status" <*>
1326− (v .: "error" <|> (v .: "error" >>= (.: "reason")))
1327− parseJSON _ = empty
1328−
1329−instance FromJSON IndexAliasesSummary where
1330− parseJSON = withObject "IndexAliasesSummary" parse
1331− where parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (HM.toList o)
1332− go ixn = withObject "index aliases" $ \ia -> do
1333− aliases <- ia .:? "aliases" .!= mempty
1334− forM (HM.toList aliases) $ \(aName, v) -> do
1335− let indexAlias = IndexAlias (IndexName ixn) (IndexAliasName (IndexName aName))
1336− IndexAliasSummary indexAlias <$> parseJSON v
1337−
1338−
1339−instance ToJSON IndexAliasAction where
1340− toJSON (AddAlias ia opts) = object ["add" .= (iaObj <> optsObj)]
1341− where Object iaObj = toJSON ia
1342− Object optsObj = toJSON opts
1343− toJSON (RemoveAlias ia) = object ["remove" .= iaObj]
1344− where Object iaObj = toJSON ia
1345−
1346−instance ToJSON IndexAlias where
1347− toJSON IndexAlias {..} = object ["index" .= srcIndex
1348− , "alias" .= indexAlias
1349− ]
1350−
1351−instance ToJSON IndexAliasCreate where
1352− toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj)
1353− where filterObj = maybe mempty (HM.singleton "filter" . toJSON) aliasCreateFilter
1354− Object routingObj = maybe (Object mempty) toJSON aliasCreateRouting
1355−
1356−instance ToJSON AliasRouting where
1357− toJSON (AllAliasRouting v) = object ["routing" .= v]
1358− toJSON (GranularAliasRouting srch idx) = object (catMaybes prs)
1359− where prs = [("search_routing" .=) <$> srch
1360− ,("index_routing" .=) <$> idx]
1361−
1362−instance FromJSON AliasRouting where
1363− parseJSON = withObject "AliasRouting" parse
1364− where parse o = parseAll o <|> parseGranular o
1365− parseAll o = AllAliasRouting <$> o .: "routing"
1366− parseGranular o = do
1367− sr <- o .:? "search_routing"
1368− ir <- o .:? "index_routing"
1369− if isNothing sr && isNothing ir
1370− then fail "Both search_routing and index_routing can't be blank"
1371− else return (GranularAliasRouting sr ir)
1372−
1373−instance FromJSON IndexAliasCreate where
1374− parseJSON v = withObject "IndexAliasCreate" parse v
1375− where parse o = IndexAliasCreate <$> optional (parseJSON v)
1376− <*> o .:? "filter"
1377−
1378−instance ToJSON SearchAliasRouting where
1379− toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs))
1380−
1381−instance FromJSON SearchAliasRouting where
1382− parseJSON = withText "SearchAliasRouting" parse
1383− where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)
1384−
1385−instance ToJSON Search where
1386− toJSON (Search mquery sFilter sort searchAggs
1387− highlight sTrackSortScores sFrom sSize _ sFields
1388− sScriptFields sSource sSuggest) =
1389− omitNulls [ "query" .= query'
1390− , "sort" .= sort
1391− , "aggregations" .= searchAggs
1392− , "highlight" .= highlight
1393− , "from" .= sFrom
1394− , "size" .= sSize
1395− , "track_scores" .= sTrackSortScores
1396− , "fields" .= sFields
1397− , "script_fields" .= sScriptFields
1398− , "_source" .= sSource
1399− , "suggest" .= sSuggest]
1400−
1401− where query' = case sFilter of
1402− Nothing -> mquery
1403− Just x ->
1404− Just
1405− . QueryBoolQuery
1406− $ mkBoolQuery (maybeToList mquery)
1407− [x] [] []
1408−
1409−instance ToJSON Source where
1410− toJSON NoSource = toJSON False
1411− toJSON (SourcePatterns patterns) = toJSON patterns
1412− toJSON (SourceIncludeExclude incl excl) = object [ "includes" .= incl, "excludes" .= excl ]
1413−
1414−instance ToJSON PatternOrPatterns where
1415− toJSON (PopPattern pattern) = toJSON pattern
1416− toJSON (PopPatterns patterns) = toJSON patterns
1417−
1418−instance ToJSON Include where
1419− toJSON (Include patterns) = toJSON patterns
1420−
1421−instance ToJSON Exclude where
1422− toJSON (Exclude patterns) = toJSON patterns
1423−
1424−instance ToJSON Pattern where
1425− toJSON (Pattern pattern) = toJSON pattern
1426−
1427−
1428−instance ToJSON FieldHighlight where
1429− toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =
1430− object [ fName .= fSettings ]
1431− toJSON (FieldHighlight (FieldName fName) Nothing) =
1432− object [ fName .= emptyObject ]
1433−
1434−instance ToJSON Highlights where
1435− toJSON (Highlights global fields) =
1436− omitNulls (("fields" .= fields)
1437− : highlightSettingsPairs global)
1438−
1439−instance ToJSON HighlightSettings where
1440− toJSON hs = omitNulls (highlightSettingsPairs (Just hs))
1441−
1442−highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
1443−highlightSettingsPairs Nothing = []
1444−highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh)
1445−highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph)
1446−highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh)
1447−
1448−
1449−plainHighPairs :: Maybe PlainHighlight -> [Pair]
1450−plainHighPairs Nothing = []
1451−plainHighPairs (Just (PlainHighlight plCom plNonPost)) =
1452− [ "type" .= String "plain"]
1453− ++ commonHighlightPairs plCom
1454− ++ nonPostingsToPairs plNonPost
1455−
1456−postHighPairs :: Maybe PostingsHighlight -> [Pair]
1457−postHighPairs Nothing = []
1458−postHighPairs (Just (PostingsHighlight pCom)) =
1459− ("type" .= String "postings")
1460− : commonHighlightPairs pCom
1461−
1462−fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
1463−fastVectorHighPairs Nothing = []
1464−fastVectorHighPairs (Just
1465− (FastVectorHighlight fvCom fvNonPostSettings fvBoundChars
1466− fvBoundMaxScan fvFragOff fvMatchedFields
1467− fvPhraseLim)) =
1468− [ "type" .= String "fvh"
1469− , "boundary_chars" .= fvBoundChars
1470− , "boundary_max_scan" .= fvBoundMaxScan
1471− , "fragment_offset" .= fvFragOff
1472− , "matched_fields" .= fvMatchedFields
1473− , "phraseLimit" .= fvPhraseLim]
1474− ++ commonHighlightPairs fvCom
1475− ++ nonPostingsToPairs fvNonPostSettings
1476−
1477−commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
1478−commonHighlightPairs Nothing = []
1479−commonHighlightPairs (Just (CommonHighlight chScore chForceSource chTag chEncoder
1480− chNoMatchSize chHighlightQuery
1481− chRequireFieldMatch)) =
1482− [ "order" .= chScore
1483− , "force_source" .= chForceSource
1484− , "encoder" .= chEncoder
1485− , "no_match_size" .= chNoMatchSize
1486− , "highlight_query" .= chHighlightQuery
1487− , "require_fieldMatch" .= chRequireFieldMatch]
1488− ++ highlightTagToPairs chTag
1489−
1490−
1491−nonPostingsToPairs :: Maybe NonPostings -> [Pair]
1492−nonPostingsToPairs Nothing = []
1493−nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =
1494− [ "fragment_size" .= npFragSize
1495− , "number_of_fragments" .= npNumOfFrags]
1496−
1497−
1498−instance ToJSON HighlightEncoder where
1499− toJSON DefaultEncoder = String "default"
1500− toJSON HTMLEncoder = String "html"
1501−
1502−highlightTagToPairs :: Maybe HighlightTag -> [Pair]
1503−highlightTagToPairs (Just (TagSchema _)) = [ "scheme" .= String "default"]
1504−highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre
1505− , "post_tags" .= post]
1506−highlightTagToPairs Nothing = []
1507−
1508−instance ToJSON SortSpec where
1509− toJSON (DefaultSortSpec
1510− (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped
1511− dsSortMode dsMissingSort dsNestedFilter)) =
1512− object [dsSortFieldName .= omitNulls base] where
1513− base = [ "order" .= dsSortOrder
1514− , "unmapped_type" .= dsIgnoreUnmapped
1515− , "mode" .= dsSortMode
1516− , "missing" .= dsMissingSort
1517− , "nested_filter" .= dsNestedFilter ]
1518−
1519− toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) =
1520− object [ "unit" .= units
1521− , field .= gdsLatLon
1522− , "order" .= gdsSortOrder ]
1523−
1524−
1525−instance ToJSON SortOrder where
1526− toJSON Ascending = String "asc"
1527− toJSON Descending = String "desc"
1528−
1529−
1530−instance ToJSON SortMode where
1531− toJSON SortMin = String "min"
1532− toJSON SortMax = String "max"
1533− toJSON SortSum = String "sum"
1534− toJSON SortAvg = String "avg"
1535−
1536−
1537−instance ToJSON Missing where
1538− toJSON LastMissing = String "_last"
1539− toJSON FirstMissing = String "_first"
1540− toJSON (CustomMissing txt) = String txt
1541−
1542−
1543−
1544−instance (FromJSON a) => FromJSON (SearchResult a) where
1545− parseJSON (Object v) = SearchResult <$>
1546− v .: "took" <*>
1547− v .: "timed_out" <*>
1548− v .: "_shards" <*>
1549− v .: "hits" <*>
1550− v .:? "aggregations" <*>
1551− v .:? "_scroll_id" <*>
1552− v .:? "suggest"
1553− parseJSON _ = empty
1554−
1555−instance (FromJSON a) => FromJSON (SearchHits a) where
1556− parseJSON (Object v) = SearchHits <$>
1557− v .: "total" <*>
1558− v .: "max_score" <*>
1559− v .: "hits"
1560− parseJSON _ = empty
1561−
1562−instance (FromJSON a) => FromJSON (Hit a) where
1563− parseJSON (Object v) = Hit <$>
1564− v .: "_index" <*>
1565− v .: "_type" <*>
1566− v .: "_id" <*>
1567− v .: "_score" <*>
1568− v .:? "_source" <*>
1569− v .:? "fields" <*>
1570− v .:? "highlight"
1571− parseJSON _ = empty
1572−
1573−instance FromJSON HitFields where
1574− parseJSON x
1575− = HitFields <$> parseJSON x
1576−
1577−instance FromJSON DocVersion where
1578− parseJSON v = do
1579− i <- parseJSON v
1580− maybe (fail "DocVersion out of range") return $ mkDocVersion i
1581−
1582−data Suggest = Suggest { suggestText :: Text
1583− , suggestName :: Text
1584− , suggestType :: SuggestType
1585− }
1586− deriving (Eq, Show)
1587−
1588−instance ToJSON Suggest where
1589− toJSON Suggest{..} = object [ "text" .= suggestText
1590− , suggestName .= suggestType
1591− ]
1592−
1593−instance FromJSON Suggest where
1594− parseJSON (Object o) = do
1595− suggestText' <- o .: "text"
1596− let dropTextList = HM.toList $ HM.filterWithKey (\x _ -> x /= "text") o
1597− suggestName' <- case dropTextList of
1598− [(x, _)] -> return x
1599− _ -> fail "error parsing Suggest field name"
1600− suggestType' <- o .: suggestName'
1601− return $ Suggest suggestText' suggestName' suggestType'
1602− parseJSON x = typeMismatch "Suggest" x
1603−
1604−data SuggestType = SuggestTypePhraseSuggester PhraseSuggester
1605− deriving (Eq, Show)
1606−
1607−instance ToJSON SuggestType where
1608− toJSON (SuggestTypePhraseSuggester x) = object ["phrase" .= x]
1609−
1610−instance FromJSON SuggestType where
1611− parseJSON = withObject "SuggestType" parse
1612− where parse o = phraseSuggester `taggedWith` "phrase"
1613− where taggedWith parser k = parser =<< o .: k
1614− phraseSuggester = pure . SuggestTypePhraseSuggester
1615−
1616−data PhraseSuggester =
1617− PhraseSuggester { phraseSuggesterField :: FieldName
1618− , phraseSuggesterGramSize :: Maybe Int
1619− , phraseSuggesterRealWordErrorLikelihood :: Maybe Int
1620− , phraseSuggesterConfidence :: Maybe Int
1621− , phraseSuggesterMaxErrors :: Maybe Int
1622− , phraseSuggesterSeparator :: Maybe Text
1623− , phraseSuggesterSize :: Maybe Size
1624− , phraseSuggesterAnalyzer :: Maybe Analyzer
1625− , phraseSuggesterShardSize :: Maybe Int
1626− , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter
1627− , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate
1628− , phraseSuggesterCandidateGenerators :: [DirectGenerators]
1629− }
1630− deriving (Eq, Show)
1631−
1632−instance ToJSON PhraseSuggester where
1633− toJSON PhraseSuggester{..} = omitNulls [ "field" .= phraseSuggesterField
1634− , "gram_size" .= phraseSuggesterGramSize
1635− , "real_word_error_likelihood" .= phraseSuggesterRealWordErrorLikelihood
1636− , "confidence" .= phraseSuggesterConfidence
1637− , "max_errors" .= phraseSuggesterMaxErrors
1638− , "separator" .= phraseSuggesterSeparator
1639− , "size" .= phraseSuggesterSize
1640− , "analyzer" .= phraseSuggesterAnalyzer
1641− , "shard_size" .= phraseSuggesterShardSize
1642− , "highlight" .= phraseSuggesterHighlight
1643− , "collate" .= phraseSuggesterCollate
1644− , "direct_generator" .= phraseSuggesterCandidateGenerators
1645− ]
1646−
1647−instance FromJSON PhraseSuggester where
1648− parseJSON = withObject "PhraseSuggester" parse
1649− where parse o = PhraseSuggester
1650− <$> o .: "field"
1651− <*> o .:? "gram_size"
1652− <*> o .:? "real_word_error_likelihood"
1653− <*> o .:? "confidence"
1654− <*> o .:? "max_errors"
1655− <*> o .:? "separator"
1656− <*> o .:? "size"
1657− <*> o .:? "analyzer"
1658− <*> o .:? "shard_size"
1659− <*> o .:? "highlight"
1660− <*> o .:? "collate"
1661− <*> o .:? "direct_generator" .!= []
1662−
1663−mkPhraseSuggester :: FieldName -> PhraseSuggester
1664−mkPhraseSuggester fName =
1665− PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing
1666− Nothing Nothing Nothing Nothing []
1667−
1668−data PhraseSuggesterHighlighter =
1669− PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text
1670− , phraseSuggesterHighlighterPostTag :: Text
1671− }
1672− deriving (Eq, Show)
1673−
1674−instance ToJSON PhraseSuggesterHighlighter where
1675− toJSON PhraseSuggesterHighlighter{..} =
1676− object [ "pre_tag" .= phraseSuggesterHighlighterPreTag
1677− , "post_tag" .= phraseSuggesterHighlighterPostTag
1678− ]
1679−
1680−instance FromJSON PhraseSuggesterHighlighter where
1681− parseJSON = withObject "PhraseSuggesterHighlighter" parse
1682− where parse o = PhraseSuggesterHighlighter
1683− <$> o .: "pre_tag"
1684− <*> o .: "post_tag"
1685−
1686−data PhraseSuggesterCollate =
1687− PhraseSuggesterCollate { phraseSuggesterCollateTemplateQuery :: TemplateQueryInline
1688− , phraseSuggesterCollatePrune :: Bool
1689− }
1690− deriving (Eq, Show)
1691−
1692−instance ToJSON PhraseSuggesterCollate where
1693− toJSON PhraseSuggesterCollate{..} = object [ "query" .= object
1694− [ "inline" .= (inline phraseSuggesterCollateTemplateQuery)
1695− ]
1696− , "params" .= (params phraseSuggesterCollateTemplateQuery)
1697− , "prune" .= phraseSuggesterCollatePrune
1698− ]
1699−
1700−instance FromJSON PhraseSuggesterCollate where
1701− parseJSON (Object o) = do
1702− query' <- o .: "query"
1703− inline' <- query' .: "inline"
1704− params' <- o .: "params"
1705− prune' <- o .:? "prune" .!= False
1706− return $ PhraseSuggesterCollate (TemplateQueryInline inline' params') prune'
1707− parseJSON x = typeMismatch "PhraseSuggesterCollate" x
1708−
1709−data SuggestOptions =
1710− SuggestOptions { suggestOptionsText :: Text
1711− , suggestOptionsScore :: Double
1712− , suggestOptionsFreq :: Maybe Int
1713− , suggestOptionsHighlighted :: Maybe Text
1714− }
1715− deriving (Eq, Read, Show)
1716−
1717−instance FromJSON SuggestOptions where
1718− parseJSON = withObject "SuggestOptions" parse
1719− where parse o = SuggestOptions
1720− <$> o .: "text"
1721− <*> o .: "score"
1722− <*> o .:? "freq"
1723− <*> o .:? "highlighted"
1724−
1725−data SuggestResponse =
1726− SuggestResponse { suggestResponseText :: Text
1727− , suggestResponseOffset :: Int
1728− , suggestResponseLength :: Int
1729− , suggestResponseOptions :: [SuggestOptions]
1730− }
1731− deriving (Eq, Read, Show)
1732−
1733−instance FromJSON SuggestResponse where
1734− parseJSON = withObject "SuggestResponse" parse
1735− where parse o = SuggestResponse
1736− <$> o .: "text"
1737− <*> o .: "offset"
1738− <*> o .: "length"
1739− <*> o .: "options"
1740−
1741−data NamedSuggestionResponse =
1742− NamedSuggestionResponse { nsrName :: Text
1743− , nsrResponses :: [SuggestResponse]
1744− }
1745− deriving (Eq, Read, Show)
1746−
1747−instance FromJSON NamedSuggestionResponse where
1748− parseJSON (Object o) = do
1749− suggestionName' <- case HM.toList o of
1750− [(x, _)] -> return x
1751− _ -> fail "error parsing NamedSuggestionResponse name"
1752− suggestionResponses' <- o .: suggestionName'
1753− return $ NamedSuggestionResponse suggestionName' suggestionResponses'
1754−
1755− parseJSON x = typeMismatch "NamedSuggestionResponse" x
1756−
1757−data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing
1758− | DirectGeneratorSuggestModePopular
1759− | DirectGeneratorSuggestModeAlways
1760− deriving (Eq, Show)
1761−
1762−instance ToJSON DirectGeneratorSuggestModeTypes where
1763− toJSON DirectGeneratorSuggestModeMissing = "missing"
1764− toJSON DirectGeneratorSuggestModePopular = "popular"
1765− toJSON DirectGeneratorSuggestModeAlways = "always"
1766−
1767−instance FromJSON DirectGeneratorSuggestModeTypes where
1768− parseJSON = withText "DirectGeneratorSuggestModeTypes" parse
1769− where parse "missing" = pure DirectGeneratorSuggestModeMissing
1770− parse "popular" = pure DirectGeneratorSuggestModePopular
1771− parse "always" = pure DirectGeneratorSuggestModeAlways
1772− parse f = fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f)
1773−
1774−data DirectGenerators = DirectGenerators
1775− { directGeneratorsField :: FieldName
1776− , directGeneratorsSize :: Maybe Int
1777− , directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes
1778− , directGeneratorMaxEdits :: Maybe Double
1779− , directGeneratorPrefixLength :: Maybe Int
1780− , directGeneratorMinWordLength :: Maybe Int
1781− , directGeneratorMaxInspections :: Maybe Int
1782− , directGeneratorMinDocFreq :: Maybe Double
1783− , directGeneratorMaxTermFreq :: Maybe Double
1784− , directGeneratorPreFilter :: Maybe Text
1785− , directGeneratorPostFilter :: Maybe Text
1786− }
1787− deriving (Eq, Show)
1788−
1789−
1790−instance ToJSON DirectGenerators where
1791− toJSON DirectGenerators{..} = omitNulls [ "field" .= directGeneratorsField
1792− , "size" .= directGeneratorsSize
1793− , "suggest_mode" .= directGeneratorSuggestMode
1794− , "max_edits" .= directGeneratorMaxEdits
1795− , "prefix_length" .= directGeneratorPrefixLength
1796− , "min_word_length" .= directGeneratorMinWordLength
1797− , "max_inspections" .= directGeneratorMaxInspections
1798− , "min_doc_freq" .= directGeneratorMinDocFreq
1799− , "max_term_freq" .= directGeneratorMaxTermFreq
1800− , "pre_filter" .= directGeneratorPreFilter
1801− , "post_filter" .= directGeneratorPostFilter
1802− ]
1803−
1804−instance FromJSON DirectGenerators where
1805− parseJSON = withObject "DirectGenerators" parse
1806− where parse o = DirectGenerators
1807− <$> o .: "field"
1808− <*> o .:? "size"
1809− <*> o .: "suggest_mode"
1810− <*> o .:? "max_edits"
1811− <*> o .:? "prefix_length"
1812− <*> o .:? "min_word_length"
1813− <*> o .:? "max_inspections"
1814− <*> o .:? "min_doc_freq"
1815− <*> o .:? "max_term_freq"
1816− <*> o .:? "pre_filter"
1817− <*> o .:? "post_filter"
1818−
1819−mkDirectGenerators :: FieldName -> DirectGenerators
1820−mkDirectGenerators fn = DirectGenerators fn Nothing DirectGeneratorSuggestModeMissing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
src/Database/V5/Bloodhound/Types/Class.hsdeleted−17
@@ -1,17 +0,0 @@
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-7.10.yamldeleted−21
@@ -1,21 +0,0 @@
1−flags:
2− bloodhound-examples:
3− werror: true
4−packages:
5−- '.'
6−- './examples'
7−extra-deps:
8−- http-client-0.5.0
9−- aeson-1.2.0.0
10−- fail-4.9.0.0
11−- http-types-0.9
12−- attoparsec-0.13.0.1
13−- quickcheck-properties-0.1
14−- semigroups-0.18.3
15−- uri-bytestring-0.1.9
16−- temporary-resourcet-0.1.0.0
17−- transformers-compat-0.5.1.4
18−- pretty-simple-2.0.2.0
19−- quickcheck-arbitrary-template-0.2.0.0
20−
21−resolver: lts-6.12
stack-7.8.yamldeleted−25
@@ -1,25 +0,0 @@
1−flags:
2− aeson:
3− old-locale: true
4− bloodhound-examples:
5− werror: true
6−packages:
7−- '.'
8−- './examples'
9−extra-deps:
10−- aeson-0.11.1.0
11−- fail-4.9.0.0
12−- http-types-0.9
13−- http-client-0.5.0
14−- attoparsec-0.13.0.1
15−- quickcheck-properties-0.1
16−- semigroups-0.18.0.1
17−- tagged-0.8.3
18−- uri-bytestring-0.1.9
19−- void-0.7.1
20−- generics-sop-0.2.2.0
21−- unordered-containers-0.2.6.0
22−- pretty-simple-2.0.2.0
23−- quickcheck-arbitrary-template-0.2.0.0
24−
25−resolver: lts-2.18
stack-8.2.yaml+4−3
@@ -7,8 +7,9 @@ packages:
7 - './examples'
7 - './examples'
8
8
9extra-deps:
9extra-deps:
10− - quickcheck-properties-0.1
10+ - aeson-1.3.0.0
11− - http-types-0.12
11+ - http-types-0.12.1
12 - quickcheck-arbitrary-template-0.2.0.0
12 - quickcheck-arbitrary-template-0.2.0.0
13+ - quickcheck-properties-0.1
13
14
14−resolver: lts-10.0
15+resolver: lts-11.6
stack-8.2.yaml.locknew file+40
@@ -0,0 +1,40 @@
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.yamlnew file+15
@@ -0,0 +1,15 @@
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.locknew file+12
@@ -0,0 +1,12 @@
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.yamlnew file+14
@@ -0,0 +1,14 @@
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.locknew file+33
@@ -0,0 +1,33 @@
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.2.yaml
1+stack-8.6.yaml
stack.yaml.locknew file+12
@@ -0,0 +1,12 @@
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/Test/Aggregation.hsnew file+147
@@ -0,0 +1,147 @@
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.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.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 "returns stats aggregation results" $ withTestEnv $ do
46+ _ <- insertData
47+ let stats = StatsAgg $ mkStatsAggregation $ FieldName "age"
48+ let search = mkAggregateSearch Nothing $ mkAggregations "users" stats
49+ let search' = search { Database.Bloodhound.from = From 0, size = Size 0 }
50+ searchExpectAggs search'
51+ let statsAggRes k n = (k, object [ "max" .= Number n
52+ , "avg" .= Number n
53+ , "count" .= Number 1
54+ , "min" .= Number n
55+ , "sum" .= Number n])
56+ res <- searchTweets search'
57+ liftIO $
58+ fmap aggregations res `shouldBe` Right (Just (M.fromList [ statsAggRes "users" 10000]))
59+
60+ it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do
61+ _ <- insertData
62+ let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
63+ let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
64+ searchExpectAggs search
65+ searchValidBucketAgg search "users" toTerms
66+
67+ -- One of these fails with 1.7.3
68+ it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
69+ _ <- insertData
70+ searchTermsAggHint [Map, Ordinals]
71+
72+ it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
73+ _ <- insertData
74+ searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
75+
76+ it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
77+ _ <- insertData
78+ searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
79+ -- One of the above.
80+
81+ it "can execute value_count aggregations" $ withTestEnv $ do
82+ _ <- insertData
83+ _ <- insertOther
84+ let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
85+ mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
86+ let search = mkAggregateSearch Nothing ags
87+ let docCountPair k n = (k, object ["value" .= Number n])
88+ res <- searchTweets search
89+ liftIO $
90+ fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
91+ , docCountPair "bogus_count" 0
92+ ]))
93+
94+ it "can execute date_range aggregations" $ withTestEnv $ do
95+ let now = fromGregorian 2015 3 14
96+ let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0
97+ let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0
98+ let oldDoc = exampleTweet { postDate = ltAMonthAgo }
99+ let newDoc = exampleTweet { postDate = ltAWeekAgo }
100+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings oldDoc (DocId "1")
101+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings newDoc (DocId "2")
102+ _ <- refreshIndex testIndex
103+ let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth])
104+ let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek])
105+ let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek])
106+ let ags = mkAggregations "date_ranges" (DateRangeAgg agg)
107+ let search = mkAggregateSearch Nothing ags
108+ res <- searchTweets search
109+ liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right 2
110+ let bucks = do magrs <- fmapL show (aggregations <$> res)
111+ agrs <- note "no aggregations returned" magrs
112+ rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs
113+ parseEither parseJSON rawBucks
114+ let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0
115+ let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0
116+ liftIO $ buckets <$> bucks `shouldBe` Right [ DateRangeResult "2015-02-14T00:00:00.000Z-*"
117+ (Just fromMonthT)
118+ (Just "2015-02-14T00:00:00.000Z")
119+ Nothing
120+ Nothing
121+ 2
122+ Nothing
123+ , DateRangeResult "2015-03-07T00:00:00.000Z-*"
124+ (Just fromWeekT)
125+ (Just "2015-03-07T00:00:00.000Z")
126+ Nothing
127+ Nothing
128+ 1
129+ Nothing
130+ ]
131+
132+ it "returns date histogram aggregation results" $ withTestEnv $ do
133+ _ <- insertData
134+ let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
135+ let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
136+ searchExpectAggs search
137+ searchValidBucketAgg search "byDate" toDateHistogram
138+
139+ it "can execute missing aggregations" $ withTestEnv $ do
140+ _ <- insertData
141+ _ <- insertExtra
142+ let ags = mkAggregations "missing_agg" (MissingAgg (MissingAggregation "extra"))
143+ let search = mkAggregateSearch Nothing ags
144+ let docCountPair k n = (k, object ["doc_count" .= Number n])
145+ res <- searchTweets search
146+ liftIO $
147+ fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "missing_agg" 1]))
tests/V5/Test/ApproxEq.hs → tests/Test/ApproxEq.hsrenamed+1−1
@@ -3,7 +3,7 @@
3
3
4module Test.ApproxEq where
4module Test.ApproxEq where
5
5
6−import Database.V5.Bloodhound
6+import Database.Bloodhound
7
7
8import Test.Import
8import Test.Import
9
9
tests/Test/BulkAPI.hsnew file+95
@@ -0,0 +1,95 @@
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 thirdTest = BulkTest "graffle"
34+ let fourthTest = BulkTest "garabadoo"
35+ let fifthTest = BulkTest "serenity"
36+ let firstDoc = BulkIndex testIndex
37+ testMapping (DocId "2") (toJSON firstTest)
38+ let secondDoc = BulkCreate testIndex
39+ testMapping (DocId "3") (toJSON secondTest)
40+ let thirdDoc = BulkCreateEncoding testIndex
41+ testMapping (DocId "4") (toEncoding thirdTest)
42+ let fourthDoc = BulkIndexAuto testIndex
43+ testMapping (toJSON fourthTest)
44+ let fifthDoc = BulkIndexEncodingAuto testIndex
45+ testMapping (toEncoding fifthTest)
46+ let stream = V.fromList [firstDoc, secondDoc, thirdDoc, fourthDoc, fifthDoc]
47+ _ <- bulk stream
48+ -- liftIO $ pPrint bulkResp
49+ _ <- refreshIndex testIndex
50+ -- liftIO $ pPrint refreshResp
51+ fDoc <- getDocument testIndex testMapping (DocId "2")
52+ sDoc <- getDocument testIndex testMapping (DocId "3")
53+ tDoc <- getDocument testIndex testMapping (DocId "4")
54+ -- note that we cannot query for fourthDoc and fifthDoc since we
55+ -- do not know their autogenerated ids.
56+ let maybeFirst =
57+ eitherDecode
58+ $ responseBody fDoc
59+ :: Either String (EsResult BulkTest)
60+ let maybeSecond =
61+ eitherDecode
62+ $ responseBody sDoc
63+ :: Either String (EsResult BulkTest)
64+ let maybeThird =
65+ eitherDecode
66+ $ responseBody tDoc
67+ :: Either String (EsResult BulkTest)
68+ -- liftIO $ pPrint [maybeFirst, maybeSecond, maybeThird]
69+ liftIO $ do
70+ fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
71+ fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
72+ fmap getSource maybeThird `shouldBe` Right (Just thirdTest)
73+ -- Since we can't get the docs by doc id, we check for their existence in
74+ -- a match all query.
75+ let query = MatchAllQuery Nothing
76+ let search = mkSearch (Just query) Nothing
77+ resp <- searchByIndex testIndex search
78+ parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))
79+ case parsed of
80+ Left e ->
81+ liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)
82+ (Right sr) -> do
83+ liftIO $
84+ hitsTotal (searchHits sr) `shouldBe` 6
85+ let nameList :: [Text]
86+ nameList =
87+ hits (searchHits sr)
88+ ^.. traverse
89+ . to hitSource
90+ . _Just
91+ . LMA.key "name"
92+ . _String
93+ liftIO $
94+ nameList
95+ `shouldBe` ["blah","bloo","graffle","garabadoo","serenity"]
tests/Test/Common.hsnew file+292
@@ -0,0 +1,292 @@
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.SemVer as SemVer
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+ , "fielddata" .= True
43+ ]
44+ -- Serializing the date as a date is breaking other tests, mysteriously.
45+ -- , "postDate" .= object [ "type" .= ("date" :: Text)
46+ -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
47+ , "message" .= object ["type" .= ("string" :: Text)]
48+ , "age" .= object ["type" .= ("integer" :: Text)]
49+ , "location" .= object ["type" .= ("geo_point" :: Text)]
50+ , "extra" .= object ["type" .= ("keyword" :: Text)]
51+ ]]
52+
53+es11 :: SemVer.Version
54+es11 = SemVer.version 1 1 0 [] []
55+
56+es13 :: SemVer.Version
57+es13 = SemVer.version 1 3 0 [] []
58+
59+es12 :: SemVer.Version
60+es12 = SemVer.version 1 2 0 [] []
61+
62+es14 :: SemVer.Version
63+es14 = SemVer.version 1 4 0 [] []
64+
65+es15 :: SemVer.Version
66+es15 = SemVer.version 1 5 0 [] []
67+
68+es16 :: SemVer.Version
69+es16 = SemVer.version 1 6 0 [] []
70+
71+es20 :: SemVer.Version
72+es20 = SemVer.version 2 0 0 [] []
73+
74+es50 :: SemVer.Version
75+es50 = SemVer.version 5 0 0 [] []
76+
77+getServerVersion :: IO (Maybe SemVer.Version)
78+getServerVersion = fmap extractVersion <$> withTestEnv getStatus
79+ where
80+ extractVersion = versionNumber . number . version
81+
82+createExampleIndex :: (MonadBH m) => m Reply
83+createExampleIndex =
84+ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
85+
86+deleteExampleIndex :: (MonadBH m) => m Reply
87+deleteExampleIndex =
88+ deleteIndex testIndex
89+
90+validateStatus :: Show body => Response body -> Int -> Expectation
91+validateStatus resp expected =
92+ if actual == expected
93+ then return ()
94+ else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)
95+ where
96+ actual = NHTS.statusCode (responseStatus resp)
97+ body = responseBody resp
98+
99+data ChildMapping = ChildMapping deriving (Eq, Show)
100+
101+instance ToJSON ChildMapping where
102+ toJSON ChildMapping =
103+ object ["_parent" .= object ["type" .= ("parent" :: Text)]
104+ , "properties" .=
105+ object [ "user" .= object ["type" .= ("string" :: Text)
106+ , "fielddata" .= True
107+ ]
108+ -- Serializing the date as a date is breaking other tests, mysteriously.
109+ -- , "postDate" .= object [ "type" .= ("date" :: Text)
110+ -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
111+ , "message" .= object ["type" .= ("string" :: Text)]
112+ , "age" .= object ["type" .= ("integer" :: Text)]
113+ , "location" .= object ["type" .= ("geo_point" :: Text)]
114+ , "extra" .= object ["type" .= ("keyword" :: Text)]
115+ ]]
116+
117+data TweetMapping = TweetMapping deriving (Eq, Show)
118+
119+instance ToJSON TweetMapping where
120+ toJSON TweetMapping =
121+ object ["tweet" .=
122+ object ["properties" .=
123+ object [ "user" .= object [ "type" .= ("string" :: Text)
124+ , "fielddata" .= True
125+ ]
126+ -- Serializing the date as a date is breaking other tests, mysteriously.
127+ -- , "postDate" .= object [ "type" .= ("date" :: Text)
128+ -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
129+ , "message" .= object ["type" .= ("string" :: Text)]
130+ , "age" .= object ["type" .= ("integer" :: Text)]
131+ , "location" .= object ["type" .= ("geo_point" :: Text)]
132+ , "extra" .= object ["type" .= ("keyword" :: Text)]
133+ ]]]
134+
135+exampleTweet :: Tweet
136+exampleTweet = Tweet { user = "bitemyapp"
137+ , postDate = UTCTime
138+ (ModifiedJulianDay 55000)
139+ (secondsToDiffTime 10)
140+ , message = "Use haskell!"
141+ , age = 10000
142+ , location = Location 40.12 (-71.34)
143+ , extra = Nothing }
144+
145+tweetWithExtra :: Tweet
146+tweetWithExtra = Tweet { user = "bitemyapp"
147+ , postDate = UTCTime
148+ (ModifiedJulianDay 55000)
149+ (secondsToDiffTime 10)
150+ , message = "Use haskell!"
151+ , age = 10000
152+ , location = Location 40.12 (-71.34)
153+ , extra = Just "blah blah" }
154+
155+newAge :: Int
156+newAge = 31337
157+
158+newUser :: Text
159+newUser = "someotherapp"
160+
161+tweetPatch :: Value
162+tweetPatch =
163+ object [ "age" .= newAge
164+ , "user" .= newUser
165+ ]
166+
167+patchedTweet :: Tweet
168+patchedTweet = exampleTweet{age = newAge, user = newUser}
169+
170+otherTweet :: Tweet
171+otherTweet = Tweet { user = "notmyapp"
172+ , postDate = UTCTime
173+ (ModifiedJulianDay 55000)
174+ (secondsToDiffTime 11)
175+ , message = "Use haskell!"
176+ , age = 1000
177+ , location = Location 40.12 (-71.34)
178+ , extra = Nothing }
179+
180+resetIndex :: BH IO ()
181+resetIndex = do
182+ _ <- deleteExampleIndex
183+ _ <- createExampleIndex
184+ _ <- putMapping testIndex testMapping TweetMapping
185+ return ()
186+
187+insertData :: BH IO Reply
188+insertData = do
189+ resetIndex
190+ insertData' defaultIndexDocumentSettings
191+
192+insertData' :: IndexDocumentSettings -> BH IO Reply
193+insertData' ids = do
194+ r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
195+ _ <- refreshIndex testIndex
196+ return r
197+
198+updateData :: BH IO Reply
199+updateData = do
200+ r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1")
201+ _ <- refreshIndex testIndex
202+ return r
203+
204+insertOther :: BH IO ()
205+insertOther = do
206+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
207+ _ <- refreshIndex testIndex
208+ return ()
209+
210+insertExtra :: BH IO ()
211+insertExtra = do
212+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4")
213+ _ <- refreshIndex testIndex
214+ return ()
215+
216+insertWithSpaceInId :: BH IO ()
217+insertWithSpaceInId = do
218+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
219+ _ <- refreshIndex testIndex
220+ return ()
221+
222+searchTweet :: Search -> BH IO (Either EsError Tweet)
223+searchTweet search = do
224+ result <- searchTweets search
225+ let myTweet :: Either EsError Tweet
226+ myTweet = grabFirst result
227+ return myTweet
228+
229+searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
230+searchTweets search = parseEsResponse =<< searchByIndex testIndex search
231+
232+searchExpectNoResults :: Search -> BH IO ()
233+searchExpectNoResults search = do
234+ result <- searchTweets search
235+ let emptyHits = fmap (hits . searchHits) result
236+ liftIO $
237+ emptyHits `shouldBe` Right []
238+
239+searchExpectAggs :: Search -> BH IO ()
240+searchExpectAggs search = do
241+ reply <- searchByIndex testIndex search
242+ let isEmpty x = return (M.null x)
243+ let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
244+ liftIO $
245+ (result >>= aggregations >>= isEmpty) `shouldBe` Just False
246+
247+searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
248+ Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
249+searchValidBucketAgg search aggKey extractor = do
250+ reply <- searchByIndex testIndex search
251+ let bucketDocs = docCount . head . buckets
252+ let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
253+ let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
254+ liftIO $
255+ count `shouldBe` Just 1
256+
257+searchTermsAggHint :: [ExecutionHint] -> BH IO ()
258+searchTermsAggHint hints = do
259+ let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
260+ let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
261+ forM_ hints $ searchExpectAggs . search
262+ forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
263+
264+searchTweetHighlight :: Search
265+ -> BH IO (Either EsError (Maybe HitHighlight))
266+searchTweetHighlight search = do
267+ result <- searchTweets search
268+ let tweetHit :: Either EsError (Maybe (Hit Tweet))
269+ tweetHit = fmap (headMay . hits . searchHits) result
270+ myHighlight :: Either EsError (Maybe HitHighlight)
271+ myHighlight = (join . fmap hitHighlight) <$> tweetHit
272+ return myHighlight
273+
274+searchExpectSource :: Source -> Either EsError Value -> BH IO ()
275+searchExpectSource src expected = do
276+ _ <- insertData
277+ let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
278+ let search = (mkSearch (Just query) Nothing) { source = Just src }
279+ reply <- searchByIndex testIndex search
280+ result <- parseEsResponse reply
281+ let value = grabFirst result
282+ liftIO $
283+ value `shouldBe` expected
284+
285+atleast :: SemVer.Version -> IO Bool
286+atleast v = getServerVersion >>= \x -> return $ x >= Just v
287+
288+atmost :: SemVer.Version -> IO Bool
289+atmost v = getServerVersion >>= \x -> return $ x <= Just v
290+
291+is :: SemVer.Version -> IO Bool
292+is v = getServerVersion >>= \x -> return $ x == Just v
tests/Test/Documents.hsnew file+51
@@ -0,0 +1,51 @@
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+ _ <- putMapping testIndex (MappingName "child") ChildMapping
44+ _ <- putMapping testIndex (MappingName "parent") ParentMapping
45+ _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
46+ let parent = (Just . DocumentParent . DocId) "1"
47+ ids = IndexDocumentSettings NoVersionControl parent
48+ _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
49+ _ <- refreshIndex testIndex
50+ exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
51+ liftIO $ exists `shouldBe` True
tests/V5/Test/Generators.hs → tests/Test/Generators.hsrenamed+42−13
@@ -5,7 +5,7 @@
5
5
6module Test.Generators where
6module Test.Generators where
7
7
8−import Database.V5.Bloodhound
8+import Database.Bloodhound
9
9
10import Test.Import
10import Test.Import
11
11
@@ -14,7 +14,7 @@ import qualified Data.List as L
14import qualified Data.List.NonEmpty as NE
14import qualified Data.List.NonEmpty as NE
15import qualified Data.Map as M
15import qualified Data.Map as M
16import qualified Data.Text as T
16import qualified Data.Text as T
17−import qualified Data.Version as Vers
17+import qualified Data.SemVer as SemVer
18import Test.QuickCheck.TH.Generators
18import Test.QuickCheck.TH.Generators
19
19
20import Test.ApproxEq
20import Test.ApproxEq
@@ -36,8 +36,10 @@ instance Arbitrary UTCTime where
36 <*> (fromRational . toRational <$> choose (0::Double, 86400))
36 <*> (fromRational . toRational <$> choose (0::Double, 86400))
37
37
38instance Arbitrary Day where
38instance Arbitrary Day where
39+ arbitrary =
39− arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary
40+ ModifiedJulianDay . (2000 +) <$> arbitrary
41+ shrink =
40− shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay
42+ (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay
41
43
42#if !MIN_VERSION_QuickCheck(2,9,0)
44#if !MIN_VERSION_QuickCheck(2,9,0)
43instance Arbitrary a => Arbitrary (NonEmpty a) where
45instance Arbitrary a => Arbitrary (NonEmpty a) where
@@ -53,6 +55,7 @@ instance (Arbitrary a, Typeable a) => Arbitrary (Hit a) where
53 <*> arbitrary
55 <*> arbitrary
54 <*> arbitraryScore
56 <*> arbitraryScore
55 <*> arbitrary
57 <*> arbitrary
58+ <*> return Nothing
56 <*> arbitrary
59 <*> arbitrary
57 <*> arbitrary
60 <*> arbitrary
58
61
@@ -181,7 +184,7 @@ instance Arbitrary Query where
181
184
182instance Arbitrary Filter where
185instance Arbitrary Filter where
183 arbitrary =
186 arbitrary =
184− Filter <$> arbitrary
187+ Filter <$> arbitrary
185 shrink (Filter q) =
188 shrink (Filter q) =
186 Filter <$> shrink q
189 Filter <$> shrink q
187
190
@@ -208,14 +211,22 @@ instance Arbitrary NodeAttrName where
208instance Arbitrary NodeAttrFilter where
211instance Arbitrary NodeAttrFilter where
209 arbitrary = do
212 arbitrary = do
210 n <- arbitrary
213 n <- arbitrary
211− s:ss <- listOf1 (listOf1 arbitraryAlphaNum)
214+ xs <- listOf1 (listOf1 arbitraryAlphaNum)
215+ let (s, ss) = unpackConsPartial xs
212− let ts = T.pack <$> s :| ss
216+ ts = T.pack <$> s :| ss
213 return (NodeAttrFilter n ts)
217 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"
214
221
215instance Arbitrary VersionNumber where
222instance Arbitrary VersionNumber where
216− arbitrary = mk . fmap getPositive . getNonEmpty <$> arbitrary
223+ arbitrary = do
224+ major <- posInt
225+ minor <- posInt
226+ patch <- posInt
227+ return $ VersionNumber $ SemVer.version major minor patch [] []
217 where
228 where
218− mk versions = VersionNumber (Vers.Version versions [])
229+ posInt = getPositive <$> arbitrary
219
230
220instance Arbitrary TemplateQueryKeyValuePairs where
231instance Arbitrary TemplateQueryKeyValuePairs where
221 arbitrary = TemplateQueryKeyValuePairs . HM.fromList <$> arbitrary
232 arbitrary = TemplateQueryKeyValuePairs . HM.fromList <$> arbitrary
@@ -433,15 +444,29 @@ makeArbitrary ''Language
433instance Arbitrary Language where arbitrary = arbitraryLanguage
444instance Arbitrary Language where arbitrary = arbitraryLanguage
434makeArbitrary ''Shingle
445makeArbitrary ''Shingle
435instance Arbitrary Shingle where arbitrary = arbitraryShingle
446instance Arbitrary Shingle where arbitrary = arbitraryShingle
447+
448+makeArbitrary ''CharFilter
449+instance Arbitrary CharFilter where arbitrary = arbitraryCharFilter
436makeArbitrary ''AnalyzerDefinition
450makeArbitrary ''AnalyzerDefinition
437instance Arbitrary AnalyzerDefinition where arbitrary = arbitraryAnalyzerDefinition
451instance Arbitrary AnalyzerDefinition where arbitrary = arbitraryAnalyzerDefinition
452+
453+-- TODO: This should have a proper generator that doesn't
454+-- create garbage that has to be filtered out.
455+instance Arbitrary CharFilterDefinition where
456+ arbitrary =
457+ oneof [ CharFilterDefinitionMapping
458+ . chomp <$> arbitrary
459+ , CharFilterDefinitionPatternReplace
460+ <$> arbitrary <*> arbitrary <*> arbitrary
461+ ]
462+ where chomp =
463+ M.map T.strip
464+ . M.mapKeys (T.replace "=>" "" . T.strip)
465+
438makeArbitrary ''Analysis
466makeArbitrary ''Analysis
439instance Arbitrary Analysis where arbitrary = arbitraryAnalysis
467instance Arbitrary Analysis where arbitrary = arbitraryAnalysis
440makeArbitrary ''Tokenizer
468makeArbitrary ''Tokenizer
441instance Arbitrary Tokenizer where arbitrary = arbitraryTokenizer
469instance Arbitrary Tokenizer where arbitrary = arbitraryTokenizer
442−makeArbitrary ''UpdatableIndexSetting
443−instance Arbitrary UpdatableIndexSetting where
444− arbitrary = arbitraryUpdatableIndexSetting
445makeArbitrary ''Compression
470makeArbitrary ''Compression
446instance Arbitrary Compression where arbitrary = arbitraryCompression
471instance Arbitrary Compression where arbitrary = arbitraryCompression
447makeArbitrary ''Bytes
472makeArbitrary ''Bytes
@@ -511,6 +536,10 @@ instance Arbitrary FactorMissingFieldValue where arbitrary = arbitraryFactorMiss
511makeArbitrary ''FactorModifier
536makeArbitrary ''FactorModifier
512instance Arbitrary FactorModifier where arbitrary = arbitraryFactorModifier
537instance Arbitrary FactorModifier where arbitrary = arbitraryFactorModifier
513
538
539+makeArbitrary ''UpdatableIndexSetting
540+instance Arbitrary UpdatableIndexSetting where
541+ arbitrary = resize 10 arbitraryUpdatableIndexSetting
542+
514newtype UpdatableIndexSetting' =
543newtype UpdatableIndexSetting' =
515 UpdatableIndexSetting' UpdatableIndexSetting
544 UpdatableIndexSetting' UpdatableIndexSetting
516 deriving (Show, Eq, ToJSON, FromJSON, ApproxEq, Typeable)
545 deriving (Show, Eq, ToJSON, FromJSON, ApproxEq, Typeable)
@@ -531,4 +560,4 @@ instance Arbitrary UpdatableIndexSetting' where
531 NE.fromList . L.nubBy sameAttrName . NE.toList
560 NE.fromList . L.nubBy sameAttrName . NE.toList
532 sameAttrName a b =
561 sameAttrName a b =
533 nodeAttrFilterName a == nodeAttrFilterName b
562 nodeAttrFilterName a == nodeAttrFilterName b
534− -- shrink (UpdatableIndexSetting' x) = map UpdatableIndexSetting' (shrink x)
563+ shrink (UpdatableIndexSetting' x) = map UpdatableIndexSetting' (shrink x)
tests/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.hs → tests/Test/Import.hsrenamed+29−3
@@ -1,5 +1,8 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
1module Test.Import
3module Test.Import
2 ( module X
4 ( module X
5+ , module Test.Import
3 ) where
6 ) where
4
7
5
8
@@ -11,15 +14,16 @@ import Control.Monad.Reader as X
11import Data.Aeson as X
14import Data.Aeson as X
12import Data.Aeson.TH as X
15import Data.Aeson.TH as X
13import Data.Aeson.Types as X (parseEither)
16import Data.Aeson.Types as X (parseEither)
17+import Data.Maybe as X
14import Data.List.NonEmpty as X (NonEmpty(..))
18import Data.List.NonEmpty as X (NonEmpty(..))
15import Data.Monoid as X
19import Data.Monoid as X
16import Data.Ord as X (comparing)
20import Data.Ord as X (comparing)
17import Data.Proxy as X
21import Data.Proxy as X
18import Data.Text as X (Text)
22import Data.Text as X (Text)
19−import Data.Time.Calendar as X (Day(..))
23+import Data.Time.Calendar as X (Day(..), fromGregorian)
20import Data.Time.Clock as X
24import Data.Time.Clock as X
21import Data.Typeable as X
25import Data.Typeable as X
22−import Database.V5.Bloodhound as X hiding (key)
26+import Database.Bloodhound as X hiding (key)
23import Lens.Micro as X
27import Lens.Micro as X
24import Lens.Micro.Aeson as X
28import Lens.Micro.Aeson as X
25import Network.HTTP.Client as X hiding (Proxy, fileSize)
29import Network.HTTP.Client as X hiding (Proxy, fileSize)
@@ -27,6 +31,28 @@ import System.IO.Temp as X
27import System.PosixCompat.Files as X
31import System.PosixCompat.Files as X
28import Test.Hspec as X
32import Test.Hspec as X
29import Test.Hspec.QuickCheck as X (prop)
33import Test.Hspec.QuickCheck as X (prop)
30−import Test.QuickCheck as X hiding (Result, Success)
34+import Test.QuickCheck as X hiding (Result, Success, isSuccess)
31import Test.QuickCheck.Property.Monoid as X (T (..), eq, prop_Monoid)
35import Test.QuickCheck.Property.Monoid as X (T (..), eq, prop_Monoid)
32import Text.Pretty.Simple as X (pPrint)
36import 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.hsnew file+173
@@ -0,0 +1,173 @@
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+import qualified Data.Map as M
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+ it "allows alias deletion" $ do
41+ aliases <- withTestEnv $ do
42+ resetIndex
43+ resp <- updateIndexAliases (action :| [])
44+ liftIO $ validateStatus resp 200
45+ _ <- deleteIndexAlias aname
46+ getIndexAliases
47+ -- let expected = IndexAliasSummary alias create
48+ case aliases of
49+ Right (IndexAliasesSummary summs) ->
50+ L.find ( (== aname)
51+ . indexAlias
52+ . indexAliasSummaryAlias
53+ ) summs
54+ `shouldBe` Nothing
55+ Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)
56+
57+ describe "Index Listing" $ do
58+ it "returns a list of index names" $ withTestEnv $ do
59+ _ <- createExampleIndex
60+ ixns <- listIndices
61+ liftIO (ixns `shouldContain` [testIndex])
62+
63+ describe "Index Settings" $ do
64+ it "persists settings" $ withTestEnv $ do
65+ _ <- deleteExampleIndex
66+ _ <- createExampleIndex
67+ let updates = BlocksWrite False :| []
68+ updateResp <- updateIndexSettings updates testIndex
69+ liftIO $ validateStatus updateResp 200
70+ getResp <- getIndexSettings testIndex
71+ liftIO $
72+ getResp `shouldBe` Right (IndexSettingsSummary
73+ testIndex
74+ (IndexSettings (ShardCount 1) (ReplicaCount 0))
75+ (NE.toList updates))
76+
77+ it "allows total fields to be set" $ when' (atleast es50) $ withTestEnv $ do
78+ _ <- deleteExampleIndex
79+ _ <- createExampleIndex
80+ let updates = MappingTotalFieldsLimit 2500 :| []
81+ updateResp <- updateIndexSettings updates testIndex
82+ liftIO $ validateStatus updateResp 200
83+ getResp <- getIndexSettings testIndex
84+ liftIO $
85+ getResp `shouldBe` Right (IndexSettingsSummary
86+ testIndex
87+ (IndexSettings (ShardCount 1) (ReplicaCount 0))
88+ (NE.toList updates))
89+
90+ it "accepts customer analyzers" $ when' (atleast es50) $ withTestEnv $ do
91+ _ <- deleteExampleIndex
92+ let analysis = Analysis
93+ (M.singleton "ex_analyzer"
94+ ( AnalyzerDefinition
95+ (Just (Tokenizer "ex_tokenizer"))
96+ (map TokenFilter
97+ [ "ex_filter_lowercase","ex_filter_uppercase","ex_filter_apostrophe"
98+ , "ex_filter_reverse","ex_filter_snowball"
99+ , "ex_filter_shingle"
100+ ]
101+ )
102+ (map CharFilter
103+ ["html_strip", "ex_mapping", "ex_pattern_replace"]
104+ )
105+ )
106+ )
107+ (M.singleton "ex_tokenizer"
108+ ( TokenizerDefinitionNgram
109+ ( Ngram 3 4 [TokenLetter,TokenDigit])
110+ )
111+ )
112+ (M.fromList
113+ [ ("ex_filter_lowercase",TokenFilterDefinitionLowercase (Just Greek))
114+ , ("ex_filter_uppercase",TokenFilterDefinitionUppercase Nothing)
115+ , ("ex_filter_apostrophe",TokenFilterDefinitionApostrophe)
116+ , ("ex_filter_reverse",TokenFilterDefinitionReverse)
117+ , ("ex_filter_snowball",TokenFilterDefinitionSnowball English)
118+ , ("ex_filter_shingle",TokenFilterDefinitionShingle (Shingle 3 3 True False " " "_"))
119+ , ("ex_filter_stemmer",TokenFilterDefinitionStemmer German)
120+ , ("ex_filter_stop1", TokenFilterDefinitionStop (Left French))
121+ , ("ex_filter_stop2",
122+ TokenFilterDefinitionStop
123+ (Right
124+ $ map StopWord ["a", "is", "the"]))
125+ ]
126+ )
127+ (M.fromList
128+ [ ("ex_mapping", CharFilterDefinitionMapping (M.singleton "١" "1"))
129+ , ("ex_pattern_replace", CharFilterDefinitionPatternReplace "(\\d+)-(?=\\d)" "$1_" Nothing)
130+ ]
131+ )
132+ updates = [AnalysisSetting analysis]
133+ createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
134+ liftIO $ validateStatus createResp 200
135+ getResp <- getIndexSettings testIndex
136+ liftIO $
137+ getResp `shouldBe` Right (IndexSettingsSummary
138+ testIndex
139+ (IndexSettings (ShardCount 1) (ReplicaCount 0))
140+ updates
141+ )
142+
143+ it "accepts default compression codec" $ when' (atleast es50) $ withTestEnv $ do
144+ _ <- deleteExampleIndex
145+ let updates = [CompressionSetting CompressionDefault]
146+ createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
147+ liftIO $ validateStatus createResp 200
148+ getResp <- getIndexSettings testIndex
149+ liftIO $ getResp `shouldBe` Right
150+ (IndexSettingsSummary testIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) updates)
151+
152+ it "accepts best compression codec" $ when' (atleast es50) $ withTestEnv $ do
153+ _ <- deleteExampleIndex
154+ let updates = [CompressionSetting CompressionBest]
155+ createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
156+ liftIO $ validateStatus createResp 200
157+ getResp <- getIndexSettings testIndex
158+ liftIO $ getResp `shouldBe` Right
159+ (IndexSettingsSummary testIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) updates)
160+
161+
162+ describe "Index Optimization" $ do
163+ it "returns a successful response upon completion" $ withTestEnv $ do
164+ _ <- createExampleIndex
165+ resp <- forceMergeIndex (IndexList (testIndex :| [])) defaultForceMergeIndexSettings
166+ liftIO $ validateStatus resp 200
167+
168+
169+ describe "Index flushing" $ do
170+ it "returns a successful response upon flushing" $ withTestEnv $ do
171+ _ <- createExampleIndex
172+ resp <- flushIndex testIndex
173+ liftIO $ validateStatus resp 200
tests/V5/Test/JSON.hs → tests/Test/JSON.hsrenamed+48−9
@@ -1,19 +1,17 @@
1+{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE ScopedTypeVariables #-}
2
3
3−module Test.JSON where
4+module Test.JSON (spec) where
4
5
5−import Database.V5.Bloodhound
6+import Test.Import
6
7
7−import Data.Aeson
8−import Data.Aeson.Types (parseEither)
9import qualified Data.ByteString.Lazy.Char8 as BL8
8import qualified Data.ByteString.Lazy.Char8 as BL8
10import qualified Data.List as L
9import qualified Data.List as L
10+import Data.List.NonEmpty (NonEmpty(..))
11import qualified Data.List.NonEmpty as NE
11import qualified Data.List.NonEmpty as NE
12−import Data.Monoid
12+import qualified Data.HashMap.Strict as HM
13−import Data.Typeable
13+import qualified Data.Text as T
14−import Test.Hspec
14+import qualified Data.Vector as V
15−import Test.Hspec.QuickCheck
16−import Test.QuickCheck
17
15
18import Test.ApproxEq
16import Test.ApproxEq
19import Test.Generators
17import Test.Generators
@@ -52,6 +50,47 @@ propApproxJSON _ = prop testName $ \(a :: a) ->
52
50
53spec :: Spec
51spec :: Spec
54spec = do
52spec = 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+
55 describe "Exact isomorphism JSON instances" $ do
94 describe "Exact isomorphism JSON instances" $ do
56 propJSON (Proxy :: Proxy Version)
95 propJSON (Proxy :: Proxy Version)
57 propJSON (Proxy :: Proxy IndexName)
96 propJSON (Proxy :: Proxy IndexName)
tests/Test/Query.hsnew file+132
@@ -0,0 +1,132 @@
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' = Filter $ MatchAllQuery Nothing
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' = Filter $ MatchAllQuery Nothing
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' = Filter $ MatchAllQuery Nothing
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 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
59+ _ <- insertData
60+ let flds = [FieldName "user", FieldName "message"]
61+ let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
62+ let search = mkSearch (Just query) Nothing
63+ myTweet <- searchTweet search
64+ liftIO $
65+ myTweet `shouldBe` Right exampleTweet
66+
67+ it "returns document for multi-match query with a custom tiebreaker" $ withTestEnv $ do
68+ _ <- insertData
69+ let tiebreaker = Just $ Tiebreaker 0.3
70+ flds = [FieldName "user", FieldName "message"]
71+ multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")
72+ query = QueryMultiMatchQuery $ multiQuery' { multiMatchQueryTiebreaker = tiebreaker }
73+ search = mkSearch (Just query) Nothing
74+ myTweet <- searchTweet search
75+ liftIO $
76+ myTweet `shouldBe` Right exampleTweet
77+
78+ it "returns document for bool query" $ withTestEnv $ do
79+ _ <- insertData
80+ let innerQuery = QueryMatchQuery $
81+ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
82+ let query = QueryBoolQuery $
83+ mkBoolQuery [innerQuery] [] [] []
84+ let search = mkSearch (Just query) Nothing
85+ myTweet <- searchTweet search
86+ liftIO $
87+ myTweet `shouldBe` Right exampleTweet
88+
89+ it "returns document for boosting query" $ withTestEnv $ do
90+ _ <- insertData
91+ let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
92+ let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
93+ let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
94+ let search = mkSearch (Just query) Nothing
95+ myTweet <- searchTweet search
96+ liftIO $
97+ myTweet `shouldBe` Right exampleTweet
98+
99+ it "returns document for common terms query" $ withTestEnv $ do
100+ _ <- insertData
101+ let query = QueryCommonTermsQuery $
102+ CommonTermsQuery (FieldName "user")
103+ (QueryString "bitemyapp")
104+ (CutoffFrequency 0.0001)
105+ Or Or Nothing Nothing Nothing Nothing
106+ let search = mkSearch (Just query) Nothing
107+ myTweet <- searchTweet search
108+ liftIO $
109+ myTweet `shouldBe` Right exampleTweet
110+
111+ it "returns document for for inline template query" $ withTestEnv $ do
112+ _ <- insertData
113+ let innerQuery = QueryMatchQuery $
114+ mkMatchQuery (FieldName "{{userKey}}")
115+ (QueryString "{{bitemyappKey}}")
116+ templateParams = TemplateQueryKeyValuePairs $ HM.fromList
117+ [ ("userKey", "user")
118+ , ("bitemyappKey", "bitemyapp")
119+ ]
120+ templateQuery = QueryTemplateQueryInline $
121+ TemplateQueryInline innerQuery templateParams
122+ search = mkSearch (Just templateQuery) Nothing
123+ myTweet <- searchTweet search
124+ liftIO $ myTweet `shouldBe` Right exampleTweet
125+
126+ it "returns document for wildcard query" $ withTestEnv $ do
127+ _ <- insertData
128+ let query = QueryWildcardQuery $ WildcardQuery (FieldName "user") "bitemy*" (Nothing)
129+ let search = mkSearch (Just query) Nothing
130+ myTweet <- searchTweet search
131+ liftIO $
132+ myTweet `shouldBe` Right exampleTweet
tests/Test/Script.hsnew file+36
@@ -0,0 +1,36 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Test.Script where
4+
5+import Test.Common
6+import Test.Import
7+
8+import qualified Data.HashMap.Strict as HM
9+import qualified Data.Map as M
10+
11+spec :: Spec
12+spec =
13+ describe "Script" $
14+ it "returns a transformed document based on the script field" $ withTestEnv $ do
15+ _ <- insertData
16+ let query = MatchAllQuery Nothing
17+ sfv = toJSON $
18+ Script
19+ (Just (ScriptLanguage "painless"))
20+ (Just (ScriptInline "doc['age'].value * 2"))
21+ Nothing
22+ Nothing
23+ sf = ScriptFields $
24+ HM.fromList [("test1", sfv)]
25+ search' = mkSearch (Just query) Nothing
26+ search = search' { scriptFields = Just sf }
27+ resp <- searchByIndex testIndex search
28+ parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))
29+ case parsed of
30+ Left e ->
31+ liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)
32+ Right sr -> do
33+ let Just results =
34+ hitFields (head (hits (searchHits sr)))
35+ liftIO $
36+ results `shouldBe` HitFields (M.fromList [("test1", [Number 20000.0])])
tests/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.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 Nothing
18+ Nothing Nothing
19+ result <- searchTweets search
20+ let myTweet = grabFirst result
21+ liftIO $
22+ myTweet `shouldBe` Right otherTweet
tests/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.hsnew file+23
@@ -0,0 +1,23 @@
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 query = QueryMatchNoneQuery
14+ phraseSuggester = mkPhraseSuggester (FieldName "message")
15+ namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
16+ search' = mkSearch (Just query) Nothing
17+ search = search' { suggestBody = Just namedSuggester }
18+ expectedText = Just "use haskell"
19+ resp <- searchByIndex testIndex search
20+ parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))
21+ case parsed of
22+ Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)
23+ Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText
tests/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/V1/tests.hsdeleted−1966
@@ -1,1966 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE RecordWildCards #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# OPTIONS_GHC -fno-warn-orphans #-}
12−#if __GLASGOW_HASKELL__ < 800
13−{-# OPTIONS_GHC -fcontext-stack=100 #-}
14−#endif
15−#if __GLASGOW_HASKELL__ >= 802
16−{-# LANGUAGE MonoLocalBinds #-}
17−#endif
18−module Main where
19−
20−import Control.Applicative
21−import Control.Error
22−import Control.Exception (evaluate)
23−import Control.Monad
24−import Control.Monad.Catch
25−import Control.Monad.Reader
26−import Data.Aeson
27−import Data.Aeson.Types (parseEither)
28−import qualified Data.ByteString.Lazy.Char8 as BL8
29−import qualified Data.HashMap.Strict as HM
30−import Data.List (nub)
31−import qualified Data.List as L
32−import Data.List.NonEmpty (NonEmpty (..))
33−import qualified Data.List.NonEmpty as NE
34−import qualified Data.Map.Strict as M
35−import Data.Monoid
36−import Data.Ord (comparing)
37−import Data.Proxy
38−import Data.Text (Text)
39−import qualified Data.Text as T
40−import Data.Time.Calendar (Day (..), fromGregorian)
41−import Data.Time.Clock (NominalDiffTime, UTCTime (..),
42− secondsToDiffTime)
43−import Data.Typeable
44−import qualified Data.Vector as V
45−import qualified Data.Version as Vers
46−import Database.V1.Bloodhound
47−import GHC.Generics as G
48−import Network.HTTP.Client hiding (Proxy)
49−import qualified Network.HTTP.Types.Method as NHTM
50−import qualified Network.HTTP.Types.Status as NHTS
51−import qualified Network.URI as URI
52−import Prelude hiding (filter)
53−import System.IO.Temp
54−import System.PosixCompat.Files
55−import Test.Hspec
56−import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid)
57−
58−import Test.Hspec.QuickCheck (prop)
59−import Test.QuickCheck
60−
61−import qualified Generics.SOP as SOP
62−import qualified Generics.SOP.GGP as SOP
63−
64−testServer :: Server
65−testServer = Server "http://localhost:9200"
66−testIndex :: IndexName
67−testIndex = IndexName "bloodhound-tests-twitter-1"
68−testMapping :: MappingName
69−testMapping = MappingName "tweet"
70−
71−withTestEnv :: BH IO a -> IO a
72−withTestEnv = withBH defaultManagerSettings testServer
73−
74−validateStatus :: Show body => Response body -> Int -> Expectation
75−validateStatus resp expected =
76− if actual == expected
77− then return ()
78− else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)
79− where
80− actual = NHTS.statusCode (responseStatus resp)
81− body = responseBody resp
82−
83−createExampleIndex :: (MonadBH m) => m Reply
84−createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
85−deleteExampleIndex :: (MonadBH m) => m Reply
86−deleteExampleIndex = deleteIndex testIndex
87−
88−es13 :: Vers.Version
89−es13 = Vers.Version [1, 3, 0] []
90−
91−es12 :: Vers.Version
92−es12 = Vers.Version [1, 2, 0] []
93−
94−es11 :: Vers.Version
95−es11 = Vers.Version [1, 1, 0] []
96−
97−es14 :: Vers.Version
98−es14 = Vers.Version [1, 4, 0] []
99−
100−es15 :: Vers.Version
101−es15 = Vers.Version [1, 5, 0] []
102−
103−es16 :: Vers.Version
104−es16 = Vers.Version [1, 6, 0] []
105−
106−es20 :: Vers.Version
107−es20 = Vers.Version [2, 0, 0] []
108−
109−getServerVersion :: IO (Maybe Vers.Version)
110−getServerVersion = fmap extractVersion <$> withTestEnv getStatus
111− where
112− extractVersion = versionNumber . number . version
113−
114−-- | Get configured repo paths for snapshotting. Note that by default
115−-- this is not enabled and if we are over es 1.5, we won't be able to
116−-- test snapshotting. Note that this can and should be part of the
117−-- client functionality in a much less ad-hoc incarnation.
118−getRepoPaths :: IO [FilePath]
119−getRepoPaths = withTestEnv $ do
120− bhe <- getBHEnv
121− let Server s = bhServer bhe
122− let tUrl = s <> "/" <> "_nodes"
123− initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl))
124− let req = setRequestIgnoreStatus $ initReq { method = NHTM.methodGet }
125− Right (Object o) <- parseEsResponse =<< liftIO (httpLbs req (bhManager bhe))
126− return $ fromMaybe mempty $ do
127− Object nodes <- HM.lookup "nodes" o
128− Object firstNode <- snd <$> headMay (HM.toList nodes)
129− Object settings <- HM.lookup "settings" firstNode
130− Object path <- HM.lookup "path" settings
131− Array repo <- HM.lookup "repo" path
132− return [ T.unpack t | String t <- V.toList repo]
133−
134−-- | 1.5 and earlier don't care about repo paths
135−canSnapshot :: IO Bool
136−canSnapshot = do
137− caresAboutRepos <- atleast es16
138− repoPaths <- getRepoPaths
139− return (not caresAboutRepos || not (null (repoPaths)))
140−
141−atleast :: Vers.Version -> IO Bool
142−atleast v = getServerVersion >>= \x -> return $ x >= Just v
143−
144−atmost :: Vers.Version -> IO Bool
145−atmost v = getServerVersion >>= \x -> return $ x <= Just v
146−
147−is :: Vers.Version -> IO Bool
148−is v = getServerVersion >>= \x -> return $ x == Just v
149−
150−when' :: Monad m => m Bool -> m () -> m ()
151−when' b f = b >>= \x -> when x f
152−
153−(==~) :: (ApproxEq a) => a -> a -> Property
154−a ==~ b = counterexample (showApproxEq a ++ " !=~ " ++ showApproxEq b) (a =~ b)
155−
156−propJSON :: forall a. (Arbitrary a, ToJSON a, FromJSON a, Show a, ApproxEq a, Typeable a) => Proxy a -> Spec
157−propJSON _ = prop testName $ \(a :: a) ->
158− let jsonStr = "via " <> BL8.unpack (encode a)
159− in counterexample jsonStr (parseEither parseJSON (toJSON a) ==~ Right a)
160− where testName = show ty <> " FromJSON/ToJSON roundtrips"
161− ty = typeOf (undefined :: a)
162−
163−data Location = Location { lat :: Double
164− , lon :: Double } deriving (Eq, Generic, Show)
165−
166−data Tweet = Tweet { user :: Text
167− , postDate :: UTCTime
168− , message :: Text
169− , age :: Int
170− , location :: Location
171− , extra :: Maybe Text }
172− deriving (Eq, Generic, Show)
173−
174−instance ToJSON Tweet where
175− toJSON = genericToJSON defaultOptions
176−instance FromJSON Tweet where
177− parseJSON = genericParseJSON defaultOptions
178−instance ToJSON Location where
179− toJSON = genericToJSON defaultOptions
180−instance FromJSON Location where
181− parseJSON = genericParseJSON defaultOptions
182−
183−data ParentMapping = ParentMapping deriving (Eq, Show)
184−
185−instance ToJSON ParentMapping where
186− toJSON ParentMapping =
187− object ["properties" .=
188− object [ "user" .= object ["type" .= ("string" :: Text)]
189− -- Serializing the date as a date is breaking other tests, mysteriously.
190− -- , "postDate" .= object [ "type" .= ("date" :: Text)
191− -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
192− , "message" .= object ["type" .= ("string" :: Text)]
193− , "age" .= object ["type" .= ("integer" :: Text)]
194− , "location" .= object ["type" .= ("geo_point" :: Text)]
195− ]]
196−
197−data ChildMapping = ChildMapping deriving (Eq, Show)
198−
199−instance ToJSON ChildMapping where
200− toJSON ChildMapping =
201− object ["_parent" .= object ["type" .= ("parent" :: Text)]
202− , "properties" .=
203− object [ "user" .= object ["type" .= ("string" :: Text)]
204− -- Serializing the date as a date is breaking other tests, mysteriously.
205− -- , "postDate" .= object [ "type" .= ("date" :: Text)
206− -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
207− , "message" .= object ["type" .= ("string" :: Text)]
208− , "age" .= object ["type" .= ("integer" :: Text)]
209− , "location" .= object ["type" .= ("geo_point" :: Text)]
210− ]]
211−
212−data TweetMapping = TweetMapping deriving (Eq, Show)
213−
214−instance ToJSON TweetMapping where
215− toJSON TweetMapping =
216− object ["properties" .=
217− object [ "user" .= object ["type" .= ("string" :: Text)]
218− -- Serializing the date as a date is breaking other tests, mysteriously.
219− -- , "postDate" .= object [ "type" .= ("date" :: Text)
220− -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
221− , "message" .= object ["type" .= ("string" :: Text)]
222− , "age" .= object ["type" .= ("integer" :: Text)]
223− , "location" .= object ["type" .= ("geo_point" :: Text)]
224− ]]
225−
226−exampleTweet :: Tweet
227−exampleTweet = Tweet { user = "bitemyapp"
228− , postDate = UTCTime
229− (ModifiedJulianDay 55000)
230− (secondsToDiffTime 10)
231− , message = "Use haskell!"
232− , age = 10000
233− , location = Location 40.12 (-71.34)
234− , extra = Nothing }
235−
236−tweetWithExtra :: Tweet
237−tweetWithExtra = Tweet { user = "bitemyapp"
238− , postDate = UTCTime
239− (ModifiedJulianDay 55000)
240− (secondsToDiffTime 10)
241− , message = "Use haskell!"
242− , age = 10000
243− , location = Location 40.12 (-71.34)
244− , extra = Just "blah blah" }
245−
246−newAge :: Int
247−newAge = 31337
248−
249−newUser :: Text
250−newUser = "someotherapp"
251−
252−tweetPatch :: Value
253−tweetPatch =
254− object [ "age" .= newAge
255− , "user" .= newUser
256− ]
257−
258−patchedTweet :: Tweet
259−patchedTweet = exampleTweet{age = newAge, user = newUser}
260−
261−otherTweet :: Tweet
262−otherTweet = Tweet { user = "notmyapp"
263− , postDate = UTCTime
264− (ModifiedJulianDay 55000)
265− (secondsToDiffTime 11)
266− , message = "Use haskell!"
267− , age = 1000
268− , location = Location 40.12 (-71.34)
269− , extra = Nothing }
270−
271−resetIndex :: BH IO ()
272−resetIndex = do
273− _ <- deleteExampleIndex
274− _ <- createExampleIndex
275− _ <- putMapping testIndex testMapping TweetMapping
276− return ()
277−
278−insertData :: BH IO Reply
279−insertData = do
280− resetIndex
281− insertData' defaultIndexDocumentSettings
282−
283−insertData' :: IndexDocumentSettings -> BH IO Reply
284−insertData' ids = do
285− r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
286− _ <- refreshIndex testIndex
287− return r
288−
289−updateData :: BH IO Reply
290−updateData = do
291− r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1")
292− _ <- refreshIndex testIndex
293− return r
294−
295−insertOther :: BH IO ()
296−insertOther = do
297− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
298− _ <- refreshIndex testIndex
299− return ()
300−
301−insertExtra :: BH IO ()
302−insertExtra = do
303− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4")
304− _ <- refreshIndex testIndex
305− return ()
306−
307−insertWithSpaceInId :: BH IO ()
308−insertWithSpaceInId = do
309− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
310− _ <- refreshIndex testIndex
311− return ()
312−
313−searchTweet :: Search -> BH IO (Either EsError Tweet)
314−searchTweet search = do
315− result <- searchTweets search
316− let myTweet :: Either EsError Tweet
317− myTweet = grabFirst result
318− return myTweet
319−
320−searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
321−searchTweets search = parseEsResponse =<< searchByIndex testIndex search
322−
323−searchExpectNoResults :: Search -> BH IO ()
324−searchExpectNoResults search = do
325− result <- searchTweets search
326− let emptyHits = fmap (hits . searchHits) result
327− liftIO $
328− emptyHits `shouldBe` Right []
329−
330−searchExpectAggs :: Search -> BH IO ()
331−searchExpectAggs search = do
332− reply <- searchByIndex testIndex search
333− let isEmpty x = return (M.null x)
334− let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
335− liftIO $
336− (result >>= aggregations >>= isEmpty) `shouldBe` Just False
337−
338−searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
339− Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
340−searchValidBucketAgg search aggKey extractor = do
341− reply <- searchByIndex testIndex search
342− let bucketDocs = docCount . head . buckets
343− let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
344− let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
345− liftIO $
346− count `shouldBe` Just 1
347−
348−searchTermsAggHint :: [ExecutionHint] -> BH IO ()
349−searchTermsAggHint hints = do
350− let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
351− let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
352− forM_ hints $ searchExpectAggs . search
353− forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
354−
355−searchTweetHighlight :: Search -> BH IO (Either EsError (Maybe HitHighlight))
356−searchTweetHighlight search = do
357− result <- searchTweets search
358− let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
359− return myHighlight
360−
361−searchExpectSource :: Source -> Either EsError Value -> BH IO ()
362−searchExpectSource src expected = do
363− _ <- insertData
364− let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
365− let search = (mkSearch (Just query) Nothing) { source = Just src }
366− reply <- searchByIndex testIndex search
367− result <- parseEsResponse reply
368− let value = grabFirst result
369− liftIO $
370− value `shouldBe` expected
371−
372−withSnapshotRepo
373− :: ( MonadMask m
374− , MonadBH m
375− )
376− => SnapshotRepoName
377− -> (GenericSnapshotRepo -> m a)
378− -> m a
379−withSnapshotRepo srn@(SnapshotRepoName n) f = do
380− repoPaths <- liftIO getRepoPaths
381− -- we'll use the first repo path if available, otherwise system temp
382− -- dir. Note that this will fail on ES > 1.6, so be sure you use
383− -- @when' canSnapshot@.
384− case repoPaths of
385− (firstRepoPath:_) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f
386− [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f
387− where
388− alloc dir = do
389− liftIO (setFileMode dir mode)
390− let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing
391− resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo
392− liftIO (validateStatus resp 200)
393− return (toGSnapshotRepo repo)
394− mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes
395− free GenericSnapshotRepo {..} = do
396− resp <- deleteSnapshotRepo gSnapshotRepoName
397− liftIO (validateStatus resp 200)
398−
399−
400−withSnapshot
401− :: ( MonadMask m
402− , MonadBH m
403− )
404− => SnapshotRepoName
405− -> SnapshotName
406− -> m a
407− -> m a
408−withSnapshot srn sn = bracket_ alloc free
409− where
410− alloc = do
411− resp <- createSnapshot srn sn createSettings
412− liftIO (validateStatus resp 200)
413− -- We'll make this synchronous for testing purposes
414− createSettings = defaultSnapshotCreateSettings { snapWaitForCompletion = True
415− , snapIndices = Just (IndexList (testIndex :| []))
416− -- We don't actually need to back up any data
417− }
418− free = do
419− deleteSnapshot srn sn
420−
421−
422−
423−data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
424−instance FromJSON BulkTest where
425− parseJSON = genericParseJSON defaultOptions
426−instance ToJSON BulkTest where
427− toJSON = genericToJSON defaultOptions
428−
429−class GApproxEq f where
430− gApproxEq :: f a -> f a -> Bool
431−
432−-- | Unit type
433−instance GApproxEq U1 where
434− gApproxEq U1 U1 = True
435−
436−-- | Sum type, ensure same constructors, recurse
437−instance (GApproxEq a, GApproxEq b) => GApproxEq (a :+: b) where
438− gApproxEq (L1 a) (L1 b) = gApproxEq a b
439− gApproxEq (R1 a) (R1 b) = gApproxEq a b
440− gApproxEq _ _ = False
441−
442−-- | Product type, ensure each field is approx eq
443−instance (GApproxEq a, GApproxEq b) => GApproxEq (a :*: b) where
444− gApproxEq (a1 :*: b1) (a2 :*: b2) = gApproxEq a1 a2 && gApproxEq b1 b2
445−
446−-- | Value type, actually check the values for approx equality
447−instance (ApproxEq a) => GApproxEq (K1 i a) where
448− gApproxEq (K1 a) (K1 b) = a =~ b
449−
450−instance (GApproxEq f) => GApproxEq (M1 i t f) where
451− gApproxEq (M1 a) (M1 b) = gApproxEq a b
452−
453−-- | Typeclass for "equal where it matters". Use this to specify
454−-- less-strict equivalence for things such as lists that can wind up
455−-- in an unpredictable order
456−class ApproxEq a where
457− (=~) :: a -> a -> Bool
458− default (=~) :: (Generic a, GApproxEq (Rep a)) => a -> a -> Bool
459− a =~ b = gApproxEq (G.from a) (G.from b)
460−
461− showApproxEq :: a -> String
462− default showApproxEq :: (Show a) => a -> String
463− showApproxEq = show
464−
465−instance ApproxEq NominalDiffTime where (=~) = (==)
466−instance ApproxEq UTCTime where (=~) = (==)
467−instance ApproxEq Text where (=~) = (==)
468−instance ApproxEq Bool where (=~) = (==)
469−instance ApproxEq Int where (=~) = (==)
470−instance ApproxEq Double where (=~) = (==)
471−instance (ApproxEq a, Show a) => ApproxEq (NonEmpty a)
472−instance (ApproxEq a, Show a) => ApproxEq (Maybe a)
473−instance ApproxEq GeoPoint
474−instance ApproxEq Regexp
475−instance ApproxEq RangeValue
476−instance ApproxEq LessThan
477−instance ApproxEq LessThanEq
478−instance ApproxEq LessThanD
479−instance ApproxEq LessThanEqD
480−instance ApproxEq GreaterThan
481−instance ApproxEq GreaterThanEq
482−instance ApproxEq GreaterThanD
483−instance ApproxEq GreaterThanEqD
484−instance ApproxEq MinimumMatchHighLow
485−instance ApproxEq RegexpFlag
486−instance ApproxEq RegexpFlags
487−instance ApproxEq NullValue
488−instance ApproxEq Version
489−instance ApproxEq VersionNumber
490−instance ApproxEq DistanceRange
491−instance ApproxEq IndexName
492−instance ApproxEq MappingName
493−instance ApproxEq DocId
494−instance ApproxEq IndexAliasRouting
495−instance ApproxEq RoutingValue
496−instance ApproxEq ShardCount
497−instance ApproxEq ReplicaCount
498−instance ApproxEq TemplateName
499−instance ApproxEq TemplatePattern
500−instance ApproxEq QueryString
501−instance ApproxEq FieldName
502−instance ApproxEq CacheName
503−instance ApproxEq CacheKey
504−instance ApproxEq Existence
505−instance ApproxEq CutoffFrequency
506−instance ApproxEq Analyzer
507−instance ApproxEq Lenient
508−instance ApproxEq Tiebreaker
509−instance ApproxEq Boost
510−instance ApproxEq BoostTerms
511−instance ApproxEq MaxExpansions
512−instance ApproxEq MinimumMatch
513−instance ApproxEq DisableCoord
514−instance ApproxEq IgnoreTermFrequency
515−instance ApproxEq MinimumTermFrequency
516−instance ApproxEq MaxQueryTerms
517−instance ApproxEq Fuzziness
518−instance ApproxEq PrefixLength
519−instance ApproxEq TypeName
520−instance ApproxEq PercentMatch
521−instance ApproxEq StopWord
522−instance ApproxEq QueryPath
523−instance ApproxEq AllowLeadingWildcard
524−instance ApproxEq LowercaseExpanded
525−instance ApproxEq EnablePositionIncrements
526−instance ApproxEq AnalyzeWildcard
527−instance ApproxEq GeneratePhraseQueries
528−instance ApproxEq Locale
529−instance ApproxEq MaxWordLength
530−instance ApproxEq MinWordLength
531−instance ApproxEq PhraseSlop
532−instance ApproxEq MinDocFrequency
533−instance ApproxEq MaxDocFrequency
534−instance ApproxEq Filter
535−instance ApproxEq Query
536−instance ApproxEq SimpleQueryStringQuery
537−instance ApproxEq FieldOrFields
538−instance ApproxEq SimpleQueryFlag
539−instance ApproxEq RegexpQuery
540−instance ApproxEq QueryStringQuery
541−instance ApproxEq RangeQuery
542−instance ApproxEq PrefixQuery
543−instance ApproxEq NestedQuery
544−instance ApproxEq MoreLikeThisFieldQuery
545−instance ApproxEq MoreLikeThisQuery
546−instance ApproxEq IndicesQuery
547−instance ApproxEq HasParentQuery
548−instance ApproxEq HasChildQuery
549−instance ApproxEq FuzzyQuery
550−instance ApproxEq FuzzyLikeFieldQuery
551−instance ApproxEq FuzzyLikeThisQuery
552−instance ApproxEq FilteredQuery
553−instance ApproxEq DisMaxQuery
554−instance ApproxEq CommonTermsQuery
555−instance ApproxEq CommonMinimumMatch
556−instance ApproxEq BoostingQuery
557−instance ApproxEq BoolQuery
558−instance ApproxEq MatchQuery
559−instance ApproxEq MultiMatchQueryType
560−instance ApproxEq BooleanOperator
561−instance ApproxEq ZeroTermsQuery
562−instance ApproxEq MatchQueryType
563−instance ApproxEq AliasRouting
564−instance ApproxEq IndexAliasCreate
565−instance ApproxEq SearchAliasRouting
566−instance ApproxEq ScoreType
567−instance ApproxEq Distance
568−instance ApproxEq DistanceUnit
569−instance ApproxEq DistanceType
570−instance ApproxEq OptimizeBbox
571−instance ApproxEq GeoBoundingBoxConstraint
572−instance ApproxEq GeoFilterType
573−instance ApproxEq GeoBoundingBox
574−instance ApproxEq LatLon
575−instance ApproxEq RangeExecution
576−instance ApproxEq FSType
577−instance ApproxEq CompoundFormat
578−instance ApproxEq InitialShardCount
579−instance ApproxEq Bytes
580−instance ApproxEq ReplicaBounds
581−instance ApproxEq Term
582−instance ApproxEq BoolMatch
583−instance ApproxEq MultiMatchQuery
584−instance ApproxEq IndexSettings
585−instance ApproxEq AllocationPolicy
586−instance ApproxEq Char where
587− (=~) = (==)
588−instance ApproxEq Vers.Version where
589− (=~) = (==)
590−instance (ApproxEq a, Show a) => ApproxEq [a] where
591− as =~ bs = and (zipWith (=~) as bs)
592−instance (ApproxEq l, ApproxEq r) => ApproxEq (Either l r) where
593− Left a =~ Left b = a =~ b
594− Right a =~ Right b = a =~ b
595− _ =~ _ = False
596− showApproxEq (Left x) = "Left " <> showApproxEq x
597− showApproxEq (Right x) = "Right " <> showApproxEq x
598−instance ApproxEq NodeAttrFilter
599−instance ApproxEq NodeAttrName
600−instance ApproxEq BuildHash
601−instance ApproxEq TemplateQueryKeyValuePairs where
602− (=~) = (==)
603−instance ApproxEq TemplateQueryInline
604−instance ApproxEq Size
605−instance ApproxEq PhraseSuggesterHighlighter
606−instance ApproxEq PhraseSuggesterCollate
607−instance ApproxEq PhraseSuggester
608−instance ApproxEq SuggestType
609−instance ApproxEq Suggest
610−instance ApproxEq DirectGenerators
611−instance ApproxEq DirectGeneratorSuggestModeTypes
612−
613−-- | Due to the way nodeattrfilters get serialized here, they may come
614−-- out in a different order, but they are morally equivalent
615−instance ApproxEq UpdatableIndexSetting where
616− RoutingAllocationInclude a =~ RoutingAllocationInclude b =
617− NE.sort a =~ NE.sort b
618− RoutingAllocationExclude a =~ RoutingAllocationExclude b =
619− NE.sort a =~ NE.sort b
620− RoutingAllocationRequire a =~ RoutingAllocationRequire b =
621− NE.sort a =~ NE.sort b
622− a =~ b = a == b
623− showApproxEq (RoutingAllocationInclude xs) = show (RoutingAllocationInclude (NE.sort xs))
624− showApproxEq (RoutingAllocationExclude xs) = show (RoutingAllocationExclude (NE.sort xs))
625− showApproxEq (RoutingAllocationRequire xs) = show (RoutingAllocationRequire (NE.sort xs))
626− showApproxEq x = show x
627−
628−
629−noDuplicates :: Eq a => [a] -> Bool
630−noDuplicates xs = nub xs == xs
631−
632−instance Arbitrary NominalDiffTime where
633− arbitrary = fromInteger <$> arbitrary
634−
635−#if !MIN_VERSION_QuickCheck(2,8,0)
636−instance (Arbitrary k, Ord k, Arbitrary v) => Arbitrary (M.Map k v) where
637− arbitrary = M.fromList <$> arbitrary
638−#endif
639−
640−instance Arbitrary Text where
641− arbitrary = T.pack <$> arbitrary
642−
643−instance Arbitrary UTCTime where
644− arbitrary = UTCTime
645− <$> arbitrary
646− <*> (fromRational . toRational <$> choose (0::Double, 86400))
647−
648−instance Arbitrary Day where
649− arbitrary = ModifiedJulianDay <$> (2000 +) <$> arbitrary
650− shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay
651−
652−#if !MIN_VERSION_QuickCheck(2,9,0)
653−instance Arbitrary a => Arbitrary (NonEmpty a) where
654− arbitrary = liftA2 (:|) arbitrary arbitrary
655−#endif
656−
657−arbitraryScore :: Gen Score
658−arbitraryScore = fmap getPositive <$> arbitrary
659−
660−instance (Arbitrary a, Typeable a) => Arbitrary (Hit a) where
661− arbitrary = Hit <$> arbitrary
662− <*> arbitrary
663− <*> arbitrary
664− <*> arbitraryScore
665− <*> arbitrary
666− <*> arbitrary
667− shrink = genericShrink
668−
669−
670−instance (Arbitrary a, Typeable a) => Arbitrary (SearchHits a) where
671− arbitrary = reduceSize $ do
672− tot <- getPositive <$> arbitrary
673− score <- arbitraryScore
674− hs <- arbitrary
675− return $ SearchHits tot score hs
676− shrink = genericShrink
677−
678−reduceSize :: Gen a -> Gen a
679−reduceSize f = sized $ \n -> resize (n `div` 2) f
680−
681−getSource :: EsResult a -> Maybe a
682−getSource = fmap _source . foundResult
683−
684−grabFirst :: Either EsError (SearchResult a) -> Either EsError a
685−grabFirst r =
686− case fmap (hitSource . head . hits . searchHits) r of
687− (Left e) -> Left e
688− (Right Nothing) -> Left (EsError 500 "Source was missing")
689− (Right (Just x)) -> Right x
690−
691−-------------------------------------------------------------------------------
692−arbitraryAlphaNum :: Gen Char
693−arbitraryAlphaNum = oneof [choose ('a', 'z')
694− ,choose ('A','Z')
695− , choose ('0', '9')]
696−
697−instance Arbitrary RoutingValue where
698− arbitrary = RoutingValue . T.pack <$> listOf1 arbitraryAlphaNum
699−
700−instance Arbitrary AliasRouting where
701− arbitrary = oneof [allAlias
702− ,one
703− ,theOther
704− ,both]
705− where one = GranularAliasRouting
706− <$> (Just <$> arbitrary)
707− <*> pure Nothing
708− theOther = GranularAliasRouting Nothing
709− <$> (Just <$> arbitrary)
710− both = GranularAliasRouting
711− <$> (Just <$> arbitrary)
712− <*> (Just <$> arbitrary)
713− allAlias = AllAliasRouting <$> arbitrary
714− shrink = genericShrink
715−
716−
717−instance Arbitrary FieldName where
718− arbitrary = FieldName . T.pack <$> listOf1 arbitraryAlphaNum
719− shrink = genericShrink
720−
721−
722−#if MIN_VERSION_base(4,10,0)
723−-- Test.QuickCheck.Modifiers
724−
725−qcNonEmptyToNonEmpty :: NonEmptyList a -> NonEmpty a
726−qcNonEmptyToNonEmpty (NonEmpty (a : xs)) = (a :| xs)
727−qcNonEmptyToNonEmpty (NonEmpty []) = error "NonEmpty was empty!"
728−
729−instance Arbitrary a => Arbitrary (NonEmpty a) where
730− arbitrary = qcNonEmptyToNonEmpty <$> arbitrary
731−#endif
732−
733−instance Arbitrary RegexpFlags where
734− arbitrary = oneof [ pure AllRegexpFlags
735− , pure NoRegexpFlags
736− , SomeRegexpFlags <$> genUniqueFlags
737− ]
738− where genUniqueFlags = NE.fromList . nub <$> listOf1 arbitrary
739− shrink = genericShrink
740−
741−
742−instance Arbitrary IndexAliasCreate where
743− arbitrary = IndexAliasCreate <$> arbitrary <*> reduceSize arbitrary
744− shrink = genericShrink
745−
746−instance Arbitrary Query where
747− arbitrary = reduceSize $ oneof [ TermQuery <$> arbitrary <*> arbitrary
748− , TermsQuery <$> arbitrary <*> arbitrary
749− , QueryMatchQuery <$> arbitrary
750− , QueryMultiMatchQuery <$> arbitrary
751− , QueryBoolQuery <$> arbitrary
752− , QueryBoostingQuery <$> arbitrary
753− , QueryCommonTermsQuery <$> arbitrary
754− , ConstantScoreFilter <$> arbitrary <*> arbitrary
755− , ConstantScoreQuery <$> arbitrary <*> arbitrary
756− , QueryDisMaxQuery <$> arbitrary
757− , QueryFilteredQuery <$> arbitrary
758− , QueryFuzzyLikeThisQuery <$> arbitrary
759− , QueryFuzzyLikeFieldQuery <$> arbitrary
760− , QueryFuzzyQuery <$> arbitrary
761− , QueryHasChildQuery <$> arbitrary
762− , QueryHasParentQuery <$> arbitrary
763− , IdsQuery <$> arbitrary <*> arbitrary
764− , QueryIndicesQuery <$> arbitrary
765− , MatchAllQuery <$> arbitrary
766− , QueryMoreLikeThisQuery <$> arbitrary
767− , QueryMoreLikeThisFieldQuery <$> arbitrary
768− , QueryNestedQuery <$> arbitrary
769− , QueryPrefixQuery <$> arbitrary
770− , QueryQueryStringQuery <$> arbitrary
771− , QuerySimpleQueryStringQuery <$> arbitrary
772− , QueryRangeQuery <$> arbitrary
773− , QueryRegexpQuery <$> arbitrary
774− , QueryTemplateQueryInline <$> arbitrary
775− ]
776− shrink = genericShrink
777−
778−instance Arbitrary Filter where
779− arbitrary = reduceSize $ oneof [ AndFilter <$> arbitrary <*> arbitrary
780− , OrFilter <$> arbitrary <*> arbitrary
781− , NotFilter <$> arbitrary <*> arbitrary
782− , pure IdentityFilter
783− , BoolFilter <$> arbitrary
784− , ExistsFilter <$> arbitrary
785− , GeoBoundingBoxFilter <$> arbitrary
786− , GeoDistanceFilter <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
787− , GeoDistanceRangeFilter <$> arbitrary <*> arbitrary
788− , GeoPolygonFilter <$> arbitrary <*> arbitrary
789− , IdsFilter <$> arbitrary <*> arbitrary
790− , LimitFilter <$> arbitrary
791− , MissingFilter <$> arbitrary <*> arbitrary <*> arbitrary
792− , PrefixFilter <$> arbitrary <*> arbitrary <*> arbitrary
793− , QueryFilter <$> arbitrary <*> arbitrary
794− , RangeFilter <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
795− , RegexpFilter <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
796− , TermFilter <$> arbitrary <*> arbitrary]
797− shrink = genericShrink
798−
799−instance Arbitrary ReplicaBounds where
800− arbitrary = oneof [ replicasBounded
801− , replicasLowerBounded
802− , pure ReplicasUnbounded
803− ]
804− where replicasBounded = do Positive a <- arbitrary
805− Positive b <- arbitrary
806− return (ReplicasBounded a b)
807− replicasLowerBounded = do Positive a <- arbitrary
808− return (ReplicasLowerBounded a)
809−
810−instance Arbitrary NodeAttrName where
811− arbitrary = NodeAttrName . T.pack <$> listOf1 arbitraryAlphaNum
812−
813−
814−instance Arbitrary NodeAttrFilter where
815− arbitrary = do
816− n <- arbitrary
817− s:ss <- listOf1 (listOf1 arbitraryAlphaNum)
818− let ts = T.pack <$> s :| ss
819− return (NodeAttrFilter n ts)
820− shrink = genericShrink
821−
822−instance Arbitrary VersionNumber where
823− arbitrary = mk . fmap getPositive . getNonEmpty <$> arbitrary
824− where
825− mk versions = VersionNumber (Vers.Version versions [])
826−
827−instance Arbitrary TemplateQueryKeyValuePairs where
828− arbitrary = TemplateQueryKeyValuePairs . HM.fromList <$> arbitrary
829− shrink (TemplateQueryKeyValuePairs x) = map (TemplateQueryKeyValuePairs . HM.fromList) . shrink $ HM.toList x
830−
831−instance Arbitrary IndexName where arbitrary = sopArbitrary; shrink = genericShrink
832−instance Arbitrary MappingName where arbitrary = sopArbitrary; shrink = genericShrink
833−instance Arbitrary DocId where arbitrary = sopArbitrary; shrink = genericShrink
834−instance Arbitrary Version where arbitrary = sopArbitrary; shrink = genericShrink
835−instance Arbitrary BuildHash where arbitrary = sopArbitrary; shrink = genericShrink
836−instance Arbitrary IndexAliasRouting where arbitrary = sopArbitrary; shrink = genericShrink
837−instance Arbitrary ShardCount where arbitrary = sopArbitrary; shrink = genericShrink
838−instance Arbitrary ReplicaCount where arbitrary = sopArbitrary; shrink = genericShrink
839−instance Arbitrary TemplateName where arbitrary = sopArbitrary; shrink = genericShrink
840−instance Arbitrary TemplatePattern where arbitrary = sopArbitrary; shrink = genericShrink
841−instance Arbitrary QueryString where arbitrary = sopArbitrary; shrink = genericShrink
842−instance Arbitrary CacheName where arbitrary = sopArbitrary; shrink = genericShrink
843−instance Arbitrary CacheKey where arbitrary = sopArbitrary; shrink = genericShrink
844−instance Arbitrary Existence where arbitrary = sopArbitrary; shrink = genericShrink
845−instance Arbitrary CutoffFrequency where arbitrary = sopArbitrary; shrink = genericShrink
846−instance Arbitrary Analyzer where arbitrary = sopArbitrary; shrink = genericShrink
847−instance Arbitrary MaxExpansions where arbitrary = sopArbitrary; shrink = genericShrink
848−instance Arbitrary Lenient where arbitrary = sopArbitrary; shrink = genericShrink
849−instance Arbitrary Tiebreaker where arbitrary = sopArbitrary; shrink = genericShrink
850−instance Arbitrary Boost where arbitrary = sopArbitrary; shrink = genericShrink
851−instance Arbitrary BoostTerms where arbitrary = sopArbitrary; shrink = genericShrink
852−instance Arbitrary MinimumMatch where arbitrary = sopArbitrary; shrink = genericShrink
853−instance Arbitrary DisableCoord where arbitrary = sopArbitrary; shrink = genericShrink
854−instance Arbitrary IgnoreTermFrequency where arbitrary = sopArbitrary; shrink = genericShrink
855−instance Arbitrary MinimumTermFrequency where arbitrary = sopArbitrary; shrink = genericShrink
856−instance Arbitrary MaxQueryTerms where arbitrary = sopArbitrary; shrink = genericShrink
857−instance Arbitrary Fuzziness where arbitrary = sopArbitrary; shrink = genericShrink
858−instance Arbitrary PrefixLength where arbitrary = sopArbitrary; shrink = genericShrink
859−instance Arbitrary TypeName where arbitrary = sopArbitrary; shrink = genericShrink
860−instance Arbitrary PercentMatch where arbitrary = sopArbitrary; shrink = genericShrink
861−instance Arbitrary StopWord where arbitrary = sopArbitrary; shrink = genericShrink
862−instance Arbitrary QueryPath where arbitrary = sopArbitrary; shrink = genericShrink
863−instance Arbitrary AllowLeadingWildcard where arbitrary = sopArbitrary; shrink = genericShrink
864−instance Arbitrary LowercaseExpanded where arbitrary = sopArbitrary; shrink = genericShrink
865−instance Arbitrary EnablePositionIncrements where arbitrary = sopArbitrary; shrink = genericShrink
866−instance Arbitrary AnalyzeWildcard where arbitrary = sopArbitrary; shrink = genericShrink
867−instance Arbitrary GeneratePhraseQueries where arbitrary = sopArbitrary; shrink = genericShrink
868−instance Arbitrary Locale where arbitrary = sopArbitrary; shrink = genericShrink
869−instance Arbitrary MaxWordLength where arbitrary = sopArbitrary; shrink = genericShrink
870−instance Arbitrary MinWordLength where arbitrary = sopArbitrary; shrink = genericShrink
871−instance Arbitrary PhraseSlop where arbitrary = sopArbitrary; shrink = genericShrink
872−instance Arbitrary MinDocFrequency where arbitrary = sopArbitrary; shrink = genericShrink
873−instance Arbitrary MaxDocFrequency where arbitrary = sopArbitrary; shrink = genericShrink
874−instance Arbitrary Regexp where arbitrary = sopArbitrary; shrink = genericShrink
875−instance Arbitrary SimpleQueryStringQuery where arbitrary = sopArbitrary; shrink = genericShrink
876−instance Arbitrary FieldOrFields where arbitrary = sopArbitrary; shrink = genericShrink
877−instance Arbitrary SimpleQueryFlag where arbitrary = sopArbitrary; shrink = genericShrink
878−instance Arbitrary RegexpQuery where arbitrary = sopArbitrary; shrink = genericShrink
879−instance Arbitrary QueryStringQuery where arbitrary = sopArbitrary; shrink = genericShrink
880−instance Arbitrary RangeQuery where arbitrary = sopArbitrary; shrink = genericShrink
881−instance Arbitrary RangeValue where arbitrary = sopArbitrary; shrink = genericShrink
882−instance Arbitrary PrefixQuery where arbitrary = sopArbitrary; shrink = genericShrink
883−instance Arbitrary NestedQuery where arbitrary = sopArbitrary; shrink = genericShrink
884−instance Arbitrary MoreLikeThisFieldQuery where arbitrary = sopArbitrary; shrink = genericShrink
885−instance Arbitrary MoreLikeThisQuery where arbitrary = sopArbitrary; shrink = genericShrink
886−instance Arbitrary IndicesQuery where arbitrary = sopArbitrary; shrink = genericShrink
887−instance Arbitrary HasParentQuery where arbitrary = sopArbitrary; shrink = genericShrink
888−instance Arbitrary HasChildQuery where arbitrary = sopArbitrary; shrink = genericShrink
889−instance Arbitrary FuzzyQuery where arbitrary = sopArbitrary; shrink = genericShrink
890−instance Arbitrary FuzzyLikeFieldQuery where arbitrary = sopArbitrary; shrink = genericShrink
891−instance Arbitrary FuzzyLikeThisQuery where arbitrary = sopArbitrary; shrink = genericShrink
892−instance Arbitrary FilteredQuery where arbitrary = sopArbitrary; shrink = genericShrink
893−instance Arbitrary DisMaxQuery where arbitrary = sopArbitrary; shrink = genericShrink
894−instance Arbitrary CommonTermsQuery where arbitrary = sopArbitrary; shrink = genericShrink
895−instance Arbitrary DistanceRange where arbitrary = sopArbitrary; shrink = genericShrink
896−instance Arbitrary MultiMatchQuery where arbitrary = sopArbitrary; shrink = genericShrink
897−instance Arbitrary LessThanD where arbitrary = sopArbitrary; shrink = genericShrink
898−instance Arbitrary LessThanEqD where arbitrary = sopArbitrary; shrink = genericShrink
899−instance Arbitrary GreaterThanD where arbitrary = sopArbitrary; shrink = genericShrink
900−instance Arbitrary GreaterThanEqD where arbitrary = sopArbitrary; shrink = genericShrink
901−instance Arbitrary LessThan where arbitrary = sopArbitrary; shrink = genericShrink
902−instance Arbitrary LessThanEq where arbitrary = sopArbitrary; shrink = genericShrink
903−instance Arbitrary GreaterThan where arbitrary = sopArbitrary; shrink = genericShrink
904−instance Arbitrary GreaterThanEq where arbitrary = sopArbitrary; shrink = genericShrink
905−instance Arbitrary GeoPoint where
906− arbitrary = GeoPoint <$> (arbitrary `suchThat` reasonableFieldName) <*> arbitrary
907− where
908− -- These are problematic for geopoint for obvious reasons
909− reasonableFieldName (FieldName "from") = False
910− reasonableFieldName (FieldName "to") = False
911− reasonableFieldName _ = True
912− shrink = genericShrink
913−instance Arbitrary NullValue where arbitrary = sopArbitrary; shrink = genericShrink
914−instance Arbitrary MinimumMatchHighLow where arbitrary = sopArbitrary; shrink = genericShrink
915−instance Arbitrary CommonMinimumMatch where arbitrary = sopArbitrary; shrink = genericShrink
916−instance Arbitrary BoostingQuery where arbitrary = sopArbitrary; shrink = genericShrink
917−instance Arbitrary BoolQuery where arbitrary = sopArbitrary; shrink = genericShrink
918−instance Arbitrary MatchQuery where arbitrary = sopArbitrary; shrink = genericShrink
919−instance Arbitrary MultiMatchQueryType where arbitrary = sopArbitrary; shrink = genericShrink
920−instance Arbitrary BooleanOperator where arbitrary = sopArbitrary; shrink = genericShrink
921−instance Arbitrary ZeroTermsQuery where arbitrary = sopArbitrary; shrink = genericShrink
922−instance Arbitrary MatchQueryType where arbitrary = sopArbitrary; shrink = genericShrink
923−instance Arbitrary SearchAliasRouting where arbitrary = sopArbitrary; shrink = genericShrink
924−instance Arbitrary ScoreType where arbitrary = sopArbitrary; shrink = genericShrink
925−instance Arbitrary Distance where arbitrary = sopArbitrary; shrink = genericShrink
926−instance Arbitrary DistanceUnit where arbitrary = sopArbitrary; shrink = genericShrink
927−instance Arbitrary DistanceType where arbitrary = sopArbitrary; shrink = genericShrink
928−instance Arbitrary OptimizeBbox where arbitrary = sopArbitrary; shrink = genericShrink
929−instance Arbitrary GeoBoundingBoxConstraint where arbitrary = sopArbitrary; shrink = genericShrink
930−instance Arbitrary GeoFilterType where arbitrary = sopArbitrary; shrink = genericShrink
931−instance Arbitrary GeoBoundingBox where arbitrary = sopArbitrary; shrink = genericShrink
932−instance Arbitrary LatLon where arbitrary = sopArbitrary; shrink = genericShrink
933−instance Arbitrary RangeExecution where arbitrary = sopArbitrary; shrink = genericShrink
934−instance Arbitrary RegexpFlag where arbitrary = sopArbitrary; shrink = genericShrink
935−instance Arbitrary BoolMatch where arbitrary = sopArbitrary; shrink = genericShrink
936−instance Arbitrary Term where arbitrary = sopArbitrary; shrink = genericShrink
937−instance Arbitrary IndexSettings where arbitrary = sopArbitrary; shrink = genericShrink
938−instance Arbitrary UpdatableIndexSetting where arbitrary = sopArbitrary; shrink = genericShrink
939−instance Arbitrary Bytes where arbitrary = sopArbitrary; shrink = genericShrink
940−instance Arbitrary AllocationPolicy where arbitrary = sopArbitrary; shrink = genericShrink
941−instance Arbitrary InitialShardCount where arbitrary = sopArbitrary; shrink = genericShrink
942−instance Arbitrary FSType where arbitrary = sopArbitrary; shrink = genericShrink
943−instance Arbitrary CompoundFormat where arbitrary = sopArbitrary; shrink = genericShrink
944−instance Arbitrary FsSnapshotRepo where arbitrary = sopArbitrary; shrink = genericShrink
945−instance Arbitrary SnapshotRepoName where arbitrary = sopArbitrary; shrink = genericShrink
946−instance Arbitrary TemplateQueryInline where arbitrary = sopArbitrary; shrink = genericShrink
947−instance Arbitrary PhraseSuggesterCollate where arbitrary = sopArbitrary; shrink = genericShrink
948−instance Arbitrary PhraseSuggesterHighlighter where arbitrary = sopArbitrary; shrink = genericShrink
949−instance Arbitrary Size where arbitrary = sopArbitrary; shrink = genericShrink
950−instance Arbitrary PhraseSuggester where arbitrary = sopArbitrary; shrink = genericShrink
951−instance Arbitrary SuggestType where arbitrary = sopArbitrary; shrink = genericShrink
952−instance Arbitrary Suggest where arbitrary = sopArbitrary; shrink = genericShrink
953−instance Arbitrary DirectGenerators where arbitrary = sopArbitrary; shrink = genericShrink
954−instance Arbitrary DirectGeneratorSuggestModeTypes where arbitrary = sopArbitrary; shrink = genericShrink
955−
956−newtype UpdatableIndexSetting' = UpdatableIndexSetting' UpdatableIndexSetting
957− deriving (Show, Eq, ToJSON, FromJSON, ApproxEq, Typeable)
958−
959−instance Arbitrary UpdatableIndexSetting' where
960− arbitrary = do
961− settings <- arbitrary
962− return $ UpdatableIndexSetting' $ case settings of
963− RoutingAllocationInclude xs -> RoutingAllocationInclude (dropDuplicateAttrNames xs)
964− RoutingAllocationExclude xs -> RoutingAllocationExclude (dropDuplicateAttrNames xs)
965− RoutingAllocationRequire xs -> RoutingAllocationRequire (dropDuplicateAttrNames xs)
966− x -> x
967− where
968− dropDuplicateAttrNames = NE.fromList . L.nubBy sameAttrName . NE.toList
969− sameAttrName a b = nodeAttrFilterName a == nodeAttrFilterName b
970−
971−main :: IO ()
972−main = hspec $ do
973−
974− describe "index create/delete API" $ do
975− it "creates and then deletes the requested index" $ withTestEnv $ do
976− -- priming state.
977− _ <- deleteExampleIndex
978− resp <- createExampleIndex
979− deleteResp <- deleteExampleIndex
980− liftIO $ do
981− validateStatus resp 200
982− validateStatus deleteResp 200
983−
984− describe "error parsing" $ do
985− it "can parse EsErrors for < 2.0" $ when' (atmost es16) $ withTestEnv $ do
986− res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
987− let errorResp = eitherDecode (responseBody res)
988− liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]"))
989−
990− it "can parse EsErrors for >= 2.0" $ when' (atleast es20) $ withTestEnv $ do
991− res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
992− let errorResp = eitherDecode (responseBody res)
993− liftIO (errorResp `shouldBe` Right (EsError 404 "no such index"))
994−
995− describe "document API" $ do
996− it "indexes, updates, gets, and then deletes the generated document" $ withTestEnv $ do
997− _ <- insertData
998− _ <- updateData
999− docInserted <- getDocument testIndex testMapping (DocId "1")
1000− let newTweet = eitherDecode
1001− (responseBody docInserted) :: Either String (EsResult Tweet)
1002− liftIO $ (fmap getSource newTweet `shouldBe` Right (Just patchedTweet))
1003−
1004− it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do
1005− _ <- insertWithSpaceInId
1006− docInserted <- getDocument testIndex testMapping (DocId "Hello World")
1007− let newTweet = eitherDecode
1008− (responseBody docInserted) :: Either String (EsResult Tweet)
1009− liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
1010−
1011− it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
1012− doc <- getDocument testIndex testMapping (DocId "bogus")
1013− let noTweet = eitherDecode
1014− (responseBody doc) :: Either String (EsResult Tweet)
1015− liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
1016−
1017− it "can use optimistic concurrency control" $ withTestEnv $ do
1018− let ev = ExternalDocVersion minBound
1019− let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
1020− resetIndex
1021− res <- insertData' cfg
1022− liftIO $ isCreated res `shouldBe` True
1023− res' <- insertData' cfg
1024− liftIO $ isVersionConflict res' `shouldBe` True
1025−
1026− it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do
1027− resetIndex
1028− _ <- putMapping testIndex (MappingName "child") ChildMapping
1029− _ <- putMapping testIndex (MappingName "parent") ParentMapping
1030− _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
1031− let parent = (Just . DocumentParent . DocId) "1"
1032− ids = IndexDocumentSettings NoVersionControl parent
1033− _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
1034− _ <- refreshIndex testIndex
1035− exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
1036− liftIO $ exists `shouldBe` True
1037−
1038− describe "template API" $ do
1039− it "can create a template" $ withTestEnv $ do
1040− let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
1041− resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
1042− liftIO $ validateStatus resp 200
1043−
1044− it "can detect if a template exists" $ withTestEnv $ do
1045− exists <- templateExists (TemplateName "tweet-tpl")
1046− liftIO $ exists `shouldBe` True
1047−
1048− it "can delete a template" $ withTestEnv $ do
1049− resp <- deleteTemplate (TemplateName "tweet-tpl")
1050− liftIO $ validateStatus resp 200
1051−
1052− it "can detect if a template doesn't exist" $ withTestEnv $ do
1053− exists <- templateExists (TemplateName "tweet-tpl")
1054− liftIO $ exists `shouldBe` False
1055−
1056− describe "bulk API" $ do
1057− it "inserts all documents we request" $ withTestEnv $ do
1058− _ <- insertData
1059− let firstTest = BulkTest "blah"
1060− let secondTest = BulkTest "bloo"
1061− let firstDoc = BulkIndex testIndex
1062− testMapping (DocId "2") (toJSON firstTest)
1063− let secondDoc = BulkCreate testIndex
1064− testMapping (DocId "3") (toJSON secondTest)
1065− let stream = V.fromList [firstDoc, secondDoc]
1066− _ <- bulk stream
1067− _ <- refreshIndex testIndex
1068− fDoc <- getDocument testIndex testMapping (DocId "2")
1069− sDoc <- getDocument testIndex testMapping (DocId "3")
1070− let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
1071− let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
1072− liftIO $ do
1073− fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
1074− fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
1075−
1076−
1077− describe "query API" $ do
1078− it "returns document for term query and identity filter" $ withTestEnv $ do
1079− _ <- insertData
1080− let query = TermQuery (Term "user" "bitemyapp") Nothing
1081− let filter = IdentityFilter <&&> IdentityFilter
1082− let search = mkSearch (Just query) (Just filter)
1083− myTweet <- searchTweet search
1084− liftIO $
1085− myTweet `shouldBe` Right exampleTweet
1086−
1087− it "handles constant score queries" $ withTestEnv $ do
1088− _ <- insertData
1089− let query = TermsQuery "user" ("bitemyapp" :| [])
1090− let cfQuery = ConstantScoreQuery query (Boost 1.0)
1091− let filter = IdentityFilter
1092− let search = mkSearch (Just cfQuery) (Just filter)
1093− myTweet <- searchTweet search
1094− liftIO $
1095− myTweet `shouldBe` Right exampleTweet
1096− it "handles constant score filters" $ withTestEnv $ do
1097− _ <- insertData
1098− let query = TermsQuery "user" ("bitemyapp" :| [])
1099− let cfFilter = ConstantScoreFilter IdentityFilter (Boost 1.0)
1100− let boolQuery = mkBoolQuery [query, cfFilter] [] []
1101− let search = mkSearch (Just (QueryBoolQuery boolQuery)) Nothing
1102− myTweet <- searchTweet search
1103− liftIO $
1104− myTweet `shouldBe` Right exampleTweet
1105−
1106−
1107− it "returns document for terms query and identity filter" $ withTestEnv $ do
1108− _ <- insertData
1109− let query = TermsQuery "user" ("bitemyapp" :| [])
1110− let filter = IdentityFilter <&&> IdentityFilter
1111− let search = mkSearch (Just query) (Just filter)
1112− myTweet <- searchTweet search
1113− liftIO $
1114− myTweet `shouldBe` Right exampleTweet
1115−
1116− it "returns document for match query" $ withTestEnv $ do
1117− _ <- insertData
1118− let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
1119− let search = mkSearch (Just query) Nothing
1120− myTweet <- searchTweet search
1121− liftIO $
1122− myTweet `shouldBe` Right exampleTweet
1123−
1124− it "returns document for multi-match query" $ withTestEnv $ do
1125− _ <- insertData
1126− let flds = [FieldName "user", FieldName "message"]
1127− let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
1128− let search = mkSearch (Just query) Nothing
1129− myTweet <- searchTweet search
1130− liftIO $
1131− myTweet `shouldBe` Right exampleTweet
1132−
1133− it "returns document for multi-match query with a custom tiebreaker" $ withTestEnv $ do
1134− _ <- insertData
1135− let tiebreaker = Just $ Tiebreaker 0.3
1136− flds = [FieldName "user", FieldName "message"]
1137− multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")
1138− query = QueryMultiMatchQuery $ multiQuery' { multiMatchQueryTiebreaker = tiebreaker }
1139− search = mkSearch (Just query) Nothing
1140− myTweet <- searchTweet search
1141− liftIO $
1142− myTweet `shouldBe` Right exampleTweet
1143−
1144− it "returns document for bool query" $ withTestEnv $ do
1145− _ <- insertData
1146− let innerQuery = QueryMatchQuery $
1147− mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
1148− let query = QueryBoolQuery $
1149− mkBoolQuery [innerQuery] [] []
1150− let search = mkSearch (Just query) Nothing
1151− myTweet <- searchTweet search
1152− liftIO $
1153− myTweet `shouldBe` Right exampleTweet
1154−
1155− it "returns document for boosting query" $ withTestEnv $ do
1156− _ <- insertData
1157− let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
1158− let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
1159− let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
1160− let search = mkSearch (Just query) Nothing
1161− myTweet <- searchTweet search
1162− liftIO $
1163− myTweet `shouldBe` Right exampleTweet
1164−
1165− it "returns document for common terms query" $ withTestEnv $ do
1166− _ <- insertData
1167− let query = QueryCommonTermsQuery $
1168− CommonTermsQuery (FieldName "user")
1169− (QueryString "bitemyapp")
1170− (CutoffFrequency 0.0001)
1171− Or Or Nothing Nothing Nothing Nothing
1172− let search = mkSearch (Just query) Nothing
1173− myTweet <- searchTweet search
1174− liftIO $
1175− myTweet `shouldBe` Right exampleTweet
1176−
1177− it "returns document for for inline template query" $ withTestEnv $ do
1178− _ <- insertData
1179− let innerQuery = QueryMatchQuery $
1180− mkMatchQuery (FieldName "{{userKey}}")
1181− (QueryString "{{bitemyappKey}}")
1182− templateParams = TemplateQueryKeyValuePairs $ HM.fromList
1183− [ ("userKey", "user")
1184− , ("bitemyappKey", "bitemyapp")
1185− ]
1186− templateQuery = QueryTemplateQueryInline $
1187− TemplateQueryInline innerQuery templateParams
1188− search = mkSearch (Just templateQuery) Nothing
1189− myTweet <- searchTweet search
1190− liftIO $ myTweet `shouldBe` Right exampleTweet
1191−
1192−
1193− describe "sorting" $ do
1194− it "returns documents in the right order" $ withTestEnv $ do
1195− _ <- insertData
1196− _ <- insertOther
1197− let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
1198− let search = Search Nothing
1199− (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
1200− False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
1201− Nothing
1202− result <- searchTweets search
1203− let myTweet = grabFirst result
1204− liftIO $
1205− myTweet `shouldBe` Right otherTweet
1206−
1207−
1208− describe "filtering API" $ do
1209− it "returns document for composed boolmatch and identity" $ withTestEnv $ do
1210− _ <- insertData
1211− let queryFilter = BoolFilter (MustMatch (Term "user" "bitemyapp") False)
1212− <&&> IdentityFilter
1213− let search = mkSearch Nothing (Just queryFilter)
1214− myTweet <- searchTweet search
1215− liftIO $
1216− myTweet `shouldBe` Right exampleTweet
1217−
1218− it "returns document for term filter" $ withTestEnv $ do
1219− _ <- insertData
1220− let termFilter = TermFilter (Term "user" "bitemyapp") False
1221− let search = mkSearch Nothing (Just termFilter)
1222− myTweet <- searchTweet search
1223− liftIO $
1224− myTweet `shouldBe` Right exampleTweet
1225−
1226− it "returns document for existential filter" $ withTestEnv $ do
1227− _ <- insertData
1228− let search = mkSearch Nothing (Just (ExistsFilter (FieldName "user")))
1229− myTweet <- searchTweet search
1230− liftIO $
1231− myTweet `shouldBe` Right exampleTweet
1232−
1233− it "returns document for geo boundingbox filter" $ withTestEnv $ do
1234− _ <- insertData
1235− let box = GeoBoundingBox (LatLon 40.73 (-74.1)) (LatLon 40.10 (-71.12))
1236− let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
1237− let geoFilter = GeoBoundingBoxFilter bbConstraint
1238− let search = mkSearch Nothing (Just geoFilter)
1239− myTweet <- searchTweet search
1240− liftIO $
1241− myTweet `shouldBe` Right exampleTweet
1242−
1243− it "doesn't return document for nonsensical boundingbox filter" $ withTestEnv $ do
1244− _ <- insertData
1245− let box = GeoBoundingBox (LatLon 0.73 (-4.1)) (LatLon 0.10 (-1.12))
1246− let bbConstraint = GeoBoundingBoxConstraint (FieldName "tweet.location") box False GeoFilterMemory
1247− let geoFilter = GeoBoundingBoxFilter bbConstraint
1248− let search = mkSearch Nothing (Just geoFilter)
1249− searchExpectNoResults search
1250−
1251− it "returns document for geo distance filter" $ withTestEnv $ do
1252− _ <- insertData
1253− let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
1254− let distance = Distance 10.0 Miles
1255− let optimizeBbox = OptimizeGeoFilterType GeoFilterMemory
1256− let geoFilter = GeoDistanceFilter geoPoint distance SloppyArc optimizeBbox False
1257− let search = mkSearch Nothing (Just geoFilter)
1258− myTweet <- searchTweet search
1259− liftIO $
1260− myTweet `shouldBe` Right exampleTweet
1261−
1262− it "returns document for geo distance range filter" $ withTestEnv $ do
1263− _ <- insertData
1264− let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
1265− let distanceRange = DistanceRange (Distance 0.0 Miles) (Distance 10.0 Miles)
1266− let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
1267− let search = mkSearch Nothing (Just geoFilter)
1268− myTweet <- searchTweet search
1269− liftIO $
1270− myTweet `shouldBe` Right exampleTweet
1271−
1272− it "doesn't return document for wild geo distance range filter" $ withTestEnv $ do
1273− _ <- insertData
1274− let geoPoint = GeoPoint (FieldName "tweet.location") (LatLon 40.12 (-71.34))
1275− let distanceRange = DistanceRange (Distance 100.0 Miles) (Distance 1000.0 Miles)
1276− let geoFilter = GeoDistanceRangeFilter geoPoint distanceRange
1277− let search = mkSearch Nothing (Just geoFilter)
1278− searchExpectNoResults search
1279−
1280− it "returns document for geo polygon filter" $ withTestEnv $ do
1281− _ <- insertData
1282− let points = [LatLon 40.0 (-70.00),
1283− LatLon 40.0 (-72.00),
1284− LatLon 41.0 (-70.00),
1285− LatLon 41.0 (-72.00)]
1286− let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
1287− let search = mkSearch Nothing (Just geoFilter)
1288− myTweet <- searchTweet search
1289− liftIO $
1290− myTweet `shouldBe` Right exampleTweet
1291−
1292− it "doesn't return document for bad geo polygon filter" $ withTestEnv $ do
1293− _ <- insertData
1294− let points = [LatLon 40.0 (-70.00),
1295− LatLon 40.0 (-71.00),
1296− LatLon 41.0 (-70.00),
1297− LatLon 41.0 (-71.00)]
1298− let geoFilter = GeoPolygonFilter (FieldName "tweet.location") points
1299− let search = mkSearch Nothing (Just geoFilter)
1300− searchExpectNoResults search
1301−
1302− it "returns document for ids filter" $ withTestEnv $ do
1303− _ <- insertData
1304− let filter = IdsFilter (MappingName "tweet") [DocId "1"]
1305− let search = mkSearch Nothing (Just filter)
1306− myTweet <- searchTweet search
1307− liftIO $
1308− myTweet `shouldBe` Right exampleTweet
1309−
1310− it "returns document for Double range filter" $ withTestEnv $ do
1311− _ <- insertData
1312− let filter = RangeFilter (FieldName "age")
1313− (RangeDoubleGtLt (GreaterThan 1000.0) (LessThan 100000.0))
1314− RangeExecutionIndex False
1315− let search = mkSearch Nothing (Just filter)
1316− myTweet <- searchTweet search
1317− liftIO $
1318− myTweet `shouldBe` Right exampleTweet
1319−
1320− it "returns document for UTCTime date filter" $ withTestEnv $ do
1321− _ <- insertData
1322− let filter = RangeFilter (FieldName "postDate")
1323− (RangeDateGtLt
1324− (GreaterThanD (UTCTime
1325− (ModifiedJulianDay 54000)
1326− (secondsToDiffTime 0)))
1327− (LessThanD (UTCTime
1328− (ModifiedJulianDay 55000)
1329− (secondsToDiffTime 11))))
1330− RangeExecutionIndex False
1331− let search = mkSearch Nothing (Just filter)
1332− myTweet <- searchTweet search
1333− liftIO $
1334− myTweet `shouldBe` Right exampleTweet
1335−
1336− it "returns document for regexp filter" $ withTestEnv $ do
1337− _ <- insertData
1338− let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
1339− AllRegexpFlags (CacheName "test") False (CacheKey "key")
1340− let search = mkSearch Nothing (Just filter)
1341− myTweet <- searchTweet search
1342− liftIO $
1343− myTweet `shouldBe` Right exampleTweet
1344−
1345− it "doesn't return document for non-matching regexp filter" $ withTestEnv $ do
1346− _ <- insertData
1347− let filter = RegexpFilter (FieldName "user")
1348− (Regexp "boy") AllRegexpFlags
1349− (CacheName "test") False (CacheKey "key")
1350− let search = mkSearch Nothing (Just filter)
1351− searchExpectNoResults search
1352−
1353− it "returns document for query filter, uncached" $ withTestEnv $ do
1354− _ <- insertData
1355− let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) True
1356− search = mkSearch Nothing (Just filter)
1357− myTweet <- searchTweet search
1358− liftIO $ myTweet `shouldBe` Right exampleTweet
1359−
1360− it "returns document for query filter, cached" $ withTestEnv $ do
1361− _ <- insertData
1362− let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) False
1363− search = mkSearch Nothing (Just filter)
1364− myTweet <- searchTweet search
1365− liftIO $ myTweet `shouldBe` Right exampleTweet
1366−
1367− describe "Aggregation API" $ do
1368− it "returns term aggregation results" $ withTestEnv $ do
1369− _ <- insertData
1370− let terms = TermsAgg $ mkTermsAggregation "user"
1371− let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
1372− searchExpectAggs search
1373− searchValidBucketAgg search "users" toTerms
1374−
1375− it "return sub-aggregation results" $ withTestEnv $ do
1376− _ <- insertData
1377− let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation "age"
1378− agg = TermsAgg $ (mkTermsAggregation "user") { termAggs = Just subaggs}
1379− search = mkAggregateSearch Nothing $ mkAggregations "users" agg
1380− reply <- searchByIndex testIndex search
1381− let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
1382− usersAggResults = result >>= aggregations >>= toTerms "users"
1383− subAggResults = usersAggResults >>= (listToMaybe . buckets) >>= termsAggs >>= toTerms "age_agg"
1384− subAddResultsExists = isJust subAggResults
1385− liftIO $ (subAddResultsExists) `shouldBe` True
1386−
1387− it "returns cardinality aggregation results" $ withTestEnv $ do
1388− _ <- insertData
1389− let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user"
1390− let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality
1391− let search' = search { Database.V1.Bloodhound.from = From 0, size = Size 0 }
1392− searchExpectAggs search'
1393− let docCountPair k n = (k, object ["value" .= Number n])
1394− res <- searchTweets search'
1395− liftIO $
1396− fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "users" 1]))
1397−
1398− it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do
1399− _ <- insertData
1400− let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
1401− let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
1402− searchExpectAggs search
1403− searchValidBucketAgg search "users" toTerms
1404−
1405− -- One of these fails with 1.7.3
1406− it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
1407− _ <- insertData
1408− searchTermsAggHint [Map, Ordinals]
1409−
1410− it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
1411− _ <- insertData
1412− searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
1413−
1414− it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
1415− _ <- insertData
1416− searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
1417− -- One of the above.
1418−
1419− it "can execute value_count aggregations" $ withTestEnv $ do
1420− _ <- insertData
1421− _ <- insertOther
1422− let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
1423− mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
1424− let search = mkAggregateSearch Nothing ags
1425− let docCountPair k n = (k, object ["value" .= Number n])
1426− res <- searchTweets search
1427− liftIO $
1428− fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
1429− , docCountPair "bogus_count" 0
1430− ]))
1431−
1432− it "can execute filter aggregations" $ withTestEnv $ do
1433− _ <- insertData
1434− _ <- insertOther
1435− let ags = mkAggregations "bitemyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "bitemyapp") defaultCache) Nothing)) <>
1436− mkAggregations "notmyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "notmyapp") defaultCache) Nothing))
1437− let search = mkAggregateSearch Nothing ags
1438− let docCountPair k n = (k, object ["doc_count" .= Number n])
1439− res <- searchTweets search
1440− liftIO $
1441− fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1
1442− , docCountPair "notmyapps" 1
1443− ]))
1444− it "can execute date_range aggregations" $ withTestEnv $ do
1445− let now = fromGregorian 2015 3 14
1446− let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0
1447− let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0
1448− let oldDoc = exampleTweet { postDate = ltAMonthAgo }
1449− let newDoc = exampleTweet { postDate = ltAWeekAgo }
1450− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings oldDoc (DocId "1")
1451− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings newDoc (DocId "2")
1452− _ <- refreshIndex testIndex
1453− let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth])
1454− let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek])
1455− let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek])
1456− let ags = mkAggregations "date_ranges" (DateRangeAgg agg)
1457− let search = mkAggregateSearch Nothing ags
1458− res <- searchTweets search
1459− liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right 2
1460− let bucks = do magrs <- fmapL show (aggregations <$> res)
1461− agrs <- note "no aggregations returned" magrs
1462− rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs
1463− parseEither parseJSON rawBucks
1464− let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0
1465− let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0
1466− liftIO $ buckets <$> bucks `shouldBe` Right [ DateRangeResult "2015-02-14T00:00:00.000Z-*"
1467− (Just fromMonthT)
1468− (Just "2015-02-14T00:00:00.000Z")
1469− Nothing
1470− Nothing
1471− 2
1472− Nothing
1473− , DateRangeResult "2015-03-07T00:00:00.000Z-*"
1474− (Just fromWeekT)
1475− (Just "2015-03-07T00:00:00.000Z")
1476− Nothing
1477− Nothing
1478− 1
1479− Nothing
1480− ]
1481−
1482− it "returns date histogram aggregation results" $ withTestEnv $ do
1483− _ <- insertData
1484− let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
1485− let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
1486− searchExpectAggs search
1487− searchValidBucketAgg search "byDate" toDateHistogram
1488−
1489− it "returns date histogram using fractional date" $ withTestEnv $ do
1490− _ <- insertData
1491− let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
1492− let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
1493− let intervals = periods ++ fractionals
1494− let histogram = mkDateHistogram (FieldName "postDate")
1495− let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
1496− let expect interval = searchExpectAggs (search interval)
1497− let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
1498− forM_ intervals expect
1499− forM_ intervals valid
1500−
1501− it "can execute missing aggregations" $ withTestEnv $ do
1502− _ <- insertData
1503− _ <- insertExtra
1504− let ags = mkAggregations "missing_agg" (MissingAgg (MissingAggregation "extra"))
1505− let search = mkAggregateSearch Nothing ags
1506− let docCountPair k n = (k, object ["doc_count" .= Number n])
1507− res <- searchTweets search
1508− liftIO $
1509− fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "missing_agg" 1]))
1510−
1511− describe "Highlights API" $ do
1512−
1513− it "returns highlight from query when there should be one" $ withTestEnv $ do
1514− _ <- insertData
1515− _ <- insertOther
1516− let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
1517− let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
1518−
1519− let search = mkHighlightSearch (Just query) testHighlight
1520− myHighlight <- searchTweetHighlight search
1521− liftIO $
1522− myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
1523−
1524− it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do
1525− _ <- insertData
1526− _ <- insertOther
1527− let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
1528− let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
1529−
1530− let search = mkHighlightSearch (Just query) testHighlight
1531− myHighlight <- searchTweetHighlight search
1532− liftIO $
1533− myHighlight `shouldBe` Right Nothing
1534−
1535− describe "Source filtering" $ do
1536−
1537− it "doesn't include source when sources are disabled" $ withTestEnv $ do
1538− searchExpectSource
1539− NoSource
1540− (Left (EsError 500 "Source was missing"))
1541−
1542− it "includes a source" $ withTestEnv $ do
1543− searchExpectSource
1544− (SourcePatterns (PopPattern (Pattern "message")))
1545− (Right (Object (HM.fromList [("message", String "Use haskell!")])))
1546−
1547− it "includes sources" $ withTestEnv $ do
1548− searchExpectSource
1549− (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))
1550− (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))
1551−
1552− it "includes source patterns" $ withTestEnv $ do
1553− searchExpectSource
1554− (SourcePatterns (PopPattern (Pattern "*ge")))
1555− (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))
1556−
1557− it "excludes source patterns" $ withTestEnv $ do
1558− searchExpectSource
1559− (SourceIncludeExclude (Include [])
1560− (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"]))
1561− (Right (Object (HM.fromList [("user",String "bitemyapp")])))
1562−
1563− describe "ToJSON RegexpFlags" $ do
1564− it "generates the correct JSON for AllRegexpFlags" $
1565− toJSON AllRegexpFlags `shouldBe` String "ALL"
1566−
1567− it "generates the correct JSON for NoRegexpFlags" $
1568− toJSON NoRegexpFlags `shouldBe` String "NONE"
1569−
1570− it "generates the correct JSON for SomeRegexpFlags" $
1571− let flags = AnyString :| [ Automaton
1572− , Complement
1573− , Empty
1574− , Intersection
1575− , Interval ]
1576− in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
1577−
1578− prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
1579− let String str = toJSON flags
1580− flagStrs = T.splitOn "|" str
1581− in noDuplicates flagStrs
1582−
1583− describe "omitNulls" $ do
1584− it "checks that omitNulls drops list elements when it should" $
1585− let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
1586− , "test2" .= (toJSON ("some value" :: Text))]
1587− in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
1588−
1589− it "checks that omitNulls doesn't drop list elements when it shouldn't" $
1590− let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
1591− , "test2" .= (toJSON ("some value" :: Text))]
1592− in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))
1593− , ("test2", String "some value")])
1594− it "checks that omitNulls drops non list elements when it should" $
1595− let dropped = omitNulls $ [ "test1" .= (toJSON Null)
1596− , "test2" .= (toJSON ("some value" :: Text))]
1597− in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
1598− it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
1599− let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
1600− , "test2" .= (toJSON ("some value" :: Text))]
1601− in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)
1602− , ("test2", String "some value")])
1603− describe "Monoid (SearchHits a)" $ do
1604− prop "abides the monoid laws" $ eq $
1605− prop_Monoid (T :: T (SearchHits ()))
1606−
1607− describe "mkDocVersion" $ do
1608− prop "can never construct an out of range docVersion" $ \i ->
1609− let res = mkDocVersion i
1610− in case res of
1611− Nothing -> property True
1612− Just dv -> (dv >= minBound) .&&.
1613− (dv <= maxBound) .&&.
1614− docVersionNumber dv === i
1615−
1616− describe "FsSnapshotRepo" $ do
1617− prop "SnapshotRepo laws" $ \fsr ->
1618− fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)
1619−
1620− describe "snapshot repos" $ do
1621− it "always parses all snapshot repos API" $ when' canSnapshot $ withTestEnv $ do
1622− res <- getSnapshotRepos AllSnapshotRepos
1623− liftIO $ case res of
1624− Left e -> expectationFailure ("Expected a right but got Left " <> show e)
1625− Right _ -> return ()
1626−
1627− it "finds an existing list of repos" $ when' canSnapshot $ withTestEnv $ do
1628− let r1n = SnapshotRepoName "bloodhound-repo1"
1629− let r2n = SnapshotRepoName "bloodhound-repo2"
1630− withSnapshotRepo r1n $ \r1 ->
1631− withSnapshotRepo r2n $ \r2 -> do
1632− repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))
1633− liftIO $ case repos of
1634− Right xs -> do
1635− let srt = L.sortBy (comparing gSnapshotRepoName)
1636− srt xs `shouldBe` srt [r1, r2]
1637− Left e -> expectationFailure (show e)
1638−
1639− it "creates and updates with updateSnapshotRepo" $ when' canSnapshot $ withTestEnv $ do
1640− let r1n = SnapshotRepoName "bloodhound-repo1"
1641− withSnapshotRepo r1n $ \r1 -> do
1642− let Just (String dir) = HM.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))
1643− let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing
1644− resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression
1645− liftIO (validateStatus resp 200)
1646− Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))
1647− liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)
1648−
1649− -- verify came around in 1.4 it seems
1650− it "can verify existing repos" $ when' canSnapshot $ when' (atleast es14) $ withTestEnv $ do
1651− let r1n = SnapshotRepoName "bloodhound-repo1"
1652− withSnapshotRepo r1n $ \_ -> do
1653− res <- verifySnapshotRepo r1n
1654− liftIO $ case res of
1655− Right (SnapshotVerification vs)
1656− | null vs -> expectationFailure "Expected nonempty set of verifying nodes"
1657− | otherwise -> return ()
1658− Left e -> expectationFailure (show e)
1659−
1660− describe "snapshots" $ do
1661− it "always parses all snapshots API" $ when' canSnapshot $ withTestEnv $ do
1662− let r1n = SnapshotRepoName "bloodhound-repo1"
1663− withSnapshotRepo r1n $ \_ -> do
1664− res <- getSnapshots r1n AllSnapshots
1665− liftIO $ case res of
1666− Left e -> expectationFailure ("Expected a right but got Left " <> show e)
1667− Right _ -> return ()
1668−
1669− it "can parse a snapshot that it created" $ when' canSnapshot $ withTestEnv $ do
1670− let r1n = SnapshotRepoName "bloodhound-repo1"
1671− withSnapshotRepo r1n $ \_ -> do
1672− let s1n = SnapshotName "example-snapshot"
1673− withSnapshot r1n s1n $ do
1674− res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))
1675− liftIO $ case res of
1676− Right [snap]
1677− | snapInfoState snap == SnapshotSuccess &&
1678− snapInfoName snap == s1n -> return ()
1679− | otherwise -> expectationFailure (show snap)
1680− Right [] -> expectationFailure "There were no snapshots"
1681− Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))
1682− Left e -> expectationFailure (show e)
1683−
1684− describe "snapshot restore" $ do
1685− it "can restore a snapshot that we create" $ when' canSnapshot $ withTestEnv $ do
1686− let r1n = SnapshotRepoName "bloodhound-repo1"
1687− withSnapshotRepo r1n $ \_ -> do
1688− let s1n = SnapshotName "example-snapshot"
1689− withSnapshot r1n s1n $ do
1690− let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True }
1691− -- have to close an index to restore it
1692− resp1 <- closeIndex testIndex
1693− liftIO (validateStatus resp1 200)
1694− resp2 <- restoreSnapshot r1n s1n settings
1695− liftIO (validateStatus resp2 200)
1696−
1697− it "can restore and rename" $ when' canSnapshot $ withTestEnv $ do
1698− let r1n = SnapshotRepoName "bloodhound-repo1"
1699− withSnapshotRepo r1n $ \_ -> do
1700− let s1n = SnapshotName "example-snapshot"
1701− withSnapshot r1n s1n $ do
1702− let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"
1703− let replace = RRTLit "restored-" :| [RRSubWholeMatch]
1704− let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"
1705− oldEnoughForOverrides <- liftIO (atleast es15)
1706− let overrides = RestoreIndexSettings { restoreOverrideReplicas = Just (ReplicaCount 0) }
1707− let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True
1708− , snapRestoreRenamePattern = Just pat
1709− , snapRestoreRenameReplacement = Just replace
1710− , snapRestoreIndexSettingsOverrides = if oldEnoughForOverrides
1711− then Just overrides
1712− else Nothing
1713− }
1714− -- have to close an index to restore it
1715− let go = do
1716− resp <- restoreSnapshot r1n s1n settings
1717− liftIO (validateStatus resp 200)
1718− exists <- indexExists expectedIndex
1719− liftIO (exists `shouldBe` True)
1720− go `finally` deleteIndex expectedIndex
1721−
1722− describe "getNodesInfo" $ do
1723− it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
1724− res <- getNodesInfo LocalNode
1725− liftIO $ case res of
1726− -- This is really just a smoke test for response
1727− -- parsing. Node info is so variable, there's not much I can
1728− -- assert here.
1729− Right NodesInfo {..} -> length nodesInfo `shouldBe` 1
1730− Left e -> expectationFailure ("Expected NodesInfo but got " <> show e)
1731−
1732− describe "getNodesStats" $ do
1733− it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
1734− res <- getNodesStats LocalNode
1735− liftIO $ case res of
1736− -- This is really just a smoke test for response
1737− -- parsing. Node stats is so variable, there's not much I can
1738− -- assert here.
1739− Right NodesStats {..} -> length nodesStats `shouldBe` 1
1740− Left e -> expectationFailure ("Expected NodesStats but got " <> show e)
1741−
1742− describe "Enum DocVersion" $ do
1743− it "follows the laws of Enum, Bounded" $ do
1744− evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
1745− evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
1746− evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
1747− evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
1748− enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
1749− enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
1750− enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
1751−
1752− describe "scan&scroll API" $ do
1753− it "returns documents using the scan&scroll API" $ withTestEnv $ do
1754− _ <- insertData
1755− _ <- insertOther
1756− let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) }
1757− regular_search <- searchTweet search
1758− scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]
1759− let scan_search = map hitSource scan_search'
1760− liftIO $
1761− regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
1762− liftIO $
1763− scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]
1764−
1765− describe "index aliases" $ do
1766− it "handles the simple case of aliasing an existing index" $ do
1767− let alias = IndexAlias (testIndex) (IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias"))
1768− let create = IndexAliasCreate Nothing Nothing
1769− let action = AddAlias alias create
1770−
1771− withTestEnv $ do
1772− resetIndex
1773− resp <- updateIndexAliases (action :| [])
1774− liftIO $ validateStatus resp 200
1775− let cleanup = withTestEnv (updateIndexAliases (RemoveAlias alias :| []))
1776− (do aliases <- withTestEnv getIndexAliases
1777− let expected = IndexAliasSummary alias create
1778− case aliases of
1779− Right (IndexAliasesSummary summs) ->
1780− L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected
1781− Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup
1782−
1783− it "handles an alias with routing and a filter" $ do
1784− let alias = IndexAlias (testIndex) (IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias"))
1785− let sar = SearchAliasRouting (RoutingValue "search val" :| [])
1786− let iar = IndexAliasRouting (RoutingValue "index val")
1787− let routing = GranularAliasRouting (Just sar) (Just iar)
1788− let filter = LimitFilter 42
1789− let create = IndexAliasCreate (Just routing) (Just filter)
1790− let action = AddAlias alias create
1791−
1792− withTestEnv $ do
1793− resetIndex
1794− resp <- updateIndexAliases (action :| [])
1795− liftIO $ validateStatus resp 200
1796− let cleanup = withTestEnv (updateIndexAliases (RemoveAlias alias :| []))
1797− (do aliases <- withTestEnv getIndexAliases
1798− let expected = IndexAliasSummary alias create
1799− case aliases of
1800− Right (IndexAliasesSummary summs) ->
1801− L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected
1802− Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup
1803−
1804− describe "Index Listing" $ do
1805− it "returns a list of index names" $ withTestEnv $ do
1806− _ <- createExampleIndex
1807− ixns <- listIndices
1808− liftIO (ixns `shouldContain` [testIndex])
1809−
1810− describe "Index Settings" $ do
1811− it "persists settings" $ withTestEnv $ do
1812− _ <- deleteExampleIndex
1813− _ <- createExampleIndex
1814− let updates = BlocksWrite False :| []
1815− updateResp <- updateIndexSettings updates testIndex
1816− liftIO $ validateStatus updateResp 200
1817− getResp <- getIndexSettings testIndex
1818− liftIO $
1819− getResp `shouldBe` Right (IndexSettingsSummary
1820− testIndex
1821− (IndexSettings (ShardCount 1) (ReplicaCount 0))
1822− (NE.toList updates))
1823−
1824− describe "Index Optimization" $ do
1825− it "returns a successful response upon completion" $ withTestEnv $ do
1826− _ <- createExampleIndex
1827− resp <- optimizeIndex (IndexList (testIndex :| [])) defaultIndexOptimizationSettings
1828− liftIO $ validateStatus resp 200
1829−
1830− describe "Suggest" $ do
1831− it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do
1832− _ <- insertData
1833− let {- query = QueryMatchNoneQuery
1834− query = TermQuery (Term "user" "bitemyapp") Nothing -}
1835− let phraseSuggester = mkPhraseSuggester (FieldName "message")
1836− namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
1837− search' = mkSearch Nothing Nothing
1838− search = search' { suggestBody = Just namedSuggester }
1839− expectedText = Just "use haskell"
1840− resp <- searchByIndex testIndex search
1841− parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))
1842− case parsed of
1843− Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)
1844− Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText
1845−
1846− describe "JSON instances" $ do
1847− propJSON (Proxy :: Proxy Version)
1848− propJSON (Proxy :: Proxy IndexName)
1849− propJSON (Proxy :: Proxy MappingName)
1850− propJSON (Proxy :: Proxy DocId)
1851− propJSON (Proxy :: Proxy IndexAliasRouting)
1852− propJSON (Proxy :: Proxy RoutingValue)
1853− propJSON (Proxy :: Proxy ShardCount)
1854− propJSON (Proxy :: Proxy ReplicaCount)
1855− propJSON (Proxy :: Proxy TemplateName)
1856− propJSON (Proxy :: Proxy TemplatePattern)
1857− propJSON (Proxy :: Proxy QueryString)
1858− propJSON (Proxy :: Proxy FieldName)
1859− propJSON (Proxy :: Proxy CacheName)
1860− propJSON (Proxy :: Proxy CacheKey)
1861− propJSON (Proxy :: Proxy Existence)
1862− propJSON (Proxy :: Proxy CutoffFrequency)
1863− propJSON (Proxy :: Proxy Analyzer)
1864− propJSON (Proxy :: Proxy MaxExpansions)
1865− propJSON (Proxy :: Proxy Lenient)
1866− propJSON (Proxy :: Proxy Tiebreaker)
1867− propJSON (Proxy :: Proxy Boost)
1868− propJSON (Proxy :: Proxy BoostTerms)
1869− propJSON (Proxy :: Proxy MinimumMatch)
1870− propJSON (Proxy :: Proxy DisableCoord)
1871− propJSON (Proxy :: Proxy IgnoreTermFrequency)
1872− propJSON (Proxy :: Proxy MinimumTermFrequency)
1873− propJSON (Proxy :: Proxy MaxQueryTerms)
1874− propJSON (Proxy :: Proxy Fuzziness)
1875− propJSON (Proxy :: Proxy PrefixLength)
1876− propJSON (Proxy :: Proxy TypeName)
1877− propJSON (Proxy :: Proxy PercentMatch)
1878− propJSON (Proxy :: Proxy StopWord)
1879− propJSON (Proxy :: Proxy QueryPath)
1880− propJSON (Proxy :: Proxy AllowLeadingWildcard)
1881− propJSON (Proxy :: Proxy LowercaseExpanded)
1882− propJSON (Proxy :: Proxy EnablePositionIncrements)
1883− propJSON (Proxy :: Proxy AnalyzeWildcard)
1884− propJSON (Proxy :: Proxy GeneratePhraseQueries)
1885− propJSON (Proxy :: Proxy Locale)
1886− propJSON (Proxy :: Proxy MaxWordLength)
1887− propJSON (Proxy :: Proxy MinWordLength)
1888− propJSON (Proxy :: Proxy PhraseSlop)
1889− propJSON (Proxy :: Proxy MinDocFrequency)
1890− propJSON (Proxy :: Proxy MaxDocFrequency)
1891− propJSON (Proxy :: Proxy Filter)
1892− propJSON (Proxy :: Proxy Query)
1893− propJSON (Proxy :: Proxy SimpleQueryStringQuery)
1894− propJSON (Proxy :: Proxy FieldOrFields)
1895− propJSON (Proxy :: Proxy SimpleQueryFlag)
1896− propJSON (Proxy :: Proxy RegexpQuery)
1897− propJSON (Proxy :: Proxy QueryStringQuery)
1898− propJSON (Proxy :: Proxy RangeQuery)
1899− propJSON (Proxy :: Proxy PrefixQuery)
1900− propJSON (Proxy :: Proxy NestedQuery)
1901− propJSON (Proxy :: Proxy MoreLikeThisFieldQuery)
1902− propJSON (Proxy :: Proxy MoreLikeThisQuery)
1903− propJSON (Proxy :: Proxy IndicesQuery)
1904− propJSON (Proxy :: Proxy HasParentQuery)
1905− propJSON (Proxy :: Proxy HasChildQuery)
1906− propJSON (Proxy :: Proxy FuzzyQuery)
1907− propJSON (Proxy :: Proxy FuzzyLikeFieldQuery)
1908− propJSON (Proxy :: Proxy FuzzyLikeThisQuery)
1909− propJSON (Proxy :: Proxy FilteredQuery)
1910− propJSON (Proxy :: Proxy DisMaxQuery)
1911− propJSON (Proxy :: Proxy CommonTermsQuery)
1912− propJSON (Proxy :: Proxy CommonMinimumMatch)
1913− propJSON (Proxy :: Proxy BoostingQuery)
1914− propJSON (Proxy :: Proxy BoolQuery)
1915− propJSON (Proxy :: Proxy MatchQuery)
1916− propJSON (Proxy :: Proxy MultiMatchQueryType)
1917− propJSON (Proxy :: Proxy BooleanOperator)
1918− propJSON (Proxy :: Proxy ZeroTermsQuery)
1919− propJSON (Proxy :: Proxy MatchQueryType)
1920− propJSON (Proxy :: Proxy AliasRouting)
1921− propJSON (Proxy :: Proxy IndexAliasCreate)
1922− propJSON (Proxy :: Proxy SearchAliasRouting)
1923− propJSON (Proxy :: Proxy ScoreType)
1924− propJSON (Proxy :: Proxy Distance)
1925− propJSON (Proxy :: Proxy DistanceUnit)
1926− propJSON (Proxy :: Proxy DistanceType)
1927− propJSON (Proxy :: Proxy OptimizeBbox)
1928− propJSON (Proxy :: Proxy GeoBoundingBoxConstraint)
1929− propJSON (Proxy :: Proxy GeoFilterType)
1930− propJSON (Proxy :: Proxy GeoBoundingBox)
1931− propJSON (Proxy :: Proxy LatLon)
1932− propJSON (Proxy :: Proxy RangeExecution)
1933− prop "RegexpFlags FromJSON/ToJSON roundtrips, removing dups " $ \rfs ->
1934− let expected = case rfs of
1935− SomeRegexpFlags fs -> SomeRegexpFlags (NE.fromList (nub (NE.toList fs)))
1936− x -> x
1937− in parseEither parseJSON (toJSON rfs) === Right expected
1938− propJSON (Proxy :: Proxy BoolMatch)
1939− propJSON (Proxy :: Proxy Term)
1940− propJSON (Proxy :: Proxy MultiMatchQuery)
1941− propJSON (Proxy :: Proxy IndexSettings)
1942− propJSON (Proxy :: Proxy UpdatableIndexSetting')
1943− propJSON (Proxy :: Proxy ReplicaBounds)
1944− propJSON (Proxy :: Proxy Bytes)
1945− propJSON (Proxy :: Proxy AllocationPolicy)
1946− propJSON (Proxy :: Proxy InitialShardCount)
1947− propJSON (Proxy :: Proxy FSType)
1948− propJSON (Proxy :: Proxy CompoundFormat)
1949− propJSON (Proxy :: Proxy TemplateQueryInline)
1950− propJSON (Proxy :: Proxy Suggest)
1951− propJSON (Proxy :: Proxy DirectGenerators)
1952− propJSON (Proxy :: Proxy DirectGeneratorSuggestModeTypes)
1953−
1954−-- Temporary solution for lacking of generic derivation of Arbitrary
1955−-- We use generics-sop, as it's much more concise than directly using GHC.Generics
1956−--
1957−-- This will be unneeded after https://github.com/nick8325/quickcheck/pull/112
1958−-- is merged and released
1959−sopArbitrary :: forall a. (Generic a, SOP.GTo a, SOP.All SOP.SListI (SOP.GCode a), SOP.All2 Arbitrary (SOP.GCode a)) => Gen a
1960−sopArbitrary = fmap SOP.gto sopArbitrary'
1961−
1962−sopArbitrary' :: forall xss. (SOP.All SOP.SListI xss, SOP.All2 Arbitrary xss) => Gen (SOP.SOP SOP.I xss)
1963−sopArbitrary' = SOP.hsequence =<< elements (SOP.apInjs_POP $ SOP.hcpure p arbitrary)
1964− where
1965− p :: Proxy Arbitrary
1966− p = Proxy
tests/V5/tests.hsdeleted−1263
@@ -1,1263 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE DeriveGeneric #-}
5−{-# LANGUAGE FlexibleContexts #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE RecordWildCards #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TemplateHaskell #-}
11−{-# LANGUAGE TypeOperators #-}
12−{-# OPTIONS_GHC -fno-warn-orphans #-}
13−#if __GLASGOW_HASKELL__ < 800
14−{-# OPTIONS_GHC -fcontext-stack=100 #-}
15−#endif
16−#if __GLASGOW_HASKELL__ >= 802
17−{-# LANGUAGE MonoLocalBinds #-}
18−#endif
19−module Main where
20−
21−import Test.Import
22−
23−import Control.Error hiding (Script)
24−import qualified Data.HashMap.Strict as HM
25−import Data.List (nub)
26−import qualified Data.List as L
27−import Data.List.NonEmpty (NonEmpty (..))
28−import qualified Data.List.NonEmpty as NE
29−import qualified Data.Map.Strict as M
30−import Data.Text (Text)
31−import qualified Data.Text as T
32−import Data.Time.Calendar (Day (..), fromGregorian)
33−import Data.Time.Clock (UTCTime (..),
34− secondsToDiffTime)
35−import qualified Data.Vector as V
36−import qualified Data.Version as Vers
37−import qualified Database.V5.Bloodhound
38−import qualified Lens.Micro.Aeson as LMA
39−import qualified Network.HTTP.Types.Method as NHTM
40−import qualified Network.HTTP.Types.Status as NHTS
41−import qualified Network.URI as URI
42−import Prelude hiding (filter)
43−
44−import qualified Test.JSON as JSON
45−
46−testServer :: Server
47−testServer = Server "http://localhost:9200"
48−testIndex :: IndexName
49−testIndex = IndexName "bloodhound-tests-twitter-1"
50−testMapping :: MappingName
51−testMapping = MappingName "tweet"
52−
53−withTestEnv :: BH IO a -> IO a
54−withTestEnv = withBH defaultManagerSettings testServer
55−
56−validateStatus :: Show body => Response body -> Int -> Expectation
57−validateStatus resp expected =
58− if actual == expected
59− then return ()
60− else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)
61− where
62− actual = NHTS.statusCode (responseStatus resp)
63− body = responseBody resp
64−
65−createExampleIndex :: (MonadBH m) => m Reply
66−createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
67−deleteExampleIndex :: (MonadBH m) => m Reply
68−deleteExampleIndex = deleteIndex testIndex
69−
70−es13 :: Vers.Version
71−es13 = Vers.Version [1, 3, 0] []
72−
73−es12 :: Vers.Version
74−es12 = Vers.Version [1, 2, 0] []
75−
76−es11 :: Vers.Version
77−es11 = Vers.Version [1, 1, 0] []
78−
79−es14 :: Vers.Version
80−es14 = Vers.Version [1, 4, 0] []
81−
82−es15 :: Vers.Version
83−es15 = Vers.Version [1, 5, 0] []
84−
85−es16 :: Vers.Version
86−es16 = Vers.Version [1, 6, 0] []
87−
88−es20 :: Vers.Version
89−es20 = Vers.Version [2, 0, 0] []
90−
91−es50 :: Vers.Version
92−es50 = Vers.Version [5, 0, 0] []
93−
94−getServerVersion :: IO (Maybe Vers.Version)
95−getServerVersion = fmap extractVersion <$> withTestEnv getStatus
96− where
97− extractVersion = versionNumber . number . version
98−
99−-- | Get configured repo paths for snapshotting. Note that by default
100−-- this is not enabled and if we are over es 1.5, we won't be able to
101−-- test snapshotting. Note that this can and should be part of the
102−-- client functionality in a much less ad-hoc incarnation.
103−getRepoPaths :: IO [FilePath]
104−getRepoPaths = withTestEnv $ do
105− bhe <- getBHEnv
106− let Server s = bhServer bhe
107− let tUrl = s <> "/" <> "_nodes"
108− initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl))
109− let req = setRequestIgnoreStatus $ initReq { method = NHTM.methodGet }
110− Right (Object o) <- parseEsResponse =<< liftIO (httpLbs req (bhManager bhe))
111− return $ fromMaybe mempty $ do
112− Object nodes <- HM.lookup "nodes" o
113− Object firstNode <- snd <$> headMay (HM.toList nodes)
114− Object settings <- HM.lookup "settings" firstNode
115− Object path <- HM.lookup "path" settings
116− Array repo <- HM.lookup "repo" path
117− return [ T.unpack t | String t <- V.toList repo]
118−
119−-- | 1.5 and earlier don't care about repo paths
120−canSnapshot :: IO Bool
121−canSnapshot = do
122− caresAboutRepos <- atleast es16
123− repoPaths <- getRepoPaths
124− return (not caresAboutRepos || not (null (repoPaths)))
125−
126−atleast :: Vers.Version -> IO Bool
127−atleast v = getServerVersion >>= \x -> return $ x >= Just v
128−
129−atmost :: Vers.Version -> IO Bool
130−atmost v = getServerVersion >>= \x -> return $ x <= Just v
131−
132−is :: Vers.Version -> IO Bool
133−is v = getServerVersion >>= \x -> return $ x == Just v
134−
135−when' :: Monad m => m Bool -> m () -> m ()
136−when' b f = b >>= \x -> when x f
137−
138−data Location = Location { lat :: Double
139− , lon :: Double } deriving (Eq, Show)
140−
141−data Tweet = Tweet { user :: Text
142− , postDate :: UTCTime
143− , message :: Text
144− , age :: Int
145− , location :: Location
146− , extra :: Maybe Text }
147− deriving (Eq, Show)
148−
149−$(deriveJSON defaultOptions ''Location)
150−$(deriveJSON defaultOptions ''Tweet)
151−
152−data ParentMapping = ParentMapping deriving (Eq, Show)
153−
154−instance ToJSON ParentMapping where
155− toJSON ParentMapping =
156− object ["properties" .=
157− object [ "user" .= object ["type" .= ("string" :: Text)
158− , "fielddata" .= True
159− ]
160− -- Serializing the date as a date is breaking other tests, mysteriously.
161− -- , "postDate" .= object [ "type" .= ("date" :: Text)
162− -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
163− , "message" .= object ["type" .= ("string" :: Text)]
164− , "age" .= object ["type" .= ("integer" :: Text)]
165− , "location" .= object ["type" .= ("geo_point" :: Text)]
166− , "extra" .= object ["type" .= ("keyword" :: Text)]
167− ]]
168−
169−data ChildMapping = ChildMapping deriving (Eq, Show)
170−
171−instance ToJSON ChildMapping where
172− toJSON ChildMapping =
173− object ["_parent" .= object ["type" .= ("parent" :: Text)]
174− , "properties" .=
175− object [ "user" .= object ["type" .= ("string" :: Text)
176− , "fielddata" .= True
177− ]
178− -- Serializing the date as a date is breaking other tests, mysteriously.
179− -- , "postDate" .= object [ "type" .= ("date" :: Text)
180− -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
181− , "message" .= object ["type" .= ("string" :: Text)]
182− , "age" .= object ["type" .= ("integer" :: Text)]
183− , "location" .= object ["type" .= ("geo_point" :: Text)]
184− , "extra" .= object ["type" .= ("keyword" :: Text)]
185− ]]
186−
187−data TweetMapping = TweetMapping deriving (Eq, Show)
188−
189−instance ToJSON TweetMapping where
190− toJSON TweetMapping =
191− object ["tweet" .=
192− object ["properties" .=
193− object [ "user" .= object [ "type" .= ("string" :: Text)
194− , "fielddata" .= True
195− ]
196− -- Serializing the date as a date is breaking other tests, mysteriously.
197− -- , "postDate" .= object [ "type" .= ("date" :: Text)
198− -- , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]
199− , "message" .= object ["type" .= ("string" :: Text)]
200− , "age" .= object ["type" .= ("integer" :: Text)]
201− , "location" .= object ["type" .= ("geo_point" :: Text)]
202− , "extra" .= object ["type" .= ("keyword" :: Text)]
203− ]]]
204−
205−exampleTweet :: Tweet
206−exampleTweet = Tweet { user = "bitemyapp"
207− , postDate = UTCTime
208− (ModifiedJulianDay 55000)
209− (secondsToDiffTime 10)
210− , message = "Use haskell!"
211− , age = 10000
212− , location = Location 40.12 (-71.34)
213− , extra = Nothing }
214−
215−tweetWithExtra :: Tweet
216−tweetWithExtra = Tweet { user = "bitemyapp"
217− , postDate = UTCTime
218− (ModifiedJulianDay 55000)
219− (secondsToDiffTime 10)
220− , message = "Use haskell!"
221− , age = 10000
222− , location = Location 40.12 (-71.34)
223− , extra = Just "blah blah" }
224−
225−newAge :: Int
226−newAge = 31337
227−
228−newUser :: Text
229−newUser = "someotherapp"
230−
231−tweetPatch :: Value
232−tweetPatch =
233− object [ "age" .= newAge
234− , "user" .= newUser
235− ]
236−
237−patchedTweet :: Tweet
238−patchedTweet = exampleTweet{age = newAge, user = newUser}
239−
240−otherTweet :: Tweet
241−otherTweet = Tweet { user = "notmyapp"
242− , postDate = UTCTime
243− (ModifiedJulianDay 55000)
244− (secondsToDiffTime 11)
245− , message = "Use haskell!"
246− , age = 1000
247− , location = Location 40.12 (-71.34)
248− , extra = Nothing }
249−
250−resetIndex :: BH IO ()
251−resetIndex = do
252− _ <- deleteExampleIndex
253− _ <- createExampleIndex
254− _ <- putMapping testIndex testMapping TweetMapping
255− return ()
256−
257−insertData :: BH IO Reply
258−insertData = do
259− resetIndex
260− insertData' defaultIndexDocumentSettings
261−
262−insertData' :: IndexDocumentSettings -> BH IO Reply
263−insertData' ids = do
264− r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
265− _ <- refreshIndex testIndex
266− return r
267−
268−updateData :: BH IO Reply
269−updateData = do
270− r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1")
271− _ <- refreshIndex testIndex
272− return r
273−
274−insertOther :: BH IO ()
275−insertOther = do
276− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
277− _ <- refreshIndex testIndex
278− return ()
279−
280−insertExtra :: BH IO ()
281−insertExtra = do
282− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4")
283− _ <- refreshIndex testIndex
284− return ()
285−
286−insertWithSpaceInId :: BH IO ()
287−insertWithSpaceInId = do
288− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World")
289− _ <- refreshIndex testIndex
290− return ()
291−
292−searchTweet :: Search -> BH IO (Either EsError Tweet)
293−searchTweet search = do
294− result <- searchTweets search
295− let myTweet :: Either EsError Tweet
296− myTweet = grabFirst result
297− return myTweet
298−
299−searchTweets :: Search -> BH IO (Either EsError (SearchResult Tweet))
300−searchTweets search = parseEsResponse =<< searchByIndex testIndex search
301−
302−searchExpectNoResults :: Search -> BH IO ()
303−searchExpectNoResults search = do
304− result <- searchTweets search
305− let emptyHits = fmap (hits . searchHits) result
306− liftIO $
307− emptyHits `shouldBe` Right []
308−
309−searchExpectAggs :: Search -> BH IO ()
310−searchExpectAggs search = do
311− reply <- searchByIndex testIndex search
312− let isEmpty x = return (M.null x)
313− let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
314− liftIO $
315− (result >>= aggregations >>= isEmpty) `shouldBe` Just False
316−
317−searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
318− Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
319−searchValidBucketAgg search aggKey extractor = do
320− reply <- searchByIndex testIndex search
321− let bucketDocs = docCount . head . buckets
322− let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
323− let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)
324− liftIO $
325− count `shouldBe` Just 1
326−
327−searchTermsAggHint :: [ExecutionHint] -> BH IO ()
328−searchTermsAggHint hints = do
329− let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
330− let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
331− forM_ hints $ searchExpectAggs . search
332− forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
333−
334−searchTweetHighlight :: Search -> BH IO (Either EsError (Maybe HitHighlight))
335−searchTweetHighlight search = do
336− result <- searchTweets search
337− let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
338− return myHighlight
339−
340−searchExpectSource :: Source -> Either EsError Value -> BH IO ()
341−searchExpectSource src expected = do
342− _ <- insertData
343− let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
344− let search = (mkSearch (Just query) Nothing) { source = Just src }
345− reply <- searchByIndex testIndex search
346− result <- parseEsResponse reply
347− let value = grabFirst result
348− liftIO $
349− value `shouldBe` expected
350−
351−withSnapshotRepo
352− :: ( MonadMask m
353− , MonadBH m
354− )
355− => SnapshotRepoName
356− -> (GenericSnapshotRepo -> m a)
357− -> m a
358−withSnapshotRepo srn@(SnapshotRepoName n) f = do
359− repoPaths <- liftIO getRepoPaths
360− -- we'll use the first repo path if available, otherwise system temp
361− -- dir. Note that this will fail on ES > 1.6, so be sure you use
362− -- @when' canSnapshot@.
363− case repoPaths of
364− (firstRepoPath:_) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f
365− [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f
366− where
367− alloc dir = do
368− liftIO (setFileMode dir mode)
369− let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing
370− resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo
371− liftIO (validateStatus resp 200)
372− return (toGSnapshotRepo repo)
373− mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes
374− free GenericSnapshotRepo {..} = do
375− resp <- deleteSnapshotRepo gSnapshotRepoName
376− liftIO (validateStatus resp 200)
377−
378−
379−withSnapshot
380− :: ( MonadMask m
381− , MonadBH m
382− )
383− => SnapshotRepoName
384− -> SnapshotName
385− -> m a
386− -> m a
387−withSnapshot srn sn = bracket_ alloc free
388− where
389− alloc = do
390− resp <- createSnapshot srn sn createSettings
391− liftIO (validateStatus resp 200)
392− -- We'll make this synchronous for testing purposes
393− createSettings = defaultSnapshotCreateSettings { snapWaitForCompletion = True
394− , snapIndices = Just (IndexList (testIndex :| []))
395− -- We don't actually need to back up any data
396− }
397− free = do
398− deleteSnapshot srn sn
399−
400−
401−
402−newtype BulkTest =
403− BulkTest { name :: Text }
404− deriving (Eq, Show)
405−
406−instance ToJSON BulkTest where
407− toJSON (BulkTest name) =
408− object ["name" .= name]
409−
410−instance FromJSON BulkTest where
411− parseJSON = withObject "BulkTest" parse
412− where
413− parse o = do
414− t <- o .: "name"
415− BulkTest <$> parseJSON t
416−
417−noDuplicates :: Eq a => [a] -> Bool
418−noDuplicates xs = nub xs == xs
419−
420−
421−getSource :: EsResult a -> Maybe a
422−getSource = fmap _source . foundResult
423−
424−grabFirst :: Either EsError (SearchResult a) -> Either EsError a
425−grabFirst r =
426− case fmap (hitSource . head . hits . searchHits) r of
427− (Left e) -> Left e
428− (Right Nothing) -> Left (EsError 500 "Source was missing")
429− (Right (Just x)) -> Right x
430−
431−main :: IO ()
432−main = hspec $ do
433− JSON.spec
434− describe "index create/delete API" $ do
435− it "creates and then deletes the requested index" $ withTestEnv $ do
436− -- priming state.
437− _ <- deleteExampleIndex
438− resp <- createExampleIndex
439− deleteResp <- deleteExampleIndex
440− liftIO $ do
441− validateStatus resp 200
442− validateStatus deleteResp 200
443−
444− describe "error parsing" $ do
445− it "can parse EsErrors for < 2.0" $ when' (atmost es16) $ withTestEnv $ do
446− res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
447− let errorResp = eitherDecode (responseBody res)
448− liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]"))
449−
450− it "can parse EsErrors for >= 2.0" $ when' (atleast es20) $ withTestEnv $ do
451− res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
452− let errorResp = eitherDecode (responseBody res)
453− liftIO (errorResp `shouldBe` Right (EsError 404 "no such index"))
454−
455− describe "document API" $ do
456− it "indexes, updates, gets, and then deletes the generated document" $ withTestEnv $ do
457− _ <- insertData
458− _ <- updateData
459− docInserted <- getDocument testIndex testMapping (DocId "1")
460− let newTweet = eitherDecode
461− (responseBody docInserted) :: Either String (EsResult Tweet)
462− liftIO $ (fmap getSource newTweet `shouldBe` Right (Just patchedTweet))
463−
464− it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do
465− _ <- insertWithSpaceInId
466− docInserted <- getDocument testIndex testMapping (DocId "Hello World")
467− let newTweet = eitherDecode
468− (responseBody docInserted) :: Either String (EsResult Tweet)
469− liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
470−
471− it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
472− doc <- getDocument testIndex testMapping (DocId "bogus")
473− let noTweet = eitherDecode
474− (responseBody doc) :: Either String (EsResult Tweet)
475− liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
476−
477− it "can use optimistic concurrency control" $ withTestEnv $ do
478− let ev = ExternalDocVersion minBound
479− let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
480− resetIndex
481− res <- insertData' cfg
482− liftIO $ isCreated res `shouldBe` True
483− res' <- insertData' cfg
484− liftIO $ isVersionConflict res' `shouldBe` True
485−
486− it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do
487− resetIndex
488− _ <- putMapping testIndex (MappingName "child") ChildMapping
489− _ <- putMapping testIndex (MappingName "parent") ParentMapping
490− _ <- indexDocument testIndex (MappingName "parent") defaultIndexDocumentSettings exampleTweet (DocId "1")
491− let parent = (Just . DocumentParent . DocId) "1"
492− ids = IndexDocumentSettings NoVersionControl parent
493− _ <- indexDocument testIndex (MappingName "child") ids otherTweet (DocId "2")
494− _ <- refreshIndex testIndex
495− exists <- documentExists testIndex (MappingName "child") parent (DocId "2")
496− liftIO $ exists `shouldBe` True
497−
498− describe "template API" $ do
499− it "can create a template" $ withTestEnv $ do
500− let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
501− resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
502− liftIO $ validateStatus resp 200
503−
504− it "can detect if a template exists" $ withTestEnv $ do
505− exists <- templateExists (TemplateName "tweet-tpl")
506− liftIO $ exists `shouldBe` True
507−
508− it "can delete a template" $ withTestEnv $ do
509− resp <- deleteTemplate (TemplateName "tweet-tpl")
510− liftIO $ validateStatus resp 200
511−
512− it "can detect if a template doesn't exist" $ withTestEnv $ do
513− exists <- templateExists (TemplateName "tweet-tpl")
514− liftIO $ exists `shouldBe` False
515−
516− describe "bulk API" $ do
517− it "inserts all documents we request" $ withTestEnv $ do
518− _ <- insertData
519− let firstTest = BulkTest "blah"
520− let secondTest = BulkTest "bloo"
521− let thirdTest = BulkTest "graffle"
522− let fourthTest = BulkTest "garabadoo"
523− let fifthTest = BulkTest "serenity"
524− let firstDoc = BulkIndex testIndex
525− testMapping (DocId "2") (toJSON firstTest)
526− let secondDoc = BulkCreate testIndex
527− testMapping (DocId "3") (toJSON secondTest)
528− let thirdDoc = BulkCreateEncoding testIndex
529− testMapping (DocId "4") (toEncoding thirdTest)
530− let fourthDoc = BulkIndexAuto testIndex
531− testMapping (toJSON fourthTest)
532− let fifthDoc = BulkIndexEncodingAuto testIndex
533− testMapping (toEncoding fifthTest)
534− let stream = V.fromList [firstDoc, secondDoc, thirdDoc, fourthDoc, fifthDoc]
535− _ <- bulk stream
536− -- liftIO $ pPrint bulkResp
537− _ <- refreshIndex testIndex
538− -- liftIO $ pPrint refreshResp
539− fDoc <- getDocument testIndex testMapping (DocId "2")
540− sDoc <- getDocument testIndex testMapping (DocId "3")
541− tDoc <- getDocument testIndex testMapping (DocId "4")
542− -- note that we cannot query for fourthDoc and fifthDoc since we
543− -- do not know their autogenerated ids.
544− let maybeFirst =
545− eitherDecode
546− $ responseBody fDoc
547− :: Either String (EsResult BulkTest)
548− let maybeSecond =
549− eitherDecode
550− $ responseBody sDoc
551− :: Either String (EsResult BulkTest)
552− let maybeThird =
553− eitherDecode
554− $ responseBody tDoc
555− :: Either String (EsResult BulkTest)
556− -- liftIO $ pPrint [maybeFirst, maybeSecond, maybeThird]
557− liftIO $ do
558− fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
559− fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
560− fmap getSource maybeThird `shouldBe` Right (Just thirdTest)
561− -- Since we can't get the docs by doc id, we check for their existence in
562− -- a match all query.
563− let query = MatchAllQuery Nothing
564− let search = mkSearch (Just query) Nothing
565− resp <- searchByIndex testIndex search
566− parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))
567− case parsed of
568− Left e ->
569− liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)
570− (Right sr) -> do
571− liftIO $
572− hitsTotal (searchHits sr) `shouldBe` 6
573− let nameList :: [Text]
574− nameList =
575− (hits (searchHits sr))
576− ^.. traverse
577− . to hitSource
578− . _Just
579− . LMA.key "name"
580− . _String
581− liftIO $
582− nameList
583− `shouldBe` ["blah","bloo","graffle","garabadoo","serenity"]
584−
585−
586− describe "query API" $ do
587− it "returns document for term query and identity filter" $ withTestEnv $ do
588− _ <- insertData
589− let query = TermQuery (Term "user" "bitemyapp") Nothing
590− let filter = Filter $ MatchAllQuery Nothing
591− let search = mkSearch (Just query) (Just filter)
592− myTweet <- searchTweet search
593− liftIO $
594− myTweet `shouldBe` Right exampleTweet
595−
596− it "handles constant score queries" $ withTestEnv $ do
597− _ <- insertData
598− let query = TermsQuery "user" ("bitemyapp" :| [])
599− let cfQuery = ConstantScoreQuery query (Boost 1.0)
600− let filter = Filter $ MatchAllQuery Nothing
601− let search = mkSearch (Just cfQuery) (Just filter)
602− myTweet <- searchTweet search
603− liftIO $
604− myTweet `shouldBe` Right exampleTweet
605−
606− it "returns document for terms query and identity filter" $ withTestEnv $ do
607− _ <- insertData
608− let query = TermsQuery "user" ("bitemyapp" :| [])
609− let filter = Filter $ MatchAllQuery Nothing
610− let search = mkSearch (Just query) (Just filter)
611− myTweet <- searchTweet search
612− liftIO $
613− myTweet `shouldBe` Right exampleTweet
614−
615− it "returns document for match query" $ withTestEnv $ do
616− _ <- insertData
617− let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
618− let search = mkSearch (Just query) Nothing
619− myTweet <- searchTweet search
620− liftIO $
621− myTweet `shouldBe` Right exampleTweet
622−
623− it "returns document for multi-match query" $ withTestEnv $ do
624− _ <- insertData
625− let flds = [FieldName "user", FieldName "message"]
626− let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
627− let search = mkSearch (Just query) Nothing
628− myTweet <- searchTweet search
629− liftIO $
630− myTweet `shouldBe` Right exampleTweet
631−
632− it "returns document for multi-match query with a custom tiebreaker" $ withTestEnv $ do
633− _ <- insertData
634− let tiebreaker = Just $ Tiebreaker 0.3
635− flds = [FieldName "user", FieldName "message"]
636− multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")
637− query = QueryMultiMatchQuery $ multiQuery' { multiMatchQueryTiebreaker = tiebreaker }
638− search = mkSearch (Just query) Nothing
639− myTweet <- searchTweet search
640− liftIO $
641− myTweet `shouldBe` Right exampleTweet
642−
643− it "returns document for bool query" $ withTestEnv $ do
644− _ <- insertData
645− let innerQuery = QueryMatchQuery $
646− mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
647− let query = QueryBoolQuery $
648− mkBoolQuery [innerQuery] [] [] []
649− let search = mkSearch (Just query) Nothing
650− myTweet <- searchTweet search
651− liftIO $
652− myTweet `shouldBe` Right exampleTweet
653−
654− it "returns document for boosting query" $ withTestEnv $ do
655− _ <- insertData
656− let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")
657− let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")
658− let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)
659− let search = mkSearch (Just query) Nothing
660− myTweet <- searchTweet search
661− liftIO $
662− myTweet `shouldBe` Right exampleTweet
663−
664− it "returns document for common terms query" $ withTestEnv $ do
665− _ <- insertData
666− let query = QueryCommonTermsQuery $
667− CommonTermsQuery (FieldName "user")
668− (QueryString "bitemyapp")
669− (CutoffFrequency 0.0001)
670− Or Or Nothing Nothing Nothing Nothing
671− let search = mkSearch (Just query) Nothing
672− myTweet <- searchTweet search
673− liftIO $
674− myTweet `shouldBe` Right exampleTweet
675−
676− it "returns document for for inline template query" $ withTestEnv $ do
677− _ <- insertData
678− let innerQuery = QueryMatchQuery $
679− mkMatchQuery (FieldName "{{userKey}}")
680− (QueryString "{{bitemyappKey}}")
681− templateParams = TemplateQueryKeyValuePairs $ HM.fromList
682− [ ("userKey", "user")
683− , ("bitemyappKey", "bitemyapp")
684− ]
685− templateQuery = QueryTemplateQueryInline $
686− TemplateQueryInline innerQuery templateParams
687− search = mkSearch (Just templateQuery) Nothing
688− myTweet <- searchTweet search
689− liftIO $ myTweet `shouldBe` Right exampleTweet
690−
691−
692− describe "sorting" $ do
693− it "returns documents in the right order" $ withTestEnv $ do
694− _ <- insertData
695− _ <- insertOther
696− let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
697− let search = Search Nothing
698− Nothing (Just [sortSpec]) Nothing Nothing
699− False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
700− Nothing Nothing
701− result <- searchTweets search
702− let myTweet = grabFirst result
703− liftIO $
704− myTweet `shouldBe` Right otherTweet
705−
706− describe "Aggregation API" $ do
707− it "returns term aggregation results" $ withTestEnv $ do
708− _ <- insertData
709− let terms = TermsAgg $ mkTermsAggregation "user"
710− let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
711− searchExpectAggs search
712− searchValidBucketAgg search "users" toTerms
713−
714− it "return sub-aggregation results" $ withTestEnv $ do
715− _ <- insertData
716− let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation "age"
717− agg = TermsAgg $ (mkTermsAggregation "user") { termAggs = Just subaggs}
718− search = mkAggregateSearch Nothing $ mkAggregations "users" agg
719− reply <- searchByIndex testIndex search
720− let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)
721− usersAggResults = result >>= aggregations >>= toTerms "users"
722− subAggResults = usersAggResults >>= (listToMaybe . buckets) >>= termsAggs >>= toTerms "age_agg"
723− subAddResultsExists = isJust subAggResults
724− liftIO $ (subAddResultsExists) `shouldBe` True
725−
726− it "returns cardinality aggregation results" $ withTestEnv $ do
727− _ <- insertData
728− let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user"
729− let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality
730− let search' = search { Database.V5.Bloodhound.from = From 0, size = Size 0 }
731− searchExpectAggs search'
732− let docCountPair k n = (k, object ["value" .= Number n])
733− res <- searchTweets search'
734− liftIO $
735− fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "users" 1]))
736−
737− it "returns stats aggregation results" $ withTestEnv $ do
738− _ <- insertData
739− let stats = StatsAgg $ mkStatsAggregation $ FieldName "age"
740− let search = mkAggregateSearch Nothing $ mkAggregations "users" stats
741− let search' = search { Database.V5.Bloodhound.from = From 0, size = Size 0 }
742− searchExpectAggs search'
743− let statsAggRes k n = (k, object [ "max" .= Number n
744− , "avg" .= Number n
745− , "count" .= Number 1
746− , "min" .= Number n
747− , "sum" .= Number n])
748− res <- searchTweets search'
749− liftIO $
750− fmap aggregations res `shouldBe` Right (Just (M.fromList [ statsAggRes "users" 10000]))
751−
752− it "can give collection hint parameters to term aggregations" $ when' (atleast es13) $ withTestEnv $ do
753− _ <- insertData
754− let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
755− let search = mkAggregateSearch Nothing $ mkAggregations "users" terms
756− searchExpectAggs search
757− searchValidBucketAgg search "users" toTerms
758−
759− -- One of these fails with 1.7.3
760− it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
761− _ <- insertData
762− searchTermsAggHint [Map, Ordinals]
763−
764− it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
765− _ <- insertData
766− searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
767−
768− it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
769− _ <- insertData
770− searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
771− -- One of the above.
772−
773− it "can execute value_count aggregations" $ withTestEnv $ do
774− _ <- insertData
775− _ <- insertOther
776− let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
777− mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
778− let search = mkAggregateSearch Nothing ags
779− let docCountPair k n = (k, object ["value" .= Number n])
780− res <- searchTweets search
781− liftIO $
782− fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
783− , docCountPair "bogus_count" 0
784− ]))
785−
786− it "can execute date_range aggregations" $ withTestEnv $ do
787− let now = fromGregorian 2015 3 14
788− let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0
789− let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0
790− let oldDoc = exampleTweet { postDate = ltAMonthAgo }
791− let newDoc = exampleTweet { postDate = ltAWeekAgo }
792− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings oldDoc (DocId "1")
793− _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings newDoc (DocId "2")
794− _ <- refreshIndex testIndex
795− let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth])
796− let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek])
797− let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek])
798− let ags = mkAggregations "date_ranges" (DateRangeAgg agg)
799− let search = mkAggregateSearch Nothing ags
800− res <- searchTweets search
801− liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right 2
802− let bucks = do magrs <- fmapL show (aggregations <$> res)
803− agrs <- note "no aggregations returned" magrs
804− rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs
805− parseEither parseJSON rawBucks
806− let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0
807− let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0
808− liftIO $ buckets <$> bucks `shouldBe` Right [ DateRangeResult "2015-02-14T00:00:00.000Z-*"
809− (Just fromMonthT)
810− (Just "2015-02-14T00:00:00.000Z")
811− Nothing
812− Nothing
813− 2
814− Nothing
815− , DateRangeResult "2015-03-07T00:00:00.000Z-*"
816− (Just fromWeekT)
817− (Just "2015-03-07T00:00:00.000Z")
818− Nothing
819− Nothing
820− 1
821− Nothing
822− ]
823−
824− it "returns date histogram aggregation results" $ withTestEnv $ do
825− _ <- insertData
826− let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
827− let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
828− searchExpectAggs search
829− searchValidBucketAgg search "byDate" toDateHistogram
830−
831− it "can execute missing aggregations" $ withTestEnv $ do
832− _ <- insertData
833− _ <- insertExtra
834− let ags = mkAggregations "missing_agg" (MissingAgg (MissingAggregation "extra"))
835− let search = mkAggregateSearch Nothing ags
836− let docCountPair k n = (k, object ["doc_count" .= Number n])
837− res <- searchTweets search
838− liftIO $
839− fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "missing_agg" 1]))
840−
841− describe "Highlights API" $ do
842−
843− it "returns highlight from query when there should be one" $ withTestEnv $ do
844− _ <- insertData
845− _ <- insertOther
846− let query = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell")
847− let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
848−
849− let search = mkHighlightSearch (Just query) testHighlight
850− myHighlight <- searchTweetHighlight search
851− liftIO $
852− myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
853−
854− it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do
855− _ <- insertData
856− _ <- insertOther
857− let query = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell")
858− let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
859−
860− let search = mkHighlightSearch (Just query) testHighlight
861− myHighlight <- searchTweetHighlight search
862− liftIO $
863− myHighlight `shouldBe` Right Nothing
864−
865− describe "Source filtering" $ do
866−
867− it "doesn't include source when sources are disabled" $ withTestEnv $ do
868− searchExpectSource
869− NoSource
870− (Left (EsError 500 "Source was missing"))
871−
872− it "includes a source" $ withTestEnv $ do
873− searchExpectSource
874− (SourcePatterns (PopPattern (Pattern "message")))
875− (Right (Object (HM.fromList [("message", String "Use haskell!")])))
876−
877− it "includes sources" $ withTestEnv $ do
878− searchExpectSource
879− (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))
880− (Right (Object (HM.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))
881−
882− it "includes source patterns" $ withTestEnv $ do
883− searchExpectSource
884− (SourcePatterns (PopPattern (Pattern "*ge")))
885− (Right (Object (HM.fromList [("age", Number 10000),("message", String "Use haskell!")])))
886−
887− it "excludes source patterns" $ withTestEnv $ do
888− searchExpectSource
889− (SourceIncludeExclude (Include [])
890− (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"]))
891− (Right (Object (HM.fromList [("user",String "bitemyapp")])))
892−
893− describe "ToJSON RegexpFlags" $ do
894− it "generates the correct JSON for AllRegexpFlags" $
895− toJSON AllRegexpFlags `shouldBe` String "ALL"
896−
897− it "generates the correct JSON for NoRegexpFlags" $
898− toJSON NoRegexpFlags `shouldBe` String "NONE"
899−
900− it "generates the correct JSON for SomeRegexpFlags" $
901− let flags = AnyString :| [ Automaton
902− , Complement
903− , Empty
904− , Intersection
905− , Interval ]
906− in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"
907−
908− prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->
909− let String str = toJSON flags
910− flagStrs = T.splitOn "|" str
911− in noDuplicates flagStrs
912−
913− describe "omitNulls" $ do
914− it "checks that omitNulls drops list elements when it should" $
915− let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))
916− , "test2" .= (toJSON ("some value" :: Text))]
917− in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
918−
919− it "checks that omitNulls doesn't drop list elements when it shouldn't" $
920− let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))
921− , "test2" .= (toJSON ("some value" :: Text))]
922− in notDropped `shouldBe` Object (HM.fromList [ ("test1", Array (V.fromList [Number 1.0]))
923− , ("test2", String "some value")])
924− it "checks that omitNulls drops non list elements when it should" $
925− let dropped = omitNulls $ [ "test1" .= (toJSON Null)
926− , "test2" .= (toJSON ("some value" :: Text))]
927− in dropped `shouldBe` Object (HM.fromList [("test2", String "some value")])
928− it "checks that omitNulls doesn't drop non list elements when it shouldn't" $
929− let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))
930− , "test2" .= (toJSON ("some value" :: Text))]
931− in notDropped `shouldBe` Object (HM.fromList [ ("test1", Number 1.0)
932− , ("test2", String "some value")])
933− describe "Monoid (SearchHits a)" $ do
934− prop "abides the monoid laws" $ eq $
935− prop_Monoid (T :: T (SearchHits ()))
936−
937− describe "mkDocVersion" $ do
938− prop "can never construct an out of range docVersion" $ \i ->
939− let res = mkDocVersion i
940− in case res of
941− Nothing -> property True
942− Just dv -> (dv >= minBound) .&&.
943− (dv <= maxBound) .&&.
944− docVersionNumber dv === i
945−
946− describe "FsSnapshotRepo" $ do
947− prop "SnapshotRepo laws" $ \fsr ->
948− fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)
949−
950− describe "snapshot repos" $ do
951− it "always parses all snapshot repos API" $ when' canSnapshot $ withTestEnv $ do
952− res <- getSnapshotRepos AllSnapshotRepos
953− liftIO $ case res of
954− Left e -> expectationFailure ("Expected a right but got Left " <> show e)
955− Right _ -> return ()
956−
957− it "finds an existing list of repos" $ when' canSnapshot $ withTestEnv $ do
958− let r1n = SnapshotRepoName "bloodhound-repo1"
959− let r2n = SnapshotRepoName "bloodhound-repo2"
960− withSnapshotRepo r1n $ \r1 ->
961− withSnapshotRepo r2n $ \r2 -> do
962− repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))
963− liftIO $ case repos of
964− Right xs -> do
965− let srt = L.sortBy (comparing gSnapshotRepoName)
966− srt xs `shouldBe` srt [r1, r2]
967− Left e -> expectationFailure (show e)
968−
969− it "creates and updates with updateSnapshotRepo" $ when' canSnapshot $ withTestEnv $ do
970− let r1n = SnapshotRepoName "bloodhound-repo1"
971− withSnapshotRepo r1n $ \r1 -> do
972− let Just (String dir) = HM.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))
973− let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing
974− resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression
975− liftIO (validateStatus resp 200)
976− Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))
977− liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)
978−
979− -- verify came around in 1.4 it seems
980− it "can verify existing repos" $ when' canSnapshot $ when' (atleast es14) $ withTestEnv $ do
981− let r1n = SnapshotRepoName "bloodhound-repo1"
982− withSnapshotRepo r1n $ \_ -> do
983− res <- verifySnapshotRepo r1n
984− liftIO $ case res of
985− Right (SnapshotVerification vs)
986− | null vs -> expectationFailure "Expected nonempty set of verifying nodes"
987− | otherwise -> return ()
988− Left e -> expectationFailure (show e)
989−
990− describe "snapshots" $ do
991− it "always parses all snapshots API" $ when' canSnapshot $ withTestEnv $ do
992− let r1n = SnapshotRepoName "bloodhound-repo1"
993− withSnapshotRepo r1n $ \_ -> do
994− res <- getSnapshots r1n AllSnapshots
995− liftIO $ case res of
996− Left e -> expectationFailure ("Expected a right but got Left " <> show e)
997− Right _ -> return ()
998−
999− it "can parse a snapshot that it created" $ when' canSnapshot $ withTestEnv $ do
1000− let r1n = SnapshotRepoName "bloodhound-repo1"
1001− withSnapshotRepo r1n $ \_ -> do
1002− let s1n = SnapshotName "example-snapshot"
1003− withSnapshot r1n s1n $ do
1004− res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))
1005− liftIO $ case res of
1006− Right [snap]
1007− | snapInfoState snap == SnapshotSuccess &&
1008− snapInfoName snap == s1n -> return ()
1009− | otherwise -> expectationFailure (show snap)
1010− Right [] -> expectationFailure "There were no snapshots"
1011− Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))
1012− Left e -> expectationFailure (show e)
1013−
1014− describe "snapshot restore" $ do
1015− it "can restore a snapshot that we create" $ when' canSnapshot $ withTestEnv $ do
1016− let r1n = SnapshotRepoName "bloodhound-repo1"
1017− withSnapshotRepo r1n $ \_ -> do
1018− let s1n = SnapshotName "example-snapshot"
1019− withSnapshot r1n s1n $ do
1020− let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True }
1021− -- have to close an index to restore it
1022− resp1 <- closeIndex testIndex
1023− liftIO (validateStatus resp1 200)
1024− resp2 <- restoreSnapshot r1n s1n settings
1025− liftIO (validateStatus resp2 200)
1026−
1027− it "can restore and rename" $ when' canSnapshot $ withTestEnv $ do
1028− let r1n = SnapshotRepoName "bloodhound-repo1"
1029− withSnapshotRepo r1n $ \_ -> do
1030− let s1n = SnapshotName "example-snapshot"
1031− withSnapshot r1n s1n $ do
1032− let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"
1033− let replace = RRTLit "restored-" :| [RRSubWholeMatch]
1034− let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"
1035− oldEnoughForOverrides <- liftIO (atleast es15)
1036− let overrides = RestoreIndexSettings { restoreOverrideReplicas = Just (ReplicaCount 0) }
1037− let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True
1038− , snapRestoreRenamePattern = Just pat
1039− , snapRestoreRenameReplacement = Just replace
1040− , snapRestoreIndexSettingsOverrides = if oldEnoughForOverrides
1041− then Just overrides
1042− else Nothing
1043− }
1044− -- have to close an index to restore it
1045− let go = do
1046− resp <- restoreSnapshot r1n s1n settings
1047− liftIO (validateStatus resp 200)
1048− exists <- indexExists expectedIndex
1049− liftIO (exists `shouldBe` True)
1050− go `finally` deleteIndex expectedIndex
1051−
1052− describe "getNodesInfo" $ do
1053− it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
1054− res <- getNodesInfo LocalNode
1055− liftIO $ case res of
1056− -- This is really just a smoke test for response
1057− -- parsing. Node info is so variable, there's not much I can
1058− -- assert here.
1059− Right NodesInfo {..} -> length nodesInfo `shouldBe` 1
1060− Left e -> expectationFailure ("Expected NodesInfo but got " <> show e)
1061−
1062− describe "getNodesStats" $ do
1063− it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
1064− res <- getNodesStats LocalNode
1065− liftIO $ case res of
1066− -- This is really just a smoke test for response
1067− -- parsing. Node stats is so variable, there's not much I can
1068− -- assert here.
1069− Right NodesStats {..} -> length nodesStats `shouldBe` 1
1070− Left e -> expectationFailure ("Expected NodesStats but got " <> show e)
1071−
1072− describe "Enum DocVersion" $ do
1073− it "follows the laws of Enum, Bounded" $ do
1074− evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
1075− evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
1076− evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
1077− evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
1078− enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
1079− enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
1080− enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
1081−
1082− describe "scan&scroll API" $ do
1083− it "returns documents using the scan&scroll API" $ withTestEnv $ do
1084− _ <- insertData
1085− _ <- insertOther
1086− let search = (mkSearch (Just $ MatchAllQuery Nothing) Nothing) { size = (Size 1) }
1087− regular_search <- searchTweet search
1088− scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]
1089− let scan_search = map hitSource scan_search'
1090− liftIO $
1091− regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
1092− liftIO $
1093− scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]
1094−
1095− describe "index aliases" $ do
1096− let aname = IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias")
1097− let alias = IndexAlias (testIndex) aname
1098− let create = IndexAliasCreate Nothing Nothing
1099− let action = AddAlias alias create
1100− it "handles the simple case of aliasing an existing index" $ do
1101− withTestEnv $ do
1102− resetIndex
1103− resp <- updateIndexAliases (action :| [])
1104− liftIO $ validateStatus resp 200
1105− let cleanup = withTestEnv (updateIndexAliases (RemoveAlias alias :| []))
1106− (do aliases <- withTestEnv getIndexAliases
1107− let expected = IndexAliasSummary alias create
1108− case aliases of
1109− Right (IndexAliasesSummary summs) ->
1110− L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected
1111− Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup
1112− it "allows alias deletion" $ do
1113− aliases <- withTestEnv $ do
1114− resetIndex
1115− resp <- updateIndexAliases (action :| [])
1116− liftIO $ validateStatus resp 200
1117− _ <- deleteIndexAlias aname
1118− getIndexAliases
1119− -- let expected = IndexAliasSummary alias create
1120− case aliases of
1121− Right (IndexAliasesSummary summs) ->
1122− L.find ( (== aname)
1123− . indexAlias
1124− . indexAliasSummaryAlias
1125− ) summs
1126− `shouldBe` Nothing
1127− Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)
1128−
1129− describe "Index Listing" $ do
1130− it "returns a list of index names" $ withTestEnv $ do
1131− _ <- createExampleIndex
1132− ixns <- listIndices
1133− liftIO (ixns `shouldContain` [testIndex])
1134−
1135− describe "Index Settings" $ do
1136− it "persists settings" $ withTestEnv $ do
1137− _ <- deleteExampleIndex
1138− _ <- createExampleIndex
1139− let updates = BlocksWrite False :| []
1140− updateResp <- updateIndexSettings updates testIndex
1141− liftIO $ validateStatus updateResp 200
1142− getResp <- getIndexSettings testIndex
1143− liftIO $
1144− getResp `shouldBe` Right (IndexSettingsSummary
1145− testIndex
1146− (IndexSettings (ShardCount 1) (ReplicaCount 0))
1147− (NE.toList updates))
1148−
1149− it "allows total fields to be set" $ when' (atleast es50) $ withTestEnv $ do
1150− _ <- deleteExampleIndex
1151− _ <- createExampleIndex
1152− let updates = MappingTotalFieldsLimit 2500 :| []
1153− updateResp <- updateIndexSettings updates testIndex
1154− liftIO $ validateStatus updateResp 200
1155− getResp <- getIndexSettings testIndex
1156− liftIO $
1157− getResp `shouldBe` Right (IndexSettingsSummary
1158− testIndex
1159− (IndexSettings (ShardCount 1) (ReplicaCount 0))
1160− (NE.toList updates))
1161−
1162− it "accepts customer analyzers" $ when' (atleast es50) $ withTestEnv $ do
1163− _ <- deleteExampleIndex
1164− let analysis = Analysis
1165− (M.singleton "ex_analyzer"
1166− ( AnalyzerDefinition
1167− (Just (Tokenizer "ex_tokenizer"))
1168− (map TokenFilter
1169− [ "ex_filter_lowercase","ex_filter_uppercase","ex_filter_apostrophe"
1170− , "ex_filter_reverse","ex_filter_snowball"
1171− , "ex_filter_shingle"
1172− ]
1173− )
1174− )
1175− )
1176− (M.singleton "ex_tokenizer"
1177− ( TokenizerDefinitionNgram
1178− ( Ngram 3 4 [TokenLetter,TokenDigit])
1179− )
1180− )
1181− (M.fromList
1182− [ ("ex_filter_lowercase",TokenFilterDefinitionLowercase (Just Greek))
1183− , ("ex_filter_uppercase",TokenFilterDefinitionUppercase Nothing)
1184− , ("ex_filter_apostrophe",TokenFilterDefinitionApostrophe)
1185− , ("ex_filter_reverse",TokenFilterDefinitionReverse)
1186− , ("ex_filter_snowball",TokenFilterDefinitionSnowball English)
1187− , ("ex_filter_shingle",TokenFilterDefinitionShingle (Shingle 3 3 True False " " "_"))
1188− ]
1189− )
1190− updates = [AnalysisSetting analysis]
1191− createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
1192− liftIO $ validateStatus createResp 200
1193− getResp <- getIndexSettings testIndex
1194− liftIO $
1195− getResp `shouldBe` Right (IndexSettingsSummary
1196− testIndex
1197− (IndexSettings (ShardCount 1) (ReplicaCount 0))
1198− updates
1199− )
1200−
1201− it "accepts default compression codec" $ when' (atleast es50) $ withTestEnv $ do
1202− _ <- deleteExampleIndex
1203− let updates = [CompressionSetting CompressionDefault]
1204− createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
1205− liftIO $ validateStatus createResp 200
1206− getResp <- getIndexSettings testIndex
1207− liftIO $ getResp `shouldBe` Right
1208− (IndexSettingsSummary testIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) updates)
1209−
1210− it "accepts best compression codec" $ when' (atleast es50) $ withTestEnv $ do
1211− _ <- deleteExampleIndex
1212− let updates = [CompressionSetting CompressionBest]
1213− createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex
1214− liftIO $ validateStatus createResp 200
1215− getResp <- getIndexSettings testIndex
1216− liftIO $ getResp `shouldBe` Right
1217− (IndexSettingsSummary testIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) updates)
1218−
1219−
1220− describe "Index Optimization" $ do
1221− it "returns a successful response upon completion" $ withTestEnv $ do
1222− _ <- createExampleIndex
1223− resp <- forceMergeIndex (IndexList (testIndex :| [])) defaultForceMergeIndexSettings
1224− liftIO $ validateStatus resp 200
1225−
1226− describe "Suggest" $ do
1227− it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do
1228− _ <- insertData
1229− let query = QueryMatchNoneQuery
1230− phraseSuggester = mkPhraseSuggester (FieldName "message")
1231− namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)
1232− search' = mkSearch (Just query) Nothing
1233− search = search' { suggestBody = Just namedSuggester }
1234− expectedText = Just "use haskell"
1235− resp <- searchByIndex testIndex search
1236− parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))
1237− case parsed of
1238− Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)
1239− Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText
1240−
1241− describe "Script" $ do
1242− it "returns a transformed document based on the script field" $ withTestEnv $ do
1243− _ <- insertData
1244− let query = MatchAllQuery Nothing
1245− sfv = toJSON $
1246− Script
1247− (Just (ScriptLanguage "painless"))
1248− (Just (ScriptInline "doc['age'].value * 2"))
1249− Nothing
1250− Nothing
1251− sf = ScriptFields $
1252− HM.fromList [("test1", sfv)]
1253− search' = mkSearch (Just query) Nothing
1254− search = search' { scriptFields = Just sf }
1255− resp <- searchByIndex testIndex search
1256− parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))
1257− case parsed of
1258− Left e ->
1259− liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)
1260− Right sr -> do
1261− let Just results =
1262− hitFields (head (hits (searchHits sr)))
1263− liftIO $ results `shouldBe` (HitFields (M.fromList [("test1", [Number 20000.0])]))
tests/tests.hsnew file+136
@@ -0,0 +1,136 @@
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 Data.Aeson as Aeson
22+import qualified Test.Aggregation as Aggregation
23+import qualified Test.BulkAPI as Bulk
24+import qualified Test.Documents as Documents
25+import qualified Test.Highlights as Highlights
26+import qualified Test.Indices as Indices
27+import qualified Test.JSON as JSON
28+import qualified Test.Query as Query
29+import qualified Test.Script as Script
30+import qualified Test.Snapshots as Snapshots
31+import qualified Test.Sorting as Sorting
32+import qualified Test.SourceFiltering as SourceFiltering
33+import qualified Test.Suggest as Suggest
34+import qualified Test.Templates as Templates
35+
36+main :: IO ()
37+main = hspec $ do
38+ Aggregation.spec
39+ Bulk.spec
40+ Documents.spec
41+ Highlights.spec
42+ Indices.spec
43+ JSON.spec
44+ Query.spec
45+ Script.spec
46+ Snapshots.spec
47+ Sorting.spec
48+ SourceFiltering.spec
49+ Suggest.spec
50+ Templates.spec
51+
52+ describe "error parsing" $ do
53+ it "can parse EsErrors for < 2.0" $ when' (atmost es16) $ withTestEnv $ do
54+ res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
55+ let errorResp = eitherDecode (responseBody res)
56+ liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]"))
57+
58+ it "can parse EsErrors for >= 2.0" $ when' (atleast es20) $ withTestEnv $ do
59+ res <- getDocument (IndexName "bogus") (MappingName "also_bogus") (DocId "bogus_as_well")
60+ let errorResp = eitherDecode (responseBody res)
61+ liftIO (errorResp `shouldBe` Right (EsError 404 "no such index"))
62+
63+ describe "Monoid (SearchHits a)" $
64+ prop "abides the monoid laws" $ eq $
65+ prop_Monoid (T :: T (SearchHits ()))
66+
67+ describe "mkDocVersion" $
68+ prop "can never construct an out of range docVersion" $ \i ->
69+ let res = mkDocVersion i
70+ in case res of
71+ Nothing -> property True
72+ Just dv -> (dv >= minBound) .&&.
73+ (dv <= maxBound) .&&.
74+ docVersionNumber dv === i
75+
76+ describe "getNodesInfo" $
77+ it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
78+ res <- getNodesInfo LocalNode
79+ liftIO $ case res of
80+ -- This is really just a smoke test for response
81+ -- parsing. Node info is so variable, there's not much I can
82+ -- assert here.
83+ Right NodesInfo {..} -> length nodesInfo `shouldBe` 1
84+ Left e -> expectationFailure ("Expected NodesInfo but got " <> show e)
85+
86+ describe "getNodesStats" $
87+ it "fetches the responding node when LocalNode is used" $ withTestEnv $ do
88+ res <- getNodesStats LocalNode
89+ liftIO $ case res of
90+ -- This is really just a smoke test for response
91+ -- parsing. Node stats is so variable, there's not much I can
92+ -- assert here.
93+ Right NodesStats {..} -> length nodesStats `shouldBe` 1
94+ Left e -> expectationFailure ("Expected NodesStats but got " <> show e)
95+
96+ describe "Enum DocVersion" $
97+ it "follows the laws of Enum, Bounded" $ do
98+ evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
99+ evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
100+ evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
101+ evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
102+ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
103+ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
104+ enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
105+
106+ describe "Scan & Scroll API" $
107+ it "returns documents using the scan&scroll API" $ withTestEnv $ do
108+ _ <- insertData
109+ _ <- insertOther
110+ let search =
111+ (mkSearch
112+ (Just $ MatchAllQuery Nothing) Nothing)
113+ { size = Size 1 }
114+ regular_search <- searchTweet search
115+ scan_search' <- scanSearch testIndex testMapping search :: BH IO [Hit Tweet]
116+ let scan_search = map hitSource scan_search'
117+ liftIO $
118+ regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored
119+ liftIO $
120+ 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