git.iko.soy/typeable/bloodhound
on aeson-0.10 help sign in
typeable/bloodhound/src/Database/Bloodhound/Client.hs
647 lines 31 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RecordWildCards #-}
4-------------------------------------------------------------------------------
5-- |
6-- Module : Database.Bloodhound.Client
7-- Copyright : (C) 2014 Chris Allen
8-- License : BSD-style (see the file LICENSE)
9-- Maintainer : Chris Allen <cma@bitemyapp.com
10-- Stability : provisional
11-- Portability : OverloadedStrings
12--
13-- Client side functions for talking to Elasticsearch servers.
14--
15-------------------------------------------------------------------------------
17module Database.Bloodhound.Client
18 ( -- * Bloodhound client functions
19 -- | The examples in this module assume the following code has been run.
20 -- The :{ and :} will only work in GHCi. You'll only need the data types
21 -- and typeclass instances for the functions that make use of them.
23 -- $setup
24 withBH
25 , createIndex
26 , deleteIndex
27 , indexExists
28 , openIndex
29 , closeIndex
30 , putTemplate
31 , templateExists
32 , deleteTemplate
33 , putMapping
34 , deleteMapping
35 , indexDocument
36 , getDocument
37 , documentExists
38 , deleteDocument
39 , searchAll
40 , searchByIndex
41 , searchByType
42 , scanSearch
43 , refreshIndex
44 , mkSearch
45 , mkAggregateSearch
46 , mkHighlightSearch
47 , bulk
48 , pageSearch
49 , mkShardCount
50 , mkReplicaCount
51 , getStatus
52 , encodeBulkOperations
53 , encodeBulkOperation
54 -- * Reply-handling tools
55 , isVersionConflict
56 , isSuccess
57 , isCreated
58 )
59 where
61import qualified Blaze.ByteString.Builder as BB
62import Control.Applicative
63import Control.Monad
64import Control.Monad.Catch
65import Control.Monad.IO.Class
66import Data.Aeson
67import Data.ByteString.Lazy.Builder
68import qualified Data.ByteString.Lazy.Char8 as L
69import Data.Ix
70import qualified Data.List as LS (filter)
71import Data.Maybe (fromMaybe, isJust)
72import Data.Monoid
73import Data.Text (Text)
74import qualified Data.Text as T
75import qualified Data.Text.Encoding as T
76import qualified Data.Vector as V
77import Network.HTTP.Client
78import qualified Network.HTTP.Types.Method as NHTM
79import qualified Network.HTTP.Types.Status as NHTS
80import qualified Network.HTTP.Types.URI as NHTU
81import qualified Network.URI as URI
82import Prelude hiding (filter, head)
84import Database.Bloodhound.Types
86-- $setup
87-- >>> :set -XOverloadedStrings
88-- >>> :set -XDeriveGeneric
89-- >>> import Database.Bloodhound
90-- >>> import Test.DocTest.Prop (assert)
91-- >>> let testServer = (Server "http://localhost:9200")
92-- >>> let runBH' = withBH defaultManagerSettings testServer
93-- >>> let testIndex = IndexName "twitter"
94-- >>> let testMapping = MappingName "tweet"
95-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)
96-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)
97-- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping
98-- >>> import GHC.Generics
99-- >>> import Data.Time.Calendar (Day (..))
100-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
101-- >>> :{
102--instance ToJSON TweetMapping where
103-- toJSON TweetMapping =
104-- object ["tweet" .=
105-- object ["properties" .=
106-- object ["location" .=
107-- object ["type" .= ("geo_point" :: Text)]]]]
108--data Location = Location { lat :: Double
109-- , lon :: Double } deriving (Eq, Generic, Show)
110--data Tweet = Tweet { user :: Text
111-- , postDate :: UTCTime
112-- , message :: Text
113-- , age :: Int
114-- , location :: Location } deriving (Eq, Generic, Show)
115--exampleTweet = Tweet { user = "bitemyapp"
116-- , postDate = UTCTime
117-- (ModifiedJulianDay 55000)
118-- (secondsToDiffTime 10)
119-- , message = "Use haskell!"
120-- , age = 10000
121-- , location = Location 40.12 (-71.34) }
122--instance ToJSON Tweet
123--instance FromJSON Tweet
124--instance ToJSON Location
125--instance FromJSON Location
126--data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
127--instance FromJSON BulkTest
128--instance ToJSON BulkTest
129-- :}
131-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'
132-- which rejects 'Int' values below 1 and above 1000.
133--
134-- >>> mkShardCount 10
135-- Just (ShardCount 10)
136mkShardCount :: Int -> Maybe ShardCount
137mkShardCount n
138 | n < 1 = Nothing
139 | n > 1000 = Nothing
140 | otherwise = Just (ShardCount n)
142-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'
143-- which rejects 'Int' values below 1 and above 1000.
144--
145-- >>> mkReplicaCount 10
146-- Just (ReplicaCount 10)
147mkReplicaCount :: Int -> Maybe ReplicaCount
148mkReplicaCount n
149 | n < 1 = Nothing
150 | n > 1000 = Nothing -- ...
151 | otherwise = Just (ReplicaCount n)
153emptyBody :: L.ByteString
154emptyBody = L.pack ""
156dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString
157 -> m Reply
158dispatch dMethod url body = do
159 initReq <- liftIO $ parseUrl' url
160 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
161 let req = initReq { method = dMethod
162 , requestBody = reqBody
163 , checkStatus = \_ _ _ -> Nothing}
164 mgr <- bhManager <$> getBHEnv
165 liftIO $ httpLbs req mgr
167joinPath' :: [Text] -> Text
168joinPath' = T.intercalate "/"
170joinPath :: MonadBH m => [Text] -> m Text
171joinPath ps = do
172 Server s <- bhServer <$> getBHEnv
173 return $ joinPath' (s:ps)
175appendSearchTypeParam :: Text -> SearchType -> Text
176appendSearchTypeParam originalUrl st = addQuery params originalUrl
177 where stText = "search_type"
178 params
179 | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")]
180 | st == SearchTypeCount = [(stText, Just "count")]
181 | st == SearchTypeScan = [(stText, Just "scan"), ("scroll", Just "1m")]
182 | st == SearchTypeQueryAndFetch = [(stText, Just "query_and_fetch")]
183 | st == SearchTypeDfsQueryAndFetch = [(stText, Just "dfs_query_and_fetch")]
184 -- used to catch 'SearchTypeQueryThenFetch', which is also the default
185 | otherwise = [(stText, Just "query_then_fetch")]
187-- | Severely dumbed down query renderer. Assumes your data doesn't
188-- need any encoding
189addQuery :: [(Text, Maybe Text)] -> Text -> Text
190addQuery q u = u <> rendered
191 where
192 rendered =
193 T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q
194 prependQuestionMark = True
196bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
197bindM2 f ma mb = join (f <$> ma <*> mb)
199-- | Convenience function that sets up a manager and BHEnv and runs
200-- the given set of bloodhound operations. Connections will be
201-- pipelined automatically in accordance with the given manager
202-- settings in IO. If you've got your own monad transformer stack, you
203-- should use 'runBH' directly.
204withBH :: ManagerSettings -> Server -> BH IO a -> IO a
205withBH ms s f = do
206 mgr <- newManager ms
207 let env = BHEnv { bhServer = s
208 , bhManager = mgr }
209 runBH env f
211-- Shortcut functions for HTTP methods
212delete :: MonadBH m => Text -> m Reply
213delete = flip (dispatch NHTM.methodDelete) Nothing
214get :: MonadBH m => Text -> m Reply
215get = flip (dispatch NHTM.methodGet) Nothing
216head :: MonadBH m => Text -> m Reply
217head = flip (dispatch NHTM.methodHead) Nothing
218put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
219put = dispatch NHTM.methodPut
220post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
221post = dispatch NHTM.methodPost
223-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
224-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
225-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
227-- | 'getStatus' fetches the 'Status' of a 'Server'
228--
229-- >>> serverStatus <- runBH' getStatus
230-- >>> fmap status (serverStatus)
231-- Just 200
232getStatus :: MonadBH m => m (Maybe Status)
233getStatus = do
234 url <- joinPath []
235 request <- liftIO $ parseUrl' url
236 mgr <- bhManager <$> getBHEnv
237 response <- liftIO $ httpLbs request mgr
238 return $ decode (responseBody response)
240-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
241--
242-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
243-- >>> respIsTwoHunna response
244-- True
245-- >>> runBH' $ indexExists (IndexName "didimakeanindex")
246-- True
247createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply
248createIndex indexSettings (IndexName indexName) =
249 bindM2 put url (return body)
250 where url = joinPath [indexName]
251 body = Just $ encode indexSettings
253-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
254--
255-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
256-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
257-- >>> respIsTwoHunna response
258-- True
259-- >>> runBH' $ indexExists testIndex
260-- False
261deleteIndex :: MonadBH m => IndexName -> m Reply
262deleteIndex (IndexName indexName) =
263 delete =<< joinPath [indexName]
265statusCodeIs :: Int -> Reply -> Bool
266statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n
268respIsTwoHunna :: Reply -> Bool
269respIsTwoHunna = statusCodeIs 200
271existentialQuery :: MonadBH m => Text -> m (Reply, Bool)
272existentialQuery url = do
273 reply <- head url
274 return (reply, respIsTwoHunna reply)
276-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
277-- in IO
278--
279-- >>> exists <- runBH' $ indexExists testIndex
280indexExists :: MonadBH m => IndexName -> m Bool
281indexExists (IndexName indexName) = do
282 (_, exists) <- existentialQuery =<< joinPath [indexName]
283 return exists
285-- | 'refreshIndex' will force a refresh on an index. You must
286-- do this if you want to read what you wrote.
287--
288-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
289-- >>> _ <- runBH' $ refreshIndex testIndex
290refreshIndex :: MonadBH m => IndexName -> m Reply
291refreshIndex (IndexName indexName) =
292 bindM2 post url (return Nothing)
293 where url = joinPath [indexName, "_refresh"]
295stringifyOCIndex :: OpenCloseIndex -> Text
296stringifyOCIndex oci = case oci of
297 OpenIndex -> "_open"
298 CloseIndex -> "_close"
300openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply
301openOrCloseIndexes oci (IndexName indexName) =
302 bindM2 post url (return Nothing)
303 where ociString = stringifyOCIndex oci
304 url = joinPath [indexName, ociString]
306-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
307-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
308--
309-- >>> reply <- runBH' $ openIndex testIndex
310openIndex :: MonadBH m => IndexName -> m Reply
311openIndex = openOrCloseIndexes OpenIndex
313-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
314-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
315--
316-- >>> reply <- runBH' $ closeIndex testIndex
317closeIndex :: MonadBH m => IndexName -> m Reply
318closeIndex = openOrCloseIndexes CloseIndex
320-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.
321-- Explained in further detail at
322-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>
323--
324-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
325-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
326putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply
327putTemplate indexTemplate (TemplateName templateName) =
328 bindM2 put url (return body)
329 where url = joinPath ["_template", templateName]
330 body = Just $ encode indexTemplate
332-- | 'templateExists' checks to see if a template exists.
333--
334-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")
335templateExists :: MonadBH m => TemplateName -> m Bool
336templateExists (TemplateName templateName) = do
337 (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
338 return exists
340-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
341--
342-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
343-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
344-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")
345deleteTemplate :: MonadBH m => TemplateName -> m Reply
346deleteTemplate (TemplateName templateName) =
347 delete =<< joinPath ["_template", templateName]
349-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
350-- for documents in indexes.
351--
352-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
353-- >>> resp <- runBH' $ putMapping testIndex testMapping TweetMapping
354-- >>> print resp
355-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","21")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}
356putMapping :: (MonadBH m, ToJSON a) => IndexName
357 -> MappingName -> a -> m Reply
358putMapping (IndexName indexName) (MappingName mappingName) mapping =
359 bindM2 put url (return body)
360 where url = joinPath [indexName, "_mapping", mappingName]
361 -- "_mapping" and mappingName above were originally transposed
362 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
363 body = Just $ encode mapping
365-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
366-- Mappings are schemas for documents in indexes.
367--
368-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
369-- >>> _ <- runBH' $ putMapping testIndex testMapping TweetMapping
370-- >>> resp <- runBH' $ deleteMapping testIndex testMapping
371-- >>> print resp
372-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("Content-Type","application/json; charset=UTF-8"),("Content-Length","21")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}
373deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
374deleteMapping (IndexName indexName)
375 (MappingName mappingName) =
376 -- "_mapping" and mappingName below were originally transposed
377 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
378 delete =<< joinPath [indexName, "_mapping", mappingName]
380-- | 'indexDocument' is the primary way to save a single document in
381-- Elasticsearch. The document itself is simply something we can
382-- convert into a JSON 'Value'. The 'DocId' will function as the
383-- primary key for the document.
384--
385-- >>> resp <- runBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")
386-- >>> print resp
387-- 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}
388indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
389 -> IndexDocumentSettings -> doc -> DocId -> m Reply
390indexDocument (IndexName indexName)
391 (MappingName mappingName) cfg document (DocId docId) =
392 bindM2 put url (return body)
393 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
394 versionCtlParams = case idsVersionControl cfg of
395 NoVersionControl -> []
396 InternalVersion v -> versionParams v "internal"
397 ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"
398 ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"
399 ForceVersion (ExternalDocVersion v) -> versionParams v "force"
400 vt = T.pack . show . docVersionNumber
401 versionParams v t = [ ("version", Just $ vt v)
402 , ("version_type", Just t)
403 ]
404 parentParams = case idsParent cfg of
405 Nothing -> []
406 Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]
407 params = versionCtlParams ++ parentParams
408 body = Just (encode document)
410-- | 'deleteDocument' is the primary way to delete a single document.
411--
412-- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1")
413deleteDocument :: MonadBH m => IndexName -> MappingName
414 -> DocId -> m Reply
415deleteDocument (IndexName indexName)
416 (MappingName mappingName) (DocId docId) =
417 delete =<< joinPath [indexName, mappingName, docId]
419-- | 'bulk' uses
420-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>
421-- to perform bulk operations. The 'BulkOperation' data type encodes the
422-- index/update/delete/create operations. You pass a 'V.Vector' of 'BulkOperation's
423-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch
424-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
425--
426-- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
427-- >>> _ <- runBH' $ bulk stream
428-- >>> _ <- runBH' $ refreshIndex testIndex
429bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
430bulk bulkOps = bindM2 post url (return body)
431 where url = joinPath ["_bulk"]
432 body = Just $ encodeBulkOperations bulkOps
434-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
435-- into an 'L.ByteString'
436--
437-- >>> let bulkOps = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
438-- >>> encodeBulkOperations bulkOps
439-- "\n{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n"
440encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
441encodeBulkOperations stream = collapsed where
442 blobs = fmap encodeBulkOperation stream
443 mashedTaters = mash (mempty :: Builder) blobs
444 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
446mash :: Builder -> V.Vector L.ByteString -> Builder
447mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))
449mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
450mkBulkStreamValue operation indexName mappingName docId =
451 object [operation .=
452 object [ "_index" .= indexName
453 , "_type" .= mappingName
454 , "_id" .= docId]]
456-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
457-- into an 'L.ByteString'
458--
459-- >>> let bulkOp = BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))
460-- >>> encodeBulkOperation bulkOp
461-- "{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}"
462encodeBulkOperation :: BulkOperation -> L.ByteString
463encodeBulkOperation (BulkIndex (IndexName indexName)
464 (MappingName mappingName)
465 (DocId docId) value) = blob
466 where metadata = mkBulkStreamValue "index" indexName mappingName docId
467 blob = encode metadata `mappend` "\n" `mappend` encode value
469encodeBulkOperation (BulkCreate (IndexName indexName)
470 (MappingName mappingName)
471 (DocId docId) value) = blob
472 where metadata = mkBulkStreamValue "create" indexName mappingName docId
473 blob = encode metadata `mappend` "\n" `mappend` encode value
475encodeBulkOperation (BulkDelete (IndexName indexName)
476 (MappingName mappingName)
477 (DocId docId)) = blob
478 where metadata = mkBulkStreamValue "delete" indexName mappingName docId
479 blob = encode metadata
481encodeBulkOperation (BulkUpdate (IndexName indexName)
482 (MappingName mappingName)
483 (DocId docId) value) = blob
484 where metadata = mkBulkStreamValue "update" indexName mappingName docId
485 doc = object ["doc" .= value]
486 blob = encode metadata `mappend` "\n" `mappend` encode doc
488-- | 'getDocument' is a straight-forward way to fetch a single document from
489-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
490-- The 'DocId' is the primary key for your Elasticsearch document.
491--
492-- >>> yourDoc <- runBH' $ getDocument testIndex testMapping (DocId "1")
493getDocument :: MonadBH m => IndexName -> MappingName
494 -> DocId -> m Reply
495getDocument (IndexName indexName)
496 (MappingName mappingName) (DocId docId) =
497 get =<< joinPath [indexName, mappingName, docId]
499-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
500-- in IO
501--
502-- >>> exists <- runBH' $ documentExists testIndex testMapping Nothing (DocId "1")
503documentExists :: MonadBH m => IndexName -> MappingName
504 -> Maybe DocumentParent -> DocId -> m Bool
505documentExists (IndexName indexName) (MappingName mappingName)
506 parent (DocId docId) = do
507 (_, exists) <- existentialQuery =<< url
508 return exists
509 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
510 parentParam = fmap (\(DocumentParent (DocId p)) -> p) parent
511 params = LS.filter (\(_, v) -> isJust v) [("parent", parentParam)]
513dispatchSearch :: MonadBH m => Text -> Search -> m Reply
514dispatchSearch url search = post url' (Just (encode search))
515 where url' = appendSearchTypeParam url (searchType search)
517-- | 'searchAll', given a 'Search', will perform that search against all indexes
518-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
519--
520-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
521-- >>> let search = mkSearch (Just query) Nothing
522-- >>> reply <- runBH' $ searchAll search
523searchAll :: MonadBH m => Search -> m Reply
524searchAll = bindM2 dispatchSearch url . return
525 where url = joinPath ["_search"]
527-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
528-- against all mappings within an index on an Elasticsearch server.
529--
530-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
531-- >>> let search = mkSearch (Just query) Nothing
532-- >>> reply <- runBH' $ searchByIndex testIndex search
533searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
534searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
535 where url = joinPath [indexName, "_search"]
537-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
538-- search against a specific mapping within an index on an Elasticsearch server.
539--
540-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
541-- >>> let search = mkSearch (Just query) Nothing
542-- >>> reply <- runBH' $ searchByType testIndex testMapping search
543searchByType :: MonadBH m => IndexName -> MappingName -> Search
544 -> m Reply
545searchByType (IndexName indexName)
546 (MappingName mappingName) = bindM2 dispatchSearch url . return
547 where url = joinPath [indexName, mappingName, "_search"]
549scanSearch' :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId)
550scanSearch' (IndexName indexName) (MappingName mappingName) search = do
551 let url = joinPath [indexName, mappingName, "_search"]
552 search' = search { searchType = SearchTypeScan }
553 resp' <- bindM2 dispatchSearch url (return search')
554 let msr = decode' $ responseBody resp' :: Maybe (SearchResult ())
555 msid = maybe Nothing scrollId msr
556 return msid
558scroll' :: (FromJSON a, MonadBH m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId)
559scroll' Nothing = return ([], Nothing)
560scroll' (Just sid) = do
561 url <- joinPath ["_search/scroll?scroll=1m"]
562 resp' <- post url (Just . L.fromStrict $ T.encodeUtf8 sid)
563 let msr = decode' $ responseBody resp' :: FromJSON a => Maybe (SearchResult a)
564 resp = case msr of
565 Just sr -> (hits $ searchHits sr, scrollId sr)
566 _ -> ([], Nothing)
567 return resp
569simpleAccumilator :: (FromJSON a, MonadBH m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId)
570simpleAccumilator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)
571simpleAccumilator oldHits ([], _) = return (oldHits, Nothing)
572simpleAccumilator oldHits (newHits, msid) = do
573 (newHits', msid') <- scroll' msid
574 simpleAccumilator (oldHits ++ newHits) (newHits', msid')
576-- | 'scanSearch' uses the 'scan&scroll' API of elastic,
577-- for a given 'IndexName' and 'MappingName',
578scanSearch :: (FromJSON a, MonadBH m) => IndexName -> MappingName -> Search -> m [Hit a]
579scanSearch indexName mappingName search = do
580 msid <- scanSearch' indexName mappingName search
581 (hits, msid') <- scroll' msid
582 (totalHits, _) <- simpleAccumilator [] (hits, msid')
583 return totalHits
585-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
586-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
587-- syntax if you want to add things like aggregations or highlights while still using
588-- this helper function.
589--
590-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
591-- >>> mkSearch (Just query) Nothing
592-- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}
593mkSearch :: Maybe Query -> Maybe Filter -> Search
594mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
596-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
597-- the 'Query' and the 'Aggregation'.
598--
599-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
600-- >>> terms
601-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
602-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
603mkAggregateSearch :: Maybe Query -> Aggregations -> Search
604mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing
606-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
607-- the 'Query' and the 'Aggregation'.
608--
609-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
610-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
611-- >>> let search = mkHighlightSearch (Just query) testHighlight
612mkHighlightSearch :: Maybe Query -> Highlights -> Search
613mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
615-- | 'pageSearch' is a helper function that takes a search and assigns the from
616-- and size fields for the search. The from parameter defines the offset
617-- from the first result you want to fetch. The size parameter allows you to
618-- configure the maximum amount of hits to be returned.
619--
620-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
621-- >>> let search = mkSearch (Just query) Nothing
622-- >>> search
623-- 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, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}
624-- >>> pageSearch (From 10) (Size 100) search
625-- 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, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}
626pageSearch :: From -- ^ The result offset
627 -> Size -- ^ The number of results to return
628 -> Search -- ^ The current seach
629 -> Search -- ^ The paged search
630pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
632parseUrl' :: MonadThrow m => Text -> m Request
633parseUrl' t = parseUrl (URI.escapeURIString URI.isAllowedInURI (T.unpack t))
635-- | Was there an optimistic concurrency control conflict when
636-- indexing a document?
637isVersionConflict :: Reply -> Bool
638isVersionConflict = statusCheck (== 409)
640isSuccess :: Reply -> Bool
641isSuccess = statusCheck (inRange (200, 299))
643isCreated :: Reply -> Bool
644isCreated = statusCheck (== 201)
646statusCheck :: (Int -> Bool) -> Reply -> Bool
647statusCheck prd = prd . NHTS.statusCode . responseStatus