git.iko.soy/typeable/bloodhound
on master help sign in
Cleanup and document
commit2f013a0b806dc1f47185bab806c6e3ea3cc8ca74 authorMichael Xavier <michael@michaelxavier.net> dateTue 3 Mar 2015, 20:49 (12 years ago) parent279e169
3 files changed+61−46
compare with master
unifiedsplit
src/Database/Bloodhound/Client.hs+38−29 src/Database/Bloodhound/Types.hs+11 tests/tests.hs+12−17
src/Database/Bloodhound/Client.hs+38−29
@@ -20,8 +20,8 @@ module Database.Bloodhound.Client
2020 -- and typeclass instances for the functions that make use of them.
2121
2222 -- $setup
23−
24− createIndex
23+ withBH
24+ , createIndex
2525 , deleteIndex
2626 , indexExists
2727 , openIndex
@@ -52,6 +52,7 @@ module Database.Bloodhound.Client
5252import Control.Applicative
5353import Control.Monad
5454import Control.Monad.IO.Class
55+import Control.Monad.Reader
5556import Data.Aeson
5657import Data.ByteString.Lazy.Builder
5758import qualified Data.ByteString.Lazy.Char8 as L
@@ -72,12 +73,12 @@ import Database.Bloodhound.Types
7273-- >>> import Database.Bloodhound
7374-- >>> import Test.DocTest.Prop (assert)
7475-- >>> let testServer = (Server "http://localhost:9200")
76+-- >>> let runBH = withBH defaultManagerSettings testServer
7577-- >>> let testIndex = IndexName "twitter"
7678-- >>> let testMapping = MappingName "tweet"
7779-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
7880-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)
79−-- >>> _ <- deleteIndex testServer testIndex
80−-- >>> _ <- deleteMapping testServer testIndex testMapping
81+-- >>> _ <- runBH $ deleteIndex testIndex >> deleteMapping testIndex testMapping
8182-- >>> import GHC.Generics
8283-- >>> import Data.Time.Calendar (Day (..))
8384-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
@@ -158,6 +159,14 @@ joinPath ps = do
158159bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c
159160bindM2 f ma mb = join (f <$> ma <*> mb)
160161
162+-- | Convenience function that sets up a mananager and BHEnv and runs
163+-- the given set of bloodhound operations. Connections will be
164+-- pipelined automatically in accordance with the given manager settings
165+withBH :: ManagerSettings -> Server -> BH a -> IO a
166+withBH ms s f = withManager ms $ \mgr -> do
167+ let env = BHEnv { bhServer = s
168+ , bhManager = mgr }
169+ runReaderT f env
161170
162171-- Shortcut functions for HTTP methods
163172delete :: MonadBloodhound m => String -> m Reply
@@ -177,7 +186,7 @@ post = dispatch NHTM.methodPost
177186
178187-- | 'getStatus' fetches the 'Status' of a 'Server'
179188--
180−-- >>> serverStatus <- getStatus testServer
189+-- >>> serverStatus <- runBH getStatus
181190-- >>> fmap status (serverStatus)
182191-- Just 200
183192getStatus :: MonadBloodhound m => m (Maybe Status)
@@ -190,10 +199,10 @@ getStatus = do
190199
191200-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.
192201--
193−-- >>> response <- createIndex testServer defaultIndexSettings (IndexName "didimakeanindex")
202+-- >>> response <- runBH $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
194203-- >>> respIsTwoHunna response
195204-- True
196−-- >>> indexExists testServer (IndexName "didimakeanindex")
205+-- >>> runBH $ indexExists (IndexName "didimakeanindex")
197206-- True
198207createIndex :: MonadBloodhound m => IndexSettings -> IndexName -> m Reply
199208createIndex indexSettings (IndexName indexName) =
@@ -203,11 +212,11 @@ createIndex indexSettings (IndexName indexName) =
203212
204213-- | 'deleteIndex' will delete an index given a 'Server', and an 'IndexName'.
205214--
206−-- >>> response <- createIndex testServer defaultIndexSettings (IndexName "didimakeanindex")
207−-- >>> response <- deleteIndex testServer (IndexName "didimakeanindex")
215+-- >>> _ <- runBH $ createIndex defaultIndexSettings (IndexName "didimakeanindex")
216+-- >>> response <- runBH $ deleteIndex (IndexName "didimakeanindex")
208217-- >>> respIsTwoHunna response
209218-- True
210−-- >>> indexExists testServer testIndex
219+-- >>> runBH $ indexExists testIndex
211220-- False
212221deleteIndex :: MonadBloodhound m => IndexName -> m Reply
213222deleteIndex (IndexName indexName) =
@@ -227,7 +236,7 @@ existentialQuery url = do
227236-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'
228237-- in IO
229238--
230−-- >>> exists <- indexExists testServer testIndex
239+-- >>> exists <- runBH $ indexExists testIndex
231240indexExists :: MonadBloodhound m => IndexName -> m Bool
232241indexExists (IndexName indexName) = do
233242 (_, exists) <- existentialQuery =<< joinPath [indexName]
@@ -236,8 +245,8 @@ indexExists (IndexName indexName) = do
236245-- | 'refreshIndex' will force a refresh on an index. You must
237246-- do this if you want to read what you wrote.
238247--
239−-- >>> _ <- createIndex testServer defaultIndexSettings testIndex
240−-- >>> _ <- refreshIndex testServer testIndex
248+-- >>> _ <- runBH $ createIndex defaultIndexSettings testIndex
249+-- >>> _ <- runBH $ refreshIndex testIndex
241250refreshIndex :: MonadBloodhound m => IndexName -> m Reply
242251refreshIndex (IndexName indexName) =
243252 bindM2 post url (return Nothing)
@@ -257,22 +266,22 @@ openOrCloseIndexes oci (IndexName indexName) =
257266-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at
258267-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
259268--
260−-- >>> reply <- openIndex testServer testIndex
269+-- >>> reply <- runBH $ openIndex testIndex
261270openIndex :: MonadBloodhound m => IndexName -> m Reply
262271openIndex = openOrCloseIndexes OpenIndex
263272
264273-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at
265274-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>
266275--
267−-- >>> reply <- closeIndex testServer testIndex
276+-- >>> reply <- runBH $ closeIndex testIndex
268277closeIndex :: MonadBloodhound m => IndexName -> m Reply
269278closeIndex = openOrCloseIndexes CloseIndex
270279
271280-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas
272281-- for documents in indexes.
273282--
274−-- >>> _ <- createIndex testServer defaultIndexSettings testIndex
275−-- >>> resp <- putMapping testServer testIndex testMapping TweetMapping
283+-- >>> _ <- runBH $ createIndex defaultIndexSettings testIndex
284+-- >>> resp <- runBH $ putMapping testIndex testMapping TweetMapping
276285-- >>> print resp
277286-- 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}
278287putMapping :: (MonadBloodhound m, ToJSON a) => IndexName
@@ -285,9 +294,9 @@ putMapping (IndexName indexName) (MappingName mappingName) mapping =
285294-- | 'deleteMapping' is an HTTP DELETE and deletes a mapping for a given index.
286295-- Mappings are schemas for documents in indexes.
287296--
288−-- >>> _ <- createIndex testServer defaultIndexSettings testIndex
289−-- >>> _ <- putMapping testServer testIndex testMapping TweetMapping
290−-- >>> resp <- deleteMapping testServer testIndex testMapping
297+-- >>> _ <- runBH $ createIndex defaultIndexSettings testIndex
298+-- >>> _ <- runBH $ putMapping testIndex testMapping TweetMapping
299+-- >>> resp <- runBH $ deleteMapping testIndex testMapping
291300-- >>> print resp
292301-- 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}
293302deleteMapping :: MonadBloodhound m => IndexName -> MappingName -> m Reply
@@ -300,7 +309,7 @@ deleteMapping (IndexName indexName)
300309-- convert into a JSON 'Value'. The 'DocId' will function as the
301310-- primary key for the document.
302311--
303−-- >>> resp <- indexDocument testServer testIndex testMapping exampleTweet (DocId "1")
312+-- >>> resp <- runBH $ indexDocument testIndex testMapping exampleTweet (DocId "1")
304313-- >>> print resp
305314-- 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}
306315indexDocument :: (ToJSON doc, MonadBloodhound m) => IndexName -> MappingName
@@ -313,7 +322,7 @@ indexDocument (IndexName indexName)
313322
314323-- | 'deleteDocument' is the primary way to delete a single document.
315324--
316−-- >>> _ <- deleteDocument testServer testIndex testMapping (DocId "1")
325+-- >>> _ <- runBH $ deleteDocument testIndex testMapping (DocId "1")
317326deleteDocument :: MonadBloodhound m => IndexName -> MappingName
318327 -> DocId -> m Reply
319328deleteDocument (IndexName indexName)
@@ -328,8 +337,8 @@ deleteDocument (IndexName indexName)
328337-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.
329338--
330339-- >>> let stream = V.fromList [BulkIndex testIndex testMapping (DocId "2") (toJSON (BulkTest "blah"))]
331−-- >>> _ <- bulk testServer stream
332−-- >>> _ <- refreshIndex testServer testIndex
340+-- >>> _ <- runBH $ bulk stream
341+-- >>> _ <- runBH $ refreshIndex testIndex
333342bulk :: MonadBloodhound m => V.Vector BulkOperation -> m Reply
334343bulk bulkOps = bindM2 post url (return body)
335344 where url = joinPath ["_bulk"]
@@ -393,7 +402,7 @@ encodeBulkOperation (BulkUpdate (IndexName indexName)
393402-- Elasticsearch using a 'Server', 'IndexName', 'MappingName', and a 'DocId'.
394403-- The 'DocId' is the primary key for your Elasticsearch document.
395404--
396−-- >>> yourDoc <- getDocument testServer testIndex testMapping (DocId "1")
405+-- >>> yourDoc <- runBH $ getDocument testIndex testMapping (DocId "1")
397406getDocument :: MonadBloodhound m => IndexName -> MappingName
398407 -> DocId -> m Reply
399408getDocument (IndexName indexName)
@@ -403,7 +412,7 @@ getDocument (IndexName indexName)
403412-- | 'documentExists' enables you to check if a document exists. Returns 'Bool'
404413-- in IO
405414--
406−-- >>> exists <- documentExists testServer testIndex testMapping (DocId "1")
415+-- >>> exists <- runBH $ documentExists testIndex testMapping (DocId "1")
407416documentExists :: MonadBloodhound m => IndexName -> MappingName
408417 -> DocId -> m Bool
409418documentExists (IndexName indexName)
@@ -420,7 +429,7 @@ dispatchSearch url search = post url (Just (encode search))
420429--
421430-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
422431-- >>> let search = mkSearch (Just query) Nothing
423−-- >>> reply <- searchAll testServer search
432+-- >>> reply <- runBH $ searchAll search
424433searchAll :: MonadBloodhound m => Search -> m Reply
425434searchAll = bindM2 dispatchSearch url . return
426435 where url = joinPath ["_search"]
@@ -430,7 +439,7 @@ searchAll = bindM2 dispatchSearch url . return
430439--
431440-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
432441-- >>> let search = mkSearch (Just query) Nothing
433−-- >>> reply <- searchByIndex testServer testIndex search
442+-- >>> reply <- runBH $ searchByIndex testIndex search
434443searchByIndex :: MonadBloodhound m => IndexName -> Search -> m Reply
435444searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
436445 where url = joinPath [indexName, "_search"]
@@ -440,7 +449,7 @@ searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return
440449--
441450-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing
442451-- >>> let search = mkSearch (Just query) Nothing
443−-- >>> reply <- searchByType testServer testIndex testMapping search
452+-- >>> reply <- runBH $ searchByType testIndex testMapping search
444453searchByType :: MonadBloodhound m => IndexName -> MappingName -> Search
445454 -> m Reply
446455searchByType (IndexName indexName)
src/Database/Bloodhound/Types.hs+11
@@ -41,6 +41,7 @@ module Database.Bloodhound.Types
4141 , toTerms
4242 , toDateHistogram
4343 , omitNulls
44+ , BH
4445 , BHEnv(..)
4546 , MonadBloodhound(..)
4647 , Version(..)
@@ -228,13 +229,23 @@ import Database.Bloodhound.Types.Class
228229-- defaultIndexSettings is exported by Database.Bloodhound as well
229230-- no trailing slashes in servers, library handles building the path.
230231
232+{-| Common environment for Elasticsearch calls. Connections will be
233+ pipelined according to the provided HTTP connection manager.
234+-}
231235data BHEnv = BHEnv { bhServer :: Server
232236 , bhManager :: Manager
233237 }
234238
239+{-| All API calls to Elasticsearch operate within
240+ MonadBloodhound. The idea is that it can be easily embedded in your
241+ own monad transformer stack. A default instance for a ReaderT and
242+ alias 'BH' is provided for the simple case.
243+-}
235244class (Functor m, Applicative m, MonadIO m) => MonadBloodhound m where
236245 getBHEnv :: m BHEnv
237246
247+type BH a = ReaderT BHEnv IO a
248+
238249instance (Functor m, Applicative m, MonadIO m) => MonadBloodhound (ReaderT BHEnv m) where
239250 getBHEnv = ask
240251
tests/tests.hs+12−17
@@ -35,22 +35,17 @@ testIndex = IndexName "bloodhound-tests-twitter-1"
3535testMapping :: MappingName
3636testMapping = MappingName "tweet"
3737
38−
39−--TODO: similar convenience function in Client
40−-- withTestEnv :: MonadIO m => Reader m a -> IO a
41−withTestEnv f = withManager defaultManagerSettings $ \mgr -> do
42− let env = BHEnv { bhServer = testServer
43− , bhManager = mgr }
44− runReaderT f env
38+withTestEnv :: BH a -> IO a
39+withTestEnv = withBH defaultManagerSettings testServer
4540
4641validateStatus :: Response body -> Int -> Expectation
4742validateStatus resp expected =
4843 (NHTS.statusCode $ responseStatus resp)
4944 `shouldBe` (expected :: Int)
5045
51−-- createExampleIndex :: IO Reply
46+createExampleIndex :: BH Reply
5247createExampleIndex = createIndex defaultIndexSettings testIndex
53−-- deleteExampleIndex :: IO Reply
48+deleteExampleIndex :: BH Reply
5449deleteExampleIndex = deleteIndex testIndex
5550
5651data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)
@@ -79,7 +74,7 @@ mkServerVersion [majorVer, minorVer, patchVer] =
7974 Just (ServerVersion majorVer minorVer patchVer)
8075mkServerVersion _ = Nothing
8176
82−-- getServerVersion :: IO (Maybe ServerVersion)
77+getServerVersion :: IO (Maybe ServerVersion)
8378getServerVersion = liftM extractVersion (withTestEnv getStatus)
8479 where
8580 version' = T.splitOn "." . number . version
@@ -152,20 +147,20 @@ insertData = do
152147 _ <- refreshIndex testIndex
153148 return ()
154149
155−-- insertOther :: IO ()
150+insertOther :: BH ()
156151insertOther = do
157152 _ <- indexDocument testIndex testMapping otherTweet (DocId "2")
158153 _ <- refreshIndex testIndex
159154 return ()
160155
161−-- searchTweet :: Search -> IO (Either String Tweet)
156+searchTweet :: Search -> BH (Either String Tweet)
162157searchTweet search = do
163158 reply <- searchByIndex testIndex search
164159 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
165160 let myTweet = fmap (hitSource . head . hits . searchHits) result
166161 return myTweet
167162
168−-- searchExpectNoResults :: Search -> IO ()
163+searchExpectNoResults :: Search -> BH ()
169164searchExpectNoResults search = do
170165 reply <- searchByIndex testIndex search
171166 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)
@@ -173,7 +168,7 @@ searchExpectNoResults search = do
173168 liftIO $
174169 emptyHits `shouldBe` Right []
175170
176−-- searchExpectAggs :: Search -> IO ()
171+searchExpectAggs :: Search -> BH ()
177172searchExpectAggs search = do
178173 reply <- searchAll search
179174 let isEmpty x = return (M.null x)
@@ -181,7 +176,7 @@ searchExpectAggs search = do
181176 liftIO $
182177 (result >>= aggregations >>= isEmpty) `shouldBe` Just False
183178
184−-- searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> IO ()
179+searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH ()
185180searchValidBucketAgg search aggKey extractor = do
186181 reply <- searchAll search
187182 let bucketDocs = docCount . head . buckets
@@ -190,14 +185,14 @@ searchValidBucketAgg search aggKey extractor = do
190185 liftIO $
191186 count `shouldBe` Just 1
192187
193−-- searchTermsAggHint :: [ExecutionHint] -> IO ()
188+searchTermsAggHint :: [ExecutionHint] -> BH ()
194189searchTermsAggHint hints = do
195190 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }
196191 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint
197192 forM_ hints $ searchExpectAggs . search
198193 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)
199194
200−-- searchTweetHighlight :: Search -> IO (Either String (Maybe HitHighlight))
195+searchTweetHighlight :: Search -> BH (Either String (Maybe HitHighlight))
201196searchTweetHighlight search = do
202197 reply <- searchByIndex testIndex search
203198 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)