fb84d9a · typeable/bloodhound

git.iko.soy/typeable/bloodhound

Use newtype wrapper for BH monad

Decided to just pull the trigger on this because the more I looked at the issue, the more the downsides looked trivial. I would consider this feature complete. I think segmenting the documentation is a great idea but orthogonal to this branch.

commitfb84d9a35f4e93812db905a546dac538dc4f185e authorMichael Xavier <michael@michaelxavier.net> dateMon 16 Mar 2015, 15:26 (12 years ago) parent664a376

3 files changed+66−35

compare with master

unifiedsplit

src/Database/Bloodhound/Client.hs+15−14 src/Database/Bloodhound/Types.hs+39−9 tests/tests.hs+12−12

src/Database/Bloodhound/Client.hs+15−14

@@ -52,18 +52,17 @@ module Database.Bloodhound.Client

5252import Control.Applicative

5353import Control.Monad

5454import Control.Monad.IO.Class

55−import Control.Monad.Reader

5655import Data.Aeson

5756import Data.ByteString.Lazy.Builder

58−import qualified Data.ByteString.Lazy.Char8 as L

59−import Data.List (intercalate)

60−import Data.Maybe (fromMaybe)

61−import Data.Text (Text)

62−import qualified Data.Vector as V

57+import qualified Data.ByteString.Lazy.Char8 as L

58+import Data.List (intercalate)

59+import Data.Maybe (fromMaybe)

60+import Data.Text (Text)

61+import qualified Data.Vector as V

6362import Network.HTTP.Client

64−import qualified Network.HTTP.Types.Method as NHTM

65−import qualified Network.HTTP.Types.Status as NHTS

66−import Prelude hiding (filter, head)

63+import qualified Network.HTTP.Types.Method as NHTM

64+import qualified Network.HTTP.Types.Status as NHTS

65+import Prelude hiding (filter, head)

6766

6867import Database.Bloodhound.Types

6968

@@ -161,12 +160,14 @@ bindM2 f ma mb = join (f <$> ma <*> mb)

161160

162161-- | Convenience function that sets up a mananager and BHEnv and runs

163162-- 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

163+-- pipelined automatically in accordance with the given manager

164+-- settings in IO. If you've got your own monad transformer stack, you

165+-- should use 'runBH' directly.

166+withBH :: ManagerSettings -> Server -> BH IO a -> IO a

166167withBH ms s f = withManager ms $ \mgr -> do

167168 let env = BHEnv { bhServer = s

168169 , bhManager = mgr }

169− runReaderT f env

170+ runBH env f

170171

171172-- Shortcut functions for HTTP methods

172173delete :: MonadBH m => String -> m Reply

@@ -263,14 +264,14 @@ openOrCloseIndexes oci (IndexName indexName) =

263264 where ociString = stringifyOCIndex oci

264265 url = joinPath [indexName, ociString]

265266

266−-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at

267+-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at

267268-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>

268269--

269270-- >>> reply <- runBH $ openIndex testIndex

270271openIndex :: MonadBH m => IndexName -> m Reply

271272openIndex = openOrCloseIndexes OpenIndex

272273

273−-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at

274+-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at

274275-- <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>

275276--

276277-- >>> reply <- runBH $ closeIndex testIndex

src/Database/Bloodhound/Types.hs+39−9

@@ -1,8 +1,11 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RecordWildCards #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FlexibleContexts #-}

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE RecordWildCards #-}

8+{-# LANGUAGE UndecidableInstances #-}

710-------------------------------------------------------------------------------

811-- |

@@ -42,6 +45,7 @@ module Database.Bloodhound.Types

4245 , toDateHistogram

4346 , omitNulls

4447 , BH

48+ , runBH

4549 , BHEnv(..)

4650 , MonadBH(..)

4751 , Version(..)

@@ -199,15 +203,16 @@ module Database.Bloodhound.Types

199203 ) where

200204

201205import Control.Applicative

202−import Control.Monad.IO.Class

206+import Control.Monad.Error

203207import Control.Monad.Reader

208+import Control.Monad.State

209+import Control.Monad.Writer

204210import Data.Aeson

205211import Data.Aeson.Types (Pair, emptyObject, parseMaybe)

206212import qualified Data.ByteString.Lazy.Char8 as L

207213import Data.List (nub)

208−import Data.List.NonEmpty (NonEmpty(..), toList)

214+import Data.List.NonEmpty (NonEmpty (..), toList)

209215import qualified Data.Map.Strict as M

210−import Data.Monoid

211216import Data.Text (Text)

212217import qualified Data.Text as T

213218import Data.Time.Clock (UTCTime)

@@ -244,11 +249,36 @@ data BHEnv = BHEnv { bhServer :: Server

244249class (Functor m, Applicative m, MonadIO m) => MonadBH m where

245250 getBHEnv :: m BHEnv

246251

247−type BH a = ReaderT BHEnv IO a

252+newtype BH m a = BH {

253+ unBH :: ReaderT BHEnv m a

254+ } deriving ( Functor

255+ , Applicative

256+ , Monad

257+ , MonadIO

258+ , MonadState s

259+ , MonadWriter w

260+ , MonadError e

261+ , MonadPlus

262+ , MonadFix)

263+

264+instance MonadTrans BH where

265+ lift = BH . lift

266+

267+instance (MonadReader r m) => MonadReader r (BH m) where

268+ ask = lift ask

269+ local f (BH (ReaderT m)) = BH $ ReaderT $ \r ->

270+ local f (m r)

271+

272+instance (Functor m, Applicative m, MonadIO m) => MonadBloodhound (BH m) where

273+ getBHEnv = BH getBHEnv

274+

248275

249276instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) where

250277 getBHEnv = ask

251278

279+runBH :: BHEnv -> BH m a -> m a

280+runBH e f = runReaderT (unBH f) e

281+

252282{-| 'Version' is embedded in 'Status' -}

253283data Version = Version { number :: Text

254284 , build_hash :: Text

tests/tests.hs+12−12

@@ -8,7 +8,7 @@ import Control.Applicative

88import Control.Monad

99import Control.Monad.Reader

1010import Data.Aeson

11−import qualified Data.HashMap.Strict as HM

11+import qualified Data.HashMap.Strict as HM

1212import Data.List (nub)

1313import Data.List.NonEmpty (NonEmpty (..))

1414import qualified Data.List.NonEmpty as NE

@@ -35,7 +35,7 @@ testIndex = IndexName "bloodhound-tests-twitter-1"

3535testMapping :: MappingName

3636testMapping = MappingName "tweet"

3737

38−withTestEnv :: BH a -> IO a

38+withTestEnv :: BH IO a -> IO a

3939withTestEnv = withBH defaultManagerSettings testServer

4040

4141validateStatus :: Response body -> Int -> Expectation

@@ -43,9 +43,9 @@ validateStatus resp expected =

4343 (NHTS.statusCode $ responseStatus resp)

4444 `shouldBe` (expected :: Int)

4545

46−createExampleIndex :: BH Reply

46+createExampleIndex :: BH IO Reply

4747createExampleIndex = createIndex defaultIndexSettings testIndex

48−deleteExampleIndex :: BH Reply

48+deleteExampleIndex :: BH IO Reply

4949deleteExampleIndex = deleteIndex testIndex

5050

5151data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord)

@@ -138,7 +138,7 @@ otherTweet = Tweet { user = "notmyapp"

138138 , age = 1000

139139 , location = Location 40.12 (-71.34) }

140140

141−insertData :: ReaderT BHEnv IO ()

141+insertData :: BH IO ()

142142insertData = do

143143 _ <- deleteExampleIndex

144144 _ <- createExampleIndex

@@ -147,20 +147,20 @@ insertData = do

147147 _ <- refreshIndex testIndex

148148 return ()

149149

150−insertOther :: BH ()

150+insertOther :: BH IO ()

151151insertOther = do

152152 _ <- indexDocument testIndex testMapping otherTweet (DocId "2")

153153 _ <- refreshIndex testIndex

154154 return ()

155155

156−searchTweet :: Search -> BH (Either String Tweet)

156+searchTweet :: Search -> BH IO (Either String Tweet)

157157searchTweet search = do

158158 reply <- searchByIndex testIndex search

159159 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)

160160 let myTweet = fmap (hitSource . head . hits . searchHits) result

161161 return myTweet

162162

163−searchExpectNoResults :: Search -> BH ()

163+searchExpectNoResults :: Search -> BH IO ()

164164searchExpectNoResults search = do

165165 reply <- searchByIndex testIndex search

166166 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)

@@ -168,7 +168,7 @@ searchExpectNoResults search = do

168168 liftIO $

169169 emptyHits `shouldBe` Right []

170170

171−searchExpectAggs :: Search -> BH ()

171+searchExpectAggs :: Search -> BH IO ()

172172searchExpectAggs search = do

173173 reply <- searchAll search

174174 let isEmpty x = return (M.null x)

@@ -176,7 +176,7 @@ searchExpectAggs search = do

176176 liftIO $

177177 (result >>= aggregations >>= isEmpty) `shouldBe` Just False

178178

179−searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH ()

179+searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()

180180searchValidBucketAgg search aggKey extractor = do

181181 reply <- searchAll search

182182 let bucketDocs = docCount . head . buckets

@@ -185,14 +185,14 @@ searchValidBucketAgg search aggKey extractor = do

185185 liftIO $

186186 count `shouldBe` Just 1

187187

188−searchTermsAggHint :: [ExecutionHint] -> BH ()

188+searchTermsAggHint :: [ExecutionHint] -> BH IO ()

189189searchTermsAggHint hints = do

190190 let terms hint = TermsAgg $ (mkTermsAggregation "user") { termExecutionHint = Just hint }

191191 let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint

192192 forM_ hints $ searchExpectAggs . search

193193 forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)

194194

195−searchTweetHighlight :: Search -> BH (Either String (Maybe HitHighlight))

195+searchTweetHighlight :: Search -> BH IO (Either String (Maybe HitHighlight))

196196searchTweetHighlight search = do

197197 reply <- searchByIndex testIndex search

198198 let result = eitherDecode (responseBody reply) :: Either String (SearchResult Tweet)