b811673 · typeable/bloodhound

git.iko.soy/typeable/bloodhound

on master help sign in

Initial work in request hooks.

b811673Michael Xavier11 years ago

bloodhound.cabal+1

compare with master

unifiedsplit

@@ -27,6 +27,7 @@ library

27 Database.Bloodhound.Client

28 Database.Bloodhound.Types

29 Database.Bloodhound.Types.Class

30+ Database.Bloodhound.Types.Internal

30 hs-source-dirs: src

31 hs-source-dirs: src

31 build-depends: base >= 4.3 && <5,

32 build-depends: base >= 4.3 && <5,

32 bytestring >= 0.10.0 && <0.11,

33 bytestring >= 0.10.0 && <0.11,

src/Database/Bloodhound/Client.hs+7−9

@@ -174,10 +174,11 @@ dispatch :: MonadBH m => Method -> Text -> Maybe L.ByteString

174 -> m Reply

175dispatch dMethod url body = do

176 initReq <- liftIO $ parseUrl' url

177+ reqHook <- bhRequestHook <$> getBHEnv

177 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body

178 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body

178− let req = initReq { method = dMethod

179+ req <- reqHook $ initReq { method = dMethod

179− , requestBody = reqBody

180+ , requestBody = reqBody

180− , checkStatus = \_ _ _ -> Nothing}

181+ , checkStatus = \_ _ _ -> Nothing}

181 mgr <- bhManager <$> getBHEnv

182 mgr <- bhManager <$> getBHEnv

182 liftIO $ httpLbs req mgr

183 liftIO $ httpLbs req mgr

183

184

@@ -221,8 +222,7 @@ bindM2 f ma mb = join (f <$> ma <*> mb)

221withBH :: ManagerSettings -> Server -> BH IO a -> IO a

222withBH :: ManagerSettings -> Server -> BH IO a -> IO a

222withBH ms s f = do

223withBH ms s f = do

223 mgr <- newManager ms

224 mgr <- newManager ms

224− let env = BHEnv { bhServer = s

225+ let env = mkBHEnv s mgr

225− , bhManager = mgr }

226 runBH env f

227

228-- Shortcut functions for HTTP methods

@@ -248,11 +248,9 @@ post = dispatch NHTM.methodPost

248-- Just 200

249getStatus :: MonadBH m => m (Maybe Status)

250getStatus = do

251− url <- joinPath []

251+ response <- get =<< url

252− request <- liftIO $ parseUrl' url

253− mgr <- bhManager <$> getBHEnv

254− response <- liftIO $ httpLbs request mgr

255 return $ decode (responseBody response)

252 return $ decode (responseBody response)

253+ where url = joinPath []

256

254

257-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.

255-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.

258--

256--

src/Database/Bloodhound/Types.hs+30−41

@@ -51,7 +51,11 @@ module Database.Bloodhound.Types

51 , omitNulls

52 , BH(..)

53 , runBH

54− , BHEnv(..)

54+ , BHEnv

55+ , bhServer

56+ , bhManager

57+ , bhRequestHook

58+ , mkBHEnv

55 , MonadBH(..)

59 , MonadBH(..)

56 , Version(..)

60 , Version(..)

57 , Status(..)

61 , Status(..)

@@ -267,30 +271,31 @@ import Control.Monad.Reader

267import Control.Monad.State

271import Control.Monad.State

268import Control.Monad.Writer

272import Control.Monad.Writer

269import Data.Aeson

273import Data.Aeson

270−import Data.Aeson.Types (Pair, Parser, emptyObject,

274+import Data.Aeson.Types (Pair, Parser, emptyObject,

271− parseMaybe)

275+ parseMaybe)

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

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

273import Data.Char

277import Data.Char

274−import Data.Hashable (Hashable)

278+import Data.Hashable (Hashable)

275−import qualified Data.HashMap.Strict as HM

279+import qualified Data.HashMap.Strict as HM

276−import Data.List (foldl', nub)

280+import Data.List (foldl', nub)

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

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

278−import qualified Data.Map.Strict as M

282+import qualified Data.Map.Strict as M

279import Data.Maybe

283import Data.Maybe

280−import Data.Text (Text)

284+import Data.Text (Text)

281−import qualified Data.Text as T

285+import qualified Data.Text as T

282import Data.Time.Calendar

286import Data.Time.Calendar

283−import Data.Time.Clock (NominalDiffTime, UTCTime)

287+import Data.Time.Clock (NominalDiffTime, UTCTime)

284import Data.Time.Clock.POSIX

288import Data.Time.Clock.POSIX

285−import qualified Data.Traversable as DT

289+import qualified Data.Traversable as DT

286−import Data.Typeable (Typeable)

290+import Data.Typeable (Typeable)

287−import qualified Data.Vector as V

291+import qualified Data.Vector as V

288import GHC.Enum

292import GHC.Enum

289−import GHC.Generics (Generic)

293+import GHC.Generics (Generic)

290import Network.HTTP.Client

294import Network.HTTP.Client

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

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

292

296

293import Database.Bloodhound.Types.Class

297import Database.Bloodhound.Types.Class

298+import Database.Bloodhound.Types.Internal

294

299

295-- $setup

300-- $setup

296-- >>> :set -XOverloadedStrings

301-- >>> :set -XOverloadedStrings

@@ -303,20 +308,12 @@ import Database.Bloodhound.Types.Class

303-- defaultIndexSettings is exported by Database.Bloodhound as well

308-- defaultIndexSettings is exported by Database.Bloodhound as well

304-- no trailing slashes in servers, library handles building the path.

309-- no trailing slashes in servers, library handles building the path.

305

310

306−{-| Common environment for Elasticsearch calls. Connections will be

311+-- | Create a 'BHEnv' with all optional fields defaulted. HTTP hook

307− pipelined according to the provided HTTP connection manager.

312+-- will be a noop. You can use the exported fields to customize it further, e.g.:

308−-}

313+--

309−data BHEnv = BHEnv { bhServer :: Server

314+-- >> (mkBHEnv myServer myManager) { bhRequestHook = customHook }

310− , bhManager :: Manager

315+mkBHEnv :: Server -> Manager -> BHEnv

311− }

316+mkBHEnv s m = BHEnv s m return

312−

313−{-| All API calls to Elasticsearch operate within

314− MonadBH. The idea is that it can be easily embedded in your

315− own monad transformer stack. A default instance for a ReaderT and

316− alias 'BH' is provided for the simple case.

317−-}

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

319− getBHEnv :: m BHEnv

320

317

321newtype BH m a = BH {

318newtype BH m a = BH {

322 unBH :: ReaderT BHEnv m a

319 unBH :: ReaderT BHEnv m a

@@ -345,10 +342,6 @@ instance (MonadReader r m) => MonadReader r (BH m) where

345instance (Functor m, Applicative m, MonadIO m) => MonadBH (BH m) where

342instance (Functor m, Applicative m, MonadIO m) => MonadBH (BH m) where

346 getBHEnv = BH getBHEnv

343 getBHEnv = BH getBHEnv

347

344

348−

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

350− getBHEnv = ask

351−

352runBH :: BHEnv -> BH m a -> m a

345runBH :: BHEnv -> BH m a -> m a

353runBH e f = runReaderT (unBH f) e

346runBH e f = runReaderT (unBH f) e

354

347

@@ -479,9 +472,9 @@ data CompoundFormat = CompoundFileFormat Bool

479

472

480newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }

473newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }

481

474

482−data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName

475+data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName

483 , sSummaryFixedSettings :: IndexSettings

476 , sSummaryFixedSettings :: IndexSettings

484− , sSummaryUpdateable :: [UpdatableIndexSetting]}

477+ , sSummaryUpdateable :: [UpdatableIndexSetting]}

485 deriving (Eq, Show, Generic, Typeable)

478 deriving (Eq, Show, Generic, Typeable)

486

479

487{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -}

480{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -}

@@ -764,10 +757,6 @@ newtype ShardCount = ShardCount Int deriving (Eq, Show, Generic, ToJSON, Typeabl

764-}

757-}

765newtype ReplicaCount = ReplicaCount Int deriving (Eq, Show, Generic, ToJSON, Typeable)

758newtype ReplicaCount = ReplicaCount Int deriving (Eq, Show, Generic, ToJSON, Typeable)

766

759

767−{-| 'Server' is used with the client functions to point at the ES instance

768−-}

769−newtype Server = Server Text deriving (Eq, Show, Generic, Typeable)

770−

771{-| 'IndexName' is used to describe which index to query/create/delete

760{-| 'IndexName' is used to describe which index to query/create/delete

772-}

761-}

773newtype IndexName = IndexName Text deriving (Eq, Generic, Show, ToJSON, FromJSON, Typeable)

762newtype IndexName = IndexName Text deriving (Eq, Generic, Show, ToJSON, FromJSON, Typeable)

src/Database/Bloodhound/Types/Internal.hsnew file+56

@@ -0,0 +1,56 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE RankNTypes #-}

7+-------------------------------------------------------------------------------

8+-- |

9+-- Module : Database.Bloodhound.Types.Internal

11+-- License : BSD-style (see the file LICENSE)

12+-- Maintainer : Chris Allen <cma@bitemyapp.com

13+-- Stability : provisional

14+-- Portability : DeriveGeneric, RecordWildCards

15+--

16+-- Internal data types for Bloodhound. These types may change without

17+-- notice so import at your own risk.

18+-------------------------------------------------------------------------------

19+module Database.Bloodhound.Types.Internal

20+ ( BHEnv(..)

21+ , Server(..)

22+ , MonadBH(..)

23+ ) where

24+

25+

26+import Control.Monad.Reader

27+import Data.Text (Text)

28+import Data.Typeable (Typeable)

29+import GHC.Generics (Generic)

30+import Network.HTTP.Client

31+

32+{-| Common environment for Elasticsearch calls. Connections will be

33+ pipelined according to the provided HTTP connection manager.

34+-}

35+data BHEnv = BHEnv { bhServer :: Server

36+ , bhManager :: Manager

37+ , bhRequestHook :: forall m. (MonadBH m) => Request -> m Request

38+ -- ^ Low-level hook that is run before every request is sent. Used to implement custom authentication strategies. Defaults to 'return' with 'mkBHEnv'.

39+ }

40+

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

42+ getBHEnv = ask

43+

44+{-| 'Server' is used with the client functions to point at the ES instance

45+-}

46+newtype Server = Server Text deriving (Eq, Show, Generic, Typeable)

47+

48+{-| All API calls to Elasticsearch operate within

49+ MonadBH

50+ . The idea is that it can be easily embedded in your

51+ own monad transformer stack. A default instance for a ReaderT and

52+ alias 'BH' is provided for the simple case.

53+-}

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

55+ getBHEnv :: m BHEnv

56+