c3df597 · typeable/bloodhound

git.iko.soy/typeable/bloodhound

on master help sign in

Merge pull request #84 from Soostone/request-hook

c3df597Chris Allen11 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+20−9

@@ -58,6 +58,8 @@ module Database.Bloodhound.Client

58 , getStatus

59 , encodeBulkOperations

60 , encodeBulkOperation

61+ -- * Authentication

62+ , basicAuthHook

61 -- * Reply-handling tools

63 -- * Reply-handling tools

62 , isVersionConflict

64 , isVersionConflict

63 , isSuccess

65 , isSuccess

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

175 -> m Reply

177 -> m Reply

176dispatch dMethod url body = do

178dispatch dMethod url body = do

177 initReq <- liftIO $ parseUrl' url

179 initReq <- liftIO $ parseUrl' url

180+ reqHook <- bhRequestHook <$> getBHEnv

178 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body

181 let reqBody = RequestBodyLBS $ fromMaybe emptyBody body

179− let req = initReq { method = dMethod

182+ req <- liftIO $ reqHook $ initReq { method = dMethod

180− , requestBody = reqBody

183+ , requestBody = reqBody

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

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

182 mgr <- bhManager <$> getBHEnv

185 mgr <- bhManager <$> getBHEnv

183 liftIO $ httpLbs req mgr

186 liftIO $ httpLbs req mgr

184

187

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

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

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

223withBH ms s f = do

226withBH ms s f = do

224 mgr <- newManager ms

227 mgr <- newManager ms

225− let env = BHEnv { bhServer = s

228+ let env = mkBHEnv s mgr

226− , bhManager = mgr }

227 runBH env f

229 runBH env f

228

230

229-- Shortcut functions for HTTP methods

231-- Shortcut functions for HTTP methods

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

249-- Just 200

251-- Just 200

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

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

251getStatus = do

253getStatus = do

252− url <- joinPath []

254+ response <- get =<< url

253− request <- liftIO $ parseUrl' url

254− mgr <- bhManager <$> getBHEnv

255− response <- liftIO $ httpLbs request mgr

256 return $ decode (responseBody response)

255 return $ decode (responseBody response)

256+ where url = joinPath []

257

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

259--

@@ -785,3 +785,14 @@ isCreated = statusCheck (== 201)

785

786statusCheck :: (Int -> Bool) -> Reply -> Bool

787statusCheck prd = prd . NHTS.statusCode . responseStatus

788+

789+-- | This is a hook that can be set via the 'bhRequestHook' function

790+-- that will authenticate all requests using an HTTP Basic

791+-- Authentication header. Note that it is *strongly* recommended that

792+-- this option only be used over an SSL connection.

793+--

794+-- >> (mkBHEnv myServer myManager) { bhRequestHook = basicAuthHook (EsUsername "myuser") (EsPassword "mypass") }

795+basicAuthHook :: Monad m => EsUsername -> EsPassword -> Request -> m Request

796+basicAuthHook (EsUsername u) (EsPassword p) = return . applyBasicAuth u' p'

797+ where u' = T.encodeUtf8 u

798+ p' = T.encodeUtf8 p

src/Database/Bloodhound/Types.hs+39−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(..)

@@ -258,6 +262,9 @@ module Database.Bloodhound.Types

258 , TermsResult(..)

262 , TermsResult(..)

259 , DateHistogramResult(..)

263 , DateHistogramResult(..)

260 , DateRangeResult(..)

264 , DateRangeResult(..)

265+

266+ , EsUsername(..)

267+ , EsPassword(..)

261 ) where

268 ) where

262

269

263import Control.Applicative

270import Control.Applicative

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

267import Control.Monad.State

274import Control.Monad.State

268import Control.Monad.Writer

275import Control.Monad.Writer

269import Data.Aeson

276import Data.Aeson

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

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

271− parseMaybe)

278+ parseMaybe)

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

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

273import Data.Char

280import Data.Char

274−import Data.Hashable (Hashable)

281+import Data.Hashable (Hashable)

275−import qualified Data.HashMap.Strict as HM

282+import qualified Data.HashMap.Strict as HM

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

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

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

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

278−import qualified Data.Map.Strict as M

285+import qualified Data.Map.Strict as M

279import Data.Maybe

286import Data.Maybe

280−import Data.Text (Text)

287+import Data.Text (Text)

281−import qualified Data.Text as T

288+import qualified Data.Text as T

282import Data.Time.Calendar

289import Data.Time.Calendar

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

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

284import Data.Time.Clock.POSIX

291import Data.Time.Clock.POSIX

285−import qualified Data.Traversable as DT

292+import qualified Data.Traversable as DT

286−import Data.Typeable (Typeable)

293+import Data.Typeable (Typeable)

287−import qualified Data.Vector as V

294+import qualified Data.Vector as V

288import GHC.Enum

295import GHC.Enum

289−import GHC.Generics (Generic)

296+import GHC.Generics (Generic)

290import Network.HTTP.Client

297import Network.HTTP.Client

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

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

292

299

293import Database.Bloodhound.Types.Class

300import Database.Bloodhound.Types.Class

301+import Database.Bloodhound.Types.Internal

294

302

295-- $setup

303-- $setup

296-- >>> :set -XOverloadedStrings

304-- >>> :set -XOverloadedStrings

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

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

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

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

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

305

313

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

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

307− pipelined according to the provided HTTP connection manager.

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

308−-}

316+--

309−data BHEnv = BHEnv { bhServer :: Server

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

310− , bhManager :: Manager

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

311− }

319+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

321newtype BH m a = BH {

322 unBH :: ReaderT BHEnv m a

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

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

346 getBHEnv = BH getBHEnv

347

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

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

353runBH e f = runReaderT (unBH f) e

349runBH e f = runReaderT (unBH f) e

354

350

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

479

475

480newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }

476newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime }

481

477

482−data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName

478+data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName

483 , sSummaryFixedSettings :: IndexSettings

479 , sSummaryFixedSettings :: IndexSettings

484− , sSummaryUpdateable :: [UpdatableIndexSetting]}

480+ , sSummaryUpdateable :: [UpdatableIndexSetting]}

485 deriving (Eq, Show, Generic, Typeable)

481 deriving (Eq, Show, Generic, Typeable)

486

482

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

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

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

764-}

760-}

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

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

766

762

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

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

772-}

764-}

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

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

@@ -3544,3 +3536,9 @@ instance Enum DocVersion where

3544 fromEnum = docVersionNumber

3536 fromEnum = docVersionNumber

3545 enumFrom = boundedEnumFrom

3537 enumFrom = boundedEnumFrom

3546 enumFromThen = boundedEnumFromThen

3538 enumFromThen = boundedEnumFromThen

3539+

3540+-- | Username type used for HTTP Basic authentication. See 'basicAuthHook'.

3541+newtype EsUsername = EsUsername { esUsername :: Text } deriving (Show, Eq)

3542+

3543+-- | Password type used for HTTP Basic authentication. See 'basicAuthHook'.

3544+newtype EsPassword = EsPassword { esPassword :: Text } deriving (Show, Eq)

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

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

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+-------------------------------------------------------------------------------

7+-- |

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

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

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

12+-- Stability : provisional

13+-- Portability : DeriveGeneric, RecordWildCards

14+--

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

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

17+-------------------------------------------------------------------------------

18+module Database.Bloodhound.Types.Internal

19+ ( BHEnv(..)

20+ , Server(..)

21+ , MonadBH(..)

22+ ) where

23+

24+

25+import Control.Applicative

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 :: Request -> IO 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+

tests/tests.hs+4−4

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

259

260searchExpectAggs :: Search -> BH IO ()

261searchExpectAggs search = do

262− reply <- searchAll search

262+ reply <- searchByIndex testIndex search

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

264 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)

265 liftIO $

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

268searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>

269 Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()

270searchValidBucketAgg search aggKey extractor = do

271− reply <- searchAll search

271+ reply <- searchByIndex testIndex search

272 let bucketDocs = docCount . head . buckets

273 let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)

274 let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)

@@ -293,8 +293,8 @@ searchExpectSource src expected = do

293 _ <- insertData

294 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")

295 let search = (mkSearch (Just query) Nothing) { source = Just src }

296− reply <- searchAll search

296+ reply <- searchByIndex testIndex search

297− result <- parseEsResponse reply-- :: Either EsError (SearchResult Value)

297+ result <- parseEsResponse reply

298 let value = grabFirst result

299 liftIO $

300 value `shouldBe` expected