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.
56 , encodeBulkOperations
58 -- * Reply-handling tools
66import qualified Blaze.ByteString.Builder as BB
67import Control.Applicative
69import Control.Monad.Catch
70import Control.Monad.IO.Class
72import Data.ByteString.Lazy.Builder
73import qualified Data.ByteString.Lazy.Char8 as L
74import Data.Foldable (toList)
76import qualified Data.List as LS (filter)
77import Data.List.NonEmpty (NonEmpty (..))
78import Data.Maybe (fromMaybe, isJust)
80import Data.Text (Text)
81import qualified Data.Text as T
82import qualified Data.Text.Encoding as T
84import qualified Data.Vector as V
85import Network.HTTP.Client
86import qualified Network.HTTP.Types.Method as NHTM
87import qualified Network.HTTP.Types.Status as NHTS
88import qualified Network.HTTP.Types.URI as NHTU
89import qualified Network.URI as URI
90import Prelude hiding (filter, head)
92import Database.Bloodhound.Types
95-- >>> :set -XOverloadedStrings
96-- >>> :set -XDeriveGeneric
97-- >>> import Database.Bloodhound
98-- >>> import Test.DocTest.Prop (assert)
99-- >>> let testServer = (Server "http://localhost:9200")
100-- >>> let runBH' = withBH defaultManagerSettings testServer
101-- >>> let testIndex = IndexName "twitter"
102-- >>> let testMapping = MappingName "tweet"
103-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)
104-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)
105-- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping
106-- >>> import GHC.Generics
107-- >>> import Data.Time.Calendar (Day (..))
108-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
110--instance ToJSON TweetMapping where
111-- toJSON TweetMapping =
113-- object ["properties" .=
114-- object ["location" .=
115-- object ["type" .= ("geo_point" :: Text)]]]]
116--data Location = Location { lat :: Double
117-- , lon :: Double } deriving (Eq, Generic, Show)
118--data Tweet = Tweet { user :: Text
119-- , postDate :: UTCTime
122-- , location :: Location } deriving (Eq, Generic, Show)
123--exampleTweet = Tweet { user = "bitemyapp"
124-- , postDate = UTCTime
125-- (ModifiedJulianDay 55000)
126-- (secondsToDiffTime 10)
127-- , message = "Use haskell!"
129-- , location = Location 40.12 (-71.34) }
130--instance ToJSON Tweet where
131-- toJSON = genericToJSON defaultOptions
132--instance FromJSON Tweet where
133-- parseJSON = genericParseJSON defaultOptions
134--instance ToJSON Location where
135-- toJSON = genericToJSON defaultOptions
136--instance FromJSON Location where
137-- parseJSON = genericParseJSON defaultOptions
138--data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
139--instance FromJSON BulkTest where
140-- parseJSON = genericParseJSON defaultOptions
141--instance ToJSON BulkTest where
142-- toJSON = genericToJSON defaultOptions
145-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'
146-- which rejects 'Int' values below 1 and above 1000.
148-- >>> mkShardCount 10
149-- Just (ShardCount 10)
150mkShardCount :: Int -> Maybe ShardCount
154 | otherwise = Just (ShardCount n)
156-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'
157-- which rejects 'Int' values below 1 and above 1000.
159-- >>> mkReplicaCount 10
160-- Just (ReplicaCount 10)
161mkReplicaCount :: Int -> Maybe ReplicaCount
164 | n > 1000 = Nothing -- ...
165 | otherwise = Just (ReplicaCount n)
167emptyBody :: L.ByteString
170dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString
172dispatch dMethod url body = do
173 initReq <- liftIO $ parseUrl' url
174 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
175 let req = initReq { method = dMethod
176 , requestBody = reqBody
177 , checkStatus = \_ _ _ -> Nothing}
178 mgr <- bhManager <$> getBHEnv
179 liftIO $ httpLbs req mgr
181joinPath' :: [Text] -> Text
182joinPath' = T.intercalate "/"
184joinPath :: MonadBH m => [Text] -> m Text
186 Server s <- bhServer <$> getBHEnv
187 return $ joinPath' (s:ps)
189appendSearchTypeParam :: Text -> SearchType -> Text
190appendSearchTypeParam originalUrl st = addQuery params originalUrl
191 where stText = "search_type"
193 | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")]
194 | st == SearchTypeCount = [(stText, Just "count")]
195 | st == SearchTypeScan = [(stText, Just "scan"), ("scroll", Just "1m")]
196 | st == SearchTypeQueryAndFetch = [(stText, Just "query_and_fetch")]
197 | st == SearchTypeDfsQueryAndFetch = [(stText, Just "dfs_query_and_fetch")]
198 -- used to catch 'SearchTypeQueryThenFetch', which is also the default
199 | otherwise = [(stText, Just "query_then_fetch")]
201-- | Severely dumbed down query renderer. Assumes your data doesn't
203addQuery :: [(Text, Maybe Text)] -> Text -> Text
204addQuery q u = u <> rendered
207 T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q
208 prependQuestionMark = True
210bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
211bindM2 f ma mb = join (f <$> ma <*> mb)
213-- | Convenience function that sets up a manager and BHEnv and runs
214-- the given set of bloodhound operations. Connections will be
215-- pipelined automatically in accordance with the given manager
216-- settings in IO. If you've got your own monad transformer stack, you
217-- should use 'runBH' directly.
218withBH :: ManagerSettings -> Server -> BH IO a -> IO a
221 let env = BHEnv { bhServer = s
225-- Shortcut functions for HTTP methods
226delete :: MonadBH m => Text -> m Reply
227delete = flip (dispatch NHTM.methodDelete) Nothing
228get :: MonadBH m => Text -> m Reply
229get = flip (dispatch NHTM.methodGet) Nothing
230head :: MonadBH m => Text -> m Reply
231head = flip (dispatch NHTM.methodHead) Nothing
232put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
233put = dispatch NHTM.methodPut
234post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
235post = dispatch NHTM.methodPost
237-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
238-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
239-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
241-- | 'getStatus' fetches the 'Status' of a 'Server'
243-- >>> serverStatus <- runBH' getStatus
244-- >>> fmap status (serverStatus)
246getStatus :: MonadBH m => m (Maybe Status)
249 request <- liftIO $ parseUrl' url
250 mgr <- bhManager <$> getBHEnv
251 response <- liftIO $ httpLbs request mgr
252 return $ decode (responseBody response)
254-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
256-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
257-- >>> respIsTwoHunna response
259-- >>> runBH' $ indexExists (IndexName "didimakeanindex")
261createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply
262createIndex indexSettings (IndexName indexName) =
263 bindM2 put url (return body)
264 where url = joinPath [indexName]
265 body = Just $ encode indexSettings
267-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
269-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
270-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
271-- >>> respIsTwoHunna response
273-- >>> runBH' $ indexExists testIndex
275deleteIndex :: MonadBH m => IndexName -> m Reply
276deleteIndex (IndexName indexName) =
277 delete =<< joinPath [indexName]
279statusCodeIs :: Int -> Reply -> Bool
280statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n
282respIsTwoHunna :: Reply -> Bool
283respIsTwoHunna = statusCodeIs 200
285existentialQuery :: MonadBH m => Text -> m (Reply, Bool)
286existentialQuery url = do
288 return (reply, respIsTwoHunna reply)
291-- | Tries to parse a response body as the expected type @a@ and
292-- failing that tries to parse it as an EsError. All well-formed, JSON
293-- responses from elasticsearch should fall into these two
294-- categories. If they don't, a 'StatusCodeException' will be thrown.
295parseEsResponse :: (MonadThrow m, FromJSON a) => Reply
296 -> m (Either EsError a)
298 | respIsTwoHunna reply = case eitherDecode body of
299 Right a -> return (Right a)
300 Left _ -> tryParseError
301 | otherwise = tryParseError
302 where body = responseBody reply
303 stat = responseStatus reply
304 hdrs = responseHeaders reply
305 cookies = responseCookieJar reply
306 tryParseError = case eitherDecode body of
307 Right e -> return (Left e)
308 -- this case should not be possible
310 explode = throwM (StatusCodeException stat hdrs cookies)
312-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
315-- >>> exists <- runBH' $ indexExists testIndex
316indexExists :: MonadBH m => IndexName -> m Bool
317indexExists (IndexName indexName) = do
318 (_, exists) <- existentialQuery =<< joinPath [indexName]
321-- | 'refreshIndex' will force a refresh on an index. You must
322-- do this if you want to read what you wrote.
324-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
325-- >>> _ <- runBH' $ refreshIndex testIndex
326refreshIndex :: MonadBH m => IndexName -> m Reply
327refreshIndex (IndexName indexName) =
328 bindM2 post url (return Nothing)
329 where url = joinPath [indexName, "_refresh"]
331stringifyOCIndex :: OpenCloseIndex -> Text
332stringifyOCIndex oci = case oci of
334 CloseIndex -> "_close"
336openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply
337openOrCloseIndexes oci (IndexName indexName) =
338 bindM2 post url (return Nothing)
339 where ociString = stringifyOCIndex oci
340 url = joinPath [indexName, ociString]
342-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
343-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
345-- >>> reply <- runBH' $ openIndex testIndex
346openIndex :: MonadBH m => IndexName -> m Reply
347openIndex = openOrCloseIndexes OpenIndex
349-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
350-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
352-- >>> reply <- runBH' $ closeIndex testIndex
353closeIndex :: MonadBH m => IndexName -> m Reply
354closeIndex = openOrCloseIndexes CloseIndex
357-- | 'updateIndexAliases' updates the server's index alias
358-- table. Operations are atomic. Explained in further detail at
359-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-aliases.html>
361-- >>> let src = IndexName "a-real-index"
362-- >>> let aliasName = IndexName "an-alias"
363-- >>> let iAlias = IndexAlias src (IndexAliasName aliasName)
364-- >>> let aliasCreate = IndexAliasCreate Nothing Nothing
365-- >>> respIsTwoHunna <$> runBH' (createIndex defaultIndexSettings src)
367-- >>> runBH' $ indexExists src
369-- >>> respIsTwoHunna <$> runBH' (updateIndexAliases (AddAlias iAlias aliasCreate :| []))
371-- >>> runBH' $ indexExists aliasName
373updateIndexAliases :: MonadBH m => NonEmpty IndexAliasAction -> m Reply
374updateIndexAliases actions = bindM2 post url (return body)
375 where url = joinPath ["_aliases"]
376 body = Just (encode bodyJSON)
377 bodyJSON = object [ "actions" .= toList actions]
379-- | Get all aliases configured on the server.
380getIndexAliases :: (MonadBH m, MonadThrow m)
381 => m (Either EsError IndexAliasesSummary)
382getIndexAliases = parseEsResponse =<< get =<< url
383 where url = joinPath ["_aliases"]
385-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.
386-- Explained in further detail at
387-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>
389-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
390-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
391putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply
392putTemplate indexTemplate (TemplateName templateName) =
393 bindM2 put url (return body)
394 where url = joinPath ["_template", templateName]
395 body = Just $ encode indexTemplate
397-- | 'templateExists' checks to see if a template exists.
399-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")
400templateExists :: MonadBH m => TemplateName -> m Bool
401templateExists (TemplateName templateName) = do
402 (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
405-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
407-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
408-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
409-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")
410deleteTemplate :: MonadBH m => TemplateName -> m Reply
411deleteTemplate (TemplateName templateName) =
412 delete =<< joinPath ["_template", templateName]
414-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
415-- for documents in indexes.
417-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
418-- >>> resp <- runBH' $ putMapping testIndex testMapping TweetMapping
420-- 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}
421putMapping :: (MonadBH m, ToJSON a) => IndexName
422 -> MappingName -> a -> m Reply
423putMapping (IndexName indexName) (MappingName mappingName) mapping =
424 bindM2 put url (return body)
425 where url = joinPath [indexName, "_mapping", mappingName]
426 -- "_mapping" and mappingName above were originally transposed
427 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
428 body = Just $ encode mapping
430-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
431-- Mappings are schemas for documents in indexes.
433-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
434-- >>> _ <- runBH' $ putMapping testIndex testMapping TweetMapping
435-- >>> resp <- runBH' $ deleteMapping testIndex testMapping
437-- 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}
438deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
439deleteMapping (IndexName indexName)
440 (MappingName mappingName) =
441 -- "_mapping" and mappingName below were originally transposed
442 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
443 delete =<< joinPath [indexName, "_mapping", mappingName]
445-- | 'indexDocument' is the primary way to save a single document in
446-- Elasticsearch. The document itself is simply something we can
447-- convert into a JSON 'Value'. The 'DocId' will function as the
448-- primary key for the document.
450-- >>> resp <- runBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")
452-- 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}
453indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
454 -> IndexDocumentSettings -> doc -> DocId -> m Reply
455indexDocument (IndexName indexName)
456 (MappingName mappingName) cfg document (DocId docId) =
457 bindM2 put url (return body)
458 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
459 versionCtlParams = case idsVersionControl cfg of
460 NoVersionControl -> []
461 InternalVersion v -> versionParams v "internal"
462 ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"
463 ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"
464 ForceVersion (ExternalDocVersion v) -> versionParams v "force"
465 vt = T.pack . show . docVersionNumber
466 versionParams v t = [ ("version", Just $ vt v)
467 , ("version_type", Just t)
469 parentParams = case idsParent cfg of
471 Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]
472 params = versionCtlParams ++ parentParams
473 body = Just (encode document)
475-- | 'deleteDocument' is the primary way to delete a single document.
477-- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1")
478deleteDocument :: MonadBH m => IndexName -> MappingName
480deleteDocument (IndexName indexName)
481 (MappingName mappingName) (DocId docId) =
482 delete =<< joinPath [indexName, mappingName, docId]
485-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>
486-- to perform bulk operations. The 'BulkOperation' data type encodes the
487-- index/update/delete/create operations. You pass a 'V.Vector' of 'BulkOperation's
488-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch
489-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
491-- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
492-- >>> _ <- runBH' $ bulk stream
493-- >>> _ <- runBH' $ refreshIndex testIndex
494bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
495bulk bulkOps = bindM2 post url (return body)
496 where url = joinPath ["_bulk"]
497 body = Just $ encodeBulkOperations bulkOps
499-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
500-- into an 'L.ByteString'
502-- >>> let bulkOps = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
503-- >>> encodeBulkOperations bulkOps
504-- "\n{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n"
505encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
506encodeBulkOperations stream = collapsed where
507 blobs = fmap encodeBulkOperation stream
508 mashedTaters = mash (mempty :: Builder) blobs
509 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
511mash :: Builder -> V.Vector L.ByteString -> Builder
512mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))
514mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
515mkBulkStreamValue operation indexName mappingName docId =
517 object [ "_index" .= indexName
518 , "_type" .= mappingName
521-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
522-- into an 'L.ByteString'
524-- >>> let bulkOp = BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))
525-- >>> encodeBulkOperation bulkOp
526-- "{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}"
527encodeBulkOperation :: BulkOperation -> L.ByteString
528encodeBulkOperation (BulkIndex (IndexName indexName)
529 (MappingName mappingName)
530 (DocId docId) value) = blob
531 where metadata = mkBulkStreamValue "index" indexName mappingName docId
532 blob = encode metadata `mappend` "\n" `mappend` encode value
534encodeBulkOperation (BulkCreate (IndexName indexName)
535 (MappingName mappingName)
536 (DocId docId) value) = blob
537 where metadata = mkBulkStreamValue "create" indexName mappingName docId
538 blob = encode metadata `mappend` "\n" `mappend` encode value
540encodeBulkOperation (BulkDelete (IndexName indexName)
541 (MappingName mappingName)
542 (DocId docId)) = blob
543 where metadata = mkBulkStreamValue "delete" indexName mappingName docId
544 blob = encode metadata
546encodeBulkOperation (BulkUpdate (IndexName indexName)
547 (MappingName mappingName)
548 (DocId docId) value) = blob
549 where metadata = mkBulkStreamValue "update" indexName mappingName docId
550 doc = object ["doc" .= value]
551 blob = encode metadata `mappend` "\n" `mappend` encode doc
553-- | 'getDocument' is a straight-forward way to fetch a single document from
554-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
555-- The 'DocId' is the primary key for your Elasticsearch document.
557-- >>> yourDoc <- runBH' $ getDocument testIndex testMapping (DocId "1")
558getDocument :: MonadBH m => IndexName -> MappingName
560getDocument (IndexName indexName)
561 (MappingName mappingName) (DocId docId) =
562 get =<< joinPath [indexName, mappingName, docId]
564-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
567-- >>> exists <- runBH' $ documentExists testIndex testMapping Nothing (DocId "1")
568documentExists :: MonadBH m => IndexName -> MappingName
569 -> Maybe DocumentParent -> DocId -> m Bool
570documentExists (IndexName indexName) (MappingName mappingName)
571 parent (DocId docId) = do
572 (_, exists) <- existentialQuery =<< url
574 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
575 parentParam = fmap (\(DocumentParent (DocId p)) -> p) parent
576 params = LS.filter (\(_, v) -> isJust v) [("parent", parentParam)]
578dispatchSearch :: MonadBH m => Text -> Search -> m Reply
579dispatchSearch url search = post url' (Just (encode search))
580 where url' = appendSearchTypeParam url (searchType search)
582-- | 'searchAll', given a 'Search', will perform that search against all indexes
583-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
585-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
586-- >>> let search = mkSearch (Just query) Nothing
587-- >>> reply <- runBH' $ searchAll search
588searchAll :: MonadBH m => Search -> m Reply
589searchAll = bindM2 dispatchSearch url . return
590 where url = joinPath ["_search"]
592-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
593-- against all mappings within an index on an Elasticsearch server.
595-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
596-- >>> let search = mkSearch (Just query) Nothing
597-- >>> reply <- runBH' $ searchByIndex testIndex search
598searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
599searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
600 where url = joinPath [indexName, "_search"]
602-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
603-- search against a specific mapping within an index on an Elasticsearch server.
605-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
606-- >>> let search = mkSearch (Just query) Nothing
607-- >>> reply <- runBH' $ searchByType testIndex testMapping search
608searchByType :: MonadBH m => IndexName -> MappingName -> Search
610searchByType (IndexName indexName)
611 (MappingName mappingName) = bindM2 dispatchSearch url . return
612 where url = joinPath [indexName, mappingName, "_search"]
614-- | For a given scearch, request a scroll for efficient streaming of
615-- search results. Note that the search is put into 'SearchTypeScan'
616-- mode and thus results will not be sorted. Combine this with
617-- 'advanceScroll' to efficiently stream through the full result set
618getInitialScroll :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId)
619getInitialScroll (IndexName indexName) (MappingName mappingName) search = do
620 let url = joinPath [indexName, mappingName, "_search"]
621 search' = search { searchType = SearchTypeScan }
622 resp' <- bindM2 dispatchSearch url (return search')
623 let msr = decode' $ responseBody resp' :: Maybe (SearchResult ())
624 msid = maybe Nothing scrollId msr
627scroll' :: (FromJSON a, MonadBH m, MonadThrow m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId)
628scroll' Nothing = return ([], Nothing)
629scroll' (Just sid) = do
630 res <- advanceScroll sid 60
632 Right SearchResult {..} -> return (hits searchHits, scrollId)
633 Left _ -> return ([], Nothing)
635-- | Use the given scroll to fetch the next page of documents. If
636-- there are still further pages, there will be a value in the
637-- 'scrollId' field of the 'SearchResult'
645 -- ^ How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default.
646 -> m (Either EsError (SearchResult a))
647advanceScroll (ScrollId sid) scroll = do
648 url <- joinPath ["_search/scroll?scroll=" <> scrollTime]
649 parseEsResponse =<< post url (Just . L.fromStrict $ T.encodeUtf8 sid)
650 where scrollTime = showText secs <> "s"
654simpleAccumulator :: (FromJSON a, MonadBH m, MonadThrow m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId)
655simpleAccumulator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)
656simpleAccumulator oldHits ([], _) = return (oldHits, Nothing)
657simpleAccumulator oldHits (newHits, msid) = do
658 (newHits', msid') <- scroll' msid
659 simpleAccumulator (oldHits ++ newHits) (newHits', msid')
661-- | 'scanSearch' uses the 'scan&scroll' API of elastic,
662-- for a given 'IndexName' and 'MappingName'. Note that this will
663-- consume the entire search result set and will be doing O(n) list
664-- appends so this may not be suitable for large result sets. In that
665-- case, 'getInitialScroll' and 'advanceScroll' are good low level
666-- tools. You should be able to hook them up trivially to conduit,
667-- pipes, or your favorite streaming IO abstraction of choice. Note
668-- that ordering on the search would destroy performance and thus is
670scanSearch :: (FromJSON a, MonadBH m, MonadThrow m) => IndexName -> MappingName -> Search -> m [Hit a]
671scanSearch indexName mappingName search = do
672 msid <- getInitialScroll indexName mappingName search
673 (hits, msid') <- scroll' msid
674 (totalHits, _) <- simpleAccumulator [] (hits, msid')
677-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
678-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
679-- syntax if you want to add things like aggregations or highlights while still using
680-- this helper function.
682-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
683-- >>> mkSearch (Just query) Nothing
684-- 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}
685mkSearch :: Maybe Query -> Maybe Filter -> Search
686mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
688-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
689-- the 'Query' and the 'Aggregation'.
691-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
693-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
694-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
695mkAggregateSearch :: Maybe Query -> Aggregations -> Search
696mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing
698-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
699-- the 'Query' and the 'Aggregation'.
701-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
702-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
703-- >>> let search = mkHighlightSearch (Just query) testHighlight
704mkHighlightSearch :: Maybe Query -> Highlights -> Search
705mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
707-- | 'pageSearch' is a helper function that takes a search and assigns the from
708-- and size fields for the search. The from parameter defines the offset
709-- from the first result you want to fetch. The size parameter allows you to
710-- configure the maximum amount of hits to be returned.
712-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
713-- >>> let search = mkSearch (Just query) Nothing
715-- 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}
716-- >>> pageSearch (From 10) (Size 100) search
717-- 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}
718pageSearch :: From -- ^ The result offset
719 -> Size -- ^ The number of results to return
720 -> Search -- ^ The current seach
721 -> Search -- ^ The paged search
722pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
724parseUrl' :: MonadThrow m => Text -> m Request
725parseUrl' t = parseUrl (URI.escapeURIString URI.isAllowedInURI (T.unpack t))
727-- | Was there an optimistic concurrency control conflict when
728-- indexing a document?
729isVersionConflict :: Reply -> Bool
730isVersionConflict = statusCheck (== 409)
732isSuccess :: Reply -> Bool
733isSuccess = statusCheck (inRange (200, 299))
735isCreated :: Reply -> Bool
736isCreated = statusCheck (== 201)
738statusCheck :: (Int -> Bool) -> Reply -> Bool
739statusCheck 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