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.
52 , encodeBulkOperations
54 -- * Reply-handling tools
61import qualified Blaze.ByteString.Builder as BB
62import Control.Applicative
64import Control.Monad.Catch
65import Control.Monad.IO.Class
67import Data.ByteString.Lazy.Builder
68import qualified Data.ByteString.Lazy.Char8 as L
70import qualified Data.List as LS (filter)
71import Data.Maybe (fromMaybe, isJust)
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
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)
102--instance ToJSON TweetMapping where
103-- toJSON TweetMapping =
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
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!"
121-- , location = Location 40.12 (-71.34) }
122--instance ToJSON Tweet where
123-- toJSON = genericToJSON defaultOptions
124--instance FromJSON Tweet where
125-- parseJSON = genericParseJSON defaultOptions
126--instance ToJSON Location where
127-- toJSON = genericToJSON defaultOptions
128--instance FromJSON Location where
129-- parseJSON = genericParseJSON defaultOptions
130--data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
131--instance FromJSON BulkTest where
132-- parseJSON = genericParseJSON defaultOptions
133--instance ToJSON BulkTest where
134-- toJSON = genericToJSON defaultOptions
137-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'
138-- which rejects 'Int' values below 1 and above 1000.
140-- >>> mkShardCount 10
141-- Just (ShardCount 10)
142mkShardCount :: Int -> Maybe ShardCount
146 | otherwise = Just (ShardCount n)
148-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'
149-- which rejects 'Int' values below 1 and above 1000.
151-- >>> mkReplicaCount 10
152-- Just (ReplicaCount 10)
153mkReplicaCount :: Int -> Maybe ReplicaCount
156 | n > 1000 = Nothing -- ...
157 | otherwise = Just (ReplicaCount n)
159emptyBody :: L.ByteString
162dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString
164dispatch dMethod url body = do
165 initReq <- liftIO $ parseUrl' url
166 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
167 let req = initReq { method = dMethod
168 , requestBody = reqBody
169 , checkStatus = \_ _ _ -> Nothing}
170 mgr <- bhManager <$> getBHEnv
171 liftIO $ httpLbs req mgr
173joinPath' :: [Text] -> Text
174joinPath' = T.intercalate "/"
176joinPath :: MonadBH m => [Text] -> m Text
178 Server s <- bhServer <$> getBHEnv
179 return $ joinPath' (s:ps)
181appendSearchTypeParam :: Text -> SearchType -> Text
182appendSearchTypeParam originalUrl st = addQuery params originalUrl
183 where stText = "search_type"
185 | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")]
186 | st == SearchTypeCount = [(stText, Just "count")]
187 | st == SearchTypeScan = [(stText, Just "scan"), ("scroll", Just "1m")]
188 | st == SearchTypeQueryAndFetch = [(stText, Just "query_and_fetch")]
189 | st == SearchTypeDfsQueryAndFetch = [(stText, Just "dfs_query_and_fetch")]
190 -- used to catch 'SearchTypeQueryThenFetch', which is also the default
191 | otherwise = [(stText, Just "query_then_fetch")]
193-- | Severely dumbed down query renderer. Assumes your data doesn't
195addQuery :: [(Text, Maybe Text)] -> Text -> Text
196addQuery q u = u <> rendered
199 T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q
200 prependQuestionMark = True
202bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
203bindM2 f ma mb = join (f <$> ma <*> mb)
205-- | Convenience function that sets up a manager and BHEnv and runs
206-- the given set of bloodhound operations. Connections will be
207-- pipelined automatically in accordance with the given manager
208-- settings in IO. If you've got your own monad transformer stack, you
209-- should use 'runBH' directly.
210withBH :: ManagerSettings -> Server -> BH IO a -> IO a
213 let env = BHEnv { bhServer = s
217-- Shortcut functions for HTTP methods
218delete :: MonadBH m => Text -> m Reply
219delete = flip (dispatch NHTM.methodDelete) Nothing
220get :: MonadBH m => Text -> m Reply
221get = flip (dispatch NHTM.methodGet) Nothing
222head :: MonadBH m => Text -> m Reply
223head = flip (dispatch NHTM.methodHead) Nothing
224put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
225put = dispatch NHTM.methodPut
226post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
227post = dispatch NHTM.methodPost
229-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
230-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
231-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
233-- | 'getStatus' fetches the 'Status' of a 'Server'
235-- >>> serverStatus <- runBH' getStatus
236-- >>> fmap status (serverStatus)
238getStatus :: MonadBH m => m (Maybe Status)
241 request <- liftIO $ parseUrl' url
242 mgr <- bhManager <$> getBHEnv
243 response <- liftIO $ httpLbs request mgr
244 return $ decode (responseBody response)
246-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
248-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
249-- >>> respIsTwoHunna response
251-- >>> runBH' $ indexExists (IndexName "didimakeanindex")
253createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply
254createIndex indexSettings (IndexName indexName) =
255 bindM2 put url (return body)
256 where url = joinPath [indexName]
257 body = Just $ encode indexSettings
259-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
261-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
262-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
263-- >>> respIsTwoHunna response
265-- >>> runBH' $ indexExists testIndex
267deleteIndex :: MonadBH m => IndexName -> m Reply
268deleteIndex (IndexName indexName) =
269 delete =<< joinPath [indexName]
271statusCodeIs :: Int -> Reply -> Bool
272statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n
274respIsTwoHunna :: Reply -> Bool
275respIsTwoHunna = statusCodeIs 200
277existentialQuery :: MonadBH m => Text -> m (Reply, Bool)
278existentialQuery url = do
280 return (reply, respIsTwoHunna reply)
282-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
285-- >>> exists <- runBH' $ indexExists testIndex
286indexExists :: MonadBH m => IndexName -> m Bool
287indexExists (IndexName indexName) = do
288 (_, exists) <- existentialQuery =<< joinPath [indexName]
291-- | 'refreshIndex' will force a refresh on an index. You must
292-- do this if you want to read what you wrote.
294-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
295-- >>> _ <- runBH' $ refreshIndex testIndex
296refreshIndex :: MonadBH m => IndexName -> m Reply
297refreshIndex (IndexName indexName) =
298 bindM2 post url (return Nothing)
299 where url = joinPath [indexName, "_refresh"]
301stringifyOCIndex :: OpenCloseIndex -> Text
302stringifyOCIndex oci = case oci of
304 CloseIndex -> "_close"
306openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply
307openOrCloseIndexes oci (IndexName indexName) =
308 bindM2 post url (return Nothing)
309 where ociString = stringifyOCIndex oci
310 url = joinPath [indexName, ociString]
312-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
313-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
315-- >>> reply <- runBH' $ openIndex testIndex
316openIndex :: MonadBH m => IndexName -> m Reply
317openIndex = openOrCloseIndexes OpenIndex
319-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
320-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
322-- >>> reply <- runBH' $ closeIndex testIndex
323closeIndex :: MonadBH m => IndexName -> m Reply
324closeIndex = openOrCloseIndexes CloseIndex
326-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.
327-- Explained in further detail at
328-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>
330-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
331-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
332putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply
333putTemplate indexTemplate (TemplateName templateName) =
334 bindM2 put url (return body)
335 where url = joinPath ["_template", templateName]
336 body = Just $ encode indexTemplate
338-- | 'templateExists' checks to see if a template exists.
340-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")
341templateExists :: MonadBH m => TemplateName -> m Bool
342templateExists (TemplateName templateName) = do
343 (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
346-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
348-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
349-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
350-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")
351deleteTemplate :: MonadBH m => TemplateName -> m Reply
352deleteTemplate (TemplateName templateName) =
353 delete =<< joinPath ["_template", templateName]
355-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
356-- for documents in indexes.
358-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
359-- >>> resp <- runBH' $ putMapping testIndex testMapping TweetMapping
361-- 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}
362putMapping :: (MonadBH m, ToJSON a) => IndexName
363 -> MappingName -> a -> m Reply
364putMapping (IndexName indexName) (MappingName mappingName) mapping =
365 bindM2 put url (return body)
366 where url = joinPath [indexName, "_mapping", mappingName]
367 -- "_mapping" and mappingName above were originally transposed
368 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
369 body = Just $ encode mapping
371-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
372-- Mappings are schemas for documents in indexes.
374-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
375-- >>> _ <- runBH' $ putMapping testIndex testMapping TweetMapping
376-- >>> resp <- runBH' $ deleteMapping testIndex testMapping
378-- 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}
379deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
380deleteMapping (IndexName indexName)
381 (MappingName mappingName) =
382 -- "_mapping" and mappingName below were originally transposed
383 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
384 delete =<< joinPath [indexName, "_mapping", mappingName]
386-- | 'indexDocument' is the primary way to save a single document in
387-- Elasticsearch. The document itself is simply something we can
388-- convert into a JSON 'Value'. The 'DocId' will function as the
389-- primary key for the document.
391-- >>> resp <- runBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")
393-- 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}
394indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
395 -> IndexDocumentSettings -> doc -> DocId -> m Reply
396indexDocument (IndexName indexName)
397 (MappingName mappingName) cfg document (DocId docId) =
398 bindM2 put url (return body)
399 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
400 versionCtlParams = case idsVersionControl cfg of
401 NoVersionControl -> []
402 InternalVersion v -> versionParams v "internal"
403 ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"
404 ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"
405 ForceVersion (ExternalDocVersion v) -> versionParams v "force"
406 vt = T.pack . show . docVersionNumber
407 versionParams v t = [ ("version", Just $ vt v)
408 , ("version_type", Just t)
410 parentParams = case idsParent cfg of
412 Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]
413 params = versionCtlParams ++ parentParams
414 body = Just (encode document)
416-- | 'deleteDocument' is the primary way to delete a single document.
418-- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1")
419deleteDocument :: MonadBH m => IndexName -> MappingName
421deleteDocument (IndexName indexName)
422 (MappingName mappingName) (DocId docId) =
423 delete =<< joinPath [indexName, mappingName, docId]
426-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>
427-- to perform bulk operations. The 'BulkOperation' data type encodes the
428-- index/update/delete/create operations. You pass a 'V.Vector' of 'BulkOperation's
429-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch
430-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
432-- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
433-- >>> _ <- runBH' $ bulk stream
434-- >>> _ <- runBH' $ refreshIndex testIndex
435bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
436bulk bulkOps = bindM2 post url (return body)
437 where url = joinPath ["_bulk"]
438 body = Just $ encodeBulkOperations bulkOps
440-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
441-- into an 'L.ByteString'
443-- >>> let bulkOps = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
444-- >>> encodeBulkOperations bulkOps
445-- "\n{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n"
446encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
447encodeBulkOperations stream = collapsed where
448 blobs = fmap encodeBulkOperation stream
449 mashedTaters = mash (mempty :: Builder) blobs
450 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
452mash :: Builder -> V.Vector L.ByteString -> Builder
453mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))
455mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
456mkBulkStreamValue operation indexName mappingName docId =
458 object [ "_index" .= indexName
459 , "_type" .= mappingName
462-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
463-- into an 'L.ByteString'
465-- >>> let bulkOp = BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))
466-- >>> encodeBulkOperation bulkOp
467-- "{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}"
468encodeBulkOperation :: BulkOperation -> L.ByteString
469encodeBulkOperation (BulkIndex (IndexName indexName)
470 (MappingName mappingName)
471 (DocId docId) value) = blob
472 where metadata = mkBulkStreamValue "index" indexName mappingName docId
473 blob = encode metadata `mappend` "\n" `mappend` encode value
475encodeBulkOperation (BulkCreate (IndexName indexName)
476 (MappingName mappingName)
477 (DocId docId) value) = blob
478 where metadata = mkBulkStreamValue "create" indexName mappingName docId
479 blob = encode metadata `mappend` "\n" `mappend` encode value
481encodeBulkOperation (BulkDelete (IndexName indexName)
482 (MappingName mappingName)
483 (DocId docId)) = blob
484 where metadata = mkBulkStreamValue "delete" indexName mappingName docId
485 blob = encode metadata
487encodeBulkOperation (BulkUpdate (IndexName indexName)
488 (MappingName mappingName)
489 (DocId docId) value) = blob
490 where metadata = mkBulkStreamValue "update" indexName mappingName docId
491 doc = object ["doc" .= value]
492 blob = encode metadata `mappend` "\n" `mappend` encode doc
494-- | 'getDocument' is a straight-forward way to fetch a single document from
495-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
496-- The 'DocId' is the primary key for your Elasticsearch document.
498-- >>> yourDoc <- runBH' $ getDocument testIndex testMapping (DocId "1")
499getDocument :: MonadBH m => IndexName -> MappingName
501getDocument (IndexName indexName)
502 (MappingName mappingName) (DocId docId) =
503 get =<< joinPath [indexName, mappingName, docId]
505-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
508-- >>> exists <- runBH' $ documentExists testIndex testMapping Nothing (DocId "1")
509documentExists :: MonadBH m => IndexName -> MappingName
510 -> Maybe DocumentParent -> DocId -> m Bool
511documentExists (IndexName indexName) (MappingName mappingName)
512 parent (DocId docId) = do
513 (_, exists) <- existentialQuery =<< url
515 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
516 parentParam = fmap (\(DocumentParent (DocId p)) -> p) parent
517 params = LS.filter (\(_, v) -> isJust v) [("parent", parentParam)]
519dispatchSearch :: MonadBH m => Text -> Search -> m Reply
520dispatchSearch url search = post url' (Just (encode search))
521 where url' = appendSearchTypeParam url (searchType search)
523-- | 'searchAll', given a 'Search', will perform that search against all indexes
524-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
526-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
527-- >>> let search = mkSearch (Just query) Nothing
528-- >>> reply <- runBH' $ searchAll search
529searchAll :: MonadBH m => Search -> m Reply
530searchAll = bindM2 dispatchSearch url . return
531 where url = joinPath ["_search"]
533-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
534-- against all mappings within an index on an Elasticsearch server.
536-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
537-- >>> let search = mkSearch (Just query) Nothing
538-- >>> reply <- runBH' $ searchByIndex testIndex search
539searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
540searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
541 where url = joinPath [indexName, "_search"]
543-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
544-- search against a specific mapping within an index on an Elasticsearch server.
546-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
547-- >>> let search = mkSearch (Just query) Nothing
548-- >>> reply <- runBH' $ searchByType testIndex testMapping search
549searchByType :: MonadBH m => IndexName -> MappingName -> Search
551searchByType (IndexName indexName)
552 (MappingName mappingName) = bindM2 dispatchSearch url . return
553 where url = joinPath [indexName, mappingName, "_search"]
555scanSearch' :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId)
556scanSearch' (IndexName indexName) (MappingName mappingName) search = do
557 let url = joinPath [indexName, mappingName, "_search"]
558 search' = search { searchType = SearchTypeScan }
559 resp' <- bindM2 dispatchSearch url (return search')
560 let msr = decode' $ responseBody resp' :: Maybe (SearchResult ())
561 msid = maybe Nothing scrollId msr
564scroll' :: (FromJSON a, MonadBH m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId)
565scroll' Nothing = return ([], Nothing)
566scroll' (Just sid) = do
567 url <- joinPath ["_search/scroll?scroll=1m"]
568 resp' <- post url (Just . L.fromStrict $ T.encodeUtf8 sid)
569 let msr = decode' $ responseBody resp' :: FromJSON a => Maybe (SearchResult a)
571 Just sr -> (hits $ searchHits sr, scrollId sr)
575simpleAccumilator :: (FromJSON a, MonadBH m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId)
576simpleAccumilator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)
577simpleAccumilator oldHits ([], _) = return (oldHits, Nothing)
578simpleAccumilator oldHits (newHits, msid) = do
579 (newHits', msid') <- scroll' msid
580 simpleAccumilator (oldHits ++ newHits) (newHits', msid')
582-- | 'scanSearch' uses the 'scan&scroll' API of elastic,
583-- for a given 'IndexName' and 'MappingName',
584scanSearch :: (FromJSON a, MonadBH m) => IndexName -> MappingName -> Search -> m [Hit a]
585scanSearch indexName mappingName search = do
586 msid <- scanSearch' indexName mappingName search
587 (hits, msid') <- scroll' msid
588 (totalHits, _) <- simpleAccumilator [] (hits, msid')
591-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
592-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
593-- syntax if you want to add things like aggregations or highlights while still using
594-- this helper function.
596-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
597-- >>> mkSearch (Just query) Nothing
598-- 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}
599mkSearch :: Maybe Query -> Maybe Filter -> Search
600mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
602-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
603-- the 'Query' and the 'Aggregation'.
605-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
607-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
608-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
609mkAggregateSearch :: Maybe Query -> Aggregations -> Search
610mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing
612-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
613-- the 'Query' and the 'Aggregation'.
615-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
616-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
617-- >>> let search = mkHighlightSearch (Just query) testHighlight
618mkHighlightSearch :: Maybe Query -> Highlights -> Search
619mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
621-- | 'pageSearch' is a helper function that takes a search and assigns the from
622-- and size fields for the search. The from parameter defines the offset
623-- from the first result you want to fetch. The size parameter allows you to
624-- configure the maximum amount of hits to be returned.
626-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
627-- >>> let search = mkSearch (Just query) Nothing
629-- 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}
630-- >>> pageSearch (From 10) (Size 100) search
631-- 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}
632pageSearch :: From -- ^ The result offset
633 -> Size -- ^ The number of results to return
634 -> Search -- ^ The current seach
635 -> Search -- ^ The paged search
636pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
638parseUrl' :: MonadThrow m => Text -> m Request
639parseUrl' t = parseUrl (URI.escapeURIString URI.isAllowedInURI (T.unpack t))
641-- | Was there an optimistic concurrency control conflict when
642-- indexing a document?
643isVersionConflict :: Reply -> Bool
644isVersionConflict = statusCheck (== 409)
646isSuccess :: Reply -> Bool
647isSuccess = statusCheck (inRange (200, 299))
649isCreated :: Reply -> Bool
650isCreated = statusCheck (== 201)
652statusCheck :: (Int -> Bool) -> Reply -> Bool
653statusCheck 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