diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -21,15 +21,29 @@ Version compatibility --------------------- -Elasticsearch \>= 1.0 is recommended. Bloodhound mostly works with 0.9.x, but I don't recommend it if you expect everything to work. As of Bloodhound 0.3 all \>=1.0 versions of Elasticsearch work. +Elasticsearch \>=1.0 && \<2.0 is recommended. Bloodhound mostly works with 0.9.x, but I don't recommend it if you expect everything to work. As of Bloodhound 0.3 all \>=1.0 && \<2.0 versions of Elasticsearch work. Some (or even most?) features will work with versions \>=2.0, but it is not officially supported yet. -Current versions we test against are 1.0.3, 1.1.2, 1.2.3, 1.3.2, and 1.4.0. We also check that GHC 7.6 and 7.8 both build and pass tests. See our [TravisCI](https://travis-ci.org/bitemyapp/bloodhound) to learn more. +Current versions we test against are 1.2.4, 1.3.6, 1.4.1, 1.5.2, 1.6.0, and 1.7.2. We also check that GHC 7.6 and 7.8 both build and pass tests. See our [TravisCI](https://travis-ci.org/bitemyapp/bloodhound) to learn more. Stability --------- Bloodhound is stable for production use. I will strive to avoid breaking API compatibility from here on forward, but dramatic features like a type-safe, fully integrated mapping API may require breaking things in the future. +Testing +--------- + +The TravisCI tests are run using [Stack](http://docs.haskellstack.org/en/stable/README.html). You should use Stack instead of `cabal` to build and test Bloodhound to avoid compatibility problems. You will also need to have an ElasticSearch instance running at `localhost:9200` in order to execute some of the tests. See the "Version compatibility" section above for a list of ElasticSearch versions that are officially validated against in TravisCI. + +Steps to run the tests locally: + 1. Dig through the [past releases] (https://www.elastic.co/downloads/past-releases) section of the ElasticSearch download page and install the desired ElasticSearch versions. + 2. Install [Stack] (http://docs.haskellstack.org/en/stable/README.html#how-to-install) + 3. In your local Bloodhound directory, run `stack setup && stack build` + 4. Start the desired version of ElasticSearch at `localhost:9200`, which should be the default. + 5. Run `stack test` in your local Bloodhound directory. + 6. The unit tests will pass if you re-execute `stack test`, but some of the doctests might fail due to existing data in ElasticSearch. If you want to start with a clean slate, stop your ElasticSearch instance, delete the `data/` folder in the ElasticSearch installation, restart ElasticSearch, and re-run `stack test`. + + Hackage page and Haddock documentation ====================================== @@ -38,7 +52,7 @@ Elasticsearch Tutorial ====================== -It's not using Bloodhound, but if you need an introduction to or overview of Elasticsearch and how to use it, you can use [this screencast](http://vimeo.com/106463167). +It's not using Bloodhound, but if you need an introduction to or overview of Elasticsearch and how to use it, you can use [this screencast](https://vimeo.com/106463167). Examples ======== @@ -758,7 +772,8 @@ #### Extracting aggregations from results -Aggregations are part of the reply structure of every search, in the form of +Aggregations are part of the reply structure of every search, in the +form of `Maybe AggregationResults` ``` {.haskell} -- Lift decode and response body to be in the IO monad. @@ -774,7 +789,7 @@ Just (Bucket {buckets = [TermsResult {termKey = "bitemyapp", termsDocCount = 1, termsAggs = Nothing}]}) ``` -Note that bucket aggregation results, such as the TermsResult is a member of the type class : +Note that bucket aggregation results, such as the TermsResult is a member of the type class `BucketAggregation`: ``` {.haskell} class BucketAggregation a where @@ -783,9 +798,10 @@ aggs :: a -> Maybe AggregationResults ``` -haskell - -You can use the function to get any nested results, if there were any. For example, if there were a nested terms aggregation keyed to "age" in a TermsResult named , you would call +You can use the `aggs` function to get any nested results, if there +were any. For example, if there were a nested terms aggregation keyed +to "age" in a TermsResult named `termresult` , you would call `aggs +termresult >>= toTerms "age"` #### Terms Aggregation @@ -803,7 +819,8 @@ termAggs :: Maybe Aggregations} ``` -Term Aggregations have two factory functions, , and , and can be used as follows: +Term Aggregations have two factory functions, `mkTermsAggregation`, and +`mkTermsScriptAggregation`, and can be used as follows: ``` {.haskell} let ta = TermsAgg $ mkTermsAggregation "user" @@ -817,7 +834,7 @@ let ta'' = TermsAgg ta' ``` -For more documentation on how the Terms Aggregation works, see +For more documentation on how the Terms Aggregation works, see #### Date Histogram Aggregation @@ -833,17 +850,15 @@ dateAggs :: Maybe Aggregations} ``` -haskell - The Date Histogram Aggregation works much the same as the Terms Aggregation. -Relevant functions include , and +Relevant functions include `mkDateHistogram`, and `toDateHistogram` ``` {.haskell} let dh = DateHistogramAgg (mkDateHistogram (FieldName "postDate") Minute) ``` -Date histograms also accept a : +Date histograms also accept a `FractionalInterval`: ``` {.haskell} FractionalInterval :: Float -> TimeInterval -> Interval @@ -857,7 +872,7 @@ let dh = DateHistogramAgg (mkDateHistogram (FieldName "postDate") (FractionalInterval 1.5 Minutes)) ``` -The is defined as: +The `DateHistogramResult` is defined as: ``` {.haskell} data DateHistogramResult @@ -867,11 +882,12 @@ dateHistogramAggs :: Maybe AggregationResults} ``` -It is an instance of , and can have nested aggregations in each bucket. +It is an instance of `BucketAggregation`, and can have nested aggregations in each bucket. -Buckets can be extracted from a using +Buckets can be extracted from an `AggregationResult` using +`toDateHistogram name` -For more information on the Date Histogram Aggregation, see: +For more information on the Date Histogram Aggregation, see: Contributors @@ -894,12 +910,12 @@ Span Queries ------------ -Beginning here: +Beginning here: Function Score Query -------------------- - + Node discovery and failover --------------------------- @@ -919,42 +935,42 @@ GeoShapeQuery ------------- - + GeoShapeFilter -------------- - + Geohash cell filter ------------------- - + HasChild Filter --------------- - + HasParent Filter ---------------- - + Indices Filter -------------- - + Query Filter ------------ - + Script based sorting -------------------- - + Collapsing redundantly nested and/or structures ----------------------------------------------- diff --git a/bloodhound.cabal b/bloodhound.cabal --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -1,5 +1,5 @@ name: bloodhound -version: 0.10.0.0 +version: 0.11.0.0 synopsis: ElasticSearch client library for Haskell description: ElasticSearch made awesome for Haskell hackers homepage: https://github.com/bitemyapp/bloodhound @@ -27,20 +27,22 @@ Database.Bloodhound.Client Database.Bloodhound.Types Database.Bloodhound.Types.Class + Database.Bloodhound.Types.Internal hs-source-dirs: src build-depends: base >= 4.3 && <5, bytestring >= 0.10.0 && <0.11, containers >= 0.5.0.0 && <0.6, - aeson >= 0.10 && <0.11, + aeson >= 0.11.1 && <0.12, http-client >= 0.3 && <0.5, network-uri >= 2.6 && <2.7, semigroups >= 0.15 && <0.19, - time >= 1.4 && <1.6, + time >= 1.4 && <1.7, text >= 0.11 && <1.3, mtl >= 1.0 && <2.3, - transformers >= 0.2 && <0.5, + transformers >= 0.2 && <0.6, http-types >= 0.8 && <0.10, vector >= 0.10.9 && <0.12, + scientific >= 0.3.0.0 && <0.4.0.0, exceptions, data-default-class, blaze-builder, @@ -60,7 +62,7 @@ http-client, http-types, containers, - hspec >= 1.8 && <2.2, + hspec >= 1.8 && <2.3, text, time, aeson, @@ -82,6 +84,8 @@ hs-source-dirs: tests, src if impl(ghc >= 7.8) build-depends: base, + aeson, + bloodhound, directory, doctest >= 0.10.1, doctest-prop, diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,41 @@ +0.11.0.0 +=================== + +Thanks to the following people, Bloodhound 0.10.0.0 is being released! This one gets a bit messy due to the Aeson 0.11 changeover, but this should be good to go now. Note that Aeson 0.11 returned to Aeson 0.9's behavior and semantics. + +* @MichaelXavier + - #112 List indices support + - #94 Implement index optimization + - #91 Make `respIsTwoHunna` more semantic + - More detail: This is actually the cause of a bug in real code. If you happen to be + using parseEsResponse (which uses respIsTwoHunna) to parse the result of + certain operations such as creating an index, those operations return a + 201 and unjustly are deemed to be a failure. + - Cleaned up errant Haskell tokens in README + - #84 Added request auth hooks + +* @dzhus / @MailOnline + - #85 Add updateDocument + +* @ReadmeCritic + - #108 Update README URLs based on HTTP redirects + +* @MHova + - #105 Add helper data types and functions for Missing Aggregations + - Removed unused server versions from the tests + - Updated readme to reflect actual ES versions supported and tested + - Added support for parsing results of Missing Aggregations + - #104 Export BucketValue + - #102 Add local testing instructions to the README + - #89 Support Bool and Numeric keys in TermsResults + - Added Missing Aggregation support + - #98 Improve EsProtocolException documentation for human error + - Updated README to warn about 2.0 compatibility + - Fix docs specifying an incorrect terminating condition + +* @bitemyapp + - Merge monkey, puzzled over spurious local doctest failures + 0.10.0.0 =================== diff --git a/src/Database/Bloodhound.hs b/src/Database/Bloodhound.hs --- a/src/Database/Bloodhound.hs +++ b/src/Database/Bloodhound.hs @@ -1,7 +1,10 @@ module Database.Bloodhound - ( module Database.Bloodhound.Client + ( -- module Data.Aeson.Types + -- , + module Database.Bloodhound.Client , module Database.Bloodhound.Types ) where +-- import Data.Aeson.Types import Database.Bloodhound.Client import Database.Bloodhound.Types diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} ------------------------------------------------------------------------------- -- | @@ -26,9 +27,11 @@ , deleteIndex , updateIndexSettings , getIndexSettings + , optimizeIndex , indexExists , openIndex , closeIndex + , listIndices , updateIndexAliases , getIndexAliases , putTemplate @@ -37,6 +40,7 @@ , putMapping , deleteMapping , indexDocument + , updateDocument , getDocument , documentExists , deleteDocument @@ -57,6 +61,8 @@ , getStatus , encodeBulkOperations , encodeBulkOperation + -- * Authentication + , basicAuthHook -- * Reply-handling tools , isVersionConflict , isSuccess @@ -78,7 +84,7 @@ import Data.Ix import qualified Data.List as LS (filter, foldl') import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe, isJust) +import Data.Maybe (catMaybes, fromMaybe, isJust) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T @@ -174,10 +180,11 @@ -> m Reply dispatch dMethod url body = do initReq <- liftIO $ parseUrl' url + reqHook <- bhRequestHook <$> getBHEnv let reqBody = RequestBodyLBS $ fromMaybe emptyBody body - let req = initReq { method = dMethod - , requestBody = reqBody - , checkStatus = \_ _ _ -> Nothing} + req <- liftIO $ reqHook $ initReq { method = dMethod + , requestBody = reqBody + , checkStatus = \_ _ _ -> Nothing} mgr <- bhManager <$> getBHEnv liftIO $ httpLbs req mgr @@ -221,8 +228,7 @@ withBH :: ManagerSettings -> Server -> BH IO a -> IO a withBH ms s f = do mgr <- newManager ms - let env = BHEnv { bhServer = s - , bhManager = mgr } + let env = mkBHEnv s mgr runBH env f -- Shortcut functions for HTTP methods @@ -248,11 +254,9 @@ -- Just 200 getStatus :: MonadBH m => m (Maybe Status) getStatus = do - url <- joinPath [] - request <- liftIO $ parseUrl' url - mgr <- bhManager <$> getBHEnv - response <- liftIO $ httpLbs request mgr + response <- get =<< url return $ decode (responseBody response) + where url = joinPath [] -- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'. -- @@ -301,6 +305,48 @@ where url = joinPath [indexName, "_settings"] +-- | 'optimizeIndex' will optimize a single index, list of indexes or +-- all indexes. Note that this call will block until finishing but +-- will continue even if the request times out. Concurrent requests to +-- optimize an index while another is performing will block until the +-- previous one finishes. For more information see +-- . Nothing +-- worthwhile comes back in the reply body, so matching on the status +-- should suffice. +-- +-- 'optimizeIndex' with a maxNumSegments of 1 and onlyExpungeDeletes +-- to True is the main way to release disk space back to the OS being +-- held by deleted documents. +-- +-- Note that this API was deprecated in ElasticSearch 2.1 for the +-- almost completely identical forcemerge API. Adding support to that +-- API would be trivial but due to the significant breaking changes, +-- this library cannot currently be used with >= 2.0, so that feature was omitted. +-- +-- >>> let ixn = IndexName "unoptimizedindex" +-- >>> _ <- runBH' $ deleteIndex ixn >> createIndex defaultIndexSettings ixn +-- >>> response <- runBH' $ optimizeIndex (IndexList (ixn :| [])) (defaultIndexOptimizationSettings { maxNumSegments = Just 1, onlyExpungeDeletes = True }) +-- >>> respIsTwoHunna response +-- True +optimizeIndex :: MonadBH m => IndexSelection -> IndexOptimizationSettings -> m Reply +optimizeIndex ixs IndexOptimizationSettings {..} = + bindM2 post url (return body) + where url = addQuery params <$> joinPath [indexName, "_optimize"] + params = catMaybes [ ("max_num_segments",) . Just . showText <$> maxNumSegments + , Just ("only_expunge_deletes", Just (boolQP onlyExpungeDeletes)) + , Just ("flush", Just (boolQP flushAfterOptimize)) + ] + indexName = indexSelectionName ixs + boolQP True = "true" + boolQP False = "false" + body = Nothing + + +------------------------------------------------------------------------------- +indexSelectionName :: IndexSelection -> Text +indexSelectionName (IndexList names) = T.intercalate "," [n | IndexName n <- toList names] +indexSelectionName AllIndexes = "_all" + deepMerge :: [Object] -> Object deepMerge = LS.foldl' go mempty where go acc = LS.foldl' go' acc . HM.toList @@ -309,11 +355,11 @@ merge _ b = b -statusCodeIs :: Int -> Reply -> Bool -statusCodeIs n resp = NHTS.statusCode (responseStatus resp) == n +statusCodeIs :: (Int, Int) -> Reply -> Bool +statusCodeIs r resp = inRange r $ NHTS.statusCode (responseStatus resp) respIsTwoHunna :: Reply -> Bool -respIsTwoHunna = statusCodeIs 200 +respIsTwoHunna = statusCodeIs (200, 299) existentialQuery :: MonadBH m => Text -> m (Reply, Bool) existentialQuery url = do @@ -385,6 +431,19 @@ closeIndex :: MonadBH m => IndexName -> m Reply closeIndex = openOrCloseIndexes CloseIndex +-- | 'listIndices' returns a list of all index names on a given 'Server' +listIndices :: (MonadThrow m, MonadBH m) => m [IndexName] +listIndices = + parse . responseBody =<< get =<< url + where + url = joinPath ["_cat/indices?v"] + -- parses the tabular format the indices api provides + parse body = case T.lines (T.decodeUtf8 (L.toStrict body)) of + (hdr:rows) -> let ks = T.words hdr + keyedRows = [ HM.fromList (zip ks (T.words row)) | row <- rows ] + names = catMaybes (HM.lookup "index" <$> keyedRows) + in return (IndexName <$> names) + [] -> throwM (EsProtocolException body) -- | 'updateIndexAliases' updates the server's index alias -- table. Operations are atomic. Explained in further detail at @@ -394,6 +453,7 @@ -- >>> let aliasName = IndexName "an-alias" -- >>> let iAlias = IndexAlias src (IndexAliasName aliasName) -- >>> let aliasCreate = IndexAliasCreate Nothing Nothing +-- >>> _ <- runBH' $ deleteIndex src -- >>> respIsTwoHunna <$> runBH' (createIndex defaultIndexSettings src) -- True -- >>> runBH' $ indexExists src @@ -474,6 +534,20 @@ -- erroneously. The correct API call is: "/INDEX/_mapping/MAPPING_NAME" delete =<< joinPath [indexName, "_mapping", mappingName] +versionCtlParams :: IndexDocumentSettings -> [(Text, Maybe Text)] +versionCtlParams cfg = + case idsVersionControl cfg of + NoVersionControl -> [] + InternalVersion v -> versionParams v "internal" + ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt" + ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte" + ForceVersion (ExternalDocVersion v) -> versionParams v "force" + where + vt = showText . docVersionNumber + versionParams v t = [ ("version", Just $ vt v) + , ("version_type", Just t) + ] + -- | 'indexDocument' is the primary way to save a single document in -- Elasticsearch. The document itself is simply something we can -- convert into a JSON 'Value'. The 'DocId' will function as the @@ -488,22 +562,23 @@ (MappingName mappingName) cfg document (DocId docId) = bindM2 put url (return body) where url = addQuery params <$> joinPath [indexName, mappingName, docId] - versionCtlParams = case idsVersionControl cfg of - NoVersionControl -> [] - InternalVersion v -> versionParams v "internal" - ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt" - ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte" - ForceVersion (ExternalDocVersion v) -> versionParams v "force" - vt = T.pack . show . docVersionNumber - versionParams v t = [ ("version", Just $ vt v) - , ("version_type", Just t) - ] parentParams = case idsParent cfg of Nothing -> [] Just (DocumentParent (DocId p)) -> [ ("parent", Just p) ] - params = versionCtlParams ++ parentParams + params = versionCtlParams cfg ++ parentParams body = Just (encode document) +-- | 'updateDocument' provides a way to perform an partial update of a +-- an already indexed document. +updateDocument :: (ToJSON patch, MonadBH m) => IndexName -> MappingName + -> IndexDocumentSettings -> patch -> DocId -> m Reply +updateDocument (IndexName indexName) + (MappingName mappingName) cfg patch (DocId docId) = + bindM2 post url (return body) + where url = addQuery (versionCtlParams cfg) <$> + joinPath [indexName, mappingName, docId, "_update"] + body = Just (encode $ object ["doc" .= toJSON patch]) + -- | 'deleteDocument' is the primary way to delete a single document. -- -- >>> _ <- runBH' $ deleteDocument testIndex testMapping (DocId "1") @@ -664,9 +739,8 @@ Right SearchResult {..} -> return (hits searchHits, scrollId) Left _ -> return ([], Nothing) --- | Use the given scroll to fetch the next page of documents. If --- there are still further pages, there will be a value in the --- 'scrollId' field of the 'SearchResult' +-- | Use the given scroll to fetch the next page of documents. If there are no +-- further pages, 'SearchResult.searchHits.hits' will be '[]'. advanceScroll :: ( FromJSON a , MonadBH m @@ -769,3 +843,14 @@ statusCheck :: (Int -> Bool) -> Reply -> Bool statusCheck prd = prd . NHTS.statusCode . responseStatus + +-- | This is a hook that can be set via the 'bhRequestHook' function +-- that will authenticate all requests using an HTTP Basic +-- Authentication header. Note that it is *strongly* recommended that +-- this option only be used over an SSL connection. +-- +-- >> (mkBHEnv myServer myManager) { bhRequestHook = basicAuthHook (EsUsername "myuser") (EsPassword "mypass") } +basicAuthHook :: Monad m => EsUsername -> EsPassword -> Request -> m Request +basicAuthHook (EsUsername u) (EsPassword p) = return . applyBasicAuth u' p' + where u' = T.encodeUtf8 u + p' = T.encodeUtf8 p diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -4,15 +4,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} +-- {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NamedFieldPuns #-} ------------------------------------------------------------------------------- -- | -- Module : Database.Bloodhound.Types --- Copyright : (C) 2014 Chris Allen +-- Copyright : (C) 2014, 2015, 2016 Chris Allen -- License : BSD-style (see the file LICENSE) -- Maintainer : Chris Allen >> :set -XOverloadedStrings +-- >>> import Data.Aeson -- >>> import Database.Bloodhound -- >>> let testServer = (Server "http://localhost:9200") -- >>> let testIndex = IndexName "twitter" @@ -303,20 +321,12 @@ -- defaultIndexSettings is exported by Database.Bloodhound as well -- no trailing slashes in servers, library handles building the path. -{-| Common environment for Elasticsearch calls. Connections will be - pipelined according to the provided HTTP connection manager. --} -data BHEnv = BHEnv { bhServer :: Server - , bhManager :: Manager - } - -{-| All API calls to Elasticsearch operate within - MonadBH. The idea is that it can be easily embedded in your - own monad transformer stack. A default instance for a ReaderT and - alias 'BH' is provided for the simple case. --} -class (Functor m, Applicative m, MonadIO m) => MonadBH m where - getBHEnv :: m BHEnv +-- | Create a 'BHEnv' with all optional fields defaulted. HTTP hook +-- will be a noop. You can use the exported fields to customize it further, e.g.: +-- +-- >> (mkBHEnv myServer myManager) { bhRequestHook = customHook } +mkBHEnv :: Server -> Manager -> BHEnv +mkBHEnv s m = BHEnv s m return newtype BH m a = BH { unBH :: ReaderT BHEnv m a @@ -345,10 +355,6 @@ instance (Functor m, Applicative m, MonadIO m) => MonadBH (BH m) where getBHEnv = BH getBHEnv - -instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) where - getBHEnv = ask - runBH :: BHEnv -> BH m a -> m a runBH e f = runReaderT (unBH f) e @@ -385,6 +391,28 @@ defaultIndexSettings :: IndexSettings defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) + +{-| 'IndexOptimizationSettings' is used to configure index optimization. See + + for more info. +-} +data IndexOptimizationSettings = + IndexOptimizationSettings { maxNumSegments :: Maybe Int + -- ^ Number of segments to optimize to. 1 will fully optimize the index. If omitted, the default behavior is to only optimize if the server deems it necessary. + , onlyExpungeDeletes :: Bool + -- ^ Should the optimize process only expunge segments with deletes in them? If the purpose of the optimization is to free disk space, this should be set to True. + , flushAfterOptimize :: Bool + -- ^ Should a flush be performed after the optimize. + } deriving (Eq, Show, Generic, Typeable) + + +{-| 'defaultIndexOptimizationSettings' implements the default settings that + ElasticSearch uses for index optimization. 'maxNumSegments' is Nothing, + 'onlyExpungeDeletes' is False, and flushAfterOptimize is True. +-} +defaultIndexOptimizationSettings :: IndexOptimizationSettings +defaultIndexOptimizationSettings = IndexOptimizationSettings Nothing False True + {-| 'UpdatableIndexSetting' are settings which may be updated after an index is created. @@ -479,9 +507,9 @@ newtype NominalDiffTimeJSON = NominalDiffTimeJSON { ndtJSON :: NominalDiffTime } -data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName +data IndexSettingsSummary = IndexSettingsSummary { sSummaryIndexName :: IndexName , sSummaryFixedSettings :: IndexSettings - , sSummaryUpdateable :: [UpdatableIndexSetting]} + , sSummaryUpdateable :: [UpdatableIndexSetting]} deriving (Eq, Show, Generic, Typeable) {-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -} @@ -566,10 +594,13 @@ data EsError = EsError { errorStatus :: Int , errorMessage :: Text } deriving (Eq, Show, Generic, Typeable) -{-| 'EsProtocolException' ideally should never be thrown. It will only -be thrown when Bloodhound can't parse a response returned by the -ElasticSearch server. This should be reported as a bug to the bug -tracker. Be sure to include the body. +{-| 'EsProtocolException' will be thrown if Bloodhound cannot parse a response +returned by the ElasticSearch server. If you encounter this error, please +verify that your domain data types and FromJSON instances are working properly +(for example, the 'a' of '[Hit a]' in 'SearchResult.searchHits.hits'). If you're +sure that your mappings are correct, then this error may be an indication of an +incompatibility between Bloodhound and ElasticSearch. Please open a bug report +and be sure to include the exception body. -} data EsProtocolException = EsProtocolException { esProtoExBody :: L.ByteString } deriving (Eq, Show, Generic, Typeable) @@ -764,14 +795,16 @@ -} newtype ReplicaCount = ReplicaCount Int deriving (Eq, Show, Generic, ToJSON, Typeable) -{-| 'Server' is used with the client functions to point at the ES instance --} -newtype Server = Server Text deriving (Eq, Show, Generic, Typeable) - {-| 'IndexName' is used to describe which index to query/create/delete -} newtype IndexName = IndexName Text deriving (Eq, Generic, Show, ToJSON, FromJSON, Typeable) +{-| 'IndexSelection' is used for APIs which take a single index, a list of + indexes, or the special @_all@ index. +-} +data IndexSelection = IndexList (NonEmpty IndexName) + | AllIndexes deriving (Eq, Generic, Show, Typeable) + {-| 'TemplateName' is used to describe which template to query/create/delete -} newtype TemplateName = TemplateName Text deriving (Eq, Show, Generic, ToJSON, FromJSON, Typeable) @@ -1549,8 +1582,12 @@ | DateHistogramAgg DateHistogramAggregation | ValueCountAgg ValueCountAggregation | FilterAgg FilterAggregation - | DateRangeAgg DateRangeAggregation deriving (Eq, Show, Generic, Typeable) + | DateRangeAgg DateRangeAggregation + | MissingAgg MissingAggregation deriving (Eq, Show, Generic, Typeable) +data MissingAggregation = MissingAggregation + { maField :: Text + } deriving (Eq, Show, Generic, Typeable) data TermsAggregation = TermsAggregation { term :: Either Text Text , termInclude :: Maybe TermInclusion @@ -1710,6 +1747,8 @@ , "aggs" .= ags] toJSON (DateRangeAgg a) = object [ "date_range" .= a ] + toJSON (MissingAgg (MissingAggregation{..})) = + object ["missing" .= object ["field" .= maField]] instance ToJSON DateRangeAggregation where toJSON DateRangeAggregation {..} = @@ -1745,14 +1784,20 @@ type AggregationResults = M.Map Text Value class BucketAggregation a where - key :: a -> Text + key :: a -> BucketValue docCount :: a -> Int aggs :: a -> Maybe AggregationResults data Bucket a = Bucket { buckets :: [a]} deriving (Show) -data TermsResult = TermsResult { termKey :: Text +data BucketValue = TextValue Text + | ScientificValue Scientific + | BoolValue Bool deriving (Show) + +data MissingResult = MissingResult { missingDocCount :: Int } deriving (Show) + +data TermsResult = TermsResult { termKey :: BucketValue , termsDocCount :: Int , termsAggs :: Maybe AggregationResults } deriving (Show) @@ -1770,11 +1815,16 @@ , dateRangeAggs :: Maybe AggregationResults } deriving (Show, Eq, Generic, Typeable) toTerms :: Text -> AggregationResults -> Maybe (Bucket TermsResult) -toTerms t a = M.lookup t a >>= deserialize - where deserialize = parseMaybe parseJSON +toTerms = toAggResult toDateHistogram :: Text -> AggregationResults -> Maybe (Bucket DateHistogramResult) -toDateHistogram t a = M.lookup t a >>= deserialize +toDateHistogram = toAggResult + +toMissing :: Text -> AggregationResults -> Maybe MissingResult +toMissing = toAggResult + +toAggResult :: (FromJSON a) => Text -> AggregationResults -> Maybe a +toAggResult t a = M.lookup t a >>= deserialize where deserialize = parseMaybe parseJSON instance BucketAggregation TermsResult where @@ -1783,12 +1833,12 @@ aggs = termsAggs instance BucketAggregation DateHistogramResult where - key = showText . dateKey + key = TextValue . showText . dateKey docCount = dateDocCount aggs = dateHistogramAggs instance BucketAggregation DateRangeResult where - key = dateRangeKey + key = TextValue . dateRangeKey docCount = dateRangeDocCount aggs = dateRangeAggs @@ -1797,6 +1847,16 @@ v .: "buckets" parseJSON _ = mempty +instance FromJSON BucketValue where + parseJSON (String t) = return $ TextValue t + parseJSON (Number s) = return $ ScientificValue s + parseJSON (Bool b) = return $ BoolValue b + parseJSON _ = mempty + +instance FromJSON MissingResult where + parseJSON = withObject "MissingResult" parse + where parse v = MissingResult <$> v .: "doc_count" + instance FromJSON TermsResult where parseJSON (Object v) = TermsResult <$> v .: "key" <*> @@ -2037,6 +2097,7 @@ toJSON (TermsQuery fieldName terms) = object [ "terms" .= object conjoined ] where conjoined = [fieldName .= terms] + toJSON (IdsQuery idsQueryMappingName docIds) = object [ "ids" .= object conjoined ] where conjoined = [ "type" .= idsQueryMappingName @@ -2424,7 +2485,8 @@ <*> o .:? "percent_terms_to_match" <*> o .:? "min_term_freq" <*> o .:? "max_query_terms" - <*> (optionalNE =<< o .:? "stop_words") + -- <*> (optionalNE =<< o .:? "stop_words") + <*> o .:? "stop_words" <*> o .:? "min_doc_freq" <*> o .:? "max_doc_freq" <*> o .:? "min_word_length" @@ -2432,7 +2494,7 @@ <*> o .:? "boost_terms" <*> o .:? "boost" <*> o .:? "analyzer" - optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON) + -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON) instance ToJSON MoreLikeThisQuery where toJSON (MoreLikeThisQuery text fields percent @@ -2457,11 +2519,13 @@ parseJSON = withObject "MoreLikeThisQuery" parse where parse o = MoreLikeThisQuery <$> o .: "like_text" - <*> (optionalNE =<< o .:? "fields") + -- <*> (optionalNE =<< o .:? "fields") + <*> o .:? "fields" <*> o .:? "percent_terms_to_match" <*> o .:? "min_term_freq" <*> o .:? "max_query_terms" - <*> (optionalNE =<< o .:? "stop_words") + -- <*> (optionalNE =<< o .:? "stop_words") + <*> o .:? "stop_words" <*> o .:? "min_doc_freq" <*> o .:? "max_doc_freq" <*> o .:? "min_word_length" @@ -2469,7 +2533,7 @@ <*> o .:? "boost_terms" <*> o .:? "boost" <*> o .:? "analyzer" - optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON) + -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON) instance ToJSON IndicesQuery where toJSON (IndicesQuery indices query noMatch) = @@ -3544,3 +3608,9 @@ fromEnum = docVersionNumber enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen + +-- | Username type used for HTTP Basic authentication. See 'basicAuthHook'. +newtype EsUsername = EsUsername { esUsername :: Text } deriving (Show, Eq) + +-- | Password type used for HTTP Basic authentication. See 'basicAuthHook'. +newtype EsPassword = EsPassword { esPassword :: Text } deriving (Show, Eq) diff --git a/src/Database/Bloodhound/Types/Internal.hs b/src/Database/Bloodhound/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Types/Internal.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------- +-- | +-- Module : Database.Bloodhound.Types.Internal +-- Copyright : (C) 2014 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen +-- Stability : provisional +-- Portability : DeriveGeneric, RecordWildCards +-- +-- Internal data types for Bloodhound. These types may change without +-- notice so import at your own risk. +------------------------------------------------------------------------------- +module Database.Bloodhound.Types.Internal + ( BHEnv(..) + , Server(..) + , MonadBH(..) + ) where + + +import Control.Applicative +import Control.Monad.Reader +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.HTTP.Client + +{-| Common environment for Elasticsearch calls. Connections will be + pipelined according to the provided HTTP connection manager. +-} +data BHEnv = BHEnv { bhServer :: Server + , bhManager :: Manager + , bhRequestHook :: Request -> IO Request + -- ^ Low-level hook that is run before every request is sent. Used to implement custom authentication strategies. Defaults to 'return' with 'mkBHEnv'. + } + +instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) where + getBHEnv = ask + +{-| 'Server' is used with the client functions to point at the ES instance +-} +newtype Server = Server Text deriving (Eq, Show, Generic, Typeable) + +{-| All API calls to Elasticsearch operate within + MonadBH + . The idea is that it can be easily embedded in your + own monad transformer stack. A default instance for a ReaderT and + alias 'BH' is provided for the simple case. +-} +class (Functor m, Applicative m, MonadIO m) => MonadBH m where + getBHEnv :: m BHEnv + diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -66,9 +66,6 @@ data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord) -es14 :: ServerVersion -es14 = ServerVersion 1 4 0 - es13 :: ServerVersion es13 = ServerVersion 1 3 0 @@ -78,9 +75,6 @@ es11 :: ServerVersion es11 = ServerVersion 1 1 0 -es10 :: ServerVersion -es10 = ServerVersion 1 0 0 - serverBranch :: ServerVersion -> ServerVersion serverBranch (ServerVersion majorVer minorVer patchVer) = ServerVersion majorVer minorVer patchVer @@ -130,7 +124,8 @@ , postDate :: UTCTime , message :: Text , age :: Int - , location :: Location } + , location :: Location + , extra :: Maybe Text } deriving (Eq, Generic, Show) instance ToJSON Tweet where @@ -178,8 +173,34 @@ (secondsToDiffTime 10) , message = "Use haskell!" , age = 10000 - , location = Location 40.12 (-71.34) } + , location = Location 40.12 (-71.34) + , extra = Nothing } +tweetWithExtra :: Tweet +tweetWithExtra = Tweet { user = "bitemyapp" + , postDate = UTCTime + (ModifiedJulianDay 55000) + (secondsToDiffTime 10) + , message = "Use haskell!" + , age = 10000 + , location = Location 40.12 (-71.34) + , extra = Just "blah blah" } + +newAge :: Int +newAge = 31337 + +newUser :: Text +newUser = "someotherapp" + +tweetPatch :: Value +tweetPatch = + object [ "age" .= newAge + , "user" .= newUser + ] + +patchedTweet :: Tweet +patchedTweet = exampleTweet{age = newAge, user = newUser} + otherTweet :: Tweet otherTweet = Tweet { user = "notmyapp" , postDate = UTCTime @@ -187,7 +208,8 @@ (secondsToDiffTime 11) , message = "Use haskell!" , age = 1000 - , location = Location 40.12 (-71.34) } + , location = Location 40.12 (-71.34) + , extra = Nothing } resetIndex :: BH IO () resetIndex = do @@ -207,12 +229,24 @@ _ <- refreshIndex testIndex return r +updateData :: BH IO Reply +updateData = do + r <- updateDocument testIndex testMapping defaultIndexDocumentSettings tweetPatch (DocId "1") + _ <- refreshIndex testIndex + return r + insertOther :: BH IO () insertOther = do _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings otherTweet (DocId "2") _ <- refreshIndex testIndex return () +insertExtra :: BH IO () +insertExtra = do + _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings tweetWithExtra (DocId "4") + _ <- refreshIndex testIndex + return () + insertWithSpaceInId :: BH IO () insertWithSpaceInId = do _ <- indexDocument testIndex testMapping defaultIndexDocumentSettings exampleTweet (DocId "Hello World") @@ -238,7 +272,7 @@ searchExpectAggs :: Search -> BH IO () searchExpectAggs search = do - reply <- searchAll search + reply <- searchByIndex testIndex search let isEmpty x = return (M.null x) let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) liftIO $ @@ -247,7 +281,7 @@ searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) => Search -> Text -> (Text -> AggregationResults -> Maybe (Bucket a)) -> BH IO () searchValidBucketAgg search aggKey extractor = do - reply <- searchAll search + reply <- searchByIndex testIndex search let bucketDocs = docCount . head . buckets let result = decode (responseBody reply) :: Maybe (SearchResult Tweet) let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x) @@ -272,8 +306,8 @@ _ <- insertData let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") let search = (mkSearch (Just query) Nothing) { source = Just src } - reply <- searchAll search - result <- parseEsResponse reply-- :: Either EsError (SearchResult Value) + reply <- searchByIndex testIndex search + result <- parseEsResponse reply let value = grabFirst result liftIO $ value `shouldBe` expected @@ -761,12 +795,13 @@ liftIO (errorResp `shouldBe` Right (EsError 404 "IndexMissingException[[bogus] missing]")) describe "document API" $ do - it "indexes, gets, and then deletes the generated document" $ withTestEnv $ do + it "indexes, updates, gets, and then deletes the generated document" $ withTestEnv $ do _ <- insertData + _ <- updateData docInserted <- getDocument testIndex testMapping (DocId "1") let newTweet = eitherDecode (responseBody docInserted) :: Either String (EsResult Tweet) - liftIO $ (fmap getSource newTweet `shouldBe` Right (Just exampleTweet)) + liftIO $ (fmap getSource newTweet `shouldBe` Right (Just patchedTweet)) it "indexes, gets, and then deletes the generated document with a DocId containing a space" $ withTestEnv $ do _ <- insertWithSpaceInId @@ -1214,6 +1249,16 @@ forM_ intervals expect forM_ intervals valid + it "can execute missing aggregations" $ withTestEnv $ do + _ <- insertData + _ <- insertExtra + let ags = mkAggregations "missing_agg" (MissingAgg (MissingAggregation "extra")) + let search = mkAggregateSearch Nothing ags + let docCountPair k n = (k, object ["doc_count" .= Number n]) + res <- searchTweets search + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "missing_agg" 1])) + describe "Highlights API" $ do it "returns highlight from query when there should be one" $ withTestEnv $ do @@ -1262,7 +1307,8 @@ it "excludes source patterns" $ withTestEnv $ do searchExpectSource - (SourceIncludeExclude (Include []) (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate"])) + (SourceIncludeExclude (Include []) + (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"])) (Right (Object (HM.fromList [("user",String "bitemyapp")]))) describe "ToJSON RegexpFlags" $ do @@ -1380,6 +1426,12 @@ L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup + describe "Index Listing" $ do + it "returns a list of index names" $ withTestEnv $ do + _ <- createExampleIndex + ixns <- listIndices + liftIO (ixns `shouldContain` [testIndex]) + describe "Index Settings" $ do it "persists settings" $ withTestEnv $ do _ <- deleteExampleIndex @@ -1393,6 +1445,12 @@ testIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) (NE.toList updates)) + + describe "Index Optimization" $ do + it "returns a successful response upon completion" $ withTestEnv $ do + _ <- createExampleIndex + resp <- optimizeIndex (IndexList (testIndex :| [])) defaultIndexOptimizationSettings + liftIO $ validateStatus resp 200 describe "JSON instances" $ do propJSON (Proxy :: Proxy Version)