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
69import Data.Default.Class
71import Data.Maybe (fromMaybe)
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 Prelude hiding (filter, head)
82import URI.ByteString hiding (Query)
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
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
131-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'
132-- which rejects 'Int' values below 1 and above 1000.
134-- >>> mkShardCount 10
135-- Just (ShardCount 10)
136mkShardCount :: Int -> Maybe ShardCount
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.
145-- >>> mkReplicaCount 10
146-- Just (ReplicaCount 10)
147mkReplicaCount :: Int -> Maybe ReplicaCount
150 | n > 1000 = Nothing -- ...
151 | otherwise = Just (ReplicaCount n)
153emptyBody :: L.ByteString
156dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString
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
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"
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
189addQuery :: [(Text, Maybe Text)] -> Text -> Text
190addQuery q u = u <> 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
207 let env = BHEnv { bhServer = s
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'
229-- >>> serverStatus <- runBH' getStatus
230-- >>> fmap status (serverStatus)
232getStatus :: MonadBH m => m (Maybe Status)
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'.
242-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
243-- >>> respIsTwoHunna response
245-- >>> runBH' $ indexExists (IndexName "didimakeanindex")
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'.
255-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
256-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
257-- >>> respIsTwoHunna response
259-- >>> runBH' $ indexExists testIndex
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
274 return (reply, respIsTwoHunna reply)
276-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
279-- >>> exists <- runBH' $ indexExists testIndex
280indexExists :: MonadBH m => IndexName -> m Bool
281indexExists (IndexName indexName) = do
282 (_, exists) <- existentialQuery =<< joinPath [indexName]
285-- | 'refreshIndex' will force a refresh on an index. You must
286-- do this if you want to read what you wrote.
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
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>
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>
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>
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.
334-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")
335templateExists :: MonadBH m => TemplateName -> m Bool
336templateExists (TemplateName templateName) = do
337 (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
340-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
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.
352-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
353-- >>> resp <- runBH' $ putMapping testIndex testMapping TweetMapping
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.
368-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
369-- >>> _ <- runBH' $ putMapping testIndex testMapping TweetMapping
370-- >>> resp <- runBH' $ deleteMapping testIndex testMapping
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.
385-- >>> resp <- runBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")
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)
404 parentParams = case idsParent cfg of
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.
412-- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1")
413deleteDocument :: MonadBH m => IndexName -> MappingName
415deleteDocument (IndexName indexName)
416 (MappingName mappingName) (DocId docId) =
417 delete =<< joinPath [indexName, mappingName, docId]
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.
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'
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 =
452 object [ "_index" .= indexName
453 , "_type" .= mappingName
456-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
457-- into an 'L.ByteString'
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.
492-- >>> yourDoc <- runBH' $ getDocument testIndex testMapping (DocId "1")
493getDocument :: MonadBH m => IndexName -> MappingName
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'
502-- >>> exists <- runBH' $ documentExists testIndex testMapping (DocId "1")
503documentExists :: MonadBH m => IndexName -> MappingName
505documentExists (IndexName indexName)
506 (MappingName mappingName) (DocId docId) = do
507 (_, exists) <- existentialQuery =<< url
509 where url = joinPath [indexName, mappingName, docId]
511dispatchSearch :: MonadBH m => Text -> Search -> m Reply
512dispatchSearch url search = post url' (Just (encode search))
513 where url' = appendSearchTypeParam url (searchType search)
515-- | 'searchAll', given a 'Search', will perform that search against all indexes
516-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
518-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
519-- >>> let search = mkSearch (Just query) Nothing
520-- >>> reply <- runBH' $ searchAll search
521searchAll :: MonadBH m => Search -> m Reply
522searchAll = bindM2 dispatchSearch url . return
523 where url = joinPath ["_search"]
525-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
526-- against all mappings within an index on an Elasticsearch server.
528-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
529-- >>> let search = mkSearch (Just query) Nothing
530-- >>> reply <- runBH' $ searchByIndex testIndex search
531searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
532searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
533 where url = joinPath [indexName, "_search"]
535-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
536-- search against a specific mapping within an index on an Elasticsearch server.
538-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
539-- >>> let search = mkSearch (Just query) Nothing
540-- >>> reply <- runBH' $ searchByType testIndex testMapping search
541searchByType :: MonadBH m => IndexName -> MappingName -> Search
543searchByType (IndexName indexName)
544 (MappingName mappingName) = bindM2 dispatchSearch url . return
545 where url = joinPath [indexName, mappingName, "_search"]
547scanSearch' :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId)
548scanSearch' (IndexName indexName) (MappingName mappingName) search = do
549 let url = joinPath [indexName, mappingName, "_search"]
550 search' = search { searchType = SearchTypeScan }
551 resp' <- bindM2 dispatchSearch url (return search')
552 let msr = decode' $ responseBody resp' :: Maybe (SearchResult ())
553 msid = maybe Nothing scrollId msr
556scroll' :: (FromJSON a, MonadBH m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId)
557scroll' Nothing = return ([], Nothing)
558scroll' (Just sid) = do
559 url <- joinPath ["_search/scroll?scroll=1m"]
560 resp' <- post url (Just . L.fromStrict $ T.encodeUtf8 sid)
561 let msr = decode' $ responseBody resp' :: FromJSON a => Maybe (SearchResult a)
563 Just sr -> (hits $ searchHits sr, scrollId sr)
567simpleAccumilator :: (FromJSON a, MonadBH m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId)
568simpleAccumilator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)
569simpleAccumilator oldHits ([], _) = return (oldHits, Nothing)
570simpleAccumilator oldHits (newHits, msid) = do
571 (newHits', msid') <- scroll' msid
572 simpleAccumilator (oldHits ++ newHits) (newHits', msid')
574-- | 'scanSearch' uses the 'scan&scroll' API of elastic,
575-- for a given 'IndexName' and 'MappingName',
576scanSearch :: (FromJSON a, MonadBH m) => IndexName -> MappingName -> Search -> m [Hit a]
577scanSearch indexName mappingName search = do
578 msid <- scanSearch' indexName mappingName search
579 (hits, msid') <- scroll' msid
580 (totalHits, _) <- simpleAccumilator [] (hits, msid')
583-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
584-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
585-- syntax if you want to add things like aggregations or highlights while still using
586-- this helper function.
588-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
589-- >>> mkSearch (Just query) Nothing
590-- 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}
591mkSearch :: Maybe Query -> Maybe Filter -> Search
592mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
594-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
595-- the 'Query' and the 'Aggregation'.
597-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
599-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
600-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
601mkAggregateSearch :: Maybe Query -> Aggregations -> Search
602mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing
604-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
605-- the 'Query' and the 'Aggregation'.
607-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
608-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
609-- >>> let search = mkHighlightSearch (Just query) testHighlight
610mkHighlightSearch :: Maybe Query -> Highlights -> Search
611mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
613-- | 'pageSearch' is a helper function that takes a search and assigns the from
614-- and size fields for the search. The from parameter defines the offset
615-- from the first result you want to fetch. The size parameter allows you to
616-- configure the maximum amount of hits to be returned.
618-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
619-- >>> let search = mkSearch (Just query) Nothing
621-- 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}
622-- >>> pageSearch (From 10) (Size 100) 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 10, size = Size 100, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}
624pageSearch :: From -- ^ The result offset
625 -> Size -- ^ The number of results to return
626 -> Search -- ^ The current seach
627 -> Search -- ^ The paged search
628pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
630parseUrl' :: MonadThrow m => Text -> m Request
632 case parseURI laxURIParserOptions (T.encodeUtf8 t) of
633 Right uri -> setURI def uri
634 Left e -> throwM $ InvalidUrlException (T.unpack t) ("Invalid URL: " ++ show e)
636setURI :: MonadThrow m => Request -> URI -> m Request
637setURI req URI{..} = do
638 Authority {..} <- maybe missingUA return uriAuthority
639 let req' = req { secure = isSecure
640 , host = hostBS authorityHost
644 thePort = maybe defPort portNumber authorityPort
645 addAuth = maybe id addAuth' authorityUserInfo
646 return $ setQueryString theQueryString $ addAuth req'
648 missingUA = throwM $ InvalidUrlException "N/A" "Missing URI host/port"
649 addAuth' UserInfo {..} = applyBasicProxyAuth uiUsername uiPassword
653 isSecure = case uriScheme of
654 Scheme "https" -> True
656 theQueryString = [(k , Just v) | (k, v) <- queryPairs uriQuery]
658-- | Was there an optimistic concurrency control conflict when
659-- indexing a document?
660isVersionConflict :: Reply -> Bool
661isVersionConflict = statusCheck (== 409)
663isSuccess :: Reply -> Bool
664isSuccess = statusCheck (inRange (200, 299))
666isCreated :: Reply -> Bool
667isCreated = statusCheck (== 201)
669statusCheck :: (Int -> Bool) -> Reply -> Bool
670statusCheck 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