git.iko.soy/typeable/bloodhound
on master help sign in
Merge remote-tracking branch 'upstream/master' into boost-in-match-query
commitcc9b285c22ab4388dcb01aeefaa9bd034461f340 authorThomas van Noort <thomas@silk.co> dateWed 12 Aug 2015, 13:40 (11 years ago) parent029a685f185e9d
12 files changed+554−235
compare with master
unifiedsplit
.travis.yml+8−6 README.md+30−18 Setup.hs+4−48 bloodhound.cabal+14−9 changelog.md+19 src/Database/Bloodhound/Client.hs+96−14 src/Database/Bloodhound/Types.hs+218−18 stack.yaml+2−1 tests/doctests.hs+4 tests/doctests.hsc−74 tests/tests.hs+158−46 upload-docs.sh+1−1
.travis.yml+8−6
@@ -7,12 +7,14 @@
77# release of a major GHC version. Setting HPVER implictly sets
88# GHCVER. Omit lines with versions you don't need/want testing for.
99env:
10− - GHCVER=7.6.3 ESVER=1.4.1
11− - GHCVER=7.8.3 ESVER=1.0.3
12− - GHCVER=7.8.3 ESVER=1.1.2
13− - GHCVER=7.8.3 ESVER=1.2.4
14− - GHCVER=7.8.3 ESVER=1.3.6
15− - GHCVER=7.8.3 ESVER=1.4.1
10+ - GHCVER=7.6.3 ESVER=1.6.0
11+ # - GHCVER=7.8.3 ESVER=1.0.3 # Deprecated
12+ # - GHCVER=7.8.3 ESVER=1.1.2 # Deprecated
13+ - GHCVER=7.8.3 ESVER=1.2.4
14+ - GHCVER=7.8.3 ESVER=1.3.6
15+ - GHCVER=7.8.3 ESVER=1.4.1
16+ - GHCVER=7.10.1 ESVER=1.5.2
17+ - GHCVER=7.10.1 ESVER=1.6.0
1618
1719# services:
1820# - elasticsearch
README.md+30−18
@@ -225,7 +225,7 @@ instance FromJSON Location
225225-- λ> encode $ Location 10.0 10.0
226226-- "{\"lat\":10,\"lon\":10}"
227227
228−resp <- withBH' $ indexDocument testIndex testMapping exampleTweet (DocId "1")
228+resp <- withBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")
229229
230230```
231231
@@ -276,23 +276,22 @@ let eitherResult = eitherDecode body :: Either String (EsResult Tweet)
276276Right (EsResult {_index = "twitter"
277277 , _type = "tweet"
278278 , _id = "1"
279− , _version = 2
280− , found = Just True
281− , _source = Tweet {user = "bitemyapp"
282− , postDate = 2009-06-18 00:00:10 UTC
283− , message = "Use haskell!"
284− , age = 10000
285− , location = Location {lat = 40.12, lon = -71.34}}})
279+ , foundResult = Just (EsResultFound { _version = 2
280+ , _source = Tweet {user = "bitemyapp"
281+ , postDate = 2009-06-18 00:00:10 UTC
282+ , message = "Use haskell!"
283+ , age = 10000
284+ , location = Location {lat = 40.12, lon = -71.34}}})})
286285
287−-- _source in EsResult is parametric, we dispatch the type by passing in what we expect (Tweet) as a parameter to EsResult.
286+-- _source in EsResultFound is parametric, we dispatch the type by passing in what we expect (Tweet) as a parameter to EsResult.
288287
289288-- use the _source record accessor to get at your document
290−fmap _source eitherResult
291−Right (Tweet {user = "bitemyapp"
292− , postDate = 2009-06-18 00:00:10 UTC
293− , message = "Use haskell!"
294− , age = 10000
295− , location = Location {lat = 40.12, lon = -71.34}})
289+fmap (fmap _source . foundResult) eitherResult
290+Right (Just (Tweet {user = "bitemyapp"
291+ , postDate = 2009-06-18 00:00:10 UTC
292+ , message = "Use haskell!"
293+ , age = 10000
294+ , location = Location {lat = 40.12, lon = -71.34}}))
296295
297296```
298297
@@ -368,7 +367,7 @@ let encodedOperations = encodeBulkOperations stream
368367
369368-- to insert into a particular server
370369-- bulk :: V.Vector BulkOperation -> IO Reply
371−_ <- withBH' $ bulk stream
370+_ <- withBH' $ bulk streamp
372371
373372```
374373
@@ -383,7 +382,7 @@ Search
383382
384383-- exported by the Client module, just defaults some stuff.
385384-- mkSearch :: Maybe Query -> Maybe Filter -> Search
386−-- mkSearch query filter = Search query filter Nothing False (From 0) (Size 10)
385+-- mkSearch query filter = Search query filter Nothing False (From 0) (Size 10) Nothing
387386
388387let query = TermQuery (Term "user" "bitemyapp") Nothing
389388
@@ -486,9 +485,22 @@ let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
486485-- -> Maybe Sort
487486-- -> TrackSortScores
488487-- -> From -> Size
488+-- -> Maybe [FieldName]
489489
490490-- just add more sortspecs to the list if you want tie-breakers.
491−let search = Search Nothing (Just IdentityFilter) (Just [sortSpec]) False (From 0) (Size 10)
491+let search = Search Nothing (Just IdentityFilter) (Just [sortSpec]) False (From 0) (Size 10) Nothing
492+
493+```
494+
495+### Field selection
496+
497+If you only want certain fields from the source document returned, you can
498+set the "fields" field of the Search record.
499+
500+``` {.haskell}
501+
502+let search' = mkSearch (Just (MatchAllQuery Nothing)) Nothing
503+ search = search' { fields = Just [FieldName "updated"] }
492504
493505```
494506
Setup.hsmode 100644 → 100755+4−48
@@ -1,51 +1,7 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Main (main) where
1+#!/usr/bin/env runhaskell
32
4−import Data.List ( nub )
5−import Data.Version ( showVersion )
6−import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )
7−import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
8−import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
9−import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )
10−import Distribution.Simple.BuildPaths ( autogenModulesDir )
11−import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))
12−import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
13−import Distribution.Text ( display )
14−import Distribution.Verbosity ( Verbosity, normal )
15−import System.FilePath ( (</>) )
3+module Main where
4+import Distribution.Simple
165
176main :: IO ()
18−main = defaultMainWithHooks simpleUserHooks
19− { buildHook = \pkg lbi hooks flags -> do
20− generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
21− buildHook simpleUserHooks pkg lbi hooks flags
22− , postHaddock = \args flags pkg lbi -> do
23− -- copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]
24− postHaddock simpleUserHooks args flags pkg lbi
25− }
26−
27−haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath
28−haddockOutputDir flags pkg = destDir where
29− baseDir = case haddockDistPref flags of
30− NoFlag -> "."
31− Flag x -> x
32− destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)
33−
34−generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
35−generateBuildModule verbosity pkg lbi = do
36− let dir = autogenModulesDir lbi
37− createDirectoryIfMissingVerbose verbosity True dir
38− withLibLBI pkg lbi $ \_ libcfg -> do
39− withTestLBI pkg lbi $ \suite suitecfg -> do
40− rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
41− [ "module Build_" ++ testName suite ++ " where"
42− , "deps :: [String]"
43− , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))
44− ]
45− where
46− formatdeps = map (formatone . snd)
47− formatone p = case packageName p of
48− PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
49−
50−testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
51−testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
7+main = defaultMain
bloodhound.cabal+14−9
@@ -1,5 +1,5 @@
11name: bloodhound
2−version: 0.6.0.0
2+version: 0.7.0.1
33synopsis: ElasticSearch client library for Haskell
44description: ElasticSearch made awesome for Haskell hackers
55homepage: https://github.com/bitemyapp/bloodhound
@@ -16,9 +16,6 @@ source-repository head
1616 type: git
1717 location: https://github.com/bitemyapp/bloodhound.git
1818
19−flag DevelopmentMode
20− Default: False
21−
2219library
2320 ghc-options: -Wall
2421 exposed-modules: Database.Bloodhound
@@ -29,7 +26,7 @@ library
2926 build-depends: base >= 4.3 && <5,
3027 bytestring >= 0.10.0 && <0.11,
3128 containers >= 0.5.0.0 && <0.6,
32− aeson >= 0.7 && <0.9,
29+ aeson >= 0.7 && <0.10,
3330 http-client >= 0.3 && <0.5,
3431 semigroups >= 0.15 && <0.17,
3532 time >= 1.4 && <1.6,
@@ -37,10 +34,12 @@ library
3734 mtl >= 1.0 && <2.3,
3835 transformers >= 0.2 && <0.5,
3936 http-types >= 0.8 && <0.9,
40− vector >= 0.10.9 && <0.11,
37+ vector >= 0.10.9 && <0.12,
4138 uri-bytestring >= 0.1 && <0.2,
4239 exceptions,
43− data-default-class
40+ data-default-class,
41+ blaze-builder,
42+ unordered-containers
4443 default-language: Haskell2010
4544
4645test-suite tests
@@ -50,6 +49,7 @@ test-suite tests
5049 hs-source-dirs: tests
5150 build-depends: base,
5251 bloodhound,
52+ bytestring,
5353 http-client,
5454 http-types,
5555 containers,
@@ -66,15 +66,20 @@ test-suite tests
6666 default-language: Haskell2010
6767
6868test-suite doctests
69+ ghc-options: -threaded -Wall
6970 default-language: Haskell2010
7071 type: exitcode-stdio-1.0
7172 main-is: doctests.hs
72− hs-source-dirs: tests
73+ hs-source-dirs: tests, src
7374 if impl(ghc >= 7.8)
7475 build-depends: base,
7576 directory,
76− doctest,
77+ doctest >= 0.10.1,
7778 doctest-prop,
7879 filepath
7980 else
8081 buildable: False
82+
83+Source-Repository head
84+ Type: git
85+ Location: git://github.com/bitemyapp/bloodhound.git
changelog.md+19
@@ -1,3 +1,22 @@
1+0.7.0.0
2+===================
3+
4+* Added QueryFilter thanks to Bjørn Nordbø!
5+
6+* Support for optimistic concurrency control thanks again to @MichaelXavier!
7+
8+0.6.0.1
9+===================
10+
11+* Allow Aeson 0.9
12+
13+0.6.0.0
14+===================
15+
16+* Moved to BHMonad, thanks to @MichaelXavier! Now there's a reader of config information and IO is lifted.
17+
18+* SearchHits have a Monoid now, makes combining search results nicer, allows for defaulting when a search cannot be performed.
19+
1200.5.0.0
221===================
322
src/Database/Bloodhound/Client.hs+96−14
@@ -27,6 +27,9 @@ module Database.Bloodhound.Client
2727 , indexExists
2828 , openIndex
2929 , closeIndex
30+ , putTemplate
31+ , templateExists
32+ , deleteTemplate
3033 , putMapping
3134 , deleteMapping
3235 , indexDocument
@@ -47,9 +50,14 @@ module Database.Bloodhound.Client
4750 , getStatus
4851 , encodeBulkOperations
4952 , encodeBulkOperation
53+ -- * Reply-handling tools
54+ , isVersionConflict
55+ , isSuccess
56+ , isCreated
5057 )
5158 where
5259
60+import qualified Blaze.ByteString.Builder as BB
5361import Control.Applicative
5462import Control.Monad
5563import Control.Monad.Catch
@@ -58,7 +66,9 @@ import Data.Aeson
5866import Data.ByteString.Lazy.Builder
5967import qualified Data.ByteString.Lazy.Char8 as L
6068import Data.Default.Class
69+import Data.Ix
6170import Data.Maybe (fromMaybe)
71+import Data.Monoid
6272import Data.Text (Text)
6373import qualified Data.Text as T
6474import qualified Data.Text.Encoding as T
@@ -66,6 +76,7 @@ import qualified Data.Vector as V
6676import Network.HTTP.Client
6777import qualified Network.HTTP.Types.Method as NHTM
6878import qualified Network.HTTP.Types.Status as NHTS
79+import qualified Network.HTTP.Types.URI as NHTU
6980import Prelude hiding (filter, head)
7081import URI.ByteString hiding (Query)
7182
@@ -80,7 +91,7 @@ import Database.Bloodhound.Types
8091-- >>> let runBH' = withBH defaultManagerSettings testServer
8192-- >>> let testIndex = IndexName "twitter"
8293-- >>> let testMapping = MappingName "tweet"
83−-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
94+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)
8495-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)
8596-- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping
8697-- >>> import GHC.Generics
@@ -160,6 +171,16 @@ joinPath ps = do
160171 Server s <- bhServer <$> getBHEnv
161172 return $ joinPath' (s:ps)
162173
174+-- | Severely dumbed down query renderer. Assumes your data doesn't
175+-- need any encoding
176+addQuery :: [(Text, Maybe Text)] -> Text -> Text
177+addQuery q u = u <> rendered
178+ where
179+ rendered =
180+ T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q
181+ prependQuestionMark = True
182+
183+
163184bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
164185bindM2 f ma mb = join (f <$> ma <*> mb)
165186
@@ -182,7 +203,7 @@ get = flip (dispatch NHTM.methodGet) Nothing
182203head :: MonadBH m => Text -> m Reply
183204head = flip (dispatch NHTM.methodHead) Nothing
184205put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
185−put = dispatch NHTM.methodPost
206+put = dispatch NHTM.methodPut
186207post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
187208post = dispatch NHTM.methodPost
188209
@@ -283,6 +304,35 @@ openIndex = openOrCloseIndexes OpenIndex
283304closeIndex :: MonadBH m => IndexName -> m Reply
284305closeIndex = openOrCloseIndexes CloseIndex
285306
307+-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.
308+-- Explained in further detail at
309+-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>
310+--
311+-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
312+-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
313+putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply
314+putTemplate indexTemplate (TemplateName templateName) =
315+ bindM2 put url (return body)
316+ where url = joinPath ["_template", templateName]
317+ body = Just $ encode indexTemplate
318+
319+-- | 'templateExists' checks to see if a template exists.
320+--
321+-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")
322+templateExists :: MonadBH m => TemplateName -> m Bool
323+templateExists (TemplateName templateName) = do
324+ (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
325+ return exists
326+
327+-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
328+--
329+-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
330+-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
331+-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")
332+deleteTemplate :: MonadBH m => TemplateName -> m Reply
333+deleteTemplate (TemplateName templateName) =
334+ delete =<< joinPath ["_template", templateName]
335+
286336-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
287337-- for documents in indexes.
288338--
@@ -294,7 +344,9 @@ putMapping :: (MonadBH m, ToJSON a) => IndexName
294344 -> MappingName -> a -> m Reply
295345putMapping (IndexName indexName) (MappingName mappingName) mapping =
296346 bindM2 put url (return body)
297− where url = joinPath [indexName, mappingName, "_mapping"]
347+ where url = joinPath [indexName, "_mapping", mappingName]
348+ -- "_mapping" and mappingName above were originally transposed
349+ -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
298350 body = Just $ encode mapping
299351
300352-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
@@ -308,22 +360,38 @@ putMapping (IndexName indexName) (MappingName mappingName) mapping =
308360deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
309361deleteMapping (IndexName indexName)
310362 (MappingName mappingName) =
311− delete =<< joinPath [indexName, mappingName, "_mapping"]
363+ -- "_mapping" and mappingName below were originally transposed
364+ -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
365+ delete =<< joinPath [indexName, "_mapping", mappingName]
312366
313367-- | 'indexDocument' is the primary way to save a single document in
314368-- Elasticsearch. The document itself is simply something we can
315369-- convert into a JSON 'Value'. The 'DocId' will function as the
316370-- primary key for the document.
317371--
318−-- >>> resp <- runBH' $ indexDocument testIndex testMapping exampleTweet (DocId "1")
372+-- >>> resp <- runBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")
319373-- >>> print resp
320374-- Response {responseStatus = Status {statusCode = 201, statusMessage = "Created"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","74")], responseBody = "{\"_index\":\"twitter\",\"_type\":\"tweet\",\"_id\":\"1\",\"_version\":1,\"created\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}
321375indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
322− -> doc -> DocId -> m Reply
376+ -> IndexDocumentSettings -> doc -> DocId -> m Reply
323377indexDocument (IndexName indexName)
324− (MappingName mappingName) document (DocId docId) =
378+ (MappingName mappingName) cfg document (DocId docId) =
325379 bindM2 put url (return body)
326− where url = joinPath [indexName, mappingName, docId]
380+ where url = addQuery params <$> joinPath [indexName, mappingName, docId]
381+ versionCtlParams = case idsVersionControl cfg of
382+ NoVersionControl -> []
383+ InternalVersion v -> versionParams v "internal"
384+ ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"
385+ ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"
386+ ForceVersion (ExternalDocVersion v) -> versionParams v "force"
387+ vt = T.pack . show . docVersionNumber
388+ versionParams v t = [ ("version", Just $ vt v)
389+ , ("version_type", Just t)
390+ ]
391+ parentParams = case idsParent cfg of
392+ Nothing -> []
393+ Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]
394+ params = versionCtlParams ++ parentParams
327395 body = Just (encode document)
328396
329397-- | 'deleteDocument' is the primary way to delete a single document.
@@ -469,9 +537,9 @@ searchByType (IndexName indexName)
469537--
470538-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
471539-- >>> mkSearch (Just query) Nothing
472−-- 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}
540+-- 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, fields = Nothing}
473541mkSearch :: Maybe Query -> Maybe Filter -> Search
474−mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10)
542+mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) Nothing
475543
476544-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
477545-- the 'Query' and the 'Aggregation'.
@@ -481,7 +549,7 @@ mkSearch query filter = Search query filter Nothing Nothing Nothing False (From
481549-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
482550-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
483551mkAggregateSearch :: Maybe Query -> Aggregations -> Search
484−mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0)
552+mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) Nothing
485553
486554-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
487555-- the 'Query' and the 'Aggregation'.
@@ -490,7 +558,7 @@ mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSear
490558-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
491559-- >>> let search = mkHighlightSearch (Just query) testHighlight
492560mkHighlightSearch :: Maybe Query -> Highlights -> Search
493−mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10)
561+mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) Nothing
494562
495563-- | 'pageSearch' is a helper function that takes a search and assigns the from
496564-- and size fields for the search. The from parameter defines the offset
@@ -500,9 +568,9 @@ mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing
500568-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
501569-- >>> let search = mkSearch (Just query) Nothing
502570-- >>> search
503−-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10}
571+-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, fields = Nothing}
504572-- >>> pageSearch (From 10) (Size 100) search
505−-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100}
573+-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100, fields = Nothing}
506574pageSearch :: From -- ^ The result offset
507575 -> Size -- ^ The number of results to return
508576 -> Search -- ^ The current seach
@@ -536,3 +604,17 @@ setURI req URI{..} = do
536604 Scheme "https" -> True
537605 _ -> False
538606 theQueryString = [(k , Just v) | (k, v) <- queryPairs uriQuery]
607+
608+-- | Was there an optimistic concurrency control conflict when
609+-- indexing a document?
610+isVersionConflict :: Reply -> Bool
611+isVersionConflict = statusCheck (== 409)
612+
613+isSuccess :: Reply -> Bool
614+isSuccess = statusCheck (inRange (200, 299))
615+
616+isCreated :: Reply -> Bool
617+isCreated = statusCheck (== 201)
618+
619+statusCheck :: (Int -> Bool) -> Reply -> Bool
620+statusCheck prd = prd . NHTS.statusCode . responseStatus
src/Database/Bloodhound/Types.hs+218−18
@@ -29,6 +29,7 @@
2929module Database.Bloodhound.Types
3030 ( defaultCache
3131 , defaultIndexSettings
32+ , defaultIndexDocumentSettings
3233 , mkSort
3334 , showText
3435 , unpackId
@@ -41,6 +42,8 @@ module Database.Bloodhound.Types
4142 , mkTermsAggregation
4243 , mkTermsScriptAggregation
4344 , mkDateHistogram
45+ , mkDocVersion
46+ , docVersionNumber
4447 , toTerms
4548 , toDateHistogram
4649 , omitNulls
@@ -53,9 +56,16 @@ module Database.Bloodhound.Types
5356 , Existence(..)
5457 , NullValue(..)
5558 , IndexSettings(..)
59+ , IndexTemplate(..)
5660 , Server(..)
5761 , Reply
5862 , EsResult(..)
63+ , EsResultFound(..)
64+ , DocVersion
65+ , ExternalDocVersion(..)
66+ , VersionControl(..)
67+ , DocumentParent(..)
68+ , IndexDocumentSettings(..)
5969 , Query(..)
6070 , Search(..)
6171 , SearchResult(..)
@@ -93,7 +103,10 @@ module Database.Bloodhound.Types
93103 , RegexpFlags(..)
94104 , RegexpFlag(..)
95105 , FieldName(..)
106+ , Script(..)
96107 , IndexName(..)
108+ , TemplateName(..)
109+ , TemplatePattern(..)
97110 , MappingName(..)
98111 , DocId(..)
99112 , CacheName(..)
@@ -189,6 +202,8 @@ module Database.Bloodhound.Types
189202 , Bucket(..)
190203 , BucketAggregation(..)
191204 , TermsAggregation(..)
205+ , ValueCountAggregation(..)
206+ , FilterAggregation(..)
192207 , DateHistogramAggregation(..)
193208
194209 , Highlights(..)
@@ -215,13 +230,16 @@ import Control.Monad.Writer
215230import Data.Aeson
216231import Data.Aeson.Types (Pair, emptyObject, parseMaybe)
217232import qualified Data.ByteString.Lazy.Char8 as L
218−import Data.List (nub)
233+import Data.List (nub, foldl')
219234import Data.List.NonEmpty (NonEmpty (..), toList)
235+import qualified Data.HashMap.Strict as HM (union)
220236import qualified Data.Map.Strict as M
237+import Data.Maybe
221238import Data.Text (Text)
222239import qualified Data.Text as T
223240import Data.Time.Clock (UTCTime)
224241import qualified Data.Vector as V
242+import GHC.Enum
225243import GHC.Generics (Generic)
226244import Network.HTTP.Client
227245import qualified Network.HTTP.Types.Method as NHTM
@@ -339,6 +357,20 @@ data FieldType = GeoPointType
339357data FieldDefinition =
340358 FieldDefinition { fieldType :: FieldType } deriving (Eq, Show)
341359
360+{-| An 'IndexTemplate' defines a template that will automatically be
361+ applied to new indices created. The templates include both
362+ 'IndexSettings' and mappings, and a simple 'TemplatePattern' that
363+ controls if the template will be applied to the index created.
364+ Specify mappings as follows: @[toJSON TweetMapping, ...]@
365+
366+ https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html
367+-}
368+data IndexTemplate =
369+ IndexTemplate { templatePattern :: TemplatePattern
370+ , templateSettings :: Maybe IndexSettings
371+ , templateMappings :: [Value]
372+ }
373+
342374data MappingField =
343375 MappingField { mappingFieldName :: FieldName
344376 , fieldDefinition :: FieldDefinition } deriving (Eq, Show)
@@ -366,14 +398,95 @@ data BulkOperation =
366398 | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show)
367399
368400{-| 'EsResult' describes the standard wrapper JSON document that you see in
369− successful Elasticsearch responses.
401+ successful Elasticsearch lookups or lookups that couldn't find the document.
370402-}
371403data EsResult a = EsResult { _index :: Text
372404 , _type :: Text
373405 , _id :: Text
374− , _version :: Int
375− , found :: Maybe Bool
376− , _source :: a } deriving (Eq, Show)
406+ , foundResult :: Maybe (EsResultFound a)} deriving (Eq, Show)
407+
408+
409+{-| 'EsResultFound' contains the document and its metadata inside of an
410+ 'EsResult' when the document was successfully found.
411+-}
412+data EsResultFound a = EsResultFound { _version :: DocVersion
413+ , _source :: a } deriving (Eq, Show)
414+
415+
416+
417+{-| 'DocVersion' is an integer version number for a document between 1
418+and 9.2e+18 used for <<https://www.elastic.co/guide/en/elasticsearch/guide/current/optimistic-concurrency-control.html optimistic concurrency control>>.
419+-}
420+newtype DocVersion = DocVersion {
421+ docVersionNumber :: Int
422+ } deriving (Eq, Show, Ord, ToJSON)
423+
424+-- | Smart constructor for in-range doc version
425+mkDocVersion :: Int -> Maybe DocVersion
426+mkDocVersion i
427+ | i >= (docVersionNumber minBound) && i <= (docVersionNumber maxBound) =
428+ Just $ DocVersion i
429+ | otherwise = Nothing
430+
431+
432+{-| 'ExternalDocVersion' is a convenience wrapper if your code uses its
433+own version numbers instead of ones from ES.
434+-}
435+newtype ExternalDocVersion = ExternalDocVersion DocVersion
436+ deriving (Eq, Show, Ord, Bounded, Enum, ToJSON)
437+
438+{-| 'VersionControl' is specified when indexing documents as a
439+optimistic concurrency control.
440+-}
441+data VersionControl = NoVersionControl
442+ -- ^ Don't send a version. This is a pure overwrite.
443+ | InternalVersion DocVersion
444+ -- ^ Use the default ES versioning scheme. Only
445+ -- index the document if the version is the same
446+ -- as the one specified. Only applicable to
447+ -- updates, as you should be getting Version from
448+ -- a search result.
449+ | ExternalGT ExternalDocVersion
450+ -- ^ Use your own version numbering. Only index
451+ -- the document if the version is strictly higher
452+ -- OR the document doesn't exist. The given
453+ -- version will be used as the new version number
454+ -- for the stored document. N.B. All updates must
455+ -- increment this number, meaning there is some
456+ -- global, external ordering of updates.
457+ | ExternalGTE ExternalDocVersion
458+ -- ^ Use your own version numbering. Only index
459+ -- the document if the version is equal or higher
460+ -- than the stored version. Will succeed if there
461+ -- is no existing document. The given version will
462+ -- be used as the new version number for the
463+ -- stored document. Use with care, as this could
464+ -- result in data loss.
465+ | ForceVersion ExternalDocVersion
466+ -- ^ The document will always be indexed and the
467+ -- given version will be the new version. This is
468+ -- typically used for correcting errors. Use with
469+ -- care, as this could result in data loss.
470+ deriving (Show, Eq, Ord)
471+
472+{-| 'DocumentParent' is used to specify a parent document.
473+-}
474+newtype DocumentParent = DocumentParent DocId
475+ deriving (Eq, Show)
476+
477+{-| 'IndexDocumentSettings' are special settings supplied when indexing
478+a document. For the best backwards compatiblity when new fields are
479+added, you should probably prefer to start with 'defaultIndexDocumentSettings'
480+-}
481+data IndexDocumentSettings =
482+ IndexDocumentSettings { idsVersionControl :: VersionControl
483+ , idsParent :: Maybe DocumentParent
484+ } deriving (Eq, Show)
485+
486+{-| Reasonable default settings. Chooses no version control and no parent.
487+-}
488+defaultIndexDocumentSettings :: IndexDocumentSettings
489+defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing
377490
378491{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order
379492 dependent with later sorts acting as tie-breakers for earlier sorts.
@@ -469,6 +582,14 @@ newtype Server = Server Text deriving (Eq, Show)
469582-}
470583newtype IndexName = IndexName Text deriving (Eq, Generic, Show)
471584
585+{-| 'TemplateName' is used to describe which template to query/create/delete
586+-}
587+newtype TemplateName = TemplateName Text deriving (Eq, Show, Generic)
588+
589+{-| 'TemplatePattern' represents a pattern which is matched against index names
590+-}
591+newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, Generic)
592+
472593{-| 'MappingName' is part of mappings which are how ES describes and schematizes
473594 the data in the indices.
474595-}
@@ -489,6 +610,12 @@ newtype QueryString = QueryString Text deriving (Eq, Generic, Show)
489610-}
490611newtype FieldName = FieldName Text deriving (Eq, Show)
491612
613+
614+{-| 'Script' is often used in place of 'FieldName' to specify more
615+complex ways of extracting a value from a document.
616+-}
617+newtype Script = Script { scriptText :: Text } deriving (Eq, Show)
618+
492619{-| 'CacheName' is used in 'RegexpFilter' for describing the
493620 'CacheKey' keyed caching behavior.
494621-}
@@ -604,7 +731,8 @@ data Search = Search { queryBody :: Maybe Query
604731 -- default False
605732 , trackSortScores :: TrackSortScores
606733 , from :: From
607− , size :: Size } deriving (Eq, Show)
734+ , size :: Size
735+ , fields :: Maybe [FieldName] } deriving (Eq, Show)
608736
609737data Highlights = Highlights { globalsettings :: Maybe HighlightSettings
610738 , highlightFields :: [FieldHighlight]
@@ -987,6 +1115,7 @@ data Filter = AndFilter [Filter] Cache
9871115 | LimitFilter Int
9881116 | MissingFilter FieldName Existence NullValue
9891117 | PrefixFilter FieldName PrefixValue Cache
1118+ | QueryFilter Query Cache
9901119 | RangeFilter FieldName RangeValue RangeExecution Cache
9911120 | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey
9921121 | TermFilter Term Cache
@@ -1191,7 +1320,9 @@ data Interval = Year
11911320 | FractionalInterval Float TimeInterval deriving (Eq, Show)
11921321
11931322data Aggregation = TermsAgg TermsAggregation
1194− | DateHistogramAgg DateHistogramAggregation deriving (Eq, Show)
1323+ | DateHistogramAgg DateHistogramAggregation
1324+ | ValueCountAgg ValueCountAggregation
1325+ | FilterAgg FilterAggregation deriving (Eq, Show)
11951326
11961327
11971328data TermsAggregation = TermsAggregation { term :: Either Text Text
@@ -1209,6 +1340,7 @@ data TermsAggregation = TermsAggregation { term :: Either Text Text
12091340data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
12101341 , dateInterval :: Interval
12111342 , dateFormat :: Maybe Text
1343+ -- pre and post deprecated in 1.5
12121344 , datePreZone :: Maybe Text
12131345 , datePostZone :: Maybe Text
12141346 , datePreOffset :: Maybe Text
@@ -1216,6 +1348,13 @@ data DateHistogramAggregation = DateHistogramAggregation { dateField :: Fie
12161348 , dateAggs :: Maybe Aggregations
12171349 } deriving (Eq, Show)
12181350
1351+-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.
1352+data ValueCountAggregation = FieldValueCount FieldName
1353+ | ScriptValueCount Script deriving (Eq, Show)
1354+
1355+-- | 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.
1356+data FilterAggregation = FilterAggregation { faFilter :: Filter
1357+ , faAggs :: Maybe Aggregations} deriving (Eq, Show)
12191358
12201359mkTermsAggregation :: Text -> TermsAggregation
12211360mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
@@ -1289,6 +1428,13 @@ instance ToJSON Aggregation where
12891428 "post_offset" .= postOffset
12901429 ],
12911430 "aggs" .= dateHistoAggs ]
1431+ toJSON (ValueCountAgg a) = object ["value_count" .= v]
1432+ where v = case a of
1433+ (FieldValueCount (FieldName n)) -> object ["field" .= n]
1434+ (ScriptValueCount (Script s)) -> object ["script" .= s]
1435+ toJSON (FilterAgg (FilterAggregation filt ags)) =
1436+ omitNulls [ "filter" .= filt
1437+ , "aggs" .= ags]
12921438
12931439type AggregationResults = M.Map Text Value
12941440
@@ -1428,6 +1574,13 @@ instance ToJSON Filter where
14281574 object [fieldName .= fieldValue
14291575 , "_cache" .= cache]]
14301576
1577+ toJSON (QueryFilter query False) =
1578+ object ["query" .= toJSON query ]
1579+ toJSON (QueryFilter query True) =
1580+ object ["fquery" .=
1581+ object [ "query" .= toJSON query
1582+ , "_cache" .= True ]]
1583+
14311584 toJSON (RangeFilter (FieldName fieldName) rangeValue rangeExecution cache) =
14321585 object ["range" .=
14331586 object [ fieldName .= object (rangeValueToPair rangeValue)
@@ -1869,6 +2022,8 @@ instance ToJSON IgnoreTermFrequency
18692022instance ToJSON MaxQueryTerms
18702023instance ToJSON TypeName
18712024instance ToJSON IndexName
2025+instance ToJSON TemplateName
2026+instance ToJSON TemplatePattern
18722027instance ToJSON BoostTerms
18732028instance ToJSON MaxWordLength
18742029instance ToJSON MinWordLength
@@ -1905,22 +2060,43 @@ instance FromJSON Status where
19052060
19062061
19072062instance ToJSON IndexSettings where
1908− toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]]
1909−
2063+ toJSON (IndexSettings s r) = object ["settings" .=
2064+ object ["index" .=
2065+ object ["number_of_shards" .= s, "number_of_replicas" .= r]
2066+ ]
2067+ ]
2068+
2069+instance ToJSON IndexTemplate where
2070+ toJSON (IndexTemplate p s m) = merge
2071+ (object [ "template" .= p
2072+ , "mappings" .= foldl' merge (object []) m
2073+ ])
2074+ (toJSON s)
2075+ where
2076+ merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2
2077+ merge o Null = o
2078+ merge _ _ = undefined
19102079
19112080instance (FromJSON a) => FromJSON (EsResult a) where
1912− parseJSON (Object v) = EsResult <$>
1913− v .: "_index" <*>
1914− v .: "_type" <*>
1915− v .: "_id" <*>
1916− v .: "_version" <*>
1917− v .:? "found" <*>
1918− v .: "_source"
2081+ parseJSON jsonVal@(Object v) = do
2082+ found <- v .:? "found" .!= False
2083+ fr <- if found
2084+ then parseJSON jsonVal
2085+ else return Nothing
2086+ EsResult <$> v .: "_index" <*>
2087+ v .: "_type" <*>
2088+ v .: "_id" <*>
2089+ pure fr
19192090 parseJSON _ = empty
19202091
2092+instance (FromJSON a) => FromJSON (EsResultFound a) where
2093+ parseJSON (Object v) = EsResultFound <$>
2094+ v .: "_version" <*>
2095+ v .: "_source"
2096+ parseJSON _ = empty
19212097
19222098instance ToJSON Search where
1923− toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize) =
2099+ toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize sFields) =
19242100 omitNulls [ "query" .= query
19252101 , "filter" .= sFilter
19262102 , "sort" .= sort
@@ -1928,7 +2104,8 @@ instance ToJSON Search where
19282104 , "highlight" .= highlight
19292105 , "from" .= sFrom
19302106 , "size" .= sSize
1931− , "track_scores" .= sTrackSortScores]
2107+ , "track_scores" .= sTrackSortScores
2108+ , "fields" .= sFields]
19322109
19332110
19342111instance ToJSON FieldHighlight where
@@ -2174,3 +2351,26 @@ instance FromJSON ShardResult where
21742351 v .: "successful" <*>
21752352 v .: "failed"
21762353 parseJSON _ = empty
2354+
2355+
2356+instance FromJSON DocVersion where
2357+ parseJSON v = do
2358+ i <- parseJSON v
2359+ maybe (fail "DocVersion out of range") return $ mkDocVersion i
2360+
2361+instance Bounded DocVersion where
2362+ minBound = DocVersion 1
2363+ maxBound = DocVersion 9200000000000000000 -- 9.2e+18
2364+
2365+instance Enum DocVersion where
2366+ succ x
2367+ | x /= maxBound = DocVersion (succ $ docVersionNumber x)
2368+ | otherwise = succError "DocVersion"
2369+ pred x
2370+ | x /= minBound = DocVersion (pred $ docVersionNumber x)
2371+ | otherwise = predError "DocVersion"
2372+ toEnum i =
2373+ fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i
2374+ fromEnum = docVersionNumber
2375+ enumFrom = boundedEnumFrom
2376+ enumFromThen = boundedEnumFromThen
stack.yaml+2−1
@@ -2,7 +2,8 @@ flags: {}
22packages:
33- '.'
44extra-deps:
5+- doctest-0.10.1
56- doctest-prop-0.2.0.1
67- quickcheck-properties-0.1
78- uri-bytestring-0.1.2
8−resolver: lts-2.11
9+resolver: lts-2.18
tests/doctests.hsnew file+4
@@ -0,0 +1,4 @@
1+import Test.DocTest
2+
3+main :: IO ()
4+main = doctest ["-i src", "Database.Bloodhound"]
tests/doctests.hscdeleted−74
@@ -1,74 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ForeignFunctionInterface #-}
3−-----------------------------------------------------------------------------
4−-- |
5−-- Module : Main (doctests)
6−-- Copyright : (C) 2014 Chris Allen
7−-- License : BSD-style (see the file LICENSE)
8−-- Maintainer : Chris Allen <cma@bitemyapp.com>
9−-- Stability : provisional
10−-- Portability : portable
11−--
12−-- This module provides doctests for a project based on the actual versions
13−-- of the packages it was built with. It requires a corresponding Setup.lhs
14−-- to be added to the project
15−-----------------------------------------------------------------------------
16−
17−module Main where
18−
19−import Build_doctests (deps)
20−import Control.Applicative
21−import Control.Monad
22−import Data.List
23−import System.Directory
24−import System.FilePath
25−import Test.DocTest
26−
27−##if defined(mingw32_HOST_OS)
28−##if defined(i386_HOST_ARCH)
29−##define USE_CP
30−import Control.Applicative
31−import Control.Exception
32−import Foreign.C.Types
33−foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
34−foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
35−##elif defined(x86_64_HOST_ARCH)
36−##define USE_CP
37−import Control.Applicative
38−import Control.Exception
39−import Foreign.C.Types
40−foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
41−foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
42−##endif
43−##endif
44−
45−-- | Run in a modified codepage where we can print UTF-8 values on Windows.
46−withUnicode :: IO a -> IO a
47−##ifdef USE_CP
48−withUnicode m = do
49− cp <- c_GetConsoleCP
50− (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp
51−##else
52−withUnicode m = m
53−##endif
54−
55−main :: IO ()
56−main = withUnicode $ getSources >>= \sources -> doctest $
57− "-isrc"
58− : "-idist/build/autogen"
59− : "-optP-include"
60− : "-optPdist/build/autogen/cabal_macros.h"
61− : "-hide-all-packages"
62− : map ("-package="++) deps ++ sources
63−
64−getSources :: IO [FilePath]
65−getSources = filter (isSuffixOf ".hs") <$> go "src"
66− where
67− go dir = do
68− (dirs, files) <- getFilesAndDirectories dir
69− (files ++) . concat <$> mapM go dirs
70−
71−getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])
72−getFilesAndDirectories dir = do
73− c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir
74− (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
tests/tests.hs+158−46
@@ -5,6 +5,7 @@
55module Main where
66
77import Control.Applicative
8+import Control.Exception
89import Control.Monad
910import Control.Monad.Reader
1011import Data.Aeson
@@ -13,6 +14,7 @@ import Data.List (nub)
1314import Data.List.NonEmpty (NonEmpty (..))
1415import qualified Data.List.NonEmpty as NE
1516import qualified Data.Map.Strict as M
17+import Data.Monoid
1618import Data.Text (Text)
1719import qualified Data.Text as T
1820import Data.Time.Calendar (Day (..))
@@ -23,9 +25,9 @@ import Database.Bloodhound
2325import GHC.Generics (Generic)
2426import Network.HTTP.Client
2527import qualified Network.HTTP.Types.Status as NHTS
26−import Prelude hiding (filter, putStrLn)
28+import Prelude hiding (filter)
2729import Test.Hspec
28−import Test.QuickCheck.Property.Monoid
30+import Test.QuickCheck.Property.Monoid (prop_Monoid, eq, T(..))
2931
3032import Test.Hspec.QuickCheck (prop)
3133import Test.QuickCheck
@@ -46,7 +48,7 @@ validateStatus resp expected =
4648 `shouldBe` (expected :: Int)
4749
4850createExampleIndex :: BH IO Reply
49−createExampleIndex = createIndex defaultIndexSettings testIndex
51+createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex
5052deleteExampleIndex :: BH IO Reply
5153deleteExampleIndex = deleteIndex testIndex
5254
@@ -120,7 +122,14 @@ instance ToJSON TweetMapping where
120122 toJSON TweetMapping =
121123 object ["tweet" .=
122124 object ["properties" .=
123− object ["location" .= object ["type" .= ("geo_point" :: Text)]]]]
125+ object [ "user" .= object ["type" .= ("string" :: Text)]
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+ ]]]
124133
125134exampleTweet :: Tweet
126135exampleTweet = Tweet { user = "bitemyapp"
@@ -140,32 +149,42 @@ otherTweet = Tweet { user = "notmyapp"
140149 , age = 1000
141150 , location = Location 40.12 (-71.34) }
142151
143−insertData :: BH IO ()
144−insertData = do
152+resetIndex :: BH IO ()
153+resetIndex = do
145154 _ <- deleteExampleIndex
146155 _ <- createExampleIndex
147156 _ <- putMapping testIndex testMapping TweetMapping
148− _ <- indexDocument testIndex testMapping exampleTweet (DocId "1")
149− _ <- refreshIndex testIndex
150157 return ()
151158
159+insertData :: BH IO Reply
160+insertData = do
161+ resetIndex
162+ insertData' defaultIndexDocumentSettings
163+
164+insertData' :: IndexDocumentSettings -> BH IO Reply
165+insertData' ids = do
166+ r <- indexDocument testIndex testMapping ids exampleTweet (DocId "1")
167+ _ <- refreshIndex testIndex
168+ return r
169+
152170insertOther :: BH IO ()
153171insertOther = do
154− _ <- indexDocument testIndex testMapping otherTweet (DocId "2")
172+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")
155173 _ <- refreshIndex testIndex
156174 return ()
157175
158176searchTweet :: Search -> BH IO (Either String Tweet)
159177searchTweet search = do
160− reply <- searchByIndex testIndex search
161− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
178+ result <- searchTweets search
162179 let myTweet = fmap (hitSource . head . hits . searchHits) result
163180 return myTweet
164181
182+searchTweets :: Search -> BH IO (Either String (SearchResult Tweet))
183+searchTweets search = eitherDecode . responseBody <$> searchByIndex testIndex search
184+
165185searchExpectNoResults :: Search -> BH IO ()
166186searchExpectNoResults search = do
167− reply <- searchByIndex testIndex search
168− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
187+ result <- searchTweets search
169188 let emptyHits = fmap (hits . searchHits) result
170189 liftIO $
171190 emptyHits `shouldBe` Right []
@@ -178,7 +197,8 @@ searchExpectAggs search = do
178197 liftIO $
179198 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
180199
181−searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
200+searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>
201+ Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()
182202searchValidBucketAgg search aggKey extractor = do
183203 reply <- searchAll search
184204 let bucketDocs = docCount . head . buckets
@@ -196,8 +216,7 @@ searchTermsAggHint hints = do
196216
197217searchTweetHighlight :: Search -> BH IO (Either String (Maybe HitHighlight))
198218searchTweetHighlight search = do
199− reply <- searchByIndex testIndex search
200− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
219+ result <- searchTweets search
201220 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result
202221 return myHighlight
203222
@@ -260,6 +279,9 @@ instance Arbitrary a => Arbitrary (SearchHits a) where
260279 hs <- arbitrary
261280 return $ SearchHits tot score hs
262281
282+getSource :: EsResult a -> Maybe a
283+getSource = fmap _source . foundResult
284+
263285main :: IO ()
264286main = hspec $ do
265287
@@ -280,8 +302,40 @@ main = hspec $ do
280302 docInserted <- getDocument testIndex testMapping (DocId "1")
281303 let newTweet = eitherDecode
282304 (responseBody docInserted) :: Either String (EsResult Tweet)
283− liftIO $ (fmap _source newTweet `shouldBe` Right exampleTweet)
284−
305+ liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
306+
307+ it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
308+ doc <- getDocument testIndex testMapping (DocId "bogus")
309+ let noTweet = eitherDecode
310+ (responseBody doc) :: Either String (EsResult Tweet)
311+ liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
312+
313+ it "can use optimistic concurrency control" $ withTestEnv $ do
314+ let ev = ExternalDocVersion minBound
315+ let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
316+ resetIndex
317+ res <- insertData' cfg
318+ liftIO $ isCreated res `shouldBe` True
319+ res' <- insertData' cfg
320+ liftIO $ isVersionConflict res' `shouldBe` True
321+
322+ describe "template API" $ do
323+ it "can create a template" $ withTestEnv $ do
324+ let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
325+ resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
326+ liftIO $ validateStatus resp 200
327+
328+ it "can detect if a template exists" $ withTestEnv $ do
329+ exists <- templateExists (TemplateName "tweet-tpl")
330+ liftIO $ exists `shouldBe` True
331+
332+ it "can delete a template" $ withTestEnv $ do
333+ resp <- deleteTemplate (TemplateName "tweet-tpl")
334+ liftIO $ validateStatus resp 200
335+
336+ it "can detect if a template doesn't exist" $ withTestEnv $ do
337+ exists <- templateExists (TemplateName "tweet-tpl")
338+ liftIO $ exists `shouldBe` False
285339
286340 describe "bulk API" $ do
287341 it "inserts all documents we request" $ withTestEnv $ do
@@ -300,8 +354,8 @@ main = hspec $ do
300354 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
301355 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
302356 liftIO $ do
303− fmap _source maybeFirst `shouldBe` Right firstTest
304− fmap _source maybeSecond `shouldBe` Right secondTest
357+ fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
358+ fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
305359
306360
307361 describe "query API" $ do
@@ -333,8 +387,8 @@ main = hspec $ do
333387
334388 it "returns document for multi-match query" $ withTestEnv $ do
335389 _ <- insertData
336− let fields = [FieldName "user", FieldName "message"]
337− let query = QueryMultiMatchQuery $ mkMultiMatchQuery fields (QueryString "bitemyapp")
390+ let flds = [FieldName "user", FieldName "message"]
391+ let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
338392 let search = mkSearch (Just query) Nothing
339393 myTweet <- searchTweet search
340394 liftIO $
@@ -381,9 +435,8 @@ main = hspec $ do
381435 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
382436 let search = Search Nothing
383437 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
384− False (From 0) (Size 10)
385− reply <- searchByIndex testIndex search
386− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
438+ False (From 0) (Size 10) Nothing
439+ result <- searchTweets search
387440 let myTweet = fmap (hitSource . head . hits . searchHits) result
388441 liftIO $
389442 myTweet `shouldBe` Right otherTweet
@@ -506,8 +559,8 @@ main = hspec $ do
506559 let filter = RangeFilter (FieldName "postDate")
507560 (RangeDateGtLt
508561 (GreaterThanD (UTCTime
509− (ModifiedJulianDay 55000)
510− (secondsToDiffTime 9)))
562+ (ModifiedJulianDay 54000)
563+ (secondsToDiffTime 0)))
511564 (LessThanD (UTCTime
512565 (ModifiedJulianDay 55000)
513566 (secondsToDiffTime 11))))
@@ -517,7 +570,6 @@ main = hspec $ do
517570 liftIO $
518571 myTweet `shouldBe` Right exampleTweet
519572
520−
521573 it "returns document for regexp filter" $ withTestEnv $ do
522574 _ <- insertData
523575 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
@@ -535,6 +587,20 @@ main = hspec $ do
535587 let search = mkSearch Nothing (Just filter)
536588 searchExpectNoResults search
537589
590+ it "returns document for query filter, uncached" $ withTestEnv $ do
591+ _ <- insertData
592+ let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) True
593+ search = mkSearch Nothing (Just filter)
594+ myTweet <- searchTweet search
595+ liftIO $ myTweet `shouldBe` Right exampleTweet
596+
597+ it "returns document for query filter, cached" $ withTestEnv $ do
598+ _ <- insertData
599+ let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) False
600+ search = mkSearch Nothing (Just filter)
601+ myTweet <- searchTweet search
602+ liftIO $ myTweet `shouldBe` Right exampleTweet
603+
538604 describe "Aggregation API" $ do
539605 it "returns term aggregation results" $ withTestEnv $ do
540606 _ <- insertData
@@ -550,36 +616,63 @@ main = hspec $ do
550616 searchExpectAggs search
551617 searchValidBucketAgg search "users" toTerms
552618
553− it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
619+ it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
554620 _ <- insertData
555621 searchTermsAggHint [Map, Ordinals]
556622
557− it "can give execution hint paramters to term aggregations" $ when' (is es12) $ withTestEnv $ do
623+ it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
558624 _ <- insertData
559625 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
560626
561− it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
627+ it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
562628 _ <- insertData
563629 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
564630
565− it "returns date histogram aggregation results" $ withTestEnv $ do
631+
632+ it "can execute value_count aggregations" $ withTestEnv $ do
566633 _ <- insertData
567− let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
568− let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
569− searchExpectAggs search
570− searchValidBucketAgg search "byDate" toDateHistogram
634+ _ <- insertOther
635+ let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
636+ mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
637+ let search = mkAggregateSearch Nothing ags
638+ let docCountPair k n = (k, object ["value" .= Number n])
639+ res <- searchTweets search
640+ liftIO $
641+ fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
642+ , docCountPair "bogus_count" 0
643+ ]))
571644
572− it "returns date histogram using fractional date" $ withTestEnv $ do
645+ it "can execute filter aggregations" $ withTestEnv $ do
573646 _ <- insertData
574− let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
575− let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
576− let intervals = periods ++ fractionals
577− let histogram = mkDateHistogram (FieldName "postDate")
578− let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
579− let expect interval = searchExpectAggs (search interval)
580− let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
581− forM_ intervals expect
582− forM_ intervals valid
647+ _ <- insertOther
648+ let ags = mkAggregations "bitemyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "bitemyapp") defaultCache) Nothing)) <>
649+ mkAggregations "notmyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "notmyapp") defaultCache) Nothing))
650+ let search = mkAggregateSearch Nothing ags
651+ let docCountPair k n = (k, object ["doc_count" .= Number n])
652+ res <- searchTweets search
653+ liftIO $
654+ fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1
655+ , docCountPair "notmyapps" 1
656+ ]))
657+ -- Interaction of date serialization and date histogram aggregation is broken.
658+ -- it "returns date histogram aggregation results" $ withTestEnv $ do
659+ -- _ <- insertData
660+ -- let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
661+ -- let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
662+ -- searchExpectAggs search
663+ -- searchValidBucketAgg search "byDate" toDateHistogram
664+
665+ -- it "returns date histogram using fractional date" $ withTestEnv $ do
666+ -- _ <- insertData
667+ -- let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
668+ -- let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
669+ -- let intervals = periods ++ fractionals
670+ -- let histogram = mkDateHistogram (FieldName "postDate")
671+ -- let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
672+ -- let expect interval = searchExpectAggs (search interval)
673+ -- let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
674+ -- forM_ intervals expect
675+ -- forM_ intervals valid
583676
584677 describe "Highlights API" $ do
585678
@@ -650,3 +743,22 @@ main = hspec $ do
650743 describe "Monoid (SearchHits a)" $ do
651744 prop "abides the monoid laws" $ eq $
652745 prop_Monoid (T :: T (SearchHits ()))
746+
747+ describe "mkDocVersion" $ do
748+ prop "can never construct an out of range docVersion" $ \i ->
749+ let res = mkDocVersion i
750+ in case res of
751+ Nothing -> property True
752+ Just dv -> (dv >= minBound) .&&.
753+ (dv <= maxBound) .&&.
754+ docVersionNumber dv === i
755+
756+ describe "Enum DocVersion" $ do
757+ it "follows the laws of Enum, Bounded" $ do
758+ evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
759+ evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
760+ evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
761+ evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
762+ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
763+ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
764+ enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]
upload-docs.sh+1−1
@@ -10,7 +10,7 @@ if [ ! -f "$cabal_file" ]; then
1010fi
1111
1212pkg=bloodhound
13−ver=0.6.0.0
13+ver=0.7.0.1
1414
1515if [ -z "$pkg" ]; then
1616 echo "Unable to determine package name"