53c397e · typeable/bloodhound

git.iko.soy/typeable/bloodhound

Merge remote-tracking branch 'upstream/master' into scanType

Conflicts: bloodhound.cabal src/Database/Bloodhound/Client.hs src/Database/Bloodhound/Types.hs merge

commit53c397e928360c64e762198ef17bd78980a807c2 authorJosh Berman <berman.josh@gmail.com> dateMon 17 Aug 2015, 17:17 (11 years ago) parent3fa24e2 f185e9d

11 files changed+499−210

compare with master

unifiedsplit

README.md+30−18 Setup.hs+4−48 bloodhound.cabal+12−5 changelog.md+7 src/Database/Bloodhound/Client.hs+96−22 src/Database/Bloodhound/Types.hs+217−18 stack.yaml+2−1 tests/doctests.hs+4 tests/doctests.hsc−74 tests/tests.hs+126−23 upload-docs.sh+1−1

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

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+12−5

@@ -1,5 +1,5 @@

11name: bloodhound

2−version: 0.6.0.2

2+version: 0.7.1.0

33synopsis: ElasticSearch client library for Haskell

44description: ElasticSearch made awesome for Haskell hackers

55homepage: https://github.com/bitemyapp/bloodhound

@@ -34,10 +34,12 @@ library

3434 mtl >= 1.0 && <2.3,

3535 transformers >= 0.2 && <0.5,

3636 http-types >= 0.8 && <0.9,

37− vector >= 0.10.9 && <0.11,

37+ vector >= 0.10.9 && <0.12,

3838 uri-bytestring >= 0.1 && <0.2,

3939 exceptions,

40− data-default-class

40+ data-default-class,

41+ blaze-builder,

42+ unordered-containers

4143 default-language: Haskell2010

4244

4345test-suite tests

@@ -64,15 +66,20 @@ test-suite tests

6466 default-language: Haskell2010

6567

6668test-suite doctests

69+ ghc-options: -threaded -Wall

6770 default-language: Haskell2010

6871 type: exitcode-stdio-1.0

6972 main-is: doctests.hs

70− hs-source-dirs: tests

73+ hs-source-dirs: tests, src

7174 if impl(ghc >= 7.8)

7275 build-depends: base,

7376 directory,

74− doctest,

77+ doctest >= 0.10.1,

7578 doctest-prop,

7679 filepath

7780 else

7881 buildable: False

82+

83+Source-Repository head

84+ Type: git

85+ Location: git://github.com/bitemyapp/bloodhound.git

changelog.md+7

@@ -1,3 +1,10 @@

1+0.7.0.0

2+===================

4+* Added QueryFilter thanks to Bjørn Nordbø!

6+* Support for optimistic concurrency control thanks again to @MichaelXavier!

180.6.0.1

29===================

310

src/Database/Bloodhound/Client.hs+96−22

@@ -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

@@ -48,9 +51,14 @@ module Database.Bloodhound.Client

4851 , getStatus

4952 , encodeBulkOperations

5053 , encodeBulkOperation

54+ -- * Reply-handling tools

55+ , isVersionConflict

56+ , isSuccess

57+ , isCreated

5158 )

5259 where

5360

61+import qualified Blaze.ByteString.Builder as BB

5462import Control.Applicative

5563import Control.Monad

5664import Control.Monad.Catch

@@ -59,8 +67,9 @@ import Data.Aeson

5967import Data.ByteString.Lazy.Builder

6068import qualified Data.ByteString.Lazy.Char8 as L

6169import Data.Default.Class

70+import Data.Ix

6271import Data.Maybe (fromMaybe)

63−import Data.Monoid ((<>))

72+import Data.Monoid

6473import Data.Text (Text)

6574import qualified Data.Text as T

6675import qualified Data.Text.Encoding as T

@@ -68,6 +77,7 @@ import qualified Data.Vector as V

6877import Network.HTTP.Client

6978import qualified Network.HTTP.Types.Method as NHTM

7079import qualified Network.HTTP.Types.Status as NHTS

80+import qualified Network.HTTP.Types.URI as NHTU

7181import Prelude hiding (filter, head)

7282import URI.ByteString hiding (Query)

7383

@@ -82,7 +92,7 @@ import Database.Bloodhound.Types

8292-- >>> let runBH' = withBH defaultManagerSettings testServer

8393-- >>> let testIndex = IndexName "twitter"

8494-- >>> let testMapping = MappingName "tweet"

85−-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)

95+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)

8696-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)

8797-- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping

8898-- >>> import GHC.Generics

@@ -162,14 +172,8 @@ joinPath ps = do

162172 Server s <- bhServer <$> getBHEnv

163173 return $ joinPath' (s:ps)

164174

165−appendQueryParam :: Text -> Text -> Text

166−appendQueryParam originalUrl newParams = originalUrl <> joiner <> newParams

167− where joiner

168− | T.any (== '?') originalUrl = "&"

169− | otherwise = "?"

170−

171175appendSearchTypeParam :: Text -> SearchType -> Text

172−appendSearchTypeParam originalUrl st = appendQueryParam originalUrl (keyEq <> stParams)

176+appendSearchTypeParam originalUrl st = addQuery [(keyEq, Just stParams)] originalUrl

173177 where keyEq = "search_type="

174178 stParams

175179 | st == SearchTypeDfsQueryThenFetch = "dfs_query_then_fetch"

@@ -180,6 +184,15 @@ appendSearchTypeParam originalUrl st = appendQueryParam originalUrl (keyEq <> st

180184 -- used to catch 'SearchTypeQueryThenFetch', which is also the default

181185 | otherwise = "query_then_fetch"

182186

187+-- | Severely dumbed down query renderer. Assumes your data doesn't

188+-- need any encoding

189+addQuery :: [(Text, Maybe Text)] -> Text -> Text

190+addQuery q u = u <> rendered

191+ where

192+ rendered =

193+ T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q

194+ prependQuestionMark = True

195+

183196bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c

184197bindM2 f ma mb = join (f <$> ma <*> mb)

185198

@@ -202,7 +215,7 @@ get = flip (dispatch NHTM.methodGet) Nothing

202215head :: MonadBH m => Text -> m Reply

203216head = flip (dispatch NHTM.methodHead) Nothing

204217put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply

205−put = dispatch NHTM.methodPost

218+put = dispatch NHTM.methodPut

206219post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply

207220post = dispatch NHTM.methodPost

208221

@@ -303,6 +316,35 @@ openIndex = openOrCloseIndexes OpenIndex

303316closeIndex :: MonadBH m => IndexName -> m Reply

304317closeIndex = openOrCloseIndexes CloseIndex

305318

319+-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.

320+-- Explained in further detail at

321+-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>

322+--

323+-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]

324+-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")

325+putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply

326+putTemplate indexTemplate (TemplateName templateName) =

327+ bindM2 put url (return body)

328+ where url = joinPath ["_template", templateName]

329+ body = Just $ encode indexTemplate

330+

331+-- | 'templateExists' checks to see if a template exists.

332+--

333+-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")

334+templateExists :: MonadBH m => TemplateName -> m Bool

335+templateExists (TemplateName templateName) = do

336+ (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]

337+ return exists

338+

339+-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.

340+--

341+-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]

342+-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")

343+-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")

344+deleteTemplate :: MonadBH m => TemplateName -> m Reply

345+deleteTemplate (TemplateName templateName) =

346+ delete =<< joinPath ["_template", templateName]

347+

306348-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas

307349-- for documents in indexes.

308350--

@@ -314,7 +356,9 @@ putMapping :: (MonadBH m, ToJSON a) => IndexName

314356 -> MappingName -> a -> m Reply

315357putMapping (IndexName indexName) (MappingName mappingName) mapping =

316358 bindM2 put url (return body)

317− where url = joinPath [indexName, mappingName, "_mapping"]

359+ where url = joinPath [indexName, "_mapping", mappingName]

360+ -- "_mapping" and mappingName above were originally transposed

361+ -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"

318362 body = Just $ encode mapping

319363

320364-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.

@@ -328,22 +372,38 @@ putMapping (IndexName indexName) (MappingName mappingName) mapping =

328372deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply

329373deleteMapping (IndexName indexName)

330374 (MappingName mappingName) =

331− delete =<< joinPath [indexName, mappingName, "_mapping"]

375+ -- "_mapping" and mappingName below were originally transposed

376+ -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"

377+ delete =<< joinPath [indexName, "_mapping", mappingName]

332378

333379-- | 'indexDocument' is the primary way to save a single document in

334380-- Elasticsearch. The document itself is simply something we can

335381-- convert into a JSON 'Value'. The 'DocId' will function as the

336382-- primary key for the document.

337383--

338−-- >>> resp <- runBH' $ indexDocument testIndex testMapping exampleTweet (DocId "1")

384+-- >>> resp <- runBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")

339385-- >>> print resp

340386-- 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}

341387indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName

342− -> doc -> DocId -> m Reply

388+ -> IndexDocumentSettings -> doc -> DocId -> m Reply

343389indexDocument (IndexName indexName)

344− (MappingName mappingName) document (DocId docId) =

390+ (MappingName mappingName) cfg document (DocId docId) =

345391 bindM2 put url (return body)

346− where url = joinPath [indexName, mappingName, docId]

392+ where url = addQuery params <$> joinPath [indexName, mappingName, docId]

393+ versionCtlParams = case idsVersionControl cfg of

394+ NoVersionControl -> []

395+ InternalVersion v -> versionParams v "internal"

396+ ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"

397+ ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"

398+ ForceVersion (ExternalDocVersion v) -> versionParams v "force"

399+ vt = T.pack . show . docVersionNumber

400+ versionParams v t = [ ("version", Just $ vt v)

401+ , ("version_type", Just t)

402+ ]

403+ parentParams = case idsParent cfg of

404+ Nothing -> []

405+ Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]

406+ params = versionCtlParams ++ parentParams

347407 body = Just (encode document)

348408

349409-- | 'deleteDocument' is the primary way to delete a single document.

@@ -524,9 +584,9 @@ scanSearch search = do

524584--

525585-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing

526586-- >>> mkSearch (Just query) Nothing

527−-- 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}

587+-- 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}

528588mkSearch :: Maybe Query -> Maybe Filter -> Search

529−mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch

589+mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing

530590

531591-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for

532592-- the 'Query' and the 'Aggregation'.

@@ -536,7 +596,7 @@ mkSearch query filter = Search query filter Nothing Nothing Nothing False (From

536596-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})

537597-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms

538598mkAggregateSearch :: Maybe Query -> Aggregations -> Search

539−mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch

599+mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing

540600

541601-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for

542602-- the 'Query' and the 'Aggregation'.

@@ -545,7 +605,7 @@ mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSear

545605-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]

546606-- >>> let search = mkHighlightSearch (Just query) testHighlight

547607mkHighlightSearch :: Maybe Query -> Highlights -> Search

548−mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch

608+mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing

549609

550610-- | 'pageSearch' is a helper function that takes a search and assigns the from

551611-- and size fields for the search. The from parameter defines the offset

@@ -555,9 +615,9 @@ mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing

555615-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")

556616-- >>> let search = mkSearch (Just query) Nothing

557617-- >>> search

558−-- 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}

618+-- 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}

559619-- >>> pageSearch (From 10) (Size 100) search

560−-- 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}

620+-- 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}

561621pageSearch :: From -- ^ The result offset

562622 -> Size -- ^ The number of results to return

563623 -> Search -- ^ The current seach

@@ -591,3 +651,17 @@ setURI req URI{..} = do

591651 Scheme "https" -> True

592652 _ -> False

593653 theQueryString = [(k , Just v) | (k, v) <- queryPairs uriQuery]

654+

655+-- | Was there an optimistic concurrency control conflict when

656+-- indexing a document?

657+isVersionConflict :: Reply -> Bool

658+isVersionConflict = statusCheck (== 409)

659+

660+isSuccess :: Reply -> Bool

661+isSuccess = statusCheck (inRange (200, 299))

662+

663+isCreated :: Reply -> Bool

664+isCreated = statusCheck (== 201)

665+

666+statusCheck :: (Int -> Bool) -> Reply -> Bool

667+statusCheck prd = prd . NHTS.statusCode . responseStatus

src/Database/Bloodhound/Types.hs+217−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 , SearchType(..)

@@ -95,7 +105,10 @@ module Database.Bloodhound.Types

95105 , RegexpFlags(..)

96106 , RegexpFlag(..)

97107 , FieldName(..)

108+ , Script(..)

98109 , IndexName(..)

110+ , TemplateName(..)

111+ , TemplatePattern(..)

99112 , MappingName(..)

100113 , DocId(..)

101114 , CacheName(..)

@@ -191,6 +204,8 @@ module Database.Bloodhound.Types

191204 , Bucket(..)

192205 , BucketAggregation(..)

193206 , TermsAggregation(..)

207+ , ValueCountAggregation(..)

208+ , FilterAggregation(..)

194209 , DateHistogramAggregation(..)

195210

196211 , Highlights(..)

@@ -217,13 +232,16 @@ import Control.Monad.Writer

217232import Data.Aeson

218233import Data.Aeson.Types (Pair, emptyObject, parseMaybe)

219234import qualified Data.ByteString.Lazy.Char8 as L

220−import Data.List (nub)

235+import Data.List (nub, foldl')

221236import Data.List.NonEmpty (NonEmpty (..), toList)

237+import qualified Data.HashMap.Strict as HM (union)

222238import qualified Data.Map.Strict as M

239+import Data.Maybe

223240import Data.Text (Text)

224241import qualified Data.Text as T

225242import Data.Time.Clock (UTCTime)

226243import qualified Data.Vector as V

244+import GHC.Enum

227245import GHC.Generics (Generic)

228246import Network.HTTP.Client

229247import qualified Network.HTTP.Types.Method as NHTM

@@ -341,6 +359,20 @@ data FieldType = GeoPointType

341359data FieldDefinition =

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

343361

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

363+ applied to new indices created. The templates include both

364+ 'IndexSettings' and mappings, and a simple 'TemplatePattern' that

365+ controls if the template will be applied to the index created.

366+ Specify mappings as follows: @[toJSON TweetMapping, ...]@

367+

368+ https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html

369+-}

370+data IndexTemplate =

371+ IndexTemplate { templatePattern :: TemplatePattern

372+ , templateSettings :: Maybe IndexSettings

373+ , templateMappings :: [Value]

374+ }

375+

344376data MappingField =

345377 MappingField { mappingFieldName :: FieldName

346378 , fieldDefinition :: FieldDefinition } deriving (Eq, Show)

@@ -368,14 +400,95 @@ data BulkOperation =

368400 | BulkUpdate IndexName MappingName DocId Value deriving (Eq, Show)

369401

370402{-| 'EsResult' describes the standard wrapper JSON document that you see in

371− successful Elasticsearch responses.

403+ successful Elasticsearch lookups or lookups that couldn't find the document.

372404-}

373405data EsResult a = EsResult { _index :: Text

374406 , _type :: Text

375407 , _id :: Text

376− , _version :: Int

377− , found :: Maybe Bool

378− , _source :: a } deriving (Eq, Show)

408+ , foundResult :: Maybe (EsResultFound a)} deriving (Eq, Show)

409+

410+

411+{-| 'EsResultFound' contains the document and its metadata inside of an

412+ 'EsResult' when the document was successfully found.

413+-}

414+data EsResultFound a = EsResultFound { _version :: DocVersion

415+ , _source :: a } deriving (Eq, Show)

416+

417+

418+

419+{-| 'DocVersion' is an integer version number for a document between 1

420+and 9.2e+18 used for <<https://www.elastic.co/guide/en/elasticsearch/guide/current/optimistic-concurrency-control.html optimistic concurrency control>>.

421+-}

422+newtype DocVersion = DocVersion {

423+ docVersionNumber :: Int

424+ } deriving (Eq, Show, Ord, ToJSON)

425+

426+-- | Smart constructor for in-range doc version

427+mkDocVersion :: Int -> Maybe DocVersion

428+mkDocVersion i

429+ | i >= (docVersionNumber minBound) && i <= (docVersionNumber maxBound) =

430+ Just $ DocVersion i

431+ | otherwise = Nothing

432+

433+

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

435+own version numbers instead of ones from ES.

436+-}

437+newtype ExternalDocVersion = ExternalDocVersion DocVersion

438+ deriving (Eq, Show, Ord, Bounded, Enum, ToJSON)

439+

440+{-| 'VersionControl' is specified when indexing documents as a

441+optimistic concurrency control.

442+-}

443+data VersionControl = NoVersionControl

444+ -- ^ Don't send a version. This is a pure overwrite.

445+ | InternalVersion DocVersion

446+ -- ^ Use the default ES versioning scheme. Only

447+ -- index the document if the version is the same

448+ -- as the one specified. Only applicable to

449+ -- updates, as you should be getting Version from

450+ -- a search result.

451+ | ExternalGT ExternalDocVersion

452+ -- ^ Use your own version numbering. Only index

453+ -- the document if the version is strictly higher

454+ -- OR the document doesn't exist. The given

455+ -- version will be used as the new version number

456+ -- for the stored document. N.B. All updates must

457+ -- increment this number, meaning there is some

458+ -- global, external ordering of updates.

459+ | ExternalGTE ExternalDocVersion

460+ -- ^ Use your own version numbering. Only index

461+ -- the document if the version is equal or higher

462+ -- than the stored version. Will succeed if there

463+ -- is no existing document. The given version will

464+ -- be used as the new version number for the

465+ -- stored document. Use with care, as this could

466+ -- result in data loss.

467+ | ForceVersion ExternalDocVersion

468+ -- ^ The document will always be indexed and the

469+ -- given version will be the new version. This is

470+ -- typically used for correcting errors. Use with

471+ -- care, as this could result in data loss.

472+ deriving (Show, Eq, Ord)

473+

474+{-| 'DocumentParent' is used to specify a parent document.

475+-}

476+newtype DocumentParent = DocumentParent DocId

477+ deriving (Eq, Show)

478+

479+{-| 'IndexDocumentSettings' are special settings supplied when indexing

480+a document. For the best backwards compatiblity when new fields are

481+added, you should probably prefer to start with 'defaultIndexDocumentSettings'

482+-}

483+data IndexDocumentSettings =

484+ IndexDocumentSettings { idsVersionControl :: VersionControl

485+ , idsParent :: Maybe DocumentParent

486+ } deriving (Eq, Show)

487+

488+{-| Reasonable default settings. Chooses no version control and no parent.

489+-}

490+defaultIndexDocumentSettings :: IndexDocumentSettings

491+defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing

379492

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

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

@@ -471,6 +584,14 @@ newtype Server = Server Text deriving (Eq, Show)

471584-}

472585newtype IndexName = IndexName Text deriving (Eq, Generic, Show)

473586

587+{-| 'TemplateName' is used to describe which template to query/create/delete

588+-}

589+newtype TemplateName = TemplateName Text deriving (Eq, Show, Generic)

590+

591+{-| 'TemplatePattern' represents a pattern which is matched against index names

592+-}

593+newtype TemplatePattern = TemplatePattern Text deriving (Eq, Show, Generic)

594+

474595{-| 'MappingName' is part of mappings which are how ES describes and schematizes

475596 the data in the indices.

476597-}

@@ -491,6 +612,12 @@ newtype QueryString = QueryString Text deriving (Eq, Generic, Show)

491612-}

492613newtype FieldName = FieldName Text deriving (Eq, Show)

493614

615+

616+{-| 'Script' is often used in place of 'FieldName' to specify more

617+complex ways of extracting a value from a document.

618+-}

619+newtype Script = Script { scriptText :: Text } deriving (Eq, Show)

620+

494621{-| 'CacheName' is used in 'RegexpFilter' for describing the

495622 'CacheKey' keyed caching behavior.

496623-}

@@ -607,7 +734,8 @@ data Search = Search { queryBody :: Maybe Query

607734 , trackSortScores :: TrackSortScores

608735 , from :: From

609736 , size :: Size

610− , searchType :: SearchType } deriving (Eq, Show)

737+ , searchType :: SearchType

738+ , fields :: Maybe [FieldName] } deriving (Eq, Show)

611739

612740data SearchType = SearchTypeQueryThenFetch

613741 | SearchTypeDfsQueryThenFetch

@@ -997,6 +1125,7 @@ data Filter = AndFilter [Filter] Cache

9971125 | LimitFilter Int

9981126 | MissingFilter FieldName Existence NullValue

9991127 | PrefixFilter FieldName PrefixValue Cache

1128+ | QueryFilter Query Cache

10001129 | RangeFilter FieldName RangeValue RangeExecution Cache

10011130 | RegexpFilter FieldName Regexp RegexpFlags CacheName Cache CacheKey

10021131 | TermFilter Term Cache

@@ -1204,7 +1333,9 @@ data Interval = Year

12041333 | FractionalInterval Float TimeInterval deriving (Eq, Show)

12051334

12061335data Aggregation = TermsAgg TermsAggregation

1207− | DateHistogramAgg DateHistogramAggregation deriving (Eq, Show)

1336+ | DateHistogramAgg DateHistogramAggregation

1337+ | ValueCountAgg ValueCountAggregation

1338+ | FilterAgg FilterAggregation deriving (Eq, Show)

12081339

12091340

12101341data TermsAggregation = TermsAggregation { term :: Either Text Text

@@ -1230,6 +1361,13 @@ data DateHistogramAggregation = DateHistogramAggregation { dateField :: Fie

12301361 , dateAggs :: Maybe Aggregations

12311362 } deriving (Eq, Show)

12321363

1364+-- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.

1365+data ValueCountAggregation = FieldValueCount FieldName

1366+ | ScriptValueCount Script deriving (Eq, Show)

1367+

1368+-- | 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.

1369+data FilterAggregation = FilterAggregation { faFilter :: Filter

1370+ , faAggs :: Maybe Aggregations} deriving (Eq, Show)

12331371

12341372mkTermsAggregation :: Text -> TermsAggregation

12351373mkTermsAggregation t = TermsAggregation (Left t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

@@ -1303,6 +1441,13 @@ instance ToJSON Aggregation where

13031441 "post_offset" .= postOffset

13041442 ],

13051443 "aggs" .= dateHistoAggs ]

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

1445+ where v = case a of

1446+ (FieldValueCount (FieldName n)) -> object ["field" .= n]

1447+ (ScriptValueCount (Script s)) -> object ["script" .= s]

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

1449+ omitNulls [ "filter" .= filt

1450+ , "aggs" .= ags]

13061451

13071452type AggregationResults = M.Map Text Value

13081453

@@ -1442,6 +1587,13 @@ instance ToJSON Filter where

14421587 object [fieldName .= fieldValue

14431588 , "_cache" .= cache]]

14441589

1590+ toJSON (QueryFilter query False) =

1591+ object ["query" .= toJSON query ]

1592+ toJSON (QueryFilter query True) =

1593+ object ["fquery" .=

1594+ object [ "query" .= toJSON query

1595+ , "_cache" .= True ]]

1596+

14451597 toJSON (RangeFilter (FieldName fieldName) rangeValue rangeExecution cache) =

14461598 object ["range" .=

14471599 object [ fieldName .= object (rangeValueToPair rangeValue)

@@ -1882,6 +2034,8 @@ instance ToJSON IgnoreTermFrequency

18822034instance ToJSON MaxQueryTerms

18832035instance ToJSON TypeName

18842036instance ToJSON IndexName

2037+instance ToJSON TemplateName

2038+instance ToJSON TemplatePattern

18852039instance ToJSON BoostTerms

18862040instance ToJSON MaxWordLength

18872041instance ToJSON MinWordLength

@@ -1918,22 +2072,43 @@ instance FromJSON Status where

19182072

19192073

19202074instance ToJSON IndexSettings where

1921− toJSON (IndexSettings s r) = object ["settings" .= object ["shards" .= s, "replicas" .= r]]

1922−

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

2076+ object ["index" .=

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

2078+ ]

2079+ ]

2080+

2081+instance ToJSON IndexTemplate where

2082+ toJSON (IndexTemplate p s m) = merge

2083+ (object [ "template" .= p

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

2085+ ])

2086+ (toJSON s)

2087+ where

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

2089+ merge o Null = o

2090+ merge _ _ = undefined

19232091

19242092instance (FromJSON a) => FromJSON (EsResult a) where

1925− parseJSON (Object v) = EsResult <$>

1926− v .: "_index" <*>

1927− v .: "_type" <*>

1928− v .: "_id" <*>

1929− v .: "_version" <*>

1930− v .:? "found" <*>

1931− v .: "_source"

2093+ parseJSON jsonVal@(Object v) = do

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

2095+ fr <- if found

2096+ then parseJSON jsonVal

2097+ else return Nothing

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

2099+ v .: "_type" <*>

2100+ v .: "_id" <*>

2101+ pure fr

19322102 parseJSON _ = empty

19332103

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

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

2106+ v .: "_version" <*>

2107+ v .: "_source"

2108+ parseJSON _ = empty

19342109

19352110instance ToJSON Search where

1936− toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _) =

2111+ toJSON (Search query sFilter sort searchAggs highlight sTrackSortScores sFrom sSize _ sFields) =

19372112 omitNulls [ "query" .= query

19382113 , "filter" .= sFilter

19392114 , "sort" .= sort

@@ -1941,7 +2116,8 @@ instance ToJSON Search where

19412116 , "highlight" .= highlight

19422117 , "from" .= sFrom

19432118 , "size" .= sSize

1944− , "track_scores" .= sTrackSortScores]

2119+ , "track_scores" .= sTrackSortScores

2120+ , "fields" .= sFields]

19452121

19462122

19472123instance ToJSON FieldHighlight where

@@ -2188,3 +2364,26 @@ instance FromJSON ShardResult where

21882364 v .: "successful" <*>

21892365 v .: "failed"

21902366 parseJSON _ = empty

2367+

2368+

2369+instance FromJSON DocVersion where

2370+ parseJSON v = do

2371+ i <- parseJSON v

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

2373+

2374+instance Bounded DocVersion where

2375+ minBound = DocVersion 1

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

2377+

2378+instance Enum DocVersion where

2379+ succ x

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

2381+ | otherwise = succError "DocVersion"

2382+ pred x

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

2384+ | otherwise = predError "DocVersion"

2385+ toEnum i =

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

2387+ fromEnum = docVersionNumber

2388+ enumFrom = boundedEnumFrom

2389+ 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

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)

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+126−23

@@ -5,6 +5,7 @@

55module Main where

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 (..))

@@ -25,7 +27,7 @@ import Network.HTTP.Client

2527import qualified Network.HTTP.Types.Status as NHTS

2628import 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

@@ -147,32 +149,42 @@ otherTweet = Tweet { user = "notmyapp"

147149 , age = 1000

148150 , location = Location 40.12 (-71.34) }

149151

150−insertData :: BH IO ()

151−insertData = do

152+resetIndex :: BH IO ()

153+resetIndex = do

152154 _ <- deleteExampleIndex

153155 _ <- createExampleIndex

154156 _ <- putMapping testIndex testMapping TweetMapping

155− _ <- indexDocument testIndex testMapping exampleTweet (DocId "1")

156− _ <- refreshIndex testIndex

157157 return ()

158158

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+

159170insertOther :: BH IO ()

160171insertOther = do

161− _ <- indexDocument testIndex testMapping otherTweet (DocId "2")

172+ _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2")

162173 _ <- refreshIndex testIndex

163174 return ()

164175

165176searchTweet :: Search -> BH IO (Either String Tweet)

166177searchTweet search = do

167− reply <- searchByIndex testIndex search

168− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)

178+ result <- searchTweets search

169179 let myTweet = fmap (hitSource . head . hits . searchHits) result

170180 return myTweet

171181

182+searchTweets :: Search -> BH IO (Either String (SearchResult Tweet))

183+searchTweets search = eitherDecode . responseBody <$> searchByIndex testIndex search

184+

172185searchExpectNoResults :: Search -> BH IO ()

173186searchExpectNoResults search = do

174− reply <- searchByIndex testIndex search

175− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)

187+ result <- searchTweets search

176188 let emptyHits = fmap (hits . searchHits) result

177189 liftIO $

178190 emptyHits `shouldBe` Right []

@@ -204,8 +216,7 @@ searchTermsAggHint hints = do

204216

205217searchTweetHighlight :: Search -> BH IO (Either String (Maybe HitHighlight))

206218searchTweetHighlight search = do

207− reply <- searchByIndex testIndex search

208− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)

219+ result <- searchTweets search

209220 let myHighlight = fmap (hitHighlight . head . hits . searchHits) result

210221 return myHighlight

211222

@@ -268,6 +279,9 @@ instance Arbitrary a => Arbitrary (SearchHits a) where

268279 hs <- arbitrary

269280 return $ SearchHits tot score hs

270281

282+getSource :: EsResult a -> Maybe a

283+getSource = fmap _source . foundResult

284+

271285main :: IO ()

272286main = hspec $ do

273287

@@ -288,8 +302,40 @@ main = hspec $ do

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

289303 let newTweet = eitherDecode

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

291− liftIO $ (fmap _source newTweet `shouldBe` Right exampleTweet)

292−

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

293339

294340 describe "bulk API" $ do

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

@@ -308,8 +354,8 @@ main = hspec $ do

308354 let maybeFirst = eitherDecode $ responseBody fDoc :: Either String (EsResult BulkTest)

309355 let maybeSecond = eitherDecode $ responseBody sDoc :: Either String (EsResult BulkTest)

310356 liftIO $ do

311− fmap _source maybeFirst `shouldBe` Right firstTest

312− fmap _source maybeSecond `shouldBe` Right secondTest

357+ fmap getSource maybeFirst `shouldBe` Right (Just firstTest)

358+ fmap getSource maybeSecond `shouldBe` Right (Just secondTest)

313359

314360

315361 describe "query API" $ do

@@ -341,8 +387,8 @@ main = hspec $ do

341387

342388 it "returns document for multi-match query" $ withTestEnv $ do

343389 _ <- insertData

344− let fields = [FieldName "user", FieldName "message"]

345− let query = QueryMultiMatchQuery $ mkMultiMatchQuery fields (QueryString "bitemyapp")

390+ let flds = [FieldName "user", FieldName "message"]

391+ let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")

346392 let search = mkSearch (Just query) Nothing

347393 myTweet <- searchTweet search

348394 liftIO $

@@ -389,9 +435,8 @@ main = hspec $ do

389435 let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending

390436 let search = Search Nothing

391437 (Just IdentityFilter) (Just [sortSpec]) Nothing Nothing

392− False (From 0) (Size 10)

393− reply <- searchByIndex testIndex search

394− let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)

438+ False (From 0) (Size 10) Nothing

439+ result <- searchTweets search

395440 let myTweet = fmap (hitSource . head . hits . searchHits) result

396441 liftIO $

397442 myTweet `shouldBe` Right otherTweet

@@ -525,7 +570,6 @@ main = hspec $ do

525570 liftIO $

526571 myTweet `shouldBe` Right exampleTweet

527572

528−

529573 it "returns document for regexp filter" $ withTestEnv $ do

530574 _ <- insertData

531575 let filter = RegexpFilter (FieldName "user") (Regexp "bite.*app")

@@ -543,6 +587,20 @@ main = hspec $ do

543587 let search = mkSearch Nothing (Just filter)

544588 searchExpectNoResults search

545589

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+

546604 describe "Aggregation API" $ do

547605 it "returns term aggregation results" $ withTestEnv $ do

548606 _ <- insertData

@@ -570,6 +628,32 @@ main = hspec $ do

570628 _ <- insertData

571629 searchTermsAggHint [GlobalOrdinals, GlobalOrdinalsHash, GlobalOrdinalsLowCardinality, Map]

572630

631+

632+ it "can execute value_count aggregations" $ withTestEnv $ do

633+ _ <- insertData

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+ ]))

644+

645+ it "can execute filter aggregations" $ withTestEnv $ do

646+ _ <- insertData

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+ ]))

573657 -- Interaction of date serialization and date histogram aggregation is broken.

574658 -- it "returns date histogram aggregation results" $ withTestEnv $ do

575659 -- _ <- insertData

@@ -659,3 +743,22 @@ main = hspec $ do

659743 describe "Monoid (SearchHits a)" $ do

660744 prop "abides the monoid laws" $ eq $

661745 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.1

13+ver=0.7.0.1

1414

1515if [ -z "$pkg" ]; then

1616 echo "Unable to determine package name"