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 qualified Data.List as LS (filter)
72import Data.Maybe (fromMaybe, isJust)
74import Data.Text (Text)
75import qualified Data.Text as T
76import qualified Data.Text.Encoding as T
77import qualified Data.Vector as V
78import Network.HTTP.Client
79import qualified Network.HTTP.Types.Method as NHTM
80import qualified Network.HTTP.Types.Status as NHTS
81import qualified Network.HTTP.Types.URI as NHTU
82import Prelude hiding (filter, head)
83import URI.ByteString hiding (Query)
85import Database.Bloodhound.Types
88-- >>> :set -XOverloadedStrings
89-- >>> :set -XDeriveGeneric
90-- >>> import Database.Bloodhound
91-- >>> import Test.DocTest.Prop (assert)
92-- >>> let testServer = (Server "http://localhost:9200")
93-- >>> let runBH' = withBH defaultManagerSettings testServer
94-- >>> let testIndex = IndexName "twitter"
95-- >>> let testMapping = MappingName "tweet"
96-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)
97-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)
98-- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping
99-- >>> import GHC.Generics
100-- >>> import Data.Time.Calendar (Day (..))
101-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
103--instance ToJSON TweetMapping where
104-- toJSON TweetMapping =
106-- object ["properties" .=
107-- object ["location" .=
108-- object ["type" .= ("geo_point" :: Text)]]]]
109--data Location = Location { lat :: Double
110-- , lon :: Double } deriving (Eq, Generic, Show)
111--data Tweet = Tweet { user :: Text
112-- , postDate :: UTCTime
115-- , location :: Location } deriving (Eq, Generic, Show)
116--exampleTweet = Tweet { user = "bitemyapp"
117-- , postDate = UTCTime
118-- (ModifiedJulianDay 55000)
119-- (secondsToDiffTime 10)
120-- , message = "Use haskell!"
122-- , location = Location 40.12 (-71.34) }
123--instance ToJSON Tweet
124--instance FromJSON Tweet
125--instance ToJSON Location
126--instance FromJSON Location
127--data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
128--instance FromJSON BulkTest
129--instance ToJSON BulkTest
132-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'
133-- which rejects 'Int' values below 1 and above 1000.
135-- >>> mkShardCount 10
136-- Just (ShardCount 10)
137mkShardCount :: Int -> Maybe ShardCount
141 | otherwise = Just (ShardCount n)
143-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'
144-- which rejects 'Int' values below 1 and above 1000.
146-- >>> mkReplicaCount 10
147-- Just (ReplicaCount 10)
148mkReplicaCount :: Int -> Maybe ReplicaCount
151 | n > 1000 = Nothing -- ...
152 | otherwise = Just (ReplicaCount n)
154emptyBody :: L.ByteString
157dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString
159dispatch dMethod url body = do
160 initReq <- liftIO $ parseUrl' url
161 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
162 let req = initReq { method = dMethod
163 , requestBody = reqBody
164 , checkStatus = \_ _ _ -> Nothing}
165 mgr <- bhManager <$> getBHEnv
166 liftIO $ httpLbs req mgr
168joinPath' :: [Text] -> Text
169joinPath' = T.intercalate "/"
171joinPath :: MonadBH m => [Text] -> m Text
173 Server s <- bhServer <$> getBHEnv
174 return $ joinPath' (s:ps)
176appendSearchTypeParam :: Text -> SearchType -> Text
177appendSearchTypeParam originalUrl st = addQuery params originalUrl
178 where stText = "search_type"
180 | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")]
181 | st == SearchTypeCount = [(stText, Just "count")]
182 | st == SearchTypeScan = [(stText, Just "scan"), ("scroll", Just "1m")]
183 | st == SearchTypeQueryAndFetch = [(stText, Just "query_and_fetch")]
184 | st == SearchTypeDfsQueryAndFetch = [(stText, Just "dfs_query_and_fetch")]
185 -- used to catch 'SearchTypeQueryThenFetch', which is also the default
186 | otherwise = [(stText, Just "query_then_fetch")]
188-- | Severely dumbed down query renderer. Assumes your data doesn't
190addQuery :: [(Text, Maybe Text)] -> Text -> Text
191addQuery q u = u <> rendered
194 T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q
195 prependQuestionMark = True
197bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
198bindM2 f ma mb = join (f <$> ma <*> mb)
200-- | Convenience function that sets up a manager and BHEnv and runs
201-- the given set of bloodhound operations. Connections will be
202-- pipelined automatically in accordance with the given manager
203-- settings in IO. If you've got your own monad transformer stack, you
204-- should use 'runBH' directly.
205withBH :: ManagerSettings -> Server -> BH IO a -> IO a
208 let env = BHEnv { bhServer = s
212-- Shortcut functions for HTTP methods
213delete :: MonadBH m => Text -> m Reply
214delete = flip (dispatch NHTM.methodDelete) Nothing
215get :: MonadBH m => Text -> m Reply
216get = flip (dispatch NHTM.methodGet) Nothing
217head :: MonadBH m => Text -> m Reply
218head = flip (dispatch NHTM.methodHead) Nothing
219put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
220put = dispatch NHTM.methodPut
221post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
222post = dispatch NHTM.methodPost
224-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
225-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
226-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
228-- | 'getStatus' fetches the 'Status' of a 'Server'
230-- >>> serverStatus <- runBH' getStatus
231-- >>> fmap status (serverStatus)
233getStatus :: MonadBH m => m (Maybe Status)
236 request <- liftIO $ parseUrl' url
237 mgr <- bhManager <$> getBHEnv
238 response <- liftIO $ httpLbs request mgr
239 return $ decode (responseBody response)
241-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
243-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
244-- >>> respIsTwoHunna response
246-- >>> runBH' $ indexExists (IndexName "didimakeanindex")
248createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply
249createIndex indexSettings (IndexName indexName) =
250 bindM2 put url (return body)
251 where url = joinPath [indexName]
252 body = Just $ encode indexSettings
254-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
256-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
257-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
258-- >>> respIsTwoHunna response
260-- >>> runBH' $ indexExists testIndex
262deleteIndex :: MonadBH m => IndexName -> m Reply
263deleteIndex (IndexName indexName) =
264 delete =<< joinPath [indexName]
266statusCodeIs :: Int -> Reply -> Bool
267statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n
269respIsTwoHunna :: Reply -> Bool
270respIsTwoHunna = statusCodeIs 200
272existentialQuery :: MonadBH m => Text -> m (Reply, Bool)
273existentialQuery url = do
275 return (reply, respIsTwoHunna reply)
277-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
280-- >>> exists <- runBH' $ indexExists testIndex
281indexExists :: MonadBH m => IndexName -> m Bool
282indexExists (IndexName indexName) = do
283 (_, exists) <- existentialQuery =<< joinPath [indexName]
286-- | 'refreshIndex' will force a refresh on an index. You must
287-- do this if you want to read what you wrote.
289-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
290-- >>> _ <- runBH' $ refreshIndex testIndex
291refreshIndex :: MonadBH m => IndexName -> m Reply
292refreshIndex (IndexName indexName) =
293 bindM2 post url (return Nothing)
294 where url = joinPath [indexName, "_refresh"]
296stringifyOCIndex :: OpenCloseIndex -> Text
297stringifyOCIndex oci = case oci of
299 CloseIndex -> "_close"
301openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply
302openOrCloseIndexes oci (IndexName indexName) =
303 bindM2 post url (return Nothing)
304 where ociString = stringifyOCIndex oci
305 url = joinPath [indexName, ociString]
307-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
308-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
310-- >>> reply <- runBH' $ openIndex testIndex
311openIndex :: MonadBH m => IndexName -> m Reply
312openIndex = openOrCloseIndexes OpenIndex
314-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
315-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
317-- >>> reply <- runBH' $ closeIndex testIndex
318closeIndex :: MonadBH m => IndexName -> m Reply
319closeIndex = openOrCloseIndexes CloseIndex
321-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.
322-- Explained in further detail at
323-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>
325-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
326-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
327putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply
328putTemplate indexTemplate (TemplateName templateName) =
329 bindM2 put url (return body)
330 where url = joinPath ["_template", templateName]
331 body = Just $ encode indexTemplate
333-- | 'templateExists' checks to see if a template exists.
335-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")
336templateExists :: MonadBH m => TemplateName -> m Bool
337templateExists (TemplateName templateName) = do
338 (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]
341-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.
343-- >>> let idxTpl = IndexTemplate (TemplatePattern "tweet-*") (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]
344-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")
345-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")
346deleteTemplate :: MonadBH m => TemplateName -> m Reply
347deleteTemplate (TemplateName templateName) =
348 delete =<< joinPath ["_template", templateName]
350-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
351-- for documents in indexes.
353-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
354-- >>> resp <- runBH' $ putMapping testIndex testMapping TweetMapping
356-- 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}
357putMapping :: (MonadBH m, ToJSON a) => IndexName
358 -> MappingName -> a -> m Reply
359putMapping (IndexName indexName) (MappingName mappingName) mapping =
360 bindM2 put url (return body)
361 where url = joinPath [indexName, "_mapping", mappingName]
362 -- "_mapping" and mappingName above were originally transposed
363 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
364 body = Just $ encode mapping
366-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
367-- Mappings are schemas for documents in indexes.
369-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
370-- >>> _ <- runBH' $ putMapping testIndex testMapping TweetMapping
371-- >>> resp <- runBH' $ deleteMapping testIndex testMapping
373-- 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}
374deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
375deleteMapping (IndexName indexName)
376 (MappingName mappingName) =
377 -- "_mapping" and mappingName below were originally transposed
378 -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME"
379 delete =<< joinPath [indexName, "_mapping", mappingName]
381-- | 'indexDocument' is the primary way to save a single document in
382-- Elasticsearch. The document itself is simply something we can
383-- convert into a JSON 'Value'. The 'DocId' will function as the
384-- primary key for the document.
386-- >>> resp <- runBH' $ indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "1")
388-- 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}
389indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
390 -> IndexDocumentSettings -> doc -> DocId -> m Reply
391indexDocument (IndexName indexName)
392 (MappingName mappingName) cfg document (DocId docId) =
393 bindM2 put url (return body)
394 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
395 versionCtlParams = case idsVersionControl cfg of
396 NoVersionControl -> []
397 InternalVersion v -> versionParams v "internal"
398 ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt"
399 ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte"
400 ForceVersion (ExternalDocVersion v) -> versionParams v "force"
401 vt = T.pack . show . docVersionNumber
402 versionParams v t = [ ("version", Just $ vt v)
403 , ("version_type", Just t)
405 parentParams = case idsParent cfg of
407 Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ]
408 params = versionCtlParams ++ parentParams
409 body = Just (encode document)
411-- | 'deleteDocument' is the primary way to delete a single document.
413-- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1")
414deleteDocument :: MonadBH m => IndexName -> MappingName
416deleteDocument (IndexName indexName)
417 (MappingName mappingName) (DocId docId) =
418 delete =<< joinPath [indexName, mappingName, docId]
421-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>
422-- to perform bulk operations. The 'BulkOperation' data type encodes the
423-- index/update/delete/create operations. You pass a 'V.Vector' of 'BulkOperation's
424-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch
425-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
427-- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
428-- >>> _ <- runBH' $ bulk stream
429-- >>> _ <- runBH' $ refreshIndex testIndex
430bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
431bulk bulkOps = bindM2 post url (return body)
432 where url = joinPath ["_bulk"]
433 body = Just $ encodeBulkOperations bulkOps
435-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
436-- into an 'L.ByteString'
438-- >>> let bulkOps = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
439-- >>> encodeBulkOperations bulkOps
440-- "\n{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n"
441encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
442encodeBulkOperations stream = collapsed where
443 blobs = fmap encodeBulkOperation stream
444 mashedTaters = mash (mempty :: Builder) blobs
445 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
447mash :: Builder -> V.Vector L.ByteString -> Builder
448mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))
450mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
451mkBulkStreamValue operation indexName mappingName docId =
453 object [ "_index" .= indexName
454 , "_type" .= mappingName
457-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
458-- into an 'L.ByteString'
460-- >>> let bulkOp = BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))
461-- >>> encodeBulkOperation bulkOp
462-- "{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}"
463encodeBulkOperation :: BulkOperation -> L.ByteString
464encodeBulkOperation (BulkIndex (IndexName indexName)
465 (MappingName mappingName)
466 (DocId docId) value) = blob
467 where metadata = mkBulkStreamValue "index" indexName mappingName docId
468 blob = encode metadata `mappend` "\n" `mappend` encode value
470encodeBulkOperation (BulkCreate (IndexName indexName)
471 (MappingName mappingName)
472 (DocId docId) value) = blob
473 where metadata = mkBulkStreamValue "create" indexName mappingName docId
474 blob = encode metadata `mappend` "\n" `mappend` encode value
476encodeBulkOperation (BulkDelete (IndexName indexName)
477 (MappingName mappingName)
478 (DocId docId)) = blob
479 where metadata = mkBulkStreamValue "delete" indexName mappingName docId
480 blob = encode metadata
482encodeBulkOperation (BulkUpdate (IndexName indexName)
483 (MappingName mappingName)
484 (DocId docId) value) = blob
485 where metadata = mkBulkStreamValue "update" indexName mappingName docId
486 doc = object ["doc" .= value]
487 blob = encode metadata `mappend` "\n" `mappend` encode doc
489-- | 'getDocument' is a straight-forward way to fetch a single document from
490-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
491-- The 'DocId' is the primary key for your Elasticsearch document.
493-- >>> yourDoc <- runBH' $ getDocument testIndex testMapping (DocId "1")
494getDocument :: MonadBH m => IndexName -> MappingName
496getDocument (IndexName indexName)
497 (MappingName mappingName) (DocId docId) =
498 get =<< joinPath [indexName, mappingName, docId]
500-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
503-- >>> exists <- runBH' $ documentExists testIndex testMapping Nothing (DocId "1")
504documentExists :: MonadBH m => IndexName -> MappingName
505 -> Maybe DocumentParent -> DocId -> m Bool
506documentExists (IndexName indexName) (MappingName mappingName)
507 parent (DocId docId) = do
508 (_, exists) <- existentialQuery =<< url
510 where url = addQuery params <$> joinPath [indexName, mappingName, docId]
511 parentParam = fmap (\(DocumentParent (DocId p)) -> p) parent
512 params = LS.filter (\(_, v) -> isJust v) [("parent", parentParam)]
514dispatchSearch :: MonadBH m => Text -> Search -> m Reply
515dispatchSearch url search = post url' (Just (encode search))
516 where url' = appendSearchTypeParam url (searchType search)
518-- | 'searchAll', given a 'Search', will perform that search against all indexes
519-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
521-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
522-- >>> let search = mkSearch (Just query) Nothing
523-- >>> reply <- runBH' $ searchAll search
524searchAll :: MonadBH m => Search -> m Reply
525searchAll = bindM2 dispatchSearch url . return
526 where url = joinPath ["_search"]
528-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
529-- against all mappings within an index on an Elasticsearch server.
531-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
532-- >>> let search = mkSearch (Just query) Nothing
533-- >>> reply <- runBH' $ searchByIndex testIndex search
534searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
535searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
536 where url = joinPath [indexName, "_search"]
538-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
539-- search against a specific mapping within an index on an Elasticsearch server.
541-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
542-- >>> let search = mkSearch (Just query) Nothing
543-- >>> reply <- runBH' $ searchByType testIndex testMapping search
544searchByType :: MonadBH m => IndexName -> MappingName -> Search
546searchByType (IndexName indexName)
547 (MappingName mappingName) = bindM2 dispatchSearch url . return
548 where url = joinPath [indexName, mappingName, "_search"]
550scanSearch' :: MonadBH m => IndexName -> MappingName -> Search -> m (Maybe ScrollId)
551scanSearch' (IndexName indexName) (MappingName mappingName) search = do
552 let url = joinPath [indexName, mappingName, "_search"]
553 search' = search { searchType = SearchTypeScan }
554 resp' <- bindM2 dispatchSearch url (return search')
555 let msr = decode' $ responseBody resp' :: Maybe (SearchResult ())
556 msid = maybe Nothing scrollId msr
559scroll' :: (FromJSON a, MonadBH m) => Maybe ScrollId -> m ([Hit a], Maybe ScrollId)
560scroll' Nothing = return ([], Nothing)
561scroll' (Just sid) = do
562 url <- joinPath ["_search/scroll?scroll=1m"]
563 resp' <- post url (Just . L.fromStrict $ T.encodeUtf8 sid)
564 let msr = decode' $ responseBody resp' :: FromJSON a => Maybe (SearchResult a)
566 Just sr -> (hits $ searchHits sr, scrollId sr)
570simpleAccumilator :: (FromJSON a, MonadBH m) => [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId)
571simpleAccumilator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)
572simpleAccumilator oldHits ([], _) = return (oldHits, Nothing)
573simpleAccumilator oldHits (newHits, msid) = do
574 (newHits', msid') <- scroll' msid
575 simpleAccumilator (oldHits ++ newHits) (newHits', msid')
577-- | 'scanSearch' uses the 'scan&scroll' API of elastic,
578-- for a given 'IndexName' and 'MappingName',
579scanSearch :: (FromJSON a, MonadBH m) => IndexName -> MappingName -> Search -> m [Hit a]
580scanSearch indexName mappingName search = do
581 msid <- scanSearch' indexName mappingName search
582 (hits, msid') <- scroll' msid
583 (totalHits, _) <- simpleAccumilator [] (hits, msid')
586-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
587-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
588-- syntax if you want to add things like aggregations or highlights while still using
589-- this helper function.
591-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
592-- >>> mkSearch (Just query) Nothing
593-- 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}
594mkSearch :: Maybe Query -> Maybe Filter -> Search
595mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
597-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
598-- the 'Query' and the 'Aggregation'.
600-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
602-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
603-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
604mkAggregateSearch :: Maybe Query -> Aggregations -> Search
605mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0) SearchTypeQueryThenFetch Nothing Nothing
607-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
608-- the 'Query' and the 'Aggregation'.
610-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
611-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
612-- >>> let search = mkHighlightSearch (Just query) testHighlight
613mkHighlightSearch :: Maybe Query -> Highlights -> Search
614mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10) SearchTypeQueryThenFetch Nothing Nothing
616-- | 'pageSearch' is a helper function that takes a search and assigns the from
617-- and size fields for the search. The from parameter defines the offset
618-- from the first result you want to fetch. The size parameter allows you to
619-- configure the maximum amount of hits to be returned.
621-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
622-- >>> let search = mkSearch (Just query) Nothing
624-- 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}
625-- >>> pageSearch (From 10) (Size 100) search
626-- 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}
627pageSearch :: From -- ^ The result offset
628 -> Size -- ^ The number of results to return
629 -> Search -- ^ The current seach
630 -> Search -- ^ The paged search
631pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
633parseUrl' :: MonadThrow m => Text -> m Request
635 case parseURI laxURIParserOptions (T.encodeUtf8 t) of
636 Right uri -> setURI def uri
637 Left e -> throwM $ InvalidUrlException (T.unpack t) ("Invalid URL: " ++ show e)
639setURI :: MonadThrow m => Request -> URI -> m Request
640setURI req URI{..} = do
641 Authority {..} <- maybe missingUA return uriAuthority
642 let req' = req { secure = isSecure
643 , host = hostBS authorityHost
647 thePort = maybe defPort portNumber authorityPort
648 addAuth = maybe id addAuth' authorityUserInfo
649 return $ setQueryString theQueryString $ addAuth req'
651 missingUA = throwM $ InvalidUrlException "N/A" "Missing URI host/port"
652 addAuth' UserInfo {..} = applyBasicProxyAuth uiUsername uiPassword
656 isSecure = case uriScheme of
657 Scheme "https" -> True
659 theQueryString = [(k , Just v) | (k, v) <- queryPairs uriQuery]
661-- | Was there an optimistic concurrency control conflict when
662-- indexing a document?
663isVersionConflict :: Reply -> Bool
664isVersionConflict = statusCheck (== 409)
666isSuccess :: Reply -> Bool
667isSuccess = statusCheck (inRange (200, 299))
669isCreated :: Reply -> Bool
670isCreated = statusCheck (== 201)
672statusCheck :: (Int -> Bool) -> Reply -> Bool
673statusCheck 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