git.iko.soy/typeable/bloodhound
on 31-search-hits-monoid help sign in
538 lines 25 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RecordWildCards #-}
4-------------------------------------------------------------------------------
5-- |
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
12--
13-- Client side functions for talking to Elasticsearch servers.
14--
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.
23 -- $setup
24 withBH
25 , createIndex
26 , deleteIndex
27 , indexExists
28 , openIndex
29 , closeIndex
30 , putMapping
31 , deleteMapping
32 , indexDocument
33 , getDocument
34 , documentExists
35 , deleteDocument
36 , searchAll
37 , searchByIndex
38 , searchByType
39 , refreshIndex
40 , mkSearch
41 , mkAggregateSearch
42 , mkHighlightSearch
43 , bulk
44 , pageSearch
45 , mkShardCount
46 , mkReplicaCount
47 , getStatus
48 , encodeBulkOperations
49 , encodeBulkOperation
50 )
51 where
53import Control.Applicative
54import Control.Monad
55import Control.Monad.Catch
56import Control.Monad.IO.Class
57import Data.Aeson
58import Data.ByteString.Lazy.Builder
59import qualified Data.ByteString.Lazy.Char8 as L
60import Data.Default.Class
61import Data.Maybe (fromMaybe)
62import Data.Text (Text)
63import qualified Data.Text as T
64import qualified Data.Text.Encoding as T
65import qualified Data.Vector as V
66import Network.HTTP.Client
67import qualified Network.HTTP.Types.Method as NHTM
68import qualified Network.HTTP.Types.Status as NHTS
69import Prelude hiding (filter, head)
70import URI.ByteString hiding (Query)
72import Database.Bloodhound.Types
74-- $setup
75-- >>> :set -XOverloadedStrings
76-- >>> :set -XDeriveGeneric
77-- >>> import Database.Bloodhound
78-- >>> import Test.DocTest.Prop (assert)
79-- >>> let testServer = (Server "http://localhost:9200")
80-- >>> let runBH' = withBH defaultManagerSettings testServer
81-- >>> let testIndex = IndexName "twitter"
82-- >>> let testMapping = MappingName "tweet"
83-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
84-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)
85-- >>> _ <- runBH' $ deleteIndex testIndex >> deleteMapping testIndex testMapping
86-- >>> import GHC.Generics
87-- >>> import Data.Time.Calendar (Day (..))
88-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
89-- >>> :{
90--instance ToJSON TweetMapping where
91-- toJSON TweetMapping =
92-- object ["tweet" .=
93-- object ["properties" .=
94-- object ["location" .=
95-- object ["type" .= ("geo_point" :: Text)]]]]
96--data Location = Location { lat :: Double
97-- , lon :: Double } deriving (Eq, Generic, Show)
98--data Tweet = Tweet { user :: Text
99-- , postDate :: UTCTime
100-- , message :: Text
101-- , age :: Int
102-- , location :: Location } deriving (Eq, Generic, Show)
103--exampleTweet = Tweet { user = "bitemyapp"
104-- , postDate = UTCTime
105-- (ModifiedJulianDay 55000)
106-- (secondsToDiffTime 10)
107-- , message = "Use haskell!"
108-- , age = 10000
109-- , location = Location 40.12 (-71.34) }
110--instance ToJSON Tweet
111--instance FromJSON Tweet
112--instance ToJSON Location
113--instance FromJSON Location
114--data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)
115--instance FromJSON BulkTest
116--instance ToJSON BulkTest
117-- :}
119-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'
120-- which rejects 'Int' values below 1 and above 1000.
121--
122-- >>> mkShardCount 10
123-- Just (ShardCount 10)
124mkShardCount :: Int -> Maybe ShardCount
125mkShardCount n
126 | n < 1 = Nothing
127 | n > 1000 = Nothing
128 | otherwise = Just (ShardCount n)
130-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'
131-- which rejects 'Int' values below 1 and above 1000.
132--
133-- >>> mkReplicaCount 10
134-- Just (ReplicaCount 10)
135mkReplicaCount :: Int -> Maybe ReplicaCount
136mkReplicaCount n
137 | n < 1 = Nothing
138 | n > 1000 = Nothing -- ...
139 | otherwise = Just (ReplicaCount n)
141emptyBody :: L.ByteString
142emptyBody = L.pack ""
144dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString
145 -> m Reply
146dispatch dMethod url body = do
147 initReq <- liftIO $ parseUrl' url
148 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body
149 let req = initReq { method = dMethod
150 , requestBody = reqBody
151 , checkStatus = \_ _ _ -> Nothing}
152 mgr <- bhManager <$> getBHEnv
153 liftIO $ httpLbs req mgr
155joinPath' :: [Text] -> Text
156joinPath' = T.intercalate "/"
158joinPath :: MonadBH m => [Text] -> m Text
159joinPath ps = do
160 Server s <- bhServer <$> getBHEnv
161 return $ joinPath' (s:ps)
163bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
164bindM2 f ma mb = join (f <$> ma <*> mb)
166-- | Convenience function that sets up a mananager and BHEnv and runs
167-- the given set of bloodhound operations. Connections will be
168-- pipelined automatically in accordance with the given manager
169-- settings in IO. If you've got your own monad transformer stack, you
170-- should use 'runBH' directly.
171withBH :: ManagerSettings -> Server -> BH IO a -> IO a
172withBH ms s f = withManager ms $ \mgr -> do
173 let env = BHEnv { bhServer = s
174 , bhManager = mgr }
175 runBH env f
177-- Shortcut functions for HTTP methods
178delete :: MonadBH m => Text -> m Reply
179delete = flip (dispatch NHTM.methodDelete) Nothing
180get :: MonadBH m => Text -> m Reply
181get = flip (dispatch NHTM.methodGet) Nothing
182head :: MonadBH m => Text -> m Reply
183head = flip (dispatch NHTM.methodHead) Nothing
184put :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
185put = dispatch NHTM.methodPost
186post :: MonadBH m => Text -> Maybe L.ByteString -> m Reply
187post = dispatch NHTM.methodPost
189-- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)
190-- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html
191-- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs
193-- | 'getStatus' fetches the 'Status' of a 'Server'
194--
195-- >>> serverStatus <- runBH' getStatus
196-- >>> fmap status (serverStatus)
197-- Just 200
198getStatus :: MonadBH m => m (Maybe Status)
199getStatus = do
200 url <- joinPath []
201 request <- liftIO $ parseUrl' url
202 mgr <- bhManager <$> getBHEnv
203 response <- liftIO $ httpLbs request mgr
204 return $ decode (responseBody response)
206-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
207--
208-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
209-- >>> respIsTwoHunna response
210-- True
211-- >>> runBH' $ indexExists (IndexName "didimakeanindex")
212-- True
213createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply
214createIndex indexSettings (IndexName indexName) =
215 bindM2 put url (return body)
216 where url = joinPath [indexName]
217 body = Just $ encode indexSettings
219-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
220--
221-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
222-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")
223-- >>> respIsTwoHunna response
224-- True
225-- >>> runBH' $ indexExists testIndex
226-- False
227deleteIndex :: MonadBH m => IndexName -> m Reply
228deleteIndex (IndexName indexName) =
229 delete =<< joinPath [indexName]
231statusCodeIs :: Int -> Reply -> Bool
232statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n
234respIsTwoHunna :: Reply -> Bool
235respIsTwoHunna = statusCodeIs 200
237existentialQuery :: MonadBH m => Text -> m (Reply, Bool)
238existentialQuery url = do
239 reply <- head url
240 return (reply, respIsTwoHunna reply)
242-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
243-- in IO
244--
245-- >>> exists <- runBH' $ indexExists testIndex
246indexExists :: MonadBH m => IndexName -> m Bool
247indexExists (IndexName indexName) = do
248 (_, exists) <- existentialQuery =<< joinPath [indexName]
249 return exists
251-- | 'refreshIndex' will force a refresh on an index. You must
252-- do this if you want to read what you wrote.
253--
254-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
255-- >>> _ <- runBH' $ refreshIndex testIndex
256refreshIndex :: MonadBH m => IndexName -> m Reply
257refreshIndex (IndexName indexName) =
258 bindM2 post url (return Nothing)
259 where url = joinPath [indexName, "_refresh"]
261stringifyOCIndex :: OpenCloseIndex -> Text
262stringifyOCIndex oci = case oci of
263 OpenIndex -> "_open"
264 CloseIndex -> "_close"
266openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply
267openOrCloseIndexes oci (IndexName indexName) =
268 bindM2 post url (return Nothing)
269 where ociString = stringifyOCIndex oci
270 url = joinPath [indexName, ociString]
272-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
273-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
274--
275-- >>> reply <- runBH' $ openIndex testIndex
276openIndex :: MonadBH m => IndexName -> m Reply
277openIndex = openOrCloseIndexes OpenIndex
279-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
280-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
281--
282-- >>> reply <- runBH' $ closeIndex testIndex
283closeIndex :: MonadBH m => IndexName -> m Reply
284closeIndex = openOrCloseIndexes CloseIndex
286-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
287-- for documents in indexes.
288--
289-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
290-- >>> resp <- runBH' $ putMapping testIndex testMapping TweetMapping
291-- >>> print resp
292-- 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}
293putMapping :: (MonadBH m, ToJSON a) => IndexName
294 -> MappingName -> a -> m Reply
295putMapping (IndexName indexName) (MappingName mappingName) mapping =
296 bindM2 put url (return body)
297 where url = joinPath [indexName, mappingName, "_mapping"]
298 body = Just $ encode mapping
300-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
301-- Mappings are schemas for documents in indexes.
302--
303-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex
304-- >>> _ <- runBH' $ putMapping testIndex testMapping TweetMapping
305-- >>> resp <- runBH' $ deleteMapping testIndex testMapping
306-- >>> print resp
307-- 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}
308deleteMapping :: MonadBH m => IndexName -> MappingName -> m Reply
309deleteMapping (IndexName indexName)
310 (MappingName mappingName) =
311 delete =<< joinPath [indexName, mappingName, "_mapping"]
313-- | 'indexDocument' is the primary way to save a single document in
314-- Elasticsearch. The document itself is simply something we can
315-- convert into a JSON 'Value'. The 'DocId' will function as the
316-- primary key for the document.
317--
318-- >>> resp <- runBH' $ indexDocument testIndex testMapping exampleTweet (DocId "1")
319-- >>> print resp
320-- 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}
321indexDocument :: (ToJSON doc, MonadBH m) => IndexName -> MappingName
322 -> doc -> DocId -> m Reply
323indexDocument (IndexName indexName)
324 (MappingName mappingName) document (DocId docId) =
325 bindM2 put url (return body)
326 where url = joinPath [indexName, mappingName, docId]
327 body = Just (encode document)
329-- | 'deleteDocument' is the primary way to delete a single document.
330--
331-- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1")
332deleteDocument :: MonadBH m => IndexName -> MappingName
333 -> DocId -> m Reply
334deleteDocument (IndexName indexName)
335 (MappingName mappingName) (DocId docId) =
336 delete =<< joinPath [indexName, mappingName, docId]
338-- | 'bulk' uses
339-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>
340-- to perform bulk operations. The 'BulkOperation' data type encodes the
341-- index/update/delete/create operations. You pass a 'V.Vector' of 'BulkOperation's
342-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch
343-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
344--
345-- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
346-- >>> _ <- runBH' $ bulk stream
347-- >>> _ <- runBH' $ refreshIndex testIndex
348bulk :: MonadBH m => V.Vector BulkOperation -> m Reply
349bulk bulkOps = bindM2 post url (return body)
350 where url = joinPath ["_bulk"]
351 body = Just $ encodeBulkOperations bulkOps
353-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'
354-- into an 'L.ByteString'
355--
356-- >>> let bulkOps = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
357-- >>> encodeBulkOperations bulkOps
358-- "\n{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n"
359encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString
360encodeBulkOperations stream = collapsed where
361 blobs = fmap encodeBulkOperation stream
362 mashedTaters = mash (mempty :: Builder) blobs
363 collapsed = toLazyByteString $ mappend mashedTaters (byteString "\n")
365mash :: Builder -> V.Vector L.ByteString -> Builder
366mash = V.foldl' (\b x -> b `mappend` (byteString "\n") `mappend` (lazyByteString x))
368mkBulkStreamValue :: Text -> Text -> Text -> Text -> Value
369mkBulkStreamValue operation indexName mappingName docId =
370 object [operation .=
371 object [ "_index" .= indexName
372 , "_type" .= mappingName
373 , "_id" .= docId]]
375-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'
376-- into an 'L.ByteString'
377--
378-- >>> let bulkOp = BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))
379-- >>> encodeBulkOperation bulkOp
380-- "{\"index\":{\"_type\":\"tweet\",\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}"
381encodeBulkOperation :: BulkOperation -> L.ByteString
382encodeBulkOperation (BulkIndex (IndexName indexName)
383 (MappingName mappingName)
384 (DocId docId) value) = blob
385 where metadata = mkBulkStreamValue "index" indexName mappingName docId
386 blob = encode metadata `mappend` "\n" `mappend` encode value
388encodeBulkOperation (BulkCreate (IndexName indexName)
389 (MappingName mappingName)
390 (DocId docId) value) = blob
391 where metadata = mkBulkStreamValue "create" indexName mappingName docId
392 blob = encode metadata `mappend` "\n" `mappend` encode value
394encodeBulkOperation (BulkDelete (IndexName indexName)
395 (MappingName mappingName)
396 (DocId docId)) = blob
397 where metadata = mkBulkStreamValue "delete" indexName mappingName docId
398 blob = encode metadata
400encodeBulkOperation (BulkUpdate (IndexName indexName)
401 (MappingName mappingName)
402 (DocId docId) value) = blob
403 where metadata = mkBulkStreamValue "update" indexName mappingName docId
404 doc = object ["doc" .= value]
405 blob = encode metadata `mappend` "\n" `mappend` encode doc
407-- | 'getDocument' is a straight-forward way to fetch a single document from
408-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
409-- The 'DocId' is the primary key for your Elasticsearch document.
410--
411-- >>> yourDoc <- runBH' $ getDocument testIndex testMapping (DocId "1")
412getDocument :: MonadBH m => IndexName -> MappingName
413 -> DocId -> m Reply
414getDocument (IndexName indexName)
415 (MappingName mappingName) (DocId docId) =
416 get =<< joinPath [indexName, mappingName, docId]
418-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
419-- in IO
420--
421-- >>> exists <- runBH' $ documentExists testIndex testMapping (DocId "1")
422documentExists :: MonadBH m => IndexName -> MappingName
423 -> DocId -> m Bool
424documentExists (IndexName indexName)
425 (MappingName mappingName) (DocId docId) = do
426 (_, exists) <- existentialQuery =<< url
427 return exists
428 where url = joinPath [indexName, mappingName, docId]
430dispatchSearch :: MonadBH m => Text -> Search -> m Reply
431dispatchSearch url search = post url (Just (encode search))
433-- | 'searchAll', given a 'Search', will perform that search against all indexes
434-- on an Elasticsearch server. Try to avoid doing this if it can be helped.
435--
436-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
437-- >>> let search = mkSearch (Just query) Nothing
438-- >>> reply <- runBH' $ searchAll search
439searchAll :: MonadBH m => Search -> m Reply
440searchAll = bindM2 dispatchSearch url . return
441 where url = joinPath ["_search"]
443-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search
444-- against all mappings within an index on an Elasticsearch server.
445--
446-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
447-- >>> let search = mkSearch (Just query) Nothing
448-- >>> reply <- runBH' $ searchByIndex testIndex search
449searchByIndex :: MonadBH m => IndexName -> Search -> m Reply
450searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
451 where url = joinPath [indexName, "_search"]
453-- | 'searchByType', given a 'Search', 'IndexName', and 'MappingName', will perform that
454-- search against a specific mapping within an index on an Elasticsearch server.
455--
456-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
457-- >>> let search = mkSearch (Just query) Nothing
458-- >>> reply <- runBH' $ searchByType testIndex testMapping search
459searchByType :: MonadBH m => IndexName -> MappingName -> Search
460 -> m Reply
461searchByType (IndexName indexName)
462 (MappingName mappingName) = bindM2 dispatchSearch url . return
463 where url = joinPath [indexName, mappingName, "_search"]
465-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'
466-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update
467-- syntax if you want to add things like aggregations or highlights while still using
468-- this helper function.
469--
470-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
471-- >>> mkSearch (Just query) Nothing
472-- 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}
473mkSearch :: Maybe Query -> Maybe Filter -> Search
474mkSearch query filter = Search query filter Nothing Nothing Nothing False (From 0) (Size 10)
476-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for
477-- the 'Query' and the 'Aggregation'.
478--
479-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }
480-- >>> terms
481-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})
482-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms
483mkAggregateSearch :: Maybe Query -> Aggregations -> Search
484mkAggregateSearch query mkSearchAggs = Search query Nothing Nothing (Just mkSearchAggs) Nothing False (From 0) (Size 0)
486-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for
487-- the 'Query' and the 'Aggregation'.
488--
489-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
490-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
491-- >>> let search = mkHighlightSearch (Just query) testHighlight
492mkHighlightSearch :: Maybe Query -> Highlights -> Search
493mkHighlightSearch query searchHighlights = Search query Nothing Nothing Nothing (Just searchHighlights) False (From 0) (Size 10)
495-- | 'pageSearch' is a helper function that takes a search and assigns the from
496-- and size fields for the search. The from parameter defines the offset
497-- from the first result you want to fetch. The size parameter allows you to
498-- configure the maximum amount of hits to be returned.
499--
500-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
501-- >>> let search = mkSearch (Just query) Nothing
502-- >>> search
503-- 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})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10}
504-- >>> pageSearch (From 10) (Size 100) search
505-- 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})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100}
506pageSearch :: From -- ^ The result offset
507 -> Size -- ^ The number of results to return
508 -> Search -- ^ The current seach
509 -> Search -- ^ The paged search
510pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }
512parseUrl' :: MonadThrow m => Text -> m Request
513parseUrl' t =
514 case parseURI laxURIParserOptions (T.encodeUtf8 t) of
515 Right uri -> setURI def uri
516 Left e -> throwM $ InvalidUrlException (T.unpack t) ("Invalid URL: " ++ show e)
518setURI :: MonadThrow m => Request -> URI -> m Request
519setURI req URI{..} = do
520 Authority {..} <- maybe missingUA return uriAuthority
521 let req' = req { secure = isSecure
522 , host = hostBS authorityHost
523 , port = thePort
524 , path = uriPath
525 }
526 thePort = maybe defPort portNumber authorityPort
527 addAuth = maybe id addAuth' authorityUserInfo
528 return $ setQueryString theQueryString $ addAuth req'
529 where
530 missingUA = throwM $ InvalidUrlException "N/A" "Missing URI host/port"
531 addAuth' UserInfo {..} = applyBasicProxyAuth uiUsername uiPassword
532 defPort
533 | isSecure = 443
534 | otherwise = 80
535 isSecure = case uriScheme of
536 Scheme "https" -> True
537 _ -> False
538 theQueryString = [(k , Just v) | (k, v) <- queryPairs uriQuery]