git.iko.soy/typeable/bloodhound
on master help sign in
Merge remote-tracking branch 'upstream/master' into source-in-search

Conflicts: src/Database/Bloodhound/Client.hs src/Database/Bloodhound/Types.hs tests/tests.hs

commitf615ac26c229870582d3266c655e16066dcaf471 authorThomas van Noort <thomas@silk.co> dateWed 12 Aug 2015, 11:21 (11 years ago) parent023f521f185e9d
12 files changed+552−233
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+216−16 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, source = Nothing}
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, source = Nothing}
473541mkSearch :: Maybe Query -> Maybe Filter -> Search
474−mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) Nothing
542+mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) Nothing 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) Nothing
552+mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) Nothing 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) Nothing
561+mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) Nothing 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, source = Nothing}
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, source = 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, source = Nothing}
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, source = 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+216−16
@@ -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(..)
@@ -98,7 +108,10 @@ module Database.Bloodhound.Types
98108 , RegexpFlags(..)
99109 , RegexpFlag(..)
100110 , FieldName(..)
111+ , Script(..)
101112 , IndexName(..)
113+ , TemplateName(..)
114+ , TemplatePattern(..)
102115 , MappingName(..)
103116 , DocId(..)
104117 , CacheName(..)
@@ -194,6 +207,8 @@ module Database.Bloodhound.Types
194207 , Bucket(..)
195208 , BucketAggregation(..)
196209 , TermsAggregation(..)
210+ , ValueCountAggregation(..)
211+ , FilterAggregation(..)
197212 , DateHistogramAggregation(..)
198213
199214 , Highlights(..)
@@ -220,13 +235,16 @@ import Control.Monad.Writer
220235import Data.Aeson
221236import Data.Aeson.Types (Pair, emptyObject, parseMaybe)
222237import qualified Data.ByteString.Lazy.Char8 as L
223−import Data.List (nub)
238+import Data.List (nub, foldl')
224239import Data.List.NonEmpty (NonEmpty (..), toList)
240+import qualified Data.HashMap.Strict as HM (union)
225241import qualified Data.Map.Strict as M
242+import Data.Maybe
226243import Data.Text (Text)
227244import qualified Data.Text as T
228245import Data.Time.Clock (UTCTime)
229246import qualified Data.Vector as V
247+import GHC.Enum
230248import GHC.Generics (Generic)
231249import Network.HTTP.Client
232250import qualified Network.HTTP.Types.Method as NHTM
@@ -344,6 +362,20 @@ data FieldType = GeoPointType
344362data FieldDefinition =
345363 FieldDefinition { fieldType :: FieldType } deriving (Eq, Show)
346364
365+{-| An 'IndexTemplate' defines a template that will automatically be
366+ applied to new indices created. The templates include both
367+ 'IndexSettings' and mappings, and a simple 'TemplatePattern' that
368+ controls if the template will be applied to the index created.
369+ Specify mappings as follows: @[toJSON TweetMapping, ...]@
370+
371+ https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html
372+-}
373+data IndexTemplate =
374+ IndexTemplate { templatePattern :: TemplatePattern
375+ , templateSettings :: Maybe IndexSettings
376+ , templateMappings :: [Value]
377+ }
378+
347379data MappingField =
348380 MappingField { mappingFieldName :: FieldName
349381 , fieldDefinition :: FieldDefinition } deriving (Eq, Show)
@@ -371,14 +403,95 @@ data BulkOperation =
371403 | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show)
372404
373405{-| 'EsResult' describes the standard wrapper JSON document that you see in
374− successful Elasticsearch responses.
406+ successful Elasticsearch lookups or lookups that couldn't find the document.
375407-}
376408data EsResult a = EsResult { _index :: Text
377409 , _type :: Text
378410 , _id :: Text
379− , _version :: Int
380− , found :: Maybe Bool
381− , _source :: a } deriving (Eq, Show)
411+ , foundResult :: Maybe (EsResultFound a)} deriving (Eq, Show)
412+
413+
414+{-| 'EsResultFound' contains the document and its metadata inside of an
415+ 'EsResult' when the document was successfully found.
416+-}
417+data EsResultFound a = EsResultFound { _version :: DocVersion
418+ , _source :: a } deriving (Eq, Show)
419+
420+
421+
422+{-| 'DocVersion' is an integer version number for a document between 1
423+and 9.2e+18 used for <<https://www.elastic.co/guide/en/elasticsearch/guide/current/optimistic-concurrency-control.html optimistic concurrency control>>.
424+-}
425+newtype DocVersion = DocVersion {
426+ docVersionNumber :: Int
427+ } deriving (Eq, Show, Ord, ToJSON)
428+
429+-- | Smart constructor for in-range doc version
430+mkDocVersion :: Int -> Maybe DocVersion
431+mkDocVersion i
432+ | i >= (docVersionNumber minBound) && i <= (docVersionNumber maxBound) =
433+ Just $ DocVersion i
434+ | otherwise = Nothing
435+
436+
437+{-| 'ExternalDocVersion' is a convenience wrapper if your code uses its
438+own version numbers instead of ones from ES.
439+-}
440+newtype ExternalDocVersion = ExternalDocVersion DocVersion
441+ deriving (Eq, Show, Ord, Bounded, Enum, ToJSON)
442+
443+{-| 'VersionControl' is specified when indexing documents as a
444+optimistic concurrency control.
445+-}
446+data VersionControl = NoVersionControl
447+ -- ^ Don't send a version. This is a pure overwrite.
448+ | InternalVersion DocVersion
449+ -- ^ Use the default ES versioning scheme. Only
450+ -- index the document if the version is the same
451+ -- as the one specified. Only applicable to
452+ -- updates, as you should be getting Version from
453+ -- a search result.
454+ | ExternalGT ExternalDocVersion
455+ -- ^ Use your own version numbering. Only index
456+ -- the document if the version is strictly higher
457+ -- OR the document doesn't exist. The given
458+ -- version will be used as the new version number
459+ -- for the stored document. N.B. All updates must
460+ -- increment this number, meaning there is some
461+ -- global, external ordering of updates.
462+ | ExternalGTE ExternalDocVersion
463+ -- ^ Use your own version numbering. Only index
464+ -- the document if the version is equal or higher
465+ -- than the stored version. Will succeed if there
466+ -- is no existing document. The given version will
467+ -- be used as the new version number for the
468+ -- stored document. Use with care, as this could
469+ -- result in data loss.
470+ | ForceVersion ExternalDocVersion
471+ -- ^ The document will always be indexed and the
472+ -- given version will be the new version. This is
473+ -- typically used for correcting errors. Use with
474+ -- care, as this could result in data loss.
475+ deriving (Show, Eq, Ord)
476+
477+{-| 'DocumentParent' is used to specify a parent document.
478+-}
479+newtype DocumentParent = DocumentParent DocId
480+ deriving (Eq, Show)
481+
482+{-| 'IndexDocumentSettings' are special settings supplied when indexing
483+a document. For the best backwards compatiblity when new fields are
484+added, you should probably prefer to start with 'defaultIndexDocumentSettings'
485+-}
486+data IndexDocumentSettings =
487+ IndexDocumentSettings { idsVersionControl :: VersionControl
488+ , idsParent :: Maybe DocumentParent
489+ } deriving (Eq, Show)
490+
491+{-| Reasonable default settings. Chooses no version control and no parent.
492+-}
493+defaultIndexDocumentSettings :: IndexDocumentSettings
494+defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing
382495
383496{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order
384497 dependent with later sorts acting as tie-breakers for earlier sorts.
@@ -474,6 +587,14 @@ newtype Server = Server Text deriving (Eq, Show)
474587-}
475588newtype IndexName = IndexName Text deriving (Eq, Generic, Show)
476589
590+{-| 'TemplateName' is used to describe which template to query/create/delete
591+-}
592+newtype TemplateName = TemplateName Text deriving (Eq, Show, Generic)
593+
594+{-| 'TemplatePattern' represents a pattern which is matched against index names
595+-}
596+newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, Generic)
597+
477598{-| 'MappingName' is part of mappings which are how ES describes and schematizes
478599 the data in the indices.
479600-}
@@ -494,6 +615,12 @@ newtype QueryString = QueryString Text deriving (Eq, Generic, Show)
494615-}
495616newtype FieldName = FieldName Text deriving (Eq, Show)
496617
618+
619+{-| 'Script' is often used in place of 'FieldName' to specify more
620+complex ways of extracting a value from a document.
621+-}
622+newtype Script = Script { scriptText :: Text } deriving (Eq, Show)
623+
497624{-| 'CacheName' is used in 'RegexpFilter' for describing the
498625 'CacheKey' keyed caching behavior.
499626-}
@@ -610,6 +737,7 @@ data Search = Search { queryBody :: Maybe Query
610737 , trackSortScores :: TrackSortScores
611738 , from :: From
612739 , size :: Size
740+ , fields :: Maybe [FieldName]
613741 , source :: Maybe Source } deriving (Eq, Show)
614742
615743data Source =
@@ -1006,6 +1134,7 @@ data Filter = AndFilter [Filter] Cache
10061134 | LimitFilter Int
10071135 | MissingFilter FieldName Existence NullValue
10081136 | PrefixFilter FieldName PrefixValue Cache
1137+ | QueryFilter Query Cache
10091138 | RangeFilter FieldName RangeValue RangeExecution Cache
10101139 | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey
10111140 | TermFilter Term Cache
@@ -1210,7 +1339,9 @@ data Interval = Year
12101339 | FractionalInterval Float TimeInterval deriving (Eq, Show)
12111340
12121341data Aggregation = TermsAgg TermsAggregation
1213− | DateHistogramAgg DateHistogramAggregation deriving (Eq, Show)
1342+ | DateHistogramAgg DateHistogramAggregation
1343+ | ValueCountAgg ValueCountAggregation
1344+ | FilterAgg FilterAggregation deriving (Eq, Show)
12141345
12151346
12161347data TermsAggregation = TermsAggregation { term :: Either Text Text
@@ -1228,6 +1359,7 @@ data TermsAggregation = TermsAggregation { term :: Either Text Text
12281359data DateHistogramAggregation = DateHistogramAggregation { dateField :: FieldName
12291360 , dateInterval :: Interval
12301361 , dateFormat :: Maybe Text
1362+ -- pre and post deprecated in 1.5
12311363 , datePreZone :: Maybe Text
12321364 , datePostZone :: Maybe Text
12331365 , datePreOffset :: Maybe Text
@@ -1235,6 +1367,13 @@ data DateHistogramAggregation = DateHistogramAggregation { dateField :: Fie
12351367 , dateAggs :: Maybe Aggregations
12361368 } deriving (Eq, Show)
12371369
1370+-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.
1371+data ValueCountAggregation = FieldValueCount FieldName
1372+ | ScriptValueCount Script deriving (Eq, Show)
1373+
1374+-- | 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.
1375+data FilterAggregation = FilterAggregation { faFilter :: Filter
1376+ , faAggs :: Maybe Aggregations} deriving (Eq, Show)
12381377
12391378mkTermsAggregation :: Text -> TermsAggregation
12401379mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
@@ -1308,6 +1447,13 @@ instance ToJSON Aggregation where
13081447 "post_offset" .= postOffset
13091448 ],
13101449 "aggs" .= dateHistoAggs ]
1450+ toJSON (ValueCountAgg a) = object ["value_count" .= v]
1451+ where v = case a of
1452+ (FieldValueCount (FieldName n)) -> object ["field" .= n]
1453+ (ScriptValueCount (Script s)) -> object ["script" .= s]
1454+ toJSON (FilterAgg (FilterAggregation filt ags)) =
1455+ omitNulls [ "filter" .= filt
1456+ , "aggs" .= ags]
13111457
13121458type AggregationResults = M.Map Text Value
13131459
@@ -1447,6 +1593,13 @@ instance ToJSON Filter where
14471593 object [fieldName .= fieldValue
14481594 , "_cache" .= cache]]
14491595
1596+ toJSON (QueryFilter query False) =
1597+ object ["query" .= toJSON query ]
1598+ toJSON (QueryFilter query True) =
1599+ object ["fquery" .=
1600+ object [ "query" .= toJSON query
1601+ , "_cache" .= True ]]
1602+
14501603 toJSON (RangeFilter (FieldName fieldName) rangeValue rangeExecution cache) =
14511604 object ["range" .=
14521605 object [ fieldName .= object (rangeValueToPair rangeValue)
@@ -1887,6 +2040,8 @@ instance ToJSON IgnoreTermFrequency
18872040instance ToJSON MaxQueryTerms
18882041instance ToJSON TypeName
18892042instance ToJSON IndexName
2043+instance ToJSON TemplateName
2044+instance ToJSON TemplatePattern
18902045instance ToJSON BoostTerms
18912046instance ToJSON MaxWordLength
18922047instance ToJSON MinWordLength
@@ -1923,22 +2078,43 @@ instance FromJSON Status where
19232078
19242079
19252080instance ToJSON IndexSettings where
1926− toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]]
1927−
2081+ toJSON (IndexSettings s r) = object ["settings" .=
2082+ object ["index" .=
2083+ object ["number_of_shards" .= s, "number_of_replicas" .= r]
2084+ ]
2085+ ]
2086+
2087+instance ToJSON IndexTemplate where
2088+ toJSON (IndexTemplate p s m) = merge
2089+ (object [ "template" .= p
2090+ , "mappings" .= foldl' merge (object []) m
2091+ ])
2092+ (toJSON s)
2093+ where
2094+ merge (Object o1) (Object o2) = toJSON $ HM.union o1 o2
2095+ merge o Null = o
2096+ merge _ _ = undefined
19282097
19292098instance (FromJSON a) => FromJSON (EsResult a) where
1930− parseJSON (Object v) = EsResult <$>
1931− v .: "_index" <*>
1932− v .: "_type" <*>
1933− v .: "_id" <*>
1934− v .: "_version" <*>
1935− v .:? "found" <*>
1936− v .: "_source"
2099+ parseJSON jsonVal@(Object v) = do
2100+ found <- v .:? "found" .!= False
2101+ fr <- if found
2102+ then parseJSON jsonVal
2103+ else return Nothing
2104+ EsResult <$> v .: "_index" <*>
2105+ v .: "_type" <*>
2106+ v .: "_id" <*>
2107+ pure fr
19372108 parseJSON _ = empty
19382109
2110+instance (FromJSON a) => FromJSON (EsResultFound a) where
2111+ parseJSON (Object v) = EsResultFound <$>
2112+ v .: "_version" <*>
2113+ v .: "_source"
2114+ parseJSON _ = empty
19392115
19402116instance ToJSON Search where
1941− toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize sSource) =
2117+ toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize sFields sSource) =
19422118 omitNulls [ "query" .= query
19432119 , "filter" .= sFilter
19442120 , "sort" .= sort
@@ -1947,6 +2123,7 @@ instance ToJSON Search where
19472123 , "from" .= sFrom
19482124 , "size" .= sSize
19492125 , "track_scores" .= sTrackSortScores
2126+ , "fields" .= sFields
19502127 , "_source" .= sSource]
19512128
19522129
@@ -2212,3 +2389,26 @@ instance FromJSON ShardResult where
22122389 v .: "successful" <*>
22132390 v .: "failed"
22142391 parseJSON _ = empty
2392+
2393+
2394+instance FromJSON DocVersion where
2395+ parseJSON v = do
2396+ i <- parseJSON v
2397+ maybe (fail "DocVersion out of range") return $ mkDocVersion i
2398+
2399+instance Bounded DocVersion where
2400+ minBound = DocVersion 1
2401+ maxBound = DocVersion 9200000000000000000 -- 9.2e+18
2402+
2403+instance Enum DocVersion where
2404+ succ x
2405+ | x /= maxBound = DocVersion (succ $ docVersionNumber x)
2406+ | otherwise = succError "DocVersion"
2407+ pred x
2408+ | x /= minBound = DocVersion (pred $ docVersionNumber x)
2409+ | otherwise = predError "DocVersion"
2410+ toEnum i =
2411+ fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i
2412+ fromEnum = docVersionNumber
2413+ enumFrom = boundedEnumFrom
2414+ 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
@@ -271,6 +290,9 @@ instance Arbitrary a => Arbitrary (SearchHits a) where
271290 hs <- arbitrary
272291 return $ SearchHits tot score hs
273292
293+getSource :: EsResult a -> Maybe a
294+getSource = fmap _source . foundResult
295+
274296main :: IO ()
275297main = hspec $ do
276298
@@ -291,8 +313,40 @@ main = hspec $ do
291313 docInserted <- getDocument testIndex testMapping (DocId "1")
292314 let newTweet = eitherDecode
293315 (responseBody docInserted) :: Either String (EsResult Tweet)
294− liftIO $ (fmap _source newTweet `shouldBe` Right exampleTweet)
295−
316+ liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet))
317+
318+ it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do
319+ doc <- getDocument testIndex testMapping (DocId "bogus")
320+ let noTweet = eitherDecode
321+ (responseBody doc) :: Either String (EsResult Tweet)
322+ liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing
323+
324+ it "can use optimistic concurrency control" $ withTestEnv $ do
325+ let ev = ExternalDocVersion minBound
326+ let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }
327+ resetIndex
328+ res <- insertData' cfg
329+ liftIO $ isCreated res `shouldBe` True
330+ res' <- insertData' cfg
331+ liftIO $ isVersionConflict res' `shouldBe` True
332+
333+ describe "template API" $ do
334+ it "can create a template" $ withTestEnv $ do
335+ let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
336+ resp <- putTemplate idxTpl (TemplateName "tweet-tpl")
337+ liftIO $ validateStatus resp 200
338+
339+ it "can detect if a template exists" $ withTestEnv $ do
340+ exists <- templateExists (TemplateName "tweet-tpl")
341+ liftIO $ exists `shouldBe` True
342+
343+ it "can delete a template" $ withTestEnv $ do
344+ resp <- deleteTemplate (TemplateName "tweet-tpl")
345+ liftIO $ validateStatus resp 200
346+
347+ it "can detect if a template doesn't exist" $ withTestEnv $ do
348+ exists <- templateExists (TemplateName "tweet-tpl")
349+ liftIO $ exists `shouldBe` False
296350
297351 describe "bulk API" $ do
298352 it "inserts all documents we request" $ withTestEnv $ do
@@ -311,8 +365,8 @@ main = hspec $ do
311365 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)
312366 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)
313367 liftIO $ do
314− fmap _source maybeFirst `shouldBe` Right firstTest
315− fmap _source maybeSecond `shouldBe` Right secondTest
368+ fmap getSource maybeFirst `shouldBe` Right (Just firstTest)
369+ fmap getSource maybeSecond `shouldBe` Right (Just secondTest)
316370
317371
318372 describe "query API" $ do
@@ -344,8 +398,8 @@ main = hspec $ do
344398
345399 it "returns document for multi-match query" $ withTestEnv $ do
346400 _ <- insertData
347− let fields = [FieldName "user", FieldName "message"]
348− let query = QueryMultiMatchQuery $ mkMultiMatchQuery fields (QueryString "bitemyapp")
401+ let flds = [FieldName "user", FieldName "message"]
402+ let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")
349403 let search = mkSearch (Just query) Nothing
350404 myTweet <- searchTweet search
351405 liftIO $
@@ -392,9 +446,8 @@ main = hspec $ do
392446 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending
393447 let search = Search Nothing
394448 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing
395− False (From 0) (Size 10) Nothing
396− reply <- searchByIndex testIndex search
397− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
449+ False (From 0) (Size 10) Nothing Nothing
450+ result <- searchTweets search
398451 let myTweet = fmap (hitSource . head . hits . searchHits) result
399452 liftIO $
400453 myTweet `shouldBe` Right otherTweet
@@ -517,8 +570,8 @@ main = hspec $ do
517570 let filter = RangeFilter (FieldName "postDate")
518571 (RangeDateGtLt
519572 (GreaterThanD (UTCTime
520− (ModifiedJulianDay 55000)
521− (secondsToDiffTime 9)))
573+ (ModifiedJulianDay 54000)
574+ (secondsToDiffTime 0)))
522575 (LessThanD (UTCTime
523576 (ModifiedJulianDay 55000)
524577 (secondsToDiffTime 11))))
@@ -528,7 +581,6 @@ main = hspec $ do
528581 liftIO $
529582 myTweet `shouldBe` Right exampleTweet
530583
531−
532584 it "returns document for regexp filter" $ withTestEnv $ do
533585 _ <- insertData
534586 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")
@@ -546,6 +598,20 @@ main = hspec $ do
546598 let search = mkSearch Nothing (Just filter)
547599 searchExpectNoResults search
548600
601+ it "returns document for query filter, uncached" $ withTestEnv $ do
602+ _ <- insertData
603+ let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) True
604+ search = mkSearch Nothing (Just filter)
605+ myTweet <- searchTweet search
606+ liftIO $ myTweet `shouldBe` Right exampleTweet
607+
608+ it "returns document for query filter, cached" $ withTestEnv $ do
609+ _ <- insertData
610+ let filter = QueryFilter (TermQuery (Term "user" "bitemyapp") Nothing) False
611+ search = mkSearch Nothing (Just filter)
612+ myTweet <- searchTweet search
613+ liftIO $ myTweet `shouldBe` Right exampleTweet
614+
549615 describe "Aggregation API" $ do
550616 it "returns term aggregation results" $ withTestEnv $ do
551617 _ <- insertData
@@ -561,36 +627,63 @@ main = hspec $ do
561627 searchExpectAggs search
562628 searchValidBucketAgg search "users" toTerms
563629
564− it "can give execution hint paramters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
630+ it "can give execution hint parameters to term aggregations" $ when' (atmost es11) $ withTestEnv $ do
565631 _ <- insertData
566632 searchTermsAggHint [Map, Ordinals]
567633
568− it "can give execution hint paramters to term aggregations" $ when' (is es12) $ withTestEnv $ do
634+ it "can give execution hint parameters to term aggregations" $ when' (is es12) $ withTestEnv $ do
569635 _ <- insertData
570636 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map, Ordinals]
571637
572− it "can give execution hint paramters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
638+ it "can give execution hint parameters to term aggregations" $ when' (atleast es12) $ withTestEnv $ do
573639 _ <- insertData
574640 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]
575641
576− it "returns date histogram aggregation results" $ withTestEnv $ do
642+
643+ it "can execute value_count aggregations" $ withTestEnv $ do
577644 _ <- insertData
578− let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
579− let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
580− searchExpectAggs search
581− searchValidBucketAgg search "byDate" toDateHistogram
645+ _ <- insertOther
646+ let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>
647+ mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))
648+ let search = mkAggregateSearch Nothing ags
649+ let docCountPair k n = (k, object ["value" .= Number n])
650+ res <- searchTweets search
651+ liftIO $
652+ fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2
653+ , docCountPair "bogus_count" 0
654+ ]))
582655
583− it "returns date histogram using fractional date" $ withTestEnv $ do
656+ it "can execute filter aggregations" $ withTestEnv $ do
584657 _ <- insertData
585− let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
586− let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
587− let intervals = periods ++ fractionals
588− let histogram = mkDateHistogram (FieldName "postDate")
589− let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
590− let expect interval = searchExpectAggs (search interval)
591− let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
592− forM_ intervals expect
593− forM_ intervals valid
658+ _ <- insertOther
659+ let ags = mkAggregations "bitemyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "bitemyapp") defaultCache) Nothing)) <>
660+ mkAggregations "notmyapps" (FilterAgg (FilterAggregation (TermFilter (Term "user" "notmyapp") defaultCache) Nothing))
661+ let search = mkAggregateSearch Nothing ags
662+ let docCountPair k n = (k, object ["doc_count" .= Number n])
663+ res <- searchTweets search
664+ liftIO $
665+ fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "bitemyapps" 1
666+ , docCountPair "notmyapps" 1
667+ ]))
668+ -- Interaction of date serialization and date histogram aggregation is broken.
669+ -- it "returns date histogram aggregation results" $ withTestEnv $ do
670+ -- _ <- insertData
671+ -- let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute
672+ -- let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)
673+ -- searchExpectAggs search
674+ -- searchValidBucketAgg search "byDate" toDateHistogram
675+
676+ -- it "returns date histogram using fractional date" $ withTestEnv $ do
677+ -- _ <- insertData
678+ -- let periods = [Year, Quarter, Month, Week, Day, Hour, Minute, Second]
679+ -- let fractionals = map (FractionalInterval 1.5) [Weeks, Days, Hours, Minutes, Seconds]
680+ -- let intervals = periods ++ fractionals
681+ -- let histogram = mkDateHistogram (FieldName "postDate")
682+ -- let search interval = mkAggregateSearch Nothing $ mkAggregations "byDate" $ DateHistogramAgg (histogram interval)
683+ -- let expect interval = searchExpectAggs (search interval)
684+ -- let valid interval = searchValidBucketAgg (search interval) "byDate" toDateHistogram
685+ -- forM_ intervals expect
686+ -- forM_ intervals valid
594687
595688 describe "Highlights API" $ do
596689
@@ -686,3 +779,22 @@ main = hspec $ do
686779 describe "Monoid (SearchHits a)" $ do
687780 prop "abides the monoid laws" $ eq $
688781 prop_Monoid (T :: T (SearchHits ()))
782+
783+ describe "mkDocVersion" $ do
784+ prop "can never construct an out of range docVersion" $ \i ->
785+ let res = mkDocVersion i
786+ in case res of
787+ Nothing -> property True
788+ Just dv -> (dv >= minBound) .&&.
789+ (dv <= maxBound) .&&.
790+ docVersionNumber dv === i
791+
792+ describe "Enum DocVersion" $ do
793+ it "follows the laws of Enum, Bounded" $ do
794+ evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall
795+ evaluate (pred minBound :: DocVersion) `shouldThrow` anyErrorCall
796+ evaluate (toEnum 0 :: DocVersion) `shouldThrow` anyErrorCall
797+ evaluate (toEnum 9200000000000000001 :: DocVersion) `shouldThrow` anyErrorCall
798+ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
799+ enumFrom (pred maxBound :: DocVersion) `shouldBe` [pred maxBound, maxBound]
800+ 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"