1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RecordWildCards #-}
4-------------------------------------------------------------------------------
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
13-- Client side functions for talking to Elasticsearch servers.
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.
53 , encodeBulkOperations
55 -- * Reply-handling tools
62import qualified Blaze.ByteString.Builder as BB
63import Control.Applicative
65import Control.Monad.Catch
66import Control.Monad.IO.Class
68import Data.ByteString.Lazy.Builder
69import qualified Data.ByteString.Lazy.Char8 as L
70import Data.Foldable (toList)
71import qualified Data.HashMap.Strict as HM
73import qualified Data.List as LS (filter, foldl')
74import Data.List.NonEmpty (NonEmpty (..))
75import Data.Maybe (fromMaybe, isJust)
77import Data.Text (Text)
78import qualified Data.Text as T
79import qualified Data.Text.Encoding as T
80import qualified Data.Vector as V
81import Network.HTTP.Client
82import qualified Network.HTTP.Types.Method as NHTM
83import qualified Network.HTTP.Types.Status as NHTS
84import qualified Network.HTTP.Types.URI as NHTU
85import qualified Network.URI as URI
86import Prelude hiding (filter, head)
88import Database.Bloodhound.Types
91-- >>> :set -XOverloadedStrings
92-- >>> :set -XDeriveGeneric
93-- >>> import Database.Bloodhound
94-- >>> import Test.DocTest.Prop (assert)
95-- >>> let testServer = (Server "http://localhost:9200")
96-- >>> let runBH' = withBH defaultManagerSettings testServer
97-- >>> let testIndex = IndexName "twitter"
98-- >>> let testMapping = MappingName "tweet"
99-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)
100-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)
101-- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping
102-- >>> import GHC.Generics
103-- >>> import Data.Time.Calendar (Day (..))
104-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
106--instance ToJSON TweetMapping where
107-- toJSON TweetMapping =
109-- object ["properties" .=
110-- object ["location" .=
111-- object ["type" .= ("geo_point" :: Text)]]]]
112--data Location = Location { lat :: Double
113-- , lon :: Double } deriving (Eq, Generic, Show)
114--data Tweet = Tweet { user :: Text
115-- , postDate :: UTCTime
118-- , location :: Location } deriving (Eq, Generic, Show)
119--exampleTweet = Tweet { user = "bitemyapp"
120-- , postDate = UTCTime
121-- (ModifiedJulianDay 55000)
122-- (secondsToDiffTime 10)
123-- , message = "Use haskell!"
125-- , location = Location 40.12 (-71.34) }
126--instance ToJSON Tweet where
127-- toJSON = genericToJSON defaultOptions
128--instance FromJSON Tweet where
129-- parseJSON = genericParseJSON defaultOptions
130--instance ToJSON Location where
131-- toJSON = genericToJSON defaultOptions
132--instance FromJSON Location where
133-- parseJSON = genericParseJSON defaultOptions
134--data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
135--instance FromJSON BulkTest where
136-- parseJSON = genericParseJSON defaultOptions
137--instance ToJSON BulkTest where
138-- toJSON = genericToJSON defaultOptions
141-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'
142-- which rejects 'Int' values below 1 and above 1000.
144-- >>> mkShardCount 10
145-- Just (ShardCount 10)
146mkShardCount :: Int -> Maybe ShardCount
150 | otherwise = Just (ShardCount n)
152-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'
153-- which rejects 'Int' values below 1 and above 1000.
155-- >>> mkReplicaCount 10
156-- Just (ReplicaCount 10)
157mkReplicaCount :: Int -> Maybe ReplicaCount
160 | n > 1000 = Nothing -- ...
161 | otherwise = Just (ReplicaCount n)
163emptyBody :: L.ByteString
166dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString
168dispatch dMethod url body = do
169 initReq <- liftIO $ parseUrl' url
170 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
171 let req = initReq { method = dMethod
172 , requestBody = reqBody
173 , checkStatus = \_ _ _ -> Nothing}
174 mgr <- bhManager <$> getBHEnv
175 liftIO $ httpLbs req mgr
177joinPath' :: [Text] -> Text
178joinPath' = T.intercalate "/"
180joinPath :: MonadBH m => [Text] -> m Text
182 Server s <- bhServer <$> getBHEnv
183 return $ joinPath' (s:ps)
185appendSearchTypeParam :: Text -> SearchType -> Text
186appendSearchTypeParam originalUrl st = addQuery params originalUrl
187 where stText = "search_type"
189 | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")]
190 | st == SearchTypeCount = [(stText, Just "count")]
191 | st == SearchTypeScan = [(stText, Just "scan"), ("scroll", Just "1m")]
192 | st == SearchTypeQueryAndFetch = [(stText, Just "query_and_fetch")]
193 | st == SearchTypeDfsQueryAndFetch = [(stText, Just "dfs_query_and_fetch")]
194 -- used to catch 'SearchTypeQueryThenFetch', which is also the default
195 | otherwise = [(stText, Just "query_then_fetch")]
197-- | Severely dumbed down query renderer. Assumes your data doesn't
199addQuery :: [(Text, Maybe Text)] -> Text -> Text
200addQuery q u = u <> rendered
203 T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q
204 prependQuestionMark = True
206bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
207bindM2 f ma mb = join (f <$> ma <*> mb)
209-- | Convenience function that sets up a manager and BHEnv and runs
210-- the given set of bloodhound operations. Connections will be
211-- pipelined automatically in accordance with the given manager
212-- settings in IO. If you've got your own monad transformer stack, you
213-- should use 'runBH' directly.
214withBH :: ManagerSettings -> Server -> BH IO a -> IO a
217 let env = BHEnv { bhServer = s
221-- Shortcut functions for HTTP methods
222delete :: MonadBH m => Text -> m Reply
223delete = flip (dispatch NHTM.methodDelete) Nothing
224get :: MonadBH m => Text -> m Reply
225get = flip (dispatch NHTM.methodGet) Nothing
226head :: MonadBH m => Text -> m Reply
227head = flip (dispatch NHTM.methodHead) Nothing
228put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
229put = dispatch NHTM.methodPut
230post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
231post = dispatch NHTM.methodPost
233-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
234-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
235-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
237-- | 'getStatus' fetches the 'Status' of a 'Server'
239-- >>> serverStatus <- runBH' getStatus
240-- >>> fmap status (serverStatus)
242getStatus :: MonadBH m => m (Maybe Status)
245 request <- liftIO $ parseUrl' url
246 mgr <- bhManager <$> getBHEnv
247 response <- liftIO $ httpLbs request mgr
248 return $ decode (responseBody response)
250-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
252-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
253-- >>> respIsTwoHunna response
255-- >>> runBH' $ indexExists (IndexName "didimakeanindex")
257createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply
258createIndex indexSettings (IndexName indexName) =
259 bindM2 put url (return body)
260 where url = joinPath [indexName]
261 body = Just $ encode indexSettings
264-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
266-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
267-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
268-- >>> respIsTwoHunna response
270-- >>> runBH' $ indexExists testIndex
272deleteIndex :: MonadBH m => IndexName -> m Reply
273deleteIndex (IndexName indexName) =
274 delete =<< joinPath [indexName]
276-- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index
278-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "unconfiguredindex")
279-- >>> response <- runBH' $ updateIndexSettings (BlocksWrite False :| []) (IndexName "unconfiguredindex")
280-- >>> respIsTwoHunna response
282updateIndexSettings :: MonadBH m => NonEmpty UpdatableIndexSetting -> IndexName -> m Reply
283updateIndexSettings updates (IndexName indexName) =
284 bindM2 put url (return body)
285 where url = joinPath [indexName, "_settings"]
286 body = Just (encode jsonBody)
287 jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])
290--TODO: This feels a little nicer than returning a reply and coyly
291--implying that it *should* be an IndexSettingsSummary
292getIndexSettings :: MonadBH m => IndexName -> m (Either EsError IndexSettingsSummary)
293getIndexSettings (IndexName indexName) = undefined
297deepMerge :: [Object] -> Object
298deepMerge = LS.foldl' go mempty
299 where go acc = LS.foldl' go' acc . HM.toList
300 go' acc (k, v) = HM.insertWith merge k v acc
301 merge (Object a) (Object b) = Object (deepMerge [a, b])
305statusCodeIs :: Int -> Reply -> Bool
306statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n
308respIsTwoHunna :: Reply -> Bool
309respIsTwoHunna = statusCodeIs 200
311existentialQuery :: MonadBH m => Text -> m (Reply, Bool)
312existentialQuery url = do
314 return (reply, respIsTwoHunna reply)
316-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
319-- >>> exists <- runBH' $ indexExists testIndex
320indexExists :: MonadBH m => IndexName -> m Bool
321indexExists (IndexName indexName) = do
322 (_, exists) <- existentialQuery =<< joinPath [indexName]
325-- | 'refreshIndex' will force a refresh on an index. You must
326-- do this if you want to read what you wrote.
328-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
329-- >>> _ <- runBH' $ refreshIndex testIndex
330refreshIndex :: MonadBH m => IndexName -> m Reply
331refreshIndex (IndexName indexName) =
332 bindM2 post url (return Nothing)
333 where url = joinPath [indexName, "_refresh"]
335stringifyOCIndex :: OpenCloseIndex -> Text
336stringifyOCIndex oci = case oci of
338 CloseIndex -> "_close"
340openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply
341openOrCloseIndexes oci (IndexName indexName) =
342 bindM2 post url (return Nothing)
343 where ociString = stringifyOCIndex oci
344 url = joinPath [indexName, ociString]
346-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
347-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
349-- >>> reply <- runBH' $ openIndex testIndex
350openIndex :: MonadBH m => IndexName -> m Reply
351openIndex = openOrCloseIndexes OpenIndex
353-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
354-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
356-- >>> reply <- runBH' $ closeIndex testIndex
357closeIndex :: MonadBH m => IndexName -> m Reply
358closeIndex = openOrCloseIndexes CloseIndex
360-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.
361-- Explained in further detail at
362-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>
364-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
365-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
366putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply
367putTemplate indexTemplate (TemplateName templateName) =
368 bindM2 put url (return body)
369 where url = joinPath ["_template", templateName]
370 body = Just $ encode indexTemplate
372-- | 'templateExists' checks to see if a template exists.
374-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")
375templateExists :: MonadBH m => TemplateName -> m Bool
376templateExists (TemplateName templateName) = do
377 (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
380-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
382-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
383-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
384-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")
385deleteTemplate :: MonadBH m => TemplateName -> m Reply
386deleteTemplate (TemplateName templateName) =
387 delete =<< joinPath ["_template", templateName]
389-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
390-- for documents in indexes.
392-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
393-- >>> resp <- runBH' $ putMapping testIndex testMapping TweetMapping
395-- 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}
396putMapping :: (MonadBH m, ToJSON a) => IndexName
397 -> MappingName -> a -> m Reply
398putMapping (IndexName indexName) (MappingName mappingName) mapping =
399 bindM2 put url (return body)
400 where url = joinPath [indexName, "_mapping", mappingName]
401 -- "_mapping" and mappingName above were originally transposed
402 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
403 body = Just $ encode mapping
405-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
406-- Mappings are schemas for documents in indexes.
408-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
409-- >>> _ <- runBH' $ putMapping testIndex testMapping TweetMapping
410-- >>> resp <- runBH' $ deleteMapping testIndex testMapping
412-- 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}
413deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
414deleteMapping (IndexName indexName)
415 (MappingName mappingName) =
416 -- "_mapping" and mappingName below were originally transposed
417 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
418 delete =<< joinPath [indexName, "_mapping", mappingName]
420-- | 'indexDocument' is the primary way to save a single document in
421-- Elasticsearch. The document itself is simply something we can
422-- convert into a JSON 'Value'. The 'DocId' will function as the
423-- primary key for the document.
425-- >>> resp <- runBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")
427-- 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}
428indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
429 -> IndexDocumentSettings -> doc -> DocId -> m Reply
430indexDocument (IndexName indexName)
431 (MappingName mappingName) cfg document (DocId docId) =
432 bindM2 put url (return body)
433 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
434 versionCtlParams = case idsVersionControl cfg of
435 NoVersionControl -> []
436 InternalVersion v -> versionParams v "internal"
437 ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"
438 ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"
439 ForceVersion (ExternalDocVersion v) -> versionParams v "force"
440 vt = T.pack . show . docVersionNumber
441 versionParams v t = [ ("version", Just $ vt v)
442 , ("version_type", Just t)
444 parentParams = case idsParent cfg of
446 Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]
447 params = versionCtlParams ++ parentParams
448 body = Just (encode document)
450-- | 'deleteDocument' is the primary way to delete a single document.
452-- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1")
453deleteDocument :: MonadBH m => IndexName -> MappingName
455deleteDocument (IndexName indexName)
456 (MappingName mappingName) (DocId docId) =
457 delete =<< joinPath [indexName, mappingName, docId]
460-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>
461-- to perform bulk operations. The 'BulkOperation' data type encodes the
462-- index/update/delete/create operations. You pass a 'V.Vector' of 'BulkOperation's
463-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch
464-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
466-- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
467-- >>> _ <- runBH' $ bulk stream
468-- >>> _ <- runBH' $ refreshIndex testIndex
469bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
470bulk bulkOps = bindM2 post url (return body)
471 where url = joinPath ["_bulk"]
472 body = Just $ encodeBulkOperations bulkOps
474-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
475-- into an 'L.ByteString'
477-- >>> let bulkOps = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
478-- >>> encodeBulkOperations bulkOps
479-- "\n{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n"
480encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
481encodeBulkOperations stream = collapsed where
482 blobs = fmap encodeBulkOperation stream
483 mashedTaters = mash (mempty :: Builder) blobs
484 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
486mash :: Builder -> V.Vector L.ByteString -> Builder
487mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))
489mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
490mkBulkStreamValue operation indexName mappingName docId =
492 object [ "_index" .= indexName
493 , "_type" .= mappingName
496-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
497-- into an 'L.ByteString'
499-- >>> let bulkOp = BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))
500-- >>> encodeBulkOperation bulkOp
501-- "{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}"
502encodeBulkOperation :: BulkOperation -> L.ByteString
503encodeBulkOperation (BulkIndex (IndexName indexName)
504 (MappingName mappingName)
505 (DocId docId) value) = blob
506 where metadata = mkBulkStreamValue "index" indexName mappingName docId
507 blob = encode metadata `mappend` "\n" `mappend` encode value
509encodeBulkOperation (BulkCreate (IndexName indexName)
510 (MappingName mappingName)
511 (DocId docId) value) = blob
512 where metadata = mkBulkStreamValue "create" indexName mappingName docId
513 blob = encode metadata `mappend` "\n" `mappend` encode value
515encodeBulkOperation (BulkDelete (IndexName indexName)
516 (MappingName mappingName)
517 (DocId docId)) = blob
518 where metadata = mkBulkStreamValue "delete" indexName mappingName docId
519 blob = encode metadata
521encodeBulkOperation (BulkUpdate (IndexName indexName)
522 (MappingName mappingName)
523 (DocId docId) value) = blob
524 where metadata = mkBulkStreamValue "update" indexName mappingName docId
525 doc = object ["doc" .= value]
526 blob = encode metadata `mappend` "\n" `mappend` encode doc
528-- | 'getDocument' is a straight-forward way to fetch a single document from
529-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
530-- The 'DocId' is the primary key for your Elasticsearch document.
532-- >>> yourDoc <- runBH' $ getDocument testIndex testMapping (DocId "1")
533getDocument :: MonadBH m => IndexName -> MappingName
535getDocument (IndexName indexName)
536 (MappingName mappingName) (DocId docId) =
537 get =<< joinPath [indexName, mappingName, docId]
539-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
542-- >>> exists <- runBH' $ documentExists testIndex testMapping Nothing (DocId "1")
543documentExists :: MonadBH m => IndexName -> MappingName
544 -> Maybe DocumentParent -> DocId -> m Bool
545documentExists (IndexName indexName) (MappingName mappingName)
546 parent (DocId docId) = do
547 (_, exists) <- existentialQuery =<< url
549 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
550 parentParam = fmap (\(DocumentParent (DocId p)) -> p) parent
551 params = LS.filter (\(_, v) -> isJust v) [("parent", parentParam)]
553dispatchSearch :: MonadBH m => Text -> Search -> m Reply
554dispatchSearch url search = post url' (Just (encode search))
555 where url' = appendSearchTypeParam url (searchType search)
557-- | 'searchAll', given a 'Search', will perform that search against all indexes
558-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
560-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
561-- >>> let search = mkSearch (Just query) Nothing
562-- >>> reply <- runBH' $ searchAll search
563searchAll :: MonadBH m => Search -> m Reply
564searchAll = bindM2 dispatchSearch url . return
565 where url = joinPath ["_search"]
567-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
568-- against all mappings within an index on an Elasticsearch server.
570-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
571-- >>> let search = mkSearch (Just query) Nothing
572-- >>> reply <- runBH' $ searchByIndex testIndex search
573searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
574searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
575 where url = joinPath [indexName, "_search"]
577-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
578-- search against a specific mapping within an index on an Elasticsearch server.
580-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
581-- >>> let search = mkSearch (Just query) Nothing
582-- >>> reply <- runBH' $ searchByType testIndex testMapping search
583searchByType :: MonadBH m => IndexName -> MappingName -> Search
585searchByType (IndexName indexName)
586 (MappingName mappingName) = bindM2 dispatchSearch url . return
587 where url = joinPath [indexName, mappingName, "_search"]
589scanSearch' :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId)
590scanSearch' (IndexName indexName) (MappingName mappingName) search = do
591 let url = joinPath [indexName, mappingName, "_search"]
592 search' = search { searchType = SearchTypeScan }
593 resp' <- bindM2 dispatchSearch url (return search')
594 let msr = decode' $ responseBody resp' :: Maybe (SearchResult ())
595 msid = maybe Nothing scrollId msr
598scroll' :: (FromJSON a, MonadBH m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId)
599scroll' Nothing = return ([], Nothing)
600scroll' (Just sid) = do
601 url <- joinPath ["_search/scroll?scroll=1m"]
602 resp' <- post url (Just . L.fromStrict $ T.encodeUtf8 sid)
603 let msr = decode' $ responseBody resp' :: FromJSON a => Maybe (SearchResult a)
605 Just sr -> (hits $ searchHits sr, scrollId sr)
609simpleAccumilator :: (FromJSON a, MonadBH m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId)
610simpleAccumilator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)
611simpleAccumilator oldHits ([], _) = return (oldHits, Nothing)
612simpleAccumilator oldHits (newHits, msid) = do
613 (newHits', msid') <- scroll' msid
614 simpleAccumilator (oldHits ++ newHits) (newHits', msid')
616-- | 'scanSearch' uses the 'scan&scroll' API of elastic,
617-- for a given 'IndexName' and 'MappingName',
618scanSearch :: (FromJSON a, MonadBH m) => IndexName -> MappingName -> Search -> m [Hit a]
619scanSearch indexName mappingName search = do
620 msid <- scanSearch' indexName mappingName search
621 (hits, msid') <- scroll' msid
622 (totalHits, _) <- simpleAccumilator [] (hits, msid')
625-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
626-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
627-- syntax if you want to add things like aggregations or highlights while still using
628-- this helper function.
630-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
631-- >>> mkSearch (Just query) Nothing
632-- 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}
633mkSearch :: Maybe Query -> Maybe Filter -> Search
634mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
636-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
637-- the 'Query' and the 'Aggregation'.
639-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
641-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
642-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
643mkAggregateSearch :: Maybe Query -> Aggregations -> Search
644mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing
646-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
647-- the 'Query' and the 'Aggregation'.
649-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
650-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
651-- >>> let search = mkHighlightSearch (Just query) testHighlight
652mkHighlightSearch :: Maybe Query -> Highlights -> Search
653mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
655-- | 'pageSearch' is a helper function that takes a search and assigns the from
656-- and size fields for the search. The from parameter defines the offset
657-- from the first result you want to fetch. The size parameter allows you to
658-- configure the maximum amount of hits to be returned.
660-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
661-- >>> let search = mkSearch (Just query) Nothing
663-- 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}
664-- >>> pageSearch (From 10) (Size 100) search
665-- 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}
666pageSearch :: From -- ^ The result offset
667 -> Size -- ^ The number of results to return
668 -> Search -- ^ The current seach
669 -> Search -- ^ The paged search
670pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
672parseUrl' :: MonadThrow m => Text -> m Request
673parseUrl' t = parseUrl (URI.escapeURIString URI.isAllowedInURI (T.unpack t))
675-- | Was there an optimistic concurrency control conflict when
676-- indexing a document?
677isVersionConflict :: Reply -> Bool
678isVersionConflict = statusCheck (== 409)
680isSuccess :: Reply -> Bool
681isSuccess = statusCheck (inRange (200, 299))
683isCreated :: Reply -> Bool
684isCreated = statusCheck (== 201)
686statusCheck :: (Int -> Bool) -> Reply -> Bool
687statusCheck prd = prd . NHTS.statusCode . responseStatus
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list