b811673 · typeable/bloodhound

git.iko.soy/typeable/bloodhound

Initial work in request hooks.

Going to take this and dogfood for a bit to see how well it works for AWS request signing.

commitb8116737a00397eff70a68dde9ed9c1c1ca1249b authorMichael Xavier <michael@michaelxavier.net> dateWed 2 Dec 2015, 16:08 (11 years ago) parent8ee8de0

4 files changed+94−50

compare with master

unifiedsplit

bloodhound.cabal+1 src/Database/Bloodhound/Client.hs+7−9 src/Database/Bloodhound/Types.hs+30−41 src/Database/Bloodhound/Types/Internal.hs+56

bloodhound.cabal+1

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

2727 Database.Bloodhound.Client

2828 Database.Bloodhound.Types

2929 Database.Bloodhound.Types.Class

30+ Database.Bloodhound.Types.Internal

3031 hs-source-dirs: src

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

3233 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

174174 -> m Reply

175175dispatch dMethod url body = do

176176 initReq <- liftIO $ parseUrl' url

177+ reqHook <- bhRequestHook <$> getBHEnv

177178 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body

178− let req = initReq { method = dMethod

179− , requestBody = reqBody

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

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

180+ , requestBody = reqBody

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

181182 mgr <- bhManager <$> getBHEnv

182183 liftIO $ httpLbs req mgr

183184

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

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

222223withBH ms s f = do

223224 mgr <- newManager ms

224− let env = BHEnv { bhServer = s

225− , bhManager = mgr }

225+ let env = mkBHEnv s mgr

226226 runBH env f

227227

228228-- Shortcut functions for HTTP methods

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

248248-- Just 200

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

250250getStatus = do

251− url <- joinPath []

252− request <- liftIO $ parseUrl' url

253− mgr <- bhManager <$> getBHEnv

254− response <- liftIO $ httpLbs request mgr

251+ response <- get =<< url

255252 return $ decode (responseBody response)

253+ where url = joinPath []

256254

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

258256--

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

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

5151 , omitNulls

5252 , BH(..)

5353 , runBH

54− , BHEnv(..)

54+ , BHEnv

55+ , bhServer

56+ , bhManager

57+ , bhRequestHook

58+ , mkBHEnv

5559 , MonadBH(..)

5660 , Version(..)

5761 , Status(..)

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

267271import Control.Monad.State

268272import Control.Monad.Writer

269273import Data.Aeson

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

271− parseMaybe)

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

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

275+ parseMaybe)

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

273277import Data.Char

274−import Data.Hashable (Hashable)

275−import qualified Data.HashMap.Strict as HM

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

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

278−import qualified Data.Map.Strict as M

278+import Data.Hashable (Hashable)

279+import qualified Data.HashMap.Strict as HM

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

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

282+import qualified Data.Map.Strict as M

279283import Data.Maybe

280−import Data.Text (Text)

281−import qualified Data.Text as T

284+import Data.Text (Text)

285+import qualified Data.Text as T

282286import Data.Time.Calendar

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

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

284288import Data.Time.Clock.POSIX

285−import qualified Data.Traversable as DT

286−import Data.Typeable (Typeable)

287−import qualified Data.Vector as V

289+import qualified Data.Traversable as DT

290+import Data.Typeable (Typeable)

291+import qualified Data.Vector as V

288292import GHC.Enum

289−import GHC.Generics (Generic)

293+import GHC.Generics (Generic)

290294import Network.HTTP.Client

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

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

292296

293297import Database.Bloodhound.Types.Class

298+import Database.Bloodhound.Types.Internal

294299

295300-- $setup

296301-- >>> :set -XOverloadedStrings

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

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

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

305310

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

307− pipelined according to the provided HTTP connection manager.

308−-}

309−data BHEnv = BHEnv { bhServer :: Server

310− , bhManager :: Manager

311− }

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

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

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

313+--

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

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

316+mkBHEnv s m = BHEnv s m return

320317

321318newtype BH m a = BH {

322319 unBH :: ReaderT BHEnv m a

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

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

346343 getBHEnv = BH getBHEnv

347344

348−

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

350− getBHEnv = ask

351−

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

353346runBH e f = runReaderT (unBH f) e

354347

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

479472

480473newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }

481474

482−data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName

475+data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName

483476 , sSummaryFixedSettings :: IndexSettings

484− , sSummaryUpdateable :: [UpdatableIndexSetting]}

477+ , sSummaryUpdateable :: [UpdatableIndexSetting]}

485478 deriving (Eq, Show, Generic, Typeable)

486479

487480{-| '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

764757-}

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

766759

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−

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

772761-}

773762newtype 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+