packages feed

bloodhound 0.19.1.0 → 0.20.0.0

raw patch · 41 files changed

+9980/−8510 lines, 41 filessetup-changed

Files

README.md view
@@ -41,7 +41,7 @@ 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. @@ -53,7 +53,11 @@   5. Run `stack test` in your local Bloodhound directory.   6. The unit tests will pass if you re-execute `stack test`. 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`. +Contributions+------------- +Any contribution is welcomed, for consistency reason [`ormolu`](https://github.com/tweag/ormolu) is used.+ Hackage page and Haddock documentation ====================================== @@ -83,6 +87,7 @@ * [Anna Kopp](https://github.com/annakopp) * [Matvey B. Aksenov](https://github.com/supki) * [Jan-Philip Loos](https://github.com/MaxDaten)+* [Gautier DI FOLCO](https://github.com/blackheaven)  Possible future functionality =============================
Setup.hs view
@@ -1,6 +1,7 @@ #!/usr/bin/env runhaskell  module Main where+ import Distribution.Simple  main :: IO ()
bloodhound.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.6.+-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack  name:           bloodhound-version:        0.19.1.0+version:        0.20.0.0 synopsis:       Elasticsearch client library for Haskell description:    Elasticsearch made awesome for Haskell hackers category:       Database, Search@@ -43,6 +43,8 @@   other-modules:       Bloodhound.Import       Database.Bloodhound.Common.Script+      Database.Bloodhound.Internal.Client.BHRequest+      Database.Bloodhound.Internal.Client.Doc       Database.Bloodhound.Internal.Count       Database.Bloodhound.Internal.PointInTime       Paths_bloodhound
changelog.md view
@@ -1,3 +1,14 @@+0.20.0.0+========+- @blackheaven+  - Strong type API, breaking changes+    - `Reply` is replaced by `BHResponse body`+    - `decode`/`eitherDecode` can't be used directly (see `decodeResponse`/`eitherDecodeResponse`)+    - `parseEsResponse` return a `ParsedEsResponse`+    - `getStatus` returns `Either`  instead of `Maybe`+    - Many functions have been strong typed from `Reply` (mainly `BHResponse a`)+    - `respIsTwoHunna` has been replaced by `isSuccess`+ 0.19.1.0 ======== - @TristanCacqueray
src/Bloodhound/Import.hs view
@@ -1,53 +1,68 @@ module Bloodhound.Import-  ( module X-  , LByteString-  , Method-  , omitNulls-  , parseNEJSON-  , parseReadText-  , readMay-  , showText-  , deleteSeveral-  , oPath-  , tshow-  ) where--import           Control.Applicative       as X (Alternative (..), optional)-import           Control.Exception         as X (Exception)-import           Control.Monad             as X (MonadPlus (..), forM, (<=<))-import           Control.Monad.Catch       as X (MonadCatch, MonadMask,-                                                 MonadThrow)-import           Control.Monad.Except      as X (MonadError)-import           Control.Monad.Fix         as X (MonadFix)-import           Control.Monad.IO.Class    as X (MonadIO (..))-import           Control.Monad.Reader      as X (MonadReader (..),-                                                 MonadTrans (..), ReaderT (..))-import           Control.Monad.State       as X (MonadState)-import           Control.Monad.Writer      as X (MonadWriter)-import           Data.Aeson                as X-import           Data.Aeson.Key            as X-import qualified Data.Aeson.KeyMap         as X-import           Data.Aeson.Types          as X (Pair, Parser, emptyObject,-                                                 parseEither, parseMaybe,-                                                 typeMismatch)-import           Data.Bifunctor            as X (first)-import           Data.Char                 as X (isNumber)-import           Data.Hashable             as X (Hashable)-import           Data.List                 as X (foldl', intercalate, nub)-import           Data.List.NonEmpty        as X (NonEmpty (..), toList)-import           Data.Maybe                as X (catMaybes, fromMaybe,-                                                 isNothing, maybeToList)-import           Data.Scientific           as X (Scientific)-import           Data.Semigroup            as X (Semigroup (..))-import           Data.Text                 as X (Text)-import           Data.Time.Calendar        as X (Day (..), showGregorian)-import           Data.Time.Clock           as X (NominalDiffTime, UTCTime)-import           Data.Time.Clock.POSIX     as X+  ( module X,+    LByteString,+    Method,+    omitNulls,+    parseNEJSON,+    parseReadText,+    readMay,+    showText,+    deleteSeveral,+    oPath,+    tshow,+  )+where -import qualified Data.ByteString.Lazy      as BL-import qualified Data.Text                 as T-import qualified Data.Traversable          as DT-import qualified Data.Vector               as V+import Control.Applicative as X (Alternative (..), optional)+import Control.Exception as X (Exception)+import Control.Monad as X (MonadPlus (..), forM, (<=<))+import Control.Monad.Catch as X+  ( MonadCatch,+    MonadMask,+    MonadThrow,+  )+import Control.Monad.Except as X (MonadError)+import Control.Monad.Fix as X (MonadFix)+import Control.Monad.IO.Class as X (MonadIO (..))+import Control.Monad.Reader as X+  ( MonadReader (..),+    MonadTrans (..),+    ReaderT (..),+  )+import Control.Monad.State as X (MonadState)+import Control.Monad.Writer as X (MonadWriter)+import Data.Aeson as X+import Data.Aeson.Key as X+import qualified Data.Aeson.KeyMap as X+import Data.Aeson.Types as X+  ( Pair,+    Parser,+    emptyObject,+    parseEither,+    parseMaybe,+    typeMismatch,+  )+import Data.Bifunctor as X (first)+import qualified Data.ByteString.Lazy as BL+import Data.Char as X (isNumber)+import Data.Hashable as X (Hashable)+import Data.List as X (foldl', intercalate, nub)+import Data.List.NonEmpty as X (NonEmpty (..), toList)+import Data.Maybe as X+  ( catMaybes,+    fromMaybe,+    isNothing,+    maybeToList,+  )+import Data.Scientific as X (Scientific)+import Data.Semigroup as X (Semigroup (..))+import Data.Text as X (Text)+import qualified Data.Text as T+import Data.Time.Calendar as X (Day (..), showGregorian)+import Data.Time.Clock as X (NominalDiffTime, UTCTime)+import Data.Time.Clock.POSIX as X+import qualified Data.Traversable as DT+import qualified Data.Vector as V import qualified Network.HTTP.Types.Method as NHTM  type LByteString = BL.ByteString@@ -56,8 +71,8 @@  readMay :: Read a => String -> Maybe a readMay s = case reads s of-              (a, ""):_ -> Just a-              _         -> Nothing+  (a, "") : _ -> Just a+  _ -> Nothing  parseReadText :: Read a => Text -> Parser a parseReadText = maybe mzero return . readMay . T.unpack@@ -66,21 +81,22 @@ showText = T.pack . show  omitNulls :: [(Key, Value)] -> Value-omitNulls = object . filter notNull where-  notNull (_, Null)    = False-  notNull (_, Array a) = (not . V.null) a-  notNull _            = True+omitNulls = object . filter notNull+  where+    notNull (_, Null) = False+    notNull (_, Array a) = (not . V.null) a+    notNull _ = True  parseNEJSON :: (FromJSON a) => [Value] -> Parser (NonEmpty a)-parseNEJSON []     = fail "Expected non-empty list"-parseNEJSON (x:xs) = DT.mapM parseJSON (x :| xs)+parseNEJSON [] = fail "Expected non-empty list"+parseNEJSON (x : xs) = DT.mapM parseJSON (x :| xs)  deleteSeveral :: [Key] -> X.KeyMap v -> X.KeyMap v deleteSeveral ks km = foldr X.delete km ks  oPath :: ToJSON a => NonEmpty Key -> a -> Value-oPath (k :| []) v   = object [k .= v]-oPath (k:| (h:t)) v = object [k .= oPath (h :| t) v]+oPath (k :| []) v = object [k .= v]+oPath (k :| (h : t)) v = object [k .= oPath (h :| t) v]  tshow :: Show a => a -> Text tshow = T.pack . show
src/Database/Bloodhound.hs view
@@ -1,9 +1,10 @@ module Database.Bloodhound-       ( -- module Data.Aeson.Types-       -- , -         module Database.Bloodhound.Client-       , module Database.Bloodhound.Types-       ) where+  ( -- module Data.Aeson.Types+    -- ,+    module Database.Bloodhound.Client,+    module Database.Bloodhound.Types,+  )+where  -- import Data.Aeson.Types import Database.Bloodhound.Client
src/Database/Bloodhound/Client.hs view
@@ -1,1435 +1,1516 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TupleSections     #-}------------------------------------------------------------------------------------ |--- Module : Database.Bloodhound.Client--- Copyright : (C) 2014, 2018 Chris Allen--- License : BSD-style (see the file LICENSE)--- Maintainer : Chris Allen <cma@bitemyapp.com>--- Stability : provisional--- Portability : OverloadedStrings------ Client side functions for talking to Elasticsearch servers.-------------------------------------------------------------------------------------module Database.Bloodhound.Client-       ( -- * Bloodhound client functions-         -- | The examples in this module assume the following code has been run.-         --   The :{ and :} will only work in GHCi. You'll only need the data types-         --   and typeclass instances for the functions that make use of them.--         -- $setup-         withBH-       -- ** Indices-       , createIndex-       , createIndexWith-       , flushIndex-       , deleteIndex-       , updateIndexSettings-       , getIndexSettings-       , forceMergeIndex-       , indexExists-       , openIndex-       , closeIndex-       , listIndices-       , catIndices-       , waitForYellowIndex-       -- *** Index Aliases-       , updateIndexAliases-       , getIndexAliases-       , deleteIndexAlias-       -- *** Index Templates-       , putTemplate-       , templateExists-       , deleteTemplate-       -- ** Mapping-       , putMapping-       -- ** Documents-       , indexDocument-       , updateDocument-       , getDocument-       , documentExists-       , deleteDocument-       , deleteByQuery-       -- ** Searching-       , searchAll-       , searchByIndex-       , searchByIndices-       , searchByIndexTemplate-       , searchByIndicesTemplate-       , scanSearch-       , getInitialScroll-       , getInitialSortedScroll-       , advanceScroll-       , pitSearch-       , openPointInTime-       , closePointInTime-       , refreshIndex-       , mkSearch-       , mkAggregateSearch-       , mkHighlightSearch-       , mkSearchTemplate-       , bulk-       , pageSearch-       , mkShardCount-       , mkReplicaCount-       , getStatus-       -- ** Templates-       , storeSearchTemplate-       , getSearchTemplate-       , deleteSearchTemplate-       -- ** Snapshot/Restore-       -- *** Snapshot Repos-       , getSnapshotRepos-       , updateSnapshotRepo-       , verifySnapshotRepo-       , deleteSnapshotRepo-       -- *** Snapshots-       , createSnapshot-       , getSnapshots-       , deleteSnapshot-       -- *** Restoring Snapshots-       , restoreSnapshot-       -- ** Nodes-       , getNodesInfo-       , getNodesStats-       -- ** Request Utilities-       , encodeBulkOperations-       , encodeBulkOperation-       -- * Authentication-       , basicAuthHook-       -- * Reply-handling tools-       , isVersionConflict-       , isSuccess-       , isCreated-       , parseEsResponse-       -- * Count-       , countByIndex-       )-       where--import qualified Blaze.ByteString.Builder     as BB-import           Control.Applicative          as A-import           Control.Monad-import           Control.Monad.Catch-import           Control.Monad.IO.Class-import           Data.Aeson-import           Data.Aeson.Key-import qualified Data.Aeson.KeyMap            as X-import           Data.ByteString.Builder-import qualified Data.ByteString.Lazy.Char8   as L-import           Data.Foldable                (toList)-import           Data.Ix-import qualified Data.List                    as LS (foldl')-import           Data.List.NonEmpty           (NonEmpty (..))-import           Data.Maybe                   (catMaybes, fromMaybe)-import           Data.Monoid-import           Data.Text                    (Text)-import qualified Data.Text                    as T-import qualified Data.Text.Encoding           as T-import           Data.Time.Clock-import qualified Data.Vector                  as V-import           Network.HTTP.Client-import qualified Network.HTTP.Types.Method    as NHTM-import qualified Network.HTTP.Types.Status    as NHTS-import qualified Network.HTTP.Types.URI       as NHTU-import qualified Network.URI                  as URI-import           Prelude                      hiding (filter, head)--import           Database.Bloodhound.Types---- $setup--- >>> :set -XOverloadedStrings--- >>> :set -XDeriveGeneric--- >>> import Database.Bloodhound--- >>> import Network.HTTP.Client--- >>> let testServer = (Server "http://localhost:9200")--- >>> let runBH' = withBH defaultManagerSettings testServer--- >>> let testIndex = IndexName "twitter"--- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)--- >>> data TweetMapping = TweetMapping deriving (Eq, Show)--- >>> _ <- runBH' $ deleteIndex testIndex--- >>> _ <- runBH' $ deleteIndex (IndexName "didimakeanindex")--- >>> import GHC.Generics--- >>> import           Data.Time.Calendar        (Day (..))--- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)--- >>> :{---instance ToJSON TweetMapping where---          toJSON TweetMapping =---            object ["properties" .=---              object ["location" .=---                object ["type" .= ("geo_point" :: Text)]]]---data Location = Location { lat :: Double---                         , lon :: Double } deriving (Eq, Generic, Show)---data Tweet = Tweet { user     :: Text---                    , postDate :: UTCTime---                    , message  :: Text---                    , age      :: Int---                    , location :: Location } deriving (Eq, Generic, Show)---exampleTweet = Tweet { user     = "bitemyapp"---                      , postDate = UTCTime---                                   (ModifiedJulianDay 55000)---                                   (secondsToDiffTime 10)---                      , message  = "Use haskell!"---                      , age      = 10000---                      , location = Location 40.12 (-71.34) }---instance ToJSON   Tweet where---  toJSON = genericToJSON defaultOptions---instance FromJSON Tweet where---  parseJSON = genericParseJSON defaultOptions---instance ToJSON   Location where---  toJSON = genericToJSON defaultOptions---instance FromJSON Location where---  parseJSON = genericParseJSON defaultOptions---data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)---instance FromJSON BulkTest where---  parseJSON = genericParseJSON defaultOptions---instance ToJSON BulkTest where---  toJSON = genericToJSON defaultOptions--- :}---- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'---   which rejects 'Int' values below 1 and above 1000.------ >>> mkShardCount 10--- Just (ShardCount 10)-mkShardCount :: Int -> Maybe ShardCount-mkShardCount n-  | n < 1 = Nothing-  | n > 1000 = Nothing-  | otherwise = Just (ShardCount n)---- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'---   which rejects 'Int' values below 0 and above 1000.------ >>> mkReplicaCount 10--- Just (ReplicaCount 10)-mkReplicaCount :: Int -> Maybe ReplicaCount-mkReplicaCount n-  | n < 0 = Nothing-  | n > 1000 = Nothing -- ...-  | otherwise = Just (ReplicaCount n)--emptyBody :: L.ByteString-emptyBody = L.pack ""--dispatch :: MonadBH m-         => Method-         -> Text-         -> Maybe L.ByteString-         -> m Reply-dispatch dMethod url body = do-  initReq <- liftIO $ parseUrl' url-  reqHook <- bhRequestHook A.<$> getBHEnv-  let reqBody = RequestBodyLBS $ fromMaybe emptyBody body-  req <- liftIO-         $ reqHook-         $ setRequestIgnoreStatus-         $ initReq { method = dMethod-                   , requestHeaders =-                     -- "application/x-ndjson" for bulk-                     ("Content-Type", "application/json") : requestHeaders initReq-                   , requestBody = reqBody }-  -- req <- liftIO $ reqHook $ setRequestIgnoreStatus $ initReq { method = dMethod-  --                                                            , requestBody = reqBody }-  mgr <- bhManager <$> getBHEnv-  liftIO $ httpLbs req mgr--joinPath' :: [Text] -> Text-joinPath' = T.intercalate "/"--joinPath :: MonadBH m => [Text] -> m Text-joinPath ps = do-  Server s <- bhServer <$> getBHEnv-  return $ joinPath' (s:ps)--appendSearchTypeParam :: Text -> SearchType -> Text-appendSearchTypeParam originalUrl st = addQuery params originalUrl-  where stText = "search_type"-        params-          | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")]-        -- used to catch 'SearchTypeQueryThenFetch', which is also the default-          | otherwise                         = []---- | Severely dumbed down query renderer. Assumes your data doesn't--- need any encoding-addQuery :: [(Text, Maybe Text)] -> Text -> Text-addQuery q u = u <> rendered-  where-    rendered =-      T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark q-    prependQuestionMark = True--bindM2 :: (Applicative m, Monad m) => (a -> b -> m c) -> m a -> m b -> m c-bindM2 f ma mb = join (f <$> ma <*> mb)---- | Convenience function that sets up a manager and BHEnv and runs--- the given set of bloodhound operations. Connections will be--- pipelined automatically in accordance with the given manager--- settings in IO. If you've got your own monad transformer stack, you--- should use 'runBH' directly.-withBH :: ManagerSettings -> Server -> BH IO a -> IO a-withBH ms s f = do-  mgr <- newManager ms-  let env = mkBHEnv s mgr-  runBH env f---- Shortcut functions for HTTP methods-delete :: MonadBH m => Text -> m Reply-delete = flip (dispatch NHTM.methodDelete) Nothing-delete' :: MonadBH m => Text -> Maybe L.ByteString -> m Reply-delete' = dispatch NHTM.methodDelete-get    :: MonadBH m => Text -> m Reply-get    = flip (dispatch NHTM.methodGet) Nothing-head   :: MonadBH m => Text -> m Reply-head   = flip (dispatch NHTM.methodHead) Nothing-put    :: MonadBH m => Text -> Maybe L.ByteString -> m Reply-put    = dispatch NHTM.methodPut-post   :: MonadBH m => Text -> Maybe L.ByteString -> m Reply-post   = dispatch NHTM.methodPost---- indexDocument s ix name doc = put (root </> s </> ix </> name </> doc) (Just encode doc)--- http://hackage.haskell.org/package/http-client-lens-0.1.0/docs/Network-HTTP-Client-Lens.html--- https://github.com/supki/libjenkins/blob/master/src/Jenkins/Rest/Internal.hs---- | 'getStatus' fetches the 'Status' of a 'Server'------ >>> serverStatus <- runBH' getStatus--- >>> fmap tagline (serverStatus)--- Just "You Know, for Search"-getStatus :: MonadBH m => m (Maybe Status)-getStatus = do-  response <- get =<< url-  return $ decode (responseBody response)-  where url = joinPath []---- | 'getSnapshotRepos' gets the definitions of a subset of the--- defined snapshot repos.-getSnapshotRepos-    :: ( MonadBH m-       , MonadThrow m-       )-    => SnapshotRepoSelection-    -> m (Either EsError [GenericSnapshotRepo])-getSnapshotRepos sel = fmap (fmap unGSRs) . parseEsResponse =<< get =<< url-  where-    url = joinPath ["_snapshot", selectorSeg]-    selectorSeg = case sel of-                    AllSnapshotRepos -> "_all"-                    SnapshotRepoList (p :| ps) -> T.intercalate "," (renderPat <$> (p:ps))-    renderPat (RepoPattern t)                  = t-    renderPat (ExactRepo (SnapshotRepoName t)) = t----- | Wrapper to extract the list of 'GenericSnapshotRepo' in the--- format they're returned in-newtype GSRs = GSRs { unGSRs :: [GenericSnapshotRepo] }---instance FromJSON GSRs where-  parseJSON = withObject "Collection of GenericSnapshotRepo" parse-    where-      parse = fmap GSRs . mapM (uncurry go) . X.toList-      go rawName = withObject "GenericSnapshotRepo" $ \o ->-        GenericSnapshotRepo (SnapshotRepoName $ toText rawName) <$> o .: "type"-                                                                <*> o .: "settings"----- | Create or update a snapshot repo-updateSnapshotRepo-  :: ( MonadBH m-     , SnapshotRepo repo-     )-  => SnapshotRepoUpdateSettings-  -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure-  -> repo-  -> m Reply-updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo =-  bindM2 put url (return (Just body))-  where-    url = addQuery params <$> joinPath ["_snapshot", snapshotRepoName gSnapshotRepoName]-    params-      | repoUpdateVerify = []-      | otherwise        = [("verify", Just "false")]-    body = encode $ object [ "type" .= gSnapshotRepoType-                           , "settings" .= gSnapshotRepoSettings-                           ]-    GenericSnapshotRepo {..} = toGSnapshotRepo repo------ | Verify if a snapshot repo is working. __NOTE:__ this API did not--- make it into Elasticsearch until 1.4. If you use an older version,--- you will get an error here.-verifySnapshotRepo-    :: ( MonadBH m-       , MonadThrow m-       )-    => SnapshotRepoName-    -> m (Either EsError SnapshotVerification)-verifySnapshotRepo (SnapshotRepoName n) =-  parseEsResponse =<< bindM2 post url (return Nothing)-  where-    url = joinPath ["_snapshot", n, "_verify"]---deleteSnapshotRepo :: MonadBH m => SnapshotRepoName -> m Reply-deleteSnapshotRepo (SnapshotRepoName n) = delete =<< url-  where-    url = joinPath ["_snapshot", n]----- | Create and start a snapshot-createSnapshot-    :: (MonadBH m)-    => SnapshotRepoName-    -> SnapshotName-    -> SnapshotCreateSettings-    -> m Reply-createSnapshot (SnapshotRepoName repoName)-               (SnapshotName snapName)-               SnapshotCreateSettings {..} =-  bindM2 put url (return (Just body))-  where-    url = addQuery params <$> joinPath ["_snapshot", repoName, snapName]-    params = [("wait_for_completion", Just (boolQP snapWaitForCompletion))]-    body = encode $ object prs-    prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapIndices-                    , Just ("ignore_unavailable" .= snapIgnoreUnavailable)-                    , Just ("ignore_global_state" .= snapIncludeGlobalState)-                    , Just ("partial" .= snapPartial)-                    ]---indexSelectionName :: IndexSelection -> Text-indexSelectionName AllIndexes            = "_all"-indexSelectionName (IndexList (i :| is)) = T.intercalate "," (renderIndex <$> (i:is))-  where-    renderIndex (IndexName n) = n----- | Get info about known snapshots given a pattern and repo name.-getSnapshots-    :: ( MonadBH m-       , MonadThrow m-       )-    => SnapshotRepoName-    -> SnapshotSelection-    -> m (Either EsError [SnapshotInfo])-getSnapshots (SnapshotRepoName repoName) sel =-  fmap (fmap unSIs) . parseEsResponse =<< get =<< url-  where-    url = joinPath ["_snapshot", repoName, snapPath]-    snapPath = case sel of-      AllSnapshots -> "_all"-      SnapshotList (s :| ss) -> T.intercalate "," (renderPath <$> (s:ss))-    renderPath (SnapPattern t)              = t-    renderPath (ExactSnap (SnapshotName t)) = t---newtype SIs = SIs { unSIs :: [SnapshotInfo] }---instance FromJSON SIs where-  parseJSON = withObject "Collection of SnapshotInfo" parse-    where-      parse o = SIs <$> o .: "snapshots"----- | Delete a snapshot. Cancels if it is running.-deleteSnapshot :: MonadBH m => SnapshotRepoName -> SnapshotName -> m Reply-deleteSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) =-  delete =<< url-  where-    url = joinPath ["_snapshot", repoName, snapName]----- | Restore a snapshot to the cluster See--- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/modules-snapshots.html#_restore>--- for more details.-restoreSnapshot-    :: MonadBH m-    => SnapshotRepoName-    -> SnapshotName-    -> SnapshotRestoreSettings-    -- ^ Start with 'defaultSnapshotRestoreSettings' and customize-    -- from there for reasonable defaults.-    -> m Reply-restoreSnapshot (SnapshotRepoName repoName)-                (SnapshotName snapName)-                SnapshotRestoreSettings {..} = bindM2 post url (return (Just body))-  where-    url = addQuery params <$> joinPath ["_snapshot", repoName, snapName, "_restore"]-    params = [("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion))]-    body = encode (object prs)---    prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapRestoreIndices-                 , Just ("ignore_unavailable" .= snapRestoreIgnoreUnavailable)-                 , Just ("include_global_state" .= snapRestoreIncludeGlobalState)-                 , ("rename_pattern" .=) <$> snapRestoreRenamePattern-                 , ("rename_replacement" .=) . renderTokens <$> snapRestoreRenameReplacement-                 , Just ("include_aliases" .= snapRestoreIncludeAliases)-                 , ("index_settings" .= ) <$> snapRestoreIndexSettingsOverrides-                 , ("ignore_index_settings" .= ) <$> snapRestoreIgnoreIndexSettings-                 ]-    renderTokens (t :| ts) = mconcat (renderToken <$> (t:ts))-    renderToken (RRTLit t)      = t-    renderToken RRSubWholeMatch = "$0"-    renderToken (RRSubGroup g)  = T.pack (show (rrGroupRefNum g))---getNodesInfo-    :: ( MonadBH m-       , MonadThrow m-       )-    => NodeSelection-    -> m (Either EsError NodesInfo)-getNodesInfo sel = parseEsResponse =<< get =<< url-  where-    url = joinPath ["_nodes", selectionSeg]-    selectionSeg = case sel of-      LocalNode -> "_local"-      NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l:ls))-      AllNodes -> "_all"-    selToSeg (NodeByName (NodeName n))            = n-    selToSeg (NodeByFullNodeId (FullNodeId i))    = i-    selToSeg (NodeByHost (Server s))              = s-    selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v--getNodesStats-    :: ( MonadBH m-       , MonadThrow m-       )-    => NodeSelection-    -> m (Either EsError NodesStats)-getNodesStats sel = parseEsResponse =<< get =<< url-  where-    url = joinPath ["_nodes", selectionSeg, "stats"]-    selectionSeg = case sel of-      LocalNode -> "_local"-      NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l:ls))-      AllNodes -> "_all"-    selToSeg (NodeByName (NodeName n))            = n-    selToSeg (NodeByFullNodeId (FullNodeId i))    = i-    selToSeg (NodeByHost (Server s))              = s-    selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v---- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.------ >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")--- >>> respIsTwoHunna response--- True--- >>> runBH' $ indexExists (IndexName "didimakeanindex")--- True-createIndex :: MonadBH m => IndexSettings -> IndexName -> m Reply-createIndex indexSettings (IndexName indexName) =-  bindM2 put url (return body)-  where url = joinPath [indexName]-        body = Just $ encode indexSettings---- | Create an index, providing it with any number of settings. This---   is more expressive than 'createIndex' but makes is more verbose---   for the common case of configuring only the shard count and---   replica count.-createIndexWith :: MonadBH m-  => [UpdatableIndexSetting]-  -> Int -- ^ shard count-  -> IndexName-  -> m Reply-createIndexWith updates shards (IndexName indexName) =-  bindM2 put url (return (Just body))-  where url = joinPath [indexName]-        body = encode $ object-          ["settings" .= deepMerge-            ( X.singleton "index.number_of_shards" (toJSON shards) :-              [u | Object u <- toJSON <$> updates]-            )-          ]---- | 'flushIndex' will flush an index given a 'Server' and an 'IndexName'.-flushIndex :: MonadBH m => IndexName -> m Reply-flushIndex (IndexName indexName) = do-  path <- joinPath [indexName, "_flush"]-  post path Nothing---- | 'deleteIndex' will delete an index given a 'Server' and an 'IndexName'.------ >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")--- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")--- >>> respIsTwoHunna response--- True--- >>> runBH' $ indexExists (IndexName "didimakeanindex")--- False-deleteIndex :: MonadBH m => IndexName -> m Reply-deleteIndex (IndexName indexName) =-  delete =<< joinPath [indexName]---- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index------ >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "unconfiguredindex")--- >>> response <- runBH' $ updateIndexSettings (BlocksWrite False :| []) (IndexName "unconfiguredindex")--- >>> respIsTwoHunna response--- True-updateIndexSettings :: MonadBH m => NonEmpty UpdatableIndexSetting -> IndexName -> m Reply-updateIndexSettings updates (IndexName indexName) =-  bindM2 put url (return body)-  where-    url = joinPath [indexName, "_settings"]-    body = Just (encode jsonBody)-    jsonBody = Object (deepMerge [u | Object u <- toJSON <$> toList updates])---getIndexSettings :: (MonadBH m, MonadThrow m) => IndexName-                 -> m (Either EsError IndexSettingsSummary)-getIndexSettings (IndexName indexName) =-  parseEsResponse =<< get =<< url-  where-    url = joinPath [indexName, "_settings"]---- | 'forceMergeIndex'------ The force merge API allows to force merging of one or more indices through--- an API. The merge relates to the number of segments a Lucene index holds--- within each shard. The force merge operation allows to reduce the number of--- segments by merging them.------ This call will block until the merge is complete. If the http connection is--- lost, the request will continue in the background, and any new requests will--- block until the previous force merge is complete.---- For more information see--- <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-forcemerge.html#indices-forcemerge>.--- Nothing--- worthwhile comes back in the reply body, so matching on the status--- should suffice.------ 'forceMergeIndex' 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.------ >>> let ixn = IndexName "unoptimizedindex"--- >>> _ <- runBH' $ deleteIndex ixn >> createIndex defaultIndexSettings ixn--- >>> response <- runBH' $ forceMergeIndex (IndexList (ixn :| [])) (defaultIndexOptimizationSettings { maxNumSegments = Just 1, onlyExpungeDeletes = True })--- >>> respIsTwoHunna response--- True-forceMergeIndex :: MonadBH m => IndexSelection -> ForceMergeIndexSettings -> m Reply-forceMergeIndex ixs ForceMergeIndexSettings {..} =-    bindM2 post url (return body)-  where url = addQuery params <$> joinPath [indexName, "_forcemerge"]-        params = catMaybes [ ("max_num_segments",) . Just . showText <$> maxNumSegments-                           , Just ("only_expunge_deletes", Just (boolQP onlyExpungeDeletes))-                           , Just ("flush", Just (boolQP flushAfterOptimize))-                           ]-        indexName = indexSelectionName ixs-        body = Nothing---deepMerge :: [Object] -> Object-deepMerge = LS.foldl' (X.unionWith merge) mempty-  where merge (Object a) (Object b) = Object (deepMerge [a, b])-        merge _ b = b---statusCodeIs :: (Int, Int) -> Reply -> Bool-statusCodeIs r resp = inRange r $ NHTS.statusCode (responseStatus resp)--respIsTwoHunna :: Reply -> Bool-respIsTwoHunna = statusCodeIs (200, 299)--existentialQuery :: MonadBH m => Text -> m (Reply, Bool)-existentialQuery url = do-  reply <- head url-  return (reply, respIsTwoHunna reply)----- | Tries to parse a response body as the expected type @a@ and--- failing that tries to parse it as an EsError. All well-formed, JSON--- responses from elasticsearch should fall into these two--- categories. If they don't, a 'EsProtocolException' will be--- thrown. If you encounter this, please report the full body it--- reports along with your Elasticsearch verison.-parseEsResponse :: ( MonadThrow m-                   , FromJSON a-                   )-                => Reply-                -> m (Either EsError a)-parseEsResponse reply-  | respIsTwoHunna reply = case eitherDecode body of-                             Right a -> return (Right a)-                             Left err ->-                               tryParseError err-  | otherwise = tryParseError "Non-200 status code"-  where body = responseBody reply-        tryParseError originalError-          = case eitherDecode body of-              Right e -> return (Left e)-              -- Failed to parse the error message.-              Left err -> explode ("Original error was: " <> originalError <> " Error parse failure was: " <> err)-        explode errorMsg = throwM (EsProtocolException (T.pack errorMsg) body)---- | 'indexExists' enables you to check if an index exists. Returns 'Bool'---   in IO------ >>> exists <- runBH' $ indexExists testIndex-indexExists :: MonadBH m => IndexName -> m Bool-indexExists (IndexName indexName) = do-  (_, exists) <- existentialQuery =<< joinPath [indexName]-  return exists---- | 'refreshIndex' will force a refresh on an index. You must--- do this if you want to read what you wrote.------ >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex--- >>> _ <- runBH' $ refreshIndex testIndex-refreshIndex :: MonadBH m => IndexName -> m Reply-refreshIndex (IndexName indexName) =-  bindM2 post url (return Nothing)-  where url = joinPath [indexName, "_refresh"]---- | Block until the index becomes available for indexing---   documents. This is useful for integration tests in which---   indices are rapidly created and deleted.-waitForYellowIndex :: MonadBH m => IndexName -> m Reply-waitForYellowIndex (IndexName indexName) = get =<< url-  where url = addQuery q <$> joinPath ["_cluster","health",indexName]-        q = [("wait_for_status",Just "yellow"),("timeout",Just "10s")]--stringifyOCIndex :: OpenCloseIndex -> Text-stringifyOCIndex oci = case oci of-  OpenIndex  -> "_open"-  CloseIndex -> "_close"--openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m Reply-openOrCloseIndexes oci (IndexName indexName) =-  bindM2 post url (return Nothing)-  where ociString = stringifyOCIndex oci-        url = joinPath [indexName, ociString]---- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at---   <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>------ >>> reply <- runBH' $ openIndex testIndex-openIndex :: MonadBH m => IndexName -> m Reply-openIndex = openOrCloseIndexes OpenIndex---- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at---   <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>------ >>> reply <- runBH' $ closeIndex testIndex-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?format=json"]-    parse body = either (\msg -> (throwM (EsProtocolException (T.pack msg) body))) return $ do-      vals <- eitherDecode body-      forM vals $ \val ->-        case val of-          Object obj ->-            case X.lookup "index" obj of-              (Just (String txt)) -> Right (IndexName txt)-              v -> Left $ "indexVal in listIndices failed on non-string, was: " <> show v-          v -> Left $ "One of the values parsed in listIndices wasn't an object, it was: " <> show v---- | 'catIndices' returns a list of all index names on a given 'Server' as well as their doc counts-catIndices :: (MonadThrow m, MonadBH m) => m [(IndexName, Int)]-catIndices =-  parse . responseBody =<< get =<< url-  where-    url = joinPath ["_cat/indices?format=json"]-    parse body = either (\msg -> (throwM (EsProtocolException (T.pack msg) body))) return $ do-      vals <- eitherDecode body-      forM vals $ \val ->-        case val of-          Object obj ->-            case (X.lookup "index" obj, X.lookup "docs.count" obj) of-              (Just (String txt), Just (String docs)) -> Right ((IndexName txt), read (T.unpack docs))-              v -> Left $ "indexVal in catIndices failed on non-string, was: " <> show v-          v -> Left $ "One of the values parsed in catIndices wasn't an object, it was: " <> show v---- | 'updateIndexAliases' updates the server's index alias--- table. Operations are atomic. Explained in further detail at--- <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-aliases.html>------ >>> let src = IndexName "a-real-index"--- >>> 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--- True--- >>> respIsTwoHunna <$> runBH' (updateIndexAliases (AddAlias iAlias aliasCreate :| []))--- True--- >>> runBH' $ indexExists aliasName--- True-updateIndexAliases :: MonadBH m => NonEmpty IndexAliasAction -> m Reply-updateIndexAliases actions = bindM2 post url (return body)-  where url = joinPath ["_aliases"]-        body = Just (encode bodyJSON)-        bodyJSON = object [ "actions" .= toList actions]---- | Get all aliases configured on the server.-getIndexAliases :: (MonadBH m, MonadThrow m)-                => m (Either EsError IndexAliasesSummary)-getIndexAliases = parseEsResponse =<< get =<< url-  where url = joinPath ["_aliases"]---- | Delete a single alias, removing it from all indices it---   is currently associated with.-deleteIndexAlias :: MonadBH m => IndexAliasName -> m Reply-deleteIndexAlias (IndexAliasName (IndexName name)) = delete =<< url-  where url = joinPath ["_all","_alias",name]---- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.---   Explained in further detail at---   <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>------   >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]---   >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")-putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m Reply-putTemplate indexTemplate (TemplateName templateName) =-  bindM2 put url (return body)-  where url = joinPath ["_template", templateName]-        body = Just $ encode indexTemplate---- | 'templateExists' checks to see if a template exists.------   >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")-templateExists :: MonadBH m => TemplateName -> m Bool-templateExists (TemplateName templateName) = do-  (_, exists) <- existentialQuery =<< joinPath ["_template", templateName]-  return exists---- | 'deleteTemplate' is an HTTP DELETE and deletes a template.------   >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]---   >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")---   >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")-deleteTemplate :: MonadBH m => TemplateName -> m Reply-deleteTemplate (TemplateName templateName) =-  delete =<< joinPath ["_template", templateName]---- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas--- for documents in indexes.------ >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex--- >>> resp <- runBH' $ putMapping testIndex TweetMapping--- >>> print resp--- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("transfer-encoding","chunked")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}-putMapping :: (MonadBH m, ToJSON a) => IndexName -> a -> m Reply-putMapping (IndexName indexName) mapping =-  bindM2 put url (return body)-  where url = joinPath [indexName, "_mapping"]-        -- "_mapping" above is originally transposed-        -- erroneously. The correct API call is: "/INDEX/_mapping"-        body = Just $ encode mapping--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---   primary key for the document. You are encouraged to generate---   your own id's and not rely on Elasticsearch's automatic id---   generation. Read more about it here:---   https://github.com/bitemyapp/bloodhound/issues/107------ >>> resp <- runBH' $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1")--- >>> print resp--- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("content-length","152")], responseBody = "{\"_index\":\"bloodhound-tests-twitter-1\",\"_type\":\"_doc\",\"_id\":\"1\",\"_version\":2,\"result\":\"updated\",\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\"_seq_no\":1,\"_primary_term\":1}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}-indexDocument :: (ToJSON doc, MonadBH m) => IndexName-                 -> IndexDocumentSettings -> doc -> DocId -> m Reply-indexDocument (IndexName indexName) cfg document (DocId docId) =-  bindM2 put url (return body)-  where url = addQuery (indexQueryString cfg (DocId docId)) <$> joinPath [indexName, "_doc", docId]-        jsonBody = encodeDocument cfg document-        body = Just (encode jsonBody)---- | 'updateDocument' provides a way to perform an partial update of a--- an already indexed document.-updateDocument :: (ToJSON patch, MonadBH m) => IndexName-                  -> IndexDocumentSettings -> patch -> DocId -> m Reply-updateDocument (IndexName indexName) cfg patch (DocId docId) =-  bindM2 post url (return body)-  where url = addQuery (indexQueryString cfg (DocId docId)) <$>-              joinPath [indexName, "_update", docId]-        jsonBody = encodeDocument cfg patch-        body = Just (encode $ object ["doc" .= jsonBody])--{-  From ES docs:-      Parent and child documents must be indexed on the same shard.-      This means that the same routing value needs to be provided when getting, deleting, or updating a child document.--    Parent/Child support in Bloodhound requires MUCH more love.-    To work it around for now (and to support the existing unit test) we route "parent" documents to their "_id"-    (which is the default strategy for the ES), and route all child documents to their parens' "_id"--    However, it may not be flexible enough for some corner cases.--    Buld operations are completely unaware of "routing" and are probably broken in that matter.-    Or perhaps they always were, because the old "_parent" would also have this requirement.--}-indexQueryString :: IndexDocumentSettings -> DocId -> [(Text, Maybe Text)]-indexQueryString cfg (DocId docId) =-  versionCtlParams cfg <> routeParams-  where-    routeParams = case idsJoinRelation cfg of-      Nothing -> []-      Just (ParentDocument _ _) -> [("routing", Just docId)]-      Just (ChildDocument _ _ (DocId pid)) -> [("routing", Just pid)]--encodeDocument :: ToJSON doc => IndexDocumentSettings -> doc -> Value-encodeDocument cfg document =-  case idsJoinRelation cfg of-    Nothing -> toJSON document-    Just (ParentDocument (FieldName field) name) ->-      mergeObjects (toJSON document) (object [fromText field .= name])-    Just (ChildDocument (FieldName field) name parent) ->-      mergeObjects (toJSON document) (object [fromText field .= object ["name" .= name, "parent" .= parent]])-  where-    mergeObjects (Object a) (Object b) = Object (a <> b)-    mergeObjects _ _ = error "Impossible happened: both document body and join parameters must be objects"---- | 'deleteDocument' is the primary way to delete a single document.------ >>> _ <- runBH' $ deleteDocument testIndex (DocId "1")-deleteDocument :: MonadBH m => IndexName -> DocId -> m Reply-deleteDocument (IndexName indexName) (DocId docId) =-  delete =<< joinPath [indexName, "_doc", docId]---- | 'deleteByQuery' performs a deletion on every document that matches a query.------ >>> let query = TermQuery (Term "user" "bitemyapp") Nothing--- >>> _ <- runBH' $ deleteDocument testIndex query-deleteByQuery :: MonadBH m => IndexName -> Query -> m Reply-deleteByQuery (IndexName indexName) query =-  bindM2 post url (return body)-  where-    url = joinPath [indexName, "_delete_by_query"]-    body = Just (encode $ object [ "query" .= query ])---- | 'bulk' uses---    <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>---    to perform bulk operations. The 'BulkOperation' data type encodes the---    index\/update\/delete\/create operations. You pass a 'V.Vector' of 'BulkOperation's---    and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch---    server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.------ >>> let stream = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))]--- >>> _ <- runBH' $ bulk stream--- >>> _ <- runBH' $ refreshIndex testIndex-bulk :: MonadBH m => V.Vector BulkOperation -> m Reply-bulk bulkOps =-  bindM2 post url (return body)-  where-    url = joinPath ["_bulk"]-    body = Just $ encodeBulkOperations bulkOps---- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'---   into an 'L.ByteString'------ >>> let bulkOps = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))]--- >>> encodeBulkOperations bulkOps--- "\n{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n"-encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString-encodeBulkOperations stream = collapsed where-  blobs =-    fmap encodeBulkOperation stream-  mashedTaters =-    mash (mempty :: Builder) blobs-  collapsed =-    toLazyByteString $ mappend mashedTaters (byteString "\n")--mash :: Builder -> V.Vector L.ByteString -> Builder-mash = V.foldl' (\b x -> b <> byteString "\n" <> lazyByteString x)--mkBulkStreamValue :: Text -> Text -> Text -> Value-mkBulkStreamValue operation indexName docId =-  object [fromText operation .=-          object [ "_index" .= indexName-                 , "_id"    .= docId]]--mkBulkStreamValueAuto :: Text -> Text -> Value-mkBulkStreamValueAuto operation indexName =-  object [fromText operation .=-          object [ "_index" .= indexName ]]--mkBulkStreamValueWithMeta :: [UpsertActionMetadata] -> Text -> Text -> Text -> Value-mkBulkStreamValueWithMeta meta operation indexName docId =-  object [ fromText operation .=-          object ([ "_index" .= indexName-                  , "_id"    .= docId]-                  <> (buildUpsertActionMetadata <$> meta))]---- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'---   into an 'L.ByteString'------ >>> let bulkOp = BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))--- >>> encodeBulkOperation bulkOp--- "{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}"-encodeBulkOperation :: BulkOperation -> L.ByteString-encodeBulkOperation (BulkIndex (IndexName indexName) (DocId docId) value) = blob-    where metadata = mkBulkStreamValue "index" indexName docId-          blob = encode metadata `mappend` "\n" `mappend` encode value--encodeBulkOperation (BulkIndexAuto (IndexName indexName) value) = blob-    where metadata = mkBulkStreamValueAuto "index" indexName-          blob = encode metadata `mappend` "\n" `mappend` encode value--encodeBulkOperation (BulkIndexEncodingAuto (IndexName indexName) encoding) = toLazyByteString blob-    where metadata = toEncoding (mkBulkStreamValueAuto "index" indexName)-          blob = fromEncoding metadata <> "\n" <> fromEncoding encoding--encodeBulkOperation (BulkCreate (IndexName indexName) (DocId docId) value) = blob-    where metadata = mkBulkStreamValue "create" indexName docId-          blob = encode metadata `mappend` "\n" `mappend` encode value--encodeBulkOperation (BulkDelete (IndexName indexName) (DocId docId)) = blob-    where metadata = mkBulkStreamValue "delete" indexName docId-          blob = encode metadata--encodeBulkOperation (BulkUpdate (IndexName indexName) (DocId docId) value) = blob-    where metadata = mkBulkStreamValue "update" indexName docId-          doc = object ["doc" .= value]-          blob = encode metadata `mappend` "\n" `mappend` encode doc--encodeBulkOperation (BulkUpsert (IndexName indexName)-                (DocId docId)-                payload-                actionMeta) = blob-    where metadata = mkBulkStreamValueWithMeta actionMeta "update" indexName docId-          blob = encode metadata <> "\n" <> encode doc-          doc = case payload of-            UpsertDoc value -> object ["doc" .= value, "doc_as_upsert" .= True]-            UpsertScript scriptedUpsert script value ->-              let scup = if scriptedUpsert then ["scripted_upsert" .= True] else []-                  upsert = ["upsert" .= value]-              in-                case (object (scup <> upsert), toJSON script) of-                  (Object obj, Object jscript) -> Object $ jscript <> obj-                  _ -> error "Impossible happened: serialising Script to Json should always be Object"----encodeBulkOperation (BulkCreateEncoding (IndexName indexName) (DocId docId) encoding) =-    toLazyByteString blob-    where metadata = toEncoding (mkBulkStreamValue "create" indexName docId)-          blob = fromEncoding metadata <> "\n" <> fromEncoding encoding---- | 'getDocument' is a straight-forward way to fetch a single document from---   Elasticsearch using a 'Server', 'IndexName', and a 'DocId'.---   The 'DocId' is the primary key for your Elasticsearch document.------ >>> yourDoc <- runBH' $ getDocument testIndex (DocId "1")-getDocument :: MonadBH m => IndexName -> DocId -> m Reply-getDocument (IndexName indexName) (DocId docId) =-  get =<< joinPath [indexName, "_doc", docId]---- | 'documentExists' enables you to check if a document exists.-documentExists :: MonadBH m => IndexName ->  DocId -> m Bool-documentExists (IndexName indexName) (DocId docId) =-  fmap snd (existentialQuery =<< joinPath [indexName, "_doc", docId])--dispatchSearch :: MonadBH m => Text -> Search -> m Reply-dispatchSearch url search = post url' (Just (encode search))-  where url' = appendSearchTypeParam url (searchType search)---- | 'searchAll', given a 'Search', will perform that search against all indexes---   on an Elasticsearch server. Try to avoid doing this if it can be helped.------ >>> let query = TermQuery (Term "user" "bitemyapp") Nothing--- >>> let search = mkSearch (Just query) Nothing--- >>> reply <- runBH' $ searchAll search-searchAll :: MonadBH m => Search -> m Reply-searchAll = bindM2 dispatchSearch url . return-  where url = joinPath ["_search"]---- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search---   within an index on an Elasticsearch server.------ >>> let query = TermQuery (Term "user" "bitemyapp") Nothing--- >>> let search = mkSearch (Just query) Nothing--- >>> reply <- runBH' $ searchByIndex testIndex search-searchByIndex :: MonadBH m => IndexName -> Search -> m Reply-searchByIndex (IndexName indexName) = bindM2 dispatchSearch url . return-  where url = joinPath [indexName, "_search"]---- | 'searchByIndices' is a variant of 'searchByIndex' that executes a---   'Search' over many indices. This is much faster than using---   'mapM' to 'searchByIndex' over a collection since it only---   causes a single HTTP request to be emitted.-searchByIndices :: MonadBH m => NonEmpty IndexName -> Search -> m Reply-searchByIndices ixs = bindM2 dispatchSearch url . return-  where url = joinPath [renderedIxs, "_search"]-        renderedIxs = T.intercalate (T.singleton ',') (map (\(IndexName t) -> t) (toList ixs))--dispatchSearchTemplate :: MonadBH m => Text -> SearchTemplate -> m Reply-dispatchSearchTemplate url search = post url (Just (encode search))---- | 'searchByIndexTemplate', given a 'SearchTemplate' and an 'IndexName', will perform that search---   within an index on an Elasticsearch server.------ >>> let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } }, \"size\" : \"{{my_size}}\"}"--- >>> let search = mkSearchTemplate (Right query) Nothing--- >>> reply <- runBH' $ searchByIndexTemplate testIndex search-searchByIndexTemplate :: MonadBH m => IndexName -> SearchTemplate -> m Reply-searchByIndexTemplate (IndexName indexName) = bindM2 dispatchSearchTemplate url . return-  where url = joinPath [indexName, "_search", "template"]---- | 'searchByIndicesTemplate' is a variant of 'searchByIndexTemplate' that executes a---   'SearchTemplate' over many indices. This is much faster than using---   'mapM' to 'searchByIndexTemplate' over a collection since it only---   causes a single HTTP request to be emitted.-searchByIndicesTemplate :: MonadBH m => NonEmpty IndexName -> SearchTemplate -> m Reply-searchByIndicesTemplate ixs = bindM2 dispatchSearchTemplate url . return-  where url = joinPath [renderedIxs, "_search", "template"]-        renderedIxs = T.intercalate (T.singleton ',') (map (\(IndexName t) -> t) (toList ixs))---- | 'storeSearchTemplate', saves a 'SearchTemplateSource' to be used later.-storeSearchTemplate :: MonadBH m => SearchTemplateId -> SearchTemplateSource -> m Reply-storeSearchTemplate (SearchTemplateId tid) ts =-  url >>= flip post (Just (encode json_))-  where-    url = joinPath ["_scripts", tid]-    json_ = Object $ X.fromList ["script" .= Object ("lang" .= String "mustache" <> "source" .= ts) ]---- | 'getSearchTemplate', get info of an stored 'SearchTemplateSource'.-getSearchTemplate :: MonadBH m => SearchTemplateId -> m Reply -getSearchTemplate (SearchTemplateId tid) =-  url >>= get-  where-    url = joinPath ["_scripts", tid]---- | 'storeSearchTemplate', -deleteSearchTemplate :: MonadBH m => SearchTemplateId -> m Reply -deleteSearchTemplate (SearchTemplateId tid) =-  url >>= delete-  where-    url = joinPath ["_scripts", tid]---- | For a given search, request a scroll for efficient streaming of--- search results. Note that the search is put into 'SearchTypeScan'--- mode and thus results will not be sorted. Combine this with--- 'advanceScroll' to efficiently stream through the full result set-getInitialScroll ::-  (FromJSON a, MonadThrow m, MonadBH m) => IndexName ->-                                           Search ->-                                           m (Either EsError (SearchResult a))-getInitialScroll (IndexName indexName) search' = do-    let url = addQuery params <$> joinPath [indexName, "_search"]-        params = [("scroll", Just "1m")]-        sorting = Just [DefaultSortSpec $ mkSort (FieldName "_doc") Descending]-        search = search' { sortBody = sorting }-    resp' <- bindM2 dispatchSearch url (return search)-    parseEsResponse resp'---- | For a given search, request a scroll for efficient streaming of--- search results. Combine this with 'advanceScroll' to efficiently--- stream through the full result set. Note that this search respects--- sorting and may be less efficient than 'getInitialScroll'.-getInitialSortedScroll ::-  (FromJSON a, MonadThrow m, MonadBH m) => IndexName ->-                                           Search ->-                                           m (Either EsError (SearchResult a))-getInitialSortedScroll (IndexName indexName) search = do-    let url = addQuery params <$> joinPath [indexName, "_search"]-        params = [("scroll", Just "1m")]-    resp' <- bindM2 dispatchSearch url (return search)-    parseEsResponse resp'--scroll' :: (FromJSON a, MonadBH m, MonadThrow m) => Maybe ScrollId ->-                                                    m ([Hit a], Maybe ScrollId)-scroll' Nothing = return ([], Nothing)-scroll' (Just sid) = do-    res <- advanceScroll sid 60-    case res of-      Right SearchResult {..} -> return (hits searchHits, scrollId)-      Left _ -> return ([], Nothing)---- | 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-     , MonadThrow m-     )-  => ScrollId-  -> NominalDiffTime-  -- ^ How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default.-  -> m (Either EsError (SearchResult a))-advanceScroll (ScrollId sid) scroll = do-  url <- joinPath ["_search", "scroll"]-  resp <- post url (Just $ encode scrollObject)-  parseEsResponse resp-  where scrollTime = showText secs <> "s"-        secs :: Integer-        secs = round scroll--        scrollObject = object [ "scroll" .= scrollTime-                              , "scroll_id" .= sid-                              ]--scanAccumulator ::-  (FromJSON a, MonadBH m, MonadThrow m) =>-                                [Hit a] ->-                                ([Hit a], Maybe ScrollId) ->-                                m ([Hit a], Maybe ScrollId)-scanAccumulator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)-scanAccumulator oldHits ([], _) = return (oldHits, Nothing)-scanAccumulator oldHits (newHits, msid) = do-    (newHits', msid') <- scroll' msid-    scanAccumulator (oldHits ++ newHits) (newHits', msid')---- | 'scanSearch' uses the 'scroll' API of elastic,--- for a given 'IndexName'. Note that this will--- consume the entire search result set and will be doing O(n) list--- appends so this may not be suitable for large result sets. In that--- case, 'getInitialScroll' and 'advanceScroll' are good low level--- tools. You should be able to hook them up trivially to conduit,--- pipes, or your favorite streaming IO abstraction of choice. Note--- that ordering on the search would destroy performance and thus is--- ignored.-scanSearch :: (FromJSON a, MonadBH m, MonadThrow m) => IndexName-                                                    -> Search-                                                    -> m [Hit a]-scanSearch indexName search = do-    initialSearchResult <- getInitialScroll indexName search-    let (hits', josh) = case initialSearchResult of-                          Right SearchResult {..} -> (hits searchHits, scrollId)-                          Left _ -> ([], Nothing)-    (totalHits, _) <- scanAccumulator [] (hits', josh)-    return totalHits--pitAccumulator-  :: (FromJSON a, MonadBH m, MonadThrow m) => Search -> [Hit a] -> m [Hit a]-pitAccumulator search oldHits = do-  resp   <- searchAll search-  parsed <- parseEsResponse resp-  case parsed of-    Left  _            -> return []-    Right searchResult -> case hits (searchHits searchResult) of-      []      -> return oldHits-      newHits -> case (hitSort $ last newHits, pitId searchResult) of-        (Nothing, Nothing) ->-          error "no point in time (PIT) ID or last sort value"-        (Just _       , Nothing    ) -> error "no point in time (PIT) ID"-        (Nothing      , _     ) -> return (oldHits <> newHits)-        (Just lastSort, Just pitId') -> do-          let newSearch = search { pointInTime = Just (PointInTime pitId' "1m")-                                 , searchAfterKey = Just lastSort-                                 }-          pitAccumulator newSearch (oldHits <> newHits)---- | 'pitSearch' uses the point in time (PIT) API of elastic, for a given--- 'IndexName'. Requires Elasticsearch >=7.10. Note that this will consume the--- entire search result set and will be doing O(n) list appends so this may--- not be suitable for large result sets. In that case, the point in time API--- should be used directly with `openPointInTime` and `closePointInTime`.------ Note that 'pitSearch' utilizes the 'search_after' parameter under the hood,--- which requires a non-empty 'sortBody' field in the provided 'Search' value.--- Otherwise, 'pitSearch' will fail to return all matching documents.------ For more information see--- <https://www.elastic.co/guide/en/elasticsearch/reference/current/point-in-time-api.html>.-pitSearch-  :: (FromJSON a, MonadBH m, MonadThrow m) => IndexName -> Search -> m [Hit a]-pitSearch indexName search = do-  openResp <- openPointInTime indexName-  case openResp of-    Left  _                            -> return []-    Right OpenPointInTimeResponse {..} -> do-      let searchPIT = search { pointInTime = Just (PointInTime oPitId "1m") }-      hits      <- pitAccumulator searchPIT []-      closeResp <- closePointInTime $ ClosePointInTime oPitId-      case closeResp of-        Left _ -> return []-        Right (ClosePointInTimeResponse False _) ->-          error "failed to close point in time (PIT)"-        Right (ClosePointInTimeResponse True _) -> return hits---- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'---   to Nothing in case you only care about your 'Query' and 'Filter'. Use record update---   syntax if you want to add things like aggregations or highlights while still using---   this helper function.------ >>> let query = TermQuery (Term "user" "bitemyapp") Nothing--- >>> mkSearch (Just query) Nothing--- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, searchAfterKey = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}-mkSearch :: Maybe Query -> Maybe Filter -> Search-mkSearch query filter = Search-  { queryBody       = query -  , filterBody      = filter-  , sortBody        = Nothing-  , aggBody         = Nothing-  , highlight       = Nothing-  , trackSortScores = False-  , from            = From 0-  , size            = Size 10-  , searchType      = SearchTypeQueryThenFetch-  , searchAfterKey  = Nothing-  , fields          = Nothing-  , scriptFields    = Nothing-  , source          = Nothing-  , suggestBody     = Nothing-  , pointInTime     = Nothing-  }---- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for---   the 'Query' and the 'Aggregation'.------ >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }--- >>> terms--- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})--- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms-mkAggregateSearch :: Maybe Query -> Aggregations -> Search-mkAggregateSearch query mkSearchAggs = Search-  { queryBody       = query-  , filterBody      = Nothing-  , sortBody        = Nothing-  , aggBody         = Just mkSearchAggs-  , highlight       = Nothing-  , trackSortScores = False-  , from            = From 0-  , size            = Size 0-  , searchType      = SearchTypeQueryThenFetch-  , searchAfterKey  = Nothing-  , fields          = Nothing-  , scriptFields    = Nothing-  , source          = Nothing-  , suggestBody     = Nothing-  , pointInTime     = Nothing-  }---- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for---   the 'Query' and the 'Aggregation'.------ >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")--- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]--- >>> let search = mkHighlightSearch (Just query) testHighlight-mkHighlightSearch :: Maybe Query -> Highlights -> Search-mkHighlightSearch query searchHighlights = Search-  { queryBody       = query-  , filterBody      = Nothing-  , sortBody        = Nothing-  , aggBody         = Nothing-  , highlight       = Just searchHighlights-  , trackSortScores = False-  , from            = From 0-  , size            = Size 10-  , searchType      = SearchTypeDfsQueryThenFetch-  , searchAfterKey  = Nothing-  , fields          = Nothing-  , scriptFields    = Nothing-  , source          = Nothing-  , suggestBody     = Nothing-  , pointInTime     = Nothing-  }---- | 'mkSearchTemplate' is a helper function for defaulting additional fields of a 'SearchTemplate'---   to Nothing. Use record update syntax if you want to add things.-mkSearchTemplate :: Either SearchTemplateId SearchTemplateSource -> TemplateQueryKeyValuePairs -> SearchTemplate-mkSearchTemplate id_ params = SearchTemplate id_ params Nothing Nothing---- | 'pageSearch' is a helper function that takes a search and assigns the from---    and size fields for the search. The from parameter defines the offset---    from the first result you want to fetch. The size parameter allows you to---    configure the maximum amount of hits to be returned.------ >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")--- >>> let search = mkSearch (Just query) Nothing--- >>> search--- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}--- >>> pageSearch (From 10) (Size 100) search--- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}-pageSearch :: From     -- ^ The result offset-           -> Size     -- ^ The number of results to return-           -> Search  -- ^ The current seach-           -> Search  -- ^ The paged search-pageSearch resultOffset pageSize search = search { from = resultOffset, size = pageSize }--parseUrl' :: MonadThrow m => Text -> m Request-parseUrl' t = parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack t))---- | Was there an optimistic concurrency control conflict when--- indexing a document?-isVersionConflict :: Reply -> Bool-isVersionConflict = statusCheck (== 409)--isSuccess :: Reply -> Bool-isSuccess = statusCheck (inRange (200, 299))--isCreated :: Reply -> Bool-isCreated = statusCheck (== 201)--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---boolQP :: Bool -> Text-boolQP True  = "true"-boolQP False = "false"--countByIndex :: (MonadBH m, MonadThrow m) => IndexName -> CountQuery -> m (Either EsError CountResponse)-countByIndex (IndexName indexName) q = do-  url <- joinPath [indexName, "_count"]-  parseEsResponse =<< post url (Just (encode q))---- | 'openPointInTime' opens a point in time for an index given an 'IndexName'. --- Note that the point in time should be closed with 'closePointInTime' as soon --- as it is no longer needed.------ For more information see--- <https://www.elastic.co/guide/en/elasticsearch/reference/current/point-in-time-api.html>.-openPointInTime-  :: (MonadBH m, MonadThrow m)-  => IndexName-  -> m (Either EsError OpenPointInTimeResponse)-openPointInTime (IndexName indexName) = do-  url <- joinPath [indexName, "_pit?keep_alive=1m"]-  parseEsResponse =<< post url Nothing---- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'.------ For more information see--- <https://www.elastic.co/guide/en/elasticsearch/reference/current/point-in-time-api.html>.-closePointInTime-  :: (MonadBH m, MonadThrow m)-  => ClosePointInTime-  -> m (Either EsError ClosePointInTimeResponse)-closePointInTime q = do-  url <- joinPath ["_pit"]-  parseEsResponse =<< delete' url (Just (encode q))+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++{- ORMOLU_DISABLE -}+-------------------------------------------------------------------------------+-- |+-- Module : Database.Bloodhound.Client+-- Copyright : (C) 2014, 2018 Chris Allen+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Chris Allen <cma@bitemyapp.com>+-- Stability : provisional+-- Portability : OverloadedStrings+--+-- Client side functions for talking to Elasticsearch servers.+-------------------------------------------------------------------------------+{- ORMOLU_ENABLE -}+module Database.Bloodhound.Client+  ( -- * Bloodhound client functions++    -- | The examples in this module assume the following code has been run.+    --   The :{ and :} will only work in GHCi. You'll only need the data types+    --   and typeclass instances for the functions that make use of them.+    -- $setup+    withBH,++    -- ** Indices+    createIndex,+    createIndexWith,+    flushIndex,+    deleteIndex,+    updateIndexSettings,+    getIndexSettings,+    forceMergeIndex,+    indexExists,+    openIndex,+    closeIndex,+    listIndices,+    catIndices,+    waitForYellowIndex,+    HealthStatus (..),++    -- *** Index Aliases+    updateIndexAliases,+    getIndexAliases,+    deleteIndexAlias,++    -- *** Index Templates+    putTemplate,+    templateExists,+    deleteTemplate,++    -- ** Mapping+    putMapping,++    -- ** Documents+    indexDocument,+    updateDocument,+    getDocument,+    documentExists,+    deleteDocument,+    deleteByQuery,+    IndexedDocument (..),+    DeletedDocuments (..),+    DeletedDocumentsRetries (..),++    -- ** Searching+    searchAll,+    searchByIndex,+    searchByIndices,+    searchByIndexTemplate,+    searchByIndicesTemplate,+    scanSearch,+    getInitialScroll,+    getInitialSortedScroll,+    advanceScroll,+    pitSearch,+    openPointInTime,+    closePointInTime,+    refreshIndex,+    mkSearch,+    mkAggregateSearch,+    mkHighlightSearch,+    mkSearchTemplate,+    bulk,+    pageSearch,+    mkShardCount,+    mkReplicaCount,+    getStatus,++    -- ** Templates+    storeSearchTemplate,+    getSearchTemplate,+    deleteSearchTemplate,++    -- ** Snapshot/Restore++    -- *** Snapshot Repos+    getSnapshotRepos,+    updateSnapshotRepo,+    verifySnapshotRepo,+    deleteSnapshotRepo,++    -- *** Snapshots+    createSnapshot,+    getSnapshots,+    deleteSnapshot,++    -- *** Restoring Snapshots+    restoreSnapshot,++    -- ** Nodes+    getNodesInfo,+    getNodesStats,++    -- ** Request Utilities+    encodeBulkOperations,+    encodeBulkOperation,++    -- * Authentication+    basicAuthHook,++    -- * BHResponse-handling tools+    isVersionConflict,+    isSuccess,+    isCreated,+    parseEsResponse,+    parseEsResponseWith,+    decodeResponse,+    eitherDecodeResponse,++    -- * Count+    countByIndex,++    -- * Generic+    Acknowledged (..),+    Accepted (..),+  )+where++import Control.Applicative as A+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Aeson+import Data.Aeson.Key+import qualified Data.Aeson.KeyMap as X+import Data.ByteString.Builder+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Foldable (toList)+import qualified Data.List as LS (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Clock+import qualified Data.Vector as V+import Database.Bloodhound.Internal.Client.BHRequest+import Database.Bloodhound.Types+import Network.HTTP.Client+import qualified Network.HTTP.Types.Method as NHTM+import qualified Network.URI as URI+import Prelude hiding (filter, head)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> :set -XDeriveGeneric+-- >>> import Database.Bloodhound+-- >>> import Network.HTTP.Client+-- >>> let testServer = (Server "http://localhost:9200")+-- >>> let runBH' = withBH defaultManagerSettings testServer+-- >>> let testIndex = IndexName "twitter"+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0)+-- >>> data TweetMapping = TweetMapping deriving (Eq, Show)+-- >>> _ <- runBH' $ deleteIndex testIndex+-- >>> _ <- runBH' $ deleteIndex (IndexName "didimakeanindex")+-- >>> import GHC.Generics+-- >>> import           Data.Time.Calendar        (Day (..))+-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime)+-- >>> :{+-- instance ToJSON TweetMapping where+--          toJSON TweetMapping =+--            object ["properties" .=+--              object ["location" .=+--                object ["type" .= ("geo_point" :: Text)]]]+-- data Location = Location { lat :: Double+--                         , lon :: Double } deriving (Eq, Generic, Show)+-- data Tweet = Tweet { user     :: Text+--                    , postDate :: UTCTime+--                    , message  :: Text+--                    , age      :: Int+--                    , location :: Location } deriving (Eq, Generic, Show)+-- exampleTweet = Tweet { user     = "bitemyapp"+--                      , postDate = UTCTime+--                                   (ModifiedJulianDay 55000)+--                                   (secondsToDiffTime 10)+--                      , message  = "Use haskell!"+--                      , age      = 10000+--                      , location = Location 40.12 (-71.34) }+-- instance ToJSON   Tweet where+--  toJSON = genericToJSON defaultOptions+-- instance FromJSON Tweet where+--  parseJSON = genericParseJSON defaultOptions+-- instance ToJSON   Location where+--  toJSON = genericToJSON defaultOptions+-- instance FromJSON Location where+--  parseJSON = genericParseJSON defaultOptions+-- data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show)+-- instance FromJSON BulkTest where+--  parseJSON = genericParseJSON defaultOptions+-- instance ToJSON BulkTest where+--  toJSON = genericToJSON defaultOptions+-- :}++-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount'+--   which rejects 'Int' values below 1 and above 1000.+--+-- >>> mkShardCount 10+-- Just (ShardCount 10)+mkShardCount :: Int -> Maybe ShardCount+mkShardCount n+  | n < 1 = Nothing+  | n > 1000 = Nothing+  | otherwise = Just (ShardCount n)++-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount'+--   which rejects 'Int' values below 0 and above 1000.+--+-- >>> mkReplicaCount 10+-- Just (ReplicaCount 10)+mkReplicaCount :: Int -> Maybe ReplicaCount+mkReplicaCount n+  | n < 0 = Nothing+  | n > 1000 = Nothing -- ...+  | otherwise = Just (ReplicaCount n)++emptyBody :: L.ByteString+emptyBody = L.pack ""++dispatch ::+  MonadBH m =>+  BHRequest body ->+  m (BHResponse body)+dispatch request = do+  env <- getBHEnv+  let url = getEndpoint (bhServer env) (bhRequestEndpoint request)+  initReq <- liftIO $ parseUrl' url+  let reqHook = bhRequestHook env+  let reqBody = RequestBodyLBS $ fromMaybe emptyBody $ bhRequestBody request+  req <-+    liftIO $+      reqHook $+        setRequestIgnoreStatus $+          initReq+            { method = bhRequestMethod request,+              requestHeaders =+                -- "application/x-ndjson" for bulk+                ("Content-Type", "application/json") : requestHeaders initReq,+              requestBody = reqBody+            }+  -- req <- liftIO $ reqHook $ setRequestIgnoreStatus $ initReq { method = dMethod+  --                                                            , requestBody = reqBody }+  let mgr = bhManager env+  BHResponse <$> liftIO (httpLbs req mgr)++-- | Convenience function that sets up a manager and BHEnv and runs+-- the given set of bloodhound operations. Connections will be+-- pipelined automatically in accordance with the given manager+-- settings in IO. If you've got your own monad transformer stack, you+-- should use 'runBH' directly.+withBH :: ManagerSettings -> Server -> BH IO a -> IO a+withBH ms s f = do+  mgr <- newManager ms+  let env = mkBHEnv s mgr+  runBH env f++-- Shortcut functions for HTTP methods+delete :: MonadBH m => Endpoint -> m (BHResponse body)+delete = dispatch . mkSimpleRequest NHTM.methodDelete++deleteWithBody :: MonadBH m => Endpoint -> L.ByteString -> m (BHResponse body)+deleteWithBody endpoint = dispatch . mkFullRequest NHTM.methodDelete endpoint++get :: MonadBH m => Endpoint -> m (BHResponse body)+get = dispatch . mkSimpleRequest NHTM.methodGet++head :: MonadBH m => Endpoint -> m (BHResponse body)+head = dispatch . mkSimpleRequest NHTM.methodHead++put :: MonadBH m => Endpoint -> L.ByteString -> m (BHResponse body)+put endpoint = dispatch . mkFullRequest NHTM.methodPut endpoint++post :: MonadBH m => Endpoint -> L.ByteString -> m (BHResponse body)+post endpoint = dispatch . mkFullRequest NHTM.methodPost endpoint++-- | 'getStatus' fetches the 'Status' of a 'Server'+--+-- >>> serverStatus <- runBH' getStatus+-- >>> fmap tagline (serverStatus)+-- Just "You Know, for Search"+getStatus :: MonadBH m => m (Either String Status)+getStatus =+  eitherDecodeResponse <$> get []++-- | 'getSnapshotRepos' gets the definitions of a subset of the+-- defined snapshot repos.+getSnapshotRepos ::+  ( MonadBH m,+    MonadThrow m+  ) =>+  SnapshotRepoSelection ->+  m (ParsedEsResponse [GenericSnapshotRepo])+getSnapshotRepos sel =+  fmap (fmap unGSRs) . parseEsResponse =<< get ["_snapshot", selectorSeg]+  where+    selectorSeg = case sel of+      AllSnapshotRepos -> "_all"+      SnapshotRepoList (p :| ps) -> T.intercalate "," (renderPat <$> (p : ps))+    renderPat (RepoPattern t) = t+    renderPat (ExactRepo (SnapshotRepoName t)) = t++-- | Wrapper to extract the list of 'GenericSnapshotRepo' in the+-- format they're returned in+newtype GSRs = GSRs {unGSRs :: [GenericSnapshotRepo]}++instance FromJSON GSRs where+  parseJSON = withObject "Collection of GenericSnapshotRepo" parse+    where+      parse = fmap GSRs . mapM (uncurry go) . X.toList+      go rawName = withObject "GenericSnapshotRepo" $ \o ->+        GenericSnapshotRepo (SnapshotRepoName $ toText rawName) <$> o .: "type"+          <*> o .: "settings"++-- | Create or update a snapshot repo+updateSnapshotRepo ::+  ( MonadBH m,+    SnapshotRepo repo+  ) =>+  -- | Use 'defaultSnapshotRepoUpdateSettings' if unsure+  SnapshotRepoUpdateSettings ->+  repo ->+  m (BHResponse Acknowledged)+updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo =+  put endpoint (encode body)+  where+    endpoint = ["_snapshot", snapshotRepoName gSnapshotRepoName] `withQueries` params+    params+      | repoUpdateVerify = []+      | otherwise = [("verify", Just "false")]+    body =+      object+        [ "type" .= gSnapshotRepoType,+          "settings" .= gSnapshotRepoSettings+        ]+    GenericSnapshotRepo {..} = toGSnapshotRepo repo++-- | Verify if a snapshot repo is working. __NOTE:__ this API did not+-- make it into Elasticsearch until 1.4. If you use an older version,+-- you will get an error here.+verifySnapshotRepo ::+  ( MonadBH m,+    MonadThrow m+  ) =>+  SnapshotRepoName ->+  m (ParsedEsResponse SnapshotVerification)+verifySnapshotRepo (SnapshotRepoName n) =+  parseEsResponse =<< post ["_snapshot", n, "_verify"] emptyBody++deleteSnapshotRepo :: MonadBH m => SnapshotRepoName -> m (BHResponse Acknowledged)+deleteSnapshotRepo (SnapshotRepoName n) =+  delete ["_snapshot", n]++-- | Create and start a snapshot+createSnapshot ::+  (MonadBH m) =>+  SnapshotRepoName ->+  SnapshotName ->+  SnapshotCreateSettings ->+  m (BHResponse Acknowledged)+createSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) SnapshotCreateSettings {..} =+  put endpoint body+  where+    endpoint = ["_snapshot", repoName, snapName] `withQueries` params+    params = [("wait_for_completion", Just (boolQP snapWaitForCompletion))]+    body = encode $ object prs+    prs =+      catMaybes+        [ ("indices" .=) . indexSelectionName <$> snapIndices,+          Just ("ignore_unavailable" .= snapIgnoreUnavailable),+          Just ("ignore_global_state" .= snapIncludeGlobalState),+          Just ("partial" .= snapPartial)+        ]++indexSelectionName :: IndexSelection -> Text+indexSelectionName AllIndexes = "_all"+indexSelectionName (IndexList (i :| is)) = T.intercalate "," (renderIndex <$> (i : is))+  where+    renderIndex (IndexName n) = n++-- | Get info about known snapshots given a pattern and repo name.+getSnapshots ::+  ( MonadBH m,+    MonadThrow m+  ) =>+  SnapshotRepoName ->+  SnapshotSelection ->+  m (ParsedEsResponse [SnapshotInfo])+getSnapshots (SnapshotRepoName repoName) sel =+  fmap (fmap unSIs) . parseEsResponse =<< get ["_snapshot", repoName, snapPath]+  where+    snapPath = case sel of+      AllSnapshots -> "_all"+      SnapshotList (s :| ss) -> T.intercalate "," (renderPath <$> (s : ss))+    renderPath (SnapPattern t) = t+    renderPath (ExactSnap (SnapshotName t)) = t++newtype SIs = SIs {unSIs :: [SnapshotInfo]}++instance FromJSON SIs where+  parseJSON = withObject "Collection of SnapshotInfo" parse+    where+      parse o = SIs <$> o .: "snapshots"++-- | Delete a snapshot. Cancels if it is running.+deleteSnapshot :: MonadBH m => SnapshotRepoName -> SnapshotName -> m (BHResponse Acknowledged)+deleteSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) =+  delete ["_snapshot", repoName, snapName]++-- | Restore a snapshot to the cluster See+-- <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/modules-snapshots.html#_restore>+-- for more details.+restoreSnapshot ::+  MonadBH m =>+  SnapshotRepoName ->+  SnapshotName ->+  -- | Start with 'defaultSnapshotRestoreSettings' and customize+  -- from there for reasonable defaults.+  SnapshotRestoreSettings ->+  m (BHResponse Accepted)+restoreSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) SnapshotRestoreSettings {..} =+  post endpoint (encode body)+  where+    endpoint = ["_snapshot", repoName, snapName, "_restore"] `withQueries` params+    params = [("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion))]+    body =+      object $+        catMaybes+          [ ("indices" .=) . indexSelectionName <$> snapRestoreIndices,+            Just ("ignore_unavailable" .= snapRestoreIgnoreUnavailable),+            Just ("include_global_state" .= snapRestoreIncludeGlobalState),+            ("rename_pattern" .=) <$> snapRestoreRenamePattern,+            ("rename_replacement" .=) . renderTokens <$> snapRestoreRenameReplacement,+            Just ("include_aliases" .= snapRestoreIncludeAliases),+            ("index_settings" .=) <$> snapRestoreIndexSettingsOverrides,+            ("ignore_index_settings" .=) <$> snapRestoreIgnoreIndexSettings+          ]+    renderTokens (t :| ts) = mconcat (renderToken <$> (t : ts))+    renderToken (RRTLit t) = t+    renderToken RRSubWholeMatch = "$0"+    renderToken (RRSubGroup g) = T.pack (show (rrGroupRefNum g))++getNodesInfo ::+  ( MonadBH m,+    MonadThrow m+  ) =>+  NodeSelection ->+  m (ParsedEsResponse NodesInfo)+getNodesInfo sel =+  parseEsResponse =<< get ["_nodes", selectionSeg]+  where+    selectionSeg = case sel of+      LocalNode -> "_local"+      NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l : ls))+      AllNodes -> "_all"+    selToSeg (NodeByName (NodeName n)) = n+    selToSeg (NodeByFullNodeId (FullNodeId i)) = i+    selToSeg (NodeByHost (Server s)) = s+    selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v++getNodesStats ::+  ( MonadBH m,+    MonadThrow m+  ) =>+  NodeSelection ->+  m (ParsedEsResponse NodesStats)+getNodesStats sel =+  parseEsResponse =<< get ["_nodes", selectionSeg, "stats"]+  where+    selectionSeg = case sel of+      LocalNode -> "_local"+      NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l : ls))+      AllNodes -> "_all"+    selToSeg (NodeByName (NodeName n)) = n+    selToSeg (NodeByFullNodeId (FullNodeId i)) = i+    selToSeg (NodeByHost (Server s)) = s+    selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v++-- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'.+--+-- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")+-- >>> isSuccess response+-- True+-- >>> runBH' $ indexExists (IndexName "didimakeanindex")+-- True+createIndex :: MonadBH m => IndexSettings -> IndexName -> m (BHResponse Acknowledged)+createIndex indexSettings (IndexName indexName) =+  put [indexName] $ encode indexSettings++-- | Create an index, providing it with any number of settings. This+--   is more expressive than 'createIndex' but makes is more verbose+--   for the common case of configuring only the shard count and+--   replica count.+createIndexWith ::+  MonadBH m =>+  [UpdatableIndexSetting] ->+  -- | shard count+  Int ->+  IndexName ->+  m (BHResponse Acknowledged)+createIndexWith updates shards (IndexName indexName) =+  put [indexName] body+  where+    body =+      encode $+        object+          [ "settings"+              .= deepMerge+                ( X.singleton "index.number_of_shards" (toJSON shards) :+                    [u | Object u <- toJSON <$> updates]+                )+          ]++-- | 'flushIndex' will flush an index given a 'Server' and an 'IndexName'.+flushIndex :: MonadBH m => IndexName -> m (BHResponse ShardResult)+flushIndex (IndexName indexName) =+  post [indexName, "_flush"] emptyBody++-- | 'deleteIndex' will delete an index given a 'Server' and an 'IndexName'.+--+-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex")+-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex")+-- >>> isSuccess response+-- True+-- >>> runBH' $ indexExists (IndexName "didimakeanindex")+-- False+deleteIndex :: MonadBH m => IndexName -> m (BHResponse Acknowledged)+deleteIndex (IndexName indexName) =+  delete [indexName]++-- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index+--+-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "unconfiguredindex")+-- >>> response <- runBH' $ updateIndexSettings (BlocksWrite False :| []) (IndexName "unconfiguredindex")+-- >>> isSuccess response+-- True+updateIndexSettings ::+  MonadBH m =>+  NonEmpty UpdatableIndexSetting ->+  IndexName ->+  m (BHResponse Acknowledged)+updateIndexSettings updates (IndexName indexName) =+  put [indexName, "_settings"] (encode body)+  where+    body = Object (deepMerge [u | Object u <- toJSON <$> toList updates])++getIndexSettings ::+  (MonadBH m, MonadThrow m) =>+  IndexName ->+  m (ParsedEsResponse IndexSettingsSummary)+getIndexSettings (IndexName indexName) =+  parseEsResponse =<< get [indexName, "_settings"]++-- | 'forceMergeIndex'+--+-- The force merge API allows to force merging of one or more indices through+-- an API. The merge relates to the number of segments a Lucene index holds+-- within each shard. The force merge operation allows to reduce the number of+-- segments by merging them.+--+-- This call will block until the merge is complete. If the http connection is+-- lost, the request will continue in the background, and any new requests will+-- block until the previous force merge is complete.++-- For more information see+-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-forcemerge.html#indices-forcemerge>.+-- Nothing+-- worthwhile comes back in the response body, so matching on the status+-- should suffice.+--+-- 'forceMergeIndex' 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.+--+-- >>> let ixn = IndexName "unoptimizedindex"+-- >>> _ <- runBH' $ deleteIndex ixn >> createIndex defaultIndexSettings ixn+-- >>> response <- runBH' $ forceMergeIndex (IndexList (ixn :| [])) (defaultIndexOptimizationSettings { maxNumSegments = Just 1, onlyExpungeDeletes = True })+-- >>> isSuccess response+-- True+forceMergeIndex :: MonadBH m => IndexSelection -> ForceMergeIndexSettings -> m (BHResponse ShardCount)+forceMergeIndex ixs ForceMergeIndexSettings {..} =+  post endpoint emptyBody+  where+    endpoint = [indexName, "_forcemerge"] `withQueries` params+    params =+      catMaybes+        [ ("max_num_segments",) . Just . showText <$> maxNumSegments,+          Just ("only_expunge_deletes", Just (boolQP onlyExpungeDeletes)),+          Just ("flush", Just (boolQP flushAfterOptimize))+        ]+    indexName = indexSelectionName ixs++deepMerge :: [Object] -> Object+deepMerge = LS.foldl' (X.unionWith merge) mempty+  where+    merge (Object a) (Object b) = Object (deepMerge [a, b])+    merge _ b = b++doesExist :: MonadBH m => Endpoint -> m Bool+doesExist endpoint =+  isSuccess <$> head endpoint++-- | 'indexExists' enables you to check if an index exists. Returns 'Bool'+--   in IO+--+-- >>> exists <- runBH' $ indexExists testIndex+indexExists :: MonadBH m => IndexName -> m Bool+indexExists (IndexName indexName) =+  doesExist [indexName]++-- | 'refreshIndex' will force a refresh on an index. You must+-- do this if you want to read what you wrote.+--+-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex+-- >>> _ <- runBH' $ refreshIndex testIndex+refreshIndex :: MonadBH m => IndexName -> m (BHResponse ShardResult)+refreshIndex (IndexName indexName) =+  post [indexName, "_refresh"] emptyBody++-- | Block until the index becomes available for indexing+--   documents. This is useful for integration tests in which+--   indices are rapidly created and deleted.+waitForYellowIndex :: MonadBH m => IndexName -> m (BHResponse HealthStatus)+waitForYellowIndex (IndexName indexName) =+  get endpoint+  where+    endpoint = ["_cluster", "health", indexName] `withQueries` params+    params = [("wait_for_status", Just "yellow"), ("timeout", Just "10s")]++data HealthStatus = HealthStatus+  { healthStatusClusterName :: Text,+    healthStatusStatus :: Text,+    healthStatusTimedOut :: Bool,+    healthStatusNumberOfNodes :: Int,+    healthStatusNumberOfDataNodes :: Int,+    healthStatusActivePrimaryShards :: Int,+    healthStatusActiveShards :: Int,+    healthStatusRelocatingShards :: Int,+    healthStatusInitializingShards :: Int,+    healthStatusUnassignedShards :: Int,+    healthStatusDelayedUnassignedShards :: Int,+    healthStatusNumberOfPendingTasks :: Int,+    healthStatusNumberOfInFlightFetch :: Int,+    healthStatusTaskMaxWaitingInQueueMillis :: Int,+    healthStatusActiveShardsPercentAsNumber :: Float+  }+  deriving stock (Eq, Show)++instance FromJSON HealthStatus where+  parseJSON =+    withObject "HealthStatus" $ \v ->+      HealthStatus+        <$> v .: "cluster_name"+        <*> v .: "status"+        <*> v .: "timed_out"+        <*> v .: "number_of_nodes"+        <*> v .: "number_of_data_nodes"+        <*> v .: "active_primary_shards"+        <*> v .: "active_shards"+        <*> v .: "relocating_shards"+        <*> v .: "initializing_shards"+        <*> v .: "unassigned_shards"+        <*> v .: "delayed_unassigned_shards"+        <*> v .: "number_of_pending_tasks"+        <*> v .: "number_of_in_flight_fetch"+        <*> v .: "task_max_waiting_in_queue_millis"+        <*> v .: "active_shards_percent_as_number"++openOrCloseIndexes :: MonadBH m => OpenCloseIndex -> IndexName -> m (BHResponse Acknowledged)+openOrCloseIndexes oci (IndexName indexName) =+  post [indexName, stringifyOCIndex] emptyBody+  where+    stringifyOCIndex = case oci of+      OpenIndex -> "_open"+      CloseIndex -> "_close"++-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at+--   <http://www.elastic.co/guide/en/elasticsearch/reference/current/indices-open-close.html>+--+-- >>> response <- runBH' $ openIndex testIndex+openIndex :: MonadBH m => IndexName -> m (BHResponse Acknowledged)+openIndex = openOrCloseIndexes OpenIndex++-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at+--   <http://www.elastic.co/guide/en/elasticsearch/reference/current/indices-open-close.html>+--+-- >>> response <- runBH' $ closeIndex testIndex+closeIndex :: MonadBH m => IndexName -> m (BHResponse Acknowledged)+closeIndex = openOrCloseIndexes CloseIndex++-- | 'listIndices' returns a list of all index names on a given 'Server'+listIndices :: (MonadThrow m, MonadBH m) => m [IndexName]+listIndices =+  parseEsResponseWith parser =<< get ["_cat/indices?format=json"]+  where+    parser :: [Value] -> Either String [IndexName]+    parser =+      mapM $ \val ->+        case val of+          Object obj ->+            case X.lookup "index" obj of+              (Just (String txt)) -> Right (IndexName txt)+              v -> Left $ "indexVal in listIndices failed on non-string, was: " <> show v+          v -> Left $ "One of the values parsed in listIndices wasn't an object, it was: " <> show v++-- | 'catIndices' returns a list of all index names on a given 'Server' as well as their doc counts+catIndices :: (MonadThrow m, MonadBH m) => m [(IndexName, Int)]+catIndices =+  parseEsResponseWith parser =<< get ["_cat/indices?format=json"]+  where+    parser :: [Value] -> Either String [(IndexName, Int)]+    parser =+      mapM $ \val ->+        case val of+          Object obj ->+            case (X.lookup "index" obj, X.lookup "docs.count" obj) of+              (Just (String txt), Just (String docs)) -> Right (IndexName txt, read (T.unpack docs))+              v -> Left $ "indexVal in catIndices failed on non-string, was: " <> show v+          v -> Left $ "One of the values parsed in catIndices wasn't an object, it was: " <> show v++-- | 'updateIndexAliases' updates the server's index alias+-- table. Operations are atomic. Explained in further detail at+-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-aliases.html>+--+-- >>> let src = IndexName "a-real-index"+-- >>> let aliasName = IndexName "an-alias"+-- >>> let iAlias = IndexAlias src (IndexAliasName aliasName)+-- >>> let aliasCreate = IndexAliasCreate Nothing Nothing+-- >>> _ <- runBH' $ deleteIndex src+-- >>> isSuccess <$> runBH' (createIndex defaultIndexSettings src)+-- True+-- >>> runBH' $ indexExists src+-- True+-- >>> isSuccess <$> runBH' (updateIndexAliases (AddAlias iAlias aliasCreate :| []))+-- True+-- >>> runBH' $ indexExists aliasName+-- True+updateIndexAliases :: MonadBH m => NonEmpty IndexAliasAction -> m (BHResponse Acknowledged)+updateIndexAliases actions =+  post ["_aliases"] (encode body)+  where+    body = object ["actions" .= toList actions]++-- | Get all aliases configured on the server.+getIndexAliases ::+  (MonadBH m, MonadThrow m) =>+  m (ParsedEsResponse IndexAliasesSummary)+getIndexAliases =+  parseEsResponse =<< get ["_aliases"]++-- | Delete a single alias, removing it from all indices it+--   is currently associated with.+deleteIndexAlias :: MonadBH m => IndexAliasName -> m (BHResponse Acknowledged)+deleteIndexAlias (IndexAliasName (IndexName name)) =+  delete ["_all", "_alias", name]++-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'.+--   Explained in further detail at+--   <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html>+--+--   >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]+--   >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")+putTemplate :: MonadBH m => IndexTemplate -> TemplateName -> m (BHResponse Acknowledged)+putTemplate indexTemplate (TemplateName templateName) =+  put ["_template", templateName] (encode indexTemplate)++-- | 'templateExists' checks to see if a template exists.+--+--   >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl")+templateExists :: MonadBH m => TemplateName -> m Bool+templateExists (TemplateName templateName) =+  doesExist ["_template", templateName]++-- | 'deleteTemplate' is an HTTP DELETE and deletes a template.+--+--   >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping]+--   >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl")+--   >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl")+deleteTemplate :: MonadBH m => TemplateName -> m (BHResponse Acknowledged)+deleteTemplate (TemplateName templateName) =+  delete ["_template", templateName]++-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas+-- for documents in indexes.+--+-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex+-- >>> resp <- runBH' $ putMapping testIndex TweetMapping+-- >>> print resp+-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("transfer-encoding","chunked")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}+putMapping :: (MonadBH m, ToJSON a) => IndexName -> a -> m (BHResponse a)+putMapping (IndexName indexName) mapping =+  -- "_mapping" above is originally transposed+  -- erroneously. The correct API call is: "/INDEX/_mapping"+  put [indexName, "_mapping"] (encode mapping)+{-# DEPRECATED putMapping "See <https://www.elastic.co/guide/en/elasticsearch/reference/7.17/removal-of-types.html>" #-}++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 :: DocVersion -> Text -> [(Text, Maybe Text)]+    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+--   primary key for the document. You are encouraged to generate+--   your own id's and not rely on Elasticsearch's automatic id+--   generation. Read more about it here:+--   https://github.com/bitemyapp/bloodhound/issues/107+--+-- >>> resp <- runBH' $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1")+-- >>> print resp+-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("content-length","152")], responseBody = "{\"_index\":\"bloodhound-tests-twitter-1\",\"_type\":\"_doc\",\"_id\":\"1\",\"_version\":2,\"result\":\"updated\",\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\"_seq_no\":1,\"_primary_term\":1}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}+indexDocument ::+  (ToJSON doc, MonadBH m) =>+  IndexName ->+  IndexDocumentSettings ->+  doc ->+  DocId ->+  m (BHResponse IndexedDocument)+indexDocument (IndexName indexName) cfg document (DocId docId) =+  put endpoint (encode body)+  where+    endpoint = [indexName, "_doc", docId] `withQueries` indexQueryString cfg (DocId docId)+    body = encodeDocument cfg document++data IndexedDocument = IndexedDocument+  { idxDocIndex :: Text,+    idxDocType :: Text,+    idxDocId :: Text,+    idxDocVersion :: Int,+    idxDocResult :: Text,+    idxDocShards :: ShardCount,+    idxDocSeqNo :: Int,+    idxDocPrimaryTerm :: Int+  }+  deriving stock (Eq, Show)++instance FromJSON IndexedDocument where+  parseJSON =+    withObject "IndexedDocument" $ \v ->+      IndexedDocument+        <$> v .: "_index"+        <*> v .: "_type"+        <*> v .: "_id"+        <*> v .: "_version"+        <*> v .: "result"+        <*> v .: "_shards"+        <*> v .: "_seq_no"+        <*> v .: "_primary_term"++-- | 'updateDocument' provides a way to perform an partial update of a+-- an already indexed document.+updateDocument ::+  (ToJSON patch, MonadBH m) =>+  IndexName ->+  IndexDocumentSettings ->+  patch ->+  DocId ->+  m (BHResponse IndexedDocument)+updateDocument (IndexName indexName) cfg patch (DocId docId) =+  post endpoint (encode body)+  where+    endpoint = [indexName, "_update", docId] `withQueries` indexQueryString cfg (DocId docId)+    body = object ["doc" .= encodeDocument cfg patch]++{-  From ES docs:+      Parent and child documents must be indexed on the same shard.+      This means that the same routing value needs to be provided when getting, deleting, or updating a child document.++    Parent/Child support in Bloodhound requires MUCH more love.+    To work it around for now (and to support the existing unit test) we route "parent" documents to their "_id"+    (which is the default strategy for the ES), and route all child documents to their parens' "_id"++    However, it may not be flexible enough for some corner cases.++    Buld operations are completely unaware of "routing" and are probably broken in that matter.+    Or perhaps they always were, because the old "_parent" would also have this requirement.+-}+indexQueryString :: IndexDocumentSettings -> DocId -> [(Text, Maybe Text)]+indexQueryString cfg (DocId docId) =+  versionCtlParams cfg <> routeParams+  where+    routeParams = case idsJoinRelation cfg of+      Nothing -> []+      Just (ParentDocument _ _) -> [("routing", Just docId)]+      Just (ChildDocument _ _ (DocId pid)) -> [("routing", Just pid)]++encodeDocument :: ToJSON doc => IndexDocumentSettings -> doc -> Value+encodeDocument cfg document =+  case idsJoinRelation cfg of+    Nothing -> toJSON document+    Just (ParentDocument (FieldName field) name) ->+      mergeObjects (toJSON document) (object [fromText field .= name])+    Just (ChildDocument (FieldName field) name parent) ->+      mergeObjects (toJSON document) (object [fromText field .= object ["name" .= name, "parent" .= parent]])+  where+    mergeObjects (Object a) (Object b) = Object (a <> b)+    mergeObjects _ _ = error "Impossible happened: both document body and join parameters must be objects"++-- | 'deleteDocument' is the primary way to delete a single document.+--+-- >>> _ <- runBH' $ deleteDocument testIndex (DocId "1")+deleteDocument :: MonadBH m => IndexName -> DocId -> m (BHResponse IndexedDocument)+deleteDocument (IndexName indexName) (DocId docId) = delete [indexName, "_doc", docId]++-- | 'deleteByQuery' performs a deletion on every document that matches a query.+--+-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing+-- >>> _ <- runBH' $ deleteDocument testIndex query+deleteByQuery :: MonadBH m => IndexName -> Query -> m (BHResponse DeletedDocuments)+deleteByQuery (IndexName indexName) query =+  post [indexName, "_delete_by_query"] (encode body)+  where+    body = object ["query" .= query]++data DeletedDocuments = DeletedDocuments+  { delDocsTook :: Int,+    delDocsTimedOut :: Bool,+    delDocsTotal :: Int,+    delDocsDeleted :: Int,+    delDocsBatches :: Int,+    delDocsVersionConflicts :: Int,+    delDocsNoops :: Int,+    delDocsRetries :: DeletedDocumentsRetries,+    delDocsThrottledMillis :: Int,+    delDocsRequestsPerSecond :: Float,+    delDocsThrottledUntilMillis :: Int,+    delDocsFailures :: [Value] -- TODO find examples+  }+  deriving stock (Eq, Show)++instance FromJSON DeletedDocuments where+  parseJSON =+    withObject "DeletedDocuments" $ \v ->+      DeletedDocuments+        <$> v .: "took"+        <*> v .: "timed_out"+        <*> v .: "total"+        <*> v .: "deleted"+        <*> v .: "batches"+        <*> v .: "version_conflicts"+        <*> v .: "noops"+        <*> v .: "retries"+        <*> v .: "throttled_millis"+        <*> v .: "requests_per_second"+        <*> v .: "throttled_until_millis"+        <*> v .: "failures"++data DeletedDocumentsRetries = DeletedDocumentsRetries+  { delDocsRetriesBulk :: Int,+    delDocsRetriesSearch :: Int+  }+  deriving stock (Eq, Show)++instance FromJSON DeletedDocumentsRetries where+  parseJSON =+    withObject "DeletedDocumentsRetries" $ \v ->+      DeletedDocumentsRetries+        <$> v .: "bulk"+        <*> v .: "search"++-- | 'bulk' uses+--    <http://www.elastic.co/guide/en/elasticsearch/reference/current/docs-bulk.html Elasticsearch's bulk API>+--    to perform bulk operations. The 'BulkOperation' data type encodes the+--    index\/update\/delete\/create operations. You pass a 'V.Vector' of 'BulkOperation's+--    and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch+--    server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead.+--+-- >>> let stream = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))]+-- >>> _ <- runBH' $ bulk stream+-- >>> _ <- runBH' $ refreshIndex testIndex+bulk :: MonadBH m => V.Vector BulkOperation -> m (BHResponse a)+bulk =+  post ["_bulk"] . encodeBulkOperations++-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation'+--   into an 'L.ByteString'+--+-- >>> let bulkOps = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))]+-- >>> encodeBulkOperations bulkOps+-- "\n{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n"+encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString+encodeBulkOperations stream = collapsed+  where+    blobs =+      fmap encodeBulkOperation stream+    mashedTaters =+      mash (mempty :: Builder) blobs+    collapsed =+      toLazyByteString $ mappend mashedTaters (byteString "\n")+    mash :: Builder -> V.Vector L.ByteString -> Builder+    mash = V.foldl' (\b x -> b <> byteString "\n" <> lazyByteString x)++mkBulkStreamValue :: Text -> Text -> Text -> Value+mkBulkStreamValue operation indexName docId =+  object+    [ fromText operation+        .= object+          [ "_index" .= indexName,+            "_id" .= docId+          ]+    ]++mkBulkStreamValueAuto :: Text -> Text -> Value+mkBulkStreamValueAuto operation indexName =+  object+    [ fromText operation+        .= object ["_index" .= indexName]+    ]++mkBulkStreamValueWithMeta :: [UpsertActionMetadata] -> Text -> Text -> Text -> Value+mkBulkStreamValueWithMeta meta operation indexName docId =+  object+    [ fromText operation+        .= object+          ( [ "_index" .= indexName,+              "_id" .= docId+            ]+              <> (buildUpsertActionMetadata <$> meta)+          )+    ]++-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation'+--   into an 'L.ByteString'+--+-- >>> let bulkOp = BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))+-- >>> encodeBulkOperation bulkOp+-- "{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}"+encodeBulkOperation :: BulkOperation -> L.ByteString+encodeBulkOperation (BulkIndex (IndexName indexName) (DocId docId) value) = blob+  where+    metadata = mkBulkStreamValue "index" indexName docId+    blob = encode metadata `mappend` "\n" `mappend` encode value+encodeBulkOperation (BulkIndexAuto (IndexName indexName) value) = blob+  where+    metadata = mkBulkStreamValueAuto "index" indexName+    blob = encode metadata `mappend` "\n" `mappend` encode value+encodeBulkOperation (BulkIndexEncodingAuto (IndexName indexName) encoding) = toLazyByteString blob+  where+    metadata = toEncoding (mkBulkStreamValueAuto "index" indexName)+    blob = fromEncoding metadata <> "\n" <> fromEncoding encoding+encodeBulkOperation (BulkCreate (IndexName indexName) (DocId docId) value) = blob+  where+    metadata = mkBulkStreamValue "create" indexName docId+    blob = encode metadata `mappend` "\n" `mappend` encode value+encodeBulkOperation (BulkDelete (IndexName indexName) (DocId docId)) = blob+  where+    metadata = mkBulkStreamValue "delete" indexName docId+    blob = encode metadata+encodeBulkOperation (BulkUpdate (IndexName indexName) (DocId docId) value) = blob+  where+    metadata = mkBulkStreamValue "update" indexName docId+    doc = object ["doc" .= value]+    blob = encode metadata `mappend` "\n" `mappend` encode doc+encodeBulkOperation+  ( BulkUpsert+      (IndexName indexName)+      (DocId docId)+      payload+      actionMeta+    ) = blob+    where+      metadata = mkBulkStreamValueWithMeta actionMeta "update" indexName docId+      blob = encode metadata <> "\n" <> encode doc+      doc = case payload of+        UpsertDoc value -> object ["doc" .= value, "doc_as_upsert" .= True]+        UpsertScript scriptedUpsert script value ->+          let scup = if scriptedUpsert then ["scripted_upsert" .= True] else []+              upsert = ["upsert" .= value]+           in case (object (scup <> upsert), toJSON script) of+                (Object obj, Object jscript) -> Object $ jscript <> obj+                _ -> error "Impossible happened: serialising Script to Json should always be Object"+encodeBulkOperation (BulkCreateEncoding (IndexName indexName) (DocId docId) encoding) =+  toLazyByteString blob+  where+    metadata = toEncoding (mkBulkStreamValue "create" indexName docId)+    blob = fromEncoding metadata <> "\n" <> fromEncoding encoding++-- | 'getDocument' is a straight-forward way to fetch a single document from+--   Elasticsearch using a 'Server', 'IndexName', and a 'DocId'.+--   The 'DocId' is the primary key for your Elasticsearch document.+--+-- >>> yourDoc <- runBH' $ getDocument testIndex (DocId "1")+getDocument :: (FromJSON a, MonadBH m) => IndexName -> DocId -> m (BHResponse (EsResult a))+getDocument (IndexName indexName) (DocId docId) =+  get [indexName, "_doc", docId]++-- | 'documentExists' enables you to check if a document exists.+documentExists :: MonadBH m => IndexName -> DocId -> m Bool+documentExists (IndexName indexName) (DocId docId) =+  doesExist [indexName, "_doc", docId]++dispatchSearch :: MonadBH m => Endpoint -> Search -> m (BHResponse (SearchResult a))+dispatchSearch endpoint search = post url' (encode search)+  where+    url' = appendSearchTypeParam endpoint (searchType search)+    appendSearchTypeParam :: Endpoint -> SearchType -> Endpoint+    appendSearchTypeParam originalUrl st = originalUrl `withQueries` params+      where+        stText = "search_type"+        params+          | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")]+          -- used to catch 'SearchTypeQueryThenFetch', which is also the default+          | otherwise = []++-- | 'searchAll', given a 'Search', will perform that search against all indexes+--   on an Elasticsearch server. Try to avoid doing this if it can be helped.+--+-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing+-- >>> let search = mkSearch (Just query) Nothing+-- >>> response <- runBH' $ searchAll search+searchAll :: MonadBH m => Search -> m (BHResponse (SearchResult a))+searchAll = dispatchSearch ["_search"]++-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search+--   within an index on an Elasticsearch server.+--+-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing+-- >>> let search = mkSearch (Just query) Nothing+-- >>> response <- runBH' $ searchByIndex testIndex search+searchByIndex :: MonadBH m => IndexName -> Search -> m (BHResponse (SearchResult a))+searchByIndex (IndexName indexName) = dispatchSearch [indexName, "_search"]++-- | 'searchByIndices' is a variant of 'searchByIndex' that executes a+--   'Search' over many indices. This is much faster than using+--   'mapM' to 'searchByIndex' over a collection since it only+--   causes a single HTTP request to be emitted.+searchByIndices :: MonadBH m => NonEmpty IndexName -> Search -> m (BHResponse (SearchResult a))+searchByIndices ixs = dispatchSearch [renderedIxs, "_search"]+  where+    renderedIxs = T.intercalate (T.singleton ',') (map (\(IndexName t) -> t) (toList ixs))++dispatchSearchTemplate ::+  (FromJSON a, MonadBH m) =>+  Endpoint ->+  SearchTemplate ->+  m (BHResponse (SearchResult a))+dispatchSearchTemplate endpoint search = post endpoint $ encode search++-- | 'searchByIndexTemplate', given a 'SearchTemplate' and an 'IndexName', will perform that search+--   within an index on an Elasticsearch server.+--+-- >>> let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } }, \"size\" : \"{{my_size}}\"}"+-- >>> let search = mkSearchTemplate (Right query) Nothing+-- >>> response <- runBH' $ searchByIndexTemplate testIndex search+searchByIndexTemplate ::+  (FromJSON a, MonadBH m) =>+  IndexName ->+  SearchTemplate ->+  m (BHResponse (SearchResult a))+searchByIndexTemplate (IndexName indexName) = dispatchSearchTemplate [indexName, "_search", "template"]++-- | 'searchByIndicesTemplate' is a variant of 'searchByIndexTemplate' that executes a+--   'SearchTemplate' over many indices. This is much faster than using+--   'mapM' to 'searchByIndexTemplate' over a collection since it only+--   causes a single HTTP request to be emitted.+searchByIndicesTemplate ::+  (FromJSON a, MonadBH m) =>+  NonEmpty IndexName ->+  SearchTemplate ->+  m (BHResponse (SearchResult a))+searchByIndicesTemplate ixs = dispatchSearchTemplate [renderedIxs, "_search", "template"]+  where+    renderedIxs = T.intercalate (T.singleton ',') (map (\(IndexName t) -> t) (toList ixs))++-- | 'storeSearchTemplate', saves a 'SearchTemplateSource' to be used later.+storeSearchTemplate :: MonadBH m => SearchTemplateId -> SearchTemplateSource -> m (BHResponse Acknowledged)+storeSearchTemplate (SearchTemplateId tid) ts =+  post ["_scripts", tid] (encode body)+  where+    body = Object $ X.fromList ["script" .= Object ("lang" .= String "mustache" <> "source" .= ts)]++-- | 'getSearchTemplate', get info of an stored 'SearchTemplateSource'.+getSearchTemplate :: MonadBH m => SearchTemplateId -> m (BHResponse GetTemplateScript)+getSearchTemplate (SearchTemplateId tid) = get ["_scripts", tid]++-- | 'storeSearchTemplate',+deleteSearchTemplate :: MonadBH m => SearchTemplateId -> m (BHResponse Acknowledged)+deleteSearchTemplate (SearchTemplateId tid) = delete ["_scripts", tid]++-- | For a given search, request a scroll for efficient streaming of+-- search results. Note that the search is put into 'SearchTypeScan'+-- mode and thus results will not be sorted. Combine this with+-- 'advanceScroll' to efficiently stream through the full result set+getInitialScroll ::+  (FromJSON a, MonadThrow m, MonadBH m) =>+  IndexName ->+  Search ->+  m (ParsedEsResponse (SearchResult a))+getInitialScroll (IndexName indexName) search' =+  parseEsResponse =<< dispatchSearch endpoint search+  where+    endpoint = [indexName, "_search"] `withQueries` [("scroll", Just "1m")]+    sorting = Just [DefaultSortSpec $ mkSort (FieldName "_doc") Descending]+    search = search' {sortBody = sorting}++-- | For a given search, request a scroll for efficient streaming of+-- search results. Combine this with 'advanceScroll' to efficiently+-- stream through the full result set. Note that this search respects+-- sorting and may be less efficient than 'getInitialScroll'.+getInitialSortedScroll ::+  (FromJSON a, MonadThrow m, MonadBH m) =>+  IndexName ->+  Search ->+  m (ParsedEsResponse (SearchResult a))+getInitialSortedScroll (IndexName indexName) search = do+  parseEsResponse =<< dispatchSearch endpoint search+  where+    endpoint = [indexName, "_search"] `withQueries` [("scroll", Just "1m")]++scroll' ::+  (FromJSON a, MonadBH m, MonadThrow m) =>+  Maybe ScrollId ->+  m ([Hit a], Maybe ScrollId)+scroll' Nothing = return ([], Nothing)+scroll' (Just sid) = do+  res <- advanceScroll sid 60+  case res of+    Right SearchResult {..} -> return (hits searchHits, scrollId)+    Left _ -> return ([], Nothing)++-- | 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,+    MonadThrow m+  ) =>+  ScrollId ->+  -- | How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default.+  NominalDiffTime ->+  m (ParsedEsResponse (SearchResult a))+advanceScroll (ScrollId sid) scroll =+  parseEsResponse =<< post ["_search", "scroll"] (encode scrollObject)+  where+    scrollTime = showText secs <> "s"+    secs :: Integer+    secs = round scroll++    scrollObject =+      object+        [ "scroll" .= scrollTime,+          "scroll_id" .= sid+        ]++scanAccumulator ::+  (FromJSON a, MonadBH m, MonadThrow m) =>+  [Hit a] ->+  ([Hit a], Maybe ScrollId) ->+  m ([Hit a], Maybe ScrollId)+scanAccumulator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing)+scanAccumulator oldHits ([], _) = return (oldHits, Nothing)+scanAccumulator oldHits (newHits, msid) = do+  (newHits', msid') <- scroll' msid+  scanAccumulator (oldHits ++ newHits) (newHits', msid')++-- | 'scanSearch' uses the 'scroll' API of elastic,+-- for a given 'IndexName'. Note that this will+-- consume the entire search result set and will be doing O(n) list+-- appends so this may not be suitable for large result sets. In that+-- case, 'getInitialScroll' and 'advanceScroll' are good low level+-- tools. You should be able to hook them up trivially to conduit,+-- pipes, or your favorite streaming IO abstraction of choice. Note+-- that ordering on the search would destroy performance and thus is+-- ignored.+scanSearch ::+  (FromJSON a, MonadBH m, MonadThrow m) =>+  IndexName ->+  Search ->+  m [Hit a]+scanSearch indexName search = do+  initialSearchResult <- getInitialScroll indexName search+  let (hits', josh) = case initialSearchResult of+        Right SearchResult {..} -> (hits searchHits, scrollId)+        Left _ -> ([], Nothing)+  (totalHits, _) <- scanAccumulator [] (hits', josh)+  return totalHits++pitAccumulator ::+  (FromJSON a, MonadBH m, MonadThrow m) => Search -> [Hit a] -> m [Hit a]+pitAccumulator search oldHits = do+  resp <- searchAll search+  parsed <- parseEsResponse resp+  case parsed of+    Left _ -> return []+    Right searchResult -> case hits (searchHits searchResult) of+      [] -> return oldHits+      newHits -> case (hitSort $ last newHits, pitId searchResult) of+        (Nothing, Nothing) ->+          error "no point in time (PIT) ID or last sort value"+        (Just _, Nothing) -> error "no point in time (PIT) ID"+        (Nothing, _) -> return (oldHits <> newHits)+        (Just lastSort, Just pitId') -> do+          let newSearch =+                search+                  { pointInTime = Just (PointInTime pitId' "1m"),+                    searchAfterKey = Just lastSort+                  }+          pitAccumulator newSearch (oldHits <> newHits)++-- | 'pitSearch' uses the point in time (PIT) API of elastic, for a given+-- 'IndexName'. Requires Elasticsearch >=7.10. Note that this will consume the+-- entire search result set and will be doing O(n) list appends so this may+-- not be suitable for large result sets. In that case, the point in time API+-- should be used directly with `openPointInTime` and `closePointInTime`.+--+-- Note that 'pitSearch' utilizes the 'search_after' parameter under the hood,+-- which requires a non-empty 'sortBody' field in the provided 'Search' value.+-- Otherwise, 'pitSearch' will fail to return all matching documents.+--+-- For more information see+-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/point-in-time-api.html>.+pitSearch ::+  (FromJSON a, MonadBH m, MonadThrow m, Show a) => IndexName -> Search -> m [Hit a]+pitSearch indexName search = do+  openResp <- openPointInTime indexName+  case openResp of+    Left _ -> return []+    Right OpenPointInTimeResponse {..} -> do+      let searchPIT = search {pointInTime = Just (PointInTime oPitId "1m")}+      hits <- pitAccumulator searchPIT []+      closeResp <- closePointInTime (ClosePointInTime oPitId)+      case closeResp of+        Left _ -> return []+        Right (ClosePointInTimeResponse False _) ->+          error "failed to close point in time (PIT)"+        Right (ClosePointInTimeResponse True _) -> return hits++-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search'+--   to Nothing in case you only care about your 'Query' and 'Filter'. Use record update+--   syntax if you want to add things like aggregations or highlights while still using+--   this helper function.+--+-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing+-- >>> mkSearch (Just query) Nothing+-- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, searchAfterKey = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}+mkSearch :: Maybe Query -> Maybe Filter -> Search+mkSearch query filter =+  Search+    { queryBody = query,+      filterBody = filter,+      sortBody = Nothing,+      aggBody = Nothing,+      highlight = Nothing,+      trackSortScores = False,+      from = From 0,+      size = Size 10,+      searchType = SearchTypeQueryThenFetch,+      searchAfterKey = Nothing,+      fields = Nothing,+      scriptFields = Nothing,+      source = Nothing,+      suggestBody = Nothing,+      pointInTime = Nothing+    }++-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for+--   the 'Query' and the 'Aggregation'.+--+-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }+-- >>> terms+-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing})+-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms+mkAggregateSearch :: Maybe Query -> Aggregations -> Search+mkAggregateSearch query mkSearchAggs =+  Search+    { queryBody = query,+      filterBody = Nothing,+      sortBody = Nothing,+      aggBody = Just mkSearchAggs,+      highlight = Nothing,+      trackSortScores = False,+      from = From 0,+      size = Size 0,+      searchType = SearchTypeQueryThenFetch,+      searchAfterKey = Nothing,+      fields = Nothing,+      scriptFields = Nothing,+      source = Nothing,+      suggestBody = Nothing,+      pointInTime = Nothing+    }++-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for+--   the 'Query' and the 'Aggregation'.+--+-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")+-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]+-- >>> let search = mkHighlightSearch (Just query) testHighlight+mkHighlightSearch :: Maybe Query -> Highlights -> Search+mkHighlightSearch query searchHighlights =+  Search+    { queryBody = query,+      filterBody = Nothing,+      sortBody = Nothing,+      aggBody = Nothing,+      highlight = Just searchHighlights,+      trackSortScores = False,+      from = From 0,+      size = Size 10,+      searchType = SearchTypeDfsQueryThenFetch,+      searchAfterKey = Nothing,+      fields = Nothing,+      scriptFields = Nothing,+      source = Nothing,+      suggestBody = Nothing,+      pointInTime = Nothing+    }++-- | 'mkSearchTemplate' is a helper function for defaulting additional fields of a 'SearchTemplate'+--   to Nothing. Use record update syntax if you want to add things.+mkSearchTemplate :: Either SearchTemplateId SearchTemplateSource -> TemplateQueryKeyValuePairs -> SearchTemplate+mkSearchTemplate id_ params = SearchTemplate id_ params Nothing Nothing++-- | 'pageSearch' is a helper function that takes a search and assigns the from+--    and size fields for the search. The from parameter defines the offset+--    from the first result you want to fetch. The size parameter allows you to+--    configure the maximum amount of hits to be returned.+--+-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")+-- >>> let search = mkSearch (Just query) Nothing+-- >>> search+-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}+-- >>> pageSearch (From 10) (Size 100) search+-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing}+pageSearch ::+  -- | The result offset+  From ->+  -- | The number of results to return+  Size ->+  -- | The current seach+  Search ->+  -- | The paged search+  Search+pageSearch resultOffset pageSize search = search {from = resultOffset, size = pageSize}++parseUrl' :: MonadThrow m => Text -> m Request+parseUrl' t = parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack t))++-- | 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++boolQP :: Bool -> Text+boolQP True = "true"+boolQP False = "false"++countByIndex :: (MonadBH m, MonadThrow m) => IndexName -> CountQuery -> m (ParsedEsResponse CountResponse)+countByIndex (IndexName indexName) q =+  parseEsResponse =<< post [indexName, "_count"] (encode q)++-- | 'openPointInTime' opens a point in time for an index given an 'IndexName'.+-- Note that the point in time should be closed with 'closePointInTime' as soon+-- as it is no longer needed.+--+-- For more information see+-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/point-in-time-api.html>.+openPointInTime ::+  (MonadBH m, MonadThrow m) =>+  IndexName ->+  m (ParsedEsResponse OpenPointInTimeResponse)+openPointInTime (IndexName indexName) =+  parseEsResponse =<< post [indexName, "_pit?keep_alive=1m"] emptyBody++-- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'.+--+-- For more information see+-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/point-in-time-api.html>.+closePointInTime ::+  (MonadBH m, MonadThrow m) =>+  ClosePointInTime ->+  m (ParsedEsResponse ClosePointInTimeResponse)+closePointInTime q = do+  parseEsResponse =<< deleteWithBody ["_pit"] (encode q)
src/Database/Bloodhound/Common/Script.hs view
@@ -1,80 +1,88 @@-{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE OverloadedStrings #-}  module Database.Bloodhound.Common.Script where -import           Bloodhound.Import--import           Data.Aeson.KeyMap-import           GHC.Generics--import           Database.Bloodhound.Internal.Newtypes+import Bloodhound.Import+import Data.Aeson.KeyMap+import Database.Bloodhound.Internal.Newtypes+import GHC.Generics -newtype ScriptFields =-  ScriptFields (KeyMap ScriptFieldValue)+newtype ScriptFields+  = ScriptFields (KeyMap ScriptFieldValue)   deriving (Eq, Show)  type ScriptFieldValue = Value -data ScriptSource = ScriptId Text-  | ScriptInline Text deriving (Eq, Show, Generic)+data ScriptSource+  = ScriptId Text+  | ScriptInline Text+  deriving (Eq, Show, Generic) -data Script =-  Script { scriptLanguage :: Maybe ScriptLanguage-         , scriptSource   :: ScriptSource-         , scriptParams   :: Maybe ScriptParams-         } deriving (Eq, Show, Generic)+data Script = Script+  { scriptLanguage :: Maybe ScriptLanguage,+    scriptSource :: ScriptSource,+    scriptParams :: Maybe ScriptParams+  }+  deriving (Eq, Show, Generic) -newtype ScriptLanguage =-  ScriptLanguage Text deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype ScriptLanguage+  = ScriptLanguage Text+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -newtype ScriptParams =-  ScriptParams (KeyMap ScriptParamValue)+newtype ScriptParams+  = ScriptParams (KeyMap ScriptParamValue)   deriving (Eq, Show)  type ScriptParamValue = Value -data BoostMode =-    BoostModeMultiply+data BoostMode+  = BoostModeMultiply   | BoostModeReplace   | BoostModeSum   | BoostModeAvg   | BoostModeMax-  | BoostModeMin deriving (Eq, Show, Generic)+  | BoostModeMin+  deriving (Eq, Show, Generic) -data ScoreMode =-    ScoreModeMultiply+data ScoreMode+  = ScoreModeMultiply   | ScoreModeSum   | ScoreModeAvg   | ScoreModeFirst   | ScoreModeMax-  | ScoreModeMin deriving (Eq, Show, Generic)+  | ScoreModeMin+  deriving (Eq, Show, Generic) -data FunctionScoreFunction =-    FunctionScoreFunctionScript Script+data FunctionScoreFunction+  = FunctionScoreFunctionScript Script   | FunctionScoreFunctionRandom Seed   | FunctionScoreFunctionFieldValueFactor FieldValueFactor   deriving (Eq, Show, Generic) -newtype Weight =-  Weight Float deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype Weight+  = Weight Float+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -newtype Seed =-  Seed Float deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype Seed+  = Seed Float+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -data FieldValueFactor =-  FieldValueFactor { fieldValueFactorField    :: FieldName-                   , fieldValueFactor         :: Maybe Factor-                   , fieldValueFactorModifier :: Maybe FactorModifier-                   , fieldValueFactorMissing  :: Maybe FactorMissingFieldValue-                   } deriving (Eq, Show, Generic)+data FieldValueFactor = FieldValueFactor+  { fieldValueFactorField :: FieldName,+    fieldValueFactor :: Maybe Factor,+    fieldValueFactorModifier :: Maybe FactorModifier,+    fieldValueFactorMissing :: Maybe FactorMissingFieldValue+  }+  deriving (Eq, Show, Generic) -newtype Factor =-  Factor Float deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype Factor+  = Factor Float+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -data FactorModifier =-  FactorModifierNone+data FactorModifier+  = FactorModifierNone   | FactorModifierLog   | FactorModifierLog1p   | FactorModifierLog2p@@ -83,75 +91,80 @@   | FactorModifierLn2p   | FactorModifierSquare   | FactorModifierSqrt-  | FactorModifierReciprocal deriving (Eq, Show, Generic)+  | FactorModifierReciprocal+  deriving (Eq, Show, Generic) -newtype FactorMissingFieldValue =-  FactorMissingFieldValue Float deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype FactorMissingFieldValue+  = FactorMissingFieldValue Float+  deriving (Eq, Show, Generic, FromJSON, ToJSON)  instance ToJSON BoostMode where   toJSON BoostModeMultiply = "multiply"-  toJSON BoostModeReplace  = "replace"-  toJSON BoostModeSum      = "sum"-  toJSON BoostModeAvg      = "avg"-  toJSON BoostModeMax      = "max"-  toJSON BoostModeMin      = "min"+  toJSON BoostModeReplace = "replace"+  toJSON BoostModeSum = "sum"+  toJSON BoostModeAvg = "avg"+  toJSON BoostModeMax = "max"+  toJSON BoostModeMin = "min"  instance FromJSON BoostMode where   parseJSON = withText "BoostMode" parse-    where parse "multiply" = pure BoostModeMultiply-          parse "replace"  = pure BoostModeReplace-          parse "sum"      = pure BoostModeSum-          parse "avg"      = pure BoostModeAvg-          parse "max"      = pure BoostModeMax-          parse "min"      = pure BoostModeMin-          parse bm         = fail ("Unexpected BoostMode: " <> show bm)+    where+      parse "multiply" = pure BoostModeMultiply+      parse "replace" = pure BoostModeReplace+      parse "sum" = pure BoostModeSum+      parse "avg" = pure BoostModeAvg+      parse "max" = pure BoostModeMax+      parse "min" = pure BoostModeMin+      parse bm = fail ("Unexpected BoostMode: " <> show bm)  instance ToJSON ScoreMode where   toJSON ScoreModeMultiply = "multiply"-  toJSON ScoreModeSum      = "sum"-  toJSON ScoreModeFirst    = "first"-  toJSON ScoreModeAvg      = "avg"-  toJSON ScoreModeMax      = "max"-  toJSON ScoreModeMin      = "min"+  toJSON ScoreModeSum = "sum"+  toJSON ScoreModeFirst = "first"+  toJSON ScoreModeAvg = "avg"+  toJSON ScoreModeMax = "max"+  toJSON ScoreModeMin = "min"  instance FromJSON ScoreMode where   parseJSON = withText "ScoreMode" parse-    where parse "multiply" = pure ScoreModeMultiply-          parse "sum"      = pure ScoreModeSum-          parse "first"    = pure ScoreModeFirst-          parse "avg"      = pure ScoreModeAvg-          parse "max"      = pure ScoreModeMax-          parse "min"      = pure ScoreModeMin-          parse sm         = fail ("Unexpected ScoreMode: " <> show sm)+    where+      parse "multiply" = pure ScoreModeMultiply+      parse "sum" = pure ScoreModeSum+      parse "first" = pure ScoreModeFirst+      parse "avg" = pure ScoreModeAvg+      parse "max" = pure ScoreModeMax+      parse "min" = pure ScoreModeMin+      parse sm = fail ("Unexpected ScoreMode: " <> show sm)  functionScoreFunctionPair :: FunctionScoreFunction -> (Key, Value) functionScoreFunctionPair (FunctionScoreFunctionScript functionScoreScript) =   ("script_score", toJSON functionScoreScript) functionScoreFunctionPair (FunctionScoreFunctionRandom seed) =-  ("random_score", omitNulls [ "seed" .= seed ])+  ("random_score", omitNulls ["seed" .= seed]) functionScoreFunctionPair (FunctionScoreFunctionFieldValueFactor fvf) =   ("field_value_factor", toJSON fvf)  parseFunctionScoreFunction :: Object -> Parser FunctionScoreFunction parseFunctionScoreFunction o =   singleScript `taggedWith` "script_score"-  <|> singleRandom `taggedWith` "random_score"-  <|> singleFieldValueFactor `taggedWith` "field_value_factor"-  where taggedWith parser k = parser =<< o .: k-        singleScript = pure . FunctionScoreFunctionScript-        singleRandom o' = FunctionScoreFunctionRandom <$> o' .: "seed"-        singleFieldValueFactor = pure . FunctionScoreFunctionFieldValueFactor+    <|> singleRandom `taggedWith` "random_score"+    <|> singleFieldValueFactor `taggedWith` "field_value_factor"+  where+    taggedWith parser k = parser =<< o .: k+    singleScript = pure . FunctionScoreFunctionScript+    singleRandom o' = FunctionScoreFunctionRandom <$> o' .: "seed"+    singleFieldValueFactor = pure . FunctionScoreFunctionFieldValueFactor  instance ToJSON ScriptFields where   toJSON (ScriptFields x) = Object x  instance FromJSON ScriptFields where   parseJSON (Object o) = pure (ScriptFields o)-  parseJSON _          = fail "error parsing ScriptFields"+  parseJSON _ = fail "error parsing ScriptFields"  instance ToJSON Script where   toJSON script =-    object [ "script" .= omitNulls (base script) ]+    object ["script" .= omitNulls (base script)]     where       base (Script lang (ScriptInline source) params) =         ["lang" .= lang, "source" .= source, "params" .= params]@@ -160,65 +173,73 @@  instance FromJSON Script where   parseJSON = withObject "Script" parse-    where +    where       parseSource o = do         inline <- o .:? "source"         id_ <- o .:? "id"-        return $ case (inline,id_) of-          (Just x,Nothing) -> ScriptInline x-          (Nothing,Just x) -> ScriptId x-          (Nothing,Nothing) -> error "Script has to be either stored or inlined"-          (Just _,Just _) -> error "Script can't both be stored and inlined at the same time"-      parse o = o .: "script" >>= \o' -> Script-        <$> o' .:? "lang"-        <*> parseSource o'-        <*> o' .:? "params"+        return $ case (inline, id_) of+          (Just x, Nothing) -> ScriptInline x+          (Nothing, Just x) -> ScriptId x+          (Nothing, Nothing) -> error "Script has to be either stored or inlined"+          (Just _, Just _) -> error "Script can't both be stored and inlined at the same time"+      parse o =+        o .: "script" >>= \o' ->+          Script+            <$> o' .:? "lang"+            <*> parseSource o'+            <*> o' .:? "params"  instance ToJSON ScriptParams where   toJSON (ScriptParams x) = Object x  instance FromJSON ScriptParams where   parseJSON (Object o) = pure (ScriptParams o)-  parseJSON _          = fail "error parsing ScriptParams"+  parseJSON _ = fail "error parsing ScriptParams"  instance ToJSON FieldValueFactor where   toJSON (FieldValueFactor field factor modifier missing) =     omitNulls base-    where base = [ "field"    .= field-                 , "factor"   .= factor-                 , "modifier" .= modifier-                 , "missing"  .= missing ]+    where+      base =+        [ "field" .= field,+          "factor" .= factor,+          "modifier" .= modifier,+          "missing" .= missing+        ]  instance FromJSON FieldValueFactor where   parseJSON = withObject "FieldValueFactor" parse-    where parse o = FieldValueFactor-                    <$> o .: "field"-                    <*> o .:? "factor"-                    <*> o .:? "modifier"-                    <*> o .:? "missing"+    where+      parse o =+        FieldValueFactor+          <$> o .: "field"+          <*> o .:? "factor"+          <*> o .:? "modifier"+          <*> o .:? "missing"  instance ToJSON FactorModifier where-  toJSON FactorModifierNone       = "none"-  toJSON FactorModifierLog        = "log"-  toJSON FactorModifierLog1p      = "log1p"-  toJSON FactorModifierLog2p      = "log2p"-  toJSON FactorModifierLn         = "ln"-  toJSON FactorModifierLn1p       = "ln1p"-  toJSON FactorModifierLn2p       = "ln2p"-  toJSON FactorModifierSquare     = "square"-  toJSON FactorModifierSqrt       = "sqrt"+  toJSON FactorModifierNone = "none"+  toJSON FactorModifierLog = "log"+  toJSON FactorModifierLog1p = "log1p"+  toJSON FactorModifierLog2p = "log2p"+  toJSON FactorModifierLn = "ln"+  toJSON FactorModifierLn1p = "ln1p"+  toJSON FactorModifierLn2p = "ln2p"+  toJSON FactorModifierSquare = "square"+  toJSON FactorModifierSqrt = "sqrt"   toJSON FactorModifierReciprocal = "reciprocal"  instance FromJSON FactorModifier where   parseJSON = withText "FactorModifier" parse-    where parse "none"       = pure FactorModifierNone-          parse "log"        = pure FactorModifierLog-          parse "log1p"      = pure FactorModifierLog1p-          parse "log2p"      = pure FactorModifierLog2p-          parse "ln"         = pure FactorModifierLn-          parse "ln1p"       = pure FactorModifierLn1p-          parse "ln2p"       = pure FactorModifierLn2p-          parse "square"     = pure FactorModifierSquare-          parse "sqrt"       = pure FactorModifierSqrt-          parse "reciprocal" = pure FactorModifierReciprocal-          parse fm           = fail ("Unexpected FactorModifier: " <> show fm)+    where+      parse "none" = pure FactorModifierNone+      parse "log" = pure FactorModifierLog+      parse "log1p" = pure FactorModifierLog1p+      parse "log2p" = pure FactorModifierLog2p+      parse "ln" = pure FactorModifierLn+      parse "ln1p" = pure FactorModifierLn1p+      parse "ln2p" = pure FactorModifierLn2p+      parse "square" = pure FactorModifierSquare+      parse "sqrt" = pure FactorModifierSqrt+      parse "reciprocal" = pure FactorModifierReciprocal+      parse fm = fail ("Unexpected FactorModifier: " <> show fm)
src/Database/Bloodhound/Internal/Aggregation.hs view
@@ -1,21 +1,19 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Database.Bloodhound.Internal.Aggregation where -import           Bloodhound.Import-+import Bloodhound.Import import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as X import qualified Data.Map.Strict as M import qualified Data.Text as T--import           Database.Bloodhound.Internal.Client-import           Database.Bloodhound.Internal.Highlight (HitHighlight)-import           Database.Bloodhound.Internal.Newtypes-import           Database.Bloodhound.Internal.Query-import           Database.Bloodhound.Internal.Sort+import Database.Bloodhound.Internal.Client+import Database.Bloodhound.Internal.Highlight (HitHighlight)+import Database.Bloodhound.Internal.Newtypes+import Database.Bloodhound.Internal.Query+import Database.Bloodhound.Internal.Sort  type Aggregations = M.Map Key Aggregation @@ -25,161 +23,196 @@ mkAggregations :: Key -> Aggregation -> Aggregations mkAggregations name aggregation = M.insert name aggregation emptyAggregations -data Aggregation = TermsAgg TermsAggregation-                 | CardinalityAgg CardinalityAggregation-                 | DateHistogramAgg DateHistogramAggregation-                 | ValueCountAgg ValueCountAggregation-                 | FilterAgg FilterAggregation-                 | DateRangeAgg DateRangeAggregation-                 | MissingAgg MissingAggregation-                 | TopHitsAgg TopHitsAggregation-                 | StatsAgg StatisticsAggregation-                 | SumAgg SumAggregation+data Aggregation+  = TermsAgg TermsAggregation+  | CardinalityAgg CardinalityAggregation+  | DateHistogramAgg DateHistogramAggregation+  | ValueCountAgg ValueCountAggregation+  | FilterAgg FilterAggregation+  | DateRangeAgg DateRangeAggregation+  | MissingAgg MissingAggregation+  | TopHitsAgg TopHitsAggregation+  | StatsAgg StatisticsAggregation+  | SumAgg SumAggregation   deriving (Eq, Show)  instance ToJSON Aggregation where   toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) =-    omitNulls ["terms" .= omitNulls [ toJSON' term,-                                      "include"        .= include,-                                      "exclude"        .= exclude,-                                      "order"          .= order,-                                      "min_doc_count"  .= minDocCount,-                                      "size"           .= size,-                                      "shard_size"     .= shardSize,-                                      "collect_mode"   .= collectMode,-                                      "execution_hint" .= executionHint-                                    ],-               "aggs"  .= termAggs ]+    omitNulls+      [ "terms"+          .= omitNulls+            [ toJSON' term,+              "include" .= include,+              "exclude" .= exclude,+              "order" .= order,+              "min_doc_count" .= minDocCount,+              "size" .= size,+              "shard_size" .= shardSize,+              "collect_mode" .= collectMode,+              "execution_hint" .= executionHint+            ],+        "aggs" .= termAggs+      ]     where-      toJSON' x = case x of { Left y -> "field" .= y;  Right y -> "script" .= y }-+      toJSON' x = case x of Left y -> "field" .= y; Right y -> "script" .= y   toJSON (CardinalityAgg (CardinalityAggregation field precisionThreshold)) =-    object ["cardinality" .= omitNulls [ "field"              .= field,-                                         "precisionThreshold" .= precisionThreshold-                                       ]-           ]--  toJSON (DateHistogramAgg-          (DateHistogramAggregation field interval format-           preZone postZone preOffset postOffset dateHistoAggs)) =-    omitNulls ["date_histogram" .= omitNulls [ "field"       .= field,-                                               "interval"    .= interval,-                                               "format"      .= format,-                                               "pre_zone"    .= preZone,-                                               "post_zone"   .= postZone,-                                               "pre_offset"  .= preOffset,-                                               "post_offset" .= postOffset-                                             ],-               "aggs"           .= dateHistoAggs ]+    object+      [ "cardinality"+          .= omitNulls+            [ "field" .= field,+              "precisionThreshold" .= precisionThreshold+            ]+      ]+  toJSON+    ( DateHistogramAgg+        ( DateHistogramAggregation+            field+            interval+            format+            preZone+            postZone+            preOffset+            postOffset+            dateHistoAggs+          )+      ) =+      omitNulls+        [ "date_histogram"+            .= omitNulls+              [ "field" .= field,+                "interval" .= interval,+                "format" .= format,+                "pre_zone" .= preZone,+                "post_zone" .= postZone,+                "pre_offset" .= preOffset,+                "post_offset" .= postOffset+              ],+          "aggs" .= dateHistoAggs+        ]   toJSON (ValueCountAgg a) = object ["value_count" .= v]-    where v = case a of-                (FieldValueCount (FieldName n)) ->-                  object ["field" .= n]-                (ScriptValueCount s) ->-                  object ["script" .= s]+    where+      v = case a of+        (FieldValueCount (FieldName n)) ->+          object ["field" .= n]+        (ScriptValueCount s) ->+          object ["script" .= s]   toJSON (FilterAgg (FilterAggregation filt ags)) =-    omitNulls [ "filter" .= filt-              , "aggs" .= ags]-  toJSON (DateRangeAgg a) = object [ "date_range" .= a-                                   ]-  toJSON (MissingAgg (MissingAggregation{..})) =+    omitNulls+      [ "filter" .= filt,+        "aggs" .= ags+      ]+  toJSON (DateRangeAgg a) =+    object+      [ "date_range" .= a+      ]+  toJSON (MissingAgg (MissingAggregation {..})) =     object ["missing" .= object ["field" .= maField]]-   toJSON (TopHitsAgg (TopHitsAggregation mfrom msize msort)) =-    omitNulls ["top_hits" .= omitNulls [ "size" .= msize-                                       , "from" .= mfrom-                                       , "sort" .= msort-                                       ]-              ]-+    omitNulls+      [ "top_hits"+          .= omitNulls+            [ "size" .= msize,+              "from" .= mfrom,+              "sort" .= msort+            ]+      ]   toJSON (StatsAgg (StatisticsAggregation typ field)) =-    object [stType .= omitNulls [ "field" .= field ]]+    object [stType .= omitNulls ["field" .= field]]     where-      stType | typ == Basic = "stats"-             | otherwise = "extended_stats"-+      stType+        | typ == Basic = "stats"+        | otherwise = "extended_stats"   toJSON (SumAgg (SumAggregation (FieldName n))) =-    omitNulls ["sum" .= omitNulls [ "field" .= n ] ]+    omitNulls ["sum" .= omitNulls ["field" .= n]]  data TopHitsAggregation = TopHitsAggregation-  { taFrom :: Maybe From-  , taSize :: Maybe Size-  , taSort :: Maybe Sort-  } deriving (Eq, Show)+  { taFrom :: Maybe From,+    taSize :: Maybe Size,+    taSort :: Maybe Sort+  }+  deriving (Eq, Show)  data MissingAggregation = MissingAggregation   { maField :: Text-  } deriving (Eq, Show)+  }+  deriving (Eq, Show)  data TermsAggregation = TermsAggregation-  { term              :: Either Text Text-  , termInclude       :: Maybe TermInclusion-  , termExclude       :: Maybe TermInclusion-  , termOrder         :: Maybe TermOrder-  , termMinDocCount   :: Maybe Int-  , termSize          :: Maybe Int-  , termShardSize     :: Maybe Int-  , termCollectMode   :: Maybe CollectionMode-  , termExecutionHint :: Maybe ExecutionHint-  , termAggs          :: Maybe Aggregations-  } deriving (Eq, Show)+  { term :: Either Text Text,+    termInclude :: Maybe TermInclusion,+    termExclude :: Maybe TermInclusion,+    termOrder :: Maybe TermOrder,+    termMinDocCount :: Maybe Int,+    termSize :: Maybe Int,+    termShardSize :: Maybe Int,+    termCollectMode :: Maybe CollectionMode,+    termExecutionHint :: Maybe ExecutionHint,+    termAggs :: Maybe Aggregations+  }+  deriving (Eq, Show)  data CardinalityAggregation = CardinalityAggregation-  { cardinalityField   :: FieldName,+  { cardinalityField :: FieldName,     precisionThreshold :: Maybe Int-  } deriving (Eq, Show)+  }+  deriving (Eq, Show)  data DateHistogramAggregation = DateHistogramAggregation-  { dateField      :: FieldName-  , dateInterval   :: Interval-  , dateFormat     :: Maybe Text+  { dateField :: FieldName,+    dateInterval :: Interval,+    dateFormat :: Maybe Text,     -- pre and post deprecated in 1.5-  , datePreZone    :: Maybe Text-  , datePostZone   :: Maybe Text-  , datePreOffset  :: Maybe Text-  , datePostOffset :: Maybe Text-  , dateAggs       :: Maybe Aggregations-  } deriving (Eq, Show)+    datePreZone :: Maybe Text,+    datePostZone :: Maybe Text,+    datePreOffset :: Maybe Text,+    datePostOffset :: Maybe Text,+    dateAggs :: Maybe Aggregations+  }+  deriving (Eq, Show)  data DateRangeAggregation = DateRangeAggregation-  { draField  :: FieldName-  , draFormat :: Maybe Text-  , draRanges :: NonEmpty DateRangeAggRange-  } deriving (Eq, Show)+  { draField :: FieldName,+    draFormat :: Maybe Text,+    draRanges :: NonEmpty DateRangeAggRange+  }+  deriving (Eq, Show)  instance ToJSON DateRangeAggregation where   toJSON DateRangeAggregation {..} =-    omitNulls [ "field" .= draField-              , "format" .= draFormat-              , "ranges" .= toList draRanges-              ]+    omitNulls+      [ "field" .= draField,+        "format" .= draFormat,+        "ranges" .= toList draRanges+      ] -data DateRangeAggRange =-    DateRangeFrom DateMathExpr+data DateRangeAggRange+  = DateRangeFrom DateMathExpr   | DateRangeTo DateMathExpr   | DateRangeFromAndTo DateMathExpr DateMathExpr   deriving (Eq, Show)  instance ToJSON DateRangeAggRange where-  toJSON (DateRangeFrom e)        = object [ "from" .= e ]-  toJSON (DateRangeTo e)          = object [ "to" .= e ]-  toJSON (DateRangeFromAndTo f t) = object [ "from" .= f, "to" .= t ]+  toJSON (DateRangeFrom e) = object ["from" .= e]+  toJSON (DateRangeTo e) = object ["to" .= e]+  toJSON (DateRangeFromAndTo f t) = object ["from" .= f, "to" .= t]  -- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-metrics-valuecount-aggregation.html> for more information.-data ValueCountAggregation =-    FieldValueCount FieldName+data ValueCountAggregation+  = FieldValueCount FieldName   | ScriptValueCount Script   deriving (Eq, Show)  -- | Single-bucket filter aggregations. See <https://www.elastic.co/guide/en/elasticsearch/reference/current/search-aggregations-bucket-filter-aggregation.html#search-aggregations-bucket-filter-aggregation> for more information. data FilterAggregation = FilterAggregation-  { faFilter :: Filter-  , faAggs   :: Maybe Aggregations }+  { faFilter :: Filter,+    faAggs :: Maybe Aggregations+  }   deriving (Eq, Show)  data StatisticsAggregation = StatisticsAggregation-  { statsType :: StatsType-  , statsField :: FieldName }+  { statsType :: StatsType,+    statsField :: FieldName+  }   deriving (Eq, Show)  data StatsType@@ -187,13 +220,22 @@   | Extended   deriving (Eq, Show) -newtype SumAggregation = SumAggregation { sumAggregationField :: FieldName }+newtype SumAggregation = SumAggregation {sumAggregationField :: FieldName}   deriving (Eq, Show)  mkTermsAggregation :: Text -> TermsAggregation mkTermsAggregation t =-  TermsAggregation (Left t)-  Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+  TermsAggregation+    (Left t)+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing  mkTermsScriptAggregation :: Text -> TermsAggregation mkTermsScriptAggregation t = TermsAggregation (Right t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing@@ -219,88 +261,103 @@  data Bucket a = Bucket   { buckets :: [a]-  } deriving (Read, Show)+  }+  deriving (Read, Show)  instance (FromJSON a) => FromJSON (Bucket a) where-  parseJSON (Object v) = Bucket <$>-                         v .: "buckets"+  parseJSON (Object v) =+    Bucket+      <$> v .: "buckets"   parseJSON _ = mempty -data BucketValue = TextValue Text-                 | ScientificValue Scientific-                 | BoolValue Bool deriving (Read, Show)+data BucketValue+  = TextValue Text+  | ScientificValue Scientific+  | BoolValue Bool+  deriving (Read, Show)  instance FromJSON BucketValue where   parseJSON (String t) = return $ TextValue t   parseJSON (Number s) = return $ ScientificValue s-  parseJSON (Bool b)   = return $ BoolValue b-  parseJSON _          = mempty+  parseJSON (Bool b) = return $ BoolValue b+  parseJSON _ = mempty -data TermInclusion = TermInclusion Text-                   | TermPattern Text Text deriving (Eq, Show)+data TermInclusion+  = TermInclusion Text+  | TermPattern Text Text+  deriving (Eq, Show)  instance ToJSON TermInclusion where   toJSON (TermInclusion x) = toJSON x   toJSON (TermPattern pattern flags) =-    omitNulls [ "pattern" .= pattern-              , "flags"   .= flags]+    omitNulls+      [ "pattern" .= pattern,+        "flags" .= flags+      ]  data TermOrder = TermOrder-  { termSortField :: Text-  , termSortOrder :: SortOrder } deriving (Eq, Show)+  { termSortField :: Text,+    termSortOrder :: SortOrder+  }+  deriving (Eq, Show)  instance ToJSON TermOrder where   toJSON (TermOrder termSortField termSortOrder) =     object [fromText termSortField .= termSortOrder] -data CollectionMode = BreadthFirst-                    | DepthFirst deriving (Eq, Show)+data CollectionMode+  = BreadthFirst+  | DepthFirst+  deriving (Eq, Show)  instance ToJSON CollectionMode where   toJSON BreadthFirst = "breadth_first"-  toJSON DepthFirst   = "depth_first"+  toJSON DepthFirst = "depth_first" -data ExecutionHint = GlobalOrdinals-                   | Map deriving (Eq, Show)+data ExecutionHint+  = GlobalOrdinals+  | Map+  deriving (Eq, Show)  instance ToJSON ExecutionHint where-  toJSON GlobalOrdinals               = "global_ordinals"-  toJSON Map                          = "map"+  toJSON GlobalOrdinals = "global_ordinals"+  toJSON Map = "map"  -- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#date-math> for more information.-data DateMathExpr =-  DateMathExpr DateMathAnchor [DateMathModifier]+data DateMathExpr+  = DateMathExpr DateMathAnchor [DateMathModifier]   deriving (Eq, Show)  instance ToJSON DateMathExpr where   toJSON (DateMathExpr a mods) = String (fmtA a <> mconcat (fmtMod <$> mods))-    where fmtA DMNow         = "now"-          fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"-          fmtMod (AddTime n u)      = "+" <> showText n <> fmtU u-          fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u-          fmtMod (RoundDownTo u)    = "/" <> fmtU u-          fmtU DMYear   = "y"-          fmtU DMMonth  = "M"-          fmtU DMWeek   = "w"-          fmtU DMDay    = "d"-          fmtU DMHour   = "h"-          fmtU DMMinute = "m"-          fmtU DMSecond = "s"+    where+      fmtA DMNow = "now"+      fmtA (DMDate date) = (T.pack $ showGregorian date) <> "||"+      fmtMod (AddTime n u) = "+" <> showText n <> fmtU u+      fmtMod (SubtractTime n u) = "-" <> showText n <> fmtU u+      fmtMod (RoundDownTo u) = "/" <> fmtU u+      fmtU DMYear = "y"+      fmtU DMMonth = "M"+      fmtU DMWeek = "w"+      fmtU DMDay = "d"+      fmtU DMHour = "h"+      fmtU DMMinute = "m"+      fmtU DMSecond = "s"  -- | Starting point for a date range. This along with the 'DateMathModifiers' gets you the date ES will start from.-data DateMathAnchor =-    DMNow+data DateMathAnchor+  = DMNow   | DMDate Day   deriving (Eq, Show) -data DateMathModifier =-    AddTime Int DateMathUnit+data DateMathModifier+  = AddTime Int DateMathUnit   | SubtractTime Int DateMathUnit   | RoundDownTo DateMathUnit   deriving (Eq, Show) -data DateMathUnit =-    DMYear+data DateMathUnit+  = DMYear   | DMMonth   | DMWeek   | DMDay@@ -310,16 +367,18 @@   deriving (Eq, Show)  data TermsResult = TermsResult-  { termKey       :: BucketValue-  , termsDocCount :: Int-  , termsAggs     :: Maybe AggregationResults-  } deriving (Read, Show)+  { termKey :: BucketValue,+    termsDocCount :: Int,+    termsAggs :: Maybe AggregationResults+  }+  deriving (Read, Show)  instance FromJSON TermsResult where-  parseJSON (Object v) = TermsResult        <$>-                         v .:   "key"       <*>-                         v .:   "doc_count" <*>-                         (pure $ getNamedSubAgg v ["key", "doc_count"])+  parseJSON (Object v) =+    TermsResult+      <$> v .: "key"+      <*> v .: "doc_count"+      <*> (pure $ getNamedSubAgg v ["key", "doc_count"])   parseJSON _ = mempty  instance BucketAggregation TermsResult where@@ -328,22 +387,27 @@   aggs = termsAggs  data DateHistogramResult = DateHistogramResult-  { dateKey           :: Int-  , dateKeyStr        :: Maybe Text-  , dateDocCount      :: Int-  , dateHistogramAggs :: Maybe AggregationResults-  } deriving (Show)+  { dateKey :: Int,+    dateKeyStr :: Maybe Text,+    dateDocCount :: Int,+    dateHistogramAggs :: Maybe AggregationResults+  }+  deriving (Show)  instance FromJSON DateHistogramResult where-  parseJSON (Object v) = DateHistogramResult   <$>-                         v .:  "key"           <*>-                         v .:? "key_as_string" <*>-                         v .:  "doc_count"     <*>-                         (pure $ getNamedSubAgg v [ "key"-                                                  , "doc_count"-                                                  , "key_as_string"-                                                  ]-                         )+  parseJSON (Object v) =+    DateHistogramResult+      <$> v .: "key"+      <*> v .:? "key_as_string"+      <*> v .: "doc_count"+      <*> ( pure $+              getNamedSubAgg+                v+                [ "key",+                  "doc_count",+                  "key_as_string"+                ]+          )   parseJSON _ = mempty  instance BucketAggregation DateHistogramResult where@@ -352,32 +416,38 @@   aggs = dateHistogramAggs  data DateRangeResult = DateRangeResult-  { dateRangeKey          :: Text-  , dateRangeFrom         :: Maybe UTCTime-  , dateRangeFromAsString :: Maybe Text-  , dateRangeTo           :: Maybe UTCTime-  , dateRangeToAsString   :: Maybe Text-  , dateRangeDocCount     :: Int-  , dateRangeAggs         :: Maybe AggregationResults-  } deriving (Eq, Show)+  { dateRangeKey :: Text,+    dateRangeFrom :: Maybe UTCTime,+    dateRangeFromAsString :: Maybe Text,+    dateRangeTo :: Maybe UTCTime,+    dateRangeToAsString :: Maybe Text,+    dateRangeDocCount :: Int,+    dateRangeAggs :: Maybe AggregationResults+  }+  deriving (Eq, Show)  instance FromJSON DateRangeResult where   parseJSON = withObject "DateRangeResult" parse-    where parse v = DateRangeResult                 <$>-                    v .:  "key"                     <*>-                    (fmap posixMS <$> v .:? "from") <*>-                    v .:? "from_as_string"          <*>-                    (fmap posixMS <$> v .:? "to")   <*>-                    v .:? "to_as_string"            <*>-                    v .:  "doc_count"               <*>-                    (pure $ getNamedSubAgg v [ "key"-                                             , "from"-                                             , "from_as_string"-                                             , "to"-                                             , "to_as_string"-                                             , "doc_count"-                                             ]-                    )+    where+      parse v =+        DateRangeResult+          <$> v .: "key"+          <*> (fmap posixMS <$> v .:? "from")+          <*> v .:? "from_as_string"+          <*> (fmap posixMS <$> v .:? "to")+          <*> v .:? "to_as_string"+          <*> v .: "doc_count"+          <*> ( pure $+                  getNamedSubAgg+                    v+                    [ "key",+                      "from",+                      "from_as_string",+                      "to",+                      "to_as_string",+                      "doc_count"+                    ]+              )  instance BucketAggregation DateRangeResult where   key = TextValue . dateRangeKey@@ -398,67 +468,79 @@  toAggResult :: (FromJSON a) => Key -> AggregationResults -> Maybe a toAggResult t a = M.lookup t a >>= deserialize-  where deserialize = parseMaybe parseJSON+  where+    deserialize = parseMaybe parseJSON  -- Try to get an AggregationResults when we don't know the -- field name. We filter out the known keys to try to minimize the noise. getNamedSubAgg :: Object -> [Key] -> Maybe AggregationResults getNamedSubAgg o knownKeys = maggRes-  where unknownKeys = X.filterWithKey (\k _ -> k `notElem` knownKeys) o-        maggRes-          | X.null unknownKeys = Nothing-          | otherwise           = Just . M.fromList $ X.toList unknownKeys+  where+    unknownKeys = X.filterWithKey (\k _ -> k `notElem` knownKeys) o+    maggRes+      | X.null unknownKeys = Nothing+      | otherwise = Just . M.fromList $ X.toList unknownKeys  data MissingResult = MissingResult   { missingDocCount :: Int-  } deriving (Show)+  }+  deriving (Show)  instance FromJSON MissingResult where   parseJSON = withObject "MissingResult" parse-    where parse v = MissingResult <$> v .: "doc_count"+    where+      parse v = MissingResult <$> v .: "doc_count"  data TopHitResult a = TopHitResult   { tarHits :: (SearchHits a)-  } deriving (Eq, Show)+  }+  deriving (Eq, Show)  instance (FromJSON a) => FromJSON (TopHitResult a) where-  parseJSON (Object v) = TopHitResult <$>-                         v .: "hits"-  parseJSON _          = fail "Failure in FromJSON (TopHitResult a)"+  parseJSON (Object v) =+    TopHitResult+      <$> v .: "hits"+  parseJSON _ = fail "Failure in FromJSON (TopHitResult a)"  data HitsTotalRelation = HTR_EQ | HTR_GTE deriving (Eq, Show)  instance FromJSON HitsTotalRelation where-  parseJSON (String "eq")  = pure HTR_EQ+  parseJSON (String "eq") = pure HTR_EQ   parseJSON (String "gte") = pure HTR_GTE-  parseJSON _              = empty+  parseJSON _ = empty -data HitsTotal =-  HitsTotal { value    :: Int-            , relation :: HitsTotalRelation } deriving (Eq, Show)+data HitsTotal = HitsTotal+  { value :: Int,+    relation :: HitsTotalRelation+  }+  deriving (Eq, Show)  instance FromJSON HitsTotal where-  parseJSON (Object v) = HitsTotal <$>-                         v .: "value"     <*>-                         v .: "relation"-  parseJSON _          = empty+  parseJSON (Object v) =+    HitsTotal+      <$> v .: "value"+      <*> v .: "relation"+  parseJSON _ = empty  instance Semigroup HitsTotal where-  (HitsTotal ta HTR_EQ)  <> (HitsTotal tb HTR_EQ)  = HitsTotal (ta + tb) HTR_EQ-  (HitsTotal ta HTR_GTE) <> (HitsTotal tb _)   = HitsTotal (ta + tb) HTR_GTE-  (HitsTotal ta _)       <> (HitsTotal tb HTR_GTE) = HitsTotal (ta + tb) HTR_GTE+  (HitsTotal ta HTR_EQ) <> (HitsTotal tb HTR_EQ) = HitsTotal (ta + tb) HTR_EQ+  (HitsTotal ta HTR_GTE) <> (HitsTotal tb _) = HitsTotal (ta + tb) HTR_GTE+  (HitsTotal ta _) <> (HitsTotal tb HTR_GTE) = HitsTotal (ta + tb) HTR_GTE -data SearchHits a =-  SearchHits { hitsTotal :: HitsTotal-             , maxScore  :: Score-             , hits      :: [Hit a] } deriving (Eq, Show)+data SearchHits a = SearchHits+  { hitsTotal :: HitsTotal,+    maxScore :: Score,+    hits :: [Hit a]+  }+  deriving (Eq, Show)  instance (FromJSON a) => FromJSON (SearchHits a) where-  parseJSON (Object v) = SearchHits <$>-                         v .: "total"     <*>-                         v .: "max_score" <*>-                         v .: "hits"-  parseJSON _          = empty+  parseJSON (Object v) =+    SearchHits+      <$> v .: "total"+      <*> v .: "max_score"+      <*> v .: "hits"+  parseJSON _ = empty  instance Semigroup (SearchHits a) where   (SearchHits ta ma ha) <> (SearchHits tb mb hb) =@@ -470,25 +552,27 @@  type SearchAfterKey = [Aeson.Value] -data Hit a =-  Hit { hitIndex     :: IndexName-      , hitDocId     :: DocId-      , hitScore     :: Score-      , hitSource    :: Maybe a-      , hitSort      :: Maybe SearchAfterKey-      , hitFields    :: Maybe HitFields-      , hitHighlight :: Maybe HitHighlight-      , hitInnerHits :: Maybe (X.KeyMap (TopHitResult Value)) } deriving (Eq, Show)+data Hit a = Hit+  { hitIndex :: IndexName,+    hitDocId :: DocId,+    hitScore :: Score,+    hitSource :: Maybe a,+    hitSort :: Maybe SearchAfterKey,+    hitFields :: Maybe HitFields,+    hitHighlight :: Maybe HitHighlight,+    hitInnerHits :: Maybe (X.KeyMap (TopHitResult Value))+  }+  deriving (Eq, Show)  instance (FromJSON a) => FromJSON (Hit a) where-  parseJSON (Object v) = Hit <$>-                         v .:  "_index"   <*>-                         v .:  "_id"      <*>-                         v .:  "_score"   <*>-                         v .:? "_source"  <*>-                         v .:? "sort"     <*>-                         v .:? "fields"   <*>-                         v .:? "highlight" <*>-                         v .:? "inner_hits"-  parseJSON _          = empty-+  parseJSON (Object v) =+    Hit+      <$> v .: "_index"+      <*> v .: "_id"+      <*> v .: "_score"+      <*> v .:? "_source"+      <*> v .:? "sort"+      <*> v .:? "fields"+      <*> v .:? "highlight"+      <*> v .:? "inner_hits"+  parseJSON _ = empty
src/Database/Bloodhound/Internal/Analysis.hs view
@@ -1,84 +1,92 @@-{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE OverloadedStrings #-}  module Database.Bloodhound.Internal.Analysis where -import           Bloodhound.Import-+import Bloodhound.Import import qualified Data.Map.Strict as M import qualified Data.Text as T-import           GHC.Generics--import           Database.Bloodhound.Internal.Newtypes-import           Database.Bloodhound.Internal.StringlyTyped+import Database.Bloodhound.Internal.Newtypes+import Database.Bloodhound.Internal.StringlyTyped+import GHC.Generics  data Analysis = Analysis-  { analysisAnalyzer :: M.Map Text AnalyzerDefinition-  , analysisTokenizer :: M.Map Text TokenizerDefinition-  , analysisTokenFilter :: M.Map Text TokenFilterDefinition-  , analysisCharFilter :: M.Map Text CharFilterDefinition-  } deriving (Eq, Show, Generic)+  { analysisAnalyzer :: M.Map Text AnalyzerDefinition,+    analysisTokenizer :: M.Map Text TokenizerDefinition,+    analysisTokenFilter :: M.Map Text TokenFilterDefinition,+    analysisCharFilter :: M.Map Text CharFilterDefinition+  }+  deriving (Eq, Show, Generic)  instance ToJSON Analysis where-  toJSON (Analysis analyzer tokenizer tokenFilter charFilter) = object-    [ "analyzer" .= analyzer-    , "tokenizer" .= tokenizer-    , "filter" .= tokenFilter-    , "char_filter" .= charFilter-    ]+  toJSON (Analysis analyzer tokenizer tokenFilter charFilter) =+    object+      [ "analyzer" .= analyzer,+        "tokenizer" .= tokenizer,+        "filter" .= tokenFilter,+        "char_filter" .= charFilter+      ]  instance FromJSON Analysis where-  parseJSON = withObject "Analysis" $ \m -> Analysis-    <$> m .: "analyzer"-    <*> m .:? "tokenizer" .!= M.empty-    <*> m .:? "filter" .!= M.empty-    <*> m .:? "char_filter" .!= M.empty+  parseJSON = withObject "Analysis" $ \m ->+    Analysis+      <$> m .: "analyzer"+      <*> m .:? "tokenizer" .!= M.empty+      <*> m .:? "filter" .!= M.empty+      <*> m .:? "char_filter" .!= M.empty -newtype Tokenizer =-  Tokenizer Text+newtype Tokenizer+  = Tokenizer Text   deriving (Eq, Show, Generic, ToJSON, FromJSON)  data AnalyzerDefinition = AnalyzerDefinition-  { analyzerDefinitionTokenizer :: Maybe Tokenizer-  , analyzerDefinitionFilter :: [TokenFilter]-  , analyzerDefinitionCharFilter :: [CharFilter]-  } deriving (Eq,Show, Generic)+  { analyzerDefinitionTokenizer :: Maybe Tokenizer,+    analyzerDefinitionFilter :: [TokenFilter],+    analyzerDefinitionCharFilter :: [CharFilter]+  }+  deriving (Eq, Show, Generic)  instance ToJSON AnalyzerDefinition where   toJSON (AnalyzerDefinition tokenizer tokenFilter charFilter) =-    object $ catMaybes-    [ fmap ("tokenizer" .=) tokenizer-    , Just $ "filter" .= tokenFilter-    , Just $ "char_filter" .= charFilter-    ]+    object $+      catMaybes+        [ fmap ("tokenizer" .=) tokenizer,+          Just $ "filter" .= tokenFilter,+          Just $ "char_filter" .= charFilter+        ]  instance FromJSON AnalyzerDefinition where-  parseJSON = withObject "AnalyzerDefinition" $ \m -> AnalyzerDefinition-    <$> m .:? "tokenizer"-    <*> m .:? "filter" .!= []-    <*> m .:? "char_filter" .!= []+  parseJSON = withObject "AnalyzerDefinition" $ \m ->+    AnalyzerDefinition+      <$> m .:? "tokenizer"+      <*> m .:? "filter" .!= []+      <*> m .:? "char_filter" .!= []  -- | Character filters are used to preprocess the stream of characters --   before it is passed to the tokenizer. data CharFilterDefinition   = CharFilterDefinitionMapping (M.Map Text Text)   | CharFilterDefinitionPatternReplace-    { charFilterDefinitionPatternReplacePattern :: Text-    , charFilterDefinitionPatternReplaceReplacement :: Text-    , charFilterDefinitionPatternReplaceFlags :: Maybe Text-    }+      { charFilterDefinitionPatternReplacePattern :: Text,+        charFilterDefinitionPatternReplaceReplacement :: Text,+        charFilterDefinitionPatternReplaceFlags :: Maybe Text+      }   deriving (Eq, Show)  instance ToJSON CharFilterDefinition where-  toJSON (CharFilterDefinitionMapping ms) = object-    [ "type" .= ("mapping" :: Text)-    , "mappings" .= [a <> " => " <> b | (a, b) <- M.toList ms] ]-  toJSON (CharFilterDefinitionPatternReplace pat repl flags) = object $-    [ "type" .= ("pattern_replace" :: Text)-    , "pattern" .= pat-    , "replacement" .= repl-    ] ++ maybe [] (\f -> ["flags" .= f]) flags+  toJSON (CharFilterDefinitionMapping ms) =+    object+      [ "type" .= ("mapping" :: Text),+        "mappings" .= [a <> " => " <> b | (a, b) <- M.toList ms]+      ]+  toJSON (CharFilterDefinitionPatternReplace pat repl flags) =+    object $+      [ "type" .= ("pattern_replace" :: Text),+        "pattern" .= pat,+        "replacement" .= repl+      ]+        ++ maybe [] (\f -> ["flags" .= f]) flags  instance FromJSON CharFilterDefinition where   parseJSON = withObject "CharFilterDefinition" $ \m -> do@@ -88,16 +96,17 @@         where           ms = m .: "mappings" >>= mapM parseMapping           parseMapping kv = case T.splitOn "=>" kv of-            (k:vs) -> pure (T.strip k, T.strip $ T.concat vs)+            (k : vs) -> pure (T.strip k, T.strip $ T.concat vs)             _ -> fail "mapping is not of the format key => value"-      "pattern_replace" -> CharFilterDefinitionPatternReplace-        <$> m .: "pattern" <*> m .: "replacement" <*> m .:? "flags"+      "pattern_replace" ->+        CharFilterDefinitionPatternReplace+          <$> m .: "pattern" <*> m .: "replacement" <*> m .:? "flags"       _ -> fail ("unrecognized character filter type: " ++ T.unpack t)  data TokenizerDefinition   = TokenizerDefinitionNgram Ngram   | TokenizerDefinitionEdgeNgram Ngram-  deriving (Eq,Show, Generic)+  deriving (Eq, Show, Generic)  instance ToJSON TokenizerDefinition where   toJSON x =@@ -108,9 +117,9 @@         object (["type" .= ("edge_ngram" :: Text)] <> ngramToObject ngram)     where       ngramToObject (Ngram minGram maxGram tokenChars) =-        [ "min_gram" .= minGram-        , "max_gram" .= maxGram-        , "token_chars" .= tokenChars+        [ "min_gram" .= minGram,+          "max_gram" .= maxGram,+          "token_chars" .= tokenChars         ]  instance FromJSON TokenizerDefinition where@@ -122,26 +131,27 @@       "edge_ngram" ->         TokenizerDefinitionEdgeNgram <$> parseNgram m       _ -> fail $ "invalid TokenizerDefinition type: " <> T.unpack typ-      where-        parseNgram m =-          Ngram-            <$> fmap unStringlyTypedInt (m .: "min_gram")-            <*> fmap unStringlyTypedInt (m .: "max_gram")-            <*> m .: "token_chars"+    where+      parseNgram m =+        Ngram+          <$> fmap unStringlyTypedInt (m .: "min_gram")+          <*> fmap unStringlyTypedInt (m .: "max_gram")+          <*> m .: "token_chars"  data Ngram = Ngram-  { ngramMinGram :: Int-  , ngramMaxGram :: Int-  , ngramTokenChars :: [TokenChar]-  } deriving (Eq,Show, Generic)+  { ngramMinGram :: Int,+    ngramMaxGram :: Int,+    ngramTokenChars :: [TokenChar]+  }+  deriving (Eq, Show, Generic) -data TokenChar =-    TokenLetter+data TokenChar+  = TokenLetter   | TokenDigit   | TokenWhitespace   | TokenPunctuation   | TokenSymbol-  deriving (Eq,Show, Generic)+  deriving (Eq, Show, Generic)  instance ToJSON TokenChar where   toJSON t = String $ case t of@@ -177,57 +187,70 @@  instance ToJSON TokenFilterDefinition where   toJSON x = case x of-    TokenFilterDefinitionLowercase mlang -> object $ catMaybes-      [ Just $ "type" .= ("lowercase" :: Text)-      , fmap (\lang -> "language" .= languageToText lang) mlang-      ]-    TokenFilterDefinitionUppercase mlang -> object $ catMaybes-      [ Just $ "type" .= ("uppercase" :: Text)-      , fmap (\lang -> "language" .= languageToText lang) mlang-      ]-    TokenFilterDefinitionApostrophe -> object-      [ "type" .= ("apostrophe" :: Text)-      ]-    TokenFilterDefinitionReverse -> object-      [ "type" .= ("reverse" :: Text)-      ]-    TokenFilterDefinitionSnowball lang -> object-      [ "type" .= ("snowball" :: Text)-      , "language" .= languageToText lang-      ]-    TokenFilterDefinitionShingle s -> object-      [ "type" .= ("shingle" :: Text)-      , "max_shingle_size" .= shingleMaxSize s-      , "min_shingle_size" .= shingleMinSize s-      , "output_unigrams" .= shingleOutputUnigrams s-      , "output_unigrams_if_no_shingles" .= shingleOutputUnigramsIfNoShingles s-      , "token_separator" .= shingleTokenSeparator s-      , "filler_token" .= shingleFillerToken s-      ]-    TokenFilterDefinitionStemmer lang -> object-      [ "type" .= ("stemmer" :: Text)-      , "language" .= languageToText lang-      ]-    TokenFilterDefinitionStop stop -> object-      [ "type" .= ("stop" :: Text)-      , "stopwords" .= case stop of-          Left lang -> String $ "_" <> languageToText lang <> "_"-          Right stops -> toJSON stops-      ]-    TokenFilterDefinitionEdgeNgram ngram side -> object-      ([ "type" .= ("edge_ngram" :: Text)-       , "side" .= side-       ]-       <> ngramFilterToPairs ngram-      )-    TokenFilterDefinitionNgram ngram -> object-      (["type" .= ("ngram" :: Text)]-       <> ngramFilterToPairs ngram-      )-    TokenFilterTruncate n -> object-      [ "type" .= ("truncate" :: Text)-      , "length" .= n-      ]+    TokenFilterDefinitionLowercase mlang ->+      object $+        catMaybes+          [ Just $ "type" .= ("lowercase" :: Text),+            fmap (\lang -> "language" .= languageToText lang) mlang+          ]+    TokenFilterDefinitionUppercase mlang ->+      object $+        catMaybes+          [ Just $ "type" .= ("uppercase" :: Text),+            fmap (\lang -> "language" .= languageToText lang) mlang+          ]+    TokenFilterDefinitionApostrophe ->+      object+        [ "type" .= ("apostrophe" :: Text)+        ]+    TokenFilterDefinitionReverse ->+      object+        [ "type" .= ("reverse" :: Text)+        ]+    TokenFilterDefinitionSnowball lang ->+      object+        [ "type" .= ("snowball" :: Text),+          "language" .= languageToText lang+        ]+    TokenFilterDefinitionShingle s ->+      object+        [ "type" .= ("shingle" :: Text),+          "max_shingle_size" .= shingleMaxSize s,+          "min_shingle_size" .= shingleMinSize s,+          "output_unigrams" .= shingleOutputUnigrams s,+          "output_unigrams_if_no_shingles" .= shingleOutputUnigramsIfNoShingles s,+          "token_separator" .= shingleTokenSeparator s,+          "filler_token" .= shingleFillerToken s+        ]+    TokenFilterDefinitionStemmer lang ->+      object+        [ "type" .= ("stemmer" :: Text),+          "language" .= languageToText lang+        ]+    TokenFilterDefinitionStop stop ->+      object+        [ "type" .= ("stop" :: Text),+          "stopwords" .= case stop of+            Left lang -> String $ "_" <> languageToText lang <> "_"+            Right stops -> toJSON stops+        ]+    TokenFilterDefinitionEdgeNgram ngram side ->+      object+        ( [ "type" .= ("edge_ngram" :: Text),+            "side" .= side+          ]+            <> ngramFilterToPairs ngram+        )+    TokenFilterDefinitionNgram ngram ->+      object+        ( ["type" .= ("ngram" :: Text)]+            <> ngramFilterToPairs ngram+        )+    TokenFilterTruncate n ->+      object+        [ "type" .= ("truncate" :: Text),+          "length" .= n+        ]  instance FromJSON TokenFilterDefinition where   parseJSON = withObject "TokenFilterDefinition" $ \m -> do@@ -235,44 +258,52 @@     case (t :: Text) of       "reverse" -> return TokenFilterDefinitionReverse       "apostrophe" -> return TokenFilterDefinitionApostrophe-      "lowercase" -> TokenFilterDefinitionLowercase-        <$> m .:? "language"-      "uppercase" -> TokenFilterDefinitionUppercase-        <$> m .:? "language"-      "snowball" -> TokenFilterDefinitionSnowball-        <$> m .: "language"-      "shingle" -> fmap TokenFilterDefinitionShingle $ Shingle-        <$> (fmap.fmap) unStringlyTypedInt (m .:? "max_shingle_size") .!= 2-        <*> (fmap.fmap) unStringlyTypedInt (m .:? "min_shingle_size") .!= 2-        <*> (fmap.fmap) unStringlyTypedBool (m .:? "output_unigrams") .!= True-        <*> (fmap.fmap) unStringlyTypedBool (m .:? "output_unigrams_if_no_shingles") .!= False-        <*> m .:? "token_separator" .!= " "-        <*> m .:? "filler_token" .!= "_"-      "stemmer" -> TokenFilterDefinitionStemmer-        <$> m .: "language"+      "lowercase" ->+        TokenFilterDefinitionLowercase+          <$> m .:? "language"+      "uppercase" ->+        TokenFilterDefinitionUppercase+          <$> m .:? "language"+      "snowball" ->+        TokenFilterDefinitionSnowball+          <$> m .: "language"+      "shingle" ->+        fmap TokenFilterDefinitionShingle $+          Shingle+            <$> (fmap . fmap) unStringlyTypedInt (m .:? "max_shingle_size") .!= 2+            <*> (fmap . fmap) unStringlyTypedInt (m .:? "min_shingle_size") .!= 2+            <*> (fmap . fmap) unStringlyTypedBool (m .:? "output_unigrams") .!= True+            <*> (fmap . fmap) unStringlyTypedBool (m .:? "output_unigrams_if_no_shingles") .!= False+            <*> m .:? "token_separator" .!= " "+            <*> m .:? "filler_token" .!= "_"+      "stemmer" ->+        TokenFilterDefinitionStemmer+          <$> m .: "language"       "stop" -> do         stop <- m .: "stopwords"         stop' <- case stop of           String lang ->-              fmap Left-            . parseJSON-            . String-            . T.drop 1-            . T.dropEnd 1 $ lang+            fmap Left+              . parseJSON+              . String+              . T.drop 1+              . T.dropEnd 1+              $ lang           _ -> Right <$> parseJSON stop         return (TokenFilterDefinitionStop stop')-      "edge_ngram" -> TokenFilterDefinitionEdgeNgram-        <$> ngramFilterFromJSONObject m-        <*> m .: "side"+      "edge_ngram" ->+        TokenFilterDefinitionEdgeNgram+          <$> ngramFilterFromJSONObject m+          <*> m .: "side"       "ngram" -> TokenFilterDefinitionNgram <$> ngramFilterFromJSONObject m       "truncate" -> TokenFilterTruncate <$> m .:? "length" .!= 10       _ -> fail ("unrecognized token filter type: " ++ T.unpack t) -data NgramFilter-  = NgramFilter { ngramFilterMinGram :: Int-                , ngramFilterMaxGram :: Int-                }-    deriving (Eq, Show, Generic)+data NgramFilter = NgramFilter+  { ngramFilterMinGram :: Int,+    ngramFilterMaxGram :: Int+  }+  deriving (Eq, Show, Generic)  ngramFilterToPairs :: NgramFilter -> [Pair] ngramFilterToPairs (NgramFilter minGram maxGram) =@@ -438,10 +469,11 @@   _ -> Nothing  data Shingle = Shingle-  { shingleMaxSize :: Int-  , shingleMinSize :: Int-  , shingleOutputUnigrams :: Bool-  , shingleOutputUnigramsIfNoShingles :: Bool-  , shingleTokenSeparator :: Text-  , shingleFillerToken :: Text-  } deriving (Eq, Show, Generic)+  { shingleMaxSize :: Int,+    shingleMinSize :: Int,+    shingleOutputUnigrams :: Bool,+    shingleOutputUnigramsIfNoShingles :: Bool,+    shingleTokenSeparator :: Text,+    shingleFillerToken :: Text+  }+  deriving (Eq, Show, Generic)
src/Database/Bloodhound/Internal/Client.hs view
@@ -1,2420 +1,2366 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE UndecidableInstances       #-}--module Database.Bloodhound.Internal.Client where--import           Bloodhound.Import--import qualified Data.Aeson.KeyMap                          as X-import qualified Data.HashMap.Strict                        as HM-import           Data.Map.Strict                            (Map)-import           Data.Maybe                                 (mapMaybe)-import qualified Data.SemVer                                as SemVer-import qualified Data.Text                                  as T-import qualified Data.Traversable                           as DT-import qualified Data.Vector                                as V-import           GHC.Enum-import           Network.HTTP.Client-import           Text.Read                                  (Read (..))-import qualified Text.Read                                  as TR-import           GHC.Generics--import           Database.Bloodhound.Internal.Analysis-import           Database.Bloodhound.Internal.Newtypes-import           Database.Bloodhound.Internal.Query-import           Database.Bloodhound.Internal.StringlyTyped--{-| 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, FromJSON)--{-| 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-    } deriving ( Functor-               , Applicative-               , Monad-               , MonadIO-               , MonadState s-               , MonadWriter w-               , MonadError e-               , Alternative-               , MonadPlus-               , MonadFix-               , MonadThrow-               , MonadCatch-#if defined(MIN_VERSION_GLASGOW_HASKELL)-#if MIN_VERSION_GLASGOW_HASKELL(8,6,0,0)-               , MonadFail-#endif-#endif-               , MonadMask)--instance MonadTrans BH where-  lift = BH . lift--instance (MonadReader r m) => MonadReader r (BH m) where-    ask = lift ask-    local f (BH (ReaderT m)) = BH $ ReaderT $ \r ->-      local f (m r)--instance (Functor m, Applicative m, MonadIO m) => MonadBH (BH m) where-  getBHEnv = BH getBHEnv--runBH :: BHEnv -> BH m a -> m a-runBH e f = runReaderT (unBH f) e--{-| 'Version' is embedded in 'Status' -}-data Version = Version { number         :: VersionNumber-                       , build_hash     :: BuildHash-                       , build_date     :: UTCTime-                       , build_snapshot :: Bool-                       , lucene_version :: VersionNumber }-     deriving (Eq, Show, Generic)---- | Traditional software versioning number-newtype VersionNumber = VersionNumber-  { versionNumber :: SemVer.Version }-  deriving (Eq, Ord, Show)--{-| 'Status' is a data type for describing the JSON body returned by-    Elasticsearch when you query its status. This was deprecated in 1.2.0.--   <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-status.html#indices-status>--}--data Status = Status-  { name         :: Text-  , cluster_name :: Text-  , cluster_uuid :: Text-  , version      :: Version-  , tagline      :: Text }-  deriving (Eq, Show)--instance FromJSON Status where-  parseJSON (Object v) = Status <$>-                         v .: "name" <*>-                         v .: "cluster_name" <*>-                         v .: "cluster_uuid" <*>-                         v .: "version" <*>-                         v .: "tagline"-  parseJSON _          = empty--{-| 'IndexSettings' is used to configure the shards and replicas when-    you create an Elasticsearch Index.--   <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-create-index.html>--}--data IndexSettings = IndexSettings-  { indexShards   :: ShardCount-  , indexReplicas :: ReplicaCount-  , indexMappingsLimits :: IndexMappingsLimits }-  deriving (Eq, Show, Generic)--instance ToJSON IndexSettings where-  toJSON (IndexSettings s r l) = object ["settings" .=-                                 object ["index" .=-                                   object ["number_of_shards" .= s, "number_of_replicas" .= r, "mapping" .= l]-                                 ]-                               ]--instance FromJSON IndexSettings where-  parseJSON = withObject "IndexSettings" parse-    where parse o = do s <- o .: "settings"-                       i <- s .: "index"-                       IndexSettings <$> i .: "number_of_shards"-                                     <*> i .: "number_of_replicas"-                                     <*> i .:? "mapping" .!= defaultIndexMappingsLimits--{-| 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and-    2 replicas. -}-defaultIndexSettings :: IndexSettings-defaultIndexSettings =  IndexSettings (ShardCount 3) (ReplicaCount 2) defaultIndexMappingsLimits--- defaultIndexSettings is exported by Database.Bloodhound as well--- no trailing slashes in servers, library handles building the path.---{-| 'IndexMappingsLimits is used to configure index's limits.-   <https://www.elastic.co/guide/en/elasticsearch/reference/master/mapping-settings-limit.html>--}--data IndexMappingsLimits = IndexMappingsLimits-  { indexMappingsLimitDepth :: Maybe Int-  , indexMappingsLimitNestedFields :: Maybe Int-  , indexMappingsLimitNestedObjects :: Maybe Int-  , indexMappingsLimitFieldNameLength :: Maybe Int }-  deriving (Eq, Show, Generic)--instance ToJSON IndexMappingsLimits where-  toJSON (IndexMappingsLimits d f o n) = object $-                                            mapMaybe go-                                              [ ("depth.limit", d)-                                              , ("nested_fields.limit", f)-                                              , ("nested_objects.limit", o)-                                              , ("field_name_length.limit", n)]-    where go (name, value) = (name .=) <$> value--instance FromJSON IndexMappingsLimits where-  parseJSON = withObject "IndexMappingsLimits" $ \o ->-                IndexMappingsLimits-                  <$> o .:?? "depth"-                  <*> o .:?? "nested_fields"-                  <*> o .:?? "nested_objects"-                  <*> o .:?? "field_name_length"-    where o .:?? name = optional $ do-            f <- o .: name-            f .: "limit"--defaultIndexMappingsLimits :: IndexMappingsLimits-defaultIndexMappingsLimits =  IndexMappingsLimits Nothing Nothing Nothing Nothing--{-| 'ForceMergeIndexSettings' is used to configure index optimization. See-    <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-forcemerge.html>-    for more info.--}-data ForceMergeIndexSettings =-  ForceMergeIndexSettings { 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)---{-| 'defaultForceMergeIndexSettings' implements the default settings that-    Elasticsearch uses for index optimization. 'maxNumSegments' is Nothing,-    'onlyExpungeDeletes' is False, and flushAfterOptimize is True.--}-defaultForceMergeIndexSettings :: ForceMergeIndexSettings-defaultForceMergeIndexSettings = ForceMergeIndexSettings Nothing False True--{-| 'UpdatableIndexSetting' are settings which may be updated after an index is created.--   <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-update-settings.html>--}-data UpdatableIndexSetting = NumberOfReplicas ReplicaCount-                           -- ^ The number of replicas each shard has.-                           | AutoExpandReplicas ReplicaBounds-                           | BlocksReadOnly Bool-                           -- ^ Set to True to have the index read only. False to allow writes and metadata changes.-                           | BlocksRead Bool-                           -- ^ Set to True to disable read operations against the index.-                           | BlocksWrite Bool-                           -- ^ Set to True to disable write operations against the index.-                           | BlocksMetaData Bool-                           -- ^ Set to True to disable metadata operations against the index.-                           | RefreshInterval NominalDiffTime-                           -- ^ The async refresh interval of a shard-                           | IndexConcurrency Int-                           | FailOnMergeFailure Bool-                           | TranslogFlushThresholdOps Int-                           -- ^ When to flush on operations.-                           | TranslogFlushThresholdSize Bytes-                           -- ^ When to flush based on translog (bytes) size.-                           | TranslogFlushThresholdPeriod NominalDiffTime-                           -- ^ When to flush based on a period of not flushing.-                           | TranslogDisableFlush Bool-                           -- ^ Disables flushing. Note, should be set for a short interval and then enabled.-                           | CacheFilterMaxSize (Maybe Bytes)-                           -- ^ The maximum size of filter cache (per segment in shard).-                           | CacheFilterExpire (Maybe NominalDiffTime)-                           -- ^ The expire after access time for filter cache.-                           | GatewaySnapshotInterval NominalDiffTime-                           -- ^ The gateway snapshot interval (only applies to shared gateways).-                           | RoutingAllocationInclude (NonEmpty NodeAttrFilter)-                           -- ^ A node matching any rule will be allowed to host shards from the index.-                           | RoutingAllocationExclude (NonEmpty NodeAttrFilter)-                           -- ^ A node matching any rule will NOT be allowed to host shards from the index.-                           | RoutingAllocationRequire (NonEmpty NodeAttrFilter)-                           -- ^ Only nodes matching all rules will be allowed to host shards from the index.-                           | RoutingAllocationEnable AllocationPolicy-                           -- ^ Enables shard allocation for a specific index.-                           | RoutingAllocationShardsPerNode ShardCount-                           -- ^ Controls the total number of shards (replicas and primaries) allowed to be allocated on a single node.-                           | RecoveryInitialShards InitialShardCount-                           -- ^ When using local gateway a particular shard is recovered only if there can be allocated quorum shards in the cluster.-                           | GCDeletes NominalDiffTime-                           | TTLDisablePurge Bool-                           -- ^ Disables temporarily the purge of expired docs.-                           | TranslogFSType FSType-                           | CompressionSetting Compression-                           | IndexCompoundFormat CompoundFormat-                           | IndexCompoundOnFlush Bool-                           | WarmerEnabled Bool-                           | MappingTotalFieldsLimit Int-                           | AnalysisSetting Analysis-                           -- ^ Analysis is not a dynamic setting and can only be performed on a closed index.-                           | UnassignedNodeLeftDelayedTimeout NominalDiffTime-                           -- ^ Sets a delay to the allocation of replica shards which become unassigned because a node has left, giving them chance to return. See <https://www.elastic.co/guide/en/elasticsearch/reference/5.6/delayed-allocation.html>-                           deriving (Eq, Show, Generic)--attrFilterJSON :: NonEmpty NodeAttrFilter -> Value-attrFilterJSON fs = object [ fromText n .= T.intercalate "," (toList vs)-                           | NodeAttrFilter (NodeAttrName n) vs <- toList fs]--parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)-parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse-  where parse o = case X.toList o of-                    []   -> fail "Expected non-empty list of NodeAttrFilters"-                    x:xs -> DT.mapM (uncurry parse') (x :| xs)-        parse' n = withText "Text" $ \t ->-          case T.splitOn "," t of-            fv:fvs -> return (NodeAttrFilter (NodeAttrName $ toText n) (fv :| fvs))-            []     -> fail "Expected non-empty list of filter values"--instance ToJSON UpdatableIndexSetting where-  toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x-  toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x-  toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x)-  toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x-  toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x-  toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x-  toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x-  toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x)-  toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x-  toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x-  toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x)-  toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x)-  toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs)-  toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs)-  toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs)-  toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x-  toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x-  toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x-  toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x)-  toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x-  toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x-  toJSON (CompressionSetting x) = oPath ("index" :| ["codec"]) x-  toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x-  toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x-  toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x-  toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x-  toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x-  toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x-  toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x-  toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping","total_fields","limit"]) x-  toJSON (AnalysisSetting x) = oPath ("index" :| ["analysis"]) x-  toJSON (UnassignedNodeLeftDelayedTimeout x) = oPath ("index" :| ["unassigned","node_left","delayed_timeout"]) (NominalDiffTimeJSON x)--instance FromJSON UpdatableIndexSetting where-  parseJSON = withObject "UpdatableIndexSetting" parse-    where parse o = numberOfReplicas `taggedAt` ["index", "number_of_replicas"]-                <|> autoExpandReplicas `taggedAt` ["index", "auto_expand_replicas"]-                <|> refreshInterval `taggedAt` ["index", "refresh_interval"]-                <|> indexConcurrency `taggedAt` ["index", "concurrency"]-                <|> failOnMergeFailure `taggedAt` ["index", "fail_on_merge_failure"]-                <|> translogFlushThresholdOps `taggedAt` ["index", "translog", "flush_threshold_ops"]-                <|> translogFlushThresholdSize `taggedAt` ["index", "translog", "flush_threshold_size"]-                <|> translogFlushThresholdPeriod `taggedAt` ["index", "translog", "flush_threshold_period"]-                <|> translogDisableFlush `taggedAt` ["index", "translog", "disable_flush"]-                <|> cacheFilterMaxSize `taggedAt` ["index", "cache", "filter", "max_size"]-                <|> cacheFilterExpire `taggedAt` ["index", "cache", "filter", "expire"]-                <|> gatewaySnapshotInterval `taggedAt` ["index", "gateway", "snapshot_interval"]-                <|> routingAllocationInclude `taggedAt` ["index", "routing", "allocation", "include"]-                <|> routingAllocationExclude `taggedAt` ["index", "routing", "allocation", "exclude"]-                <|> routingAllocationRequire `taggedAt` ["index", "routing", "allocation", "require"]-                <|> routingAllocationEnable `taggedAt` ["index", "routing", "allocation", "enable"]-                <|> routingAllocationShardsPerNode `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"]-                <|> recoveryInitialShards `taggedAt` ["index", "recovery", "initial_shards"]-                <|> gcDeletes `taggedAt` ["index", "gc_deletes"]-                <|> ttlDisablePurge `taggedAt` ["index", "ttl", "disable_purge"]-                <|> translogFSType `taggedAt` ["index", "translog", "fs", "type"]-                <|> compressionSetting `taggedAt` ["index", "codec"]-                <|> compoundFormat `taggedAt` ["index", "compound_format"]-                <|> compoundOnFlush `taggedAt` ["index", "compound_on_flush"]-                <|> warmerEnabled `taggedAt` ["index", "warmer", "enabled"]-                <|> blocksReadOnly `taggedAt` ["blocks", "read_only"]-                <|> blocksRead `taggedAt` ["blocks", "read"]-                <|> blocksWrite `taggedAt` ["blocks", "write"]-                <|> blocksMetaData `taggedAt` ["blocks", "metadata"]-                <|> mappingTotalFieldsLimit `taggedAt` ["index", "mapping", "total_fields", "limit"]-                <|> analysisSetting `taggedAt` ["index", "analysis"]-                <|> unassignedNodeLeftDelayedTimeout `taggedAt` ["index", "unassigned", "node_left", "delayed_timeout"]-            where taggedAt f ks = taggedAt' f (Object o) ks-          taggedAt' f v [] =-            f =<< (parseJSON v <|> parseJSON (unStringlyTypeJSON v))-          taggedAt' f v (k:ks) =-            withObject "Object" (\o -> do v' <- o .: k-                                          taggedAt' f v' ks) v-          numberOfReplicas                 = pure . NumberOfReplicas-          autoExpandReplicas               = pure . AutoExpandReplicas-          refreshInterval                  = pure . RefreshInterval . ndtJSON-          indexConcurrency                 = pure . IndexConcurrency-          failOnMergeFailure               = pure . FailOnMergeFailure-          translogFlushThresholdOps        = pure . TranslogFlushThresholdOps-          translogFlushThresholdSize       = pure . TranslogFlushThresholdSize-          translogFlushThresholdPeriod     = pure . TranslogFlushThresholdPeriod . ndtJSON-          translogDisableFlush             = pure . TranslogDisableFlush-          cacheFilterMaxSize               = pure . CacheFilterMaxSize-          cacheFilterExpire                = pure . CacheFilterExpire . fmap ndtJSON-          gatewaySnapshotInterval          = pure . GatewaySnapshotInterval . ndtJSON-          routingAllocationInclude         = fmap RoutingAllocationInclude . parseAttrFilter-          routingAllocationExclude         = fmap RoutingAllocationExclude . parseAttrFilter-          routingAllocationRequire         = fmap RoutingAllocationRequire . parseAttrFilter-          routingAllocationEnable          = pure . RoutingAllocationEnable-          routingAllocationShardsPerNode   = pure . RoutingAllocationShardsPerNode-          recoveryInitialShards            = pure . RecoveryInitialShards-          gcDeletes                        = pure . GCDeletes . ndtJSON-          ttlDisablePurge                  = pure . TTLDisablePurge-          translogFSType                   = pure . TranslogFSType-          compressionSetting               = pure . CompressionSetting-          compoundFormat                   = pure . IndexCompoundFormat-          compoundOnFlush                  = pure . IndexCompoundOnFlush-          warmerEnabled                    = pure . WarmerEnabled-          blocksReadOnly                   = pure . BlocksReadOnly-          blocksRead                       = pure . BlocksRead-          blocksWrite                      = pure . BlocksWrite-          blocksMetaData                   = pure . BlocksMetaData-          mappingTotalFieldsLimit          = pure . MappingTotalFieldsLimit-          analysisSetting                  = pure . AnalysisSetting-          unassignedNodeLeftDelayedTimeout = pure . UnassignedNodeLeftDelayedTimeout . ndtJSON--data ReplicaBounds = ReplicasBounded Int Int-                   | ReplicasLowerBounded Int-                   | ReplicasUnbounded-                   deriving (Eq, Show)---instance ToJSON ReplicaBounds where-  toJSON (ReplicasBounded a b)    = String (showText a <> "-" <> showText b)-  toJSON (ReplicasLowerBounded a) = String (showText a <> "-all")-  toJSON ReplicasUnbounded        = Bool False--instance FromJSON ReplicaBounds where-  parseJSON v = withText "ReplicaBounds" parseText v-            <|> withBool "ReplicaBounds" parseBool v-    where parseText t = case T.splitOn "-" t of-                          [a, "all"] -> ReplicasLowerBounded <$> parseReadText a-                          [a, b] -> ReplicasBounded <$> parseReadText a-                                                    <*> parseReadText b-                          _ -> fail ("Could not parse ReplicaBounds: " <> show t)-          parseBool False = pure ReplicasUnbounded-          parseBool _ = fail "ReplicasUnbounded cannot be represented with True"--data Compression-  = CompressionDefault-    -- ^ Compress with LZ4-  | CompressionBest-    -- ^ Compress with DEFLATE. Elastic-    --   <https://www.elastic.co/blog/elasticsearch-storage-the-true-story-2.0 blogs>-    --   that this can reduce disk use by 15%-25%.-  deriving (Eq,Show, Generic)--instance ToJSON Compression where-  toJSON x = case x of-    CompressionDefault -> toJSON ("default" :: Text)-    CompressionBest -> toJSON ("best_compression" :: Text)--instance FromJSON Compression where-  parseJSON = withText "Compression" $ \t -> case t of-    "default" -> return CompressionDefault-    "best_compression" -> return CompressionBest-    _ -> fail "invalid compression codec"---- | A measure of bytes used for various configurations. You may want--- to use smart constructors like 'gigabytes' for larger values.------ >>> gigabytes 9--- Bytes 9000000000------ >>> megabytes 9--- Bytes 9000000------ >>> kilobytes 9--- Bytes 9000-newtype Bytes =-  Bytes Int-  deriving (Eq, Show, Generic, Ord, ToJSON, FromJSON)--gigabytes :: Int -> Bytes-gigabytes n = megabytes (1000 * n)---megabytes :: Int -> Bytes-megabytes n = kilobytes (1000 * n)---kilobytes :: Int -> Bytes-kilobytes n = Bytes (1000 * n)---data FSType = FSSimple-            | FSBuffered deriving (Eq, Show, Generic)--instance ToJSON FSType where-  toJSON FSSimple   = "simple"-  toJSON FSBuffered = "buffered"--instance FromJSON FSType where-  parseJSON = withText "FSType" parse-    where parse "simple"   = pure FSSimple-          parse "buffered" = pure FSBuffered-          parse t          = fail ("Invalid FSType: " <> show t)--data InitialShardCount = QuorumShards-                       | QuorumMinus1Shards-                       | FullShards-                       | FullMinus1Shards-                       | ExplicitShards Int-                       deriving (Eq, Show, Generic)--instance FromJSON InitialShardCount where-  parseJSON v = withText "InitialShardCount" parseText v-            <|> ExplicitShards <$> parseJSON v-    where parseText "quorum"   = pure QuorumShards-          parseText "quorum-1" = pure QuorumMinus1Shards-          parseText "full"     = pure FullShards-          parseText "full-1"   = pure FullMinus1Shards-          parseText _          = mzero--instance ToJSON InitialShardCount where-  toJSON QuorumShards       = String "quorum"-  toJSON QuorumMinus1Shards = String "quorum-1"-  toJSON FullShards         = String "full"-  toJSON FullMinus1Shards   = String "full-1"-  toJSON (ExplicitShards x) = toJSON x--data NodeAttrFilter = NodeAttrFilter-  { nodeAttrFilterName   :: NodeAttrName-  , nodeAttrFilterValues :: NonEmpty Text }-  deriving (Eq, Ord, Show)--newtype NodeAttrName = NodeAttrName Text deriving (Eq, Ord, Show)--data CompoundFormat = CompoundFileFormat Bool-                    | MergeSegmentVsTotalIndex Double-                    -- ^ percentage between 0 and 1 where 0 is false, 1 is true-                    deriving (Eq, Show, Generic)--instance ToJSON CompoundFormat where-  toJSON (CompoundFileFormat x)       = Bool x-  toJSON (MergeSegmentVsTotalIndex x) = toJSON x--instance FromJSON CompoundFormat where-  parseJSON v = CompoundFileFormat <$> parseJSON v-            <|> MergeSegmentVsTotalIndex <$> parseJSON v--newtype NominalDiffTimeJSON =-  NominalDiffTimeJSON { ndtJSON ::  NominalDiffTime }--instance ToJSON NominalDiffTimeJSON where-  toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s")--instance FromJSON NominalDiffTimeJSON where-  parseJSON = withText "NominalDiffTime" parse-    where parse t = case T.takeEnd 1 t of-                      "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t)-                      _ -> fail "Invalid or missing NominalDiffTime unit (expected s)"--data IndexSettingsSummary = IndexSettingsSummary-  { sSummaryIndexName     :: IndexName-  , sSummaryFixedSettings :: IndexSettings-  , sSummaryUpdateable    :: [UpdatableIndexSetting]}-  deriving (Eq, Show)--parseSettings :: Object -> Parser [UpdatableIndexSetting]-parseSettings o = do-  o' <- o .: "index"-  -- slice the index object into singleton hashmaps and try to parse each-  parses <- forM (HM.toList o') $ \(k, v) -> do-    -- blocks are now nested into the "index" key, which is not how they're serialized-    let atRoot = Object (X.singleton k v)-    let atIndex = Object (X.singleton "index" atRoot)-    optional (parseJSON atRoot <|> parseJSON atIndex)-  return (catMaybes parses)--instance FromJSON IndexSettingsSummary where-  parseJSON = withObject "IndexSettingsSummary" parse-    where parse o = case X.toList o of-                      [(ixn, v@(Object o'))] -> IndexSettingsSummary (IndexName $ toText ixn)-                                                <$> parseJSON v-                                                <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")-                      _ -> fail "Expected single-key object with index name"-          redundant (NumberOfReplicas _) = True-          redundant _                    = False--{-| 'Reply' and 'Method' are type synonyms from 'Network.HTTP.Types.Method.Method' -}-type Reply = Network.HTTP.Client.Response LByteString--{-| 'OpenCloseIndex' is a sum type for opening and closing indices.--   <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/indices-open-close.html>--}-data OpenCloseIndex = OpenIndex | CloseIndex deriving (Eq, Show)--data FieldType = GeoPointType-               | GeoShapeType-               | FloatType-               | IntegerType-               | LongType-               | ShortType-               | ByteType deriving (Eq, Show)--newtype FieldDefinition = FieldDefinition-  { fieldType :: FieldType-  } deriving (Eq, Show)--{-| An 'IndexTemplate' defines a template that will automatically be-    applied to new indices created. The templates include both-    'IndexSettings' and mappings, and a simple 'IndexPattern' that-    controls if the template will be applied to the index created.-    Specify mappings as follows: @[toJSON TweetMapping, ...]@--    https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html--}-data IndexTemplate =-  IndexTemplate { templatePatterns :: [IndexPattern]-                , templateSettings :: Maybe IndexSettings-                , templateMappings :: Value-                }--instance ToJSON IndexTemplate where-  toJSON (IndexTemplate p s m) = merge-    (object [ "index_patterns" .= p-            , "mappings" .= m-            ])-    (toJSON s)-   where-     merge (Object o1) (Object o2) = toJSON $ X.union o1 o2-     merge o           Null        = o-     merge _           _           = undefined--data MappingField =-  MappingField { mappingFieldName :: FieldName-               , fieldDefinition  :: FieldDefinition }-  deriving (Eq, Show)--{-| Support for type reification of 'Mapping's is currently incomplete, for-    now the mapping API verbiage expects a 'ToJSON'able blob.--    Indexes have mappings, mappings are schemas for the documents contained-    in the index. I'd recommend having only one mapping per index, always-    having a mapping, and keeping different kinds of documents separated-    if possible.--}-newtype Mapping =-  Mapping { mappingFields :: [MappingField] }-  deriving (Eq, Show)--data UpsertActionMetadata-  = UA_RetryOnConflict Int-  | UA_Version Int-  deriving (Eq, Show)--buildUpsertActionMetadata :: UpsertActionMetadata -> Pair-buildUpsertActionMetadata (UA_RetryOnConflict i) = "retry_on_conflict"  .= i-buildUpsertActionMetadata (UA_Version i)         = "_version"           .= i--data UpsertPayload-  = UpsertDoc Value-  | UpsertScript Bool Script Value-  deriving (Eq, Show)--data AllocationPolicy = AllocAll-                      -- ^ Allows shard allocation for all shards.-                      | AllocPrimaries-                      -- ^ Allows shard allocation only for primary shards.-                      | AllocNewPrimaries-                      -- ^ Allows shard allocation only for primary shards for new indices.-                      | AllocNone-                      -- ^ No shard allocation is allowed-                      deriving (Eq, Show, Generic)--instance ToJSON AllocationPolicy where-  toJSON AllocAll          = String "all"-  toJSON AllocPrimaries    = String "primaries"-  toJSON AllocNewPrimaries = String "new_primaries"-  toJSON AllocNone         = String "none"--instance FromJSON AllocationPolicy where-  parseJSON = withText "AllocationPolicy" parse-    where parse "all" = pure AllocAll-          parse "primaries" = pure AllocPrimaries-          parse "new_primaries" = pure AllocNewPrimaries-          parse "none" = pure AllocNone-          parse t = fail ("Invlaid AllocationPolicy: " <> show t)--{-| 'BulkOperation' is a sum type for expressing the four kinds of bulk-    operation index, create, delete, and update. 'BulkIndex' behaves like an-    "upsert", 'BulkCreate' will fail if a document already exists at the DocId.-    Consult the <http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/docs-bulk.html#docs-bulk Bulk API documentation>-    for further explanation.-    Warning: Bulk operations suffixed with @Auto@ rely on Elasticsearch to-    generate the id. Often, people use auto-generated identifiers when-    Elasticsearch is the only place that their data is stored. Do not let-    Elasticsearch be the only place your data is stored. It does not guarantee-    durability, and it may silently discard data.-    This <https://github.com/elastic/elasticsearch/issues/10708 issue> is-    discussed further on github.--}-data BulkOperation =-    BulkIndex  IndexName DocId Value-    -- ^ Create the document, replacing it if it already exists.-  | BulkIndexAuto IndexName Value-    -- ^ Create a document with an autogenerated id.-  | BulkIndexEncodingAuto IndexName Encoding-    -- ^ Create a document with an autogenerated id. Use fast JSON encoding.-  | BulkCreate IndexName DocId Value-    -- ^ Create a document, failing if it already exists.-  | BulkCreateEncoding IndexName DocId Encoding-    -- ^ Create a document, failing if it already exists. Use fast JSON encoding.-  | BulkDelete IndexName DocId-    -- ^ Delete the document-  | BulkUpdate IndexName DocId Value-    -- ^ Update the document, merging the new value with the existing one.-  | BulkUpsert IndexName DocId UpsertPayload [UpsertActionMetadata]-    -- ^ Update the document if it already exists, otherwise insert it.-    deriving (Eq, Show)--{-| 'EsResult' describes the standard wrapper JSON document that you see in-    successful Elasticsearch lookups or lookups that couldn't find the document.--}-data EsResult a = EsResult { _index      :: Text-                           , _type       :: Text-                           , _id         :: Text-                           , foundResult :: Maybe (EsResultFound a)} deriving (Eq, Show)--{-| 'EsResultFound' contains the document and its metadata inside of an-    'EsResult' when the document was successfully found.--}-data EsResultFound a =-  EsResultFound {  _version :: DocVersion-                , _source   :: a }-  deriving (Eq, Show)--instance (FromJSON a) => FromJSON (EsResult a) where-  parseJSON jsonVal@(Object v) = do-    found <- v .:? "found" .!= False-    fr <- if found-             then parseJSON jsonVal-             else return Nothing-    EsResult <$> v .:  "_index"   <*>-                 v .:  "_type"    <*>-                 v .:  "_id"      <*>-                 pure fr-  parseJSON _          = empty--instance (FromJSON a) => FromJSON (EsResultFound a) where-  parseJSON (Object v) = EsResultFound <$>-                         v .: "_version" <*>-                         v .: "_source"-  parseJSON _          = empty--{-| 'EsError' is the generic type that will be returned when there was a-    problem. If you can't parse the expected response, its a good idea to-    try parsing this.--}-data EsError =-  EsError { errorStatus  :: Int-          , errorMessage :: Text }-  deriving (Eq, Show)--instance FromJSON EsError where-  parseJSON (Object v) = EsError <$>-                         v .: "status" <*>-                         (v .: "error" <|> (v .: "error" >>= (.: "reason")))-  parseJSON _ = empty--{-| '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-  { esProtoExMessage :: !Text-  , esProtoExBody :: !LByteString-  } deriving (Eq, Show)--instance Exception EsProtocolException--data IndexAlias = IndexAlias { srcIndex   :: IndexName-                             , indexAlias :: IndexAliasName } deriving (Eq, Show)--data IndexAliasAction =-    AddAlias IndexAlias IndexAliasCreate-  | RemoveAlias IndexAlias-  deriving (Eq, Show)--data IndexAliasCreate =-  IndexAliasCreate { aliasCreateRouting :: Maybe AliasRouting-                   , aliasCreateFilter  :: Maybe Filter}-  deriving (Eq, Show)--data AliasRouting =-    AllAliasRouting RoutingValue-  | GranularAliasRouting (Maybe SearchAliasRouting) (Maybe IndexAliasRouting)-  deriving (Eq, Show)--newtype SearchAliasRouting =-  SearchAliasRouting (NonEmpty RoutingValue)-  deriving (Eq, Show, Generic)--instance ToJSON SearchAliasRouting where-  toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs))--instance FromJSON SearchAliasRouting where-  parseJSON = withText "SearchAliasRouting" parse-    where parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)--newtype IndexAliasRouting =-  IndexAliasRouting RoutingValue-  deriving (Eq, Show, Generic, ToJSON, FromJSON)--newtype RoutingValue =-  RoutingValue { routingValue :: Text }-  deriving (Eq, Show, ToJSON, FromJSON)--newtype IndexAliasesSummary =-  IndexAliasesSummary { indexAliasesSummary :: [IndexAliasSummary] }-  deriving (Eq, Show)--instance FromJSON IndexAliasesSummary where-  parseJSON = withObject "IndexAliasesSummary" parse-    where parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (X.toList o)-          go ixn = withObject "index aliases" $ \ia -> do-                     aliases <- ia .:? "aliases" .!= mempty-                     forM (HM.toList aliases) $ \(aName, v) -> do-                       let indexAlias = IndexAlias (IndexName $ toText ixn) (IndexAliasName (IndexName $ toText aName))-                       IndexAliasSummary indexAlias <$> parseJSON v---instance ToJSON IndexAliasAction where-  toJSON (AddAlias ia opts) = object ["add" .= (iaObj <> optsObj)]-    where Object iaObj = toJSON ia-          Object optsObj = toJSON opts-  toJSON (RemoveAlias ia) = object ["remove" .= iaObj]-    where Object iaObj = toJSON ia--instance ToJSON IndexAlias where-  toJSON IndexAlias {..} = object ["index" .= srcIndex-                                  , "alias" .= indexAlias-                                  ]--instance ToJSON IndexAliasCreate where-  toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj)-    where filterObj = maybe mempty (X.singleton "filter" . toJSON) aliasCreateFilter-          Object routingObj = maybe (Object mempty) toJSON aliasCreateRouting--instance ToJSON AliasRouting where-  toJSON (AllAliasRouting v) = object ["routing" .= v]-  toJSON (GranularAliasRouting srch idx) = object (catMaybes prs)-    where prs = [("search_routing" .=) <$> srch-                ,("index_routing" .=) <$> idx]--instance FromJSON AliasRouting where-  parseJSON = withObject "AliasRouting" parse-    where parse o = parseAll o <|> parseGranular o-          parseAll o = AllAliasRouting <$> o .: "routing"-          parseGranular o = do-            sr <- o .:? "search_routing"-            ir <- o .:? "index_routing"-            if isNothing sr && isNothing ir-               then fail "Both search_routing and index_routing can't be blank"-               else return (GranularAliasRouting sr ir)--instance FromJSON IndexAliasCreate where-  parseJSON v = withObject "IndexAliasCreate" parse v-    where parse o = IndexAliasCreate <$> optional (parseJSON v)-                                     <*> o .:? "filter"--{-| 'IndexAliasSummary' is a summary of an index alias configured for a server. -}-data IndexAliasSummary = IndexAliasSummary-  { indexAliasSummaryAlias  :: IndexAlias-  , indexAliasSummaryCreate :: IndexAliasCreate }-  deriving (Eq, Show)--{-| 'DocVersion' is an integer version number for a document between 1-and 9.2e+18 used for <<https://www.elastic.co/guide/en/elasticsearch/guide/current/optimistic-concurrency-control.html optimistic concurrency control>>.--}-newtype DocVersion = DocVersion {-      docVersionNumber :: Int-    } deriving (Eq, Show, Ord, ToJSON)---- | Smart constructor for in-range doc version-mkDocVersion :: Int -> Maybe DocVersion-mkDocVersion i-  |    i >= docVersionNumber minBound-    && i <= docVersionNumber maxBound =-    Just $ DocVersion i-  | otherwise = Nothing--instance Bounded DocVersion where-  minBound = DocVersion 1-  maxBound = DocVersion 9200000000000000000 -- 9.2e+18--instance Enum DocVersion where-  succ x-    | x /= maxBound = DocVersion (succ $ docVersionNumber x)-    | otherwise     = succError "DocVersion"-  pred x-    | x /= minBound = DocVersion (pred $ docVersionNumber x)-    | otherwise     = predError "DocVersion"-  toEnum i =-    fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i-  fromEnum = docVersionNumber-  enumFrom = boundedEnumFrom-  enumFromThen = boundedEnumFromThen--instance FromJSON DocVersion where-  parseJSON v = do-    i <- parseJSON v-    maybe (fail "DocVersion out of range") return $ mkDocVersion i--{-| 'ExternalDocVersion' is a convenience wrapper if your code uses its-own version numbers instead of ones from ES.--}-newtype ExternalDocVersion = ExternalDocVersion DocVersion-    deriving (Eq, Show, Ord, Bounded, Enum, ToJSON)--{-| 'VersionControl' is specified when indexing documents as a-optimistic concurrency control.--}-data VersionControl = NoVersionControl-                    -- ^ Don't send a version. This is a pure overwrite.-                    | InternalVersion DocVersion-                    -- ^ Use the default ES versioning scheme. Only-                    -- index the document if the version is the same-                    -- as the one specified. Only applicable to-                    -- updates, as you should be getting Version from-                    -- a search result.-                    | ExternalGT ExternalDocVersion-                    -- ^ Use your own version numbering. Only index-                    -- the document if the version is strictly higher-                    -- OR the document doesn't exist. The given-                    -- version will be used as the new version number-                    -- for the stored document. N.B. All updates must-                    -- increment this number, meaning there is some-                    -- global, external ordering of updates.-                    | ExternalGTE ExternalDocVersion-                    -- ^ Use your own version numbering. Only index-                    -- the document if the version is equal or higher-                    -- than the stored version. Will succeed if there-                    -- is no existing document. The given version will-                    -- be used as the new version number for the-                    -- stored document. Use with care, as this could-                    -- result in data loss.-                    | ForceVersion ExternalDocVersion-                    -- ^ The document will always be indexed and the-                    -- given version will be the new version. This is-                    -- typically used for correcting errors. Use with-                    -- care, as this could result in data loss.-                    deriving (Eq, Show, Ord)--data JoinRelation-  = ParentDocument FieldName RelationName-  | ChildDocument FieldName RelationName DocId-  deriving (Show, Eq)--{-| 'IndexDocumentSettings' are special settings supplied when indexing-a document. For the best backwards compatiblity when new fields are-added, you should probably prefer to start with 'defaultIndexDocumentSettings'--}-data IndexDocumentSettings =-  IndexDocumentSettings { idsVersionControl :: VersionControl-                        , idsJoinRelation   :: Maybe JoinRelation-                        } deriving (Eq, Show)--{-| Reasonable default settings. Chooses no version control and no parent.--}-defaultIndexDocumentSettings :: IndexDocumentSettings-defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing--{-| 'IndexSelection' is used for APIs which take a single index, a list of-    indexes, or the special @_all@ index.--}---TODO: this does not fully support <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/multi-index.html multi-index syntax>. It wouldn't be too hard to implement but you'd have to add the optional parameters (ignore_unavailable, allow_no_indices, expand_wildcards) to any APIs using it. Also would be a breaking API.-data IndexSelection =-    IndexList (NonEmpty IndexName)-  | AllIndexes-  deriving (Eq, Show)--{-| 'NodeSelection' is used for most cluster APIs. See <https://www.elastic.co/guide/en/elasticsearch/reference/current/cluster.html#cluster-nodes here> for more details.--}-data NodeSelection =-    LocalNode-    -- ^ Whatever node receives this request-  | NodeList (NonEmpty NodeSelector)-  | AllNodes-  deriving (Eq, Show)----- | An exact match or pattern to identify a node. Note that All of--- these options support wildcarding, so your node name, server, attr--- name can all contain * characters to be a fuzzy match.-data NodeSelector =-    NodeByName NodeName-  | NodeByFullNodeId FullNodeId-  | NodeByHost Server-    -- ^ e.g. 10.0.0.1 or even 10.0.0.*-  | NodeByAttribute NodeAttrName Text-    -- ^ NodeAttrName can be a pattern, e.g. rack*. The value can too.-  deriving (Eq, Show)--{-| 'TemplateName' is used to describe which template to query/create/delete--}-newtype TemplateName = TemplateName Text deriving (Eq, Show, Generic, ToJSON, FromJSON)--{-| 'IndexPattern' represents a pattern which is matched against index names--}-newtype IndexPattern = IndexPattern Text deriving (Eq, Show, Generic, ToJSON, FromJSON)---- | Username type used for HTTP Basic authentication. See 'basicAuthHook'.-newtype EsUsername = EsUsername { esUsername :: Text } deriving (Read, Show, Eq)---- | Password type used for HTTP Basic authentication. See 'basicAuthHook'.-newtype EsPassword = EsPassword { esPassword :: Text } deriving (Read, Show, Eq)---data SnapshotRepoSelection =-    SnapshotRepoList (NonEmpty SnapshotRepoPattern)-  | AllSnapshotRepos-  deriving (Eq, Show)----- | Either specifies an exact repo name or one with globs in it,--- e.g. @RepoPattern "foo*"@ __NOTE__: Patterns are not supported on ES < 1.7-data SnapshotRepoPattern =-    ExactRepo SnapshotRepoName-  | RepoPattern Text-  deriving (Eq, Show)---- | The unique name of a snapshot repository.-newtype SnapshotRepoName =-  SnapshotRepoName { snapshotRepoName :: Text }-  deriving (Eq, Ord, Show, Generic, ToJSON, FromJSON)----- | A generic representation of a snapshot repo. This is what gets--- sent to and parsed from the server. For repo types enabled by--- plugins that aren't exported by this library, consider making a--- custom type which implements 'SnapshotRepo'. If it is a common repo--- type, consider submitting a pull request to have it included in the--- library proper-data GenericSnapshotRepo = GenericSnapshotRepo {-      gSnapshotRepoName     :: SnapshotRepoName-    , gSnapshotRepoType     :: SnapshotRepoType-    , gSnapshotRepoSettings :: GenericSnapshotRepoSettings-    } deriving (Eq, Show)---instance SnapshotRepo GenericSnapshotRepo where-  toGSnapshotRepo = id-  fromGSnapshotRepo = Right---newtype SnapshotRepoType =-  SnapshotRepoType { snapshotRepoType :: Text }-  deriving (Eq, Ord, Show, ToJSON, FromJSON)----- | Opaque representation of snapshot repo settings. Instances of--- 'SnapshotRepo' will produce this.-newtype GenericSnapshotRepoSettings =-  GenericSnapshotRepoSettings { gSnapshotRepoSettingsObject :: Object }-  deriving (Eq, Show, ToJSON)--- -- Regardless of whether you send strongly typed json, my version of- -- ES sends back stringly typed json in the settings, e.g. booleans- -- as strings, so we'll try to convert them.-instance FromJSON GenericSnapshotRepoSettings where-  parseJSON = fmap (GenericSnapshotRepoSettings . fmap unStringlyTypeJSON). parseJSON---- | The result of running 'verifySnapshotRepo'.-newtype SnapshotVerification =-  SnapshotVerification {-    snapshotNodeVerifications :: [SnapshotNodeVerification]-  } deriving (Eq, Show)---instance FromJSON SnapshotVerification where-  parseJSON = withObject "SnapshotVerification" parse-    where-      parse o = do-        o2 <- o .: "nodes"-        SnapshotVerification <$> mapM (uncurry parse') (HM.toList o2)-      parse' rawFullId = withObject "SnapshotNodeVerification" $ \o ->-        SnapshotNodeVerification (FullNodeId rawFullId) <$> o .: "name"----- | A node that has verified a snapshot-data SnapshotNodeVerification = SnapshotNodeVerification {-      snvFullId   :: FullNodeId-    , snvNodeName :: NodeName-    } deriving (Eq, Show)----- | Unique, automatically-generated name assigned to nodes that are--- usually returned in node-oriented APIs.-newtype FullNodeId = FullNodeId { fullNodeId :: Text }-                   deriving (Eq, Ord, Show, FromJSON)----- | A human-readable node name that is supplied by the user in the--- node config or automatically generated by Elasticsearch.-newtype NodeName = NodeName { nodeName :: Text }-                 deriving (Eq, Ord, Show, FromJSON)--newtype ClusterName = ClusterName { clusterName :: Text }-                 deriving (Eq, Ord, Show, FromJSON)--data NodesInfo = NodesInfo {-      nodesInfo        :: [NodeInfo]-    , nodesClusterName :: ClusterName-    } deriving (Eq, Show)--data NodesStats = NodesStats {-      nodesStats            :: [NodeStats]-    , nodesStatsClusterName :: ClusterName-    } deriving (Eq, Show)--data NodeStats = NodeStats {-      nodeStatsName          :: NodeName-    , nodeStatsFullId        :: FullNodeId-    , nodeStatsBreakersStats :: Maybe NodeBreakersStats-    , nodeStatsHTTP          :: NodeHTTPStats-    , nodeStatsTransport     :: NodeTransportStats-    , nodeStatsFS            :: NodeFSStats-    , nodeStatsNetwork       :: Maybe NodeNetworkStats-    , nodeStatsThreadPool    :: Map Text NodeThreadPoolStats-    , nodeStatsJVM           :: NodeJVMStats-    , nodeStatsProcess       :: NodeProcessStats-    , nodeStatsOS            :: NodeOSStats-    , nodeStatsIndices       :: NodeIndicesStats-    } deriving (Eq, Show)--data NodeBreakersStats = NodeBreakersStats {-      nodeStatsParentBreaker    :: NodeBreakerStats-    , nodeStatsRequestBreaker   :: NodeBreakerStats-    , nodeStatsFieldDataBreaker :: NodeBreakerStats-    } deriving (Eq, Show)--data NodeBreakerStats = NodeBreakerStats {-      nodeBreakersTripped   :: Int-    , nodeBreakersOverhead  :: Double-    , nodeBreakersEstSize   :: Bytes-    , nodeBreakersLimitSize :: Bytes-    } deriving (Eq, Show)--data NodeHTTPStats = NodeHTTPStats {-      nodeHTTPTotalOpened :: Int-    , nodeHTTPCurrentOpen :: Int-    } deriving (Eq, Show)--data NodeTransportStats = NodeTransportStats {-      nodeTransportTXSize     :: Bytes-    , nodeTransportCount      :: Int-    , nodeTransportRXSize     :: Bytes-    , nodeTransportRXCount    :: Int-    , nodeTransportServerOpen :: Int-    } deriving (Eq, Show)--data NodeFSStats = NodeFSStats {-      nodeFSDataPaths :: [NodeDataPathStats]-    , nodeFSTotal     :: NodeFSTotalStats-    , nodeFSTimestamp :: UTCTime-    } deriving (Eq, Show)--data NodeDataPathStats = NodeDataPathStats {-      nodeDataPathDiskServiceTime :: Maybe Double-    , nodeDataPathDiskQueue       :: Maybe Double-    , nodeDataPathIOSize          :: Maybe Bytes-    , nodeDataPathWriteSize       :: Maybe Bytes-    , nodeDataPathReadSize        :: Maybe Bytes-    , nodeDataPathIOOps           :: Maybe Int-    , nodeDataPathWrites          :: Maybe Int-    , nodeDataPathReads           :: Maybe Int-    , nodeDataPathAvailable       :: Bytes-    , nodeDataPathFree            :: Bytes-    , nodeDataPathTotal           :: Bytes-    , nodeDataPathType            :: Maybe Text-    , nodeDataPathDevice          :: Maybe Text-    , nodeDataPathMount           :: Text-    , nodeDataPathPath            :: Text-    } deriving (Eq, Show)--data NodeFSTotalStats = NodeFSTotalStats {-      nodeFSTotalDiskServiceTime :: Maybe Double-    , nodeFSTotalDiskQueue       :: Maybe Double-    , nodeFSTotalIOSize          :: Maybe Bytes-    , nodeFSTotalWriteSize       :: Maybe Bytes-    , nodeFSTotalReadSize        :: Maybe Bytes-    , nodeFSTotalIOOps           :: Maybe Int-    , nodeFSTotalWrites          :: Maybe Int-    , nodeFSTotalReads           :: Maybe Int-    , nodeFSTotalAvailable       :: Bytes-    , nodeFSTotalFree            :: Bytes-    , nodeFSTotalTotal           :: Bytes-    } deriving (Eq, Show)--data NodeNetworkStats = NodeNetworkStats {-      nodeNetTCPOutRSTs      :: Int-    , nodeNetTCPInErrs       :: Int-    , nodeNetTCPAttemptFails :: Int-    , nodeNetTCPEstabResets  :: Int-    , nodeNetTCPRetransSegs  :: Int-    , nodeNetTCPOutSegs      :: Int-    , nodeNetTCPInSegs       :: Int-    , nodeNetTCPCurrEstab    :: Int-    , nodeNetTCPPassiveOpens :: Int-    , nodeNetTCPActiveOpens  :: Int-    } deriving (Eq, Show)--data NodeThreadPoolStats = NodeThreadPoolStats {-      nodeThreadPoolCompleted :: Int-    , nodeThreadPoolLargest   :: Int-    , nodeThreadPoolRejected  :: Int-    , nodeThreadPoolActive    :: Int-    , nodeThreadPoolQueue     :: Int-    , nodeThreadPoolThreads   :: Int-    } deriving (Eq, Show)--data NodeJVMStats = NodeJVMStats {-      nodeJVMStatsMappedBufferPool :: JVMBufferPoolStats-    , nodeJVMStatsDirectBufferPool :: JVMBufferPoolStats-    , nodeJVMStatsGCOldCollector   :: JVMGCStats-    , nodeJVMStatsGCYoungCollector :: JVMGCStats-    , nodeJVMStatsPeakThreadsCount :: Int-    , nodeJVMStatsThreadsCount     :: Int-    , nodeJVMStatsOldPool          :: JVMPoolStats-    , nodeJVMStatsSurvivorPool     :: JVMPoolStats-    , nodeJVMStatsYoungPool        :: JVMPoolStats-    , nodeJVMStatsNonHeapCommitted :: Bytes-    , nodeJVMStatsNonHeapUsed      :: Bytes-    , nodeJVMStatsHeapMax          :: Bytes-    , nodeJVMStatsHeapCommitted    :: Bytes-    , nodeJVMStatsHeapUsedPercent  :: Int-    , nodeJVMStatsHeapUsed         :: Bytes-    , nodeJVMStatsUptime           :: NominalDiffTime-    , nodeJVMStatsTimestamp        :: UTCTime-    } deriving (Eq, Show)--data JVMBufferPoolStats = JVMBufferPoolStats {-      jvmBufferPoolStatsTotalCapacity :: Bytes-    , jvmBufferPoolStatsUsed          :: Bytes-    , jvmBufferPoolStatsCount         :: Int-    } deriving (Eq, Show)--data JVMGCStats = JVMGCStats {-      jvmGCStatsCollectionTime  :: NominalDiffTime-    , jvmGCStatsCollectionCount :: Int-    } deriving (Eq, Show)--data JVMPoolStats = JVMPoolStats {-      jvmPoolStatsPeakMax  :: Bytes-    , jvmPoolStatsPeakUsed :: Bytes-    , jvmPoolStatsMax      :: Bytes-    , jvmPoolStatsUsed     :: Bytes-    } deriving (Eq, Show)--data NodeProcessStats = NodeProcessStats {-      nodeProcessTimestamp       :: UTCTime-    , nodeProcessOpenFDs         :: Int-    , nodeProcessMaxFDs          :: Int-    , nodeProcessCPUPercent      :: Int-    , nodeProcessCPUTotal        :: NominalDiffTime-    , nodeProcessMemTotalVirtual :: Bytes-    } deriving (Eq, Show)--data NodeOSStats = NodeOSStats {-      nodeOSTimestamp      :: UTCTime-    , nodeOSCPUPercent     :: Int-    , nodeOSLoad           :: Maybe LoadAvgs-    , nodeOSMemTotal       :: Bytes-    , nodeOSMemFree        :: Bytes-    , nodeOSMemFreePercent :: Int-    , nodeOSMemUsed        :: Bytes-    , nodeOSMemUsedPercent :: Int-    , nodeOSSwapTotal      :: Bytes-    , nodeOSSwapFree       :: Bytes-    , nodeOSSwapUsed       :: Bytes-    } deriving (Eq, Show)--data LoadAvgs = LoadAvgs {-     loadAvg1Min  :: Double-   , loadAvg5Min  :: Double-   , loadAvg15Min :: Double-   } deriving (Eq, Show)--data NodeIndicesStats = NodeIndicesStats {-      nodeIndicesStatsRecoveryThrottleTime    :: Maybe NominalDiffTime-    , nodeIndicesStatsRecoveryCurrentAsTarget :: Maybe Int-    , nodeIndicesStatsRecoveryCurrentAsSource :: Maybe Int-    , nodeIndicesStatsQueryCacheMisses        :: Maybe Int-    , nodeIndicesStatsQueryCacheHits          :: Maybe Int-    , nodeIndicesStatsQueryCacheEvictions     :: Maybe Int-    , nodeIndicesStatsQueryCacheSize          :: Maybe Bytes-    , nodeIndicesStatsSuggestCurrent          :: Maybe Int-    , nodeIndicesStatsSuggestTime             :: Maybe NominalDiffTime-    , nodeIndicesStatsSuggestTotal            :: Maybe Int-    , nodeIndicesStatsTranslogSize            :: Bytes-    , nodeIndicesStatsTranslogOps             :: Int-    , nodeIndicesStatsSegFixedBitSetMemory    :: Maybe Bytes-    , nodeIndicesStatsSegVersionMapMemory     :: Bytes-    , nodeIndicesStatsSegIndexWriterMaxMemory :: Maybe Bytes-    , nodeIndicesStatsSegIndexWriterMemory    :: Bytes-    , nodeIndicesStatsSegMemory               :: Bytes-    , nodeIndicesStatsSegCount                :: Int-    , nodeIndicesStatsCompletionSize          :: Bytes-    , nodeIndicesStatsPercolateQueries        :: Maybe Int-    , nodeIndicesStatsPercolateMemory         :: Maybe Bytes-    , nodeIndicesStatsPercolateCurrent        :: Maybe Int-    , nodeIndicesStatsPercolateTime           :: Maybe NominalDiffTime-    , nodeIndicesStatsPercolateTotal          :: Maybe Int-    , nodeIndicesStatsFieldDataEvictions      :: Int-    , nodeIndicesStatsFieldDataMemory         :: Bytes-    , nodeIndicesStatsWarmerTotalTime         :: NominalDiffTime-    , nodeIndicesStatsWarmerTotal             :: Int-    , nodeIndicesStatsWarmerCurrent           :: Int-    , nodeIndicesStatsFlushTotalTime          :: NominalDiffTime-    , nodeIndicesStatsFlushTotal              :: Int-    , nodeIndicesStatsRefreshTotalTime        :: NominalDiffTime-    , nodeIndicesStatsRefreshTotal            :: Int-    , nodeIndicesStatsMergesTotalSize         :: Bytes-    , nodeIndicesStatsMergesTotalDocs         :: Int-    , nodeIndicesStatsMergesTotalTime         :: NominalDiffTime-    , nodeIndicesStatsMergesTotal             :: Int-    , nodeIndicesStatsMergesCurrentSize       :: Bytes-    , nodeIndicesStatsMergesCurrentDocs       :: Int-    , nodeIndicesStatsMergesCurrent           :: Int-    , nodeIndicesStatsSearchFetchCurrent      :: Int-    , nodeIndicesStatsSearchFetchTime         :: NominalDiffTime-    , nodeIndicesStatsSearchFetchTotal        :: Int-    , nodeIndicesStatsSearchQueryCurrent      :: Int-    , nodeIndicesStatsSearchQueryTime         :: NominalDiffTime-    , nodeIndicesStatsSearchQueryTotal        :: Int-    , nodeIndicesStatsSearchOpenContexts      :: Int-    , nodeIndicesStatsGetCurrent              :: Int-    , nodeIndicesStatsGetMissingTime          :: NominalDiffTime-    , nodeIndicesStatsGetMissingTotal         :: Int-    , nodeIndicesStatsGetExistsTime           :: NominalDiffTime-    , nodeIndicesStatsGetExistsTotal          :: Int-    , nodeIndicesStatsGetTime                 :: NominalDiffTime-    , nodeIndicesStatsGetTotal                :: Int-    , nodeIndicesStatsIndexingThrottleTime    :: Maybe NominalDiffTime-    , nodeIndicesStatsIndexingIsThrottled     :: Maybe Bool-    , nodeIndicesStatsIndexingNoopUpdateTotal :: Maybe Int-    , nodeIndicesStatsIndexingDeleteCurrent   :: Int-    , nodeIndicesStatsIndexingDeleteTime      :: NominalDiffTime-    , nodeIndicesStatsIndexingDeleteTotal     :: Int-    , nodeIndicesStatsIndexingIndexCurrent    :: Int-    , nodeIndicesStatsIndexingIndexTime       :: NominalDiffTime-    , nodeIndicesStatsIndexingTotal           :: Int-    , nodeIndicesStatsStoreThrottleTime       :: Maybe NominalDiffTime-    , nodeIndicesStatsStoreSize               :: Bytes-    , nodeIndicesStatsDocsDeleted             :: Int-    , nodeIndicesStatsDocsCount               :: Int-    } deriving (Eq, Show)---- | A quirky address format used throughout Elasticsearch. An example--- would be inet[/1.1.1.1:9200]. inet may be a placeholder for a--- <https://en.wikipedia.org/wiki/Fully_qualified_domain_name FQDN>.-newtype EsAddress = EsAddress { esAddress :: Text }-                 deriving (Eq, Ord, Show, FromJSON)---- | Typically a 7 character hex string.-newtype BuildHash = BuildHash { buildHash :: Text }-                 deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)--newtype PluginName = PluginName { pluginName :: Text }-                 deriving (Eq, Ord, Show, FromJSON)--data NodeInfo = NodeInfo {-      nodeInfoHTTPAddress      :: Maybe EsAddress-    , nodeInfoBuild            :: BuildHash-    , nodeInfoESVersion        :: VersionNumber-    , nodeInfoIP               :: Server-    , nodeInfoHost             :: Server-    , nodeInfoTransportAddress :: EsAddress-    , nodeInfoName             :: NodeName-    , nodeInfoFullId           :: FullNodeId-    , nodeInfoPlugins          :: [NodePluginInfo]-    , nodeInfoHTTP             :: NodeHTTPInfo-    , nodeInfoTransport        :: NodeTransportInfo-    , nodeInfoNetwork          :: Maybe NodeNetworkInfo-    , nodeInfoThreadPool       :: Map Text NodeThreadPoolInfo-    , nodeInfoJVM              :: NodeJVMInfo-    , nodeInfoProcess          :: NodeProcessInfo-    , nodeInfoOS               :: NodeOSInfo-    , nodeInfoSettings         :: Object-    -- ^ The members of the settings objects are not consistent,-    -- dependent on plugins, etc.-    } deriving (Eq, Show)--data NodePluginInfo = NodePluginInfo {-      nodePluginSite        :: Maybe Bool-    -- ^ Is this a site plugin?-    , nodePluginJVM         :: Maybe Bool-    -- ^ Is this plugin running on the JVM-    , nodePluginDescription :: Text-    , nodePluginVersion     :: MaybeNA VersionNumber-    , nodePluginName        :: PluginName-    } deriving (Eq, Show)--data NodeHTTPInfo = NodeHTTPInfo {-      nodeHTTPMaxContentLength :: Bytes-    , nodeHTTPpublishAddress :: EsAddress-    , nodeHTTPbound_address :: [EsAddress]-    } deriving (Eq, Show)--data NodeTransportInfo = NodeTransportInfo {-      nodeTransportProfiles       :: [BoundTransportAddress]-    , nodeTransportPublishAddress :: EsAddress-    , nodeTransportBoundAddress   :: [EsAddress]-    } deriving (Eq, Show)--data BoundTransportAddress = BoundTransportAddress {-      publishAddress :: EsAddress-    , boundAddress   :: [EsAddress]-    } deriving (Eq, Show)--data NodeNetworkInfo = NodeNetworkInfo {-      nodeNetworkPrimaryInterface :: NodeNetworkInterface-    , nodeNetworkRefreshInterval  :: NominalDiffTime-    } deriving (Eq, Show)--newtype MacAddress = MacAddress { macAddress :: Text }-                 deriving (Eq, Ord, Show, FromJSON)--newtype NetworkInterfaceName = NetworkInterfaceName { networkInterfaceName :: Text }-                 deriving (Eq, Ord, Show, FromJSON)--data NodeNetworkInterface = NodeNetworkInterface {-      nodeNetIfaceMacAddress :: MacAddress-    , nodeNetIfaceName       :: NetworkInterfaceName-    , nodeNetIfaceAddress    :: Server-    } deriving (Eq, Show)--data ThreadPool = ThreadPool {-      nodeThreadPoolName :: Text-    , nodeThreadPoolInfo :: NodeThreadPoolInfo-} deriving (Eq, Show)--data NodeThreadPoolInfo = NodeThreadPoolInfo {-      nodeThreadPoolQueueSize :: ThreadPoolSize-    , nodeThreadPoolKeepalive :: Maybe NominalDiffTime-    , nodeThreadPoolMin       :: Maybe Int-    , nodeThreadPoolMax       :: Maybe Int-    , nodeThreadPoolType      :: ThreadPoolType-    } deriving (Eq, Show)--data ThreadPoolSize = ThreadPoolBounded Int-                    | ThreadPoolUnbounded-                    deriving (Eq, Show)--data ThreadPoolType = ThreadPoolScaling-                    | ThreadPoolFixed-                    | ThreadPoolCached-                    | ThreadPoolFixedAutoQueueSize-                    deriving (Eq, Show)--data NodeJVMInfo = NodeJVMInfo {-      nodeJVMInfoMemoryPools             :: [JVMMemoryPool]-    , nodeJVMInfoMemoryPoolsGCCollectors :: [JVMGCCollector]-    , nodeJVMInfoMemoryInfo              :: JVMMemoryInfo-    , nodeJVMInfoStartTime               :: UTCTime-    , nodeJVMInfoVMVendor                :: Text-    , nodeJVMVMVersion                   :: VMVersion-    -- ^ JVM doesn't seme to follow normal version conventions-    , nodeJVMVMName                      :: Text-    , nodeJVMVersion                     :: JVMVersion-    , nodeJVMPID                         :: PID-    } deriving (Eq, Show)---- | We cannot parse JVM version numbers and we're not going to try.-newtype JVMVersion =-  JVMVersion { unJVMVersion :: Text }-  deriving (Eq, Show)--instance FromJSON JVMVersion where-  parseJSON = withText "JVMVersion" (pure . JVMVersion)--data JVMMemoryInfo = JVMMemoryInfo {-      jvmMemoryInfoDirectMax   :: Bytes-    , jvmMemoryInfoNonHeapMax  :: Bytes-    , jvmMemoryInfoNonHeapInit :: Bytes-    , jvmMemoryInfoHeapMax     :: Bytes-    , jvmMemoryInfoHeapInit    :: Bytes-    } deriving (Eq, Show)---- VM version numbers don't appear to be SemVer--- so we're special casing this jawn.-newtype VMVersion =-  VMVersion { unVMVersion :: Text }-  deriving (Eq, Show)--instance ToJSON VMVersion where-  toJSON = toJSON . unVMVersion--instance FromJSON VMVersion where-  parseJSON = withText "VMVersion" (pure . VMVersion)--newtype JVMMemoryPool = JVMMemoryPool {-      jvmMemoryPool :: Text-    } deriving (Eq, Show, FromJSON)--newtype JVMGCCollector = JVMGCCollector {-      jvmGCCollector :: Text-    } deriving (Eq, Show, FromJSON)--newtype PID = PID {-      pid :: Int-    } deriving (Eq, Show, FromJSON)--data NodeOSInfo = NodeOSInfo {-      nodeOSRefreshInterval     :: NominalDiffTime-    , nodeOSName                :: Text-    , nodeOSArch                :: Text-    , nodeOSVersion             :: Text -- semver breaks on "5.10.60.1-microsoft-standard-WSL2"-    , nodeOSAvailableProcessors :: Int-    , nodeOSAllocatedProcessors :: Int-    } deriving (Eq, Show)--data CPUInfo = CPUInfo {-      cpuCacheSize      :: Bytes-    , cpuCoresPerSocket :: Int-    , cpuTotalSockets   :: Int-    , cpuTotalCores     :: Int-    , cpuMHZ            :: Int-    , cpuModel          :: Text-    , cpuVendor         :: Text-    } deriving (Eq, Show)--data NodeProcessInfo = NodeProcessInfo {-      nodeProcessMLockAll           :: Bool-    -- ^ See <https://www.elastic.co/guide/en/elasticsearch/reference/current/setup-configuration.html>-    , nodeProcessMaxFileDescriptors :: Maybe Int-    , nodeProcessId                 :: PID-    , nodeProcessRefreshInterval    :: NominalDiffTime-    } deriving (Eq, Show)--data ShardResult =-  ShardResult { shardTotal       :: Int-              , shardsSuccessful :: Int-              , shardsSkipped    :: Int-              , shardsFailed     :: Int } deriving (Eq, Show)--instance FromJSON ShardResult where-  parseJSON (Object v) = ShardResult       <$>-                         v .: "total"      <*>-                         v .: "successful" <*>-                         v .: "skipped"    <*>-                         v .: "failed"-  parseJSON _          = empty--data SnapshotState = SnapshotInit-                   | SnapshotStarted-                   | SnapshotSuccess-                   | SnapshotFailed-                   | SnapshotAborted-                   | SnapshotMissing-                   | SnapshotWaiting-                   deriving (Eq, Show)--instance FromJSON SnapshotState where-  parseJSON = withText "SnapshotState" parse-    where-      parse "INIT"    = return SnapshotInit-      parse "STARTED" = return SnapshotStarted-      parse "SUCCESS" = return SnapshotSuccess-      parse "FAILED"  = return SnapshotFailed-      parse "ABORTED" = return SnapshotAborted-      parse "MISSING" = return SnapshotMissing-      parse "WAITING" = return SnapshotWaiting-      parse t         = fail ("Invalid snapshot state " <> T.unpack t)---data SnapshotRestoreSettings = SnapshotRestoreSettings {-      snapRestoreWaitForCompletion      :: Bool-      -- ^ Should the API call return immediately after initializing-      -- the restore or wait until completed? Note that if this is-      -- enabled, it could wait a long time, so you should adjust your-      -- 'ManagerSettings' accordingly to set long timeouts or-      -- explicitly handle timeouts.-    , snapRestoreIndices                :: Maybe IndexSelection-    -- ^ Nothing will restore all indices in the snapshot. Just [] is-    -- permissable and will essentially be a no-op restore.-    , snapRestoreIgnoreUnavailable      :: Bool-    -- ^ If set to True, any indices that do not exist will be ignored-    -- during snapshot rather than failing the restore.-    , snapRestoreIncludeGlobalState     :: Bool-    -- ^ If set to false, will ignore any global state in the snapshot-    -- and will not restore it.-    , snapRestoreRenamePattern          :: Maybe RestoreRenamePattern-    -- ^ A regex pattern for matching indices. Used with-    -- 'snapRestoreRenameReplacement', the restore can reference the-    -- matched index and create a new index name upon restore.-    , snapRestoreRenameReplacement      :: Maybe (NonEmpty RestoreRenameToken)-    -- ^ Expression of how index renames should be constructed.-    , snapRestorePartial                :: Bool-    -- ^ If some indices fail to restore, should the process proceed?-    , snapRestoreIncludeAliases         :: Bool-    -- ^ Should the restore also restore the aliases captured in the-    -- snapshot.-    , snapRestoreIndexSettingsOverrides :: Maybe RestoreIndexSettings-    -- ^ Settings to apply during the restore process. __NOTE:__ This-    -- option is not supported in ES < 1.5 and should be set to-    -- Nothing in that case.-    , snapRestoreIgnoreIndexSettings    :: Maybe (NonEmpty Text)-    -- ^ This type could be more rich but it isn't clear which-    -- settings are allowed to be ignored during restore, so we're-    -- going with including this feature in a basic form rather than-    -- omitting it. One example here would be-    -- "index.refresh_interval". Any setting specified here will-    -- revert back to the server default during the restore process.-    } deriving (Eq, Show)--newtype SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings-  { repoUpdateVerify :: Bool-    -- ^ After creation/update, synchronously check that nodes can-    -- write to this repo. Defaults to True. You may use False if you-    -- need a faster response and plan on verifying manually later-    -- with 'verifySnapshotRepo'.-  } deriving (Eq, Show)----- | Reasonable defaults for repo creation/update------ * repoUpdateVerify True-defaultSnapshotRepoUpdateSettings :: SnapshotRepoUpdateSettings-defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True----- | A filesystem-based snapshot repo that ships with--- Elasticsearch. This is an instance of 'SnapshotRepo' so it can be--- used with 'updateSnapshotRepo'-data FsSnapshotRepo = FsSnapshotRepo {-      fsrName                   :: SnapshotRepoName-    , fsrLocation               :: FilePath-    , fsrCompressMetadata       :: Bool-    , fsrChunkSize              :: Maybe Bytes-    -- ^ Size by which to split large files during snapshotting.-    , fsrMaxRestoreBytesPerSec  :: Maybe Bytes-    -- ^ Throttle node restore rate. If not supplied, defaults to 40mb/sec-    , fsrMaxSnapshotBytesPerSec :: Maybe Bytes-    -- ^ Throttle node snapshot rate. If not supplied, defaults to 40mb/sec-    } deriving (Eq, Show, Generic)---instance SnapshotRepo FsSnapshotRepo where-  toGSnapshotRepo FsSnapshotRepo {..} =-    GenericSnapshotRepo fsrName fsRepoType (GenericSnapshotRepoSettings settings)-    where-      Object settings = object $ [ "location" .= fsrLocation-                                 , "compress" .= fsrCompressMetadata-                                 ] ++ optionalPairs-      optionalPairs = catMaybes [ ("chunk_size" .=) <$> fsrChunkSize-                                , ("max_restore_bytes_per_sec" .=) <$> fsrMaxRestoreBytesPerSec-                                , ("max_snapshot_bytes_per_sec" .=) <$> fsrMaxSnapshotBytesPerSec-                                ]-  fromGSnapshotRepo GenericSnapshotRepo {..}-    | gSnapshotRepoType == fsRepoType = do-      let o = gSnapshotRepoSettingsObject gSnapshotRepoSettings-      parseRepo $-        FsSnapshotRepo gSnapshotRepoName <$> o .: "location"-                                         <*> o .:? "compress" .!= False-                                         <*> o .:? "chunk_size"-                                         <*> o .:? "max_restore_bytes_per_sec"-                                         <*> o .:? "max_snapshot_bytes_per_sec"-    | otherwise = Left (RepoTypeMismatch fsRepoType gSnapshotRepoType)---parseRepo :: Parser a -> Either SnapshotRepoConversionError a-parseRepo parser = case parseEither (const parser) () of-  Left e  -> Left (OtherRepoConversionError (T.pack e))-  Right a -> Right a---fsRepoType :: SnapshotRepoType-fsRepoType = SnapshotRepoType "fs"---- | Law: fromGSnapshotRepo (toGSnapshotRepo r) == Right r-class SnapshotRepo r where-  toGSnapshotRepo :: r -> GenericSnapshotRepo-  fromGSnapshotRepo :: GenericSnapshotRepo -> Either SnapshotRepoConversionError r---data SnapshotRepoConversionError = RepoTypeMismatch SnapshotRepoType SnapshotRepoType-                                 -- ^ Expected type and actual type-                                 | OtherRepoConversionError Text-                                 deriving (Show, Eq)---instance Exception SnapshotRepoConversionError---data SnapshotCreateSettings = SnapshotCreateSettings {-      snapWaitForCompletion  :: Bool-      -- ^ Should the API call return immediately after initializing-      -- the snapshot or wait until completed? Note that if this is-      -- enabled it could wait a long time, so you should adjust your-      -- 'ManagerSettings' accordingly to set long timeouts or-      -- explicitly handle timeouts.-    , snapIndices            :: Maybe IndexSelection-    -- ^ Nothing will snapshot all indices. Just [] is permissable and-    -- will essentially be a no-op snapshot.-    , snapIgnoreUnavailable  :: Bool-    -- ^ If set to True, any matched indices that don't exist will be-    -- ignored. Otherwise it will be an error and fail.-    , snapIncludeGlobalState :: Bool-    , snapPartial            :: Bool-    -- ^ If some indices failed to snapshot (e.g. if not all primary-    -- shards are available), should the process proceed?-    } deriving (Eq, Show)----- | Reasonable defaults for snapshot creation------ * snapWaitForCompletion False--- * snapIndices Nothing--- * snapIgnoreUnavailable False--- * snapIncludeGlobalState True--- * snapPartial False-defaultSnapshotCreateSettings :: SnapshotCreateSettings-defaultSnapshotCreateSettings = SnapshotCreateSettings {-      snapWaitForCompletion = False-    , snapIndices = Nothing-    , snapIgnoreUnavailable = False-    , snapIncludeGlobalState = True-    , snapPartial = False-    }---data SnapshotSelection =-    SnapshotList (NonEmpty SnapshotPattern)-  | AllSnapshots-  deriving (Eq, Show)----- | Either specifies an exact snapshot name or one with globs in it,--- e.g. @SnapPattern "foo*"@ __NOTE__: Patterns are not supported on--- ES < 1.7-data SnapshotPattern =-    ExactSnap SnapshotName-  | SnapPattern Text-  deriving (Eq, Show)----- | General information about the state of a snapshot. Has some--- redundancies with 'SnapshotStatus'-data SnapshotInfo = SnapshotInfo {-      snapInfoShards    :: ShardResult-    , snapInfoFailures  :: [SnapshotShardFailure]-    , snapInfoDuration  :: NominalDiffTime-    , snapInfoEndTime   :: UTCTime-    , snapInfoStartTime :: UTCTime-    , snapInfoState     :: SnapshotState-    , snapInfoIndices   :: [IndexName]-    , snapInfoName      :: SnapshotName-    } deriving (Eq, Show)---instance FromJSON SnapshotInfo where-  parseJSON = withObject "SnapshotInfo" parse-    where-      parse o = SnapshotInfo <$> o .: "shards"-                             <*> o .: "failures"-                             <*> (unMS <$> o .: "duration_in_millis")-                             <*> (posixMS <$> o .: "end_time_in_millis")-                             <*> (posixMS <$> o .: "start_time_in_millis")-                             <*> o .: "state"-                             <*> o .: "indices"-                             <*> o .: "snapshot"--data SnapshotShardFailure = SnapshotShardFailure {-      snapShardFailureIndex   :: IndexName-    , snapShardFailureNodeId  :: Maybe NodeName -- I'm not 100% sure this isn't actually 'FullNodeId'-    , snapShardFailureReason  :: Text-    , snapShardFailureShardId :: ShardId-    } deriving (Eq, Show)---instance FromJSON SnapshotShardFailure where-  parseJSON = withObject "SnapshotShardFailure" parse-    where-      parse o = SnapshotShardFailure <$> o .: "index"-                                     <*> o .:? "node_id"-                                     <*> o .: "reason"-                                     <*> o .: "shard_id"---- | Regex-stype pattern, e.g. "index_(.+)" to match index names-newtype RestoreRenamePattern =-  RestoreRenamePattern { rrPattern :: Text }-  deriving (Eq, Show, Ord, ToJSON)----- | A single token in a index renaming scheme for a restore. These--- are concatenated into a string before being sent to--- Elasticsearch. Check out these Java--- <https://docs.oracle.com/javase/7/docs/api/java/util/regex/Matcher.html docs> to find out more if you're into that sort of thing.-data RestoreRenameToken = RRTLit Text-                        -- ^ Just a literal string of characters-                        | RRSubWholeMatch-                        -- ^ Equivalent to $0. The entire matched pattern, not any subgroup-                        | RRSubGroup RRGroupRefNum-                        -- ^ A specific reference to a group number-                        deriving (Eq, Show)----- | A group number for regex matching. Only values from 1-9 are--- supported. Construct with 'mkRRGroupRefNum'-newtype RRGroupRefNum =-  RRGroupRefNum { rrGroupRefNum :: Int }-  deriving (Eq, Ord, Show)--instance Bounded RRGroupRefNum where-  minBound = RRGroupRefNum 1-  maxBound = RRGroupRefNum 9----- | Only allows valid group number references (1-9).-mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum-mkRRGroupRefNum i-  |    i >= rrGroupRefNum minBound-    && i <= rrGroupRefNum maxBound =-    Just $ RRGroupRefNum i-  | otherwise = Nothing---- | Reasonable defaults for snapshot restores------ * snapRestoreWaitForCompletion False--- * snapRestoreIndices Nothing--- * snapRestoreIgnoreUnavailable False--- * snapRestoreIncludeGlobalState True--- * snapRestoreRenamePattern Nothing--- * snapRestoreRenameReplacement Nothing--- * snapRestorePartial False--- * snapRestoreIncludeAliases True--- * snapRestoreIndexSettingsOverrides Nothing--- * snapRestoreIgnoreIndexSettings Nothing-defaultSnapshotRestoreSettings :: SnapshotRestoreSettings-defaultSnapshotRestoreSettings = SnapshotRestoreSettings {-      snapRestoreWaitForCompletion = False-    , snapRestoreIndices = Nothing-    , snapRestoreIgnoreUnavailable  = False-    , snapRestoreIncludeGlobalState = True-    , snapRestoreRenamePattern = Nothing-    , snapRestoreRenameReplacement = Nothing-    , snapRestorePartial = False-    , snapRestoreIncludeAliases = True-    , snapRestoreIndexSettingsOverrides = Nothing-    , snapRestoreIgnoreIndexSettings = Nothing-    }----- | Index settings that can be overridden. The docs only mention you--- can update number of replicas, but there may be more. You--- definitely cannot override shard count.-newtype RestoreIndexSettings = RestoreIndexSettings-  { restoreOverrideReplicas :: Maybe ReplicaCount-  } deriving (Eq, Show)---instance ToJSON RestoreIndexSettings where-  toJSON RestoreIndexSettings {..} = object prs-    where-      prs = catMaybes [("index.number_of_replicas" .=) <$> restoreOverrideReplicas]---instance FromJSON NodesInfo where-  parseJSON = withObject "NodesInfo" parse-    where-      parse o = do-        nodes <- o .: "nodes"-        infos <- forM (HM.toList nodes) $ \(fullNID, v) -> do-          node <- parseJSON v-          parseNodeInfo (FullNodeId fullNID) node-        cn <- o .: "cluster_name"-        return (NodesInfo infos cn)--instance FromJSON NodesStats where-  parseJSON = withObject "NodesStats" parse-    where-      parse o = do-        nodes <- o .: "nodes"-        stats <- forM (HM.toList nodes) $ \(fullNID, v) -> do-          node <- parseJSON v-          parseNodeStats (FullNodeId fullNID) node-        cn <- o .: "cluster_name"-        return (NodesStats stats cn)--instance FromJSON NodeBreakerStats where-  parseJSON = withObject "NodeBreakerStats" parse-    where-      parse o = NodeBreakerStats <$> o .: "tripped"-                                 <*> o .: "overhead"-                                 <*> o .: "estimated_size_in_bytes"-                                 <*> o .: "limit_size_in_bytes"--instance FromJSON NodeHTTPStats where-  parseJSON = withObject "NodeHTTPStats" parse-    where-      parse o = NodeHTTPStats <$> o .: "total_opened"-                              <*> o .: "current_open"--instance FromJSON NodeTransportStats where-  parseJSON = withObject "NodeTransportStats" parse-    where-      parse o = NodeTransportStats <$> o .: "tx_size_in_bytes"-                                   <*> o .: "tx_count"-                                   <*> o .: "rx_size_in_bytes"-                                   <*> o .: "rx_count"-                                   <*> o .: "server_open"--instance FromJSON NodeFSStats where-  parseJSON = withObject "NodeFSStats" parse-    where-      parse o = NodeFSStats <$> o .: "data"-                            <*> o .: "total"-                            <*> (posixMS <$> o .: "timestamp")--instance FromJSON NodeDataPathStats where-  parseJSON = withObject "NodeDataPathStats" parse-    where-      parse o =-        NodeDataPathStats <$> (fmap unStringlyTypedDouble <$> o .:? "disk_service_time")-                          <*> (fmap unStringlyTypedDouble <$> o .:? "disk_queue")-                          <*> o .:? "disk_io_size_in_bytes"-                          <*> o .:? "disk_write_size_in_bytes"-                          <*> o .:? "disk_read_size_in_bytes"-                          <*> o .:? "disk_io_op"-                          <*> o .:? "disk_writes"-                          <*> o .:? "disk_reads"-                          <*> o .: "available_in_bytes"-                          <*> o .: "free_in_bytes"-                          <*> o .: "total_in_bytes"-                          <*> o .:? "type"-                          <*> o .:? "dev"-                          <*> o .: "mount"-                          <*> o .: "path"--instance FromJSON NodeFSTotalStats where-  parseJSON = withObject "NodeFSTotalStats" parse-    where-      parse o = NodeFSTotalStats <$> (fmap unStringlyTypedDouble <$> o .:? "disk_service_time")-                                 <*> (fmap unStringlyTypedDouble <$> o .:? "disk_queue")-                                 <*> o .:? "disk_io_size_in_bytes"-                                 <*> o .:? "disk_write_size_in_bytes"-                                 <*> o .:? "disk_read_size_in_bytes"-                                 <*> o .:? "disk_io_op"-                                 <*> o .:? "disk_writes"-                                 <*> o .:? "disk_reads"-                                 <*> o .: "available_in_bytes"-                                 <*> o .: "free_in_bytes"-                                 <*> o .: "total_in_bytes"--instance FromJSON NodeNetworkStats where-  parseJSON = withObject "NodeNetworkStats" parse-    where-      parse o = do-        tcp <- o .: "tcp"-        NodeNetworkStats <$> tcp .: "out_rsts"-                         <*> tcp .: "in_errs"-                         <*> tcp .: "attempt_fails"-                         <*> tcp .: "estab_resets"-                         <*> tcp .: "retrans_segs"-                         <*> tcp .: "out_segs"-                         <*> tcp .: "in_segs"-                         <*> tcp .: "curr_estab"-                         <*> tcp .: "passive_opens"-                         <*> tcp .: "active_opens"--instance FromJSON NodeThreadPoolStats where-    parseJSON = withObject "NodeThreadPoolStats" parse-      where-        parse o = NodeThreadPoolStats <$> o .: "completed"-                                      <*> o .: "largest"-                                      <*> o .: "rejected"-                                      <*> o .: "active"-                                      <*> o .: "queue"-                                      <*> o .: "threads"--instance FromJSON NodeJVMStats where-  parseJSON = withObject "NodeJVMStats" parse-    where-      parse o = do-        bufferPools <- o .: "buffer_pools"-        mapped <- bufferPools .: "mapped"-        direct <- bufferPools .: "direct"-        gc <- o .: "gc"-        collectors <- gc .: "collectors"-        oldC <- collectors .: "old"-        youngC <- collectors .: "young"-        threads <- o .: "threads"-        mem <- o .: "mem"-        pools <- mem .: "pools"-        oldM <- pools .: "old"-        survivorM <- pools .: "survivor"-        youngM <- pools .: "young"-        NodeJVMStats <$> pure mapped-                     <*> pure direct-                     <*> pure oldC-                     <*> pure youngC-                     <*> threads .: "peak_count"-                     <*> threads .: "count"-                     <*> pure oldM-                     <*> pure survivorM-                     <*> pure youngM-                     <*> mem .: "non_heap_committed_in_bytes"-                     <*> mem .: "non_heap_used_in_bytes"-                     <*> mem .: "heap_max_in_bytes"-                     <*> mem .: "heap_committed_in_bytes"-                     <*> mem .: "heap_used_percent"-                     <*> mem .: "heap_used_in_bytes"-                     <*> (unMS <$> o .: "uptime_in_millis")-                     <*> (posixMS <$> o .: "timestamp")--instance FromJSON JVMBufferPoolStats where-  parseJSON = withObject "JVMBufferPoolStats" parse-    where-      parse o = JVMBufferPoolStats <$> o .: "total_capacity_in_bytes"-                                   <*> o .: "used_in_bytes"-                                   <*> o .: "count"--instance FromJSON JVMGCStats where-  parseJSON = withObject "JVMGCStats" parse-    where-      parse o = JVMGCStats <$> (unMS <$> o .: "collection_time_in_millis")-                           <*> o .: "collection_count"--instance FromJSON JVMPoolStats where-  parseJSON = withObject "JVMPoolStats" parse-    where-      parse o = JVMPoolStats <$> o .: "peak_max_in_bytes"-                             <*> o .: "peak_used_in_bytes"-                             <*> o .: "max_in_bytes"-                             <*> o .: "used_in_bytes"--instance FromJSON NodeProcessStats where-  parseJSON = withObject "NodeProcessStats" parse-    where-      parse o = do-        mem <- o .: "mem"-        cpu <- o .: "cpu"-        NodeProcessStats <$> (posixMS <$> o .: "timestamp")-                         <*> o .: "open_file_descriptors"-                         <*> o .: "max_file_descriptors"-                         <*> cpu .: "percent"-                         <*> (unMS <$> cpu .: "total_in_millis")-                         <*> mem .: "total_virtual_in_bytes"--instance FromJSON NodeOSStats where-  parseJSON = withObject "NodeOSStats" parse-    where-      parse o = do-        swap <- o .: "swap"-        mem <- o .: "mem"-        cpu <- o .: "cpu"-        load <- o .:? "load_average"-        NodeOSStats <$> (posixMS <$> o .: "timestamp")-                    <*> cpu .: "percent"-                    <*> pure load-                    <*> mem .: "total_in_bytes"-                    <*> mem .: "free_in_bytes"-                    <*> mem .: "free_percent"-                    <*> mem .: "used_in_bytes"-                    <*> mem .: "used_percent"-                    <*> swap .: "total_in_bytes"-                    <*> swap .: "free_in_bytes"-                    <*> swap .: "used_in_bytes"--instance FromJSON LoadAvgs where-  parseJSON = withArray "LoadAvgs" parse-    where-      parse v = case V.toList v of-        [one, five, fifteen] -> LoadAvgs <$> parseJSON one-                                         <*> parseJSON five-                                         <*> parseJSON fifteen-        _                    -> fail "Expecting a triple of Doubles"--instance FromJSON NodeIndicesStats where-  parseJSON = withObject "NodeIndicesStats" parse-    where-      parse o = do-        let (.::) mv k = case mv of-              Just v  -> Just <$> v .: k-              Nothing -> pure Nothing-        mRecovery <- o .:? "recovery"-        mQueryCache <- o .:? "query_cache"-        mSuggest <- o .:? "suggest"-        translog <- o .: "translog"-        segments <- o .: "segments"-        completion <- o .: "completion"-        mPercolate <- o .:? "percolate"-        fielddata <- o .: "fielddata"-        warmer <- o .: "warmer"-        flush <- o .: "flush"-        refresh <- o .: "refresh"-        merges <- o .: "merges"-        search <- o .: "search"-        getStats <- o .: "get"-        indexing <- o .: "indexing"-        store <- o .: "store"-        docs <- o .: "docs"-        NodeIndicesStats <$> (fmap unMS <$> mRecovery .:: "throttle_time_in_millis")-                         <*> mRecovery .:: "current_as_target"-                         <*> mRecovery .:: "current_as_source"-                         <*> mQueryCache .:: "miss_count"-                         <*> mQueryCache .:: "hit_count"-                         <*> mQueryCache .:: "evictions"-                         <*> mQueryCache .:: "memory_size_in_bytes"-                         <*> mSuggest .:: "current"-                         <*> (fmap unMS <$> mSuggest .:: "time_in_millis")-                         <*> mSuggest .:: "total"-                         <*> translog .: "size_in_bytes"-                         <*> translog .: "operations"-                         <*> segments .:? "fixed_bit_set_memory_in_bytes"-                         <*> segments .: "version_map_memory_in_bytes"-                         <*> segments .:? "index_writer_max_memory_in_bytes"-                         <*> segments .: "index_writer_memory_in_bytes"-                         <*> segments .: "memory_in_bytes"-                         <*> segments .: "count"-                         <*> completion .: "size_in_bytes"-                         <*> mPercolate .:: "queries"-                         <*> mPercolate .:: "memory_size_in_bytes"-                         <*> mPercolate .:: "current"-                         <*> (fmap unMS <$> mPercolate .:: "time_in_millis")-                         <*> mPercolate .:: "total"-                         <*> fielddata .: "evictions"-                         <*> fielddata .: "memory_size_in_bytes"-                         <*> (unMS <$> warmer .: "total_time_in_millis")-                         <*> warmer .: "total"-                         <*> warmer .: "current"-                         <*> (unMS <$> flush .: "total_time_in_millis")-                         <*> flush .: "total"-                         <*> (unMS <$> refresh .: "total_time_in_millis")-                         <*> refresh .: "total"-                         <*> merges .: "total_size_in_bytes"-                         <*> merges .: "total_docs"-                         <*> (unMS <$> merges .: "total_time_in_millis")-                         <*> merges .: "total"-                         <*> merges .: "current_size_in_bytes"-                         <*> merges .: "current_docs"-                         <*> merges .: "current"-                         <*> search .: "fetch_current"-                         <*> (unMS <$> search .: "fetch_time_in_millis")-                         <*> search .: "fetch_total"-                         <*> search .: "query_current"-                         <*> (unMS <$> search .: "query_time_in_millis")-                         <*> search .: "query_total"-                         <*> search .: "open_contexts"-                         <*> getStats .: "current"-                         <*> (unMS <$> getStats .: "missing_time_in_millis")-                         <*> getStats .: "missing_total"-                         <*> (unMS <$> getStats .: "exists_time_in_millis")-                         <*> getStats .: "exists_total"-                         <*> (unMS <$> getStats .: "time_in_millis")-                         <*> getStats .: "total"-                         <*> (fmap unMS <$> indexing .:? "throttle_time_in_millis")-                         <*> indexing .:? "is_throttled"-                         <*> indexing .:? "noop_update_total"-                         <*> indexing .: "delete_current"-                         <*> (unMS <$> indexing .: "delete_time_in_millis")-                         <*> indexing .: "delete_total"-                         <*> indexing .: "index_current"-                         <*> (unMS <$> indexing .: "index_time_in_millis")-                         <*> indexing .: "index_total"-                         <*> (fmap unMS <$> store .:? "throttle_time_in_millis")-                         <*> store .: "size_in_bytes"-                         <*> docs .: "deleted"-                         <*> docs .: "count"--instance FromJSON NodeBreakersStats where-  parseJSON = withObject "NodeBreakersStats" parse-    where-      parse o = NodeBreakersStats <$> o .: "parent"-                                  <*> o .: "request"-                                  <*> o .: "fielddata"--parseNodeStats :: FullNodeId -> Object -> Parser NodeStats-parseNodeStats fnid o =-  NodeStats <$> o .: "name"-            <*> pure fnid-            <*> o .:? "breakers"-            <*> o .: "http"-            <*> o .: "transport"-            <*> o .: "fs"-            <*> o .:? "network"-            <*> o .: "thread_pool"-            <*> o .: "jvm"-            <*> o .: "process"-            <*> o .: "os"-            <*> o .: "indices"--parseNodeInfo :: FullNodeId -> Object -> Parser NodeInfo-parseNodeInfo nid o =-  NodeInfo <$> o .:? "http_address"-           <*> o .: "build_hash"-           <*> o .: "version"-           <*> o .: "ip"-           <*> o .: "host"-           <*> o .: "transport_address"-           <*> o .: "name"-           <*> pure nid-           <*> o .: "plugins"-           <*> o .: "http"-           <*> o .: "transport"-           <*> o .:? "network"-           <*> o .: "thread_pool"-           <*> o .: "jvm"-           <*> o .: "process"-           <*> o .: "os"-           <*> o .: "settings"--instance FromJSON NodePluginInfo where-  parseJSON = withObject "NodePluginInfo" parse-    where-      parse o = NodePluginInfo <$> o .:?  "site"-                               <*> o .:?  "jvm"-                               <*> o .:   "description"-                               <*> o .:   "version"-                               <*> o .:   "name"--instance FromJSON NodeHTTPInfo where-  parseJSON = withObject "NodeHTTPInfo" parse-    where-      parse o = NodeHTTPInfo <$> o .: "max_content_length_in_bytes"-                             <*> o .: "publish_address"-                             <*> o .: "bound_address"--instance FromJSON BoundTransportAddress where-  parseJSON = withObject "BoundTransportAddress" parse-    where-      parse o = BoundTransportAddress <$> o .: "publish_address"-                                      <*> o .: "bound_address"--instance FromJSON NodeOSInfo where-  parseJSON = withObject "NodeOSInfo" parse-    where-      parse o =-        NodeOSInfo <$> (unMS <$> o .: "refresh_interval_in_millis")-                   <*> o .: "name"-                   <*> o .: "arch"-                   <*> o .: "version"-                   <*> o .: "available_processors"-                   <*> o .: "allocated_processors"---instance FromJSON CPUInfo where-  parseJSON = withObject "CPUInfo" parse-    where-      parse o = CPUInfo <$> o .: "cache_size_in_bytes"-                        <*> o .: "cores_per_socket"-                        <*> o .: "total_sockets"-                        <*> o .: "total_cores"-                        <*> o .: "mhz"-                        <*> o .: "model"-                        <*> o .: "vendor"--instance FromJSON NodeProcessInfo where-  parseJSON = withObject "NodeProcessInfo" parse-    where-      parse o = NodeProcessInfo <$> o .: "mlockall"-                                <*> o .:? "max_file_descriptors"-                                <*> o .: "id"-                                <*> (unMS <$> o .: "refresh_interval_in_millis")--instance FromJSON NodeJVMInfo where-  parseJSON = withObject "NodeJVMInfo" parse-    where-      parse o = NodeJVMInfo <$> o .: "memory_pools"-                            <*> o .: "gc_collectors"-                            <*> o .: "mem"-                            <*> (posixMS <$> o .: "start_time_in_millis")-                            <*> o .: "vm_vendor"-                            <*> o .: "vm_version"-                            <*> o .: "vm_name"-                            <*> o .: "version"-                            <*> o .: "pid"--instance FromJSON JVMMemoryInfo where-  parseJSON = withObject "JVMMemoryInfo" parse-    where-      parse o = JVMMemoryInfo <$> o .: "direct_max_in_bytes"-                              <*> o .: "non_heap_max_in_bytes"-                              <*> o .: "non_heap_init_in_bytes"-                              <*> o .: "heap_max_in_bytes"-                              <*> o .: "heap_init_in_bytes"--instance FromJSON NodeThreadPoolInfo where-  parseJSON = withObject "NodeThreadPoolInfo" parse-    where-      parse o = do-        ka <- maybe (return Nothing) (fmap Just . parseStringInterval) =<< o .:? "keep_alive"-        NodeThreadPoolInfo <$> (parseJSON . unStringlyTypeJSON =<< o .: "queue_size")-                           <*> pure ka-                           <*> o .:? "min"-                           <*> o .:? "max"-                           <*> o .: "type"--data TimeInterval = Weeks-                  | Days-                  | Hours-                  | Minutes-                  | Seconds deriving Eq--instance Show TimeInterval where-  show Weeks   = "w"-  show Days    = "d"-  show Hours   = "h"-  show Minutes = "m"-  show Seconds = "s"--instance Read TimeInterval where-  readPrec = f =<< TR.get-    where-      f 'w' = return Weeks-      f 'd' = return Days-      f 'h' = return Hours-      f 'm' = return Minutes-      f 's' = return Seconds-      f  _  = fail "TimeInterval expected one of w, d, h, m, s"--data Interval = Year-              | Quarter-              | Month-              | Week-              | Day-              | Hour-              | Minute-              | Second deriving (Eq, Show)--instance ToJSON Interval where-  toJSON Year    = "year"-  toJSON Quarter = "quarter"-  toJSON Month   = "month"-  toJSON Week    = "week"-  toJSON Day     = "day"-  toJSON Hour    = "hour"-  toJSON Minute  = "minute"-  toJSON Second  = "second"--parseStringInterval :: (Monad m, MonadFail m) => String -> m NominalDiffTime-parseStringInterval s = case span isNumber s of-  ("", _) -> fail "Invalid interval"-  (nS, unitS) -> case (readMay nS, readMay unitS) of-    (Just n, Just unit) -> return (fromInteger (n * unitNDT unit))-    (Nothing, _)        -> fail "Invalid interval number"-    (_, Nothing)        -> fail "Invalid interval unit"-  where-    unitNDT Seconds = 1-    unitNDT Minutes = 60-    unitNDT Hours   = 60 * 60-    unitNDT Days    = 24 * 60 * 60-    unitNDT Weeks   = 7 * 24 * 60 * 60--instance FromJSON ThreadPoolSize where-  parseJSON v = parseAsNumber v <|> parseAsString v-    where-      parseAsNumber = parseAsInt <=< parseJSON-      parseAsInt (-1) = return ThreadPoolUnbounded-      parseAsInt n-        | n >= 0 = return (ThreadPoolBounded n)-        | otherwise = fail "Thread pool size must be >= -1."-      parseAsString = withText "ThreadPoolSize" $ \t ->-        case first (readMay . T.unpack) (T.span isNumber t) of-          (Just n, "k") -> return (ThreadPoolBounded (n * 1000))-          (Just n, "")  -> return (ThreadPoolBounded n)-          _             -> fail ("Invalid thread pool size " <> T.unpack t)--instance FromJSON ThreadPoolType where-  parseJSON = withText "ThreadPoolType" parse-    where-      parse "scaling" = return ThreadPoolScaling-      parse "fixed"   = return ThreadPoolFixed-      parse "cached"  = return ThreadPoolCached-      parse "fixed_auto_queue_size" = return ThreadPoolFixedAutoQueueSize-      parse e         = fail ("Unexpected thread pool type" <> T.unpack e)--instance FromJSON NodeTransportInfo where-  parseJSON = withObject "NodeTransportInfo" parse-    where-      parse o = NodeTransportInfo <$> (maybe (return mempty) parseProfiles =<< o .:? "profiles")-                                  <*> o .: "publish_address"-                                  <*> o .: "bound_address"-      parseProfiles (Object o)  | X.null o = return []-      parseProfiles v@(Array _) = parseJSON v-      parseProfiles Null        = return []-      parseProfiles _           = fail "Could not parse profiles"--instance FromJSON NodeNetworkInfo where-  parseJSON = withObject "NodeNetworkInfo" parse-    where-      parse o = NodeNetworkInfo <$> o .: "primary_interface"-                                <*> (unMS <$> o .: "refresh_interval_in_millis")---instance FromJSON NodeNetworkInterface where-  parseJSON = withObject "NodeNetworkInterface" parse-    where-      parse o = NodeNetworkInterface <$> o .: "mac_address"-                                     <*> o .: "name"-                                     <*> o .: "address"---instance ToJSON Version where-  toJSON Version {..} = object ["number" .= number-                               ,"build_hash" .= build_hash-                               ,"build_date" .= build_date-                               ,"build_snapshot" .= build_snapshot-                               ,"lucene_version" .= lucene_version]--instance FromJSON Version where-  parseJSON = withObject "Version" parse-    where parse o = Version-                    <$> o .: "number"-                    <*> o .: "build_hash"-                    <*> o .: "build_date"-                    <*> o .: "build_snapshot"-                    <*> o .: "lucene_version"--instance ToJSON VersionNumber where-  toJSON = toJSON . SemVer.toText . versionNumber--instance FromJSON VersionNumber where-  parseJSON = withText "VersionNumber" parse-    where-      parse t =-        case SemVer.fromText t of-          (Left err) -> fail err-          (Right v) -> return (VersionNumber v)-+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Bloodhound.Internal.Client where++import Bloodhound.Import+import qualified Data.Aeson.KeyMap as X+import qualified Data.HashMap.Strict as HM+import Data.Map.Strict (Map)+import Data.Maybe (mapMaybe)+import qualified Data.SemVer as SemVer+import qualified Data.Text as T+import qualified Data.Traversable as DT+import qualified Data.Vector as V+import Database.Bloodhound.Internal.Analysis+import Database.Bloodhound.Internal.Client.BHRequest+import Database.Bloodhound.Internal.Client.Doc+import Database.Bloodhound.Internal.Newtypes+import Database.Bloodhound.Internal.Query+import Database.Bloodhound.Internal.StringlyTyped+import GHC.Generics+import Network.HTTP.Client+import Text.Read (Read (..))+import qualified Text.Read as TR++-- | Common environment for Elasticsearch calls. Connections will be+--    pipelined according to the provided HTTP connection manager.+data BHEnv = BHEnv+  { bhServer :: Server,+    bhManager :: Manager,+    -- | Low-level hook that is run before every request is sent. Used to implement custom authentication strategies. Defaults to 'return' with 'mkBHEnv'.+    bhRequestHook :: Request -> IO Request+  }++instance (Functor m, Applicative m, MonadIO m) => MonadBH (ReaderT BHEnv m) where+  getBHEnv = ask++-- | 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+  }+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadIO,+      MonadState s,+      MonadWriter w,+      MonadError e,+      Alternative,+      MonadPlus,+      MonadFix,+      MonadThrow,+      MonadCatch,+      MonadFail,+      MonadMask+    )++instance MonadTrans BH where+  lift = BH . lift++instance (MonadReader r m) => MonadReader r (BH m) where+  ask = lift ask+  local f (BH (ReaderT m)) = BH $+    ReaderT $ \r ->+      local f (m r)++instance (Functor m, Applicative m, MonadIO m) => MonadBH (BH m) where+  getBHEnv = BH getBHEnv++runBH :: BHEnv -> BH m a -> m a+runBH e f = runReaderT (unBH f) e++-- | 'Version' is embedded in 'Status'+data Version = Version+  { number :: VersionNumber,+    build_hash :: BuildHash,+    build_date :: UTCTime,+    build_snapshot :: Bool,+    lucene_version :: VersionNumber+  }+  deriving (Eq, Show, Generic)++-- | Traditional software versioning number+newtype VersionNumber = VersionNumber+  {versionNumber :: SemVer.Version}+  deriving (Eq, Ord, Show)++-- | 'Status' is a data type for describing the JSON body returned by+--    Elasticsearch when you query its status. This was deprecated in 1.2.0.+--+--   <http://www.elastic.co/guide/en/elasticsearch/reference/current/indices-status.html#indices-status>+data Status = Status+  { name :: Text,+    cluster_name :: Text,+    cluster_uuid :: Text,+    version :: Version,+    tagline :: Text+  }+  deriving (Eq, Show)++instance FromJSON Status where+  parseJSON (Object v) =+    Status+      <$> v .: "name"+      <*> v .: "cluster_name"+      <*> v .: "cluster_uuid"+      <*> v .: "version"+      <*> v .: "tagline"+  parseJSON _ = empty++-- | 'IndexSettings' is used to configure the shards and replicas when+--    you create an Elasticsearch Index.+--+--   <http://www.elastic.co/guide/en/elasticsearch/reference/current/indices-create-index.html>+data IndexSettings = IndexSettings+  { indexShards :: ShardCount,+    indexReplicas :: ReplicaCount,+    indexMappingsLimits :: IndexMappingsLimits+  }+  deriving (Eq, Show, Generic)++instance ToJSON IndexSettings where+  toJSON (IndexSettings s r l) =+    object+      [ "settings"+          .= object+            [ "index"+                .= object ["number_of_shards" .= s, "number_of_replicas" .= r, "mapping" .= l]+            ]+      ]++instance FromJSON IndexSettings where+  parseJSON = withObject "IndexSettings" parse+    where+      parse o = do+        s <- o .: "settings"+        i <- s .: "index"+        IndexSettings <$> i .: "number_of_shards"+          <*> i .: "number_of_replicas"+          <*> i .:? "mapping" .!= defaultIndexMappingsLimits++-- | 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and+--    2 replicas.+defaultIndexSettings :: IndexSettings+defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) defaultIndexMappingsLimits++-- defaultIndexSettings is exported by Database.Bloodhound as well+-- no trailing slashes in servers, library handles building the path.++-- | 'IndexMappingsLimits is used to configure index's limits.+--   <https://www.elastic.co/guide/en/elasticsearch/reference/master/mapping-settings-limit.html>+data IndexMappingsLimits = IndexMappingsLimits+  { indexMappingsLimitDepth :: Maybe Int,+    indexMappingsLimitNestedFields :: Maybe Int,+    indexMappingsLimitNestedObjects :: Maybe Int,+    indexMappingsLimitFieldNameLength :: Maybe Int+  }+  deriving (Eq, Show, Generic)++instance ToJSON IndexMappingsLimits where+  toJSON (IndexMappingsLimits d f o n) =+    object $+      mapMaybe+        go+        [ ("depth.limit", d),+          ("nested_fields.limit", f),+          ("nested_objects.limit", o),+          ("field_name_length.limit", n)+        ]+    where+      go (name, value) = (name .=) <$> value++instance FromJSON IndexMappingsLimits where+  parseJSON = withObject "IndexMappingsLimits" $ \o ->+    IndexMappingsLimits+      <$> o .:?? "depth"+      <*> o .:?? "nested_fields"+      <*> o .:?? "nested_objects"+      <*> o .:?? "field_name_length"+    where+      o .:?? name = optional $ do+        f <- o .: name+        f .: "limit"++defaultIndexMappingsLimits :: IndexMappingsLimits+defaultIndexMappingsLimits = IndexMappingsLimits Nothing Nothing Nothing Nothing++-- | 'ForceMergeIndexSettings' is used to configure index optimization. See+--    <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-forcemerge.html>+--    for more info.+data ForceMergeIndexSettings = ForceMergeIndexSettings+  { -- | 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.+    maxNumSegments :: Maybe Int,+    -- | 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.+    onlyExpungeDeletes :: Bool,+    -- | Should a flush be performed after the optimize.+    flushAfterOptimize :: Bool+  }+  deriving (Eq, Show)++-- | 'defaultForceMergeIndexSettings' implements the default settings that+--    Elasticsearch uses for index optimization. 'maxNumSegments' is Nothing,+--    'onlyExpungeDeletes' is False, and flushAfterOptimize is True.+defaultForceMergeIndexSettings :: ForceMergeIndexSettings+defaultForceMergeIndexSettings = ForceMergeIndexSettings Nothing False True++-- | 'UpdatableIndexSetting' are settings which may be updated after an index is created.+--+--   <https://www.elastic.co/guide/en/elasticsearch/reference/current/indices-update-settings.html>+data UpdatableIndexSetting+  = -- | The number of replicas each shard has.+    NumberOfReplicas ReplicaCount+  | AutoExpandReplicas ReplicaBounds+  | -- | Set to True to have the index read only. False to allow writes and metadata changes.+    BlocksReadOnly Bool+  | -- | Set to True to disable read operations against the index.+    BlocksRead Bool+  | -- | Set to True to disable write operations against the index.+    BlocksWrite Bool+  | -- | Set to True to disable metadata operations against the index.+    BlocksMetaData Bool+  | -- | The async refresh interval of a shard+    RefreshInterval NominalDiffTime+  | IndexConcurrency Int+  | FailOnMergeFailure Bool+  | -- | When to flush on operations.+    TranslogFlushThresholdOps Int+  | -- | When to flush based on translog (bytes) size.+    TranslogFlushThresholdSize Bytes+  | -- | When to flush based on a period of not flushing.+    TranslogFlushThresholdPeriod NominalDiffTime+  | -- | Disables flushing. Note, should be set for a short interval and then enabled.+    TranslogDisableFlush Bool+  | -- | The maximum size of filter cache (per segment in shard).+    CacheFilterMaxSize (Maybe Bytes)+  | -- | The expire after access time for filter cache.+    CacheFilterExpire (Maybe NominalDiffTime)+  | -- | The gateway snapshot interval (only applies to shared gateways).+    GatewaySnapshotInterval NominalDiffTime+  | -- | A node matching any rule will be allowed to host shards from the index.+    RoutingAllocationInclude (NonEmpty NodeAttrFilter)+  | -- | A node matching any rule will NOT be allowed to host shards from the index.+    RoutingAllocationExclude (NonEmpty NodeAttrFilter)+  | -- | Only nodes matching all rules will be allowed to host shards from the index.+    RoutingAllocationRequire (NonEmpty NodeAttrFilter)+  | -- | Enables shard allocation for a specific index.+    RoutingAllocationEnable AllocationPolicy+  | -- | Controls the total number of shards (replicas and primaries) allowed to be allocated on a single node.+    RoutingAllocationShardsPerNode ShardCount+  | -- | When using local gateway a particular shard is recovered only if there can be allocated quorum shards in the cluster.+    RecoveryInitialShards InitialShardCount+  | GCDeletes NominalDiffTime+  | -- | Disables temporarily the purge of expired docs.+    TTLDisablePurge Bool+  | TranslogFSType FSType+  | CompressionSetting Compression+  | IndexCompoundFormat CompoundFormat+  | IndexCompoundOnFlush Bool+  | WarmerEnabled Bool+  | MappingTotalFieldsLimit Int+  | -- | Analysis is not a dynamic setting and can only be performed on a closed index.+    AnalysisSetting Analysis+  | -- | Sets a delay to the allocation of replica shards which become unassigned because a node has left, giving them chance to return. See <https://www.elastic.co/guide/en/elasticsearch/reference/5.6/delayed-allocation.html>+    UnassignedNodeLeftDelayedTimeout NominalDiffTime+  deriving (Eq, Show, Generic)++attrFilterJSON :: NonEmpty NodeAttrFilter -> Value+attrFilterJSON fs =+  object+    [ fromText n .= T.intercalate "," (toList vs)+      | NodeAttrFilter (NodeAttrName n) vs <- toList fs+    ]++parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter)+parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse+  where+    parse o = case X.toList o of+      [] -> fail "Expected non-empty list of NodeAttrFilters"+      x : xs -> DT.mapM (uncurry parse') (x :| xs)+    parse' n = withText "Text" $ \t ->+      case T.splitOn "," t of+        fv : fvs -> return (NodeAttrFilter (NodeAttrName $ toText n) (fv :| fvs))+        [] -> fail "Expected non-empty list of filter values"++instance ToJSON UpdatableIndexSetting where+  toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x+  toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x+  toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x)+  toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x+  toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x+  toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x+  toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x+  toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x)+  toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x+  toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x+  toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x)+  toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x)+  toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs)+  toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs)+  toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs)+  toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x+  toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x+  toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x+  toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x)+  toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x+  toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x+  toJSON (CompressionSetting x) = oPath ("index" :| ["codec"]) x+  toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x+  toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x+  toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x+  toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x+  toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x+  toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x+  toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x+  toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping", "total_fields", "limit"]) x+  toJSON (AnalysisSetting x) = oPath ("index" :| ["analysis"]) x+  toJSON (UnassignedNodeLeftDelayedTimeout x) = oPath ("index" :| ["unassigned", "node_left", "delayed_timeout"]) (NominalDiffTimeJSON x)++instance FromJSON UpdatableIndexSetting where+  parseJSON = withObject "UpdatableIndexSetting" parse+    where+      parse o =+        numberOfReplicas `taggedAt` ["index", "number_of_replicas"]+          <|> autoExpandReplicas `taggedAt` ["index", "auto_expand_replicas"]+          <|> refreshInterval `taggedAt` ["index", "refresh_interval"]+          <|> indexConcurrency `taggedAt` ["index", "concurrency"]+          <|> failOnMergeFailure `taggedAt` ["index", "fail_on_merge_failure"]+          <|> translogFlushThresholdOps `taggedAt` ["index", "translog", "flush_threshold_ops"]+          <|> translogFlushThresholdSize `taggedAt` ["index", "translog", "flush_threshold_size"]+          <|> translogFlushThresholdPeriod `taggedAt` ["index", "translog", "flush_threshold_period"]+          <|> translogDisableFlush `taggedAt` ["index", "translog", "disable_flush"]+          <|> cacheFilterMaxSize `taggedAt` ["index", "cache", "filter", "max_size"]+          <|> cacheFilterExpire `taggedAt` ["index", "cache", "filter", "expire"]+          <|> gatewaySnapshotInterval `taggedAt` ["index", "gateway", "snapshot_interval"]+          <|> routingAllocationInclude `taggedAt` ["index", "routing", "allocation", "include"]+          <|> routingAllocationExclude `taggedAt` ["index", "routing", "allocation", "exclude"]+          <|> routingAllocationRequire `taggedAt` ["index", "routing", "allocation", "require"]+          <|> routingAllocationEnable `taggedAt` ["index", "routing", "allocation", "enable"]+          <|> routingAllocationShardsPerNode `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"]+          <|> recoveryInitialShards `taggedAt` ["index", "recovery", "initial_shards"]+          <|> gcDeletes `taggedAt` ["index", "gc_deletes"]+          <|> ttlDisablePurge `taggedAt` ["index", "ttl", "disable_purge"]+          <|> translogFSType `taggedAt` ["index", "translog", "fs", "type"]+          <|> compressionSetting `taggedAt` ["index", "codec"]+          <|> compoundFormat `taggedAt` ["index", "compound_format"]+          <|> compoundOnFlush `taggedAt` ["index", "compound_on_flush"]+          <|> warmerEnabled `taggedAt` ["index", "warmer", "enabled"]+          <|> blocksReadOnly `taggedAt` ["blocks", "read_only"]+          <|> blocksRead `taggedAt` ["blocks", "read"]+          <|> blocksWrite `taggedAt` ["blocks", "write"]+          <|> blocksMetaData `taggedAt` ["blocks", "metadata"]+          <|> mappingTotalFieldsLimit `taggedAt` ["index", "mapping", "total_fields", "limit"]+          <|> analysisSetting `taggedAt` ["index", "analysis"]+          <|> unassignedNodeLeftDelayedTimeout `taggedAt` ["index", "unassigned", "node_left", "delayed_timeout"]+        where+          taggedAt f ks = taggedAt' f (Object o) ks+      taggedAt' f v [] =+        f =<< (parseJSON v <|> parseJSON (unStringlyTypeJSON v))+      taggedAt' f v (k : ks) =+        withObject+          "Object"+          ( \o -> do+              v' <- o .: k+              taggedAt' f v' ks+          )+          v+      numberOfReplicas = pure . NumberOfReplicas+      autoExpandReplicas = pure . AutoExpandReplicas+      refreshInterval = pure . RefreshInterval . ndtJSON+      indexConcurrency = pure . IndexConcurrency+      failOnMergeFailure = pure . FailOnMergeFailure+      translogFlushThresholdOps = pure . TranslogFlushThresholdOps+      translogFlushThresholdSize = pure . TranslogFlushThresholdSize+      translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON+      translogDisableFlush = pure . TranslogDisableFlush+      cacheFilterMaxSize = pure . CacheFilterMaxSize+      cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON+      gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON+      routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter+      routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter+      routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter+      routingAllocationEnable = pure . RoutingAllocationEnable+      routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode+      recoveryInitialShards = pure . RecoveryInitialShards+      gcDeletes = pure . GCDeletes . ndtJSON+      ttlDisablePurge = pure . TTLDisablePurge+      translogFSType = pure . TranslogFSType+      compressionSetting = pure . CompressionSetting+      compoundFormat = pure . IndexCompoundFormat+      compoundOnFlush = pure . IndexCompoundOnFlush+      warmerEnabled = pure . WarmerEnabled+      blocksReadOnly = pure . BlocksReadOnly+      blocksRead = pure . BlocksRead+      blocksWrite = pure . BlocksWrite+      blocksMetaData = pure . BlocksMetaData+      mappingTotalFieldsLimit = pure . MappingTotalFieldsLimit+      analysisSetting = pure . AnalysisSetting+      unassignedNodeLeftDelayedTimeout = pure . UnassignedNodeLeftDelayedTimeout . ndtJSON++data ReplicaBounds+  = ReplicasBounded Int Int+  | ReplicasLowerBounded Int+  | ReplicasUnbounded+  deriving (Eq, Show)++instance ToJSON ReplicaBounds where+  toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b)+  toJSON (ReplicasLowerBounded a) = String (showText a <> "-all")+  toJSON ReplicasUnbounded = Bool False++instance FromJSON ReplicaBounds where+  parseJSON v =+    withText "ReplicaBounds" parseText v+      <|> withBool "ReplicaBounds" parseBool v+    where+      parseText t = case T.splitOn "-" t of+        [a, "all"] -> ReplicasLowerBounded <$> parseReadText a+        [a, b] ->+          ReplicasBounded <$> parseReadText a+            <*> parseReadText b+        _ -> fail ("Could not parse ReplicaBounds: " <> show t)+      parseBool False = pure ReplicasUnbounded+      parseBool _ = fail "ReplicasUnbounded cannot be represented with True"++data Compression+  = -- | Compress with LZ4+    CompressionDefault+  | -- | Compress with DEFLATE. Elastic+    --   <https://www.elastic.co/blog/elasticsearch-storage-the-true-story-2.0 blogs>+    --   that this can reduce disk use by 15%-25%.+    CompressionBest+  deriving (Eq, Show, Generic)++instance ToJSON Compression where+  toJSON x = case x of+    CompressionDefault -> toJSON ("default" :: Text)+    CompressionBest -> toJSON ("best_compression" :: Text)++instance FromJSON Compression where+  parseJSON = withText "Compression" $ \t -> case t of+    "default" -> return CompressionDefault+    "best_compression" -> return CompressionBest+    _ -> fail "invalid compression codec"++-- | A measure of bytes used for various configurations. You may want+-- to use smart constructors like 'gigabytes' for larger values.+--+-- >>> gigabytes 9+-- Bytes 9000000000+--+-- >>> megabytes 9+-- Bytes 9000000+--+-- >>> kilobytes 9+-- Bytes 9000+newtype Bytes+  = Bytes Int+  deriving (Eq, Show, Generic, Ord, ToJSON, FromJSON)++gigabytes :: Int -> Bytes+gigabytes n = megabytes (1000 * n)++megabytes :: Int -> Bytes+megabytes n = kilobytes (1000 * n)++kilobytes :: Int -> Bytes+kilobytes n = Bytes (1000 * n)++data FSType+  = FSSimple+  | FSBuffered+  deriving (Eq, Show, Generic)++instance ToJSON FSType where+  toJSON FSSimple = "simple"+  toJSON FSBuffered = "buffered"++instance FromJSON FSType where+  parseJSON = withText "FSType" parse+    where+      parse "simple" = pure FSSimple+      parse "buffered" = pure FSBuffered+      parse t = fail ("Invalid FSType: " <> show t)++data InitialShardCount+  = QuorumShards+  | QuorumMinus1Shards+  | FullShards+  | FullMinus1Shards+  | ExplicitShards Int+  deriving (Eq, Show, Generic)++instance FromJSON InitialShardCount where+  parseJSON v =+    withText "InitialShardCount" parseText v+      <|> ExplicitShards <$> parseJSON v+    where+      parseText "quorum" = pure QuorumShards+      parseText "quorum-1" = pure QuorumMinus1Shards+      parseText "full" = pure FullShards+      parseText "full-1" = pure FullMinus1Shards+      parseText _ = mzero++instance ToJSON InitialShardCount where+  toJSON QuorumShards = String "quorum"+  toJSON QuorumMinus1Shards = String "quorum-1"+  toJSON FullShards = String "full"+  toJSON FullMinus1Shards = String "full-1"+  toJSON (ExplicitShards x) = toJSON x++data NodeAttrFilter = NodeAttrFilter+  { nodeAttrFilterName :: NodeAttrName,+    nodeAttrFilterValues :: NonEmpty Text+  }+  deriving (Eq, Ord, Show)++newtype NodeAttrName = NodeAttrName Text deriving (Eq, Ord, Show)++data CompoundFormat+  = CompoundFileFormat Bool+  | -- | percentage between 0 and 1 where 0 is false, 1 is true+    MergeSegmentVsTotalIndex Double+  deriving (Eq, Show, Generic)++instance ToJSON CompoundFormat where+  toJSON (CompoundFileFormat x) = Bool x+  toJSON (MergeSegmentVsTotalIndex x) = toJSON x++instance FromJSON CompoundFormat where+  parseJSON v =+    CompoundFileFormat <$> parseJSON v+      <|> MergeSegmentVsTotalIndex <$> parseJSON v++newtype NominalDiffTimeJSON = NominalDiffTimeJSON {ndtJSON :: NominalDiffTime}++instance ToJSON NominalDiffTimeJSON where+  toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s")++instance FromJSON NominalDiffTimeJSON where+  parseJSON = withText "NominalDiffTime" parse+    where+      parse t = case T.takeEnd 1 t of+        "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t)+        _ -> fail "Invalid or missing NominalDiffTime unit (expected s)"++data IndexSettingsSummary = IndexSettingsSummary+  { sSummaryIndexName :: IndexName,+    sSummaryFixedSettings :: IndexSettings,+    sSummaryUpdateable :: [UpdatableIndexSetting]+  }+  deriving (Eq, Show)++parseSettings :: Object -> Parser [UpdatableIndexSetting]+parseSettings o = do+  o' <- o .: "index"+  -- slice the index object into singleton hashmaps and try to parse each+  parses <- forM (HM.toList o') $ \(k, v) -> do+    -- blocks are now nested into the "index" key, which is not how they're serialized+    let atRoot = Object (X.singleton k v)+    let atIndex = Object (X.singleton "index" atRoot)+    optional (parseJSON atRoot <|> parseJSON atIndex)+  return (catMaybes parses)++instance FromJSON IndexSettingsSummary where+  parseJSON = withObject "IndexSettingsSummary" parse+    where+      parse o = case X.toList o of+        [(ixn, v@(Object o'))] ->+          IndexSettingsSummary (IndexName $ toText ixn)+            <$> parseJSON v+            <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings")+        _ -> fail "Expected single-key object with index name"+      redundant (NumberOfReplicas _) = True+      redundant _ = False++-- | 'OpenCloseIndex' is a sum type for opening and closing indices.+--+--   <http://www.elastic.co/guide/en/elasticsearch/reference/current/indices-open-close.html>+data OpenCloseIndex = OpenIndex | CloseIndex deriving (Eq, Show)++data FieldType+  = GeoPointType+  | GeoShapeType+  | FloatType+  | IntegerType+  | LongType+  | ShortType+  | ByteType+  deriving (Eq, Show)++newtype FieldDefinition = FieldDefinition+  { fieldType :: FieldType+  }+  deriving (Eq, Show)++-- | An 'IndexTemplate' defines a template that will automatically be+--    applied to new indices created. The templates include both+--    'IndexSettings' and mappings, and a simple 'IndexPattern' that+--    controls if the template will be applied to the index created.+--    Specify mappings as follows: @[toJSON TweetMapping, ...]@+--+--    https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html+data IndexTemplate = IndexTemplate+  { templatePatterns :: [IndexPattern],+    templateSettings :: Maybe IndexSettings,+    templateMappings :: Value+  }++instance ToJSON IndexTemplate where+  toJSON (IndexTemplate p s m) =+    merge+      ( object+          [ "index_patterns" .= p,+            "mappings" .= m+          ]+      )+      (toJSON s)+    where+      merge (Object o1) (Object o2) = toJSON $ X.union o1 o2+      merge o Null = o+      merge _ _ = undefined++data MappingField = MappingField+  { mappingFieldName :: FieldName,+    fieldDefinition :: FieldDefinition+  }+  deriving (Eq, Show)++-- | Support for type reification of 'Mapping's is currently incomplete, for+--    now the mapping API verbiage expects a 'ToJSON'able blob.+--+--    Indexes have mappings, mappings are schemas for the documents contained+--    in the index. I'd recommend having only one mapping per index, always+--    having a mapping, and keeping different kinds of documents separated+--    if possible.+newtype Mapping = Mapping {mappingFields :: [MappingField]}+  deriving (Eq, Show)++data UpsertActionMetadata+  = UA_RetryOnConflict Int+  | UA_Version Int+  deriving (Eq, Show)++buildUpsertActionMetadata :: UpsertActionMetadata -> Pair+buildUpsertActionMetadata (UA_RetryOnConflict i) = "retry_on_conflict" .= i+buildUpsertActionMetadata (UA_Version i) = "_version" .= i++data UpsertPayload+  = UpsertDoc Value+  | UpsertScript Bool Script Value+  deriving (Eq, Show)++data AllocationPolicy+  = -- | Allows shard allocation for all shards.+    AllocAll+  | -- | Allows shard allocation only for primary shards.+    AllocPrimaries+  | -- | Allows shard allocation only for primary shards for new indices.+    AllocNewPrimaries+  | -- | No shard allocation is allowed+    AllocNone+  deriving (Eq, Show, Generic)++instance ToJSON AllocationPolicy where+  toJSON AllocAll = String "all"+  toJSON AllocPrimaries = String "primaries"+  toJSON AllocNewPrimaries = String "new_primaries"+  toJSON AllocNone = String "none"++instance FromJSON AllocationPolicy where+  parseJSON = withText "AllocationPolicy" parse+    where+      parse "all" = pure AllocAll+      parse "primaries" = pure AllocPrimaries+      parse "new_primaries" = pure AllocNewPrimaries+      parse "none" = pure AllocNone+      parse t = fail ("Invlaid AllocationPolicy: " <> show t)++-- | 'BulkOperation' is a sum type for expressing the four kinds of bulk+--    operation index, create, delete, and update. 'BulkIndex' behaves like an+--    "upsert", 'BulkCreate' will fail if a document already exists at the DocId.+--    Consult the <http://www.elastic.co/guide/en/elasticsearch/reference/current/docs-bulk.html#docs-bulk Bulk API documentation>+--    for further explanation.+--    Warning: Bulk operations suffixed with @Auto@ rely on Elasticsearch to+--    generate the id. Often, people use auto-generated identifiers when+--    Elasticsearch is the only place that their data is stored. Do not let+--    Elasticsearch be the only place your data is stored. It does not guarantee+--    durability, and it may silently discard data.+--    This <https://github.com/elastic/elasticsearch/issues/10708 issue> is+--    discussed further on github.+data BulkOperation+  = -- | Create the document, replacing it if it already exists.+    BulkIndex IndexName DocId Value+  | -- | Create a document with an autogenerated id.+    BulkIndexAuto IndexName Value+  | -- | Create a document with an autogenerated id. Use fast JSON encoding.+    BulkIndexEncodingAuto IndexName Encoding+  | -- | Create a document, failing if it already exists.+    BulkCreate IndexName DocId Value+  | -- | Create a document, failing if it already exists. Use fast JSON encoding.+    BulkCreateEncoding IndexName DocId Encoding+  | -- | Delete the document+    BulkDelete IndexName DocId+  | -- | Update the document, merging the new value with the existing one.+    BulkUpdate IndexName DocId Value+  | -- | Update the document if it already exists, otherwise insert it.+    BulkUpsert IndexName DocId UpsertPayload [UpsertActionMetadata]+  deriving (Eq, Show)++data IndexAlias = IndexAlias+  { srcIndex :: IndexName,+    indexAlias :: IndexAliasName+  }+  deriving (Eq, Show)++data IndexAliasAction+  = AddAlias IndexAlias IndexAliasCreate+  | RemoveAlias IndexAlias+  deriving (Eq, Show)++data IndexAliasCreate = IndexAliasCreate+  { aliasCreateRouting :: Maybe AliasRouting,+    aliasCreateFilter :: Maybe Filter+  }+  deriving (Eq, Show)++data AliasRouting+  = AllAliasRouting RoutingValue+  | GranularAliasRouting (Maybe SearchAliasRouting) (Maybe IndexAliasRouting)+  deriving (Eq, Show)++newtype SearchAliasRouting+  = SearchAliasRouting (NonEmpty RoutingValue)+  deriving (Eq, Show, Generic)++instance ToJSON SearchAliasRouting where+  toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs))++instance FromJSON SearchAliasRouting where+  parseJSON = withText "SearchAliasRouting" parse+    where+      parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t)++newtype IndexAliasRouting+  = IndexAliasRouting RoutingValue+  deriving (Eq, Show, Generic, ToJSON, FromJSON)++newtype RoutingValue = RoutingValue {routingValue :: Text}+  deriving (Eq, Show, ToJSON, FromJSON)++newtype IndexAliasesSummary = IndexAliasesSummary {indexAliasesSummary :: [IndexAliasSummary]}+  deriving (Eq, Show)++instance FromJSON IndexAliasesSummary where+  parseJSON = withObject "IndexAliasesSummary" parse+    where+      parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (X.toList o)+      go ixn = withObject "index aliases" $ \ia -> do+        aliases <- ia .:? "aliases" .!= mempty+        forM (HM.toList aliases) $ \(aName, v) -> do+          let indexAlias = IndexAlias (IndexName $ toText ixn) (IndexAliasName (IndexName $ toText aName))+          IndexAliasSummary indexAlias <$> parseJSON v++instance ToJSON IndexAliasAction where+  toJSON (AddAlias ia opts) = object ["add" .= (iaObj <> optsObj)]+    where+      Object iaObj = toJSON ia+      Object optsObj = toJSON opts+  toJSON (RemoveAlias ia) = object ["remove" .= iaObj]+    where+      Object iaObj = toJSON ia++instance ToJSON IndexAlias where+  toJSON IndexAlias {..} =+    object+      [ "index" .= srcIndex,+        "alias" .= indexAlias+      ]++instance ToJSON IndexAliasCreate where+  toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj)+    where+      filterObj = maybe mempty (X.singleton "filter" . toJSON) aliasCreateFilter+      Object routingObj = maybe (Object mempty) toJSON aliasCreateRouting++instance ToJSON AliasRouting where+  toJSON (AllAliasRouting v) = object ["routing" .= v]+  toJSON (GranularAliasRouting srch idx) = object (catMaybes prs)+    where+      prs =+        [ ("search_routing" .=) <$> srch,+          ("index_routing" .=) <$> idx+        ]++instance FromJSON AliasRouting where+  parseJSON = withObject "AliasRouting" parse+    where+      parse o = parseAll o <|> parseGranular o+      parseAll o = AllAliasRouting <$> o .: "routing"+      parseGranular o = do+        sr <- o .:? "search_routing"+        ir <- o .:? "index_routing"+        if isNothing sr && isNothing ir+          then fail "Both search_routing and index_routing can't be blank"+          else return (GranularAliasRouting sr ir)++instance FromJSON IndexAliasCreate where+  parseJSON v = withObject "IndexAliasCreate" parse v+    where+      parse o =+        IndexAliasCreate <$> optional (parseJSON v)+          <*> o .:? "filter"++-- | 'IndexAliasSummary' is a summary of an index alias configured for a server.+data IndexAliasSummary = IndexAliasSummary+  { indexAliasSummaryAlias :: IndexAlias,+    indexAliasSummaryCreate :: IndexAliasCreate+  }+  deriving (Eq, Show)++data JoinRelation+  = ParentDocument FieldName RelationName+  | ChildDocument FieldName RelationName DocId+  deriving (Show, Eq)++-- | 'IndexDocumentSettings' are special settings supplied when indexing+-- a document. For the best backwards compatiblity when new fields are+-- added, you should probably prefer to start with 'defaultIndexDocumentSettings'+data IndexDocumentSettings = IndexDocumentSettings+  { idsVersionControl :: VersionControl,+    idsJoinRelation :: Maybe JoinRelation+  }+  deriving (Eq, Show)++-- | Reasonable default settings. Chooses no version control and no parent.+defaultIndexDocumentSettings :: IndexDocumentSettings+defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing++-- | 'IndexSelection' is used for APIs which take a single index, a list of+--    indexes, or the special @_all@ index.++--TODO: this does not fully support <https://www.elastic.co/guide/en/elasticsearch/reference/1.7/multi-index.html multi-index syntax>. It wouldn't be too hard to implement but you'd have to add the optional parameters (ignore_unavailable, allow_no_indices, expand_wildcards) to any APIs using it. Also would be a breaking API.+data IndexSelection+  = IndexList (NonEmpty IndexName)+  | AllIndexes+  deriving (Eq, Show)++-- | 'NodeSelection' is used for most cluster APIs. See <https://www.elastic.co/guide/en/elasticsearch/reference/current/cluster.html#cluster-nodes here> for more details.+data NodeSelection+  = -- | Whatever node receives this request+    LocalNode+  | NodeList (NonEmpty NodeSelector)+  | AllNodes+  deriving (Eq, Show)++-- | An exact match or pattern to identify a node. Note that All of+-- these options support wildcarding, so your node name, server, attr+-- name can all contain * characters to be a fuzzy match.+data NodeSelector+  = NodeByName NodeName+  | NodeByFullNodeId FullNodeId+  | -- | e.g. 10.0.0.1 or even 10.0.0.*+    NodeByHost Server+  | -- | NodeAttrName can be a pattern, e.g. rack*. The value can too.+    NodeByAttribute NodeAttrName Text+  deriving (Eq, Show)++-- | 'TemplateName' is used to describe which template to query/create/delete+newtype TemplateName = TemplateName Text deriving (Eq, Show, Generic, ToJSON, FromJSON)++-- | 'IndexPattern' represents a pattern which is matched against index names+newtype IndexPattern = IndexPattern Text deriving (Eq, Show, Generic, ToJSON, FromJSON)++-- | Username type used for HTTP Basic authentication. See 'basicAuthHook'.+newtype EsUsername = EsUsername {esUsername :: Text} deriving (Read, Show, Eq)++-- | Password type used for HTTP Basic authentication. See 'basicAuthHook'.+newtype EsPassword = EsPassword {esPassword :: Text} deriving (Read, Show, Eq)++data SnapshotRepoSelection+  = SnapshotRepoList (NonEmpty SnapshotRepoPattern)+  | AllSnapshotRepos+  deriving (Eq, Show)++-- | Either specifies an exact repo name or one with globs in it,+-- e.g. @RepoPattern "foo*"@ __NOTE__: Patterns are not supported on ES < 1.7+data SnapshotRepoPattern+  = ExactRepo SnapshotRepoName+  | RepoPattern Text+  deriving (Eq, Show)++-- | The unique name of a snapshot repository.+newtype SnapshotRepoName = SnapshotRepoName {snapshotRepoName :: Text}+  deriving (Eq, Ord, Show, Generic, ToJSON, FromJSON)++-- | A generic representation of a snapshot repo. This is what gets+-- sent to and parsed from the server. For repo types enabled by+-- plugins that aren't exported by this library, consider making a+-- custom type which implements 'SnapshotRepo'. If it is a common repo+-- type, consider submitting a pull request to have it included in the+-- library proper+data GenericSnapshotRepo = GenericSnapshotRepo+  { gSnapshotRepoName :: SnapshotRepoName,+    gSnapshotRepoType :: SnapshotRepoType,+    gSnapshotRepoSettings :: GenericSnapshotRepoSettings+  }+  deriving (Eq, Show)++instance SnapshotRepo GenericSnapshotRepo where+  toGSnapshotRepo = id+  fromGSnapshotRepo = Right++newtype SnapshotRepoType = SnapshotRepoType {snapshotRepoType :: Text}+  deriving (Eq, Ord, Show, ToJSON, FromJSON)++-- | Opaque representation of snapshot repo settings. Instances of+-- 'SnapshotRepo' will produce this.+newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings {gSnapshotRepoSettingsObject :: Object}+  deriving (Eq, Show, ToJSON)++-- Regardless of whether you send strongly typed json, my version of+-- ES sends back stringly typed json in the settings, e.g. booleans+-- as strings, so we'll try to convert them.+instance FromJSON GenericSnapshotRepoSettings where+  parseJSON = fmap (GenericSnapshotRepoSettings . fmap unStringlyTypeJSON) . parseJSON++-- | The result of running 'verifySnapshotRepo'.+newtype SnapshotVerification = SnapshotVerification+  { snapshotNodeVerifications :: [SnapshotNodeVerification]+  }+  deriving (Eq, Show)++instance FromJSON SnapshotVerification where+  parseJSON = withObject "SnapshotVerification" parse+    where+      parse o = do+        o2 <- o .: "nodes"+        SnapshotVerification <$> mapM (uncurry parse') (HM.toList o2)+      parse' rawFullId = withObject "SnapshotNodeVerification" $ \o ->+        SnapshotNodeVerification (FullNodeId rawFullId) <$> o .: "name"++-- | A node that has verified a snapshot+data SnapshotNodeVerification = SnapshotNodeVerification+  { snvFullId :: FullNodeId,+    snvNodeName :: NodeName+  }+  deriving (Eq, Show)++-- | Unique, automatically-generated name assigned to nodes that are+-- usually returned in node-oriented APIs.+newtype FullNodeId = FullNodeId {fullNodeId :: Text}+  deriving (Eq, Ord, Show, FromJSON)++-- | A human-readable node name that is supplied by the user in the+-- node config or automatically generated by Elasticsearch.+newtype NodeName = NodeName {nodeName :: Text}+  deriving (Eq, Ord, Show, FromJSON)++newtype ClusterName = ClusterName {clusterName :: Text}+  deriving (Eq, Ord, Show, FromJSON)++data NodesInfo = NodesInfo+  { nodesInfo :: [NodeInfo],+    nodesClusterName :: ClusterName+  }+  deriving (Eq, Show)++data NodesStats = NodesStats+  { nodesStats :: [NodeStats],+    nodesStatsClusterName :: ClusterName+  }+  deriving (Eq, Show)++data NodeStats = NodeStats+  { nodeStatsName :: NodeName,+    nodeStatsFullId :: FullNodeId,+    nodeStatsBreakersStats :: Maybe NodeBreakersStats,+    nodeStatsHTTP :: NodeHTTPStats,+    nodeStatsTransport :: NodeTransportStats,+    nodeStatsFS :: NodeFSStats,+    nodeStatsNetwork :: Maybe NodeNetworkStats,+    nodeStatsThreadPool :: Map Text NodeThreadPoolStats,+    nodeStatsJVM :: NodeJVMStats,+    nodeStatsProcess :: NodeProcessStats,+    nodeStatsOS :: NodeOSStats,+    nodeStatsIndices :: NodeIndicesStats+  }+  deriving (Eq, Show)++data NodeBreakersStats = NodeBreakersStats+  { nodeStatsParentBreaker :: NodeBreakerStats,+    nodeStatsRequestBreaker :: NodeBreakerStats,+    nodeStatsFieldDataBreaker :: NodeBreakerStats+  }+  deriving (Eq, Show)++data NodeBreakerStats = NodeBreakerStats+  { nodeBreakersTripped :: Int,+    nodeBreakersOverhead :: Double,+    nodeBreakersEstSize :: Bytes,+    nodeBreakersLimitSize :: Bytes+  }+  deriving (Eq, Show)++data NodeHTTPStats = NodeHTTPStats+  { nodeHTTPTotalOpened :: Int,+    nodeHTTPCurrentOpen :: Int+  }+  deriving (Eq, Show)++data NodeTransportStats = NodeTransportStats+  { nodeTransportTXSize :: Bytes,+    nodeTransportCount :: Int,+    nodeTransportRXSize :: Bytes,+    nodeTransportRXCount :: Int,+    nodeTransportServerOpen :: Int+  }+  deriving (Eq, Show)++data NodeFSStats = NodeFSStats+  { nodeFSDataPaths :: [NodeDataPathStats],+    nodeFSTotal :: NodeFSTotalStats,+    nodeFSTimestamp :: UTCTime+  }+  deriving (Eq, Show)++data NodeDataPathStats = NodeDataPathStats+  { nodeDataPathDiskServiceTime :: Maybe Double,+    nodeDataPathDiskQueue :: Maybe Double,+    nodeDataPathIOSize :: Maybe Bytes,+    nodeDataPathWriteSize :: Maybe Bytes,+    nodeDataPathReadSize :: Maybe Bytes,+    nodeDataPathIOOps :: Maybe Int,+    nodeDataPathWrites :: Maybe Int,+    nodeDataPathReads :: Maybe Int,+    nodeDataPathAvailable :: Bytes,+    nodeDataPathFree :: Bytes,+    nodeDataPathTotal :: Bytes,+    nodeDataPathType :: Maybe Text,+    nodeDataPathDevice :: Maybe Text,+    nodeDataPathMount :: Text,+    nodeDataPathPath :: Text+  }+  deriving (Eq, Show)++data NodeFSTotalStats = NodeFSTotalStats+  { nodeFSTotalDiskServiceTime :: Maybe Double,+    nodeFSTotalDiskQueue :: Maybe Double,+    nodeFSTotalIOSize :: Maybe Bytes,+    nodeFSTotalWriteSize :: Maybe Bytes,+    nodeFSTotalReadSize :: Maybe Bytes,+    nodeFSTotalIOOps :: Maybe Int,+    nodeFSTotalWrites :: Maybe Int,+    nodeFSTotalReads :: Maybe Int,+    nodeFSTotalAvailable :: Bytes,+    nodeFSTotalFree :: Bytes,+    nodeFSTotalTotal :: Bytes+  }+  deriving (Eq, Show)++data NodeNetworkStats = NodeNetworkStats+  { nodeNetTCPOutRSTs :: Int,+    nodeNetTCPInErrs :: Int,+    nodeNetTCPAttemptFails :: Int,+    nodeNetTCPEstabResets :: Int,+    nodeNetTCPRetransSegs :: Int,+    nodeNetTCPOutSegs :: Int,+    nodeNetTCPInSegs :: Int,+    nodeNetTCPCurrEstab :: Int,+    nodeNetTCPPassiveOpens :: Int,+    nodeNetTCPActiveOpens :: Int+  }+  deriving (Eq, Show)++data NodeThreadPoolStats = NodeThreadPoolStats+  { nodeThreadPoolCompleted :: Int,+    nodeThreadPoolLargest :: Int,+    nodeThreadPoolRejected :: Int,+    nodeThreadPoolActive :: Int,+    nodeThreadPoolQueue :: Int,+    nodeThreadPoolThreads :: Int+  }+  deriving (Eq, Show)++data NodeJVMStats = NodeJVMStats+  { nodeJVMStatsMappedBufferPool :: JVMBufferPoolStats,+    nodeJVMStatsDirectBufferPool :: JVMBufferPoolStats,+    nodeJVMStatsGCOldCollector :: JVMGCStats,+    nodeJVMStatsGCYoungCollector :: JVMGCStats,+    nodeJVMStatsPeakThreadsCount :: Int,+    nodeJVMStatsThreadsCount :: Int,+    nodeJVMStatsOldPool :: JVMPoolStats,+    nodeJVMStatsSurvivorPool :: JVMPoolStats,+    nodeJVMStatsYoungPool :: JVMPoolStats,+    nodeJVMStatsNonHeapCommitted :: Bytes,+    nodeJVMStatsNonHeapUsed :: Bytes,+    nodeJVMStatsHeapMax :: Bytes,+    nodeJVMStatsHeapCommitted :: Bytes,+    nodeJVMStatsHeapUsedPercent :: Int,+    nodeJVMStatsHeapUsed :: Bytes,+    nodeJVMStatsUptime :: NominalDiffTime,+    nodeJVMStatsTimestamp :: UTCTime+  }+  deriving (Eq, Show)++data JVMBufferPoolStats = JVMBufferPoolStats+  { jvmBufferPoolStatsTotalCapacity :: Bytes,+    jvmBufferPoolStatsUsed :: Bytes,+    jvmBufferPoolStatsCount :: Int+  }+  deriving (Eq, Show)++data JVMGCStats = JVMGCStats+  { jvmGCStatsCollectionTime :: NominalDiffTime,+    jvmGCStatsCollectionCount :: Int+  }+  deriving (Eq, Show)++data JVMPoolStats = JVMPoolStats+  { jvmPoolStatsPeakMax :: Bytes,+    jvmPoolStatsPeakUsed :: Bytes,+    jvmPoolStatsMax :: Bytes,+    jvmPoolStatsUsed :: Bytes+  }+  deriving (Eq, Show)++data NodeProcessStats = NodeProcessStats+  { nodeProcessTimestamp :: UTCTime,+    nodeProcessOpenFDs :: Int,+    nodeProcessMaxFDs :: Int,+    nodeProcessCPUPercent :: Int,+    nodeProcessCPUTotal :: NominalDiffTime,+    nodeProcessMemTotalVirtual :: Bytes+  }+  deriving (Eq, Show)++data NodeOSStats = NodeOSStats+  { nodeOSTimestamp :: UTCTime,+    nodeOSCPUPercent :: Int,+    nodeOSLoad :: Maybe LoadAvgs,+    nodeOSMemTotal :: Bytes,+    nodeOSMemFree :: Bytes,+    nodeOSMemFreePercent :: Int,+    nodeOSMemUsed :: Bytes,+    nodeOSMemUsedPercent :: Int,+    nodeOSSwapTotal :: Bytes,+    nodeOSSwapFree :: Bytes,+    nodeOSSwapUsed :: Bytes+  }+  deriving (Eq, Show)++data LoadAvgs = LoadAvgs+  { loadAvg1Min :: Double,+    loadAvg5Min :: Double,+    loadAvg15Min :: Double+  }+  deriving (Eq, Show)++data NodeIndicesStats = NodeIndicesStats+  { nodeIndicesStatsRecoveryThrottleTime :: Maybe NominalDiffTime,+    nodeIndicesStatsRecoveryCurrentAsTarget :: Maybe Int,+    nodeIndicesStatsRecoveryCurrentAsSource :: Maybe Int,+    nodeIndicesStatsQueryCacheMisses :: Maybe Int,+    nodeIndicesStatsQueryCacheHits :: Maybe Int,+    nodeIndicesStatsQueryCacheEvictions :: Maybe Int,+    nodeIndicesStatsQueryCacheSize :: Maybe Bytes,+    nodeIndicesStatsSuggestCurrent :: Maybe Int,+    nodeIndicesStatsSuggestTime :: Maybe NominalDiffTime,+    nodeIndicesStatsSuggestTotal :: Maybe Int,+    nodeIndicesStatsTranslogSize :: Bytes,+    nodeIndicesStatsTranslogOps :: Int,+    nodeIndicesStatsSegFixedBitSetMemory :: Maybe Bytes,+    nodeIndicesStatsSegVersionMapMemory :: Bytes,+    nodeIndicesStatsSegIndexWriterMaxMemory :: Maybe Bytes,+    nodeIndicesStatsSegIndexWriterMemory :: Bytes,+    nodeIndicesStatsSegMemory :: Bytes,+    nodeIndicesStatsSegCount :: Int,+    nodeIndicesStatsCompletionSize :: Bytes,+    nodeIndicesStatsPercolateQueries :: Maybe Int,+    nodeIndicesStatsPercolateMemory :: Maybe Bytes,+    nodeIndicesStatsPercolateCurrent :: Maybe Int,+    nodeIndicesStatsPercolateTime :: Maybe NominalDiffTime,+    nodeIndicesStatsPercolateTotal :: Maybe Int,+    nodeIndicesStatsFieldDataEvictions :: Int,+    nodeIndicesStatsFieldDataMemory :: Bytes,+    nodeIndicesStatsWarmerTotalTime :: NominalDiffTime,+    nodeIndicesStatsWarmerTotal :: Int,+    nodeIndicesStatsWarmerCurrent :: Int,+    nodeIndicesStatsFlushTotalTime :: NominalDiffTime,+    nodeIndicesStatsFlushTotal :: Int,+    nodeIndicesStatsRefreshTotalTime :: NominalDiffTime,+    nodeIndicesStatsRefreshTotal :: Int,+    nodeIndicesStatsMergesTotalSize :: Bytes,+    nodeIndicesStatsMergesTotalDocs :: Int,+    nodeIndicesStatsMergesTotalTime :: NominalDiffTime,+    nodeIndicesStatsMergesTotal :: Int,+    nodeIndicesStatsMergesCurrentSize :: Bytes,+    nodeIndicesStatsMergesCurrentDocs :: Int,+    nodeIndicesStatsMergesCurrent :: Int,+    nodeIndicesStatsSearchFetchCurrent :: Int,+    nodeIndicesStatsSearchFetchTime :: NominalDiffTime,+    nodeIndicesStatsSearchFetchTotal :: Int,+    nodeIndicesStatsSearchQueryCurrent :: Int,+    nodeIndicesStatsSearchQueryTime :: NominalDiffTime,+    nodeIndicesStatsSearchQueryTotal :: Int,+    nodeIndicesStatsSearchOpenContexts :: Int,+    nodeIndicesStatsGetCurrent :: Int,+    nodeIndicesStatsGetMissingTime :: NominalDiffTime,+    nodeIndicesStatsGetMissingTotal :: Int,+    nodeIndicesStatsGetExistsTime :: NominalDiffTime,+    nodeIndicesStatsGetExistsTotal :: Int,+    nodeIndicesStatsGetTime :: NominalDiffTime,+    nodeIndicesStatsGetTotal :: Int,+    nodeIndicesStatsIndexingThrottleTime :: Maybe NominalDiffTime,+    nodeIndicesStatsIndexingIsThrottled :: Maybe Bool,+    nodeIndicesStatsIndexingNoopUpdateTotal :: Maybe Int,+    nodeIndicesStatsIndexingDeleteCurrent :: Int,+    nodeIndicesStatsIndexingDeleteTime :: NominalDiffTime,+    nodeIndicesStatsIndexingDeleteTotal :: Int,+    nodeIndicesStatsIndexingIndexCurrent :: Int,+    nodeIndicesStatsIndexingIndexTime :: NominalDiffTime,+    nodeIndicesStatsIndexingTotal :: Int,+    nodeIndicesStatsStoreThrottleTime :: Maybe NominalDiffTime,+    nodeIndicesStatsStoreSize :: Bytes,+    nodeIndicesStatsDocsDeleted :: Int,+    nodeIndicesStatsDocsCount :: Int+  }+  deriving (Eq, Show)++-- | A quirky address format used throughout Elasticsearch. An example+-- would be inet[/1.1.1.1:9200]. inet may be a placeholder for a+-- <https://en.wikipedia.org/wiki/Fully_qualified_domain_name FQDN>.+newtype EsAddress = EsAddress {esAddress :: Text}+  deriving (Eq, Ord, Show, FromJSON)++-- | Typically a 7 character hex string.+newtype BuildHash = BuildHash {buildHash :: Text}+  deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)++newtype PluginName = PluginName {pluginName :: Text}+  deriving (Eq, Ord, Show, FromJSON)++data NodeInfo = NodeInfo+  { nodeInfoHTTPAddress :: Maybe EsAddress,+    nodeInfoBuild :: BuildHash,+    nodeInfoESVersion :: VersionNumber,+    nodeInfoIP :: Server,+    nodeInfoHost :: Server,+    nodeInfoTransportAddress :: EsAddress,+    nodeInfoName :: NodeName,+    nodeInfoFullId :: FullNodeId,+    nodeInfoPlugins :: [NodePluginInfo],+    nodeInfoHTTP :: NodeHTTPInfo,+    nodeInfoTransport :: NodeTransportInfo,+    nodeInfoNetwork :: Maybe NodeNetworkInfo,+    nodeInfoThreadPool :: Map Text NodeThreadPoolInfo,+    nodeInfoJVM :: NodeJVMInfo,+    nodeInfoProcess :: NodeProcessInfo,+    nodeInfoOS :: NodeOSInfo,+    -- | The members of the settings objects are not consistent,+    -- dependent on plugins, etc.+    nodeInfoSettings :: Object+  }+  deriving (Eq, Show)++data NodePluginInfo = NodePluginInfo+  { -- | Is this a site plugin?+    nodePluginSite :: Maybe Bool,+    -- | Is this plugin running on the JVM+    nodePluginJVM :: Maybe Bool,+    nodePluginDescription :: Text,+    nodePluginVersion :: MaybeNA VersionNumber,+    nodePluginName :: PluginName+  }+  deriving (Eq, Show)++data NodeHTTPInfo = NodeHTTPInfo+  { nodeHTTPMaxContentLength :: Bytes,+    nodeHTTPpublishAddress :: EsAddress,+    nodeHTTPbound_address :: [EsAddress]+  }+  deriving (Eq, Show)++data NodeTransportInfo = NodeTransportInfo+  { nodeTransportProfiles :: [BoundTransportAddress],+    nodeTransportPublishAddress :: EsAddress,+    nodeTransportBoundAddress :: [EsAddress]+  }+  deriving (Eq, Show)++data BoundTransportAddress = BoundTransportAddress+  { publishAddress :: EsAddress,+    boundAddress :: [EsAddress]+  }+  deriving (Eq, Show)++data NodeNetworkInfo = NodeNetworkInfo+  { nodeNetworkPrimaryInterface :: NodeNetworkInterface,+    nodeNetworkRefreshInterval :: NominalDiffTime+  }+  deriving (Eq, Show)++newtype MacAddress = MacAddress {macAddress :: Text}+  deriving (Eq, Ord, Show, FromJSON)++newtype NetworkInterfaceName = NetworkInterfaceName {networkInterfaceName :: Text}+  deriving (Eq, Ord, Show, FromJSON)++data NodeNetworkInterface = NodeNetworkInterface+  { nodeNetIfaceMacAddress :: MacAddress,+    nodeNetIfaceName :: NetworkInterfaceName,+    nodeNetIfaceAddress :: Server+  }+  deriving (Eq, Show)++data ThreadPool = ThreadPool+  { nodeThreadPoolName :: Text,+    nodeThreadPoolInfo :: NodeThreadPoolInfo+  }+  deriving (Eq, Show)++data NodeThreadPoolInfo = NodeThreadPoolInfo+  { nodeThreadPoolQueueSize :: ThreadPoolSize,+    nodeThreadPoolKeepalive :: Maybe NominalDiffTime,+    nodeThreadPoolMin :: Maybe Int,+    nodeThreadPoolMax :: Maybe Int,+    nodeThreadPoolType :: ThreadPoolType+  }+  deriving (Eq, Show)++data ThreadPoolSize+  = ThreadPoolBounded Int+  | ThreadPoolUnbounded+  deriving (Eq, Show)++data ThreadPoolType+  = ThreadPoolScaling+  | ThreadPoolFixed+  | ThreadPoolCached+  | ThreadPoolFixedAutoQueueSize+  deriving (Eq, Show)++data NodeJVMInfo = NodeJVMInfo+  { nodeJVMInfoMemoryPools :: [JVMMemoryPool],+    nodeJVMInfoMemoryPoolsGCCollectors :: [JVMGCCollector],+    nodeJVMInfoMemoryInfo :: JVMMemoryInfo,+    nodeJVMInfoStartTime :: UTCTime,+    nodeJVMInfoVMVendor :: Text,+    -- | JVM doesn't seme to follow normal version conventions+    nodeJVMVMVersion :: VMVersion,+    nodeJVMVMName :: Text,+    nodeJVMVersion :: JVMVersion,+    nodeJVMPID :: PID+  }+  deriving (Eq, Show)++-- | We cannot parse JVM version numbers and we're not going to try.+newtype JVMVersion = JVMVersion {unJVMVersion :: Text}+  deriving (Eq, Show)++instance FromJSON JVMVersion where+  parseJSON = withText "JVMVersion" (pure . JVMVersion)++data JVMMemoryInfo = JVMMemoryInfo+  { jvmMemoryInfoDirectMax :: Bytes,+    jvmMemoryInfoNonHeapMax :: Bytes,+    jvmMemoryInfoNonHeapInit :: Bytes,+    jvmMemoryInfoHeapMax :: Bytes,+    jvmMemoryInfoHeapInit :: Bytes+  }+  deriving (Eq, Show)++-- VM version numbers don't appear to be SemVer+-- so we're special casing this jawn.+newtype VMVersion = VMVersion {unVMVersion :: Text}+  deriving (Eq, Show)++instance ToJSON VMVersion where+  toJSON = toJSON . unVMVersion++instance FromJSON VMVersion where+  parseJSON = withText "VMVersion" (pure . VMVersion)++newtype JVMMemoryPool = JVMMemoryPool+  { jvmMemoryPool :: Text+  }+  deriving (Eq, Show, FromJSON)++newtype JVMGCCollector = JVMGCCollector+  { jvmGCCollector :: Text+  }+  deriving (Eq, Show, FromJSON)++newtype PID = PID+  { pid :: Int+  }+  deriving (Eq, Show, FromJSON)++data NodeOSInfo = NodeOSInfo+  { nodeOSRefreshInterval :: NominalDiffTime,+    nodeOSName :: Text,+    nodeOSArch :: Text,+    nodeOSVersion :: Text, -- semver breaks on "5.10.60.1-microsoft-standard-WSL2"+    nodeOSAvailableProcessors :: Int,+    nodeOSAllocatedProcessors :: Int+  }+  deriving (Eq, Show)++data CPUInfo = CPUInfo+  { cpuCacheSize :: Bytes,+    cpuCoresPerSocket :: Int,+    cpuTotalSockets :: Int,+    cpuTotalCores :: Int,+    cpuMHZ :: Int,+    cpuModel :: Text,+    cpuVendor :: Text+  }+  deriving (Eq, Show)++data NodeProcessInfo = NodeProcessInfo+  { -- | See <https://www.elastic.co/guide/en/elasticsearch/reference/current/setup-configuration.html>+    nodeProcessMLockAll :: Bool,+    nodeProcessMaxFileDescriptors :: Maybe Int,+    nodeProcessId :: PID,+    nodeProcessRefreshInterval :: NominalDiffTime+  }+  deriving (Eq, Show)++data ShardResult = ShardResult+  { shardTotal :: Int,+    shardsSuccessful :: Int,+    shardsSkipped :: Int,+    shardsFailed :: Int+  }+  deriving (Eq, Show)++instance FromJSON ShardResult where+  parseJSON =+    withObject "ShardResult" $ \v ->+      ShardResult+        <$> v .:? "total" .!= 0+        <*> v .:? "successful" .!= 0+        <*> v .:? "skipped" .!= 0+        <*> v .:? "failed" .!= 0++data SnapshotState+  = SnapshotInit+  | SnapshotStarted+  | SnapshotSuccess+  | SnapshotFailed+  | SnapshotAborted+  | SnapshotMissing+  | SnapshotWaiting+  deriving (Eq, Show)++instance FromJSON SnapshotState where+  parseJSON = withText "SnapshotState" parse+    where+      parse "INIT" = return SnapshotInit+      parse "STARTED" = return SnapshotStarted+      parse "SUCCESS" = return SnapshotSuccess+      parse "FAILED" = return SnapshotFailed+      parse "ABORTED" = return SnapshotAborted+      parse "MISSING" = return SnapshotMissing+      parse "WAITING" = return SnapshotWaiting+      parse t = fail ("Invalid snapshot state " <> T.unpack t)++data SnapshotRestoreSettings = SnapshotRestoreSettings+  { -- | Should the API call return immediately after initializing+    -- the restore or wait until completed? Note that if this is+    -- enabled, it could wait a long time, so you should adjust your+    -- 'ManagerSettings' accordingly to set long timeouts or+    -- explicitly handle timeouts.+    snapRestoreWaitForCompletion :: Bool,+    -- | Nothing will restore all indices in the snapshot. Just [] is+    -- permissable and will essentially be a no-op restore.+    snapRestoreIndices :: Maybe IndexSelection,+    -- | If set to True, any indices that do not exist will be ignored+    -- during snapshot rather than failing the restore.+    snapRestoreIgnoreUnavailable :: Bool,+    -- | If set to false, will ignore any global state in the snapshot+    -- and will not restore it.+    snapRestoreIncludeGlobalState :: Bool,+    -- | A regex pattern for matching indices. Used with+    -- 'snapRestoreRenameReplacement', the restore can reference the+    -- matched index and create a new index name upon restore.+    snapRestoreRenamePattern :: Maybe RestoreRenamePattern,+    -- | Expression of how index renames should be constructed.+    snapRestoreRenameReplacement :: Maybe (NonEmpty RestoreRenameToken),+    -- | If some indices fail to restore, should the process proceed?+    snapRestorePartial :: Bool,+    -- | Should the restore also restore the aliases captured in the+    -- snapshot.+    snapRestoreIncludeAliases :: Bool,+    -- | Settings to apply during the restore process. __NOTE:__ This+    -- option is not supported in ES < 1.5 and should be set to+    -- Nothing in that case.+    snapRestoreIndexSettingsOverrides :: Maybe RestoreIndexSettings,+    -- | This type could be more rich but it isn't clear which+    -- settings are allowed to be ignored during restore, so we're+    -- going with including this feature in a basic form rather than+    -- omitting it. One example here would be+    -- "index.refresh_interval". Any setting specified here will+    -- revert back to the server default during the restore process.+    snapRestoreIgnoreIndexSettings :: Maybe (NonEmpty Text)+  }+  deriving (Eq, Show)++newtype SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings+  { -- | After creation/update, synchronously check that nodes can+    -- write to this repo. Defaults to True. You may use False if you+    -- need a faster response and plan on verifying manually later+    -- with 'verifySnapshotRepo'.+    repoUpdateVerify :: Bool+  }+  deriving (Eq, Show)++-- | Reasonable defaults for repo creation/update+--+-- * repoUpdateVerify True+defaultSnapshotRepoUpdateSettings :: SnapshotRepoUpdateSettings+defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True++-- | A filesystem-based snapshot repo that ships with+-- Elasticsearch. This is an instance of 'SnapshotRepo' so it can be+-- used with 'updateSnapshotRepo'+data FsSnapshotRepo = FsSnapshotRepo+  { fsrName :: SnapshotRepoName,+    fsrLocation :: FilePath,+    fsrCompressMetadata :: Bool,+    -- | Size by which to split large files during snapshotting.+    fsrChunkSize :: Maybe Bytes,+    -- | Throttle node restore rate. If not supplied, defaults to 40mb/sec+    fsrMaxRestoreBytesPerSec :: Maybe Bytes,+    -- | Throttle node snapshot rate. If not supplied, defaults to 40mb/sec+    fsrMaxSnapshotBytesPerSec :: Maybe Bytes+  }+  deriving (Eq, Show, Generic)++instance SnapshotRepo FsSnapshotRepo where+  toGSnapshotRepo FsSnapshotRepo {..} =+    GenericSnapshotRepo fsrName fsRepoType (GenericSnapshotRepoSettings settings)+    where+      Object settings =+        object $+          [ "location" .= fsrLocation,+            "compress" .= fsrCompressMetadata+          ]+            ++ optionalPairs+      optionalPairs =+        catMaybes+          [ ("chunk_size" .=) <$> fsrChunkSize,+            ("max_restore_bytes_per_sec" .=) <$> fsrMaxRestoreBytesPerSec,+            ("max_snapshot_bytes_per_sec" .=) <$> fsrMaxSnapshotBytesPerSec+          ]+  fromGSnapshotRepo GenericSnapshotRepo {..}+    | gSnapshotRepoType == fsRepoType = do+      let o = gSnapshotRepoSettingsObject gSnapshotRepoSettings+      parseRepo $+        FsSnapshotRepo gSnapshotRepoName <$> o .: "location"+          <*> o .:? "compress" .!= False+          <*> o .:? "chunk_size"+          <*> o .:? "max_restore_bytes_per_sec"+          <*> o .:? "max_snapshot_bytes_per_sec"+    | otherwise = Left (RepoTypeMismatch fsRepoType gSnapshotRepoType)++parseRepo :: Parser a -> Either SnapshotRepoConversionError a+parseRepo parser = case parseEither (const parser) () of+  Left e -> Left (OtherRepoConversionError (T.pack e))+  Right a -> Right a++fsRepoType :: SnapshotRepoType+fsRepoType = SnapshotRepoType "fs"++-- | Law: fromGSnapshotRepo (toGSnapshotRepo r) == Right r+class SnapshotRepo r where+  toGSnapshotRepo :: r -> GenericSnapshotRepo+  fromGSnapshotRepo :: GenericSnapshotRepo -> Either SnapshotRepoConversionError r++data SnapshotRepoConversionError+  = -- | Expected type and actual type+    RepoTypeMismatch SnapshotRepoType SnapshotRepoType+  | OtherRepoConversionError Text+  deriving (Show, Eq)++instance Exception SnapshotRepoConversionError++data SnapshotCreateSettings = SnapshotCreateSettings+  { -- | Should the API call return immediately after initializing+    -- the snapshot or wait until completed? Note that if this is+    -- enabled it could wait a long time, so you should adjust your+    -- 'ManagerSettings' accordingly to set long timeouts or+    -- explicitly handle timeouts.+    snapWaitForCompletion :: Bool,+    -- | Nothing will snapshot all indices. Just [] is permissable and+    -- will essentially be a no-op snapshot.+    snapIndices :: Maybe IndexSelection,+    -- | If set to True, any matched indices that don't exist will be+    -- ignored. Otherwise it will be an error and fail.+    snapIgnoreUnavailable :: Bool,+    snapIncludeGlobalState :: Bool,+    -- | If some indices failed to snapshot (e.g. if not all primary+    -- shards are available), should the process proceed?+    snapPartial :: Bool+  }+  deriving (Eq, Show)++-- | Reasonable defaults for snapshot creation+--+-- * snapWaitForCompletion False+-- * snapIndices Nothing+-- * snapIgnoreUnavailable False+-- * snapIncludeGlobalState True+-- * snapPartial False+defaultSnapshotCreateSettings :: SnapshotCreateSettings+defaultSnapshotCreateSettings =+  SnapshotCreateSettings+    { snapWaitForCompletion = False,+      snapIndices = Nothing,+      snapIgnoreUnavailable = False,+      snapIncludeGlobalState = True,+      snapPartial = False+    }++data SnapshotSelection+  = SnapshotList (NonEmpty SnapshotPattern)+  | AllSnapshots+  deriving (Eq, Show)++-- | Either specifies an exact snapshot name or one with globs in it,+-- e.g. @SnapPattern "foo*"@ __NOTE__: Patterns are not supported on+-- ES < 1.7+data SnapshotPattern+  = ExactSnap SnapshotName+  | SnapPattern Text+  deriving (Eq, Show)++-- | General information about the state of a snapshot. Has some+-- redundancies with 'SnapshotStatus'+data SnapshotInfo = SnapshotInfo+  { snapInfoShards :: ShardResult,+    snapInfoFailures :: [SnapshotShardFailure],+    snapInfoDuration :: NominalDiffTime,+    snapInfoEndTime :: UTCTime,+    snapInfoStartTime :: UTCTime,+    snapInfoState :: SnapshotState,+    snapInfoIndices :: [IndexName],+    snapInfoName :: SnapshotName+  }+  deriving (Eq, Show)++instance FromJSON SnapshotInfo where+  parseJSON = withObject "SnapshotInfo" parse+    where+      parse o =+        SnapshotInfo <$> o .: "shards"+          <*> o .: "failures"+          <*> (unMS <$> o .: "duration_in_millis")+          <*> (posixMS <$> o .: "end_time_in_millis")+          <*> (posixMS <$> o .: "start_time_in_millis")+          <*> o .: "state"+          <*> o .: "indices"+          <*> o .: "snapshot"++data SnapshotShardFailure = SnapshotShardFailure+  { snapShardFailureIndex :: IndexName,+    snapShardFailureNodeId :: Maybe NodeName, -- I'm not 100% sure this isn't actually 'FullNodeId'+    snapShardFailureReason :: Text,+    snapShardFailureShardId :: ShardId+  }+  deriving (Eq, Show)++instance FromJSON SnapshotShardFailure where+  parseJSON = withObject "SnapshotShardFailure" parse+    where+      parse o =+        SnapshotShardFailure <$> o .: "index"+          <*> o .:? "node_id"+          <*> o .: "reason"+          <*> o .: "shard_id"++-- | Regex-stype pattern, e.g. "index_(.+)" to match index names+newtype RestoreRenamePattern = RestoreRenamePattern {rrPattern :: Text}+  deriving (Eq, Show, Ord, ToJSON)++-- | A single token in a index renaming scheme for a restore. These+-- are concatenated into a string before being sent to+-- Elasticsearch. Check out these Java+-- <https://docs.oracle.com/javase/7/docs/api/java/util/regex/Matcher.html docs> to find out more if you're into that sort of thing.+data RestoreRenameToken+  = -- | Just a literal string of characters+    RRTLit Text+  | -- | Equivalent to $0. The entire matched pattern, not any subgroup+    RRSubWholeMatch+  | -- | A specific reference to a group number+    RRSubGroup RRGroupRefNum+  deriving (Eq, Show)++-- | A group number for regex matching. Only values from 1-9 are+-- supported. Construct with 'mkRRGroupRefNum'+newtype RRGroupRefNum = RRGroupRefNum {rrGroupRefNum :: Int}+  deriving (Eq, Ord, Show)++instance Bounded RRGroupRefNum where+  minBound = RRGroupRefNum 1+  maxBound = RRGroupRefNum 9++-- | Only allows valid group number references (1-9).+mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum+mkRRGroupRefNum i+  | i >= rrGroupRefNum minBound+      && i <= rrGroupRefNum maxBound =+    Just $ RRGroupRefNum i+  | otherwise = Nothing++-- | Reasonable defaults for snapshot restores+--+-- * snapRestoreWaitForCompletion False+-- * snapRestoreIndices Nothing+-- * snapRestoreIgnoreUnavailable False+-- * snapRestoreIncludeGlobalState True+-- * snapRestoreRenamePattern Nothing+-- * snapRestoreRenameReplacement Nothing+-- * snapRestorePartial False+-- * snapRestoreIncludeAliases True+-- * snapRestoreIndexSettingsOverrides Nothing+-- * snapRestoreIgnoreIndexSettings Nothing+defaultSnapshotRestoreSettings :: SnapshotRestoreSettings+defaultSnapshotRestoreSettings =+  SnapshotRestoreSettings+    { snapRestoreWaitForCompletion = False,+      snapRestoreIndices = Nothing,+      snapRestoreIgnoreUnavailable = False,+      snapRestoreIncludeGlobalState = True,+      snapRestoreRenamePattern = Nothing,+      snapRestoreRenameReplacement = Nothing,+      snapRestorePartial = False,+      snapRestoreIncludeAliases = True,+      snapRestoreIndexSettingsOverrides = Nothing,+      snapRestoreIgnoreIndexSettings = Nothing+    }++-- | Index settings that can be overridden. The docs only mention you+-- can update number of replicas, but there may be more. You+-- definitely cannot override shard count.+newtype RestoreIndexSettings = RestoreIndexSettings+  { restoreOverrideReplicas :: Maybe ReplicaCount+  }+  deriving (Eq, Show)++instance ToJSON RestoreIndexSettings where+  toJSON RestoreIndexSettings {..} = object prs+    where+      prs = catMaybes [("index.number_of_replicas" .=) <$> restoreOverrideReplicas]++instance FromJSON NodesInfo where+  parseJSON = withObject "NodesInfo" parse+    where+      parse o = do+        nodes <- o .: "nodes"+        infos <- forM (HM.toList nodes) $ \(fullNID, v) -> do+          node <- parseJSON v+          parseNodeInfo (FullNodeId fullNID) node+        cn <- o .: "cluster_name"+        return (NodesInfo infos cn)++instance FromJSON NodesStats where+  parseJSON = withObject "NodesStats" parse+    where+      parse o = do+        nodes <- o .: "nodes"+        stats <- forM (HM.toList nodes) $ \(fullNID, v) -> do+          node <- parseJSON v+          parseNodeStats (FullNodeId fullNID) node+        cn <- o .: "cluster_name"+        return (NodesStats stats cn)++instance FromJSON NodeBreakerStats where+  parseJSON = withObject "NodeBreakerStats" parse+    where+      parse o =+        NodeBreakerStats <$> o .: "tripped"+          <*> o .: "overhead"+          <*> o .: "estimated_size_in_bytes"+          <*> o .: "limit_size_in_bytes"++instance FromJSON NodeHTTPStats where+  parseJSON = withObject "NodeHTTPStats" parse+    where+      parse o =+        NodeHTTPStats <$> o .: "total_opened"+          <*> o .: "current_open"++instance FromJSON NodeTransportStats where+  parseJSON = withObject "NodeTransportStats" parse+    where+      parse o =+        NodeTransportStats <$> o .: "tx_size_in_bytes"+          <*> o .: "tx_count"+          <*> o .: "rx_size_in_bytes"+          <*> o .: "rx_count"+          <*> o .: "server_open"++instance FromJSON NodeFSStats where+  parseJSON = withObject "NodeFSStats" parse+    where+      parse o =+        NodeFSStats <$> o .: "data"+          <*> o .: "total"+          <*> (posixMS <$> o .: "timestamp")++instance FromJSON NodeDataPathStats where+  parseJSON = withObject "NodeDataPathStats" parse+    where+      parse o =+        NodeDataPathStats <$> (fmap unStringlyTypedDouble <$> o .:? "disk_service_time")+          <*> (fmap unStringlyTypedDouble <$> o .:? "disk_queue")+          <*> o .:? "disk_io_size_in_bytes"+          <*> o .:? "disk_write_size_in_bytes"+          <*> o .:? "disk_read_size_in_bytes"+          <*> o .:? "disk_io_op"+          <*> o .:? "disk_writes"+          <*> o .:? "disk_reads"+          <*> o .: "available_in_bytes"+          <*> o .: "free_in_bytes"+          <*> o .: "total_in_bytes"+          <*> o .:? "type"+          <*> o .:? "dev"+          <*> o .: "mount"+          <*> o .: "path"++instance FromJSON NodeFSTotalStats where+  parseJSON = withObject "NodeFSTotalStats" parse+    where+      parse o =+        NodeFSTotalStats <$> (fmap unStringlyTypedDouble <$> o .:? "disk_service_time")+          <*> (fmap unStringlyTypedDouble <$> o .:? "disk_queue")+          <*> o .:? "disk_io_size_in_bytes"+          <*> o .:? "disk_write_size_in_bytes"+          <*> o .:? "disk_read_size_in_bytes"+          <*> o .:? "disk_io_op"+          <*> o .:? "disk_writes"+          <*> o .:? "disk_reads"+          <*> o .: "available_in_bytes"+          <*> o .: "free_in_bytes"+          <*> o .: "total_in_bytes"++instance FromJSON NodeNetworkStats where+  parseJSON = withObject "NodeNetworkStats" parse+    where+      parse o = do+        tcp <- o .: "tcp"+        NodeNetworkStats <$> tcp .: "out_rsts"+          <*> tcp .: "in_errs"+          <*> tcp .: "attempt_fails"+          <*> tcp .: "estab_resets"+          <*> tcp .: "retrans_segs"+          <*> tcp .: "out_segs"+          <*> tcp .: "in_segs"+          <*> tcp .: "curr_estab"+          <*> tcp .: "passive_opens"+          <*> tcp .: "active_opens"++instance FromJSON NodeThreadPoolStats where+  parseJSON = withObject "NodeThreadPoolStats" parse+    where+      parse o =+        NodeThreadPoolStats <$> o .: "completed"+          <*> o .: "largest"+          <*> o .: "rejected"+          <*> o .: "active"+          <*> o .: "queue"+          <*> o .: "threads"++instance FromJSON NodeJVMStats where+  parseJSON = withObject "NodeJVMStats" parse+    where+      parse o = do+        bufferPools <- o .: "buffer_pools"+        mapped <- bufferPools .: "mapped"+        direct <- bufferPools .: "direct"+        gc <- o .: "gc"+        collectors <- gc .: "collectors"+        oldC <- collectors .: "old"+        youngC <- collectors .: "young"+        threads <- o .: "threads"+        mem <- o .: "mem"+        pools <- mem .: "pools"+        oldM <- pools .: "old"+        survivorM <- pools .: "survivor"+        youngM <- pools .: "young"+        NodeJVMStats <$> pure mapped+          <*> pure direct+          <*> pure oldC+          <*> pure youngC+          <*> threads .: "peak_count"+          <*> threads .: "count"+          <*> pure oldM+          <*> pure survivorM+          <*> pure youngM+          <*> mem .: "non_heap_committed_in_bytes"+          <*> mem .: "non_heap_used_in_bytes"+          <*> mem .: "heap_max_in_bytes"+          <*> mem .: "heap_committed_in_bytes"+          <*> mem .: "heap_used_percent"+          <*> mem .: "heap_used_in_bytes"+          <*> (unMS <$> o .: "uptime_in_millis")+          <*> (posixMS <$> o .: "timestamp")++instance FromJSON JVMBufferPoolStats where+  parseJSON = withObject "JVMBufferPoolStats" parse+    where+      parse o =+        JVMBufferPoolStats <$> o .: "total_capacity_in_bytes"+          <*> o .: "used_in_bytes"+          <*> o .: "count"++instance FromJSON JVMGCStats where+  parseJSON = withObject "JVMGCStats" parse+    where+      parse o =+        JVMGCStats <$> (unMS <$> o .: "collection_time_in_millis")+          <*> o .: "collection_count"++instance FromJSON JVMPoolStats where+  parseJSON = withObject "JVMPoolStats" parse+    where+      parse o =+        JVMPoolStats <$> o .: "peak_max_in_bytes"+          <*> o .: "peak_used_in_bytes"+          <*> o .: "max_in_bytes"+          <*> o .: "used_in_bytes"++instance FromJSON NodeProcessStats where+  parseJSON = withObject "NodeProcessStats" parse+    where+      parse o = do+        mem <- o .: "mem"+        cpu <- o .: "cpu"+        NodeProcessStats <$> (posixMS <$> o .: "timestamp")+          <*> o .: "open_file_descriptors"+          <*> o .: "max_file_descriptors"+          <*> cpu .: "percent"+          <*> (unMS <$> cpu .: "total_in_millis")+          <*> mem .: "total_virtual_in_bytes"++instance FromJSON NodeOSStats where+  parseJSON = withObject "NodeOSStats" parse+    where+      parse o = do+        swap <- o .: "swap"+        mem <- o .: "mem"+        cpu <- o .: "cpu"+        load <- o .:? "load_average"+        NodeOSStats <$> (posixMS <$> o .: "timestamp")+          <*> cpu .: "percent"+          <*> pure load+          <*> mem .: "total_in_bytes"+          <*> mem .: "free_in_bytes"+          <*> mem .: "free_percent"+          <*> mem .: "used_in_bytes"+          <*> mem .: "used_percent"+          <*> swap .: "total_in_bytes"+          <*> swap .: "free_in_bytes"+          <*> swap .: "used_in_bytes"++instance FromJSON LoadAvgs where+  parseJSON = withArray "LoadAvgs" parse+    where+      parse v = case V.toList v of+        [one, five, fifteen] ->+          LoadAvgs <$> parseJSON one+            <*> parseJSON five+            <*> parseJSON fifteen+        _ -> fail "Expecting a triple of Doubles"++instance FromJSON NodeIndicesStats where+  parseJSON = withObject "NodeIndicesStats" parse+    where+      parse o = do+        let (.::) mv k = case mv of+              Just v -> Just <$> v .: k+              Nothing -> pure Nothing+        mRecovery <- o .:? "recovery"+        mQueryCache <- o .:? "query_cache"+        mSuggest <- o .:? "suggest"+        translog <- o .: "translog"+        segments <- o .: "segments"+        completion <- o .: "completion"+        mPercolate <- o .:? "percolate"+        fielddata <- o .: "fielddata"+        warmer <- o .: "warmer"+        flush <- o .: "flush"+        refresh <- o .: "refresh"+        merges <- o .: "merges"+        search <- o .: "search"+        getStats <- o .: "get"+        indexing <- o .: "indexing"+        store <- o .: "store"+        docs <- o .: "docs"+        NodeIndicesStats <$> (fmap unMS <$> mRecovery .:: "throttle_time_in_millis")+          <*> mRecovery .:: "current_as_target"+          <*> mRecovery .:: "current_as_source"+          <*> mQueryCache .:: "miss_count"+          <*> mQueryCache .:: "hit_count"+          <*> mQueryCache .:: "evictions"+          <*> mQueryCache .:: "memory_size_in_bytes"+          <*> mSuggest .:: "current"+          <*> (fmap unMS <$> mSuggest .:: "time_in_millis")+          <*> mSuggest .:: "total"+          <*> translog .: "size_in_bytes"+          <*> translog .: "operations"+          <*> segments .:? "fixed_bit_set_memory_in_bytes"+          <*> segments .: "version_map_memory_in_bytes"+          <*> segments .:? "index_writer_max_memory_in_bytes"+          <*> segments .: "index_writer_memory_in_bytes"+          <*> segments .: "memory_in_bytes"+          <*> segments .: "count"+          <*> completion .: "size_in_bytes"+          <*> mPercolate .:: "queries"+          <*> mPercolate .:: "memory_size_in_bytes"+          <*> mPercolate .:: "current"+          <*> (fmap unMS <$> mPercolate .:: "time_in_millis")+          <*> mPercolate .:: "total"+          <*> fielddata .: "evictions"+          <*> fielddata .: "memory_size_in_bytes"+          <*> (unMS <$> warmer .: "total_time_in_millis")+          <*> warmer .: "total"+          <*> warmer .: "current"+          <*> (unMS <$> flush .: "total_time_in_millis")+          <*> flush .: "total"+          <*> (unMS <$> refresh .: "total_time_in_millis")+          <*> refresh .: "total"+          <*> merges .: "total_size_in_bytes"+          <*> merges .: "total_docs"+          <*> (unMS <$> merges .: "total_time_in_millis")+          <*> merges .: "total"+          <*> merges .: "current_size_in_bytes"+          <*> merges .: "current_docs"+          <*> merges .: "current"+          <*> search .: "fetch_current"+          <*> (unMS <$> search .: "fetch_time_in_millis")+          <*> search .: "fetch_total"+          <*> search .: "query_current"+          <*> (unMS <$> search .: "query_time_in_millis")+          <*> search .: "query_total"+          <*> search .: "open_contexts"+          <*> getStats .: "current"+          <*> (unMS <$> getStats .: "missing_time_in_millis")+          <*> getStats .: "missing_total"+          <*> (unMS <$> getStats .: "exists_time_in_millis")+          <*> getStats .: "exists_total"+          <*> (unMS <$> getStats .: "time_in_millis")+          <*> getStats .: "total"+          <*> (fmap unMS <$> indexing .:? "throttle_time_in_millis")+          <*> indexing .:? "is_throttled"+          <*> indexing .:? "noop_update_total"+          <*> indexing .: "delete_current"+          <*> (unMS <$> indexing .: "delete_time_in_millis")+          <*> indexing .: "delete_total"+          <*> indexing .: "index_current"+          <*> (unMS <$> indexing .: "index_time_in_millis")+          <*> indexing .: "index_total"+          <*> (fmap unMS <$> store .:? "throttle_time_in_millis")+          <*> store .: "size_in_bytes"+          <*> docs .: "deleted"+          <*> docs .: "count"++instance FromJSON NodeBreakersStats where+  parseJSON = withObject "NodeBreakersStats" parse+    where+      parse o =+        NodeBreakersStats <$> o .: "parent"+          <*> o .: "request"+          <*> o .: "fielddata"++parseNodeStats :: FullNodeId -> Object -> Parser NodeStats+parseNodeStats fnid o =+  NodeStats <$> o .: "name"+    <*> pure fnid+    <*> o .:? "breakers"+    <*> o .: "http"+    <*> o .: "transport"+    <*> o .: "fs"+    <*> o .:? "network"+    <*> o .: "thread_pool"+    <*> o .: "jvm"+    <*> o .: "process"+    <*> o .: "os"+    <*> o .: "indices"++parseNodeInfo :: FullNodeId -> Object -> Parser NodeInfo+parseNodeInfo nid o =+  NodeInfo <$> o .:? "http_address"+    <*> o .: "build_hash"+    <*> o .: "version"+    <*> o .: "ip"+    <*> o .: "host"+    <*> o .: "transport_address"+    <*> o .: "name"+    <*> pure nid+    <*> o .: "plugins"+    <*> o .: "http"+    <*> o .: "transport"+    <*> o .:? "network"+    <*> o .: "thread_pool"+    <*> o .: "jvm"+    <*> o .: "process"+    <*> o .: "os"+    <*> o .: "settings"++instance FromJSON NodePluginInfo where+  parseJSON = withObject "NodePluginInfo" parse+    where+      parse o =+        NodePluginInfo <$> o .:? "site"+          <*> o .:? "jvm"+          <*> o .: "description"+          <*> o .: "version"+          <*> o .: "name"++instance FromJSON NodeHTTPInfo where+  parseJSON = withObject "NodeHTTPInfo" parse+    where+      parse o =+        NodeHTTPInfo <$> o .: "max_content_length_in_bytes"+          <*> o .: "publish_address"+          <*> o .: "bound_address"++instance FromJSON BoundTransportAddress where+  parseJSON = withObject "BoundTransportAddress" parse+    where+      parse o =+        BoundTransportAddress <$> o .: "publish_address"+          <*> o .: "bound_address"++instance FromJSON NodeOSInfo where+  parseJSON = withObject "NodeOSInfo" parse+    where+      parse o =+        NodeOSInfo <$> (unMS <$> o .: "refresh_interval_in_millis")+          <*> o .: "name"+          <*> o .: "arch"+          <*> o .: "version"+          <*> o .: "available_processors"+          <*> o .: "allocated_processors"++instance FromJSON CPUInfo where+  parseJSON = withObject "CPUInfo" parse+    where+      parse o =+        CPUInfo <$> o .: "cache_size_in_bytes"+          <*> o .: "cores_per_socket"+          <*> o .: "total_sockets"+          <*> o .: "total_cores"+          <*> o .: "mhz"+          <*> o .: "model"+          <*> o .: "vendor"++instance FromJSON NodeProcessInfo where+  parseJSON = withObject "NodeProcessInfo" parse+    where+      parse o =+        NodeProcessInfo <$> o .: "mlockall"+          <*> o .:? "max_file_descriptors"+          <*> o .: "id"+          <*> (unMS <$> o .: "refresh_interval_in_millis")++instance FromJSON NodeJVMInfo where+  parseJSON = withObject "NodeJVMInfo" parse+    where+      parse o =+        NodeJVMInfo <$> o .: "memory_pools"+          <*> o .: "gc_collectors"+          <*> o .: "mem"+          <*> (posixMS <$> o .: "start_time_in_millis")+          <*> o .: "vm_vendor"+          <*> o .: "vm_version"+          <*> o .: "vm_name"+          <*> o .: "version"+          <*> o .: "pid"++instance FromJSON JVMMemoryInfo where+  parseJSON = withObject "JVMMemoryInfo" parse+    where+      parse o =+        JVMMemoryInfo <$> o .: "direct_max_in_bytes"+          <*> o .: "non_heap_max_in_bytes"+          <*> o .: "non_heap_init_in_bytes"+          <*> o .: "heap_max_in_bytes"+          <*> o .: "heap_init_in_bytes"++instance FromJSON NodeThreadPoolInfo where+  parseJSON = withObject "NodeThreadPoolInfo" parse+    where+      parse o = do+        ka <- maybe (return Nothing) (fmap Just . parseStringInterval) =<< o .:? "keep_alive"+        NodeThreadPoolInfo <$> (parseJSON . unStringlyTypeJSON =<< o .: "queue_size")+          <*> pure ka+          <*> o .:? "min"+          <*> o .:? "max"+          <*> o .: "type"++data TimeInterval+  = Weeks+  | Days+  | Hours+  | Minutes+  | Seconds+  deriving (Eq)++instance Show TimeInterval where+  show Weeks = "w"+  show Days = "d"+  show Hours = "h"+  show Minutes = "m"+  show Seconds = "s"++instance Read TimeInterval where+  readPrec = f =<< TR.get+    where+      f 'w' = return Weeks+      f 'd' = return Days+      f 'h' = return Hours+      f 'm' = return Minutes+      f 's' = return Seconds+      f _ = fail "TimeInterval expected one of w, d, h, m, s"++data Interval+  = Year+  | Quarter+  | Month+  | Week+  | Day+  | Hour+  | Minute+  | Second+  deriving (Eq, Show)++instance ToJSON Interval where+  toJSON Year = "year"+  toJSON Quarter = "quarter"+  toJSON Month = "month"+  toJSON Week = "week"+  toJSON Day = "day"+  toJSON Hour = "hour"+  toJSON Minute = "minute"+  toJSON Second = "second"++parseStringInterval :: (Monad m, MonadFail m) => String -> m NominalDiffTime+parseStringInterval s = case span isNumber s of+  ("", _) -> fail "Invalid interval"+  (nS, unitS) -> case (readMay nS, readMay unitS) of+    (Just n, Just unit) -> return (fromInteger (n * unitNDT unit))+    (Nothing, _) -> fail "Invalid interval number"+    (_, Nothing) -> fail "Invalid interval unit"+  where+    unitNDT Seconds = 1+    unitNDT Minutes = 60+    unitNDT Hours = 60 * 60+    unitNDT Days = 24 * 60 * 60+    unitNDT Weeks = 7 * 24 * 60 * 60++instance FromJSON ThreadPoolSize where+  parseJSON v = parseAsNumber v <|> parseAsString v+    where+      parseAsNumber = parseAsInt <=< parseJSON+      parseAsInt (-1) = return ThreadPoolUnbounded+      parseAsInt n+        | n >= 0 = return (ThreadPoolBounded n)+        | otherwise = fail "Thread pool size must be >= -1."+      parseAsString = withText "ThreadPoolSize" $ \t ->+        case first (readMay . T.unpack) (T.span isNumber t) of+          (Just n, "k") -> return (ThreadPoolBounded (n * 1000))+          (Just n, "") -> return (ThreadPoolBounded n)+          _ -> fail ("Invalid thread pool size " <> T.unpack t)++instance FromJSON ThreadPoolType where+  parseJSON = withText "ThreadPoolType" parse+    where+      parse "scaling" = return ThreadPoolScaling+      parse "fixed" = return ThreadPoolFixed+      parse "cached" = return ThreadPoolCached+      parse "fixed_auto_queue_size" = return ThreadPoolFixedAutoQueueSize+      parse e = fail ("Unexpected thread pool type" <> T.unpack e)++instance FromJSON NodeTransportInfo where+  parseJSON = withObject "NodeTransportInfo" parse+    where+      parse o =+        NodeTransportInfo <$> (maybe (return mempty) parseProfiles =<< o .:? "profiles")+          <*> o .: "publish_address"+          <*> o .: "bound_address"+      parseProfiles (Object o) | X.null o = return []+      parseProfiles v@(Array _) = parseJSON v+      parseProfiles Null = return []+      parseProfiles _ = fail "Could not parse profiles"++instance FromJSON NodeNetworkInfo where+  parseJSON = withObject "NodeNetworkInfo" parse+    where+      parse o =+        NodeNetworkInfo <$> o .: "primary_interface"+          <*> (unMS <$> o .: "refresh_interval_in_millis")++instance FromJSON NodeNetworkInterface where+  parseJSON = withObject "NodeNetworkInterface" parse+    where+      parse o =+        NodeNetworkInterface <$> o .: "mac_address"+          <*> o .: "name"+          <*> o .: "address"++instance ToJSON Version where+  toJSON Version {..} =+    object+      [ "number" .= number,+        "build_hash" .= build_hash,+        "build_date" .= build_date,+        "build_snapshot" .= build_snapshot,+        "lucene_version" .= lucene_version+      ]++instance FromJSON Version where+  parseJSON = withObject "Version" parse+    where+      parse o =+        Version+          <$> o .: "number"+          <*> o .: "build_hash"+          <*> o .: "build_date"+          <*> o .: "build_snapshot"+          <*> o .: "lucene_version"++instance ToJSON VersionNumber where+  toJSON = toJSON . SemVer.toText . versionNumber++instance FromJSON VersionNumber where+  parseJSON = withText "VersionNumber" parse+    where+      parse t =+        case SemVer.fromText t of+          (Left err) -> fail err+          (Right v) -> return (VersionNumber v)
+ src/Database/Bloodhound/Internal/Client/BHRequest.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++{- ORMOLU_DISABLE -}+-------------------------------------------------------------------------------+-- |+-- Module : Database.Bloodhound.Client+-- Copyright : (C) 2014, 2018 Chris Allen+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability : provisional+-- Portability : GHC+--+-- Client side abstractions to interact with Elasticsearch servers.+-------------------------------------------------------------------------------+{- ORMOLU_ENABLE -}++module Database.Bloodhound.Internal.Client.BHRequest+  ( -- * Request+    BHRequest (..),+    mkFullRequest,+    mkSimpleRequest,+    Server (..),+    Endpoint (..),+    mkEndpoint,+    withQueries,+    getEndpoint,++    -- * Response+    BHResponse (..),++    -- * Response interpretation+    ParsedEsResponse,+    decodeResponse,+    eitherDecodeResponse,+    parseEsResponse,+    parseEsResponseWith,+    isVersionConflict,+    isSuccess,+    isCreated,+    statusCodeIs,++    -- * Response handling+    EsProtocolException (..),+    EsResult (..),+    EsResultFound (..),+    EsError (..),++    -- * Common results+    Acknowledged (..),+    Accepted (..),+  )+where++import qualified Blaze.ByteString.Builder as BB+import Control.Applicative as A+import Control.Monad+import Control.Monad.Catch+import Data.Aeson+import qualified Data.ByteString.Lazy as BL+import Data.Ix+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Database.Bloodhound.Internal.Client.Doc+import GHC.Exts+import Network.HTTP.Client+import qualified Network.HTTP.Types.Method as NHTM+import qualified Network.HTTP.Types.Status as NHTS+import qualified Network.HTTP.Types.URI as NHTU+import Prelude hiding (filter, head)++-- | 'Server' is used with the client functions to point at the ES instance+newtype Server = Server Text+  deriving stock (Eq, Show)+  deriving newtype (FromJSON)++-- | 'Endpoint' represents an url before being built+data Endpoint = Endpoint+  { getRawEndpoint :: [Text],+    getRawEndpointQueries :: [(Text, Maybe Text)]+  }+  deriving stock (Eq, Show)++instance IsList Endpoint where+  type Item Endpoint = Text+  toList = getRawEndpoint+  fromList = mkEndpoint++-- | Create an 'Endpoint' from a list of url parts+mkEndpoint :: [Text] -> Endpoint+mkEndpoint urlParts = Endpoint urlParts mempty++-- | Generate the raw URL+getEndpoint :: Server -> Endpoint -> Text+getEndpoint (Server serverRoot) endpoint =+  T.intercalate "/" (serverRoot : getRawEndpoint endpoint) <> queries+  where+    queries = T.decodeUtf8 $ BB.toByteString $ NHTU.renderQueryText prependQuestionMark $ getRawEndpointQueries endpoint+    prependQuestionMark = True++-- | Severely dumbed down query renderer. Assumes your data doesn't+-- need any encoding+withQueries :: Endpoint -> [(Text, Maybe Text)] -> Endpoint+withQueries endpoint queries = endpoint {getRawEndpointQueries = getRawEndpointQueries endpoint <> queries}++-- | 'Request' upon Elasticsearch's server.+--+-- @responseBody@ is a phantom type for the expected result+data BHRequest responseBody = BHRequest+  { bhRequestMethod :: NHTM.Method,+    bhRequestEndpoint :: Endpoint,+    bhRequestBody :: Maybe BL.ByteString+  }+  deriving stock (Eq, Show)++-- | 'BHRequest' with a body+mkFullRequest :: NHTM.Method -> Endpoint -> BL.ByteString -> BHRequest body+mkFullRequest method' endpoint body =+  BHRequest+    { bhRequestMethod = method',+      bhRequestEndpoint = endpoint,+      bhRequestBody = Just body+    }++-- | 'BHRequest' without a body+mkSimpleRequest :: NHTM.Method -> Endpoint -> BHRequest body+mkSimpleRequest method' endpoint =+  BHRequest+    { bhRequestMethod = method',+      bhRequestEndpoint = endpoint,+      bhRequestBody = Nothing+    }++-- | Result of a 'BHRequest'+newtype BHResponse body = BHResponse {getResponse :: Network.HTTP.Client.Response BL.ByteString}+  deriving stock (Eq, Show)++-- | Result of a 'parseEsResponse'+type ParsedEsResponse a = Either EsError a++-- | Tries to parse a response body as the expected type @body@ and+-- failing that tries to parse it as an EsError. All well-formed, JSON+-- responses from elasticsearch should fall into these two+-- categories. If they don't, a 'EsProtocolException' will be+-- thrown. If you encounter this, please report the full body it+-- reports along with your Elasticsearch version.+parseEsResponse ::+  ( MonadThrow m,+    FromJSON body+  ) =>+  BHResponse body ->+  m (ParsedEsResponse body)+parseEsResponse response+  | isSuccess response = case eitherDecode body of+    Right a -> return (Right a)+    Left err ->+      tryParseError err+  | otherwise = tryParseError "Non-200 status code"+  where+    body = responseBody $ getResponse response+    tryParseError originalError =+      case eitherDecode body of+        Right e -> return (Left e)+        -- Failed to parse the error message.+        Left err -> explode ("Original error was: " <> originalError <> " Error parse failure was: " <> err)+    explode errorMsg = throwM $ EsProtocolException (T.pack errorMsg) body++-- | Parse 'BHResponse' with an arbitrary parser+parseEsResponseWith ::+  ( MonadThrow m,+    FromJSON body+  ) =>+  (body -> Either String parsed) ->+  BHResponse body ->+  m parsed+parseEsResponseWith parser response =+  case eitherDecode body of+    Left e -> explode e+    Right parsed ->+      case parser parsed of+        Right a -> return a+        Left e -> explode e+  where+    body = responseBody $ getResponse response+    explode errorMsg = throwM $ EsProtocolException (T.pack errorMsg) body++-- | Helper around 'aeson' 'decode'+decodeResponse ::+  FromJSON a =>+  BHResponse a ->+  Maybe a+decodeResponse = decode . responseBody . getResponse++-- | Helper around 'aeson' 'eitherDecode'+eitherDecodeResponse ::+  FromJSON a =>+  BHResponse a ->+  Either String a+eitherDecodeResponse = eitherDecode . responseBody . getResponse++-- | Was there an optimistic concurrency control conflict when+-- indexing a document?+isVersionConflict :: BHResponse a -> Bool+isVersionConflict = statusCheck (== 409)++-- | Check '2xx' status codes+isSuccess :: BHResponse a -> Bool+isSuccess = statusCodeIs (200, 299)++-- | Check '201' status code+isCreated :: BHResponse a -> Bool+isCreated = statusCheck (== 201)++-- | Check status code+statusCheck :: (Int -> Bool) -> BHResponse a -> Bool+statusCheck prd = prd . NHTS.statusCode . responseStatus . getResponse++-- | Check status code in range+statusCodeIs :: (Int, Int) -> BHResponse body -> Bool+statusCodeIs r resp = inRange r $ NHTS.statusCode (responseStatus $ getResponse resp)++-- | 'EsResult' describes the standard wrapper JSON document that you see in+--    successful Elasticsearch lookups or lookups that couldn't find the document.+data EsResult a = EsResult+  { _index :: Text,+    _type :: Text,+    _id :: Text,+    foundResult :: Maybe (EsResultFound a)+  }+  deriving (Eq, Show)++-- | 'EsResultFound' contains the document and its metadata inside of an+--    'EsResult' when the document was successfully found.+data EsResultFound a = EsResultFound+  { _version :: DocVersion,+    _source :: a+  }+  deriving (Eq, Show)++instance (FromJSON a) => FromJSON (EsResult a) where+  parseJSON jsonVal@(Object v) = do+    found <- v .:? "found" .!= False+    fr <-+      if found+        then parseJSON jsonVal+        else return Nothing+    EsResult <$> v .: "_index"+      <*> v .: "_type"+      <*> v .: "_id"+      <*> pure fr+  parseJSON _ = empty++instance (FromJSON a) => FromJSON (EsResultFound a) where+  parseJSON (Object v) =+    EsResultFound+      <$> v .: "_version"+      <*> v .: "_source"+  parseJSON _ = empty++-- | 'EsError' is the generic type that will be returned when there was a+--    problem. If you can't parse the expected response, its a good idea to+--    try parsing this.+data EsError = EsError+  { errorStatus :: Int,+    errorMessage :: Text+  }+  deriving (Eq, Show)++instance FromJSON EsError where+  parseJSON (Object v) =+    EsError+      <$> v .: "status"+      <*> (v .: "error" <|> (v .: "error" >>= (.: "reason")))+  parseJSON _ = empty++-- | '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+  { esProtoExMessage :: !Text,+    esProtoExResponse :: !BL.ByteString+  }+  deriving (Eq, Show)++instance Exception EsProtocolException++newtype Acknowledged = Acknowledged {isAcknowledged :: Bool}+  deriving stock (Eq, Show)++instance FromJSON Acknowledged where+  parseJSON =+    withObject+      "Acknowledged"+      (.: "acknowledged")++newtype Accepted = Accepted {isAccepted :: Bool}+  deriving stock (Eq, Show)++instance FromJSON Accepted where+  parseJSON =+    withObject+      "Accepted"+      (.: "accepted")
+ src/Database/Bloodhound/Internal/Client/Doc.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Database.Bloodhound.Internal.Client.Doc+  ( DocVersion (..),+    ExternalDocVersion (..),+    mkDocVersion,+    VersionControl (..),+  )+where++import Data.Aeson+import Data.Maybe+import GHC.Enum++-- | 'DocVersion' is an integer version number for a document between 1+-- and 9.2e+18 used for <<https://www.elastic.co/guide/en/elasticsearch/guide/current/optimistic-concurrency-control.html optimistic concurrency control>>.+newtype DocVersion = DocVersion+  { docVersionNumber :: Int+  }+  deriving stock (Eq, Show, Ord)+  deriving newtype (ToJSON)++-- | Smart constructor for in-range doc version+mkDocVersion :: Int -> Maybe DocVersion+mkDocVersion i+  | i >= docVersionNumber minBound+      && i <= docVersionNumber maxBound =+    Just $ DocVersion i+  | otherwise = Nothing++instance Bounded DocVersion where+  minBound = DocVersion 1+  maxBound = DocVersion 9200000000000000000 -- 9.2e+18++instance Enum DocVersion where+  succ x+    | x /= maxBound = DocVersion (succ $ docVersionNumber x)+    | otherwise = succError "DocVersion"+  pred x+    | x /= minBound = DocVersion (pred $ docVersionNumber x)+    | otherwise = predError "DocVersion"+  toEnum i =+    fromMaybe (error $ show i ++ " out of DocVersion range") $ mkDocVersion i+  fromEnum = docVersionNumber+  enumFrom = boundedEnumFrom+  enumFromThen = boundedEnumFromThen++instance FromJSON DocVersion where+  parseJSON v = do+    i <- parseJSON v+    maybe (fail "DocVersion out of range") return $ mkDocVersion i++-- | 'ExternalDocVersion' is a convenience wrapper if your code uses its+-- own version numbers instead of ones from ES.+newtype ExternalDocVersion = ExternalDocVersion DocVersion+  deriving (Eq, Show, Ord, Bounded, Enum, ToJSON)++-- | 'VersionControl' is specified when indexing documents as a+-- optimistic concurrency control.+data VersionControl+  = -- | Don't send a version. This is a pure overwrite.+    NoVersionControl+  | -- | Use the default ES versioning scheme. Only+    -- index the document if the version is the same+    -- as the one specified. Only applicable to+    -- updates, as you should be getting Version from+    -- a search result.+    InternalVersion DocVersion+  | -- | Use your own version numbering. Only index+    -- the document if the version is strictly higher+    -- OR the document doesn't exist. The given+    -- version will be used as the new version number+    -- for the stored document. N.B. All updates must+    -- increment this number, meaning there is some+    -- global, external ordering of updates.+    ExternalGT ExternalDocVersion+  | -- | Use your own version numbering. Only index+    -- the document if the version is equal or higher+    -- than the stored version. Will succeed if there+    -- is no existing document. The given version will+    -- be used as the new version number for the+    -- stored document. Use with care, as this could+    -- result in data loss.+    ExternalGTE ExternalDocVersion+  | -- | The document will always be indexed and the+    -- given version will be the new version. This is+    -- typically used for correcting errors. Use with+    -- care, as this could result in data loss.+    ForceVersion ExternalDocVersion+  deriving (Eq, Show, Ord)
src/Database/Bloodhound/Internal/Count.hs view
@@ -1,45 +1,46 @@ {-# LANGUAGE OverloadedStrings #-}-module Database.Bloodhound.Internal.Count-  (CountQuery (..), CountResponse(..), CountShards(..))-where -import           Data.Aeson-import           Database.Bloodhound.Internal.Query-import           Numeric.Natural+module Database.Bloodhound.Internal.Count (CountQuery (..), CountResponse (..), CountShards (..)) where -newtype CountQuery = CountQuery { countQuery :: Query }+import Data.Aeson+import Database.Bloodhound.Internal.Query+import Numeric.Natural++newtype CountQuery = CountQuery {countQuery :: Query}   deriving (Eq, Show)  instance ToJSON CountQuery where   toJSON (CountQuery q) =     object ["query" .= q] -data CountResponse = CountResponse { crCount  :: Natural-                                   , crShards :: CountShards-                                   }+data CountResponse = CountResponse+  { crCount :: Natural,+    crShards :: CountShards+  }   deriving (Eq, Show)  instance FromJSON CountResponse where   parseJSON =-    withObject "CountResponse"-    $ \o ->+    withObject "CountResponse" $+      \o ->         CountResponse-        <$> o .: "count"-        <*> o .: "_shards"+          <$> o .: "count"+          <*> o .: "_shards" -data CountShards = CountShards { csTotal      :: Int-                               , csSuccessful :: Int-                               , csSkipped    :: Int-                               , csFailed     :: Int-                               }+data CountShards = CountShards+  { csTotal :: Int,+    csSuccessful :: Int,+    csSkipped :: Int,+    csFailed :: Int+  }   deriving (Eq, Show)  instance FromJSON CountShards where   parseJSON =-    withObject "CountShards"-    $ \o ->+    withObject "CountShards" $+      \o ->         CountShards-        <$> o .: "total"-        <*> o .: "successful"-        <*> o .: "skipped"-        <*> o .: "failed"+          <$> o .: "total"+          <*> o .: "successful"+          <*> o .: "skipped"+          <*> o .: "failed"
src/Database/Bloodhound/Internal/Highlight.hs view
@@ -1,98 +1,102 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE OverloadedStrings #-}  module Database.Bloodhound.Internal.Highlight where -import           Bloodhound.Import-+import Bloodhound.Import import qualified Data.Map.Strict as M--import           Database.Bloodhound.Internal.Newtypes-import           Database.Bloodhound.Internal.Query+import Database.Bloodhound.Internal.Newtypes+import Database.Bloodhound.Internal.Query  type HitHighlight = M.Map Text [Text]  data Highlights = Highlights-  { globalsettings  :: Maybe HighlightSettings-  , highlightFields :: [FieldHighlight]-  } deriving (Eq, Show)+  { globalsettings :: Maybe HighlightSettings,+    highlightFields :: [FieldHighlight]+  }+  deriving (Eq, Show)  instance ToJSON Highlights where-    toJSON (Highlights global fields) =-        omitNulls (("fields" .= fields)-                  : highlightSettingsPairs global)+  toJSON (Highlights global fields) =+    omitNulls+      ( ("fields" .= fields) :+        highlightSettingsPairs global+      ) -data FieldHighlight =-  FieldHighlight FieldName (Maybe HighlightSettings)+data FieldHighlight+  = FieldHighlight FieldName (Maybe HighlightSettings)   deriving (Eq, Show) - instance ToJSON FieldHighlight where-    toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =-        object [ fromText fName .= fSettings ]-    toJSON (FieldHighlight (FieldName fName) Nothing) =-        object [ fromText fName .= emptyObject ]+  toJSON (FieldHighlight (FieldName fName) (Just fSettings)) =+    object [fromText fName .= fSettings]+  toJSON (FieldHighlight (FieldName fName) Nothing) =+    object [fromText fName .= emptyObject] -data HighlightSettings =-    Plain PlainHighlight+data HighlightSettings+  = Plain PlainHighlight   | Postings PostingsHighlight   | FastVector FastVectorHighlight   deriving (Eq, Show) - instance ToJSON HighlightSettings where-    toJSON hs = omitNulls (highlightSettingsPairs (Just hs))+  toJSON hs = omitNulls (highlightSettingsPairs (Just hs)) -data PlainHighlight =-  PlainHighlight { plainCommon  :: Maybe CommonHighlight-                 , plainNonPost :: Maybe NonPostings }+data PlainHighlight = PlainHighlight+  { plainCommon :: Maybe CommonHighlight,+    plainNonPost :: Maybe NonPostings+  }   deriving (Eq, Show) - -- This requires that index_options are set to 'offset' in the mapping.-data PostingsHighlight =-  PostingsHighlight (Maybe CommonHighlight)+-- This requires that index_options are set to 'offset' in the mapping.+data PostingsHighlight+  = PostingsHighlight (Maybe CommonHighlight)   deriving (Eq, Show)  -- This requires that term_vector is set to 'with_positions_offsets' in the mapping. data FastVectorHighlight = FastVectorHighlight-  { fvCommon          :: Maybe CommonHighlight-  , fvNonPostSettings :: Maybe NonPostings-  , boundaryChars     :: Maybe Text-  , boundaryMaxScan   :: Maybe Int-  , fragmentOffset    :: Maybe Int-  , matchedFields     :: [Text]-  , phraseLimit       :: Maybe Int-  } deriving (Eq, Show)+  { fvCommon :: Maybe CommonHighlight,+    fvNonPostSettings :: Maybe NonPostings,+    boundaryChars :: Maybe Text,+    boundaryMaxScan :: Maybe Int,+    fragmentOffset :: Maybe Int,+    matchedFields :: [Text],+    phraseLimit :: Maybe Int+  }+  deriving (Eq, Show)  data CommonHighlight = CommonHighlight-  { order             :: Maybe Text-  , forceSource       :: Maybe Bool-  , tag               :: Maybe HighlightTag-  , encoder           :: Maybe HighlightEncoder-  , noMatchSize       :: Maybe Int-  , highlightQuery    :: Maybe Query-  , requireFieldMatch :: Maybe Bool-  } deriving (Eq, Show)+  { order :: Maybe Text,+    forceSource :: Maybe Bool,+    tag :: Maybe HighlightTag,+    encoder :: Maybe HighlightEncoder,+    noMatchSize :: Maybe Int,+    highlightQuery :: Maybe Query,+    requireFieldMatch :: Maybe Bool+  }+  deriving (Eq, Show)  -- Settings that are only applicable to FastVector and Plain highlighters.-data NonPostings =-    NonPostings { fragmentSize      :: Maybe Int-                , numberOfFragments :: Maybe Int-                } deriving (Eq, Show)+data NonPostings = NonPostings+  { fragmentSize :: Maybe Int,+    numberOfFragments :: Maybe Int+  }+  deriving (Eq, Show) -data HighlightEncoder = DefaultEncoder-                      | HTMLEncoder-                      deriving (Eq, Show)+data HighlightEncoder+  = DefaultEncoder+  | HTMLEncoder+  deriving (Eq, Show)  instance ToJSON HighlightEncoder where-    toJSON DefaultEncoder = String "default"-    toJSON HTMLEncoder    = String "html"+  toJSON DefaultEncoder = String "default"+  toJSON HTMLEncoder = String "html"  -- NOTE: Should the tags use some kind of HTML type, rather than Text?-data HighlightTag =-    TagSchema Text-    -- Only uses more than the first value in the lists if fvh-  | CustomTags ([Text], [Text]) +data HighlightTag+  = TagSchema Text+  | -- Only uses more than the first value in the lists if fvh+    CustomTags ([Text], [Text])   deriving (Eq, Show)  highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]@@ -101,64 +105,79 @@ highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph) highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh) - plainHighPairs :: Maybe PlainHighlight -> [Pair] plainHighPairs Nothing = [] plainHighPairs (Just (PlainHighlight plCom plNonPost)) =-    [ "type" .= String "plain"]+  ["type" .= String "plain"]     ++ commonHighlightPairs plCom     ++ nonPostingsToPairs plNonPost  postHighPairs :: Maybe PostingsHighlight -> [Pair] postHighPairs Nothing = [] postHighPairs (Just (PostingsHighlight pCom)) =-    ("type" .= String "postings")-    : commonHighlightPairs pCom+  ("type" .= String "postings") :+  commonHighlightPairs pCom  fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair] fastVectorHighPairs Nothing = [] fastVectorHighPairs-  (Just-    (FastVectorHighlight fvCom fvNonPostSettings' fvBoundChars-                         fvBoundMaxScan fvFragOff fvMatchedFields-                                          fvPhraseLim)) =-                        [ "type" .= String "fvh"-                        , "boundary_chars" .= fvBoundChars-                        , "boundary_max_scan" .= fvBoundMaxScan-                        , "fragment_offset" .= fvFragOff-                        , "matched_fields" .= fvMatchedFields-                        , "phraseLimit" .= fvPhraseLim]-                        ++ commonHighlightPairs fvCom-                        ++ nonPostingsToPairs fvNonPostSettings'+  ( Just+      ( FastVectorHighlight+          fvCom+          fvNonPostSettings'+          fvBoundChars+          fvBoundMaxScan+          fvFragOff+          fvMatchedFields+          fvPhraseLim+        )+    ) =+    [ "type" .= String "fvh",+      "boundary_chars" .= fvBoundChars,+      "boundary_max_scan" .= fvBoundMaxScan,+      "fragment_offset" .= fvFragOff,+      "matched_fields" .= fvMatchedFields,+      "phraseLimit" .= fvPhraseLim+    ]+      ++ commonHighlightPairs fvCom+      ++ nonPostingsToPairs fvNonPostSettings'  commonHighlightPairs :: Maybe CommonHighlight -> [Pair] commonHighlightPairs Nothing = []-commonHighlightPairs (Just (CommonHighlight chScore chForceSource-                            chTag chEncoder chNoMatchSize-                            chHighlightQuery chRequireFieldMatch)) =-    [ "order" .= chScore-    , "force_source" .= chForceSource-    , "encoder" .= chEncoder-    , "no_match_size" .= chNoMatchSize-    , "highlight_query" .= chHighlightQuery-    , "require_fieldMatch" .= chRequireFieldMatch+commonHighlightPairs+  ( Just+      ( CommonHighlight+          chScore+          chForceSource+          chTag+          chEncoder+          chNoMatchSize+          chHighlightQuery+          chRequireFieldMatch+        )+    ) =+    [ "order" .= chScore,+      "force_source" .= chForceSource,+      "encoder" .= chEncoder,+      "no_match_size" .= chNoMatchSize,+      "highlight_query" .= chHighlightQuery,+      "require_fieldMatch" .= chRequireFieldMatch     ]-    ++ highlightTagToPairs chTag-+      ++ highlightTagToPairs chTag  nonPostingsToPairs :: Maybe NonPostings -> [Pair] nonPostingsToPairs Nothing = [] nonPostingsToPairs (Just (NonPostings npFragSize npNumOfFrags)) =-    [ "fragment_size" .= npFragSize-    , "number_of_fragments" .= npNumOfFrags-    ]+  [ "fragment_size" .= npFragSize,+    "number_of_fragments" .= npNumOfFrags+  ]  highlightTagToPairs :: Maybe HighlightTag -> [Pair] highlightTagToPairs (Just (TagSchema _)) =   [ "scheme" .= String "default"   ] highlightTagToPairs (Just (CustomTags (pre, post))) =-  [ "pre_tags"  .= pre-  , "post_tags" .= post+  [ "pre_tags" .= pre,+    "post_tags" .= post   ] highlightTagToPairs Nothing = []
src/Database/Bloodhound/Internal/Newtypes.hs view
@@ -1,61 +1,56 @@-{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE OverloadedStrings #-}  module Database.Bloodhound.Internal.Newtypes where -import           Bloodhound.Import-+import Bloodhound.Import import qualified Data.Map.Strict as M-import           GHC.Generics+import GHC.Generics  newtype From = From Int deriving (Eq, Show, ToJSON)+ newtype Size = Size Int deriving (Eq, Show, Generic, ToJSON, FromJSON)  -- Used with scripts-newtype HitFields =-  HitFields (M.Map Text [Value])+newtype HitFields+  = HitFields (M.Map Text [Value])   deriving (Eq, Show)  instance FromJSON HitFields where-  parseJSON x-    = HitFields <$> parseJSON x+  parseJSON x =+    HitFields <$> parseJSON x  -- Slight misnomer. type Score = Maybe Double -newtype ShardId = ShardId { shardId :: Int }-                deriving (Eq, Show, FromJSON)+newtype ShardId = ShardId {shardId :: Int}+  deriving (Eq, Show, FromJSON) -{-| 'DocId' is a generic wrapper value for expressing unique Document IDs.-    Can be set by the user or created by ES itself. Often used in client-    functions for poking at specific documents.--}-newtype DocId =-  DocId Text+-- | 'DocId' is a generic wrapper value for expressing unique Document IDs.+--    Can be set by the user or created by ES itself. Often used in client+--    functions for poking at specific documents.+newtype DocId+  = DocId Text   deriving (Eq, Show, Generic, ToJSON, FromJSON) -{-| 'FieldName' is used all over the place wherever a specific field within-     a document needs to be specified, usually in 'Query's or 'Filter's.--}-newtype FieldName =-  FieldName Text+-- | 'FieldName' is used all over the place wherever a specific field within+--     a document needs to be specified, usually in 'Query's or 'Filter's.+newtype FieldName+  = FieldName Text   deriving (Eq, Read, Show, ToJSON, FromJSON) -{- | 'RelationName' describes a relation role between parend and child Documents-     in a Join relarionship: https://www.elastic.co/guide/en/elasticsearch/reference/current/parent-join.html--}-newtype RelationName =-  RelationName Text+-- | 'RelationName' describes a relation role between parend and child Documents+--     in a Join relarionship: https://www.elastic.co/guide/en/elasticsearch/reference/current/parent-join.html+newtype RelationName+  = RelationName Text   deriving (Eq, Read, Show, Generic, ToJSON, FromJSON) -{-| 'QueryString' is used to wrap query text bodies, be they human written or not.--}-newtype QueryString =-  QueryString Text+-- | 'QueryString' is used to wrap query text bodies, be they human written or not.+newtype QueryString+  = QueryString Text   deriving (Eq, Show, Generic, ToJSON, FromJSON) - -- {-| 'Script' is often used in place of 'FieldName' to specify more -- complex ways of extracting a value from a document. -- -}@@ -63,170 +58,203 @@ --   Script { scriptText :: Text } --   deriving (Eq, Show) -{-| 'CacheName' is used in 'RegexpFilter' for describing the-    'CacheKey' keyed caching behavior.--}-newtype CacheName =-  CacheName Text+-- | 'CacheName' is used in 'RegexpFilter' for describing the+--    'CacheKey' keyed caching behavior.+newtype CacheName+  = CacheName Text   deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| 'CacheKey' is used in 'RegexpFilter' to key regex caching.--}-newtype CacheKey =-  CacheKey Text deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype Existence =-  Existence Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype NullValue =-  NullValue Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype CutoffFrequency =-  CutoffFrequency Double deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype Analyzer =-  Analyzer Text deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype MaxExpansions =-  MaxExpansions Int deriving (Eq, Generic, Show, FromJSON, ToJSON)+-- | 'CacheKey' is used in 'RegexpFilter' to key regex caching.+newtype CacheKey+  = CacheKey Text+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| 'Lenient', if set to true, will cause format based failures to be-    ignored. I don't know what the bloody default is, Elasticsearch-    documentation didn't say what it was. Let me know if you figure it out.--}-newtype Lenient =-  Lenient Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype Tiebreaker =-  Tiebreaker Double deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype Existence+  = Existence Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| 'MinimumMatch' controls how many should clauses in the bool query should-     match. Can be an absolute value (2) or a percentage (30%) or a-     combination of both.--}-newtype MinimumMatch =-  MinimumMatch Int deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype DisableCoord =-  DisableCoord Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype IgnoreTermFrequency =-  IgnoreTermFrequency Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype MinimumTermFrequency =-  MinimumTermFrequency Int deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype MaxQueryTerms =-  MaxQueryTerms Int deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype NullValue+  = NullValue Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| 'PrefixLength' is the prefix length used in queries, defaults to 0. -}-newtype PrefixLength =-  PrefixLength Int deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype PercentMatch =-  PercentMatch Double deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype StopWord =-  StopWord Text deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype QueryPath =-  QueryPath Text deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype CutoffFrequency+  = CutoffFrequency Double+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| Allowing a wildcard at the beginning of a word (eg "*ing") is particularly-    heavy, because all terms in the index need to be examined, just in case-    they match. Leading wildcards can be disabled by setting-    'AllowLeadingWildcard' to false. -}-newtype AllowLeadingWildcard =-  AllowLeadingWildcard     Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype LowercaseExpanded =-  LowercaseExpanded        Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype EnablePositionIncrements =-  EnablePositionIncrements Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype Analyzer+  = Analyzer Text+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| By default, wildcard terms in a query are not analyzed.-    Setting 'AnalyzeWildcard' to true enables best-effort analysis.--}+newtype MaxExpansions+  = MaxExpansions Int+  deriving (Eq, Generic, Show, FromJSON, ToJSON)++-- | 'Lenient', if set to true, will cause format based failures to be+--    ignored. I don't know what the bloody default is, Elasticsearch+--    documentation didn't say what it was. Let me know if you figure it out.+newtype Lenient+  = Lenient Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype Tiebreaker+  = Tiebreaker Double+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | 'MinimumMatch' controls how many should clauses in the bool query should+--     match. Can be an absolute value (2) or a percentage (30%) or a+--     combination of both.+newtype MinimumMatch+  = MinimumMatch Int+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype DisableCoord+  = DisableCoord Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype IgnoreTermFrequency+  = IgnoreTermFrequency Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype MinimumTermFrequency+  = MinimumTermFrequency Int+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype MaxQueryTerms+  = MaxQueryTerms Int+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | 'PrefixLength' is the prefix length used in queries, defaults to 0.+newtype PrefixLength+  = PrefixLength Int+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype PercentMatch+  = PercentMatch Double+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype StopWord+  = StopWord Text+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype QueryPath+  = QueryPath Text+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | Allowing a wildcard at the beginning of a word (eg "*ing") is particularly+--    heavy, because all terms in the index need to be examined, just in case+--    they match. Leading wildcards can be disabled by setting+--    'AllowLeadingWildcard' to false.+newtype AllowLeadingWildcard+  = AllowLeadingWildcard Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype LowercaseExpanded+  = LowercaseExpanded Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype EnablePositionIncrements+  = EnablePositionIncrements Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | By default, wildcard terms in a query are not analyzed.+--    Setting 'AnalyzeWildcard' to true enables best-effort analysis. newtype AnalyzeWildcard = AnalyzeWildcard Bool deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| 'GeneratePhraseQueries' defaults to false.--}-newtype GeneratePhraseQueries =-  GeneratePhraseQueries Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)+-- | 'GeneratePhraseQueries' defaults to false.+newtype GeneratePhraseQueries+  = GeneratePhraseQueries Bool+  deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| 'Locale' is used for string conversions - defaults to ROOT.--}-newtype Locale        = Locale        Text deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype MaxWordLength = MaxWordLength Int  deriving (Eq, Show, Generic, FromJSON, ToJSON)-newtype MinWordLength = MinWordLength Int  deriving (Eq, Show, Generic, FromJSON, ToJSON)+-- | 'Locale' is used for string conversions - defaults to ROOT.+newtype Locale = Locale Text deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| 'PhraseSlop' sets the default slop for phrases, 0 means exact-     phrase matches. Default is 0.--}-newtype PhraseSlop      = PhraseSlop      Int deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype MaxWordLength = MaxWordLength Int deriving (Eq, Show, Generic, FromJSON, ToJSON)++newtype MinWordLength = MinWordLength Int deriving (Eq, Show, Generic, FromJSON, ToJSON)++-- | 'PhraseSlop' sets the default slop for phrases, 0 means exact+--     phrase matches. Default is 0.+newtype PhraseSlop = PhraseSlop Int deriving (Eq, Show, Generic, FromJSON, ToJSON)+ newtype MinDocFrequency = MinDocFrequency Int deriving (Eq, Show, Generic, FromJSON, ToJSON)+ newtype MaxDocFrequency = MaxDocFrequency Int deriving (Eq, Show, Generic, FromJSON, ToJSON)  -- | Indicates whether the relevance score of a matching parent document is aggregated into its child documents. newtype AggregateParentScore = AggregateParentScore Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)  -- | Indicates whether to ignore an unmapped parent_type and not return any documents instead of an error.-newtype IgnoreUnmapped  = IgnoreUnmapped Bool deriving (Eq, Show, Generic, FromJSON, ToJSON)+newtype IgnoreUnmapped = IgnoreUnmapped Bool deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| Maximum number of child documents that match the query allowed for a returned parent document.-    If the parent document exceeds this limit, it is excluded from the search results.--}-newtype MinChildren     = MinChildren Int     deriving (Eq, Show, Generic, FromJSON, ToJSON)+-- | Maximum number of child documents that match the query allowed for a returned parent document.+--    If the parent document exceeds this limit, it is excluded from the search results.+newtype MinChildren = MinChildren Int deriving (Eq, Show, Generic, FromJSON, ToJSON) -{-| Minimum number of child documents that match the query required to match the query for a returned parent document.-    If the parent document does not meet this limit, it is excluded from the search results.--}-newtype MaxChildren     = MaxChildren Int     deriving (Eq, Show, Generic, FromJSON, ToJSON)+-- | Minimum number of child documents that match the query required to match the query for a returned parent document.+--    If the parent document does not meet this limit, it is excluded from the search results.+newtype MaxChildren = MaxChildren Int deriving (Eq, Show, Generic, FromJSON, ToJSON)  -- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ-newtype POSIXMS = POSIXMS { posixMS :: UTCTime }+newtype POSIXMS = POSIXMS {posixMS :: UTCTime}  instance FromJSON POSIXMS where   parseJSON = withScientific "POSIXMS" (return . parse)-    where parse n =-            let n' = truncate n :: Integer-            in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000)))+    where+      parse n =+        let n' = truncate n :: Integer+         in POSIXMS (posixSecondsToUTCTime (fromInteger (n' `div` 1000))) -newtype Boost =-  Boost Double+newtype Boost+  = Boost Double   deriving (Eq, Show, Generic, ToJSON, FromJSON) -newtype BoostTerms =-  BoostTerms Double+newtype BoostTerms+  = BoostTerms Double   deriving (Eq, Show, Generic, ToJSON, FromJSON) -{-| 'ReplicaCount' is part of 'IndexSettings' -}-newtype ReplicaCount =-  ReplicaCount Int+-- | 'ReplicaCount' is part of 'IndexSettings'+newtype ReplicaCount+  = ReplicaCount Int   deriving (Eq, Show, Generic, ToJSON) -{-| 'ShardCount' is part of 'IndexSettings' -}-newtype ShardCount =-  ShardCount Int+-- | 'ShardCount' is part of 'IndexSettings'+newtype ShardCount+  = ShardCount Int   deriving (Eq, Show, Generic, ToJSON)  -- This insanity is because ES *sometimes* returns Replica/Shard counts as strings instance FromJSON ReplicaCount where-  parseJSON v = parseAsInt v-            <|> parseAsString v-    where parseAsInt = fmap ReplicaCount . parseJSON-          parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)+  parseJSON v =+    parseAsInt v+      <|> parseAsString v+    where+      parseAsInt = fmap ReplicaCount . parseJSON+      parseAsString = withText "ReplicaCount" (fmap ReplicaCount . parseReadText)  instance FromJSON ShardCount where-  parseJSON v = parseAsInt v-            <|> parseAsString v-    where parseAsInt = fmap ShardCount . parseJSON-          parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText)+  parseJSON v =+    parseAsInt v+      <|> parseAsString v+    where+      parseAsInt = fmap ShardCount . parseJSON+      parseAsString = withText "ShardCount" (fmap ShardCount . parseReadText) -{-| 'IndexName' is used to describe which index to query/create/delete -}-newtype IndexName =-  IndexName Text+-- | 'IndexName' is used to describe which index to query/create/delete+newtype IndexName+  = IndexName Text   deriving (Eq, Show, Generic, ToJSON, FromJSON) -newtype IndexAliasName =-  IndexAliasName { indexAliasName :: IndexName }+newtype IndexAliasName = IndexAliasName {indexAliasName :: IndexName}   deriving (Eq, Show, ToJSON) -newtype MaybeNA a = MaybeNA { unMaybeNA :: Maybe a }+newtype MaybeNA a = MaybeNA {unMaybeNA :: Maybe a}   deriving (Show, Eq)  instance FromJSON a => FromJSON (MaybeNA a) where   parseJSON (String "NA") = pure $ MaybeNA Nothing-  parseJSON o             = MaybeNA . Just <$> parseJSON o+  parseJSON o = MaybeNA . Just <$> parseJSON o -newtype SnapshotName =-  SnapshotName { snapshotName :: Text }+newtype SnapshotName = SnapshotName {snapshotName :: Text}   deriving (Eq, Show, ToJSON, FromJSON)  -- | Milliseconds@@ -236,16 +264,15 @@ unMS :: MS -> NominalDiffTime unMS (MS t) = t - instance FromJSON MS where   parseJSON = withScientific "MS" (return . MS . parse)     where       parse n = fromInteger (truncate n * 1000) -newtype TokenFilter =-  TokenFilter Text+newtype TokenFilter+  = TokenFilter Text   deriving (Eq, Show, Generic, FromJSON, ToJSON) -newtype CharFilter =-  CharFilter Text+newtype CharFilter+  = CharFilter Text   deriving (Eq, Show, Generic, FromJSON, ToJSON)
src/Database/Bloodhound/Internal/PointInTime.hs view
@@ -1,57 +1,65 @@-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Database.Bloodhound.Internal.PointInTime where -import           Bloodhound.Import+import Bloodhound.Import  data PointInTime = PointInTime-  { pPitId :: Text-  , keepAlive :: Text-  } deriving (Eq, Show)+  { pPitId :: Text,+    keepAlive :: Text+  }+  deriving (Eq, Show)  instance ToJSON PointInTime where-  toJSON PointInTime{..} =-    object [ "id" .= pPitId-           , "keep_alive" .= keepAlive ]+  toJSON PointInTime {..} =+    object+      [ "id" .= pPitId,+        "keep_alive" .= keepAlive+      ]  instance FromJSON PointInTime where   parseJSON (Object o) = PointInTime <$> o .: "id" <*> o .: "keep_alive"   parseJSON x = typeMismatch "PointInTime" x -data OpenPointInTimeResponse = OpenPointInTimeResponse {-    oPitId :: Text-} deriving (Eq, Show)+data OpenPointInTimeResponse = OpenPointInTimeResponse+  { oPitId :: Text+  }+  deriving (Eq, Show)  instance ToJSON OpenPointInTimeResponse where-    toJSON OpenPointInTimeResponse{..} =-        object [ "id" .= oPitId]+  toJSON OpenPointInTimeResponse {..} =+    object ["id" .= oPitId]  instance FromJSON OpenPointInTimeResponse where   parseJSON (Object o) = OpenPointInTimeResponse <$> o .: "id"   parseJSON x = typeMismatch "OpenPointInTimeResponse" x -data ClosePointInTime = ClosePointInTime {-    cPitId :: Text-} deriving (Eq, Show)+data ClosePointInTime = ClosePointInTime+  { cPitId :: Text+  }+  deriving (Eq, Show)  instance ToJSON ClosePointInTime where-    toJSON ClosePointInTime{..} =-        object [ "id" .= cPitId]+  toJSON ClosePointInTime {..} =+    object ["id" .= cPitId]  instance FromJSON ClosePointInTime where   parseJSON (Object o) = ClosePointInTime <$> o .: "id"   parseJSON x = typeMismatch "ClosePointInTime" x -data ClosePointInTimeResponse = ClosePointInTimeResponse {-    succeeded :: Bool,+data ClosePointInTimeResponse = ClosePointInTimeResponse+  { succeeded :: Bool,     numFreed :: Int-} deriving (Eq, Show)+  }+  deriving (Eq, Show)  instance ToJSON ClosePointInTimeResponse where-    toJSON ClosePointInTimeResponse{..} =-        object [ "succeeded" .= succeeded-               , "num_freed" .= numFreed]+  toJSON ClosePointInTimeResponse {..} =+    object+      [ "succeeded" .= succeeded,+        "num_freed" .= numFreed+      ]  instance FromJSON ClosePointInTimeResponse where   parseJSON (Object o) = do
src/Database/Bloodhound/Internal/Query.hs view
@@ -1,1651 +1,1996 @@-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}--module Database.Bloodhound.Internal.Query-  ( module X-  , module Database.Bloodhound.Internal.Query-  ) where--import           Bloodhound.Import--import qualified Data.Aeson.KeyMap   as X-import qualified Data.HashMap.Strict as HM-import qualified Data.Text           as T-import           GHC.Generics--import           Database.Bloodhound.Common.Script as X-import           Database.Bloodhound.Internal.Newtypes--data Query =-    TermQuery                   Term (Maybe Boost)-  | TermsQuery                  Key (NonEmpty Text)-  | QueryMatchQuery             MatchQuery-  | QueryMultiMatchQuery        MultiMatchQuery-  | QueryBoolQuery              BoolQuery-  | QueryBoostingQuery          BoostingQuery-  | QueryCommonTermsQuery       CommonTermsQuery-  | ConstantScoreQuery          Query Boost-  | QueryFunctionScoreQuery     FunctionScoreQuery-  | QueryDisMaxQuery            DisMaxQuery-  | QueryFuzzyLikeThisQuery     FuzzyLikeThisQuery-  | QueryFuzzyLikeFieldQuery    FuzzyLikeFieldQuery-  | QueryFuzzyQuery             FuzzyQuery-  | QueryHasChildQuery          HasChildQuery-  | QueryHasParentQuery         HasParentQuery-  | IdsQuery                    [DocId]-  | QueryIndicesQuery           IndicesQuery-  | MatchAllQuery               (Maybe Boost)-  | QueryMoreLikeThisQuery      MoreLikeThisQuery-  | QueryMoreLikeThisFieldQuery MoreLikeThisFieldQuery-  | QueryNestedQuery            NestedQuery-  | QueryPrefixQuery            PrefixQuery-  | QueryQueryStringQuery       QueryStringQuery-  | QuerySimpleQueryStringQuery SimpleQueryStringQuery-  | QueryRangeQuery             RangeQuery-  | QueryRegexpQuery            RegexpQuery-  | QueryExistsQuery            FieldName-  | QueryMatchNoneQuery-  | QueryWildcardQuery          WildcardQuery-  deriving (Eq, Show, Generic)--instance ToJSON Query where-  toJSON (TermQuery (Term termQueryField termQueryValue) boost) =-    object [ "term" .=-             object [termQueryField .= object merged]]-    where-      base = [ "value" .= termQueryValue ]-      boosted = maybe [] (return . ("boost" .=)) boost-      merged = mappend base boosted--  toJSON (TermsQuery fieldName terms) =-    object [ "terms" .= object conjoined ]-    where conjoined = [fieldName .= terms]--  toJSON (IdsQuery docIds) =-    object [ "ids" .= object conjoined ]-    where conjoined = [ "values" .= fmap toJSON docIds ]--  toJSON (QueryQueryStringQuery qQueryStringQuery) =-    object [ "query_string" .= qQueryStringQuery ]--  toJSON (QueryMatchQuery matchQuery) =-    object [ "match" .= matchQuery ]--  toJSON (QueryMultiMatchQuery multiMatchQuery) =-      toJSON multiMatchQuery--  toJSON (QueryBoolQuery boolQuery) =-    object [ "bool" .= boolQuery ]--  toJSON (QueryBoostingQuery boostingQuery) =-    object [ "boosting" .= boostingQuery ]--  toJSON (QueryCommonTermsQuery commonTermsQuery) =-    object [ "common" .= commonTermsQuery ]--  toJSON (ConstantScoreQuery query boost) =-    object ["constant_score" .= object ["filter" .= query-                                       , "boost" .= boost]]--  toJSON (QueryFunctionScoreQuery functionScoreQuery) =-    object [ "function_score" .= functionScoreQuery ]--  toJSON (QueryDisMaxQuery disMaxQuery) =-    object [ "dis_max" .= disMaxQuery ]--  toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) =-    object [ "fuzzy_like_this" .= fuzzyQuery ]--  toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) =-    object [ "fuzzy_like_this_field" .= fuzzyFieldQuery ]--  toJSON (QueryFuzzyQuery fuzzyQuery) =-    object [ "fuzzy" .= fuzzyQuery ]--  toJSON (QueryHasChildQuery childQuery) =-    object [ "has_child" .= childQuery ]--  toJSON (QueryHasParentQuery parentQuery) =-    object [ "has_parent" .= parentQuery ]--  toJSON (QueryIndicesQuery qIndicesQuery) =-    object [ "indices" .= qIndicesQuery ]--  toJSON (MatchAllQuery boost) =-    object [ "match_all" .= omitNulls [ "boost" .= boost ] ]--  toJSON (QueryMoreLikeThisQuery query) =-    object [ "more_like_this" .= query ]--  toJSON (QueryMoreLikeThisFieldQuery query) =-    object [ "more_like_this_field" .= query ]--  toJSON (QueryNestedQuery query) =-    object [ "nested" .= query ]--  toJSON (QueryPrefixQuery query) =-    object [ "prefix" .= query ]--  toJSON (QueryRangeQuery query) =-    object [ "range"  .= query ]--  toJSON (QueryRegexpQuery query) =-    object [ "regexp" .= query ]--  toJSON (QuerySimpleQueryStringQuery query) =-    object [ "simple_query_string" .= query ]--  toJSON (QueryExistsQuery (FieldName fieldName)) =-    object ["exists"  .= object-             ["field"  .= fieldName]-           ]-  toJSON QueryMatchNoneQuery =-    object ["match_none" .= object []]--  toJSON (QueryWildcardQuery query) =-    object [ "wildcard" .= query ]--instance FromJSON Query where-  parseJSON v = withObject "Query" parse v-    where parse o = termQuery `taggedWith` "term"-                <|> termsQuery `taggedWith` "terms"-                <|> idsQuery `taggedWith` "ids"-                <|> queryQueryStringQuery `taggedWith` "query_string"-                <|> queryMatchQuery `taggedWith` "match"-                <|> queryMultiMatchQuery-                <|> queryBoolQuery `taggedWith` "bool"-                <|> queryBoostingQuery `taggedWith` "boosting"-                <|> queryCommonTermsQuery `taggedWith` "common"-                <|> constantScoreQuery `taggedWith` "constant_score"-                <|> queryFunctionScoreQuery `taggedWith` "function_score"-                <|> queryDisMaxQuery `taggedWith` "dis_max"-                <|> queryFuzzyLikeThisQuery `taggedWith` "fuzzy_like_this"-                <|> queryFuzzyLikeFieldQuery `taggedWith` "fuzzy_like_this_field"-                <|> queryFuzzyQuery `taggedWith` "fuzzy"-                <|> queryHasChildQuery `taggedWith` "has_child"-                <|> queryHasParentQuery `taggedWith` "has_parent"-                <|> queryIndicesQuery `taggedWith` "indices"-                <|> matchAllQuery `taggedWith` "match_all"-                <|> queryMoreLikeThisQuery `taggedWith` "more_like_this"-                <|> queryMoreLikeThisFieldQuery `taggedWith` "more_like_this_field"-                <|> queryNestedQuery `taggedWith` "nested"-                <|> queryPrefixQuery `taggedWith` "prefix"-                <|> queryRangeQuery `taggedWith` "range"-                <|> queryRegexpQuery `taggedWith` "regexp"-                <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"-                <|> queryWildcardQuery `taggedWith` "wildcard"-            where taggedWith parser k = parser =<< o .: k-          termQuery = fieldTagged $ \(FieldName fn) o ->-                        TermQuery <$> (Term (fromText fn) <$> o .: "value") <*> o .:? "boost"-          termsQuery o = case HM.toList o of-                           [(fn, vs)] -> do vals <- parseJSON vs-                                            case vals of-                                              x:xs -> return (TermsQuery fn (x :| xs))-                                              _ -> fail "Expected non empty list of values"-                           _ -> fail "Expected object with 1 field-named key"-          idsQuery o = IdsQuery <$> o .: "values"-          queryQueryStringQuery = pure . QueryQueryStringQuery-          queryMatchQuery = pure . QueryMatchQuery-          queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v-          queryBoolQuery = pure . QueryBoolQuery-          queryBoostingQuery = pure . QueryBoostingQuery-          queryCommonTermsQuery = pure . QueryCommonTermsQuery-          constantScoreQuery o = case X.lookup "filter" o of-            Just x -> ConstantScoreQuery <$> parseJSON x-                                         <*> o .: "boost"-            _ -> fail "Does not appear to be a ConstantScoreQuery"-          queryFunctionScoreQuery = pure . QueryFunctionScoreQuery-          queryDisMaxQuery = pure . QueryDisMaxQuery-          queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery-          queryFuzzyLikeFieldQuery = pure . QueryFuzzyLikeFieldQuery-          queryFuzzyQuery = pure . QueryFuzzyQuery-          queryHasChildQuery = pure . QueryHasChildQuery-          queryHasParentQuery = pure . QueryHasParentQuery-          queryIndicesQuery = pure . QueryIndicesQuery-          matchAllQuery o = MatchAllQuery <$> o .:? "boost"-          queryMoreLikeThisQuery = pure . QueryMoreLikeThisQuery-          queryMoreLikeThisFieldQuery = pure . QueryMoreLikeThisFieldQuery-          queryNestedQuery = pure . QueryNestedQuery-          queryPrefixQuery = pure . QueryPrefixQuery-          queryRangeQuery = pure . QueryRangeQuery-          queryRegexpQuery = pure . QueryRegexpQuery-          querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery-          -- queryExistsQuery o = QueryExistsQuery <$> o .: "field"-          queryWildcardQuery = pure . QueryWildcardQuery---- | As of Elastic 2.0, 'Filters' are just 'Queries' housed in a---   Bool Query, and flagged in a different context.-newtype Filter = Filter { unFilter :: Query }-  deriving (Eq, Show)--instance ToJSON Filter where-  toJSON = toJSON . unFilter--instance FromJSON Filter where-  parseJSON v = Filter <$> parseJSON v--data RegexpQuery =-  RegexpQuery { regexpQueryField :: FieldName-              , regexpQuery      :: Regexp-              , regexpQueryFlags :: RegexpFlags-              , regexpQueryBoost :: Maybe Boost-              } deriving (Eq, Show, Generic)--instance ToJSON RegexpQuery where-  toJSON (RegexpQuery (FieldName rqQueryField)-          (Regexp regexpQueryQuery) rqQueryFlags-          rqQueryBoost) =-   object [ fromText rqQueryField .= omitNulls base ]-   where base = [ "value" .= regexpQueryQuery-                , "flags" .= rqQueryFlags-                , "boost" .= rqQueryBoost ]--instance FromJSON RegexpQuery where-  parseJSON = withObject "RegexpQuery" parse-    where parse = fieldTagged $ \fn o ->-                    RegexpQuery fn-                    <$> o .: "value"-                    <*> o .: "flags"-                    <*> o .:? "boost"--data WildcardQuery =-  WildcardQuery { wildcardQueryField :: FieldName-                , wildcardQuery      :: Key-                , wildcardQueryBoost :: Maybe Boost-              } deriving (Eq, Show, Generic)--instance ToJSON WildcardQuery where-  toJSON (WildcardQuery (FieldName wcQueryField)-         (wcQueryQuery) wcQueryBoost) =-   object [ fromText wcQueryField .= omitNulls base ]-   where base = [ "value" .= wcQueryQuery-                , "boost" .= wcQueryBoost ]--instance FromJSON WildcardQuery where-  parseJSON = withObject "WildcardQuery" parse-    where parse = fieldTagged $ \fn o ->-                    WildcardQuery fn-                    <$> o .: "value"-                    <*> o .:? "boost"--data RangeQuery =-  RangeQuery { rangeQueryField :: FieldName-             , rangeQueryRange :: RangeValue-             , rangeQueryBoost :: Boost } deriving (Eq, Show, Generic)--instance ToJSON RangeQuery where-  toJSON (RangeQuery (FieldName fieldName) range boost) =-    object [ fromText fieldName .= object conjoined ]-    where-      conjoined = ("boost" .= boost) : rangeValueToPair range--instance FromJSON RangeQuery where-  parseJSON = withObject "RangeQuery" parse-    where parse = fieldTagged $ \fn o ->-                    RangeQuery fn-                    <$> parseJSON (Object o)-                    <*> o .: "boost"--mkRangeQuery :: FieldName -> RangeValue -> RangeQuery-mkRangeQuery f r = RangeQuery f r (Boost 1.0)--data SimpleQueryStringQuery =-  SimpleQueryStringQuery-    { simpleQueryStringQuery             :: QueryString-    , simpleQueryStringField             :: Maybe FieldOrFields-    , simpleQueryStringOperator          :: Maybe BooleanOperator-    , simpleQueryStringAnalyzer          :: Maybe Analyzer-    , simpleQueryStringFlags             :: Maybe (NonEmpty SimpleQueryFlag)-    , simpleQueryStringLowercaseExpanded :: Maybe LowercaseExpanded-    , simpleQueryStringLocale            :: Maybe Locale-    } deriving (Eq, Show, Generic)---instance ToJSON SimpleQueryStringQuery where-  toJSON SimpleQueryStringQuery {..} =-    omitNulls (base ++ maybeAdd)-    where base = [ "query" .= simpleQueryStringQuery ]-          maybeAdd = [ "fields" .= simpleQueryStringField-                     , "default_operator" .= simpleQueryStringOperator-                     , "analyzer" .= simpleQueryStringAnalyzer-                     , "flags" .= simpleQueryStringFlags-                     , "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded-                     , "locale" .= simpleQueryStringLocale ]--instance FromJSON SimpleQueryStringQuery where-  parseJSON = withObject "SimpleQueryStringQuery" parse-    where parse o = SimpleQueryStringQuery <$> o .: "query"-                                           <*> o .:? "fields"-                                           <*> o .:? "default_operator"-                                           <*> o .:? "analyzer"-                                           <*> (parseFlags <$> o .:? "flags")-                                           <*> o .:? "lowercase_expanded_terms"-                                           <*> o .:? "locale"-          parseFlags (Just (x:xs)) = Just (x :| xs)-          parseFlags _             = Nothing--data SimpleQueryFlag =-    SimpleQueryAll-  | SimpleQueryNone-  | SimpleQueryAnd-  | SimpleQueryOr-  | SimpleQueryPrefix-  | SimpleQueryPhrase-  | SimpleQueryPrecedence-  | SimpleQueryEscape-  | SimpleQueryWhitespace-  | SimpleQueryFuzzy-  | SimpleQueryNear-  | SimpleQuerySlop deriving (Eq, Show, Generic)--instance ToJSON SimpleQueryFlag where-  toJSON SimpleQueryAll        = "ALL"-  toJSON SimpleQueryNone       = "NONE"-  toJSON SimpleQueryAnd        = "AND"-  toJSON SimpleQueryOr         = "OR"-  toJSON SimpleQueryPrefix     = "PREFIX"-  toJSON SimpleQueryPhrase     = "PHRASE"-  toJSON SimpleQueryPrecedence = "PRECEDENCE"-  toJSON SimpleQueryEscape     = "ESCAPE"-  toJSON SimpleQueryWhitespace = "WHITESPACE"-  toJSON SimpleQueryFuzzy      = "FUZZY"-  toJSON SimpleQueryNear       = "NEAR"-  toJSON SimpleQuerySlop       = "SLOP"--instance FromJSON SimpleQueryFlag where-  parseJSON = withText "SimpleQueryFlag" parse-    where parse "ALL"        = pure SimpleQueryAll-          parse "NONE"       = pure SimpleQueryNone-          parse "AND"        = pure SimpleQueryAnd-          parse "OR"         = pure SimpleQueryOr-          parse "PREFIX"     = pure SimpleQueryPrefix-          parse "PHRASE"     = pure SimpleQueryPhrase-          parse "PRECEDENCE" = pure SimpleQueryPrecedence-          parse "ESCAPE"     = pure SimpleQueryEscape-          parse "WHITESPACE" = pure SimpleQueryWhitespace-          parse "FUZZY"      = pure SimpleQueryFuzzy-          parse "NEAR"       = pure SimpleQueryNear-          parse "SLOP"       = pure SimpleQuerySlop-          parse f            = fail ("Unexpected SimpleQueryFlag: " <> show f)---- use_dis_max and tie_breaker when fields are plural?-data QueryStringQuery =-  QueryStringQuery-  { queryStringQuery                    :: QueryString-  , queryStringDefaultField             :: Maybe FieldName-  , queryStringOperator                 :: Maybe BooleanOperator-  , queryStringAnalyzer                 :: Maybe Analyzer-  , queryStringAllowLeadingWildcard     :: Maybe AllowLeadingWildcard-  , queryStringLowercaseExpanded        :: Maybe LowercaseExpanded-  , queryStringEnablePositionIncrements :: Maybe EnablePositionIncrements-  , queryStringFuzzyMaxExpansions       :: Maybe MaxExpansions-  , queryStringFuzziness                :: Maybe Fuzziness-  , queryStringFuzzyPrefixLength        :: Maybe PrefixLength-  , queryStringPhraseSlop               :: Maybe PhraseSlop-  , queryStringBoost                    :: Maybe Boost-  , queryStringAnalyzeWildcard          :: Maybe AnalyzeWildcard-  , queryStringGeneratePhraseQueries    :: Maybe GeneratePhraseQueries-  , queryStringMinimumShouldMatch       :: Maybe MinimumMatch-  , queryStringLenient                  :: Maybe Lenient-  , queryStringLocale                   :: Maybe Locale-  } deriving (Eq, Show, Generic)---instance ToJSON QueryStringQuery where-  toJSON (QueryStringQuery qsQueryString-          qsDefaultField qsOperator-          qsAnalyzer qsAllowWildcard-          qsLowercaseExpanded  qsEnablePositionIncrements-          qsFuzzyMaxExpansions qsFuzziness-          qsFuzzyPrefixLength qsPhraseSlop-          qsBoost qsAnalyzeWildcard-          qsGeneratePhraseQueries qsMinimumShouldMatch-          qsLenient qsLocale) =-    omitNulls base-    where-      base = [ "query" .= qsQueryString-             , "default_field" .= qsDefaultField-             , "default_operator" .= qsOperator-             , "analyzer" .= qsAnalyzer-             , "allow_leading_wildcard" .= qsAllowWildcard-             , "lowercase_expanded_terms" .= qsLowercaseExpanded-             , "enable_position_increments" .= qsEnablePositionIncrements-             , "fuzzy_max_expansions" .= qsFuzzyMaxExpansions-             , "fuzziness" .= qsFuzziness-             , "fuzzy_prefix_length" .= qsFuzzyPrefixLength-             , "phrase_slop" .= qsPhraseSlop-             , "boost" .= qsBoost-             , "analyze_wildcard" .= qsAnalyzeWildcard-             , "auto_generate_phrase_queries" .= qsGeneratePhraseQueries-             , "minimum_should_match" .= qsMinimumShouldMatch-             , "lenient" .= qsLenient-             , "locale" .= qsLocale ]--instance FromJSON QueryStringQuery where-  parseJSON = withObject "QueryStringQuery" parse-    where parse o = QueryStringQuery-                    <$> o .: "query"-                    <*> o .:? "default_field"-                    <*> o .:? "default_operator"-                    <*> o .:? "analyzer"-                    <*> o .:? "allow_leading_wildcard"-                    <*> o .:? "lowercase_expanded_terms"-                    <*> o .:? "enable_position_increments"-                    <*> o .:? "fuzzy_max_expansions"-                    <*> o .:? "fuzziness"-                    <*> o .:? "fuzzy_prefix_length"-                    <*> o .:? "phrase_slop"-                    <*> o .:? "boost"-                    <*> o .:? "analyze_wildcard"-                    <*> o .:? "auto_generate_phrase_queries"-                    <*> o .:? "minimum_should_match"-                    <*> o .:? "lenient"-                    <*> o .:? "locale"--mkQueryStringQuery :: QueryString -> QueryStringQuery-mkQueryStringQuery qs =-  QueryStringQuery qs Nothing Nothing-  Nothing Nothing Nothing Nothing-  Nothing Nothing Nothing Nothing-  Nothing Nothing Nothing Nothing-  Nothing Nothing--data FieldOrFields = FofField   FieldName-                   | FofFields (NonEmpty FieldName) deriving (Eq, Show, Generic)--instance ToJSON FieldOrFields where-  toJSON (FofField fieldName) =-    toJSON fieldName-  toJSON (FofFields fieldNames) =-    toJSON fieldNames--instance FromJSON FieldOrFields where-  parseJSON v = FofField  <$> parseJSON v-            <|> FofFields <$> (parseNEJSON =<< parseJSON v)--data PrefixQuery =-  PrefixQuery-  { prefixQueryField       :: FieldName-  , prefixQueryPrefixValue :: Text-  , prefixQueryBoost       :: Maybe Boost } deriving (Eq, Show, Generic)--instance ToJSON PrefixQuery where-  toJSON (PrefixQuery (FieldName fieldName) queryValue boost) =-    object [ fromText fieldName .= omitNulls base ]-    where base = [ "value" .= queryValue-                 , "boost" .= boost ]--instance FromJSON PrefixQuery where-  parseJSON = withObject "PrefixQuery" parse-    where parse = fieldTagged $ \fn o ->-                    PrefixQuery fn-                    <$> o .: "value"-                    <*> o .:? "boost"--data NestedQuery =-  NestedQuery-  { nestedQueryPath      :: QueryPath-  , nestedQueryScoreType :: ScoreType-  , nestedQuery          :: Query-  , nestedQueryInnerHits :: Maybe InnerHits } deriving (Eq, Show, Generic)--instance ToJSON NestedQuery where-  toJSON (NestedQuery nqPath nqScoreType nqQuery nqInnerHits) =-    omitNulls [ "path"       .= nqPath-              , "score_mode" .= nqScoreType-              , "query"      .= nqQuery-              , "inner_hits" .= nqInnerHits-              ]--instance FromJSON NestedQuery where-  parseJSON = withObject "NestedQuery" parse-    where parse o = NestedQuery-                    <$> o .: "path"-                    <*> o .: "score_mode"-                    <*> o .: "query"-                    <*> o .:? "inner_hits"--data MoreLikeThisFieldQuery =-  MoreLikeThisFieldQuery-  { moreLikeThisFieldText            :: Text-  , moreLikeThisFieldFields          :: FieldName-                                        -- default 0.3 (30%)-  , moreLikeThisFieldPercentMatch    :: Maybe PercentMatch-  , moreLikeThisFieldMinimumTermFreq :: Maybe MinimumTermFrequency-  , moreLikeThisFieldMaxQueryTerms   :: Maybe MaxQueryTerms-  , moreLikeThisFieldStopWords       :: Maybe (NonEmpty StopWord)-  , moreLikeThisFieldMinDocFrequency :: Maybe MinDocFrequency-  , moreLikeThisFieldMaxDocFrequency :: Maybe MaxDocFrequency-  , moreLikeThisFieldMinWordLength   :: Maybe MinWordLength-  , moreLikeThisFieldMaxWordLength   :: Maybe MaxWordLength-  , moreLikeThisFieldBoostTerms      :: Maybe BoostTerms-  , moreLikeThisFieldBoost           :: Maybe Boost-  , moreLikeThisFieldAnalyzer        :: Maybe Analyzer-  } deriving (Eq, Show, Generic)---instance ToJSON MoreLikeThisFieldQuery where-  toJSON (MoreLikeThisFieldQuery text (FieldName fieldName)-          percent mtf mqt stopwords mindf maxdf-          minwl maxwl boostTerms boost analyzer) =-    object [ fromText fieldName .= omitNulls base ]-    where base = [ "like_text" .= text-                 , "percent_terms_to_match" .= percent-                 , "min_term_freq" .= mtf-                 , "max_query_terms" .= mqt-                 , "stop_words" .= stopwords-                 , "min_doc_freq" .= mindf-                 , "max_doc_freq" .= maxdf-                 , "min_word_length" .= minwl-                 , "max_word_length" .= maxwl-                 , "boost_terms" .= boostTerms-                 , "boost" .= boost-                 , "analyzer" .= analyzer ]--instance FromJSON MoreLikeThisFieldQuery where-  parseJSON = withObject "MoreLikeThisFieldQuery" parse-    where parse = fieldTagged $ \fn o ->-                    MoreLikeThisFieldQuery-                    <$> o .: "like_text"-                    <*> pure fn-                    <*> o .:? "percent_terms_to_match"-                    <*> o .:? "min_term_freq"-                    <*> o .:? "max_query_terms"-                    -- <*> (optionalNE =<< o .:? "stop_words")-                    <*> o .:? "stop_words"-                    <*> o .:? "min_doc_freq"-                    <*> o .:? "max_doc_freq"-                    <*> o .:? "min_word_length"-                    <*> o .:? "max_word_length"-                    <*> o .:? "boost_terms"-                    <*> o .:? "boost"-                    <*> o .:? "analyzer"-          -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)--data MoreLikeThisQuery =-  MoreLikeThisQuery-  { moreLikeThisText            :: Text-  , moreLikeThisFields          :: Maybe (NonEmpty FieldName)-    -- default 0.3 (30%)-  , moreLikeThisPercentMatch    :: Maybe PercentMatch-  , moreLikeThisMinimumTermFreq :: Maybe MinimumTermFrequency-  , moreLikeThisMaxQueryTerms   :: Maybe MaxQueryTerms-  , moreLikeThisStopWords       :: Maybe (NonEmpty StopWord)-  , moreLikeThisMinDocFrequency :: Maybe MinDocFrequency-  , moreLikeThisMaxDocFrequency :: Maybe MaxDocFrequency-  , moreLikeThisMinWordLength   :: Maybe MinWordLength-  , moreLikeThisMaxWordLength   :: Maybe MaxWordLength-  , moreLikeThisBoostTerms      :: Maybe BoostTerms-  , moreLikeThisBoost           :: Maybe Boost-  , moreLikeThisAnalyzer        :: Maybe Analyzer-  } deriving (Eq, Show, Generic)---instance ToJSON MoreLikeThisQuery where-  toJSON (MoreLikeThisQuery text fields percent-          mtf mqt stopwords mindf maxdf-          minwl maxwl boostTerms boost analyzer) =-    omitNulls base-    where base = [ "like_text" .= text-                 , "fields" .= fields-                 , "percent_terms_to_match" .= percent-                 , "min_term_freq" .= mtf-                 , "max_query_terms" .= mqt-                 , "stop_words" .= stopwords-                 , "min_doc_freq" .= mindf-                 , "max_doc_freq" .= maxdf-                 , "min_word_length" .= minwl-                 , "max_word_length" .= maxwl-                 , "boost_terms" .= boostTerms-                 , "boost" .= boost-                 , "analyzer" .= analyzer ]--instance FromJSON MoreLikeThisQuery where-  parseJSON = withObject "MoreLikeThisQuery" parse-    where parse o = MoreLikeThisQuery-                    <$> o .: "like_text"-                    -- <*> (optionalNE =<< o .:? "fields")-                    <*> o .:? "fields"-                    <*> o .:? "percent_terms_to_match"-                    <*> o .:? "min_term_freq"-                    <*> o .:? "max_query_terms"-                    -- <*> (optionalNE =<< o .:? "stop_words")-                    <*> o .:? "stop_words"-                    <*> o .:? "min_doc_freq"-                    <*> o .:? "max_doc_freq"-                    <*> o .:? "min_word_length"-                    <*> o .:? "max_word_length"-                    <*> o .:? "boost_terms"-                    <*> o .:? "boost"-                    <*> o .:? "analyzer"-          -- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)--data IndicesQuery =-  IndicesQuery-  { indicesQueryIndices :: [IndexName]-  , indicesQuery        :: Query-    -- default "all"-  , indicesQueryNoMatch :: Maybe Query } deriving (Eq, Show, Generic)---instance ToJSON IndicesQuery where-  toJSON (IndicesQuery indices query noMatch) =-    omitNulls [ "indices" .= indices-              , "no_match_query" .= noMatch-              , "query" .= query ]--instance FromJSON IndicesQuery where-  parseJSON = withObject "IndicesQuery" parse-    where parse o = IndicesQuery-                    <$> o .:? "indices" .!= []-                    <*> o .: "query"-                    <*> o .:? "no_match_query"--data HasParentQuery =-  HasParentQuery-  { hasParentQueryType      :: RelationName-  , hasParentQuery          :: Query-  , hasParentQueryScore     :: Maybe AggregateParentScore-  , hasParentIgnoreUnmapped :: Maybe IgnoreUnmapped-  } deriving (Eq, Show, Generic)--instance ToJSON HasParentQuery where-  toJSON (HasParentQuery queryType query scoreType ignoreUnmapped) =-    omitNulls [ "parent_type" .= queryType-              , "score" .= scoreType-              , "query" .= query-              , "ignore_unmapped" .= ignoreUnmapped-              ]--instance FromJSON HasParentQuery where-  parseJSON = withObject "HasParentQuery" parse-    where parse o = HasParentQuery-                    <$> o .: "parent_type"-                    <*> o .: "query"-                    <*> o .:? "score"-                    <*> o .:? "ignore_unmapped"--data HasChildQuery =-  HasChildQuery-  { hasChildQueryType       :: RelationName-  , hasChildQuery           :: Query-  , hasChildQueryScoreType  :: Maybe ScoreType-  , hasChildIgnoreUnmappped :: Maybe IgnoreUnmapped-  , hasChildMinChildren     :: Maybe MinChildren-  , hasChildMaxChildren     :: Maybe MaxChildren-  } deriving (Eq, Show, Generic)--instance ToJSON HasChildQuery where-  toJSON (HasChildQuery queryType query scoreType ignoreUnmapped minChildren maxChildren) =-    omitNulls [ "query" .= query-              , "score_mode" .= scoreType-              , "type"  .= queryType-              , "min_children" .= minChildren-              , "max_children" .= maxChildren-              , "ignore_unmapped" .= ignoreUnmapped-              ]--instance FromJSON HasChildQuery where-  parseJSON = withObject "HasChildQuery" parse-    where parse o = HasChildQuery-                    <$> o .: "type"-                    <*> o .: "query"-                    <*> o .:? "score_mode"-                    <*> o .:? "ignore_unmapped"-                    <*> o .:? "min_children"-                    <*> o .:? "max_children"--data ScoreType =-    ScoreTypeMax-  | ScoreTypeSum-  | ScoreTypeAvg-  | ScoreTypeNone deriving (Eq, Show, Generic)--instance ToJSON ScoreType where-  toJSON ScoreTypeMax  = "max"-  toJSON ScoreTypeAvg  = "avg"-  toJSON ScoreTypeSum  = "sum"-  toJSON ScoreTypeNone = "none"--instance FromJSON ScoreType where-  parseJSON = withText "ScoreType" parse-    where parse "max"  = pure ScoreTypeMax-          parse "avg"  = pure ScoreTypeAvg-          parse "sum"  = pure ScoreTypeSum-          parse "none" = pure ScoreTypeNone-          parse t      = fail ("Unexpected ScoreType: " <> show t)--data FuzzyQuery =-  FuzzyQuery { fuzzyQueryField         :: FieldName-             , fuzzyQueryValue         :: Text-             , fuzzyQueryPrefixLength  :: PrefixLength-             , fuzzyQueryMaxExpansions :: MaxExpansions-             , fuzzyQueryFuzziness     :: Fuzziness-             , fuzzyQueryBoost         :: Maybe Boost-             } deriving (Eq, Show, Generic)---instance ToJSON FuzzyQuery where-  toJSON (FuzzyQuery (FieldName fieldName) queryText-          prefixLength maxEx fuzziness boost) =-    object [ fromText fieldName .= omitNulls base ]-    where base = [ "value"          .= queryText-                 , "fuzziness"      .= fuzziness-                 , "prefix_length"  .= prefixLength-                 , "boost" .= boost-                 , "max_expansions" .= maxEx ]--instance FromJSON FuzzyQuery where-  parseJSON = withObject "FuzzyQuery" parse-    where parse = fieldTagged $ \fn o ->-                    FuzzyQuery fn-                    <$> o .: "value"-                    <*> o .: "prefix_length"-                    <*> o .: "max_expansions"-                    <*> o .: "fuzziness"-                    <*> o .:? "boost"--data FuzzyLikeFieldQuery =-  FuzzyLikeFieldQuery-  { fuzzyLikeField                    :: FieldName-    -- anaphora is good for the soul.-  , fuzzyLikeFieldText                :: Text-  , fuzzyLikeFieldMaxQueryTerms       :: MaxQueryTerms-  , fuzzyLikeFieldIgnoreTermFrequency :: IgnoreTermFrequency-  , fuzzyLikeFieldFuzziness           :: Fuzziness-  , fuzzyLikeFieldPrefixLength        :: PrefixLength-  , fuzzyLikeFieldBoost               :: Boost-  , fuzzyLikeFieldAnalyzer            :: Maybe Analyzer-  } deriving (Eq, Show, Generic)---instance ToJSON FuzzyLikeFieldQuery where-  toJSON (FuzzyLikeFieldQuery (FieldName fieldName)-          fieldText maxTerms ignoreFreq fuzziness prefixLength-          boost analyzer) =-    object [ fromText fieldName .=-             omitNulls [ "like_text"       .= fieldText-                       , "max_query_terms" .= maxTerms-                       , "ignore_tf"       .= ignoreFreq-                       , "fuzziness"       .= fuzziness-                       , "prefix_length"   .= prefixLength-                       , "analyzer" .= analyzer-                       , "boost"           .= boost ]]--instance FromJSON FuzzyLikeFieldQuery where-  parseJSON = withObject "FuzzyLikeFieldQuery" parse-    where parse = fieldTagged $ \fn o ->-                    FuzzyLikeFieldQuery fn-                    <$> o .: "like_text"-                    <*> o .: "max_query_terms"-                    <*> o .: "ignore_tf"-                    <*> o .: "fuzziness"-                    <*> o .: "prefix_length"-                    <*> o .: "boost"-                    <*> o .:? "analyzer"--data FuzzyLikeThisQuery =-  FuzzyLikeThisQuery-  { fuzzyLikeFields              :: [FieldName]-  , fuzzyLikeText                :: Text-  , fuzzyLikeMaxQueryTerms       :: MaxQueryTerms-  , fuzzyLikeIgnoreTermFrequency :: IgnoreTermFrequency-  , fuzzyLikeFuzziness           :: Fuzziness-  , fuzzyLikePrefixLength        :: PrefixLength-  , fuzzyLikeBoost               :: Boost-  , fuzzyLikeAnalyzer            :: Maybe Analyzer-  } deriving (Eq, Show, Generic)---instance ToJSON FuzzyLikeThisQuery where-  toJSON (FuzzyLikeThisQuery fields text maxTerms-          ignoreFreq fuzziness prefixLength boost analyzer) =-    omitNulls base-    where base = [ "fields"          .= fields-                 , "like_text"       .= text-                 , "max_query_terms" .= maxTerms-                 , "ignore_tf"       .= ignoreFreq-                 , "fuzziness"       .= fuzziness-                 , "prefix_length"   .= prefixLength-                 , "analyzer"        .= analyzer-                 , "boost"           .= boost ]--instance FromJSON FuzzyLikeThisQuery where-  parseJSON = withObject "FuzzyLikeThisQuery" parse-    where parse o = FuzzyLikeThisQuery-                    <$> o .:? "fields" .!= []-                    <*> o .: "like_text"-                    <*> o .: "max_query_terms"-                    <*> o .: "ignore_tf"-                    <*> o .: "fuzziness"-                    <*> o .: "prefix_length"-                    <*> o .: "boost"-                    <*> o .:? "analyzer"--data DisMaxQuery =-  DisMaxQuery { disMaxQueries    :: [Query]-                -- default 0.0-              , disMaxTiebreaker :: Tiebreaker-              , disMaxBoost      :: Maybe Boost-              } deriving (Eq, Show, Generic)---instance ToJSON DisMaxQuery where-  toJSON (DisMaxQuery queries tiebreaker boost) =-    omitNulls base-    where base = [ "queries"     .= queries-                 , "boost"       .= boost-                 , "tie_breaker" .= tiebreaker ]--instance FromJSON DisMaxQuery where-  parseJSON = withObject "DisMaxQuery" parse-    where parse o = DisMaxQuery-                    <$> o .:? "queries" .!= []-                    <*> o .: "tie_breaker"-                    <*> o .:? "boost"--data MatchQuery = MatchQuery-  { matchQueryField              :: FieldName-  , matchQueryQueryString        :: QueryString-  , matchQueryOperator           :: BooleanOperator-  , matchQueryZeroTerms          :: ZeroTermsQuery-  , matchQueryCutoffFrequency    :: Maybe CutoffFrequency-  , matchQueryMatchType          :: Maybe MatchQueryType-  , matchQueryAnalyzer           :: Maybe Analyzer-  , matchQueryMaxExpansions      :: Maybe MaxExpansions-  , matchQueryLenient            :: Maybe Lenient-  , matchQueryBoost              :: Maybe Boost-  , matchQueryMinimumShouldMatch :: Maybe Text-  , matchQueryFuzziness          :: Maybe Fuzziness-  } deriving (Eq, Show, Generic)---instance ToJSON MatchQuery where-  toJSON (MatchQuery (FieldName fieldName)-          (QueryString mqQueryString) booleanOperator-          zeroTermsQuery cutoffFrequency matchQueryType-          analyzer maxExpansions lenient boost-          minShouldMatch mqFuzziness-         ) =-    object [ fromText fieldName .= omitNulls base ]-    where base = [ "query" .= mqQueryString-                 , "operator" .= booleanOperator-                 , "zero_terms_query" .= zeroTermsQuery-                 , "cutoff_frequency" .= cutoffFrequency-                 , "type" .= matchQueryType-                 , "analyzer" .= analyzer-                 , "max_expansions" .= maxExpansions-                 , "lenient" .= lenient-                 , "boost" .= boost-                 , "minimum_should_match" .= minShouldMatch-                 , "fuzziness" .= mqFuzziness-                 ]--instance FromJSON MatchQuery where-  parseJSON = withObject "MatchQuery" parse-    where parse = fieldTagged $ \fn o ->-                    MatchQuery fn-                    <$> o .:  "query"-                    <*> o .:  "operator"-                    <*> o .:  "zero_terms_query"-                    <*> o .:? "cutoff_frequency"-                    <*> o .:? "type"-                    <*> o .:? "analyzer"-                    <*> o .:? "max_expansions"-                    <*> o .:? "lenient"-                    <*> o .:? "boost"-                    <*> o .:? "minimum_should_match"-                    <*> o .:? "fuzziness"--{-| 'mkMatchQuery' is a convenience function that defaults the less common parameters,-    enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery'--}-mkMatchQuery :: FieldName -> QueryString -> MatchQuery-mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing--data MatchQueryType =-    MatchPhrase-  | MatchPhrasePrefix deriving (Eq, Show, Generic)--instance ToJSON MatchQueryType where-  toJSON MatchPhrase       = "phrase"-  toJSON MatchPhrasePrefix = "phrase_prefix"--instance FromJSON MatchQueryType where-  parseJSON = withText "MatchQueryType" parse-    where parse "phrase"        = pure MatchPhrase-          parse "phrase_prefix" = pure MatchPhrasePrefix-          parse t               = fail ("Unexpected MatchQueryType: " <> show t)--data MultiMatchQuery = MultiMatchQuery-  { multiMatchQueryFields          :: [FieldName]-  , multiMatchQueryString          :: QueryString-  , multiMatchQueryOperator        :: BooleanOperator-  , multiMatchQueryZeroTerms       :: ZeroTermsQuery-  , multiMatchQueryTiebreaker      :: Maybe Tiebreaker-  , multiMatchQueryType            :: Maybe MultiMatchQueryType-  , multiMatchQueryCutoffFrequency :: Maybe CutoffFrequency-  , multiMatchQueryAnalyzer        :: Maybe Analyzer-  , multiMatchQueryMaxExpansions   :: Maybe MaxExpansions-  , multiMatchQueryLenient         :: Maybe Lenient-  } deriving (Eq, Show, Generic)--instance ToJSON MultiMatchQuery where-  toJSON (MultiMatchQuery fields (QueryString query) boolOp-          ztQ tb mmqt cf analyzer maxEx lenient) =-    object ["multi_match" .= omitNulls base]-    where base = [ "fields" .= fmap toJSON fields-                 , "query" .= query-                 , "operator" .= boolOp-                 , "zero_terms_query" .= ztQ-                 , "tie_breaker" .= tb-                 , "type" .= mmqt-                 , "cutoff_frequency" .= cf-                 , "analyzer" .= analyzer-                 , "max_expansions" .= maxEx-                 , "lenient" .= lenient ]--instance FromJSON MultiMatchQuery where-  parseJSON = withObject "MultiMatchQuery" parse-    where parse raw = do o <- raw .: "multi_match"-                         MultiMatchQuery-                           <$> o .:? "fields" .!= []-                           <*> o .: "query"-                           <*> o .: "operator"-                           <*> o .: "zero_terms_query"-                           <*> o .:? "tie_breaker"-                           <*> o .:? "type"-                           <*> o .:? "cutoff_frequency"-                           <*> o .:? "analyzer"-                           <*> o .:? "max_expansions"-                           <*> o .:? "lenient"--{-| 'mkMultiMatchQuery' is a convenience function that defaults the less common parameters,-    enabling you to provide only the list of 'FieldName's and 'QueryString' to-    make a 'MultiMatchQuery'.--}--mkMultiMatchQuery :: [FieldName] -> QueryString -> MultiMatchQuery-mkMultiMatchQuery matchFields query =-  MultiMatchQuery matchFields query-  Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing--data MultiMatchQueryType =-    MultiMatchBestFields-  | MultiMatchMostFields-  | MultiMatchCrossFields-  | MultiMatchPhrase-  | MultiMatchPhrasePrefix deriving (Eq, Show, Generic)--instance ToJSON MultiMatchQueryType where-  toJSON MultiMatchBestFields   = "best_fields"-  toJSON MultiMatchMostFields   = "most_fields"-  toJSON MultiMatchCrossFields  = "cross_fields"-  toJSON MultiMatchPhrase       = "phrase"-  toJSON MultiMatchPhrasePrefix = "phrase_prefix"--instance FromJSON MultiMatchQueryType where-  parseJSON = withText "MultiMatchPhrasePrefix" parse-    where parse "best_fields"   = pure MultiMatchBestFields-          parse "most_fields"   = pure MultiMatchMostFields-          parse "cross_fields"  = pure MultiMatchCrossFields-          parse "phrase"        = pure MultiMatchPhrase-          parse "phrase_prefix" = pure MultiMatchPhrasePrefix-          parse t = fail ("Unexpected MultiMatchPhrasePrefix: " <> show t)--data BoolQuery =-  BoolQuery { boolQueryMustMatch          :: [Query]-            , boolQueryFilter             :: [Filter]-            , boolQueryMustNotMatch       :: [Query]-            , boolQueryShouldMatch        :: [Query]-            , boolQueryMinimumShouldMatch :: Maybe MinimumMatch-            , boolQueryBoost              :: Maybe Boost-            , boolQueryDisableCoord       :: Maybe DisableCoord-            } deriving (Eq, Show, Generic)---instance ToJSON BoolQuery where-  toJSON (BoolQuery mustM filterM' notM shouldM bqMin boost disableCoord) =-    omitNulls base-    where base = [ "must" .= mustM-                 , "filter" .= filterM'-                 , "must_not" .= notM-                 , "should" .= shouldM-                 , "minimum_should_match" .= bqMin-                 , "boost" .= boost-                 , "disable_coord" .= disableCoord ]--instance FromJSON BoolQuery where-  parseJSON = withObject "BoolQuery" parse-    where parse o = BoolQuery-                    <$> o .:? "must" .!= []-                    <*> o .:? "filter" .!= []-                    <*> o .:? "must_not" .!= []-                    <*> o .:? "should" .!= []-                    <*> o .:? "minimum_should_match"-                    <*> o .:? "boost"-                    <*> o .:? "disable_coord"--mkBoolQuery :: [Query] -> [Filter] -> [Query] -> [Query] -> BoolQuery-mkBoolQuery must filt mustNot should =-  BoolQuery must filt mustNot should Nothing Nothing Nothing--data BoostingQuery =-  BoostingQuery { positiveQuery :: Query-                , negativeQuery :: Query-                , negativeBoost :: Boost } deriving (Eq, Show, Generic)--instance ToJSON BoostingQuery where-  toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) =-    object [ "positive"       .= bqPositiveQuery-           , "negative"       .= bqNegativeQuery-           , "negative_boost" .= bqNegativeBoost ]--instance FromJSON BoostingQuery where-  parseJSON = withObject "BoostingQuery" parse-    where parse o = BoostingQuery-                    <$> o .: "positive"-                    <*> o .: "negative"-                    <*> o .: "negative_boost"--data CommonTermsQuery =-  CommonTermsQuery { commonField              :: FieldName-                   , commonQuery              :: QueryString-                   , commonCutoffFrequency    :: CutoffFrequency-                   , commonLowFreqOperator    :: BooleanOperator-                   , commonHighFreqOperator   :: BooleanOperator-                   , commonMinimumShouldMatch :: Maybe CommonMinimumMatch-                   , commonBoost              :: Maybe Boost-                   , commonAnalyzer           :: Maybe Analyzer-                   , commonDisableCoord       :: Maybe DisableCoord-                   } deriving (Eq, Show, Generic)---instance ToJSON CommonTermsQuery where-  toJSON (CommonTermsQuery (FieldName fieldName)-          (QueryString query) cf lfo hfo msm-          boost analyzer disableCoord) =-    object [fromText fieldName .= omitNulls base ]-    where base = [ "query"              .= query-                 , "cutoff_frequency"   .= cf-                 , "low_freq_operator"  .= lfo-                 , "minimum_should_match" .= msm-                 , "boost" .= boost-                 , "analyzer" .= analyzer-                 , "disable_coord" .= disableCoord-                 , "high_freq_operator" .= hfo ]--instance FromJSON CommonTermsQuery where-  parseJSON = withObject "CommonTermsQuery" parse-    where parse = fieldTagged $ \fn o ->-                    CommonTermsQuery fn-                    <$> o .: "query"-                    <*> o .: "cutoff_frequency"-                    <*> o .: "low_freq_operator"-                    <*> o .: "high_freq_operator"-                    <*> o .:? "minimum_should_match"-                    <*> o .:? "boost"-                    <*> o .:? "analyzer"-                    <*> o .:? "disable_coord"--data CommonMinimumMatch =-    CommonMinimumMatchHighLow MinimumMatchHighLow-  | CommonMinimumMatch        MinimumMatch-  deriving (Eq, Show, Generic)---instance ToJSON CommonMinimumMatch where-  toJSON (CommonMinimumMatch mm) = toJSON mm-  toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) =-    object [ "low_freq"  .= lowF-           , "high_freq" .= highF ]--instance FromJSON CommonMinimumMatch where-  parseJSON v = parseMinimum v-            <|> parseMinimumHighLow v-    where parseMinimum = fmap CommonMinimumMatch . parseJSON-          parseMinimumHighLow = fmap CommonMinimumMatchHighLow . withObject "CommonMinimumMatchHighLow" (\o ->-                                  MinimumMatchHighLow-                                  <$> o .: "low_freq"-                                  <*> o .: "high_freq")--data MinimumMatchHighLow =-  MinimumMatchHighLow { lowFreq  :: MinimumMatch-                      , highFreq :: MinimumMatch } deriving (Eq, Show, Generic)--data ZeroTermsQuery =-    ZeroTermsNone-  | ZeroTermsAll deriving (Eq, Show, Generic)--instance ToJSON ZeroTermsQuery where-  toJSON ZeroTermsNone = String "none"-  toJSON ZeroTermsAll  = String "all"--instance FromJSON ZeroTermsQuery where-  parseJSON = withText "ZeroTermsQuery" parse-    where parse "none" = pure ZeroTermsNone-          parse "all"  = pure ZeroTermsAll-          parse q      = fail ("Unexpected ZeroTermsQuery: " <> show q)--data RangeExecution = RangeExecutionIndex-                    | RangeExecutionFielddata deriving (Eq, Show, Generic)---- index for smaller ranges, fielddata for longer ranges-instance ToJSON RangeExecution where-  toJSON RangeExecutionIndex     = "index"-  toJSON RangeExecutionFielddata = "fielddata"---instance FromJSON RangeExecution where-  parseJSON = withText "RangeExecution" parse-    where parse "index"     = pure RangeExecutionIndex-          parse "fielddata" = pure RangeExecutionFielddata-          parse t           = error ("Unrecognized RangeExecution " <> show t)--newtype Regexp = Regexp Text deriving (Eq, Show, Generic, FromJSON)--data RegexpFlags = AllRegexpFlags-                 | NoRegexpFlags-                 | SomeRegexpFlags (NonEmpty RegexpFlag) deriving (Eq, Show, Generic)--instance ToJSON RegexpFlags where-  toJSON AllRegexpFlags              = String "ALL"-  toJSON NoRegexpFlags               = String "NONE"-  toJSON (SomeRegexpFlags (h :| fs)) = String $ T.intercalate "|" flagStrs-    where flagStrs             = map flagStr . nub $ h:fs-          flagStr AnyString    = "ANYSTRING"-          flagStr Automaton    = "AUTOMATON"-          flagStr Complement   = "COMPLEMENT"-          flagStr Empty        = "EMPTY"-          flagStr Intersection = "INTERSECTION"-          flagStr Interval     = "INTERVAL"--instance FromJSON RegexpFlags where-  parseJSON = withText "RegexpFlags" parse-    where parse "ALL" = pure AllRegexpFlags-          parse "NONE" = pure NoRegexpFlags-          parse t = SomeRegexpFlags <$> parseNEJSON (String <$> T.splitOn "|" t)--data RegexpFlag = AnyString-                | Automaton-                | Complement-                | Empty-                | Intersection-                | Interval deriving (Eq, Show, Generic)--instance FromJSON RegexpFlag where-  parseJSON = withText "RegexpFlag" parse-    where parse "ANYSTRING"    = pure AnyString-          parse "AUTOMATON"    = pure Automaton-          parse "COMPLEMENT"   = pure Complement-          parse "EMPTY"        = pure Empty-          parse "INTERSECTION" = pure Intersection-          parse "INTERVAL"     = pure Interval-          parse f              = fail ("Unknown RegexpFlag: " <> show f)--newtype LessThan = LessThan Double deriving (Eq, Show, Generic)-newtype LessThanEq = LessThanEq Double deriving (Eq, Show, Generic)-newtype GreaterThan = GreaterThan Double deriving (Eq, Show, Generic)-newtype GreaterThanEq = GreaterThanEq Double deriving (Eq, Show, Generic)--newtype LessThanD = LessThanD UTCTime deriving (Eq, Show, Generic)-newtype LessThanEqD = LessThanEqD UTCTime deriving (Eq, Show, Generic)-newtype GreaterThanD = GreaterThanD UTCTime deriving (Eq, Show, Generic)-newtype GreaterThanEqD = GreaterThanEqD UTCTime deriving (Eq, Show, Generic)--data RangeValue = RangeDateLte LessThanEqD-                | RangeDateLt LessThanD-                | RangeDateGte GreaterThanEqD-                | RangeDateGt GreaterThanD-                | RangeDateGtLt GreaterThanD LessThanD-                | RangeDateGteLte GreaterThanEqD LessThanEqD-                | RangeDateGteLt GreaterThanEqD LessThanD-                | RangeDateGtLte GreaterThanD LessThanEqD-                | RangeDoubleLte LessThanEq-                | RangeDoubleLt LessThan-                | RangeDoubleGte GreaterThanEq-                | RangeDoubleGt GreaterThan-                | RangeDoubleGtLt GreaterThan LessThan-                | RangeDoubleGteLte GreaterThanEq LessThanEq-                | RangeDoubleGteLt GreaterThanEq LessThan-                | RangeDoubleGtLte GreaterThan LessThanEq-                deriving (Eq, Show, Generic)---parseRangeValue :: ( FromJSON t4-                   , FromJSON t3-                   , FromJSON t2-                   , FromJSON t1-                   )-                => (t3 -> t5)-                -> (t1 -> t6)-                -> (t4 -> t7)-                -> (t2 -> t8)-                -> (t5 -> t6 -> b)-                -> (t7 -> t6 -> b)-                -> (t5 -> t8 -> b)-                -> (t7 -> t8 -> b)-                -> (t5 -> b)-                -> (t6 -> b)-                -> (t7 -> b)-                -> (t8 -> b)-                -> Parser b-                -> Object-                -> Parser b-parseRangeValue mkGt mkLt mkGte mkLte-                fGtLt fGteLt fGtLte fGteLte-                fGt fLt fGte fLte nada o = do-  lt <- o .:? "lt"-  lte <- o .:? "lte"-  gt <- o .:? "gt"-  gte <- o .:? "gte"-  case (lt, lte, gt, gte) of-    (Just a, _, Just b, _) ->-      return (fGtLt (mkGt b) (mkLt a))-    (Just a, _, _, Just b) ->-      return (fGteLt (mkGte b) (mkLt a))-    (_, Just a, Just b, _) ->-      return (fGtLte (mkGt b) (mkLte a))-    (_, Just a, _, Just b) ->-      return (fGteLte (mkGte b) (mkLte a))-    (_, _, Just a, _) ->-      return (fGt (mkGt a))-    (Just a, _, _, _) ->-      return (fLt (mkLt a))-    (_, _, _, Just a) ->-      return (fGte (mkGte a))-    (_, Just a, _, _) ->-      return (fLte (mkLte a))-    (Nothing, Nothing, Nothing, Nothing) ->-      nada---instance FromJSON RangeValue where-  parseJSON = withObject "RangeValue" parse-    where parse o = parseDate o-                <|> parseDouble o-          parseDate o =-            parseRangeValue-            GreaterThanD LessThanD-            GreaterThanEqD LessThanEqD-            RangeDateGtLt RangeDateGteLt-            RangeDateGtLte RangeDateGteLte-            RangeDateGt RangeDateLt-            RangeDateGte RangeDateLte-            mzero o-          parseDouble o =-            parseRangeValue-            GreaterThan LessThan-            GreaterThanEq LessThanEq-            RangeDoubleGtLt RangeDoubleGteLt-            RangeDoubleGtLte RangeDoubleGteLte-            RangeDoubleGt RangeDoubleLt-            RangeDoubleGte RangeDoubleLte-            mzero o--rangeValueToPair :: RangeValue -> [Pair]-rangeValueToPair rv = case rv of-  RangeDateLte (LessThanEqD t)                       -> ["lte" .= t]-  RangeDateGte (GreaterThanEqD t)                    -> ["gte" .= t]-  RangeDateLt (LessThanD t)                          -> ["lt"  .= t]-  RangeDateGt (GreaterThanD t)                       -> ["gt"  .= t]-  RangeDateGteLte (GreaterThanEqD l) (LessThanEqD g) -> ["gte" .= l, "lte" .= g]-  RangeDateGtLte (GreaterThanD l) (LessThanEqD g)    -> ["gt"  .= l, "lte" .= g]-  RangeDateGteLt (GreaterThanEqD l) (LessThanD g)    -> ["gte" .= l, "lt"  .= g]-  RangeDateGtLt (GreaterThanD l) (LessThanD g)       -> ["gt"  .= l, "lt"  .= g]-  RangeDoubleLte (LessThanEq t)                      -> ["lte" .= t]-  RangeDoubleGte (GreaterThanEq t)                   -> ["gte" .= t]-  RangeDoubleLt (LessThan t)                         -> ["lt"  .= t]-  RangeDoubleGt (GreaterThan t)                      -> ["gt"  .= t]-  RangeDoubleGteLte (GreaterThanEq l) (LessThanEq g) -> ["gte" .= l, "lte" .= g]-  RangeDoubleGtLte (GreaterThan l) (LessThanEq g)    -> ["gt"  .= l, "lte" .= g]-  RangeDoubleGteLt (GreaterThanEq l) (LessThan g)    -> ["gte" .= l, "lt"  .= g]-  RangeDoubleGtLt (GreaterThan l) (LessThan g)       -> ["gt"  .= l, "lt"  .= g]--data Term = Term { termField :: Key-                 , termValue :: Text } deriving (Eq, Show, Generic)--instance ToJSON Term where-  toJSON (Term field value) = object ["term" .= object-                                      [field .= value]]--instance FromJSON Term where-  parseJSON = withObject "Term" parse-    where parse o = do termObj <- o .: "term"-                       case HM.toList termObj of-                         [(fn, v)] -> Term fn <$> parseJSON v-                         _ -> fail "Expected object with 1 field-named key"--data BoolMatch = MustMatch    Term  Cache-               | MustNotMatch Term  Cache-               | ShouldMatch [Term] Cache deriving (Eq, Show, Generic)---instance ToJSON BoolMatch where-  toJSON (MustMatch    term  cache) = object ["must"     .= term,-                                              "_cache" .= cache]-  toJSON (MustNotMatch term  cache) = object ["must_not" .= term,-                                              "_cache" .= cache]-  toJSON (ShouldMatch  terms cache) = object ["should"   .= fmap toJSON terms,-                                              "_cache" .= cache]--instance FromJSON BoolMatch where-  parseJSON = withObject "BoolMatch" parse-    where parse o = mustMatch `taggedWith` "must"-                <|> mustNotMatch `taggedWith` "must_not"-                <|> shouldMatch `taggedWith` "should"-            where taggedWith parser k = parser =<< o .: k-                  mustMatch t = MustMatch t <$> o .:? "_cache" .!= defaultCache-                  mustNotMatch t = MustNotMatch t <$> o .:? "_cache" .!= defaultCache-                  shouldMatch t = ShouldMatch t <$> o .:? "_cache" .!= defaultCache---- "memory" or "indexed"-data GeoFilterType = GeoFilterMemory-                   | GeoFilterIndexed deriving (Eq, Show, Generic)--instance ToJSON GeoFilterType where-  toJSON GeoFilterMemory  = String "memory"-  toJSON GeoFilterIndexed = String "indexed"--instance FromJSON GeoFilterType where-  parseJSON = withText "GeoFilterType" parse-    where parse "memory"  = pure GeoFilterMemory-          parse "indexed" = pure GeoFilterIndexed-          parse t         = fail ("Unrecognized GeoFilterType: " <> show t)--data LatLon = LatLon { lat :: Double-                     , lon :: Double } deriving (Eq, Show, Generic)--instance ToJSON LatLon where-  toJSON (LatLon lLat lLon) =-    object ["lat"  .= lLat-           , "lon" .= lLon]--instance FromJSON LatLon where-  parseJSON = withObject "LatLon" parse-    where parse o = LatLon <$> o .: "lat"-                           <*> o .: "lon"--data GeoBoundingBox =-  GeoBoundingBox { topLeft     :: LatLon-                 , bottomRight :: LatLon } deriving (Eq, Show, Generic)--instance ToJSON GeoBoundingBox where-  toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) =-    object ["top_left"      .= gbbTopLeft-           , "bottom_right" .= gbbBottomRight]--instance FromJSON GeoBoundingBox where-  parseJSON = withObject "GeoBoundingBox" parse-    where parse o = GeoBoundingBox-                    <$> o .: "top_left"-                    <*> o .: "bottom_right"--data GeoBoundingBoxConstraint =-  GeoBoundingBoxConstraint { geoBBField        :: FieldName-                           , constraintBox     :: GeoBoundingBox-                           , bbConstraintcache :: Cache-                           , geoType           :: GeoFilterType-                           } deriving (Eq, Show, Generic)--instance ToJSON GeoBoundingBoxConstraint where-  toJSON (GeoBoundingBoxConstraint-          (FieldName gbbcGeoBBField) gbbcConstraintBox cache type') =-    object [fromText gbbcGeoBBField .= gbbcConstraintBox-           , "_cache"  .= cache-           , "type" .= type']--instance FromJSON GeoBoundingBoxConstraint where-  parseJSON = withObject "GeoBoundingBoxConstraint" parse-    where parse o = case X.toList (deleteSeveral ["type", "_cache"] o) of-                      [(fn, v)] -> GeoBoundingBoxConstraint (FieldName $ toText fn)-                                   <$> parseJSON v-                                   <*> o .:? "_cache" .!= defaultCache-                                   <*> o .: "type"-                      _ -> fail "Could not find field name for GeoBoundingBoxConstraint"--data GeoPoint =-  GeoPoint { geoField :: FieldName-           , latLon   :: LatLon} deriving (Eq, Show, Generic)--instance ToJSON GeoPoint where-  toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) =-    object [ fromText geoPointField  .= geoPointLatLon ]--data DistanceUnit = Miles-                  | Yards-                  | Feet-                  | Inches-                  | Kilometers-                  | Meters-                  | Centimeters-                  | Millimeters-                  | NauticalMiles deriving (Eq, Show, Generic)--instance ToJSON DistanceUnit where-  toJSON Miles         = String "mi"-  toJSON Yards         = String "yd"-  toJSON Feet          = String "ft"-  toJSON Inches        = String "in"-  toJSON Kilometers    = String "km"-  toJSON Meters        = String "m"-  toJSON Centimeters   = String "cm"-  toJSON Millimeters   = String "mm"-  toJSON NauticalMiles = String "nmi"--instance FromJSON DistanceUnit where-  parseJSON = withText "DistanceUnit" parse-    where parse "mi"  = pure Miles-          parse "yd"  = pure Yards-          parse "ft"  = pure Feet-          parse "in"  = pure Inches-          parse "km"  = pure Kilometers-          parse "m"   = pure Meters-          parse "cm"  = pure Centimeters-          parse "mm"  = pure Millimeters-          parse "nmi" = pure NauticalMiles-          parse u     = fail ("Unrecognized DistanceUnit: " <> show u)--data DistanceType = Arc-                  | SloppyArc -- doesn't exist <1.0-                  | Plane deriving (Eq, Show, Generic)--instance ToJSON DistanceType where-  toJSON Arc       = String "arc"-  toJSON SloppyArc = String "sloppy_arc"-  toJSON Plane     = String "plane"--instance FromJSON DistanceType where-  parseJSON = withText "DistanceType" parse-    where parse "arc"        = pure Arc-          parse "sloppy_arc" = pure SloppyArc-          parse "plane"      = pure Plane-          parse t            = fail ("Unrecognized DistanceType: " <> show t)--data OptimizeBbox = OptimizeGeoFilterType GeoFilterType-                  | NoOptimizeBbox deriving (Eq, Show, Generic)---instance ToJSON OptimizeBbox where-  toJSON NoOptimizeBbox              = String "none"-  toJSON (OptimizeGeoFilterType gft) = toJSON gft--instance FromJSON OptimizeBbox where-  parseJSON v = withText "NoOptimizeBbox" parseNoOptimize v-            <|> parseOptimize v-    where parseNoOptimize "none" = pure NoOptimizeBbox-          parseNoOptimize _      = mzero-          parseOptimize = fmap OptimizeGeoFilterType . parseJSON--data Distance =-  Distance { coefficient :: Double-           , unit        :: DistanceUnit } deriving (Eq, Show, Generic)---instance ToJSON Distance where-  toJSON (Distance dCoefficient dUnit) =-    String boltedTogether where-      coefText = showText dCoefficient-      (String unitText) = toJSON dUnit-      boltedTogether = mappend coefText unitText--instance FromJSON Distance where-  parseJSON = withText "Distance" parse-    where parse t = Distance <$> parseCoeff nT-                             <*> parseJSON (String unitT)-            where (nT, unitT) = T.span validForNumber t-                  -- may be a better way to do this-                  validForNumber '-' = True-                  validForNumber '.' = True-                  validForNumber 'e' = True-                  validForNumber c   = isNumber c-                  parseCoeff "" = fail "Empty string cannot be parsed as number"-                  parseCoeff s = return (read (T.unpack s))--data DistanceRange =-  DistanceRange { distanceFrom :: Distance-                , distanceTo   :: Distance } deriving (Eq, Show, Generic)--type TemplateQueryValue = Text--newtype TemplateQueryKeyValuePairs =-  TemplateQueryKeyValuePairs (X.KeyMap TemplateQueryValue)-  deriving (Eq, Show)--instance ToJSON TemplateQueryKeyValuePairs where-  toJSON (TemplateQueryKeyValuePairs x) = Object $ String <$> x--instance FromJSON TemplateQueryKeyValuePairs where-  parseJSON (Object o) =-    pure . TemplateQueryKeyValuePairs $ X.mapMaybe getValue o-    where getValue (String x) = Just x-          getValue _          = Nothing-  parseJSON _          =-    fail "error parsing TemplateQueryKeyValuePairs"--{-| 'BooleanOperator' is the usual And/Or operators with an ES compatible-    JSON encoding baked in. Used all over the place.--}-data BooleanOperator = And | Or deriving (Eq, Show, Generic)--instance ToJSON BooleanOperator where-  toJSON And = String "and"-  toJSON Or  = String "or"--instance FromJSON BooleanOperator where-  parseJSON = withText "BooleanOperator" parse-    where parse "and" = pure And-          parse "or"  = pure Or-          parse o     = fail ("Unexpected BooleanOperator: " <> show o)--{-| 'Cache' is for telling ES whether it should cache a 'Filter' not.-    'Query's cannot be cached.--}-type Cache   = Bool -- caching on/off-defaultCache :: Cache-defaultCache = False---data FunctionScoreQuery =-  FunctionScoreQuery { functionScoreQuery     :: Maybe Query-                     , functionScoreBoost     :: Maybe Boost-                     , functionScoreFunctions :: FunctionScoreFunctions-                     , functionScoreMaxBoost  :: Maybe Boost-                     , functionScoreBoostMode :: Maybe BoostMode-                     , functionScoreMinScore  :: Score-                     , functionScoreScoreMode :: Maybe ScoreMode-                     } deriving (Eq, Show, Generic)--instance ToJSON FunctionScoreQuery where-  toJSON (FunctionScoreQuery query boost fns maxBoost boostMode minScore scoreMode) =-    omitNulls base-    where base = functionScoreFunctionsPair fns :-                 [ "query"      .= query-                 , "boost"      .= boost-                 , "max_boost"  .= maxBoost-                 , "boost_mode" .= boostMode-                 , "min_score"  .= minScore-                 , "score_mode" .= scoreMode ]--instance FromJSON FunctionScoreQuery where-  parseJSON = withObject "FunctionScoreQuery" parse-    where parse o = FunctionScoreQuery-                    <$> o .:? "query"-                    <*> o .:? "boost"-                    <*> (singleFunction o-                          <|> multipleFunctions `taggedWith` "functions")-                    <*> o .:? "max_boost"-                    <*> o .:? "boost_mode"-                    <*> o .:? "min_score"-                    <*> o .:? "score_mode"-            where taggedWith parser k = parser =<< o .: k-          singleFunction = fmap FunctionScoreSingle . parseFunctionScoreFunction-          multipleFunctions = pure . FunctionScoreMultiple--data FunctionScoreFunctions =-  FunctionScoreSingle FunctionScoreFunction-  | FunctionScoreMultiple (NonEmpty ComponentFunctionScoreFunction) deriving (Eq, Show, Generic)--data ComponentFunctionScoreFunction =-  ComponentFunctionScoreFunction { componentScoreFunctionFilter :: Maybe Filter-                                 , componentScoreFunction       :: FunctionScoreFunction-                                 , componentScoreFunctionWeight :: Maybe Weight-                                 } deriving (Eq, Show, Generic)--instance ToJSON ComponentFunctionScoreFunction where-  toJSON (ComponentFunctionScoreFunction filter' fn weight) =-    omitNulls base-    where base = functionScoreFunctionPair fn :-                 [ "filter" .= filter'-                 , "weight" .= weight ]--instance FromJSON ComponentFunctionScoreFunction where-  parseJSON = withObject "ComponentFunctionScoreFunction" parse-    where parse o = ComponentFunctionScoreFunction-                    <$> o .:? "filter"-                    <*> parseFunctionScoreFunction o-                    <*> o .:? "weight"--functionScoreFunctionsPair :: FunctionScoreFunctions -> (Key, Value)-functionScoreFunctionsPair (FunctionScoreSingle fn)-  = functionScoreFunctionPair fn-functionScoreFunctionsPair (FunctionScoreMultiple componentFns) =-  ("functions", toJSON componentFns)--fieldTagged :: (Monad m, MonadFail m)=> (FieldName -> Object -> m a) -> Object -> m a-fieldTagged f o = case X.toList o of-                    [(k, Object o')] -> f (FieldName $ toText k) o'-                    _ -> fail "Expected object with 1 field-named key"---- | Fuzziness value as a number or 'AUTO'.--- See:--- https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#fuzziness-data Fuzziness = Fuzziness Double | FuzzinessAuto-  deriving (Eq, Show, Generic)--instance ToJSON Fuzziness where-  toJSON (Fuzziness n) = toJSON n-  toJSON FuzzinessAuto = String "AUTO"--instance FromJSON Fuzziness where-  parseJSON (String "AUTO") = return FuzzinessAuto-  parseJSON v               = Fuzziness <$> parseJSON v--data InnerHits = InnerHits-  { innerHitsFrom :: Maybe Integer-  , innerHitsSize :: Maybe Integer-  } deriving (Eq, Show, Generic)--instance ToJSON InnerHits where-  toJSON (InnerHits ihFrom ihSize) =-    omitNulls [ "from" .= ihFrom-              , "size" .= ihSize-              ]--instance FromJSON InnerHits where-  parseJSON = withObject "InnerHits" parse-    where parse o = InnerHits-                    <$> o .:? "from"-                    <*> o .:? "size"+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Bloodhound.Internal.Query+  ( module X,+    module Database.Bloodhound.Internal.Query,+  )+where++import Bloodhound.Import+import qualified Data.Aeson.KeyMap as X+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Database.Bloodhound.Common.Script as X+import Database.Bloodhound.Internal.Newtypes+import GHC.Generics++data Query+  = TermQuery Term (Maybe Boost)+  | TermsQuery Key (NonEmpty Text)+  | QueryMatchQuery MatchQuery+  | QueryMultiMatchQuery MultiMatchQuery+  | QueryBoolQuery BoolQuery+  | QueryBoostingQuery BoostingQuery+  | QueryCommonTermsQuery CommonTermsQuery+  | ConstantScoreQuery Query Boost+  | QueryFunctionScoreQuery FunctionScoreQuery+  | QueryDisMaxQuery DisMaxQuery+  | QueryFuzzyLikeThisQuery FuzzyLikeThisQuery+  | QueryFuzzyLikeFieldQuery FuzzyLikeFieldQuery+  | QueryFuzzyQuery FuzzyQuery+  | QueryHasChildQuery HasChildQuery+  | QueryHasParentQuery HasParentQuery+  | IdsQuery [DocId]+  | QueryIndicesQuery IndicesQuery+  | MatchAllQuery (Maybe Boost)+  | QueryMoreLikeThisQuery MoreLikeThisQuery+  | QueryMoreLikeThisFieldQuery MoreLikeThisFieldQuery+  | QueryNestedQuery NestedQuery+  | QueryPrefixQuery PrefixQuery+  | QueryQueryStringQuery QueryStringQuery+  | QuerySimpleQueryStringQuery SimpleQueryStringQuery+  | QueryRangeQuery RangeQuery+  | QueryRegexpQuery RegexpQuery+  | QueryExistsQuery FieldName+  | QueryMatchNoneQuery+  | QueryWildcardQuery WildcardQuery+  deriving (Eq, Show, Generic)++instance ToJSON Query where+  toJSON (TermQuery (Term termQueryField termQueryValue) boost) =+    object+      [ "term"+          .= object [termQueryField .= object merged]+      ]+    where+      base = ["value" .= termQueryValue]+      boosted = maybe [] (return . ("boost" .=)) boost+      merged = mappend base boosted+  toJSON (TermsQuery fieldName terms) =+    object ["terms" .= object conjoined]+    where+      conjoined = [fieldName .= terms]+  toJSON (IdsQuery docIds) =+    object ["ids" .= object conjoined]+    where+      conjoined = ["values" .= fmap toJSON docIds]+  toJSON (QueryQueryStringQuery qQueryStringQuery) =+    object ["query_string" .= qQueryStringQuery]+  toJSON (QueryMatchQuery matchQuery) =+    object ["match" .= matchQuery]+  toJSON (QueryMultiMatchQuery multiMatchQuery) =+    toJSON multiMatchQuery+  toJSON (QueryBoolQuery boolQuery) =+    object ["bool" .= boolQuery]+  toJSON (QueryBoostingQuery boostingQuery) =+    object ["boosting" .= boostingQuery]+  toJSON (QueryCommonTermsQuery commonTermsQuery) =+    object ["common" .= commonTermsQuery]+  toJSON (ConstantScoreQuery query boost) =+    object+      [ "constant_score"+          .= object+            [ "filter" .= query,+              "boost" .= boost+            ]+      ]+  toJSON (QueryFunctionScoreQuery functionScoreQuery) =+    object ["function_score" .= functionScoreQuery]+  toJSON (QueryDisMaxQuery disMaxQuery) =+    object ["dis_max" .= disMaxQuery]+  toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) =+    object ["fuzzy_like_this" .= fuzzyQuery]+  toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) =+    object ["fuzzy_like_this_field" .= fuzzyFieldQuery]+  toJSON (QueryFuzzyQuery fuzzyQuery) =+    object ["fuzzy" .= fuzzyQuery]+  toJSON (QueryHasChildQuery childQuery) =+    object ["has_child" .= childQuery]+  toJSON (QueryHasParentQuery parentQuery) =+    object ["has_parent" .= parentQuery]+  toJSON (QueryIndicesQuery qIndicesQuery) =+    object ["indices" .= qIndicesQuery]+  toJSON (MatchAllQuery boost) =+    object ["match_all" .= omitNulls ["boost" .= boost]]+  toJSON (QueryMoreLikeThisQuery query) =+    object ["more_like_this" .= query]+  toJSON (QueryMoreLikeThisFieldQuery query) =+    object ["more_like_this_field" .= query]+  toJSON (QueryNestedQuery query) =+    object ["nested" .= query]+  toJSON (QueryPrefixQuery query) =+    object ["prefix" .= query]+  toJSON (QueryRangeQuery query) =+    object ["range" .= query]+  toJSON (QueryRegexpQuery query) =+    object ["regexp" .= query]+  toJSON (QuerySimpleQueryStringQuery query) =+    object ["simple_query_string" .= query]+  toJSON (QueryExistsQuery (FieldName fieldName)) =+    object+      [ "exists"+          .= object+            ["field" .= fieldName]+      ]+  toJSON QueryMatchNoneQuery =+    object ["match_none" .= object []]+  toJSON (QueryWildcardQuery query) =+    object ["wildcard" .= query]++instance FromJSON Query where+  parseJSON v = withObject "Query" parse v+    where+      parse o =+        termQuery `taggedWith` "term"+          <|> termsQuery `taggedWith` "terms"+          <|> idsQuery `taggedWith` "ids"+          <|> queryQueryStringQuery `taggedWith` "query_string"+          <|> queryMatchQuery `taggedWith` "match"+          <|> queryMultiMatchQuery+          <|> queryBoolQuery `taggedWith` "bool"+          <|> queryBoostingQuery `taggedWith` "boosting"+          <|> queryCommonTermsQuery `taggedWith` "common"+          <|> constantScoreQuery `taggedWith` "constant_score"+          <|> queryFunctionScoreQuery `taggedWith` "function_score"+          <|> queryDisMaxQuery `taggedWith` "dis_max"+          <|> queryFuzzyLikeThisQuery `taggedWith` "fuzzy_like_this"+          <|> queryFuzzyLikeFieldQuery `taggedWith` "fuzzy_like_this_field"+          <|> queryFuzzyQuery `taggedWith` "fuzzy"+          <|> queryHasChildQuery `taggedWith` "has_child"+          <|> queryHasParentQuery `taggedWith` "has_parent"+          <|> queryIndicesQuery `taggedWith` "indices"+          <|> matchAllQuery `taggedWith` "match_all"+          <|> queryMoreLikeThisQuery `taggedWith` "more_like_this"+          <|> queryMoreLikeThisFieldQuery `taggedWith` "more_like_this_field"+          <|> queryNestedQuery `taggedWith` "nested"+          <|> queryPrefixQuery `taggedWith` "prefix"+          <|> queryRangeQuery `taggedWith` "range"+          <|> queryRegexpQuery `taggedWith` "regexp"+          <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"+          <|> queryWildcardQuery `taggedWith` "wildcard"+        where+          taggedWith parser k = parser =<< o .: k+      termQuery = fieldTagged $ \(FieldName fn) o ->+        TermQuery <$> (Term (fromText fn) <$> o .: "value") <*> o .:? "boost"+      termsQuery o = case HM.toList o of+        [(fn, vs)] -> do+          vals <- parseJSON vs+          case vals of+            x : xs -> return (TermsQuery fn (x :| xs))+            _ -> fail "Expected non empty list of values"+        _ -> fail "Expected object with 1 field-named key"+      idsQuery o = IdsQuery <$> o .: "values"+      queryQueryStringQuery = pure . QueryQueryStringQuery+      queryMatchQuery = pure . QueryMatchQuery+      queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v+      queryBoolQuery = pure . QueryBoolQuery+      queryBoostingQuery = pure . QueryBoostingQuery+      queryCommonTermsQuery = pure . QueryCommonTermsQuery+      constantScoreQuery o = case X.lookup "filter" o of+        Just x ->+          ConstantScoreQuery <$> parseJSON x+            <*> o .: "boost"+        _ -> fail "Does not appear to be a ConstantScoreQuery"+      queryFunctionScoreQuery = pure . QueryFunctionScoreQuery+      queryDisMaxQuery = pure . QueryDisMaxQuery+      queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery+      queryFuzzyLikeFieldQuery = pure . QueryFuzzyLikeFieldQuery+      queryFuzzyQuery = pure . QueryFuzzyQuery+      queryHasChildQuery = pure . QueryHasChildQuery+      queryHasParentQuery = pure . QueryHasParentQuery+      queryIndicesQuery = pure . QueryIndicesQuery+      matchAllQuery o = MatchAllQuery <$> o .:? "boost"+      queryMoreLikeThisQuery = pure . QueryMoreLikeThisQuery+      queryMoreLikeThisFieldQuery = pure . QueryMoreLikeThisFieldQuery+      queryNestedQuery = pure . QueryNestedQuery+      queryPrefixQuery = pure . QueryPrefixQuery+      queryRangeQuery = pure . QueryRangeQuery+      queryRegexpQuery = pure . QueryRegexpQuery+      querySimpleQueryStringQuery = pure . QuerySimpleQueryStringQuery+      -- queryExistsQuery o = QueryExistsQuery <$> o .: "field"+      queryWildcardQuery = pure . QueryWildcardQuery++-- | As of Elastic 2.0, 'Filters' are just 'Queries' housed in a+--   Bool Query, and flagged in a different context.+newtype Filter = Filter {unFilter :: Query}+  deriving (Eq, Show)++instance ToJSON Filter where+  toJSON = toJSON . unFilter++instance FromJSON Filter where+  parseJSON v = Filter <$> parseJSON v++data RegexpQuery = RegexpQuery+  { regexpQueryField :: FieldName,+    regexpQuery :: Regexp,+    regexpQueryFlags :: RegexpFlags,+    regexpQueryBoost :: Maybe Boost+  }+  deriving (Eq, Show, Generic)++instance ToJSON RegexpQuery where+  toJSON+    ( RegexpQuery+        (FieldName rqQueryField)+        (Regexp regexpQueryQuery)+        rqQueryFlags+        rqQueryBoost+      ) =+      object [fromText rqQueryField .= omitNulls base]+      where+        base =+          [ "value" .= regexpQueryQuery,+            "flags" .= rqQueryFlags,+            "boost" .= rqQueryBoost+          ]++instance FromJSON RegexpQuery where+  parseJSON = withObject "RegexpQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        RegexpQuery fn+          <$> o .: "value"+          <*> o .: "flags"+          <*> o .:? "boost"++data WildcardQuery = WildcardQuery+  { wildcardQueryField :: FieldName,+    wildcardQuery :: Key,+    wildcardQueryBoost :: Maybe Boost+  }+  deriving (Eq, Show, Generic)++instance ToJSON WildcardQuery where+  toJSON+    ( WildcardQuery+        (FieldName wcQueryField)+        (wcQueryQuery)+        wcQueryBoost+      ) =+      object [fromText wcQueryField .= omitNulls base]+      where+        base =+          [ "value" .= wcQueryQuery,+            "boost" .= wcQueryBoost+          ]++instance FromJSON WildcardQuery where+  parseJSON = withObject "WildcardQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        WildcardQuery fn+          <$> o .: "value"+          <*> o .:? "boost"++data RangeQuery = RangeQuery+  { rangeQueryField :: FieldName,+    rangeQueryRange :: RangeValue,+    rangeQueryBoost :: Boost+  }+  deriving (Eq, Show, Generic)++instance ToJSON RangeQuery where+  toJSON (RangeQuery (FieldName fieldName) range boost) =+    object [fromText fieldName .= object conjoined]+    where+      conjoined = ("boost" .= boost) : rangeValueToPair range++instance FromJSON RangeQuery where+  parseJSON = withObject "RangeQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        RangeQuery fn+          <$> parseJSON (Object o)+          <*> o .: "boost"++mkRangeQuery :: FieldName -> RangeValue -> RangeQuery+mkRangeQuery f r = RangeQuery f r (Boost 1.0)++data SimpleQueryStringQuery = SimpleQueryStringQuery+  { simpleQueryStringQuery :: QueryString,+    simpleQueryStringField :: Maybe FieldOrFields,+    simpleQueryStringOperator :: Maybe BooleanOperator,+    simpleQueryStringAnalyzer :: Maybe Analyzer,+    simpleQueryStringFlags :: Maybe (NonEmpty SimpleQueryFlag),+    simpleQueryStringLowercaseExpanded :: Maybe LowercaseExpanded,+    simpleQueryStringLocale :: Maybe Locale+  }+  deriving (Eq, Show, Generic)++instance ToJSON SimpleQueryStringQuery where+  toJSON SimpleQueryStringQuery {..} =+    omitNulls (base ++ maybeAdd)+    where+      base = ["query" .= simpleQueryStringQuery]+      maybeAdd =+        [ "fields" .= simpleQueryStringField,+          "default_operator" .= simpleQueryStringOperator,+          "analyzer" .= simpleQueryStringAnalyzer,+          "flags" .= simpleQueryStringFlags,+          "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded,+          "locale" .= simpleQueryStringLocale+        ]++instance FromJSON SimpleQueryStringQuery where+  parseJSON = withObject "SimpleQueryStringQuery" parse+    where+      parse o =+        SimpleQueryStringQuery <$> o .: "query"+          <*> o .:? "fields"+          <*> o .:? "default_operator"+          <*> o .:? "analyzer"+          <*> (parseFlags <$> o .:? "flags")+          <*> o .:? "lowercase_expanded_terms"+          <*> o .:? "locale"+      parseFlags (Just (x : xs)) = Just (x :| xs)+      parseFlags _ = Nothing++data SimpleQueryFlag+  = SimpleQueryAll+  | SimpleQueryNone+  | SimpleQueryAnd+  | SimpleQueryOr+  | SimpleQueryPrefix+  | SimpleQueryPhrase+  | SimpleQueryPrecedence+  | SimpleQueryEscape+  | SimpleQueryWhitespace+  | SimpleQueryFuzzy+  | SimpleQueryNear+  | SimpleQuerySlop+  deriving (Eq, Show, Generic)++instance ToJSON SimpleQueryFlag where+  toJSON SimpleQueryAll = "ALL"+  toJSON SimpleQueryNone = "NONE"+  toJSON SimpleQueryAnd = "AND"+  toJSON SimpleQueryOr = "OR"+  toJSON SimpleQueryPrefix = "PREFIX"+  toJSON SimpleQueryPhrase = "PHRASE"+  toJSON SimpleQueryPrecedence = "PRECEDENCE"+  toJSON SimpleQueryEscape = "ESCAPE"+  toJSON SimpleQueryWhitespace = "WHITESPACE"+  toJSON SimpleQueryFuzzy = "FUZZY"+  toJSON SimpleQueryNear = "NEAR"+  toJSON SimpleQuerySlop = "SLOP"++instance FromJSON SimpleQueryFlag where+  parseJSON = withText "SimpleQueryFlag" parse+    where+      parse "ALL" = pure SimpleQueryAll+      parse "NONE" = pure SimpleQueryNone+      parse "AND" = pure SimpleQueryAnd+      parse "OR" = pure SimpleQueryOr+      parse "PREFIX" = pure SimpleQueryPrefix+      parse "PHRASE" = pure SimpleQueryPhrase+      parse "PRECEDENCE" = pure SimpleQueryPrecedence+      parse "ESCAPE" = pure SimpleQueryEscape+      parse "WHITESPACE" = pure SimpleQueryWhitespace+      parse "FUZZY" = pure SimpleQueryFuzzy+      parse "NEAR" = pure SimpleQueryNear+      parse "SLOP" = pure SimpleQuerySlop+      parse f = fail ("Unexpected SimpleQueryFlag: " <> show f)++-- use_dis_max and tie_breaker when fields are plural?+data QueryStringQuery = QueryStringQuery+  { queryStringQuery :: QueryString,+    queryStringDefaultField :: Maybe FieldName,+    queryStringOperator :: Maybe BooleanOperator,+    queryStringAnalyzer :: Maybe Analyzer,+    queryStringAllowLeadingWildcard :: Maybe AllowLeadingWildcard,+    queryStringLowercaseExpanded :: Maybe LowercaseExpanded,+    queryStringEnablePositionIncrements :: Maybe EnablePositionIncrements,+    queryStringFuzzyMaxExpansions :: Maybe MaxExpansions,+    queryStringFuzziness :: Maybe Fuzziness,+    queryStringFuzzyPrefixLength :: Maybe PrefixLength,+    queryStringPhraseSlop :: Maybe PhraseSlop,+    queryStringBoost :: Maybe Boost,+    queryStringAnalyzeWildcard :: Maybe AnalyzeWildcard,+    queryStringGeneratePhraseQueries :: Maybe GeneratePhraseQueries,+    queryStringMinimumShouldMatch :: Maybe MinimumMatch,+    queryStringLenient :: Maybe Lenient,+    queryStringLocale :: Maybe Locale+  }+  deriving (Eq, Show, Generic)++instance ToJSON QueryStringQuery where+  toJSON+    ( QueryStringQuery+        qsQueryString+        qsDefaultField+        qsOperator+        qsAnalyzer+        qsAllowWildcard+        qsLowercaseExpanded+        qsEnablePositionIncrements+        qsFuzzyMaxExpansions+        qsFuzziness+        qsFuzzyPrefixLength+        qsPhraseSlop+        qsBoost+        qsAnalyzeWildcard+        qsGeneratePhraseQueries+        qsMinimumShouldMatch+        qsLenient+        qsLocale+      ) =+      omitNulls base+      where+        base =+          [ "query" .= qsQueryString,+            "default_field" .= qsDefaultField,+            "default_operator" .= qsOperator,+            "analyzer" .= qsAnalyzer,+            "allow_leading_wildcard" .= qsAllowWildcard,+            "lowercase_expanded_terms" .= qsLowercaseExpanded,+            "enable_position_increments" .= qsEnablePositionIncrements,+            "fuzzy_max_expansions" .= qsFuzzyMaxExpansions,+            "fuzziness" .= qsFuzziness,+            "fuzzy_prefix_length" .= qsFuzzyPrefixLength,+            "phrase_slop" .= qsPhraseSlop,+            "boost" .= qsBoost,+            "analyze_wildcard" .= qsAnalyzeWildcard,+            "auto_generate_phrase_queries" .= qsGeneratePhraseQueries,+            "minimum_should_match" .= qsMinimumShouldMatch,+            "lenient" .= qsLenient,+            "locale" .= qsLocale+          ]++instance FromJSON QueryStringQuery where+  parseJSON = withObject "QueryStringQuery" parse+    where+      parse o =+        QueryStringQuery+          <$> o .: "query"+          <*> o .:? "default_field"+          <*> o .:? "default_operator"+          <*> o .:? "analyzer"+          <*> o .:? "allow_leading_wildcard"+          <*> o .:? "lowercase_expanded_terms"+          <*> o .:? "enable_position_increments"+          <*> o .:? "fuzzy_max_expansions"+          <*> o .:? "fuzziness"+          <*> o .:? "fuzzy_prefix_length"+          <*> o .:? "phrase_slop"+          <*> o .:? "boost"+          <*> o .:? "analyze_wildcard"+          <*> o .:? "auto_generate_phrase_queries"+          <*> o .:? "minimum_should_match"+          <*> o .:? "lenient"+          <*> o .:? "locale"++mkQueryStringQuery :: QueryString -> QueryStringQuery+mkQueryStringQuery qs =+  QueryStringQuery+    qs+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing++data FieldOrFields+  = FofField FieldName+  | FofFields (NonEmpty FieldName)+  deriving (Eq, Show, Generic)++instance ToJSON FieldOrFields where+  toJSON (FofField fieldName) =+    toJSON fieldName+  toJSON (FofFields fieldNames) =+    toJSON fieldNames++instance FromJSON FieldOrFields where+  parseJSON v =+    FofField <$> parseJSON v+      <|> FofFields <$> (parseNEJSON =<< parseJSON v)++data PrefixQuery = PrefixQuery+  { prefixQueryField :: FieldName,+    prefixQueryPrefixValue :: Text,+    prefixQueryBoost :: Maybe Boost+  }+  deriving (Eq, Show, Generic)++instance ToJSON PrefixQuery where+  toJSON (PrefixQuery (FieldName fieldName) queryValue boost) =+    object [fromText fieldName .= omitNulls base]+    where+      base =+        [ "value" .= queryValue,+          "boost" .= boost+        ]++instance FromJSON PrefixQuery where+  parseJSON = withObject "PrefixQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        PrefixQuery fn+          <$> o .: "value"+          <*> o .:? "boost"++data NestedQuery = NestedQuery+  { nestedQueryPath :: QueryPath,+    nestedQueryScoreType :: ScoreType,+    nestedQuery :: Query,+    nestedQueryInnerHits :: Maybe InnerHits+  }+  deriving (Eq, Show, Generic)++instance ToJSON NestedQuery where+  toJSON (NestedQuery nqPath nqScoreType nqQuery nqInnerHits) =+    omitNulls+      [ "path" .= nqPath,+        "score_mode" .= nqScoreType,+        "query" .= nqQuery,+        "inner_hits" .= nqInnerHits+      ]++instance FromJSON NestedQuery where+  parseJSON = withObject "NestedQuery" parse+    where+      parse o =+        NestedQuery+          <$> o .: "path"+          <*> o .: "score_mode"+          <*> o .: "query"+          <*> o .:? "inner_hits"++data MoreLikeThisFieldQuery = MoreLikeThisFieldQuery+  { moreLikeThisFieldText :: Text,+    moreLikeThisFieldFields :: FieldName,+    -- default 0.3 (30%)+    moreLikeThisFieldPercentMatch :: Maybe PercentMatch,+    moreLikeThisFieldMinimumTermFreq :: Maybe MinimumTermFrequency,+    moreLikeThisFieldMaxQueryTerms :: Maybe MaxQueryTerms,+    moreLikeThisFieldStopWords :: Maybe (NonEmpty StopWord),+    moreLikeThisFieldMinDocFrequency :: Maybe MinDocFrequency,+    moreLikeThisFieldMaxDocFrequency :: Maybe MaxDocFrequency,+    moreLikeThisFieldMinWordLength :: Maybe MinWordLength,+    moreLikeThisFieldMaxWordLength :: Maybe MaxWordLength,+    moreLikeThisFieldBoostTerms :: Maybe BoostTerms,+    moreLikeThisFieldBoost :: Maybe Boost,+    moreLikeThisFieldAnalyzer :: Maybe Analyzer+  }+  deriving (Eq, Show, Generic)++instance ToJSON MoreLikeThisFieldQuery where+  toJSON+    ( MoreLikeThisFieldQuery+        text+        (FieldName fieldName)+        percent+        mtf+        mqt+        stopwords+        mindf+        maxdf+        minwl+        maxwl+        boostTerms+        boost+        analyzer+      ) =+      object [fromText fieldName .= omitNulls base]+      where+        base =+          [ "like_text" .= text,+            "percent_terms_to_match" .= percent,+            "min_term_freq" .= mtf,+            "max_query_terms" .= mqt,+            "stop_words" .= stopwords,+            "min_doc_freq" .= mindf,+            "max_doc_freq" .= maxdf,+            "min_word_length" .= minwl,+            "max_word_length" .= maxwl,+            "boost_terms" .= boostTerms,+            "boost" .= boost,+            "analyzer" .= analyzer+          ]++instance FromJSON MoreLikeThisFieldQuery where+  parseJSON = withObject "MoreLikeThisFieldQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        MoreLikeThisFieldQuery+          <$> o .: "like_text"+          <*> pure fn+          <*> o .:? "percent_terms_to_match"+          <*> o .:? "min_term_freq"+          <*> o .:? "max_query_terms"+          -- <*> (optionalNE =<< o .:? "stop_words")+          <*> o .:? "stop_words"+          <*> o .:? "min_doc_freq"+          <*> o .:? "max_doc_freq"+          <*> o .:? "min_word_length"+          <*> o .:? "max_word_length"+          <*> o .:? "boost_terms"+          <*> o .:? "boost"+          <*> o .:? "analyzer"++-- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)++data MoreLikeThisQuery = MoreLikeThisQuery+  { moreLikeThisText :: Text,+    moreLikeThisFields :: Maybe (NonEmpty FieldName),+    -- default 0.3 (30%)+    moreLikeThisPercentMatch :: Maybe PercentMatch,+    moreLikeThisMinimumTermFreq :: Maybe MinimumTermFrequency,+    moreLikeThisMaxQueryTerms :: Maybe MaxQueryTerms,+    moreLikeThisStopWords :: Maybe (NonEmpty StopWord),+    moreLikeThisMinDocFrequency :: Maybe MinDocFrequency,+    moreLikeThisMaxDocFrequency :: Maybe MaxDocFrequency,+    moreLikeThisMinWordLength :: Maybe MinWordLength,+    moreLikeThisMaxWordLength :: Maybe MaxWordLength,+    moreLikeThisBoostTerms :: Maybe BoostTerms,+    moreLikeThisBoost :: Maybe Boost,+    moreLikeThisAnalyzer :: Maybe Analyzer+  }+  deriving (Eq, Show, Generic)++instance ToJSON MoreLikeThisQuery where+  toJSON+    ( MoreLikeThisQuery+        text+        fields+        percent+        mtf+        mqt+        stopwords+        mindf+        maxdf+        minwl+        maxwl+        boostTerms+        boost+        analyzer+      ) =+      omitNulls base+      where+        base =+          [ "like_text" .= text,+            "fields" .= fields,+            "percent_terms_to_match" .= percent,+            "min_term_freq" .= mtf,+            "max_query_terms" .= mqt,+            "stop_words" .= stopwords,+            "min_doc_freq" .= mindf,+            "max_doc_freq" .= maxdf,+            "min_word_length" .= minwl,+            "max_word_length" .= maxwl,+            "boost_terms" .= boostTerms,+            "boost" .= boost,+            "analyzer" .= analyzer+          ]++instance FromJSON MoreLikeThisQuery where+  parseJSON = withObject "MoreLikeThisQuery" parse+    where+      parse o =+        MoreLikeThisQuery+          <$> o .: "like_text"+          -- <*> (optionalNE =<< o .:? "fields")+          <*> o .:? "fields"+          <*> o .:? "percent_terms_to_match"+          <*> o .:? "min_term_freq"+          <*> o .:? "max_query_terms"+          -- <*> (optionalNE =<< o .:? "stop_words")+          <*> o .:? "stop_words"+          <*> o .:? "min_doc_freq"+          <*> o .:? "max_doc_freq"+          <*> o .:? "min_word_length"+          <*> o .:? "max_word_length"+          <*> o .:? "boost_terms"+          <*> o .:? "boost"+          <*> o .:? "analyzer"++-- optionalNE = maybe (pure Nothing) (fmap Just . parseNEJSON)++data IndicesQuery = IndicesQuery+  { indicesQueryIndices :: [IndexName],+    indicesQuery :: Query,+    -- default "all"+    indicesQueryNoMatch :: Maybe Query+  }+  deriving (Eq, Show, Generic)++instance ToJSON IndicesQuery where+  toJSON (IndicesQuery indices query noMatch) =+    omitNulls+      [ "indices" .= indices,+        "no_match_query" .= noMatch,+        "query" .= query+      ]++instance FromJSON IndicesQuery where+  parseJSON = withObject "IndicesQuery" parse+    where+      parse o =+        IndicesQuery+          <$> o .:? "indices" .!= []+          <*> o .: "query"+          <*> o .:? "no_match_query"++data HasParentQuery = HasParentQuery+  { hasParentQueryType :: RelationName,+    hasParentQuery :: Query,+    hasParentQueryScore :: Maybe AggregateParentScore,+    hasParentIgnoreUnmapped :: Maybe IgnoreUnmapped+  }+  deriving (Eq, Show, Generic)++instance ToJSON HasParentQuery where+  toJSON (HasParentQuery queryType query scoreType ignoreUnmapped) =+    omitNulls+      [ "parent_type" .= queryType,+        "score" .= scoreType,+        "query" .= query,+        "ignore_unmapped" .= ignoreUnmapped+      ]++instance FromJSON HasParentQuery where+  parseJSON = withObject "HasParentQuery" parse+    where+      parse o =+        HasParentQuery+          <$> o .: "parent_type"+          <*> o .: "query"+          <*> o .:? "score"+          <*> o .:? "ignore_unmapped"++data HasChildQuery = HasChildQuery+  { hasChildQueryType :: RelationName,+    hasChildQuery :: Query,+    hasChildQueryScoreType :: Maybe ScoreType,+    hasChildIgnoreUnmappped :: Maybe IgnoreUnmapped,+    hasChildMinChildren :: Maybe MinChildren,+    hasChildMaxChildren :: Maybe MaxChildren+  }+  deriving (Eq, Show, Generic)++instance ToJSON HasChildQuery where+  toJSON (HasChildQuery queryType query scoreType ignoreUnmapped minChildren maxChildren) =+    omitNulls+      [ "query" .= query,+        "score_mode" .= scoreType,+        "type" .= queryType,+        "min_children" .= minChildren,+        "max_children" .= maxChildren,+        "ignore_unmapped" .= ignoreUnmapped+      ]++instance FromJSON HasChildQuery where+  parseJSON = withObject "HasChildQuery" parse+    where+      parse o =+        HasChildQuery+          <$> o .: "type"+          <*> o .: "query"+          <*> o .:? "score_mode"+          <*> o .:? "ignore_unmapped"+          <*> o .:? "min_children"+          <*> o .:? "max_children"++data ScoreType+  = ScoreTypeMax+  | ScoreTypeSum+  | ScoreTypeAvg+  | ScoreTypeNone+  deriving (Eq, Show, Generic)++instance ToJSON ScoreType where+  toJSON ScoreTypeMax = "max"+  toJSON ScoreTypeAvg = "avg"+  toJSON ScoreTypeSum = "sum"+  toJSON ScoreTypeNone = "none"++instance FromJSON ScoreType where+  parseJSON = withText "ScoreType" parse+    where+      parse "max" = pure ScoreTypeMax+      parse "avg" = pure ScoreTypeAvg+      parse "sum" = pure ScoreTypeSum+      parse "none" = pure ScoreTypeNone+      parse t = fail ("Unexpected ScoreType: " <> show t)++data FuzzyQuery = FuzzyQuery+  { fuzzyQueryField :: FieldName,+    fuzzyQueryValue :: Text,+    fuzzyQueryPrefixLength :: PrefixLength,+    fuzzyQueryMaxExpansions :: MaxExpansions,+    fuzzyQueryFuzziness :: Fuzziness,+    fuzzyQueryBoost :: Maybe Boost+  }+  deriving (Eq, Show, Generic)++instance ToJSON FuzzyQuery where+  toJSON+    ( FuzzyQuery+        (FieldName fieldName)+        queryText+        prefixLength+        maxEx+        fuzziness+        boost+      ) =+      object [fromText fieldName .= omitNulls base]+      where+        base =+          [ "value" .= queryText,+            "fuzziness" .= fuzziness,+            "prefix_length" .= prefixLength,+            "boost" .= boost,+            "max_expansions" .= maxEx+          ]++instance FromJSON FuzzyQuery where+  parseJSON = withObject "FuzzyQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        FuzzyQuery fn+          <$> o .: "value"+          <*> o .: "prefix_length"+          <*> o .: "max_expansions"+          <*> o .: "fuzziness"+          <*> o .:? "boost"++data FuzzyLikeFieldQuery = FuzzyLikeFieldQuery+  { fuzzyLikeField :: FieldName,+    -- anaphora is good for the soul.+    fuzzyLikeFieldText :: Text,+    fuzzyLikeFieldMaxQueryTerms :: MaxQueryTerms,+    fuzzyLikeFieldIgnoreTermFrequency :: IgnoreTermFrequency,+    fuzzyLikeFieldFuzziness :: Fuzziness,+    fuzzyLikeFieldPrefixLength :: PrefixLength,+    fuzzyLikeFieldBoost :: Boost,+    fuzzyLikeFieldAnalyzer :: Maybe Analyzer+  }+  deriving (Eq, Show, Generic)++instance ToJSON FuzzyLikeFieldQuery where+  toJSON+    ( FuzzyLikeFieldQuery+        (FieldName fieldName)+        fieldText+        maxTerms+        ignoreFreq+        fuzziness+        prefixLength+        boost+        analyzer+      ) =+      object+        [ fromText fieldName+            .= omitNulls+              [ "like_text" .= fieldText,+                "max_query_terms" .= maxTerms,+                "ignore_tf" .= ignoreFreq,+                "fuzziness" .= fuzziness,+                "prefix_length" .= prefixLength,+                "analyzer" .= analyzer,+                "boost" .= boost+              ]+        ]++instance FromJSON FuzzyLikeFieldQuery where+  parseJSON = withObject "FuzzyLikeFieldQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        FuzzyLikeFieldQuery fn+          <$> o .: "like_text"+          <*> o .: "max_query_terms"+          <*> o .: "ignore_tf"+          <*> o .: "fuzziness"+          <*> o .: "prefix_length"+          <*> o .: "boost"+          <*> o .:? "analyzer"++data FuzzyLikeThisQuery = FuzzyLikeThisQuery+  { fuzzyLikeFields :: [FieldName],+    fuzzyLikeText :: Text,+    fuzzyLikeMaxQueryTerms :: MaxQueryTerms,+    fuzzyLikeIgnoreTermFrequency :: IgnoreTermFrequency,+    fuzzyLikeFuzziness :: Fuzziness,+    fuzzyLikePrefixLength :: PrefixLength,+    fuzzyLikeBoost :: Boost,+    fuzzyLikeAnalyzer :: Maybe Analyzer+  }+  deriving (Eq, Show, Generic)++instance ToJSON FuzzyLikeThisQuery where+  toJSON+    ( FuzzyLikeThisQuery+        fields+        text+        maxTerms+        ignoreFreq+        fuzziness+        prefixLength+        boost+        analyzer+      ) =+      omitNulls base+      where+        base =+          [ "fields" .= fields,+            "like_text" .= text,+            "max_query_terms" .= maxTerms,+            "ignore_tf" .= ignoreFreq,+            "fuzziness" .= fuzziness,+            "prefix_length" .= prefixLength,+            "analyzer" .= analyzer,+            "boost" .= boost+          ]++instance FromJSON FuzzyLikeThisQuery where+  parseJSON = withObject "FuzzyLikeThisQuery" parse+    where+      parse o =+        FuzzyLikeThisQuery+          <$> o .:? "fields" .!= []+          <*> o .: "like_text"+          <*> o .: "max_query_terms"+          <*> o .: "ignore_tf"+          <*> o .: "fuzziness"+          <*> o .: "prefix_length"+          <*> o .: "boost"+          <*> o .:? "analyzer"++data DisMaxQuery = DisMaxQuery+  { disMaxQueries :: [Query],+    -- default 0.0+    disMaxTiebreaker :: Tiebreaker,+    disMaxBoost :: Maybe Boost+  }+  deriving (Eq, Show, Generic)++instance ToJSON DisMaxQuery where+  toJSON (DisMaxQuery queries tiebreaker boost) =+    omitNulls base+    where+      base =+        [ "queries" .= queries,+          "boost" .= boost,+          "tie_breaker" .= tiebreaker+        ]++instance FromJSON DisMaxQuery where+  parseJSON = withObject "DisMaxQuery" parse+    where+      parse o =+        DisMaxQuery+          <$> o .:? "queries" .!= []+          <*> o .: "tie_breaker"+          <*> o .:? "boost"++data MatchQuery = MatchQuery+  { matchQueryField :: FieldName,+    matchQueryQueryString :: QueryString,+    matchQueryOperator :: BooleanOperator,+    matchQueryZeroTerms :: ZeroTermsQuery,+    matchQueryCutoffFrequency :: Maybe CutoffFrequency,+    matchQueryMatchType :: Maybe MatchQueryType,+    matchQueryAnalyzer :: Maybe Analyzer,+    matchQueryMaxExpansions :: Maybe MaxExpansions,+    matchQueryLenient :: Maybe Lenient,+    matchQueryBoost :: Maybe Boost,+    matchQueryMinimumShouldMatch :: Maybe Text,+    matchQueryFuzziness :: Maybe Fuzziness+  }+  deriving (Eq, Show, Generic)++instance ToJSON MatchQuery where+  toJSON+    ( MatchQuery+        (FieldName fieldName)+        (QueryString mqQueryString)+        booleanOperator+        zeroTermsQuery+        cutoffFrequency+        matchQueryType+        analyzer+        maxExpansions+        lenient+        boost+        minShouldMatch+        mqFuzziness+      ) =+      object [fromText fieldName .= omitNulls base]+      where+        base =+          [ "query" .= mqQueryString,+            "operator" .= booleanOperator,+            "zero_terms_query" .= zeroTermsQuery,+            "cutoff_frequency" .= cutoffFrequency,+            "type" .= matchQueryType,+            "analyzer" .= analyzer,+            "max_expansions" .= maxExpansions,+            "lenient" .= lenient,+            "boost" .= boost,+            "minimum_should_match" .= minShouldMatch,+            "fuzziness" .= mqFuzziness+          ]++instance FromJSON MatchQuery where+  parseJSON = withObject "MatchQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        MatchQuery fn+          <$> o .: "query"+          <*> o .: "operator"+          <*> o .: "zero_terms_query"+          <*> o .:? "cutoff_frequency"+          <*> o .:? "type"+          <*> o .:? "analyzer"+          <*> o .:? "max_expansions"+          <*> o .:? "lenient"+          <*> o .:? "boost"+          <*> o .:? "minimum_should_match"+          <*> o .:? "fuzziness"++-- | 'mkMatchQuery' is a convenience function that defaults the less common parameters,+--    enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery'+mkMatchQuery :: FieldName -> QueryString -> MatchQuery+mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++data MatchQueryType+  = MatchPhrase+  | MatchPhrasePrefix+  deriving (Eq, Show, Generic)++instance ToJSON MatchQueryType where+  toJSON MatchPhrase = "phrase"+  toJSON MatchPhrasePrefix = "phrase_prefix"++instance FromJSON MatchQueryType where+  parseJSON = withText "MatchQueryType" parse+    where+      parse "phrase" = pure MatchPhrase+      parse "phrase_prefix" = pure MatchPhrasePrefix+      parse t = fail ("Unexpected MatchQueryType: " <> show t)++data MultiMatchQuery = MultiMatchQuery+  { multiMatchQueryFields :: [FieldName],+    multiMatchQueryString :: QueryString,+    multiMatchQueryOperator :: BooleanOperator,+    multiMatchQueryZeroTerms :: ZeroTermsQuery,+    multiMatchQueryTiebreaker :: Maybe Tiebreaker,+    multiMatchQueryType :: Maybe MultiMatchQueryType,+    multiMatchQueryCutoffFrequency :: Maybe CutoffFrequency,+    multiMatchQueryAnalyzer :: Maybe Analyzer,+    multiMatchQueryMaxExpansions :: Maybe MaxExpansions,+    multiMatchQueryLenient :: Maybe Lenient+  }+  deriving (Eq, Show, Generic)++instance ToJSON MultiMatchQuery where+  toJSON+    ( MultiMatchQuery+        fields+        (QueryString query)+        boolOp+        ztQ+        tb+        mmqt+        cf+        analyzer+        maxEx+        lenient+      ) =+      object ["multi_match" .= omitNulls base]+      where+        base =+          [ "fields" .= fmap toJSON fields,+            "query" .= query,+            "operator" .= boolOp,+            "zero_terms_query" .= ztQ,+            "tie_breaker" .= tb,+            "type" .= mmqt,+            "cutoff_frequency" .= cf,+            "analyzer" .= analyzer,+            "max_expansions" .= maxEx,+            "lenient" .= lenient+          ]++instance FromJSON MultiMatchQuery where+  parseJSON = withObject "MultiMatchQuery" parse+    where+      parse raw = do+        o <- raw .: "multi_match"+        MultiMatchQuery+          <$> o .:? "fields" .!= []+          <*> o .: "query"+          <*> o .: "operator"+          <*> o .: "zero_terms_query"+          <*> o .:? "tie_breaker"+          <*> o .:? "type"+          <*> o .:? "cutoff_frequency"+          <*> o .:? "analyzer"+          <*> o .:? "max_expansions"+          <*> o .:? "lenient"++-- | 'mkMultiMatchQuery' is a convenience function that defaults the less common parameters,+--    enabling you to provide only the list of 'FieldName's and 'QueryString' to+--    make a 'MultiMatchQuery'.+mkMultiMatchQuery :: [FieldName] -> QueryString -> MultiMatchQuery+mkMultiMatchQuery matchFields query =+  MultiMatchQuery+    matchFields+    query+    Or+    ZeroTermsNone+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing++data MultiMatchQueryType+  = MultiMatchBestFields+  | MultiMatchMostFields+  | MultiMatchCrossFields+  | MultiMatchPhrase+  | MultiMatchPhrasePrefix+  deriving (Eq, Show, Generic)++instance ToJSON MultiMatchQueryType where+  toJSON MultiMatchBestFields = "best_fields"+  toJSON MultiMatchMostFields = "most_fields"+  toJSON MultiMatchCrossFields = "cross_fields"+  toJSON MultiMatchPhrase = "phrase"+  toJSON MultiMatchPhrasePrefix = "phrase_prefix"++instance FromJSON MultiMatchQueryType where+  parseJSON = withText "MultiMatchPhrasePrefix" parse+    where+      parse "best_fields" = pure MultiMatchBestFields+      parse "most_fields" = pure MultiMatchMostFields+      parse "cross_fields" = pure MultiMatchCrossFields+      parse "phrase" = pure MultiMatchPhrase+      parse "phrase_prefix" = pure MultiMatchPhrasePrefix+      parse t = fail ("Unexpected MultiMatchPhrasePrefix: " <> show t)++data BoolQuery = BoolQuery+  { boolQueryMustMatch :: [Query],+    boolQueryFilter :: [Filter],+    boolQueryMustNotMatch :: [Query],+    boolQueryShouldMatch :: [Query],+    boolQueryMinimumShouldMatch :: Maybe MinimumMatch,+    boolQueryBoost :: Maybe Boost,+    boolQueryDisableCoord :: Maybe DisableCoord+  }+  deriving (Eq, Show, Generic)++instance ToJSON BoolQuery where+  toJSON (BoolQuery mustM filterM' notM shouldM bqMin boost disableCoord) =+    omitNulls base+    where+      base =+        [ "must" .= mustM,+          "filter" .= filterM',+          "must_not" .= notM,+          "should" .= shouldM,+          "minimum_should_match" .= bqMin,+          "boost" .= boost,+          "disable_coord" .= disableCoord+        ]++instance FromJSON BoolQuery where+  parseJSON = withObject "BoolQuery" parse+    where+      parse o =+        BoolQuery+          <$> o .:? "must" .!= []+          <*> o .:? "filter" .!= []+          <*> o .:? "must_not" .!= []+          <*> o .:? "should" .!= []+          <*> o .:? "minimum_should_match"+          <*> o .:? "boost"+          <*> o .:? "disable_coord"++mkBoolQuery :: [Query] -> [Filter] -> [Query] -> [Query] -> BoolQuery+mkBoolQuery must filt mustNot should =+  BoolQuery must filt mustNot should Nothing Nothing Nothing++data BoostingQuery = BoostingQuery+  { positiveQuery :: Query,+    negativeQuery :: Query,+    negativeBoost :: Boost+  }+  deriving (Eq, Show, Generic)++instance ToJSON BoostingQuery where+  toJSON (BoostingQuery bqPositiveQuery bqNegativeQuery bqNegativeBoost) =+    object+      [ "positive" .= bqPositiveQuery,+        "negative" .= bqNegativeQuery,+        "negative_boost" .= bqNegativeBoost+      ]++instance FromJSON BoostingQuery where+  parseJSON = withObject "BoostingQuery" parse+    where+      parse o =+        BoostingQuery+          <$> o .: "positive"+          <*> o .: "negative"+          <*> o .: "negative_boost"++data CommonTermsQuery = CommonTermsQuery+  { commonField :: FieldName,+    commonQuery :: QueryString,+    commonCutoffFrequency :: CutoffFrequency,+    commonLowFreqOperator :: BooleanOperator,+    commonHighFreqOperator :: BooleanOperator,+    commonMinimumShouldMatch :: Maybe CommonMinimumMatch,+    commonBoost :: Maybe Boost,+    commonAnalyzer :: Maybe Analyzer,+    commonDisableCoord :: Maybe DisableCoord+  }+  deriving (Eq, Show, Generic)++instance ToJSON CommonTermsQuery where+  toJSON+    ( CommonTermsQuery+        (FieldName fieldName)+        (QueryString query)+        cf+        lfo+        hfo+        msm+        boost+        analyzer+        disableCoord+      ) =+      object [fromText fieldName .= omitNulls base]+      where+        base =+          [ "query" .= query,+            "cutoff_frequency" .= cf,+            "low_freq_operator" .= lfo,+            "minimum_should_match" .= msm,+            "boost" .= boost,+            "analyzer" .= analyzer,+            "disable_coord" .= disableCoord,+            "high_freq_operator" .= hfo+          ]++instance FromJSON CommonTermsQuery where+  parseJSON = withObject "CommonTermsQuery" parse+    where+      parse = fieldTagged $ \fn o ->+        CommonTermsQuery fn+          <$> o .: "query"+          <*> o .: "cutoff_frequency"+          <*> o .: "low_freq_operator"+          <*> o .: "high_freq_operator"+          <*> o .:? "minimum_should_match"+          <*> o .:? "boost"+          <*> o .:? "analyzer"+          <*> o .:? "disable_coord"++data CommonMinimumMatch+  = CommonMinimumMatchHighLow MinimumMatchHighLow+  | CommonMinimumMatch MinimumMatch+  deriving (Eq, Show, Generic)++instance ToJSON CommonMinimumMatch where+  toJSON (CommonMinimumMatch mm) = toJSON mm+  toJSON (CommonMinimumMatchHighLow (MinimumMatchHighLow lowF highF)) =+    object+      [ "low_freq" .= lowF,+        "high_freq" .= highF+      ]++instance FromJSON CommonMinimumMatch where+  parseJSON v =+    parseMinimum v+      <|> parseMinimumHighLow v+    where+      parseMinimum = fmap CommonMinimumMatch . parseJSON+      parseMinimumHighLow =+        fmap CommonMinimumMatchHighLow+          . withObject+            "CommonMinimumMatchHighLow"+            ( \o ->+                MinimumMatchHighLow+                  <$> o .: "low_freq"+                  <*> o .: "high_freq"+            )++data MinimumMatchHighLow = MinimumMatchHighLow+  { lowFreq :: MinimumMatch,+    highFreq :: MinimumMatch+  }+  deriving (Eq, Show, Generic)++data ZeroTermsQuery+  = ZeroTermsNone+  | ZeroTermsAll+  deriving (Eq, Show, Generic)++instance ToJSON ZeroTermsQuery where+  toJSON ZeroTermsNone = String "none"+  toJSON ZeroTermsAll = String "all"++instance FromJSON ZeroTermsQuery where+  parseJSON = withText "ZeroTermsQuery" parse+    where+      parse "none" = pure ZeroTermsNone+      parse "all" = pure ZeroTermsAll+      parse q = fail ("Unexpected ZeroTermsQuery: " <> show q)++data RangeExecution+  = RangeExecutionIndex+  | RangeExecutionFielddata+  deriving (Eq, Show, Generic)++-- index for smaller ranges, fielddata for longer ranges+instance ToJSON RangeExecution where+  toJSON RangeExecutionIndex = "index"+  toJSON RangeExecutionFielddata = "fielddata"++instance FromJSON RangeExecution where+  parseJSON = withText "RangeExecution" parse+    where+      parse "index" = pure RangeExecutionIndex+      parse "fielddata" = pure RangeExecutionFielddata+      parse t = error ("Unrecognized RangeExecution " <> show t)++newtype Regexp = Regexp Text deriving (Eq, Show, Generic, FromJSON)++data RegexpFlags+  = AllRegexpFlags+  | NoRegexpFlags+  | SomeRegexpFlags (NonEmpty RegexpFlag)+  deriving (Eq, Show, Generic)++instance ToJSON RegexpFlags where+  toJSON AllRegexpFlags = String "ALL"+  toJSON NoRegexpFlags = String "NONE"+  toJSON (SomeRegexpFlags (h :| fs)) = String $ T.intercalate "|" flagStrs+    where+      flagStrs = map flagStr . nub $ h : fs+      flagStr AnyString = "ANYSTRING"+      flagStr Automaton = "AUTOMATON"+      flagStr Complement = "COMPLEMENT"+      flagStr Empty = "EMPTY"+      flagStr Intersection = "INTERSECTION"+      flagStr Interval = "INTERVAL"++instance FromJSON RegexpFlags where+  parseJSON = withText "RegexpFlags" parse+    where+      parse "ALL" = pure AllRegexpFlags+      parse "NONE" = pure NoRegexpFlags+      parse t = SomeRegexpFlags <$> parseNEJSON (String <$> T.splitOn "|" t)++data RegexpFlag+  = AnyString+  | Automaton+  | Complement+  | Empty+  | Intersection+  | Interval+  deriving (Eq, Show, Generic)++instance FromJSON RegexpFlag where+  parseJSON = withText "RegexpFlag" parse+    where+      parse "ANYSTRING" = pure AnyString+      parse "AUTOMATON" = pure Automaton+      parse "COMPLEMENT" = pure Complement+      parse "EMPTY" = pure Empty+      parse "INTERSECTION" = pure Intersection+      parse "INTERVAL" = pure Interval+      parse f = fail ("Unknown RegexpFlag: " <> show f)++newtype LessThan = LessThan Double deriving (Eq, Show, Generic)++newtype LessThanEq = LessThanEq Double deriving (Eq, Show, Generic)++newtype GreaterThan = GreaterThan Double deriving (Eq, Show, Generic)++newtype GreaterThanEq = GreaterThanEq Double deriving (Eq, Show, Generic)++newtype LessThanD = LessThanD UTCTime deriving (Eq, Show, Generic)++newtype LessThanEqD = LessThanEqD UTCTime deriving (Eq, Show, Generic)++newtype GreaterThanD = GreaterThanD UTCTime deriving (Eq, Show, Generic)++newtype GreaterThanEqD = GreaterThanEqD UTCTime deriving (Eq, Show, Generic)++data RangeValue+  = RangeDateLte LessThanEqD+  | RangeDateLt LessThanD+  | RangeDateGte GreaterThanEqD+  | RangeDateGt GreaterThanD+  | RangeDateGtLt GreaterThanD LessThanD+  | RangeDateGteLte GreaterThanEqD LessThanEqD+  | RangeDateGteLt GreaterThanEqD LessThanD+  | RangeDateGtLte GreaterThanD LessThanEqD+  | RangeDoubleLte LessThanEq+  | RangeDoubleLt LessThan+  | RangeDoubleGte GreaterThanEq+  | RangeDoubleGt GreaterThan+  | RangeDoubleGtLt GreaterThan LessThan+  | RangeDoubleGteLte GreaterThanEq LessThanEq+  | RangeDoubleGteLt GreaterThanEq LessThan+  | RangeDoubleGtLte GreaterThan LessThanEq+  deriving (Eq, Show, Generic)++parseRangeValue ::+  ( FromJSON t4,+    FromJSON t3,+    FromJSON t2,+    FromJSON t1+  ) =>+  (t3 -> t5) ->+  (t1 -> t6) ->+  (t4 -> t7) ->+  (t2 -> t8) ->+  (t5 -> t6 -> b) ->+  (t7 -> t6 -> b) ->+  (t5 -> t8 -> b) ->+  (t7 -> t8 -> b) ->+  (t5 -> b) ->+  (t6 -> b) ->+  (t7 -> b) ->+  (t8 -> b) ->+  Parser b ->+  Object ->+  Parser b+parseRangeValue+  mkGt+  mkLt+  mkGte+  mkLte+  fGtLt+  fGteLt+  fGtLte+  fGteLte+  fGt+  fLt+  fGte+  fLte+  nada+  o = do+    lt <- o .:? "lt"+    lte <- o .:? "lte"+    gt <- o .:? "gt"+    gte <- o .:? "gte"+    case (lt, lte, gt, gte) of+      (Just a, _, Just b, _) ->+        return (fGtLt (mkGt b) (mkLt a))+      (Just a, _, _, Just b) ->+        return (fGteLt (mkGte b) (mkLt a))+      (_, Just a, Just b, _) ->+        return (fGtLte (mkGt b) (mkLte a))+      (_, Just a, _, Just b) ->+        return (fGteLte (mkGte b) (mkLte a))+      (_, _, Just a, _) ->+        return (fGt (mkGt a))+      (Just a, _, _, _) ->+        return (fLt (mkLt a))+      (_, _, _, Just a) ->+        return (fGte (mkGte a))+      (_, Just a, _, _) ->+        return (fLte (mkLte a))+      (Nothing, Nothing, Nothing, Nothing) ->+        nada++instance FromJSON RangeValue where+  parseJSON = withObject "RangeValue" parse+    where+      parse o =+        parseDate o+          <|> parseDouble o+      parseDate o =+        parseRangeValue+          GreaterThanD+          LessThanD+          GreaterThanEqD+          LessThanEqD+          RangeDateGtLt+          RangeDateGteLt+          RangeDateGtLte+          RangeDateGteLte+          RangeDateGt+          RangeDateLt+          RangeDateGte+          RangeDateLte+          mzero+          o+      parseDouble o =+        parseRangeValue+          GreaterThan+          LessThan+          GreaterThanEq+          LessThanEq+          RangeDoubleGtLt+          RangeDoubleGteLt+          RangeDoubleGtLte+          RangeDoubleGteLte+          RangeDoubleGt+          RangeDoubleLt+          RangeDoubleGte+          RangeDoubleLte+          mzero+          o++rangeValueToPair :: RangeValue -> [Pair]+rangeValueToPair rv = case rv of+  RangeDateLte (LessThanEqD t) -> ["lte" .= t]+  RangeDateGte (GreaterThanEqD t) -> ["gte" .= t]+  RangeDateLt (LessThanD t) -> ["lt" .= t]+  RangeDateGt (GreaterThanD t) -> ["gt" .= t]+  RangeDateGteLte (GreaterThanEqD l) (LessThanEqD g) -> ["gte" .= l, "lte" .= g]+  RangeDateGtLte (GreaterThanD l) (LessThanEqD g) -> ["gt" .= l, "lte" .= g]+  RangeDateGteLt (GreaterThanEqD l) (LessThanD g) -> ["gte" .= l, "lt" .= g]+  RangeDateGtLt (GreaterThanD l) (LessThanD g) -> ["gt" .= l, "lt" .= g]+  RangeDoubleLte (LessThanEq t) -> ["lte" .= t]+  RangeDoubleGte (GreaterThanEq t) -> ["gte" .= t]+  RangeDoubleLt (LessThan t) -> ["lt" .= t]+  RangeDoubleGt (GreaterThan t) -> ["gt" .= t]+  RangeDoubleGteLte (GreaterThanEq l) (LessThanEq g) -> ["gte" .= l, "lte" .= g]+  RangeDoubleGtLte (GreaterThan l) (LessThanEq g) -> ["gt" .= l, "lte" .= g]+  RangeDoubleGteLt (GreaterThanEq l) (LessThan g) -> ["gte" .= l, "lt" .= g]+  RangeDoubleGtLt (GreaterThan l) (LessThan g) -> ["gt" .= l, "lt" .= g]++data Term = Term+  { termField :: Key,+    termValue :: Text+  }+  deriving (Eq, Show, Generic)++instance ToJSON Term where+  toJSON (Term field value) =+    object+      [ "term"+          .= object+            [field .= value]+      ]++instance FromJSON Term where+  parseJSON = withObject "Term" parse+    where+      parse o = do+        termObj <- o .: "term"+        case HM.toList termObj of+          [(fn, v)] -> Term fn <$> parseJSON v+          _ -> fail "Expected object with 1 field-named key"++data BoolMatch+  = MustMatch Term Cache+  | MustNotMatch Term Cache+  | ShouldMatch [Term] Cache+  deriving (Eq, Show, Generic)++instance ToJSON BoolMatch where+  toJSON (MustMatch term cache) =+    object+      [ "must" .= term,+        "_cache" .= cache+      ]+  toJSON (MustNotMatch term cache) =+    object+      [ "must_not" .= term,+        "_cache" .= cache+      ]+  toJSON (ShouldMatch terms cache) =+    object+      [ "should" .= fmap toJSON terms,+        "_cache" .= cache+      ]++instance FromJSON BoolMatch where+  parseJSON = withObject "BoolMatch" parse+    where+      parse o =+        mustMatch `taggedWith` "must"+          <|> mustNotMatch `taggedWith` "must_not"+          <|> shouldMatch `taggedWith` "should"+        where+          taggedWith parser k = parser =<< o .: k+          mustMatch t = MustMatch t <$> o .:? "_cache" .!= defaultCache+          mustNotMatch t = MustNotMatch t <$> o .:? "_cache" .!= defaultCache+          shouldMatch t = ShouldMatch t <$> o .:? "_cache" .!= defaultCache++-- "memory" or "indexed"+data GeoFilterType+  = GeoFilterMemory+  | GeoFilterIndexed+  deriving (Eq, Show, Generic)++instance ToJSON GeoFilterType where+  toJSON GeoFilterMemory = String "memory"+  toJSON GeoFilterIndexed = String "indexed"++instance FromJSON GeoFilterType where+  parseJSON = withText "GeoFilterType" parse+    where+      parse "memory" = pure GeoFilterMemory+      parse "indexed" = pure GeoFilterIndexed+      parse t = fail ("Unrecognized GeoFilterType: " <> show t)++data LatLon = LatLon+  { lat :: Double,+    lon :: Double+  }+  deriving (Eq, Show, Generic)++instance ToJSON LatLon where+  toJSON (LatLon lLat lLon) =+    object+      [ "lat" .= lLat,+        "lon" .= lLon+      ]++instance FromJSON LatLon where+  parseJSON = withObject "LatLon" parse+    where+      parse o =+        LatLon <$> o .: "lat"+          <*> o .: "lon"++data GeoBoundingBox = GeoBoundingBox+  { topLeft :: LatLon,+    bottomRight :: LatLon+  }+  deriving (Eq, Show, Generic)++instance ToJSON GeoBoundingBox where+  toJSON (GeoBoundingBox gbbTopLeft gbbBottomRight) =+    object+      [ "top_left" .= gbbTopLeft,+        "bottom_right" .= gbbBottomRight+      ]++instance FromJSON GeoBoundingBox where+  parseJSON = withObject "GeoBoundingBox" parse+    where+      parse o =+        GeoBoundingBox+          <$> o .: "top_left"+          <*> o .: "bottom_right"++data GeoBoundingBoxConstraint = GeoBoundingBoxConstraint+  { geoBBField :: FieldName,+    constraintBox :: GeoBoundingBox,+    bbConstraintcache :: Cache,+    geoType :: GeoFilterType+  }+  deriving (Eq, Show, Generic)++instance ToJSON GeoBoundingBoxConstraint where+  toJSON+    ( GeoBoundingBoxConstraint+        (FieldName gbbcGeoBBField)+        gbbcConstraintBox+        cache+        type'+      ) =+      object+        [ fromText gbbcGeoBBField .= gbbcConstraintBox,+          "_cache" .= cache,+          "type" .= type'+        ]++instance FromJSON GeoBoundingBoxConstraint where+  parseJSON = withObject "GeoBoundingBoxConstraint" parse+    where+      parse o = case X.toList (deleteSeveral ["type", "_cache"] o) of+        [(fn, v)] ->+          GeoBoundingBoxConstraint (FieldName $ toText fn)+            <$> parseJSON v+            <*> o .:? "_cache" .!= defaultCache+            <*> o .: "type"+        _ -> fail "Could not find field name for GeoBoundingBoxConstraint"++data GeoPoint = GeoPoint+  { geoField :: FieldName,+    latLon :: LatLon+  }+  deriving (Eq, Show, Generic)++instance ToJSON GeoPoint where+  toJSON (GeoPoint (FieldName geoPointField) geoPointLatLon) =+    object [fromText geoPointField .= geoPointLatLon]++data DistanceUnit+  = Miles+  | Yards+  | Feet+  | Inches+  | Kilometers+  | Meters+  | Centimeters+  | Millimeters+  | NauticalMiles+  deriving (Eq, Show, Generic)++instance ToJSON DistanceUnit where+  toJSON Miles = String "mi"+  toJSON Yards = String "yd"+  toJSON Feet = String "ft"+  toJSON Inches = String "in"+  toJSON Kilometers = String "km"+  toJSON Meters = String "m"+  toJSON Centimeters = String "cm"+  toJSON Millimeters = String "mm"+  toJSON NauticalMiles = String "nmi"++instance FromJSON DistanceUnit where+  parseJSON = withText "DistanceUnit" parse+    where+      parse "mi" = pure Miles+      parse "yd" = pure Yards+      parse "ft" = pure Feet+      parse "in" = pure Inches+      parse "km" = pure Kilometers+      parse "m" = pure Meters+      parse "cm" = pure Centimeters+      parse "mm" = pure Millimeters+      parse "nmi" = pure NauticalMiles+      parse u = fail ("Unrecognized DistanceUnit: " <> show u)++data DistanceType+  = Arc+  | SloppyArc -- doesn't exist <1.0+  | Plane+  deriving (Eq, Show, Generic)++instance ToJSON DistanceType where+  toJSON Arc = String "arc"+  toJSON SloppyArc = String "sloppy_arc"+  toJSON Plane = String "plane"++instance FromJSON DistanceType where+  parseJSON = withText "DistanceType" parse+    where+      parse "arc" = pure Arc+      parse "sloppy_arc" = pure SloppyArc+      parse "plane" = pure Plane+      parse t = fail ("Unrecognized DistanceType: " <> show t)++data OptimizeBbox+  = OptimizeGeoFilterType GeoFilterType+  | NoOptimizeBbox+  deriving (Eq, Show, Generic)++instance ToJSON OptimizeBbox where+  toJSON NoOptimizeBbox = String "none"+  toJSON (OptimizeGeoFilterType gft) = toJSON gft++instance FromJSON OptimizeBbox where+  parseJSON v =+    withText "NoOptimizeBbox" parseNoOptimize v+      <|> parseOptimize v+    where+      parseNoOptimize "none" = pure NoOptimizeBbox+      parseNoOptimize _ = mzero+      parseOptimize = fmap OptimizeGeoFilterType . parseJSON++data Distance = Distance+  { coefficient :: Double,+    unit :: DistanceUnit+  }+  deriving (Eq, Show, Generic)++instance ToJSON Distance where+  toJSON (Distance dCoefficient dUnit) =+    String boltedTogether+    where+      coefText = showText dCoefficient+      (String unitText) = toJSON dUnit+      boltedTogether = mappend coefText unitText++instance FromJSON Distance where+  parseJSON = withText "Distance" parse+    where+      parse t =+        Distance <$> parseCoeff nT+          <*> parseJSON (String unitT)+        where+          (nT, unitT) = T.span validForNumber t+          -- may be a better way to do this+          validForNumber '-' = True+          validForNumber '.' = True+          validForNumber 'e' = True+          validForNumber c = isNumber c+          parseCoeff "" = fail "Empty string cannot be parsed as number"+          parseCoeff s = return (read (T.unpack s))++data DistanceRange = DistanceRange+  { distanceFrom :: Distance,+    distanceTo :: Distance+  }+  deriving (Eq, Show, Generic)++type TemplateQueryValue = Text++newtype TemplateQueryKeyValuePairs+  = TemplateQueryKeyValuePairs (X.KeyMap TemplateQueryValue)+  deriving (Eq, Show)++instance ToJSON TemplateQueryKeyValuePairs where+  toJSON (TemplateQueryKeyValuePairs x) = Object $ String <$> x++instance FromJSON TemplateQueryKeyValuePairs where+  parseJSON (Object o) =+    pure . TemplateQueryKeyValuePairs $ X.mapMaybe getValue o+    where+      getValue (String x) = Just x+      getValue _ = Nothing+  parseJSON _ =+    fail "error parsing TemplateQueryKeyValuePairs"++-- | 'BooleanOperator' is the usual And/Or operators with an ES compatible+--    JSON encoding baked in. Used all over the place.+data BooleanOperator = And | Or deriving (Eq, Show, Generic)++instance ToJSON BooleanOperator where+  toJSON And = String "and"+  toJSON Or = String "or"++instance FromJSON BooleanOperator where+  parseJSON = withText "BooleanOperator" parse+    where+      parse "and" = pure And+      parse "or" = pure Or+      parse o = fail ("Unexpected BooleanOperator: " <> show o)++-- | 'Cache' is for telling ES whether it should cache a 'Filter' not.+--    'Query's cannot be cached.+type Cache = Bool -- caching on/off++defaultCache :: Cache+defaultCache = False++data FunctionScoreQuery = FunctionScoreQuery+  { functionScoreQuery :: Maybe Query,+    functionScoreBoost :: Maybe Boost,+    functionScoreFunctions :: FunctionScoreFunctions,+    functionScoreMaxBoost :: Maybe Boost,+    functionScoreBoostMode :: Maybe BoostMode,+    functionScoreMinScore :: Score,+    functionScoreScoreMode :: Maybe ScoreMode+  }+  deriving (Eq, Show, Generic)++instance ToJSON FunctionScoreQuery where+  toJSON (FunctionScoreQuery query boost fns maxBoost boostMode minScore scoreMode) =+    omitNulls base+    where+      base =+        functionScoreFunctionsPair fns :+        [ "query" .= query,+          "boost" .= boost,+          "max_boost" .= maxBoost,+          "boost_mode" .= boostMode,+          "min_score" .= minScore,+          "score_mode" .= scoreMode+        ]++instance FromJSON FunctionScoreQuery where+  parseJSON = withObject "FunctionScoreQuery" parse+    where+      parse o =+        FunctionScoreQuery+          <$> o .:? "query"+          <*> o .:? "boost"+          <*> ( singleFunction o+                  <|> multipleFunctions `taggedWith` "functions"+              )+          <*> o .:? "max_boost"+          <*> o .:? "boost_mode"+          <*> o .:? "min_score"+          <*> o .:? "score_mode"+        where+          taggedWith parser k = parser =<< o .: k+      singleFunction = fmap FunctionScoreSingle . parseFunctionScoreFunction+      multipleFunctions = pure . FunctionScoreMultiple++data FunctionScoreFunctions+  = FunctionScoreSingle FunctionScoreFunction+  | FunctionScoreMultiple (NonEmpty ComponentFunctionScoreFunction)+  deriving (Eq, Show, Generic)++data ComponentFunctionScoreFunction = ComponentFunctionScoreFunction+  { componentScoreFunctionFilter :: Maybe Filter,+    componentScoreFunction :: FunctionScoreFunction,+    componentScoreFunctionWeight :: Maybe Weight+  }+  deriving (Eq, Show, Generic)++instance ToJSON ComponentFunctionScoreFunction where+  toJSON (ComponentFunctionScoreFunction filter' fn weight) =+    omitNulls base+    where+      base =+        functionScoreFunctionPair fn :+        [ "filter" .= filter',+          "weight" .= weight+        ]++instance FromJSON ComponentFunctionScoreFunction where+  parseJSON = withObject "ComponentFunctionScoreFunction" parse+    where+      parse o =+        ComponentFunctionScoreFunction+          <$> o .:? "filter"+          <*> parseFunctionScoreFunction o+          <*> o .:? "weight"++functionScoreFunctionsPair :: FunctionScoreFunctions -> (Key, Value)+functionScoreFunctionsPair (FunctionScoreSingle fn) =+  functionScoreFunctionPair fn+functionScoreFunctionsPair (FunctionScoreMultiple componentFns) =+  ("functions", toJSON componentFns)++fieldTagged :: (Monad m, MonadFail m) => (FieldName -> Object -> m a) -> Object -> m a+fieldTagged f o = case X.toList o of+  [(k, Object o')] -> f (FieldName $ toText k) o'+  _ -> fail "Expected object with 1 field-named key"++-- | Fuzziness value as a number or 'AUTO'.+-- See:+-- https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#fuzziness+data Fuzziness = Fuzziness Double | FuzzinessAuto+  deriving (Eq, Show, Generic)++instance ToJSON Fuzziness where+  toJSON (Fuzziness n) = toJSON n+  toJSON FuzzinessAuto = String "AUTO"++instance FromJSON Fuzziness where+  parseJSON (String "AUTO") = return FuzzinessAuto+  parseJSON v = Fuzziness <$> parseJSON v++data InnerHits = InnerHits+  { innerHitsFrom :: Maybe Integer,+    innerHitsSize :: Maybe Integer+  }+  deriving (Eq, Show, Generic)++instance ToJSON InnerHits where+  toJSON (InnerHits ihFrom ihSize) =+    omitNulls+      [ "from" .= ihFrom,+        "size" .= ihSize+      ]++instance FromJSON InnerHits where+  parseJSON = withObject "InnerHits" parse+    where+      parse o =+        InnerHits+          <$> o .:? "from"+          <*> o .:? "size"
src/Database/Bloodhound/Internal/Sort.hs view
@@ -1,22 +1,22 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Database.Bloodhound.Internal.Sort where -import           Bloodhound.Import--import           Database.Bloodhound.Internal.Newtypes-import           Database.Bloodhound.Internal.Query--{-| 'SortMode' prescribes how to handle sorting array/multi-valued fields.+import Bloodhound.Import+import Database.Bloodhound.Internal.Newtypes+import Database.Bloodhound.Internal.Query -http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option--}-data SortMode = SortMin-              | SortMax-              | SortSum-              | SortAvg deriving (Eq, Show)+-- | 'SortMode' prescribes how to handle sorting array/multi-valued fields.+--+-- http://www.elastic.co/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option+data SortMode+  = SortMin+  | SortMax+  | SortSum+  | SortAvg+  deriving (Eq, Show)  instance ToJSON SortMode where   toJSON SortMin = String "min"@@ -24,84 +24,96 @@   toJSON SortSum = String "sum"   toJSON SortAvg = String "avg" -{-| 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so-    that you can concisely describe the usual kind of 'SortSpec's you want.--}+-- | 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so+--    that you can concisely describe the usual kind of 'SortSpec's you want. mkSort :: FieldName -> SortOrder -> DefaultSort mkSort fieldName sOrder = DefaultSort fieldName sOrder Nothing Nothing Nothing Nothing -{-| 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order-    dependent with later sorts acting as tie-breakers for earlier sorts.--}+-- | 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order+--    dependent with later sorts acting as tie-breakers for earlier sorts. type Sort = [SortSpec] -{-| The two main kinds of 'SortSpec' are 'DefaultSortSpec' and-    'GeoDistanceSortSpec'. The latter takes a 'SortOrder', 'GeoPoint', and-    'DistanceUnit' to express "nearness" to a single geographical point as a-    sort specification.--<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>--}-data SortSpec =-    DefaultSortSpec DefaultSort+-- | The two main kinds of 'SortSpec' are 'DefaultSortSpec' and+--    'GeoDistanceSortSpec'. The latter takes a 'SortOrder', 'GeoPoint', and+--    'DistanceUnit' to express "nearness" to a single geographical point as a+--    sort specification.+--+-- <http://www.elastic.co/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>+data SortSpec+  = DefaultSortSpec DefaultSort   | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit   deriving (Eq, Show)  instance ToJSON SortSpec where-  toJSON (DefaultSortSpec-          (DefaultSort (FieldName dsSortFieldName) dsSortOrder dsIgnoreUnmapped-           dsSortMode dsMissingSort dsNestedFilter)) =-    object [fromText dsSortFieldName .= omitNulls base] where-      base = [ "order" .= dsSortOrder-             , "unmapped_type" .= dsIgnoreUnmapped-             , "mode" .= dsSortMode-             , "missing" .= dsMissingSort-             , "nested_filter" .= dsNestedFilter ]-+  toJSON+    ( DefaultSortSpec+        ( DefaultSort+            (FieldName dsSortFieldName)+            dsSortOrder+            dsIgnoreUnmapped+            dsSortMode+            dsMissingSort+            dsNestedFilter+          )+      ) =+      object [fromText dsSortFieldName .= omitNulls base]+      where+        base =+          [ "order" .= dsSortOrder,+            "unmapped_type" .= dsIgnoreUnmapped,+            "mode" .= dsSortMode,+            "missing" .= dsMissingSort,+            "nested_filter" .= dsNestedFilter+          ]   toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) =-    object [ "unit" .= units-           , fromText field .= gdsLatLon-           , "order" .= gdsSortOrder ]--{-| 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a-    'mkSort' convenience function for when you want to specify only the most-    common parameters.--    The `ignoreUnmapped`, when `Just` field is used to set the elastic 'unmapped_type'--<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>--}-data DefaultSort =-  DefaultSort { sortFieldName  :: FieldName-              , sortOrder      :: SortOrder-                                  -- default False-              , ignoreUnmapped :: Maybe Text-              , sortMode       :: Maybe SortMode-              , missingSort    :: Maybe Missing-              , nestedFilter   :: Maybe Filter } deriving (Eq, Show)+    object+      [ "unit" .= units,+        fromText field .= gdsLatLon,+        "order" .= gdsSortOrder+      ] -{-| 'SortOrder' is 'Ascending' or 'Descending', as you might expect. These get-    encoded into "asc" or "desc" when turned into JSON.+-- | 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a+--    'mkSort' convenience function for when you want to specify only the most+--    common parameters.+--+--    The `ignoreUnmapped`, when `Just` field is used to set the elastic 'unmapped_type'+--+-- <http://www.elastic.co/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>+data DefaultSort = DefaultSort+  { sortFieldName :: FieldName,+    sortOrder :: SortOrder,+    -- default False+    ignoreUnmapped :: Maybe Text,+    sortMode :: Maybe SortMode,+    missingSort :: Maybe Missing,+    nestedFilter :: Maybe Filter+  }+  deriving (Eq, Show) -<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>--}-data SortOrder = Ascending-               | Descending deriving (Eq, Show)+-- | 'SortOrder' is 'Ascending' or 'Descending', as you might expect. These get+--    encoded into "asc" or "desc" when turned into JSON.+--+-- <http://www.elastic.co/guide/en/elasticsearch/reference/current/search-request-sort.html#search-request-sort>+data SortOrder+  = Ascending+  | Descending+  deriving (Eq, Show)  instance ToJSON SortOrder where-  toJSON Ascending  = String "asc"+  toJSON Ascending = String "asc"   toJSON Descending = String "desc" -{-| 'Missing' prescribes how to handle missing fields. A missing field can be-    sorted last, first, or using a custom value as a substitute.--<http://www.elasticsearch.org/guide/en/elasticsearch/reference/current/search-request-sort.html#_missing_values>--}-data Missing = LastMissing-             | FirstMissing-             | CustomMissing Text deriving (Eq, Show)+-- | 'Missing' prescribes how to handle missing fields. A missing field can be+--    sorted last, first, or using a custom value as a substitute.+--+-- <http://www.elastic.co/guide/en/elasticsearch/reference/current/search-request-sort.html#_missing_values>+data Missing+  = LastMissing+  | FirstMissing+  | CustomMissing Text+  deriving (Eq, Show)  instance ToJSON Missing where-  toJSON LastMissing         = String "_last"-  toJSON FirstMissing        = String "_first"+  toJSON LastMissing = String "_last"+  toJSON FirstMissing = String "_first"   toJSON (CustomMissing txt) = String txt
src/Database/Bloodhound/Internal/StringlyTyped.hs view
@@ -2,37 +2,35 @@  module Database.Bloodhound.Internal.StringlyTyped where -import           Bloodhound.Import--import qualified Data.Text     as T-+import Bloodhound.Import+import qualified Data.Text as T  -- This whole module is a sin bucket to deal with Elasticsearch badness. newtype StringlyTypedDouble = StringlyTypedDouble-  { unStringlyTypedDouble :: Double }+  {unStringlyTypedDouble :: Double}  instance FromJSON StringlyTypedDouble where   parseJSON =-      fmap StringlyTypedDouble-    . parseJSON-    . unStringlyTypeJSON+    fmap StringlyTypedDouble+      . parseJSON+      . unStringlyTypeJSON  newtype StringlyTypedInt = StringlyTypedInt-  { unStringlyTypedInt :: Int }+  {unStringlyTypedInt :: Int}  instance FromJSON StringlyTypedInt where   parseJSON =-      fmap StringlyTypedInt-    . parseJSON-    . unStringlyTypeJSON+    fmap StringlyTypedInt+      . parseJSON+      . unStringlyTypeJSON -newtype StringlyTypedBool = StringlyTypedBool { unStringlyTypedBool :: Bool }+newtype StringlyTypedBool = StringlyTypedBool {unStringlyTypedBool :: Bool}  instance FromJSON StringlyTypedBool where   parseJSON =-      fmap StringlyTypedBool-    . parseJSON-    . unStringlyTypeJSON+    fmap StringlyTypedBool+      . parseJSON+      . unStringlyTypeJSON  -- | For some reason in several settings APIs, all leaf values get returned -- as strings. This function attempts to recover from this for all@@ -46,6 +44,6 @@   Null unStringlyTypeJSON v@(String t) =   case readMay (T.unpack t) of-    Just n  -> Number n+    Just n -> Number n     Nothing -> v unStringlyTypeJSON v = v
src/Database/Bloodhound/Internal/Suggest.hs view
@@ -1,36 +1,36 @@-{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Database.Bloodhound.Internal.Suggest where -import           Bloodhound.Import-+import Bloodhound.Import import qualified Data.Aeson.KeyMap as X-import           GHC.Generics--import           Database.Bloodhound.Internal.Newtypes-import           Database.Bloodhound.Internal.Query (Query, TemplateQueryKeyValuePairs)+import Database.Bloodhound.Internal.Newtypes+import Database.Bloodhound.Internal.Query (Query, TemplateQueryKeyValuePairs)+import GHC.Generics  data Suggest = Suggest-  { suggestText :: Text-  , suggestName :: Text-  , suggestType :: SuggestType-  } deriving (Eq, Show, Generic)+  { suggestText :: Text,+    suggestName :: Text,+    suggestType :: SuggestType+  }+  deriving (Eq, Show, Generic)  instance ToJSON Suggest where-  toJSON Suggest{..} =-    object [ "text" .= suggestText-           , fromText suggestName .= suggestType-           ]+  toJSON Suggest {..} =+    object+      [ "text" .= suggestText,+        fromText suggestName .= suggestType+      ]  instance FromJSON Suggest where   parseJSON (Object o) = do     suggestText' <- o .: "text"     let dropTextList =-            X.toList-          $ X.filterWithKey (\x _ -> x /= "text") o+          X.toList $+            X.filterWithKey (\x _ -> x /= "text") o     suggestName' <-       case dropTextList of         [(x, _)] -> return x@@ -39,106 +39,129 @@     return $ Suggest suggestText' (toText suggestName') suggestType'   parseJSON x = typeMismatch "Suggest" x -data SuggestType =-  SuggestTypePhraseSuggester PhraseSuggester+data SuggestType+  = SuggestTypePhraseSuggester PhraseSuggester   deriving (Eq, Show, Generic)  instance ToJSON SuggestType where   toJSON (SuggestTypePhraseSuggester x) =-    object [ "phrase" .= x ]+    object ["phrase" .= x]  instance FromJSON SuggestType where   parseJSON = withObject "SuggestType" parse-    where parse o = phraseSuggester `taggedWith` "phrase"-           where taggedWith parser k = parser =<< o .: k-                 phraseSuggester = pure . SuggestTypePhraseSuggester+    where+      parse o = phraseSuggester `taggedWith` "phrase"+        where+          taggedWith parser k = parser =<< o .: k+          phraseSuggester = pure . SuggestTypePhraseSuggester  data PhraseSuggester = PhraseSuggester-  { phraseSuggesterField :: FieldName-  , phraseSuggesterGramSize :: Maybe Int-  , phraseSuggesterRealWordErrorLikelihood :: Maybe Int-  , phraseSuggesterConfidence :: Maybe Int-  , phraseSuggesterMaxErrors :: Maybe Int-  , phraseSuggesterSeparator :: Maybe Text-  , phraseSuggesterSize :: Maybe Size-  , phraseSuggesterAnalyzer :: Maybe Analyzer-  , phraseSuggesterShardSize :: Maybe Int-  , phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter-  , phraseSuggesterCollate :: Maybe PhraseSuggesterCollate-  , phraseSuggesterCandidateGenerators :: [DirectGenerators]-  } deriving (Eq, Show, Generic)+  { phraseSuggesterField :: FieldName,+    phraseSuggesterGramSize :: Maybe Int,+    phraseSuggesterRealWordErrorLikelihood :: Maybe Int,+    phraseSuggesterConfidence :: Maybe Int,+    phraseSuggesterMaxErrors :: Maybe Int,+    phraseSuggesterSeparator :: Maybe Text,+    phraseSuggesterSize :: Maybe Size,+    phraseSuggesterAnalyzer :: Maybe Analyzer,+    phraseSuggesterShardSize :: Maybe Int,+    phraseSuggesterHighlight :: Maybe PhraseSuggesterHighlighter,+    phraseSuggesterCollate :: Maybe PhraseSuggesterCollate,+    phraseSuggesterCandidateGenerators :: [DirectGenerators]+  }+  deriving (Eq, Show, Generic)  instance ToJSON PhraseSuggester where-  toJSON PhraseSuggester{..} =-    omitNulls [ "field" .= phraseSuggesterField-              , "gram_size" .= phraseSuggesterGramSize-              , "real_word_error_likelihood" .=-                phraseSuggesterRealWordErrorLikelihood-              , "confidence" .= phraseSuggesterConfidence-              , "max_errors" .= phraseSuggesterMaxErrors-              , "separator" .= phraseSuggesterSeparator-              , "size" .= phraseSuggesterSize-              , "analyzer" .= phraseSuggesterAnalyzer-              , "shard_size" .= phraseSuggesterShardSize-              , "highlight" .= phraseSuggesterHighlight-              , "collate" .= phraseSuggesterCollate-              , "direct_generator" .=-                phraseSuggesterCandidateGenerators-              ]+  toJSON PhraseSuggester {..} =+    omitNulls+      [ "field" .= phraseSuggesterField,+        "gram_size" .= phraseSuggesterGramSize,+        "real_word_error_likelihood"+          .= phraseSuggesterRealWordErrorLikelihood,+        "confidence" .= phraseSuggesterConfidence,+        "max_errors" .= phraseSuggesterMaxErrors,+        "separator" .= phraseSuggesterSeparator,+        "size" .= phraseSuggesterSize,+        "analyzer" .= phraseSuggesterAnalyzer,+        "shard_size" .= phraseSuggesterShardSize,+        "highlight" .= phraseSuggesterHighlight,+        "collate" .= phraseSuggesterCollate,+        "direct_generator"+          .= phraseSuggesterCandidateGenerators+      ]  instance FromJSON PhraseSuggester where   parseJSON = withObject "PhraseSuggester" parse-    where parse o = PhraseSuggester-                      <$> o .: "field"-                      <*> o .:? "gram_size"-                      <*> o .:? "real_word_error_likelihood"-                      <*> o .:? "confidence"-                      <*> o .:? "max_errors"-                      <*> o .:? "separator"-                      <*> o .:? "size"-                      <*> o .:? "analyzer"-                      <*> o .:? "shard_size"-                      <*> o .:? "highlight"-                      <*> o .:? "collate"-                      <*> o .:? "direct_generator" .!= []+    where+      parse o =+        PhraseSuggester+          <$> o .: "field"+          <*> o .:? "gram_size"+          <*> o .:? "real_word_error_likelihood"+          <*> o .:? "confidence"+          <*> o .:? "max_errors"+          <*> o .:? "separator"+          <*> o .:? "size"+          <*> o .:? "analyzer"+          <*> o .:? "shard_size"+          <*> o .:? "highlight"+          <*> o .:? "collate"+          <*> o .:? "direct_generator" .!= []  mkPhraseSuggester :: FieldName -> PhraseSuggester mkPhraseSuggester fName =-  PhraseSuggester fName Nothing Nothing Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing []+  PhraseSuggester+    fName+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    [] -data PhraseSuggesterHighlighter =-  PhraseSuggesterHighlighter { phraseSuggesterHighlighterPreTag :: Text-                             , phraseSuggesterHighlighterPostTag :: Text-                             }+data PhraseSuggesterHighlighter = PhraseSuggesterHighlighter+  { phraseSuggesterHighlighterPreTag :: Text,+    phraseSuggesterHighlighterPostTag :: Text+  }   deriving (Eq, Show, Generic)  instance ToJSON PhraseSuggesterHighlighter where-  toJSON PhraseSuggesterHighlighter{..} =-            object [ "pre_tag" .= phraseSuggesterHighlighterPreTag-                   , "post_tag" .= phraseSuggesterHighlighterPostTag-                   ]+  toJSON PhraseSuggesterHighlighter {..} =+    object+      [ "pre_tag" .= phraseSuggesterHighlighterPreTag,+        "post_tag" .= phraseSuggesterHighlighterPostTag+      ]  instance FromJSON PhraseSuggesterHighlighter where   parseJSON = withObject "PhraseSuggesterHighlighter" parse-    where parse o = PhraseSuggesterHighlighter-                      <$> o .: "pre_tag"-                      <*> o .: "post_tag"+    where+      parse o =+        PhraseSuggesterHighlighter+          <$> o .: "pre_tag"+          <*> o .: "post_tag"  data PhraseSuggesterCollate = PhraseSuggesterCollate-  { phraseSuggesterCollateTemplateQuery :: Query-  , phraseSuggesterCollateParams :: TemplateQueryKeyValuePairs-  , phraseSuggesterCollatePrune :: Bool-  } deriving (Eq, Show, Generic)+  { phraseSuggesterCollateTemplateQuery :: Query,+    phraseSuggesterCollateParams :: TemplateQueryKeyValuePairs,+    phraseSuggesterCollatePrune :: Bool+  }+  deriving (Eq, Show, Generic)  instance ToJSON PhraseSuggesterCollate where-  toJSON PhraseSuggesterCollate{..} =-    object [ "query" .= object-             [ "source" .= phraseSuggesterCollateTemplateQuery-             ]-           , "params" .= phraseSuggesterCollateParams-           , "prune" .= phraseSuggesterCollatePrune-           ]+  toJSON PhraseSuggesterCollate {..} =+    object+      [ "query"+          .= object+            [ "source" .= phraseSuggesterCollateTemplateQuery+            ],+        "params" .= phraseSuggesterCollateParams,+        "prune" .= phraseSuggesterCollatePrune+      ]  instance FromJSON PhraseSuggesterCollate where   parseJSON (Object o) = do@@ -149,57 +172,61 @@     return $ PhraseSuggesterCollate inline' params' prune'   parseJSON x = typeMismatch "PhraseSuggesterCollate" x -data SuggestOptions =-  SuggestOptions { suggestOptionsText :: Text-                 , suggestOptionsScore :: Double-                 , suggestOptionsFreq :: Maybe Int-                 , suggestOptionsHighlighted :: Maybe Text-                 }+data SuggestOptions = SuggestOptions+  { suggestOptionsText :: Text,+    suggestOptionsScore :: Double,+    suggestOptionsFreq :: Maybe Int,+    suggestOptionsHighlighted :: Maybe Text+  }   deriving (Eq, Read, Show)  instance FromJSON SuggestOptions where   parseJSON = withObject "SuggestOptions" parse     where-      parse o = SuggestOptions-            <$> o .: "text"-            <*> o .: "score"-            <*> o .:? "freq"-            <*> o .:? "highlighted"+      parse o =+        SuggestOptions+          <$> o .: "text"+          <*> o .: "score"+          <*> o .:? "freq"+          <*> o .:? "highlighted" -data SuggestResponse =-  SuggestResponse { suggestResponseText :: Text-                  , suggestResponseOffset :: Int-                  , suggestResponseLength :: Int-                  , suggestResponseOptions :: [SuggestOptions]-                  }+data SuggestResponse = SuggestResponse+  { suggestResponseText :: Text,+    suggestResponseOffset :: Int,+    suggestResponseLength :: Int,+    suggestResponseOptions :: [SuggestOptions]+  }   deriving (Eq, Read, Show)  instance FromJSON SuggestResponse where   parseJSON = withObject "SuggestResponse" parse-    where parse o = SuggestResponse-                    <$> o .: "text"-                    <*> o .: "offset"-                    <*> o .: "length"-                    <*> o .: "options"+    where+      parse o =+        SuggestResponse+          <$> o .: "text"+          <*> o .: "offset"+          <*> o .: "length"+          <*> o .: "options"  data NamedSuggestionResponse = NamedSuggestionResponse-  { nsrName :: Text-  , nsrResponses :: [SuggestResponse]-  } deriving (Eq, Read, Show)+  { nsrName :: Text,+    nsrResponses :: [SuggestResponse]+  }+  deriving (Eq, Read, Show)  instance FromJSON NamedSuggestionResponse where   parseJSON (Object o) = do     suggestionName' <- case X.toList o of-                        [(x, _)] -> return x-                        _ -> fail "error parsing NamedSuggestionResponse name"+      [(x, _)] -> return x+      _ -> fail "error parsing NamedSuggestionResponse name"     suggestionResponses' <- o .: suggestionName'     return $ NamedSuggestionResponse (toText suggestionName') suggestionResponses'-   parseJSON x = typeMismatch "NamedSuggestionResponse" x -data DirectGeneratorSuggestModeTypes = DirectGeneratorSuggestModeMissing-                                | DirectGeneratorSuggestModePopular-                                | DirectGeneratorSuggestModeAlways+data DirectGeneratorSuggestModeTypes+  = DirectGeneratorSuggestModeMissing+  | DirectGeneratorSuggestModePopular+  | DirectGeneratorSuggestModeAlways   deriving (Eq, Show, Generic)  instance ToJSON DirectGeneratorSuggestModeTypes where@@ -220,53 +247,64 @@         fail ("Unexpected DirectGeneratorSuggestModeTypes: " <> show f)  data DirectGenerators = DirectGenerators-  { directGeneratorsField :: FieldName-  , directGeneratorsSize :: Maybe Int-  , directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes-  , directGeneratorMaxEdits :: Maybe Double-  , directGeneratorPrefixLength :: Maybe Int-  , directGeneratorMinWordLength :: Maybe Int-  , directGeneratorMaxInspections :: Maybe Int-  , directGeneratorMinDocFreq :: Maybe Double-  , directGeneratorMaxTermFreq :: Maybe Double-  , directGeneratorPreFilter :: Maybe Text-  , directGeneratorPostFilter :: Maybe Text-  } deriving (Eq, Show, Generic)+  { directGeneratorsField :: FieldName,+    directGeneratorsSize :: Maybe Int,+    directGeneratorSuggestMode :: DirectGeneratorSuggestModeTypes,+    directGeneratorMaxEdits :: Maybe Double,+    directGeneratorPrefixLength :: Maybe Int,+    directGeneratorMinWordLength :: Maybe Int,+    directGeneratorMaxInspections :: Maybe Int,+    directGeneratorMinDocFreq :: Maybe Double,+    directGeneratorMaxTermFreq :: Maybe Double,+    directGeneratorPreFilter :: Maybe Text,+    directGeneratorPostFilter :: Maybe Text+  }+  deriving (Eq, Show, Generic)  instance ToJSON DirectGenerators where-  toJSON DirectGenerators{..} =-    omitNulls [ "field" .= directGeneratorsField-              , "size" .= directGeneratorsSize-              , "suggest_mode" .= directGeneratorSuggestMode-              , "max_edits" .= directGeneratorMaxEdits-              , "prefix_length" .= directGeneratorPrefixLength-              , "min_word_length" .= directGeneratorMinWordLength-              , "max_inspections" .= directGeneratorMaxInspections-              , "min_doc_freq" .= directGeneratorMinDocFreq-              , "max_term_freq" .= directGeneratorMaxTermFreq-              , "pre_filter" .= directGeneratorPreFilter-              , "post_filter" .= directGeneratorPostFilter-              ]+  toJSON DirectGenerators {..} =+    omitNulls+      [ "field" .= directGeneratorsField,+        "size" .= directGeneratorsSize,+        "suggest_mode" .= directGeneratorSuggestMode,+        "max_edits" .= directGeneratorMaxEdits,+        "prefix_length" .= directGeneratorPrefixLength,+        "min_word_length" .= directGeneratorMinWordLength,+        "max_inspections" .= directGeneratorMaxInspections,+        "min_doc_freq" .= directGeneratorMinDocFreq,+        "max_term_freq" .= directGeneratorMaxTermFreq,+        "pre_filter" .= directGeneratorPreFilter,+        "post_filter" .= directGeneratorPostFilter+      ]  instance FromJSON DirectGenerators where   parseJSON = withObject "DirectGenerators" parse-    where parse o = DirectGenerators-                      <$> o .: "field"-                      <*> o .:? "size"-                      <*> o .:  "suggest_mode"-                      <*> o .:? "max_edits"-                      <*> o .:? "prefix_length"-                      <*> o .:? "min_word_length"-                      <*> o .:? "max_inspections"-                      <*> o .:? "min_doc_freq"-                      <*> o .:? "max_term_freq"-                      <*> o .:? "pre_filter"-                      <*> o .:? "post_filter"+    where+      parse o =+        DirectGenerators+          <$> o .: "field"+          <*> o .:? "size"+          <*> o .: "suggest_mode"+          <*> o .:? "max_edits"+          <*> o .:? "prefix_length"+          <*> o .:? "min_word_length"+          <*> o .:? "max_inspections"+          <*> o .:? "min_doc_freq"+          <*> o .:? "max_term_freq"+          <*> o .:? "pre_filter"+          <*> o .:? "post_filter"  mkDirectGenerators :: FieldName -> DirectGenerators mkDirectGenerators fn =   DirectGenerators-  fn-  Nothing-  DirectGeneratorSuggestModeMissing-  Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+    fn+    Nothing+    DirectGeneratorSuggestModeMissing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing+    Nothing
src/Database/Bloodhound/Types.hs view
@@ -1,676 +1,711 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE NamedFieldPuns             #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE UndecidableInstances       #-}------------------------------------------------------------------------------------ |--- Module : Database.Bloodhound.Types--- Copyright : (C) 2014, 2018 Chris Allen--- License : BSD-style (see the file LICENSE)--- Maintainer : Chris Allen <cma@bitemyapp.com--- Stability : provisional--- Portability : RecordWildCards------ Data types for describing actions and data structures performed to interact--- with Elasticsearch. The two main buckets your queries against Elasticsearch--- will fall into are 'Query's and 'Filter's. 'Filter's are more like--- traditional database constraints and often have preferable performance--- properties. 'Query's support human-written textual queries, such as fuzzy--- queries.------------------------------------------------------------------------------------module Database.Bloodhound.Types-       ( defaultCache-       , defaultIndexSettings-       , defaultIndexMappingsLimits-       , defaultIndexDocumentSettings-       , mkSort-       , showText-       , unpackId-       , mkMatchQuery-       , mkMultiMatchQuery-       , mkBoolQuery-       , mkRangeQuery-       , mkQueryStringQuery-       , mkAggregations-       , mkTermsAggregation-       , mkTermsScriptAggregation-       , mkDateHistogram-       , mkCardinalityAggregation-       , mkDocVersion-       , mkStatsAggregation-       , mkExtendedStatsAggregation-       , docVersionNumber-       , toMissing-       , toTerms-       , toDateHistogram-       , toTopHits-       , omitNulls-       , BH(..)-       , runBH-       , BHEnv-       , bhServer-       , bhManager-       , bhRequestHook-       , mkBHEnv-       , MonadBH(..)-       , Version(..)-       , VersionNumber(..)-       , MaybeNA(..)-       , BuildHash(..)-       , Status(..)-       , Existence(..)-       , NullValue(..)-       , IndexMappingsLimits (..)-       , IndexSettings(..)-       , UpdatableIndexSetting(..)-       , IndexSettingsSummary(..)-       , AllocationPolicy(..)-       , Compression(..)-       , ReplicaBounds(..)-       , Bytes(..)-       , gigabytes-       , megabytes-       , kilobytes-       , FSType(..)-       , InitialShardCount(..)-       , NodeAttrFilter(..)-       , NodeAttrName(..)-       , CompoundFormat(..)-       , IndexTemplate(..)-       , Server(..)-       , Reply-       , EsResult(..)-       , EsResultFound(..)-       , EsError(..)-       , EsProtocolException(..)-       , IndexAlias(..)-       , IndexAliasName(..)-       , IndexAliasAction(..)-       , IndexAliasCreate(..)-       , IndexAliasSummary(..)-       , IndexAliasesSummary(..)-       , AliasRouting(..)-       , SearchAliasRouting(..)-       , IndexAliasRouting(..)-       , RoutingValue(..)-       , DocVersion-       , ExternalDocVersion(..)-       , VersionControl(..)-       , JoinRelation(..)-       , IndexDocumentSettings(..)-       , Query(..)-       , Search(..)-       , SearchType(..)-       , SearchResult(..)-       , ScrollId(..)-       , HitsTotalRelation(..)-       , HitsTotal(..)-       , SearchHits(..)-       , TrackSortScores-       , From(..)-       , Size(..)-       , Source(..)-       , PatternOrPatterns(..)-       , Include(..)-       , Exclude(..)-       , Pattern(..)-       , ShardResult(..)-       , Hit(..)-       , HitFields(..)-       , Filter(..)-       , BoolMatch(..)-       , Term(..)-       , GeoPoint(..)-       , GeoBoundingBoxConstraint(..)-       , GeoBoundingBox(..)-       , GeoFilterType(..)-       , Distance(..)-       , DistanceUnit(..)-       , DistanceType(..)-       , DistanceRange(..)-       , OptimizeBbox(..)-       , LatLon(..)-       , RangeValue(..)-       , RangeExecution(..)-       , LessThan(..)-       , LessThanEq(..)-       , GreaterThan(..)-       , GreaterThanEq(..)-       , LessThanD(..)-       , LessThanEqD(..)-       , GreaterThanD(..)-       , GreaterThanEqD(..)-       , Regexp(..)-       , RegexpFlags(..)-       , RegexpFlag(..)-       , FieldName(..)-       , ScriptFields(..)-       , ScriptFieldValue-       , Script(..)-       , ScriptLanguage(..)-       , ScriptSource(..)-       , ScriptParams(..)-       , ScriptParamValue-       , IndexName(..)-       , IndexSelection(..)-       , NodeSelection(..)-       , NodeSelector(..)-       , ForceMergeIndexSettings(..)-       , defaultForceMergeIndexSettings-       , TemplateName(..)-       , IndexPattern(..)-       , DocId(..)-       , CacheName(..)-       , CacheKey(..)-       , BulkOperation(..)-       , ReplicaCount(..)-       , ShardCount(..)-       , Sort-       , SortMode(..)-       , SortOrder(..)-       , SortSpec(..)-       , DefaultSort(..)-       , Missing(..)-       , OpenCloseIndex(..)-       , Method-       , Boost(..)-       , MatchQuery(..)-       , MultiMatchQuery(..)-       , BoolQuery(..)-       , BoostingQuery(..)-       , CommonTermsQuery(..)-       , FunctionScoreQuery(..)-       , BoostMode(..)-       , ScoreMode(..)-       , FunctionScoreFunctions(..)-       , ComponentFunctionScoreFunction(..)-       , FunctionScoreFunction(..)-       , Weight(..)-       , Seed(..)-       , FieldValueFactor(..)-       , Factor(..)-       , FactorModifier(..)-       , FactorMissingFieldValue(..)-       , DisMaxQuery(..)-       , FuzzyLikeThisQuery(..)-       , FuzzyLikeFieldQuery(..)-       , FuzzyQuery(..)-       , HasChildQuery(..)-       , HasParentQuery(..)-       , IndicesQuery(..)-       , MoreLikeThisQuery(..)-       , MoreLikeThisFieldQuery(..)-       , NestedQuery(..)-       , PrefixQuery(..)-       , QueryStringQuery(..)-       , SimpleQueryStringQuery(..)-       , RangeQuery(..)-       , RegexpQuery(..)-       , QueryString(..)-       , SearchTemplateId(..)-       , SearchTemplateSource(..)-       , SearchTemplate(..)-       , GetTemplateScript(..)-       , TemplateQueryKeyValuePairs(..)-       , WildcardQuery(..)-       , BooleanOperator(..)-       , ZeroTermsQuery(..)-       , CutoffFrequency(..)-       , Analyzer(..)-       , Tokenizer(..)-       , TokenFilter(..)-       , CharFilter(..)-       , MaxExpansions(..)-       , Lenient(..)-       , MatchQueryType(..)-       , MultiMatchQueryType(..)-       , Tiebreaker(..)-       , MinimumMatch(..)-       , DisableCoord(..)-       , CommonMinimumMatch(..)-       , MinimumMatchHighLow(..)-       , PrefixLength(..)-       , Fuzziness(..)-       , IgnoreTermFrequency(..)-       , MaxQueryTerms(..)-       , AggregateParentScore(..)-       , IgnoreUnmapped(..)-       , MinChildren(..)-       , MaxChildren(..)-       , ScoreType(..)-       , InnerHits(..)-       , Score-       , Cache-       , RelationName(..)-       , BoostTerms(..)-       , MaxWordLength(..)-       , MinWordLength(..)-       , MaxDocFrequency(..)-       , MinDocFrequency(..)-       , PhraseSlop(..)-       , StopWord(..)-       , QueryPath(..)-       , MinimumTermFrequency(..)-       , PercentMatch(..)-       , FieldDefinition(..)-       , MappingField(..)-       , Mapping(..)-       , UpsertActionMetadata(..)-       , buildUpsertActionMetadata-       , UpsertPayload(..)-       , AllowLeadingWildcard(..)-       , LowercaseExpanded(..)-       , GeneratePhraseQueries(..)-       , Locale(..)-       , AnalyzeWildcard(..)-       , EnablePositionIncrements(..)-       , SimpleQueryFlag(..)-       , FieldOrFields(..)-       , Monoid(..)-       , ToJSON(..)-       , Interval(..)-       , TimeInterval(..)-       , ExecutionHint(..)-       , CollectionMode(..)-       , TermOrder(..)-       , TermInclusion(..)-       , SnapshotRepoSelection(..)-       , GenericSnapshotRepo(..)-       , SnapshotRepo(..)-       , SnapshotRepoConversionError(..)-       , SnapshotRepoType(..)-       , GenericSnapshotRepoSettings(..)-       , SnapshotRepoUpdateSettings(..)-       , defaultSnapshotRepoUpdateSettings-       , SnapshotRepoName(..)-       , SnapshotRepoPattern(..)-       , SnapshotVerification(..)-       , SnapshotNodeVerification(..)-       , FullNodeId(..)-       , NodeName(..)-       , ClusterName(..)-       , NodesInfo(..)-       , NodesStats(..)-       , NodeStats(..)-       , NodeBreakersStats(..)-       , NodeBreakerStats(..)-       , NodeHTTPStats(..)-       , NodeTransportStats(..)-       , NodeFSStats(..)-       , NodeDataPathStats(..)-       , NodeFSTotalStats(..)-       , NodeNetworkStats(..)-       , NodeThreadPoolStats(..)-       , NodeJVMStats(..)-       , JVMBufferPoolStats(..)-       , JVMGCStats(..)-       , JVMPoolStats(..)-       , NodeProcessStats(..)-       , NodeOSStats(..)-       , LoadAvgs(..)-       , NodeIndicesStats(..)-       , EsAddress(..)-       , PluginName(..)-       , NodeInfo(..)-       , NodePluginInfo(..)-       , NodeHTTPInfo(..)-       , NodeTransportInfo(..)-       , BoundTransportAddress(..)-       , NodeNetworkInfo(..)-       , MacAddress(..)-       , NetworkInterfaceName(..)-       , NodeNetworkInterface(..)-       , NodeThreadPoolInfo(..)-       , ThreadPoolSize(..)-       , ThreadPoolType(..)-       , NodeJVMInfo(..)-       , JVMMemoryPool(..)-       , JVMGCCollector(..)-       , JVMMemoryInfo(..)-       , PID(..)-       , NodeOSInfo(..)-       , CPUInfo(..)-       , NodeProcessInfo(..)-       , FsSnapshotRepo(..)-       , SnapshotCreateSettings(..)-       , defaultSnapshotCreateSettings-       , SnapshotSelection(..)-       , SnapshotPattern(..)-       , SnapshotInfo(..)-       , SnapshotShardFailure(..)-       , ShardId(..)-       , SnapshotName(..)-       , SnapshotState(..)-       , SnapshotRestoreSettings(..)-       , defaultSnapshotRestoreSettings-       , RestoreRenamePattern(..)-       , RestoreRenameToken(..)-       , RRGroupRefNum-       , rrGroupRefNum-       , mkRRGroupRefNum-       , RestoreIndexSettings(..)-       , Suggest(..)-       , SuggestType(..)-       , PhraseSuggester(..)-       , PhraseSuggesterHighlighter(..)-       , PhraseSuggesterCollate(..)-       , mkPhraseSuggester-       , SuggestOptions(..)-       , SuggestResponse(..)-       , NamedSuggestionResponse(..)-       , DirectGenerators(..)-       , mkDirectGenerators-       , DirectGeneratorSuggestModeTypes (..)--       , Aggregation(..)-       , Aggregations-       , AggregationResults-       , BucketValue(..)-       , Bucket(..)-       , BucketAggregation(..)-       , TermsAggregation(..)-       , MissingAggregation(..)-       , ValueCountAggregation(..)-       , FilterAggregation(..)-       , CardinalityAggregation(..)-       , DateHistogramAggregation(..)-       , DateRangeAggregation(..)-       , DateRangeAggRange(..)-       , DateMathExpr(..)-       , DateMathAnchor(..)-       , DateMathModifier(..)-       , DateMathUnit(..)-       , TopHitsAggregation(..)-       , StatisticsAggregation(..)-       , SearchAfterKey-       , CountQuery (..)-       , CountResponse (..)-       , CountShards (..)-       , PointInTime(..)-       , OpenPointInTimeResponse (..)-       , ClosePointInTime (..)-       , ClosePointInTimeResponse (..)-       , SumAggregation(..)--       , Highlights(..)-       , FieldHighlight(..)-       , HighlightSettings(..)-       , PlainHighlight(..)-       , PostingsHighlight(..)-       , FastVectorHighlight(..)-       , CommonHighlight(..)-       , NonPostings(..)-       , HighlightEncoder(..)-       , HighlightTag(..)-       , HitHighlight--       , MissingResult(..)-       , TermsResult(..)-       , DateHistogramResult(..)-       , DateRangeResult(..)-       , TopHitResult(..)--       , EsUsername(..)-       , EsPassword(..)--       , Analysis(..)-       , AnalyzerDefinition(..)-       , TokenizerDefinition(..)-       , TokenFilterDefinition(..)-       , CharFilterDefinition(..)-       , Ngram(..)-       , NgramFilter(..)-       , EdgeNgramFilterSide(..)-       , TokenChar(..)-       , Shingle(..)-       , Language(..)-       ) where--import           Bloodhound.Import--import           Database.Bloodhound.Internal.Aggregation-import           Database.Bloodhound.Internal.Analysis-import           Database.Bloodhound.Internal.Client-import Database.Bloodhound.Internal.Count-import           Database.Bloodhound.Internal.Highlight-import           Database.Bloodhound.Internal.Newtypes-import           Database.Bloodhound.Internal.Query-import           Database.Bloodhound.Internal.Sort-import           Database.Bloodhound.Internal.Suggest-import           Database.Bloodhound.Internal.PointInTime-import qualified Data.HashMap.Strict as HM--{-| 'unpackId' is a silly convenience function that gets used once.--}-unpackId :: DocId -> Text-unpackId (DocId docId) = docId--type TrackSortScores = Bool--data Search = Search { queryBody       :: Maybe Query-                     , filterBody      :: Maybe Filter-                     , sortBody        :: Maybe Sort-                     , aggBody         :: Maybe Aggregations-                     , highlight       :: Maybe Highlights-                       -- default False-                     , trackSortScores :: TrackSortScores-                     , from            :: From-                     , size            :: Size-                     , searchType      :: SearchType-                     , searchAfterKey  :: Maybe SearchAfterKey-                     , fields          :: Maybe [FieldName]-                     , scriptFields    :: Maybe ScriptFields-                     , source          :: Maybe Source-                     , suggestBody     :: Maybe Suggest -- ^ Only one Suggestion request / response per Search is supported.-                     , pointInTime     :: Maybe PointInTime-                     } deriving (Eq, Show)---instance ToJSON Search where-  toJSON (Search mquery sFilter sort searchAggs-          highlight sTrackSortScores sFrom sSize _ sAfter sFields-          sScriptFields sSource sSuggest pPointInTime) =-    omitNulls [ "query"         .= query'-              , "sort"          .= sort-              , "aggregations"  .= searchAggs-              , "highlight"     .= highlight-              , "from"          .= sFrom-              , "size"          .= sSize-              , "track_scores"  .= sTrackSortScores-              , "search_after"  .= sAfter-              , "fields"        .= sFields-              , "script_fields" .= sScriptFields-              , "_source"       .= sSource-              , "suggest"       .= sSuggest-              , "pit"           .= pPointInTime]--    where query' = case sFilter of-                    Nothing -> mquery-                    Just x ->-                        Just-                      . QueryBoolQuery-                      $ mkBoolQuery (maybeToList mquery)-                        [x] [] []--data SearchType = SearchTypeQueryThenFetch-                | SearchTypeDfsQueryThenFetch-  deriving (Eq, Show)--instance ToJSON SearchType where-  toJSON SearchTypeQueryThenFetch = String "query_then_fetch"-  toJSON SearchTypeDfsQueryThenFetch = String "dfs_query_then_fetch"--instance FromJSON SearchType where-  parseJSON (String "query_then_fetch") = pure $ SearchTypeQueryThenFetch-  parseJSON (String "dfs_query_then_fetch") = pure $ SearchTypeDfsQueryThenFetch-  parseJSON _          = empty--data Source =-    NoSource-  | SourcePatterns PatternOrPatterns-  | SourceIncludeExclude Include Exclude-    deriving (Eq, Show)--instance ToJSON Source where-    toJSON NoSource                         = toJSON False-    toJSON (SourcePatterns patterns)        = toJSON patterns-    toJSON (SourceIncludeExclude incl excl) = object [ "includes" .= incl, "excludes" .= excl ]--data PatternOrPatterns = PopPattern   Pattern-                       | PopPatterns [Pattern] deriving (Eq, Read, Show)--instance ToJSON PatternOrPatterns where-  toJSON (PopPattern pattern)   = toJSON pattern-  toJSON (PopPatterns patterns) = toJSON patterns--data Include = Include [Pattern] deriving (Eq, Read, Show)-data Exclude = Exclude [Pattern] deriving (Eq, Read, Show)--instance ToJSON Include where-  toJSON (Include patterns) = toJSON patterns--instance ToJSON Exclude where-  toJSON (Exclude patterns) = toJSON patterns--newtype Pattern = Pattern Text deriving (Eq, Read, Show)--instance ToJSON Pattern where-  toJSON (Pattern pattern) = toJSON pattern--data SearchResult a =-  SearchResult { took         :: Int-               , timedOut     :: Bool-               , shards       :: ShardResult-               , searchHits   :: SearchHits a-               , aggregations :: Maybe AggregationResults-               , scrollId     :: Maybe ScrollId-               -- ^ Only one Suggestion request / response per-               --   Search is supported.-               , suggest      :: Maybe NamedSuggestionResponse-               , pitId        :: Maybe Text-               }-  deriving (Eq, Show)--instance (FromJSON a) => FromJSON (SearchResult a) where-  parseJSON (Object v) = SearchResult <$>-                         v .:  "took"         <*>-                         v .:  "timed_out"    <*>-                         v .:  "_shards"      <*>-                         v .:  "hits"         <*>-                         v .:? "aggregations" <*>-                         v .:? "_scroll_id"   <*>-                         v .:? "suggest"      <*>-                         v .:? "pit_id"-  parseJSON _          = empty--newtype ScrollId =-  ScrollId Text-  deriving (Eq, Show, Ord, ToJSON, FromJSON)--newtype SearchTemplateId = SearchTemplateId Text deriving (Eq, Show)--instance ToJSON SearchTemplateId where-  toJSON (SearchTemplateId x) = toJSON x--newtype SearchTemplateSource = SearchTemplateSource Text deriving (Eq, Show)--instance ToJSON SearchTemplateSource where-  toJSON (SearchTemplateSource x) = toJSON x--instance FromJSON SearchTemplateSource where-  parseJSON (String s) = pure $ SearchTemplateSource s-  parseJSON _          = empty--data ExpandWildcards = ExpandWildcardsAll-  | ExpandWildcardsOpen-  | ExpandWildcardsClosed-  | ExpandWildcardsNone-  deriving (Eq, Show)--instance ToJSON ExpandWildcards where-  toJSON ExpandWildcardsAll = String "all"-  toJSON ExpandWildcardsOpen = String "open"-  toJSON ExpandWildcardsClosed = String "closed"-  toJSON ExpandWildcardsNone = String "none"--instance FromJSON ExpandWildcards where-  parseJSON (String "all") = pure $ ExpandWildcardsAll-  parseJSON (String "open") = pure $ ExpandWildcardsOpen-  parseJSON (String "closed") = pure $ ExpandWildcardsClosed-  parseJSON (String "none") = pure $ ExpandWildcardsNone-  parseJSON _          = empty--data TimeUnits = TimeUnitDays -  | TimeUnitHours-  | TimeUnitMinutes-  | TimeUnitSeconds-  | TimeUnitMilliseconds-  | TimeUnitMicroseconds-  | TimeUnitNanoseconds-  deriving (Eq, Show)--instance ToJSON TimeUnits where-  toJSON TimeUnitDays = String "d"-  toJSON TimeUnitHours = String "h"-  toJSON TimeUnitMinutes = String "m"-  toJSON TimeUnitSeconds = String "s"-  toJSON TimeUnitMilliseconds = String "ms"-  toJSON TimeUnitMicroseconds = String "micros"-  toJSON TimeUnitNanoseconds = String "nanos"--instance FromJSON TimeUnits where-  parseJSON (String "d") = pure $ TimeUnitDays-  parseJSON (String "h") = pure $ TimeUnitHours-  parseJSON ( String "m") = pure $ TimeUnitMinutes-  parseJSON (String "s") = pure $ TimeUnitSeconds-  parseJSON (String "ms") = pure $ TimeUnitMilliseconds-  parseJSON (String "micros") = pure $ TimeUnitMicroseconds-  parseJSON (String "nanos") = pure $ TimeUnitNanoseconds-  parseJSON _          = empty--data SearchTemplate = SearchTemplate {-    searchTemplate                      :: Either SearchTemplateId SearchTemplateSource-    , params                              :: TemplateQueryKeyValuePairs-    , explainSearchTemplate               :: Maybe Bool-    , profileSearchTemplate               :: Maybe Bool-  } deriving (Eq, Show)--instance ToJSON SearchTemplate where-  toJSON SearchTemplate{..} = omitNulls [ -    either ("id" .=) ("source" .=) searchTemplate-    , "params" .= params-    , "explain" .= explainSearchTemplate-    , "profile" .= profileSearchTemplate-    ]--data GetTemplateScript = GetTemplateScript {-    getTemplateScriptLang      :: Maybe Text-    , getTemplateScriptSource  :: Maybe SearchTemplateSource-    , getTemplateScriptOptions :: Maybe (HM.HashMap Text Text)-    , getTemplateScriptId      :: Text-    , getTemplateScriptFound   :: Bool-  } deriving (Eq, Show)--instance FromJSON GetTemplateScript where-  parseJSON (Object v) = do-    script <- v .:? "script"-    maybe-      (GetTemplateScript Nothing Nothing Nothing <$> v .: "_id" <*> v .: "found")-      (\s -> GetTemplateScript <$>-        s .:? "lang"    <*>-        s .:? "source"  <*>-        s .:? "options" <*>-        v .: "_id"      <*>-        v .: "found"-      )-      script-  parseJSON _          = empty-+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}++{- ORMOLU_DISABLE -}+-------------------------------------------------------------------------------+-- |+-- Module : Database.Bloodhound.Types+-- Copyright : (C) 2014, 2018 Chris Allen+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Chris Allen <cma@bitemyapp.com+-- Stability : provisional+-- Portability : RecordWildCards+--+-- Data types for describing actions and data structures performed to interact+-- with Elasticsearch. The two main buckets your queries against Elasticsearch+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like+-- traditional database constraints and often have preferable performance+-- properties. 'Query's support human-written textual queries, such as fuzzy+-- queries.+-------------------------------------------------------------------------------+{- ORMOLU_ENABLE -}+module Database.Bloodhound.Types+  ( defaultCache,+    defaultIndexSettings,+    defaultIndexMappingsLimits,+    defaultIndexDocumentSettings,+    mkSort,+    showText,+    unpackId,+    mkMatchQuery,+    mkMultiMatchQuery,+    mkBoolQuery,+    mkRangeQuery,+    mkQueryStringQuery,+    mkAggregations,+    mkTermsAggregation,+    mkTermsScriptAggregation,+    mkDateHistogram,+    mkCardinalityAggregation,+    mkDocVersion,+    mkStatsAggregation,+    mkExtendedStatsAggregation,+    docVersionNumber,+    toMissing,+    toTerms,+    toDateHistogram,+    toTopHits,+    omitNulls,+    BH (..),+    runBH,+    BHEnv,+    bhServer,+    bhManager,+    bhRequestHook,+    mkBHEnv,+    MonadBH (..),+    Version (..),+    VersionNumber (..),+    MaybeNA (..),+    BuildHash (..),+    Status (..),+    Existence (..),+    NullValue (..),+    IndexMappingsLimits (..),+    IndexSettings (..),+    UpdatableIndexSetting (..),+    IndexSettingsSummary (..),+    AllocationPolicy (..),+    Compression (..),+    ReplicaBounds (..),+    Bytes (..),+    gigabytes,+    megabytes,+    kilobytes,+    FSType (..),+    InitialShardCount (..),+    NodeAttrFilter (..),+    NodeAttrName (..),+    CompoundFormat (..),+    IndexTemplate (..),+    Server (..),+    EsResult (..),+    EsResultFound (..),+    EsError (..),+    EsProtocolException (..),+    IndexAlias (..),+    IndexAliasName (..),+    IndexAliasAction (..),+    IndexAliasCreate (..),+    IndexAliasSummary (..),+    IndexAliasesSummary (..),+    AliasRouting (..),+    SearchAliasRouting (..),+    IndexAliasRouting (..),+    RoutingValue (..),+    DocVersion,+    ExternalDocVersion (..),+    VersionControl (..),+    JoinRelation (..),+    IndexDocumentSettings (..),+    Query (..),+    Search (..),+    SearchType (..),+    SearchResult (..),+    ScrollId (..),+    HitsTotalRelation (..),+    HitsTotal (..),+    SearchHits (..),+    TrackSortScores,+    From (..),+    Size (..),+    Source (..),+    PatternOrPatterns (..),+    Include (..),+    Exclude (..),+    Pattern (..),+    ShardResult (..),+    Hit (..),+    HitFields (..),+    Filter (..),+    BoolMatch (..),+    Term (..),+    GeoPoint (..),+    GeoBoundingBoxConstraint (..),+    GeoBoundingBox (..),+    GeoFilterType (..),+    Distance (..),+    DistanceUnit (..),+    DistanceType (..),+    DistanceRange (..),+    OptimizeBbox (..),+    LatLon (..),+    RangeValue (..),+    RangeExecution (..),+    LessThan (..),+    LessThanEq (..),+    GreaterThan (..),+    GreaterThanEq (..),+    LessThanD (..),+    LessThanEqD (..),+    GreaterThanD (..),+    GreaterThanEqD (..),+    Regexp (..),+    RegexpFlags (..),+    RegexpFlag (..),+    FieldName (..),+    ScriptFields (..),+    ScriptFieldValue,+    Script (..),+    ScriptLanguage (..),+    ScriptSource (..),+    ScriptParams (..),+    ScriptParamValue,+    IndexName (..),+    IndexSelection (..),+    NodeSelection (..),+    NodeSelector (..),+    ForceMergeIndexSettings (..),+    defaultForceMergeIndexSettings,+    TemplateName (..),+    IndexPattern (..),+    DocId (..),+    CacheName (..),+    CacheKey (..),+    BulkOperation (..),+    ReplicaCount (..),+    ShardCount (..),+    Sort,+    SortMode (..),+    SortOrder (..),+    SortSpec (..),+    DefaultSort (..),+    Missing (..),+    OpenCloseIndex (..),+    Method,+    Boost (..),+    MatchQuery (..),+    MultiMatchQuery (..),+    BoolQuery (..),+    BoostingQuery (..),+    CommonTermsQuery (..),+    FunctionScoreQuery (..),+    BoostMode (..),+    ScoreMode (..),+    FunctionScoreFunctions (..),+    ComponentFunctionScoreFunction (..),+    FunctionScoreFunction (..),+    Weight (..),+    Seed (..),+    FieldValueFactor (..),+    Factor (..),+    FactorModifier (..),+    FactorMissingFieldValue (..),+    DisMaxQuery (..),+    FuzzyLikeThisQuery (..),+    FuzzyLikeFieldQuery (..),+    FuzzyQuery (..),+    HasChildQuery (..),+    HasParentQuery (..),+    IndicesQuery (..),+    MoreLikeThisQuery (..),+    MoreLikeThisFieldQuery (..),+    NestedQuery (..),+    PrefixQuery (..),+    QueryStringQuery (..),+    SimpleQueryStringQuery (..),+    RangeQuery (..),+    RegexpQuery (..),+    QueryString (..),+    SearchTemplateId (..),+    SearchTemplateSource (..),+    SearchTemplate (..),+    GetTemplateScript (..),+    TemplateQueryKeyValuePairs (..),+    WildcardQuery (..),+    BooleanOperator (..),+    ZeroTermsQuery (..),+    CutoffFrequency (..),+    Analyzer (..),+    Tokenizer (..),+    TokenFilter (..),+    CharFilter (..),+    MaxExpansions (..),+    Lenient (..),+    MatchQueryType (..),+    MultiMatchQueryType (..),+    Tiebreaker (..),+    MinimumMatch (..),+    DisableCoord (..),+    CommonMinimumMatch (..),+    MinimumMatchHighLow (..),+    PrefixLength (..),+    Fuzziness (..),+    IgnoreTermFrequency (..),+    MaxQueryTerms (..),+    AggregateParentScore (..),+    IgnoreUnmapped (..),+    MinChildren (..),+    MaxChildren (..),+    ScoreType (..),+    InnerHits (..),+    Score,+    Cache,+    RelationName (..),+    BoostTerms (..),+    MaxWordLength (..),+    MinWordLength (..),+    MaxDocFrequency (..),+    MinDocFrequency (..),+    PhraseSlop (..),+    StopWord (..),+    QueryPath (..),+    MinimumTermFrequency (..),+    PercentMatch (..),+    FieldDefinition (..),+    MappingField (..),+    Mapping (..),+    UpsertActionMetadata (..),+    buildUpsertActionMetadata,+    UpsertPayload (..),+    AllowLeadingWildcard (..),+    LowercaseExpanded (..),+    GeneratePhraseQueries (..),+    Locale (..),+    AnalyzeWildcard (..),+    EnablePositionIncrements (..),+    SimpleQueryFlag (..),+    FieldOrFields (..),+    Monoid (..),+    ToJSON (..),+    Interval (..),+    TimeInterval (..),+    ExecutionHint (..),+    CollectionMode (..),+    TermOrder (..),+    TermInclusion (..),+    SnapshotRepoSelection (..),+    GenericSnapshotRepo (..),+    SnapshotRepo (..),+    SnapshotRepoConversionError (..),+    SnapshotRepoType (..),+    GenericSnapshotRepoSettings (..),+    SnapshotRepoUpdateSettings (..),+    defaultSnapshotRepoUpdateSettings,+    SnapshotRepoName (..),+    SnapshotRepoPattern (..),+    SnapshotVerification (..),+    SnapshotNodeVerification (..),+    FullNodeId (..),+    NodeName (..),+    ClusterName (..),+    NodesInfo (..),+    NodesStats (..),+    NodeStats (..),+    NodeBreakersStats (..),+    NodeBreakerStats (..),+    NodeHTTPStats (..),+    NodeTransportStats (..),+    NodeFSStats (..),+    NodeDataPathStats (..),+    NodeFSTotalStats (..),+    NodeNetworkStats (..),+    NodeThreadPoolStats (..),+    NodeJVMStats (..),+    JVMBufferPoolStats (..),+    JVMGCStats (..),+    JVMPoolStats (..),+    NodeProcessStats (..),+    NodeOSStats (..),+    LoadAvgs (..),+    NodeIndicesStats (..),+    EsAddress (..),+    PluginName (..),+    NodeInfo (..),+    NodePluginInfo (..),+    NodeHTTPInfo (..),+    NodeTransportInfo (..),+    BoundTransportAddress (..),+    NodeNetworkInfo (..),+    MacAddress (..),+    NetworkInterfaceName (..),+    NodeNetworkInterface (..),+    NodeThreadPoolInfo (..),+    ThreadPoolSize (..),+    ThreadPoolType (..),+    NodeJVMInfo (..),+    JVMMemoryPool (..),+    JVMGCCollector (..),+    JVMMemoryInfo (..),+    PID (..),+    NodeOSInfo (..),+    CPUInfo (..),+    NodeProcessInfo (..),+    FsSnapshotRepo (..),+    SnapshotCreateSettings (..),+    defaultSnapshotCreateSettings,+    SnapshotSelection (..),+    SnapshotPattern (..),+    SnapshotInfo (..),+    SnapshotShardFailure (..),+    ShardId (..),+    SnapshotName (..),+    SnapshotState (..),+    SnapshotRestoreSettings (..),+    defaultSnapshotRestoreSettings,+    RestoreRenamePattern (..),+    RestoreRenameToken (..),+    RRGroupRefNum,+    rrGroupRefNum,+    mkRRGroupRefNum,+    RestoreIndexSettings (..),+    Suggest (..),+    SuggestType (..),+    PhraseSuggester (..),+    PhraseSuggesterHighlighter (..),+    PhraseSuggesterCollate (..),+    mkPhraseSuggester,+    SuggestOptions (..),+    SuggestResponse (..),+    NamedSuggestionResponse (..),+    DirectGenerators (..),+    mkDirectGenerators,+    DirectGeneratorSuggestModeTypes (..),+    Aggregation (..),+    Aggregations,+    AggregationResults,+    BucketValue (..),+    Bucket (..),+    BucketAggregation (..),+    TermsAggregation (..),+    MissingAggregation (..),+    ValueCountAggregation (..),+    FilterAggregation (..),+    CardinalityAggregation (..),+    DateHistogramAggregation (..),+    DateRangeAggregation (..),+    DateRangeAggRange (..),+    DateMathExpr (..),+    DateMathAnchor (..),+    DateMathModifier (..),+    DateMathUnit (..),+    TopHitsAggregation (..),+    StatisticsAggregation (..),+    SearchAfterKey,+    CountQuery (..),+    CountResponse (..),+    CountShards (..),+    PointInTime (..),+    OpenPointInTimeResponse (..),+    ClosePointInTime (..),+    ClosePointInTimeResponse (..),+    SumAggregation (..),+    Highlights (..),+    FieldHighlight (..),+    HighlightSettings (..),+    PlainHighlight (..),+    PostingsHighlight (..),+    FastVectorHighlight (..),+    CommonHighlight (..),+    NonPostings (..),+    HighlightEncoder (..),+    HighlightTag (..),+    HitHighlight,+    MissingResult (..),+    TermsResult (..),+    DateHistogramResult (..),+    DateRangeResult (..),+    TopHitResult (..),+    EsUsername (..),+    EsPassword (..),+    Analysis (..),+    AnalyzerDefinition (..),+    TokenizerDefinition (..),+    TokenFilterDefinition (..),+    CharFilterDefinition (..),+    Ngram (..),+    NgramFilter (..),+    EdgeNgramFilterSide (..),+    TokenChar (..),+    Shingle (..),+    Language (..),+    BHRequest (..),+    mkFullRequest,+    mkSimpleRequest,+    Endpoint (..),+    withQueries,+    mkEndpoint,+    getEndpoint,+    BHResponse (..),+    ParsedEsResponse,+  )+where++import Bloodhound.Import+import qualified Data.HashMap.Strict as HM+import Database.Bloodhound.Internal.Aggregation+import Database.Bloodhound.Internal.Analysis+import Database.Bloodhound.Internal.Client+import Database.Bloodhound.Internal.Client.BHRequest+import Database.Bloodhound.Internal.Client.Doc+import Database.Bloodhound.Internal.Count+import Database.Bloodhound.Internal.Highlight+import Database.Bloodhound.Internal.Newtypes+import Database.Bloodhound.Internal.PointInTime+import Database.Bloodhound.Internal.Query+import Database.Bloodhound.Internal.Sort+import Database.Bloodhound.Internal.Suggest++-- | 'unpackId' is a silly convenience function that gets used once.+unpackId :: DocId -> Text+unpackId (DocId docId) = docId++type TrackSortScores = Bool++data Search = Search+  { queryBody :: Maybe Query,+    filterBody :: Maybe Filter,+    sortBody :: Maybe Sort,+    aggBody :: Maybe Aggregations,+    highlight :: Maybe Highlights,+    -- default False+    trackSortScores :: TrackSortScores,+    from :: From,+    size :: Size,+    searchType :: SearchType,+    searchAfterKey :: Maybe SearchAfterKey,+    fields :: Maybe [FieldName],+    scriptFields :: Maybe ScriptFields,+    source :: Maybe Source,+    -- | Only one Suggestion request / response per Search is supported.+    suggestBody :: Maybe Suggest,+    pointInTime :: Maybe PointInTime+  }+  deriving (Eq, Show)++instance ToJSON Search where+  toJSON+    ( Search+        mquery+        sFilter+        sort+        searchAggs+        highlight+        sTrackSortScores+        sFrom+        sSize+        _+        sAfter+        sFields+        sScriptFields+        sSource+        sSuggest+        pPointInTime+      ) =+      omitNulls+        [ "query" .= query',+          "sort" .= sort,+          "aggregations" .= searchAggs,+          "highlight" .= highlight,+          "from" .= sFrom,+          "size" .= sSize,+          "track_scores" .= sTrackSortScores,+          "search_after" .= sAfter,+          "fields" .= sFields,+          "script_fields" .= sScriptFields,+          "_source" .= sSource,+          "suggest" .= sSuggest,+          "pit" .= pPointInTime+        ]+      where+        query' = case sFilter of+          Nothing -> mquery+          Just x ->+            Just+              . QueryBoolQuery+              $ mkBoolQuery+                (maybeToList mquery)+                [x]+                []+                []++data SearchType+  = SearchTypeQueryThenFetch+  | SearchTypeDfsQueryThenFetch+  deriving (Eq, Show)++instance ToJSON SearchType where+  toJSON SearchTypeQueryThenFetch = String "query_then_fetch"+  toJSON SearchTypeDfsQueryThenFetch = String "dfs_query_then_fetch"++instance FromJSON SearchType where+  parseJSON (String "query_then_fetch") = pure $ SearchTypeQueryThenFetch+  parseJSON (String "dfs_query_then_fetch") = pure $ SearchTypeDfsQueryThenFetch+  parseJSON _ = empty++data Source+  = NoSource+  | SourcePatterns PatternOrPatterns+  | SourceIncludeExclude Include Exclude+  deriving (Eq, Show)++instance ToJSON Source where+  toJSON NoSource = toJSON False+  toJSON (SourcePatterns patterns) = toJSON patterns+  toJSON (SourceIncludeExclude incl excl) = object ["includes" .= incl, "excludes" .= excl]++data PatternOrPatterns+  = PopPattern Pattern+  | PopPatterns [Pattern]+  deriving (Eq, Read, Show)++instance ToJSON PatternOrPatterns where+  toJSON (PopPattern pattern) = toJSON pattern+  toJSON (PopPatterns patterns) = toJSON patterns++data Include = Include [Pattern] deriving (Eq, Read, Show)++data Exclude = Exclude [Pattern] deriving (Eq, Read, Show)++instance ToJSON Include where+  toJSON (Include patterns) = toJSON patterns++instance ToJSON Exclude where+  toJSON (Exclude patterns) = toJSON patterns++newtype Pattern = Pattern Text deriving (Eq, Read, Show)++instance ToJSON Pattern where+  toJSON (Pattern pattern) = toJSON pattern++data SearchResult a = SearchResult+  { took :: Int,+    timedOut :: Bool,+    shards :: ShardResult,+    searchHits :: SearchHits a,+    aggregations :: Maybe AggregationResults,+    -- | Only one Suggestion request / response per+    --   Search is supported.+    scrollId :: Maybe ScrollId,+    suggest :: Maybe NamedSuggestionResponse,+    pitId :: Maybe Text+  }+  deriving (Eq, Show)++instance (FromJSON a) => FromJSON (SearchResult a) where+  parseJSON (Object v) =+    SearchResult+      <$> v .: "took"+      <*> v .: "timed_out"+      <*> v .: "_shards"+      <*> v .: "hits"+      <*> v .:? "aggregations"+      <*> v .:? "_scroll_id"+      <*> v .:? "suggest"+      <*> v .:? "pit_id"+  parseJSON _ = empty++newtype ScrollId+  = ScrollId Text+  deriving (Eq, Show, Ord, ToJSON, FromJSON)++newtype SearchTemplateId = SearchTemplateId Text deriving (Eq, Show)++instance ToJSON SearchTemplateId where+  toJSON (SearchTemplateId x) = toJSON x++newtype SearchTemplateSource = SearchTemplateSource Text deriving (Eq, Show)++instance ToJSON SearchTemplateSource where+  toJSON (SearchTemplateSource x) = toJSON x++instance FromJSON SearchTemplateSource where+  parseJSON (String s) = pure $ SearchTemplateSource s+  parseJSON _ = empty++data ExpandWildcards+  = ExpandWildcardsAll+  | ExpandWildcardsOpen+  | ExpandWildcardsClosed+  | ExpandWildcardsNone+  deriving (Eq, Show)++instance ToJSON ExpandWildcards where+  toJSON ExpandWildcardsAll = String "all"+  toJSON ExpandWildcardsOpen = String "open"+  toJSON ExpandWildcardsClosed = String "closed"+  toJSON ExpandWildcardsNone = String "none"++instance FromJSON ExpandWildcards where+  parseJSON (String "all") = pure $ ExpandWildcardsAll+  parseJSON (String "open") = pure $ ExpandWildcardsOpen+  parseJSON (String "closed") = pure $ ExpandWildcardsClosed+  parseJSON (String "none") = pure $ ExpandWildcardsNone+  parseJSON _ = empty++data TimeUnits+  = TimeUnitDays+  | TimeUnitHours+  | TimeUnitMinutes+  | TimeUnitSeconds+  | TimeUnitMilliseconds+  | TimeUnitMicroseconds+  | TimeUnitNanoseconds+  deriving (Eq, Show)++instance ToJSON TimeUnits where+  toJSON TimeUnitDays = String "d"+  toJSON TimeUnitHours = String "h"+  toJSON TimeUnitMinutes = String "m"+  toJSON TimeUnitSeconds = String "s"+  toJSON TimeUnitMilliseconds = String "ms"+  toJSON TimeUnitMicroseconds = String "micros"+  toJSON TimeUnitNanoseconds = String "nanos"++instance FromJSON TimeUnits where+  parseJSON (String "d") = pure $ TimeUnitDays+  parseJSON (String "h") = pure $ TimeUnitHours+  parseJSON (String "m") = pure $ TimeUnitMinutes+  parseJSON (String "s") = pure $ TimeUnitSeconds+  parseJSON (String "ms") = pure $ TimeUnitMilliseconds+  parseJSON (String "micros") = pure $ TimeUnitMicroseconds+  parseJSON (String "nanos") = pure $ TimeUnitNanoseconds+  parseJSON _ = empty++data SearchTemplate = SearchTemplate+  { searchTemplate :: Either SearchTemplateId SearchTemplateSource,+    params :: TemplateQueryKeyValuePairs,+    explainSearchTemplate :: Maybe Bool,+    profileSearchTemplate :: Maybe Bool+  }+  deriving (Eq, Show)++instance ToJSON SearchTemplate where+  toJSON SearchTemplate {..} =+    omitNulls+      [ either ("id" .=) ("source" .=) searchTemplate,+        "params" .= params,+        "explain" .= explainSearchTemplate,+        "profile" .= profileSearchTemplate+      ]++data GetTemplateScript = GetTemplateScript+  { getTemplateScriptLang :: Maybe Text,+    getTemplateScriptSource :: Maybe SearchTemplateSource,+    getTemplateScriptOptions :: Maybe (HM.HashMap Text Text),+    getTemplateScriptId :: Text,+    getTemplateScriptFound :: Bool+  }+  deriving (Eq, Show)++instance FromJSON GetTemplateScript where+  parseJSON (Object v) = do+    script <- v .:? "script"+    maybe+      (GetTemplateScript Nothing Nothing Nothing <$> v .: "_id" <*> v .: "found")+      ( \s ->+          GetTemplateScript+            <$> s .:? "lang"+            <*> s .:? "source"+            <*> s .:? "options"+            <*> v .: "_id"+            <*> v .: "found"+      )+      script+  parseJSON _ = empty
tests/Test/Aggregation.hs view
@@ -2,137 +2,164 @@  module Test.Aggregation (spec) where -import Test.Common-import Test.Import- import Control.Error (fmapL, note) import qualified Data.Map as M import qualified Database.Bloodhound+import Test.Common+import Test.Import  spec :: Spec spec =   describe "Aggregation API" $ do-    it "returns term aggregation results" $ withTestEnv $ do-      _ <- insertData-      let terms = TermsAgg $ mkTermsAggregation "user"-      let search = mkAggregateSearch Nothing $ mkAggregations "users" terms-      searchExpectAggs search-      searchValidBucketAgg search "users" toTerms+    it "returns term aggregation results" $+      withTestEnv $ do+        _ <- insertData+        let terms = TermsAgg $ mkTermsAggregation "user"+        let search = mkAggregateSearch Nothing $ mkAggregations "users" terms+        searchExpectAggs search+        searchValidBucketAgg search "users" toTerms -    it "return sub-aggregation results" $ withTestEnv $ do-      _ <- insertData-      let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation "age"-          agg = TermsAgg $ (mkTermsAggregation "user") { termAggs = Just subaggs}-          search = mkAggregateSearch Nothing $ mkAggregations "users" agg-      reply <- searchByIndex testIndex search-      let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)-          usersAggResults = result >>= aggregations >>= toTerms "users"-          subAggResults = usersAggResults >>= (listToMaybe . buckets) >>= termsAggs >>= toTerms "age_agg"-          subAddResultsExists = isJust subAggResults-      liftIO $ subAddResultsExists `shouldBe` True+    it "return sub-aggregation results" $+      withTestEnv $ do+        _ <- insertData+        let subaggs = mkAggregations "age_agg" . TermsAgg $ mkTermsAggregation "age"+            agg = TermsAgg $ (mkTermsAggregation "user") {termAggs = Just subaggs}+            search = mkAggregateSearch Nothing $ mkAggregations "users" agg+        response <- searchByIndex testIndex search+        let result = decodeResponse response :: Maybe (SearchResult Tweet)+            usersAggResults = result >>= aggregations >>= toTerms "users"+            subAggResults = usersAggResults >>= (listToMaybe . buckets) >>= termsAggs >>= toTerms "age_agg"+            subAddResultsExists = isJust subAggResults+        liftIO $ subAddResultsExists `shouldBe` True -    it "returns cardinality aggregation results" $ withTestEnv $ do-      _ <- insertData-      let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user"-      let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality-      let search' = search { Database.Bloodhound.from = From 0, size = Size 0 }-      searchExpectAggs search'-      let docCountPair k n = (k, object ["value" .= Number n])-      res <- searchTweets search'-      liftIO $-        fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "users" 1]))+    it "returns cardinality aggregation results" $+      withTestEnv $ do+        _ <- insertData+        let cardinality = CardinalityAgg $ mkCardinalityAggregation $ FieldName "user"+        let search = mkAggregateSearch Nothing $ mkAggregations "users" cardinality+        let search' = search {Database.Bloodhound.from = From 0, size = Size 0}+        searchExpectAggs search'+        let docCountPair k n = (k, object ["value" .= Number n])+        res <- searchTweets search'+        liftIO $+          fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "users" 1])) -    it "returns stats aggregation results" $ withTestEnv $ do-      _ <- insertData-      let stats = StatsAgg $ mkStatsAggregation $ FieldName "age"-      let search = mkAggregateSearch Nothing $ mkAggregations "users" stats-      let search' = search { Database.Bloodhound.from = From 0, size = Size 0 }-      searchExpectAggs search'-      let statsAggRes k n = (k, object [ "max" .= Number n-                                       , "avg" .= Number n-                                       , "count" .= Number 1-                                       , "min" .= Number n-                                       , "sum" .= Number n])-      res <- searchTweets search'-      liftIO $-        fmap aggregations res `shouldBe` Right (Just (M.fromList [ statsAggRes "users" 10000]))+    it "returns stats aggregation results" $+      withTestEnv $ do+        _ <- insertData+        let stats = StatsAgg $ mkStatsAggregation $ FieldName "age"+        let search = mkAggregateSearch Nothing $ mkAggregations "users" stats+        let search' = search {Database.Bloodhound.from = From 0, size = Size 0}+        searchExpectAggs search'+        let statsAggRes k n =+              ( k,+                object+                  [ "max" .= Number n,+                    "avg" .= Number n,+                    "count" .= Number 1,+                    "min" .= Number n,+                    "sum" .= Number n+                  ]+              )+        res <- searchTweets search'+        liftIO $+          fmap aggregations res `shouldBe` Right (Just (M.fromList [statsAggRes "users" 10000])) -    it "can give collection hint parameters to term aggregations" $ withTestEnv $ do-      _ <- insertData-      let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst }-      let search = mkAggregateSearch Nothing $ mkAggregations "users" terms-      searchExpectAggs search-      searchValidBucketAgg search "users" toTerms+    it "can give collection hint parameters to term aggregations" $+      withTestEnv $ do+        _ <- insertData+        let terms = TermsAgg $ (mkTermsAggregation "user") {termCollectMode = Just BreadthFirst}+        let search = mkAggregateSearch Nothing $ mkAggregations "users" terms+        searchExpectAggs search+        searchValidBucketAgg search "users" toTerms -    it "can give execution hint parameters to term aggregations" $ withTestEnv $ do-      _ <- insertData-      searchTermsAggHint [GlobalOrdinals, Map]+    it "can give execution hint parameters to term aggregations" $+      withTestEnv $ do+        _ <- insertData+        searchTermsAggHint [GlobalOrdinals, Map]     -- One of the above. -    it "can execute value_count aggregations" $ withTestEnv $ do-      _ <- insertData-      _ <- insertOther-      let ags = mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user"))) <>-                mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))-      let search = mkAggregateSearch Nothing ags-      let docCountPair k n = (k, object ["value" .= Number n])-      res <- searchTweets search-      liftIO $-        fmap aggregations res `shouldBe` Right (Just (M.fromList [ docCountPair "user_count" 2-                                                                 , docCountPair "bogus_count" 0-                                                                 ]))+    it "can execute value_count aggregations" $+      withTestEnv $ do+        _ <- insertData+        _ <- insertOther+        let ags =+              mkAggregations "user_count" (ValueCountAgg (FieldValueCount (FieldName "user")))+                <> mkAggregations "bogus_count" (ValueCountAgg (FieldValueCount (FieldName "bogus")))+        let search = mkAggregateSearch Nothing ags+        let docCountPair k n = (k, object ["value" .= Number n])+        res <- searchTweets search+        liftIO $+          fmap aggregations res+            `shouldBe` Right+              ( Just+                  ( M.fromList+                      [ docCountPair "user_count" 2,+                        docCountPair "bogus_count" 0+                      ]+                  )+              ) -    it "can execute date_range aggregations" $ withTestEnv $ do-      let now = fromGregorian 2015 3 14-      let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0-      let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0-      let oldDoc = exampleTweet { postDate = ltAMonthAgo }-      let newDoc = exampleTweet { postDate = ltAWeekAgo }-      _ <- indexDocument testIndex defaultIndexDocumentSettings oldDoc (DocId "1")-      _ <- indexDocument testIndex defaultIndexDocumentSettings newDoc (DocId "2")-      _ <- refreshIndex testIndex-      let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth])-      let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek])-      let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek])-      let ags = mkAggregations "date_ranges" (DateRangeAgg agg)-      let search = mkAggregateSearch Nothing ags-      res <- searchTweets search-      liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right (HitsTotal 2 HTR_EQ)-      let bucks = do magrs <- fmapL show (aggregations <$> res)-                     agrs <- note "no aggregations returned" magrs-                     rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs-                     parseEither parseJSON rawBucks-      let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0-      let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0-      liftIO $ buckets <$> bucks `shouldBe` Right [ DateRangeResult "2015-02-14T00:00:00.000Z-*"-                                                                    (Just fromMonthT)-                                                                    (Just "2015-02-14T00:00:00.000Z")-                                                                    Nothing-                                                                    Nothing-                                                                    2-                                                                    Nothing-                                                  , DateRangeResult "2015-03-07T00:00:00.000Z-*"-                                                                    (Just fromWeekT)-                                                                    (Just "2015-03-07T00:00:00.000Z")-                                                                    Nothing-                                                                    Nothing-                                                                    1-                                                                    Nothing-                                     ]+    it "can execute date_range aggregations" $+      withTestEnv $ do+        let now = fromGregorian 2015 3 14+        let ltAMonthAgo = UTCTime (fromGregorian 2015 3 1) 0+        let ltAWeekAgo = UTCTime (fromGregorian 2015 3 10) 0+        let oldDoc = exampleTweet {postDate = ltAMonthAgo}+        let newDoc = exampleTweet {postDate = ltAWeekAgo}+        _ <- indexDocument testIndex defaultIndexDocumentSettings oldDoc (DocId "1")+        _ <- indexDocument testIndex defaultIndexDocumentSettings newDoc (DocId "2")+        _ <- refreshIndex testIndex+        let thisMonth = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMMonth])+        let thisWeek = DateRangeFrom (DateMathExpr (DMDate now) [SubtractTime 1 DMWeek])+        let agg = DateRangeAggregation (FieldName "postDate") Nothing (thisMonth :| [thisWeek])+        let ags = mkAggregations "date_ranges" (DateRangeAgg agg)+        let search = mkAggregateSearch Nothing ags+        res <- searchTweets search+        liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right (HitsTotal 2 HTR_EQ)+        let bucks = do+              magrs <- fmapL show (aggregations <$> res)+              agrs <- note "no aggregations returned" magrs+              rawBucks <- note "no date_ranges aggregation" $ M.lookup "date_ranges" agrs+              parseEither parseJSON rawBucks+        let fromMonthT = UTCTime (fromGregorian 2015 2 14) 0+        let fromWeekT = UTCTime (fromGregorian 2015 3 7) 0+        liftIO $+          buckets <$> bucks+            `shouldBe` Right+              [ DateRangeResult+                  "2015-02-14T00:00:00.000Z-*"+                  (Just fromMonthT)+                  (Just "2015-02-14T00:00:00.000Z")+                  Nothing+                  Nothing+                  2+                  Nothing,+                DateRangeResult+                  "2015-03-07T00:00:00.000Z-*"+                  (Just fromWeekT)+                  (Just "2015-03-07T00:00:00.000Z")+                  Nothing+                  Nothing+                  1+                  Nothing+              ] -    it "returns date histogram aggregation results" $ withTestEnv $ do-      _ <- insertData-      let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute-      let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)-      searchExpectAggs search-      searchValidBucketAgg search "byDate" toDateHistogram+    it "returns date histogram aggregation results" $+      withTestEnv $ do+        _ <- insertData+        let histogram = DateHistogramAgg $ mkDateHistogram (FieldName "postDate") Minute+        let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram)+        searchExpectAggs search+        searchValidBucketAgg search "byDate" toDateHistogram -    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]))+    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]))
tests/Test/ApproxEq.hs view
@@ -3,12 +3,10 @@  module Test.ApproxEq where +import qualified Data.List.NonEmpty as NE import Database.Bloodhound- import Test.Import -import qualified Data.List.NonEmpty as NE- -- | Typeclass for "equal where it matters". Use this to specify -- less-strict equivalence for things such as lists that can wind up -- in an unpredictable order@@ -23,28 +21,42 @@ a ==~ b = counterexample (showApproxEq a ++ " !=~ " ++ showApproxEq b) (a =~ b)  instance ApproxEq NominalDiffTime where (=~) = (==)+ instance ApproxEq Bool where (=~) = (==)+ instance ApproxEq Int where (=~) = (==)+ instance (Eq a, Show a) => ApproxEq (Maybe a) where (=~) = (==)+ instance ApproxEq Char where   (=~) = (==)  instance ApproxEq NodeAttrFilter where (=~) = (==)+ instance ApproxEq NodeAttrName where (=~) = (==)+ instance (Eq a, Show a) => ApproxEq (NonEmpty a) where (=~) = (==)+ instance (ApproxEq l, Show l, ApproxEq r, Show r) => ApproxEq (Either l r) where   Left a =~ Left b = a =~ b   Right a =~ Right b = a =~ b   _ =~ _ = False-  showApproxEq (Left x)  = "Left " <> showApproxEq x+  showApproxEq (Left x) = "Left " <> showApproxEq x   showApproxEq (Right x) = "Right " <> showApproxEq x+ instance (ApproxEq a, Show a) => ApproxEq [a] where   as =~ bs = and (zipWith (=~) as bs)+ instance ApproxEq ReplicaCount where (=~) = (==)+ instance ApproxEq ReplicaBounds where (=~) = (==)+ instance ApproxEq Bytes where (=~) = (==)+ instance ApproxEq AllocationPolicy where (=~) = (==)+ instance ApproxEq InitialShardCount where (=~) = (==)+ instance ApproxEq FSType where (=~) = (==)  -- | Due to the way nodeattrfilters get serialized here, they may come
tests/Test/BulkAPI.hs view
@@ -1,17 +1,16 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}  module Test.BulkAPI (spec) where -import           Test.Common-import           Test.Import--import qualified Data.Aeson.KeyMap   as X-import qualified Data.Vector         as V-import qualified Lens.Micro.Aeson    as LMA+import qualified Data.Aeson.KeyMap as X+import qualified Data.Vector as V+import qualified Lens.Micro.Aeson as LMA+import Test.Common+import Test.Import -newtype BulkTest =-  BulkTest Text+newtype BulkTest+  = BulkTest Text   deriving (Eq, Show)  instance ToJSON BulkTest where@@ -26,8 +25,8 @@         BulkTest <$> parseJSON t  data BulkScriptTest = BulkScriptTest-  { bstName    :: Text-  , bstCounter :: Int+  { bstName :: Text,+    bstCounter :: Int   }   deriving (Eq, Show) @@ -36,22 +35,25 @@     object ["name" .= name', "counter" .= count]  instance FromJSON BulkScriptTest where-  parseJSON = withObject "BulkScriptTest" $ \v -> BulkScriptTest-    <$> v.: "name"-    <*> v .: "counter"+  parseJSON = withObject "BulkScriptTest" $ \v ->+    BulkScriptTest+      <$> v .: "name"+      <*> v .: "counter"  assertDocs :: (FromJSON a, Show a, Eq a) => [(DocId, a)] -> BH IO () assertDocs as = do   let (ids, docs) = unzip as-  res <- ids &   traverse (getDocument testIndex)-             <&> traverse (fmap getSource . eitherDecode . responseBody)+  res <-+    ids & traverse (getDocument testIndex)+      <&> traverse (fmap getSource . eitherDecodeResponse)    liftIO $ res `shouldBe` Right (Just <$> docs) -upsertDocs :: (ToJSON a, Show a, Eq a)-  => (Value -> UpsertPayload)-  -> [(DocId, a)]-  -> BH IO ()+upsertDocs ::+  (ToJSON a, Show a, Eq a) =>+  (Value -> UpsertPayload) ->+  [(DocId, a)] ->+  BH IO () upsertDocs f as = do   let batch = as <&> (\(id_, doc) -> BulkUpsert testIndex id_ (f $ toJSON doc) []) & V.fromList   bulk batch >> refreshIndex testIndex >> pure ()@@ -59,128 +61,133 @@ spec :: Spec spec =   describe "Bulk API" $ do-    it "upsert operations" $ withTestEnv $ do-      _ <- insertData+    it "upsert operations" $+      withTestEnv $ do+        _ <- insertData -      -- Upserting in a to a fresh index should insert-      let toInsert = [(DocId "3", BulkTest "stringer"), (DocId "5", BulkTest "sobotka"), (DocId "7", BulkTest "snoop")]-      upsertDocs UpsertDoc toInsert-      assertDocs toInsert+        -- Upserting in a to a fresh index should insert+        let toInsert = [(DocId "3", BulkTest "stringer"), (DocId "5", BulkTest "sobotka"), (DocId "7", BulkTest "snoop")]+        upsertDocs UpsertDoc toInsert+        assertDocs toInsert -      -- Upserting existing documents should update-      let toUpsert = [(DocId "3", BulkTest "bell"), (DocId "5", BulkTest "frank"), (DocId "7", BulkTest "snoop")]-      upsertDocs UpsertDoc toUpsert-      assertDocs toUpsert+        -- Upserting existing documents should update+        let toUpsert = [(DocId "3", BulkTest "bell"), (DocId "5", BulkTest "frank"), (DocId "7", BulkTest "snoop")]+        upsertDocs UpsertDoc toUpsert+        assertDocs toUpsert -    it "upsert with a script" $ withTestEnv $ do-      _ <- insertData+    it "upsert with a script" $+      withTestEnv $ do+        _ <- insertData -      -- first insert the batch-      let batch = [(DocId "3", BulkScriptTest "stringer" 0), (DocId "5", BulkScriptTest "sobotka" 3)]-      upsertDocs UpsertDoc batch+        -- first insert the batch+        let batch = [(DocId "3", BulkScriptTest "stringer" 0), (DocId "5", BulkScriptTest "sobotka" 3)]+        upsertDocs UpsertDoc batch -      -- then upsert with the script+        -- then upsert with the script -      let script = Script-                    { scriptLanguage = Just $ ScriptLanguage "painless"-                    , scriptSource = ScriptInline "ctx._source.counter += params.count"-                    , scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)]-                    }+        let script =+              Script+                { scriptLanguage = Just $ ScriptLanguage "painless",+                  scriptSource = ScriptInline "ctx._source.counter += params.count",+                  scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)]+                } -      upsertDocs (UpsertScript False script) batch-      assertDocs (batch <&> (\(i, v) -> (i, v { bstCounter = bstCounter v + 2 })))+        upsertDocs (UpsertScript False script) batch+        assertDocs (batch <&> (\(i, v) -> (i, v {bstCounter = bstCounter v + 2}))) -    it "script upsert without scripted_upsert" $ withTestEnv $ do-      _ <- insertData+    it "script upsert without scripted_upsert" $+      withTestEnv $ do+        _ <- insertData -      let batch = [(DocId "3", BulkScriptTest "stringer" 0), (DocId "5", BulkScriptTest "sobotka" 3)]+        let batch = [(DocId "3", BulkScriptTest "stringer" 0), (DocId "5", BulkScriptTest "sobotka" 3)] -      let script = Script-                    { scriptLanguage = Just $ ScriptLanguage "painless"-                    , scriptSource = ScriptInline "ctx._source.counter += params.count"-                    , scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)]-                    }+        let script =+              Script+                { scriptLanguage = Just $ ScriptLanguage "painless",+                  scriptSource = ScriptInline "ctx._source.counter += params.count",+                  scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)]+                } -      -- Without "script_upsert" flag new documents are simply inserted and are not handled by the script-      upsertDocs (UpsertScript False script) batch-      assertDocs batch+        -- Without "script_upsert" flag new documents are simply inserted and are not handled by the script+        upsertDocs (UpsertScript False script) batch+        assertDocs batch -    it "script upsert with scripted_upsert -- will fail if a bug on elasticsearch is fix, delete patch line" $ withTestEnv $ do-      _ <- insertData+    it "script upsert with scripted_upsert -- will fail if a bug on elasticsearch is fix, delete patch line" $+      withTestEnv $ do+        _ <- insertData -      let batch = [(DocId "3", BulkScriptTest "stringer" 0), (DocId "5", BulkScriptTest "sobotka" 3)]+        let batch = [(DocId "3", BulkScriptTest "stringer" 0), (DocId "5", BulkScriptTest "sobotka" 3)] -      let script = Script-                    { scriptLanguage = Just $ ScriptLanguage "painless"-                    , scriptSource = ScriptInline "ctx._source.counter += params.count"-                    , scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)]-                    }+        let script =+              Script+                { scriptLanguage = Just $ ScriptLanguage "painless",+                  scriptSource = ScriptInline "ctx._source.counter += params.count",+                  scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)]+                } -      -- Without "script_upsert" flag new documents are simply inserted and are not handled by the script-      upsertDocs (UpsertScript True script) batch+        -- Without "script_upsert" flag new documents are simply inserted and are not handled by the script+        upsertDocs (UpsertScript True script) batch -      -- if this test fails due to a bug in ES7: https://github.com/elastic/elasticsearch/issues/48670, delete next line when it is solved.-      assertDocs (batch <&> (\(i, v) -> (i, v { bstCounter = bstCounter v + 2 })))+        -- if this test fails due to a bug in ES7: https://github.com/elastic/elasticsearch/issues/48670, delete next line when it is solved.+        assertDocs (batch <&> (\(i, v) -> (i, v {bstCounter = bstCounter v + 2}))) -    it "inserts all documents we request" $ withTestEnv $ do-      _ <- insertData-      let firstTest   = BulkTest "blah"-      let secondTest  = BulkTest "bloo"-      let thirdTest   = BulkTest "graffle"-      let fourthTest  = BulkTest "garabadoo"-      let fifthTest   = BulkTest "serenity"-      let firstDoc    = BulkIndex testIndex (DocId "2") (toJSON firstTest)-      let secondDoc   = BulkCreate testIndex (DocId "3") (toJSON secondTest)-      let thirdDoc    = BulkCreateEncoding testIndex (DocId "4") (toEncoding thirdTest)-      let fourthDoc   = BulkIndexAuto testIndex (toJSON fourthTest)-      let fifthDoc    = BulkIndexEncodingAuto testIndex (toEncoding fifthTest)-      let stream = V.fromList [firstDoc, secondDoc, thirdDoc, fourthDoc, fifthDoc]-      _ <- bulk stream-      -- liftIO $ pPrint bulkResp-      _ <- refreshIndex testIndex-      -- liftIO $ pPrint refreshResp-      fDoc <- getDocument testIndex (DocId "2")-      sDoc <- getDocument testIndex (DocId "3")-      tDoc <- getDocument testIndex (DocId "4")-      -- note that we cannot query for fourthDoc and fifthDoc since we-      -- do not know their autogenerated ids.-      let maybeFirst =-            eitherDecode-            $ responseBody fDoc-              :: Either String (EsResult BulkTest)-      let maybeSecond =-            eitherDecode-            $ responseBody sDoc-            :: Either String (EsResult BulkTest)-      let maybeThird =-            eitherDecode-            $ responseBody tDoc-            :: Either String (EsResult BulkTest)-      -- liftIO $ pPrint [maybeFirst, maybeSecond, maybeThird]-      liftIO $ do-        fmap getSource maybeFirst `shouldBe` Right (Just firstTest)-        fmap getSource maybeSecond `shouldBe` Right (Just secondTest)-        fmap getSource maybeThird `shouldBe` Right (Just thirdTest)-      -- Since we can't get the docs by doc id, we check for their existence in-      -- a match all query.-      let query = MatchAllQuery Nothing-      let search = mkSearch (Just query) Nothing-      resp <- searchByIndex testIndex search-      parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))-      case parsed of-        Left e ->-          liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)-        (Right sr) -> do-          liftIO $-            hitsTotal (searchHits sr) `shouldBe` HitsTotal 6 HTR_EQ-          let nameList :: [Text]-              nameList =-                hits (searchHits sr)-                ^.. traverse-                  . to hitSource-                  . _Just-                  . LMA.key "name"-                  . _String-          liftIO $-            nameList-            `shouldBe` ["blah","bloo","graffle","garabadoo","serenity"]+    it "inserts all documents we request" $+      withTestEnv $ do+        _ <- insertData+        let firstTest = BulkTest "blah"+        let secondTest = BulkTest "bloo"+        let thirdTest = BulkTest "graffle"+        let fourthTest = BulkTest "garabadoo"+        let fifthTest = BulkTest "serenity"+        let firstDoc = BulkIndex testIndex (DocId "2") (toJSON firstTest)+        let secondDoc = BulkCreate testIndex (DocId "3") (toJSON secondTest)+        let thirdDoc = BulkCreateEncoding testIndex (DocId "4") (toEncoding thirdTest)+        let fourthDoc = BulkIndexAuto testIndex (toJSON fourthTest)+        let fifthDoc = BulkIndexEncodingAuto testIndex (toEncoding fifthTest)+        let stream = V.fromList [firstDoc, secondDoc, thirdDoc, fourthDoc, fifthDoc]+        _ <- bulk stream+        -- liftIO $ pPrint bulkResp+        _ <- refreshIndex testIndex+        -- liftIO $ pPrint refreshResp+        fDoc <- getDocument testIndex (DocId "2")+        sDoc <- getDocument testIndex (DocId "3")+        tDoc <- getDocument testIndex (DocId "4")+        -- note that we cannot query for fourthDoc and fifthDoc since we+        -- do not know their autogenerated ids.+        let maybeFirst =+              eitherDecodeResponse fDoc ::+                Either String (EsResult BulkTest)+        let maybeSecond =+              eitherDecodeResponse sDoc ::+                Either String (EsResult BulkTest)+        let maybeThird =+              eitherDecodeResponse tDoc ::+                Either String (EsResult BulkTest)+        -- liftIO $ pPrint [maybeFirst, maybeSecond, maybeThird]+        liftIO $ do+          fmap getSource maybeFirst `shouldBe` Right (Just firstTest)+          fmap getSource maybeSecond `shouldBe` Right (Just secondTest)+          fmap getSource maybeThird `shouldBe` Right (Just thirdTest)+        -- Since we can't get the docs by doc id, we check for their existence in+        -- a match all query.+        let query = MatchAllQuery Nothing+        let search = mkSearch (Just query) Nothing+        resp <- searchByIndex testIndex search+        parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))+        case parsed of+          Left e ->+            liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)+          (Right sr) -> do+            liftIO $+              hitsTotal (searchHits sr) `shouldBe` HitsTotal 6 HTR_EQ+            let nameList :: [Text]+                nameList =+                  hits (searchHits sr)+                    ^.. traverse+                      . to hitSource+                      . _Just+                      . LMA.key "name"+                      . _String+            liftIO $+              nameList+                `shouldBe` ["blah", "bloo", "graffle", "garabadoo", "serenity"]
tests/Test/Common.hs view
@@ -1,32 +1,37 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TemplateHaskell #-}  module Test.Common where -import Test.Import- import qualified Data.Map as M import qualified Data.SemVer as SemVer import qualified Network.HTTP.Types.Status as NHTS+import Test.Import -testServer  :: Server-testServer  = Server "http://localhost:9200"-testIndex   :: IndexName-testIndex   = IndexName "bloodhound-tests-twitter-1"+testServer :: Server+testServer = Server "http://localhost:9200" +testIndex :: IndexName+testIndex = IndexName "bloodhound-tests-twitter-1"+ withTestEnv :: BH IO a -> IO a withTestEnv = withBH defaultManagerSettings testServer -data Location = Location { lat :: Double-                         , lon :: Double } deriving (Eq, Show)+data Location = Location+  { lat :: Double,+    lon :: Double+  }+  deriving (Eq, Show) -data Tweet = Tweet { user     :: Text-                   , postDate :: UTCTime-                   , message  :: Text-                   , age      :: Int-                   , location :: Location-                   , extra    :: Maybe Text }-           deriving (Eq, Show)+data Tweet = Tweet+  { user :: Text,+    postDate :: UTCTime,+    message :: Text,+    age :: Int,+    location :: Location,+    extra :: Maybe Text+  }+  deriving (Eq, Show)  $(deriveJSON defaultOptions ''Location) $(deriveJSON defaultOptions ''Tweet)@@ -35,90 +40,114 @@  instance ToJSON ConversationMapping where   toJSON ConversationMapping =-    object ["properties" .=-      object ["reply_join"  .= object [ "type"       .= ("join" :: Text)-                                      , "relations"  .= object [ "message" .= ("reply" :: Text) ]-                                      ]-            , "user"        .= object [ "type"       .= ("text" :: Text)-                                      , "fielddata"  .= True-                                      ]-            -- Serializing the date as a date is breaking other tests, mysteriously.-            -- , "postDate" .= object [ "type"   .= ("date" :: Text)-            --                        , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]-            , "message"  .= object ["type" .= ("text" :: Text)]-            , "age"      .= object ["type" .= ("integer" :: Text)]-            , "location" .= object ["type" .= ("geo_point" :: Text)]-            , "extra"    .= object ["type" .= ("keyword" :: Text)]-            ]]+    object+      [ "properties"+          .= object+            [ "reply_join"+                .= object+                  [ "type" .= ("join" :: Text),+                    "relations" .= object ["message" .= ("reply" :: Text)]+                  ],+              "user"+                .= object+                  [ "type" .= ("text" :: Text),+                    "fielddata" .= True+                  ],+              -- Serializing the date as a date is breaking other tests, mysteriously.+              -- , "postDate" .= object [ "type"   .= ("date" :: Text)+              --                        , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]+              "message" .= object ["type" .= ("text" :: Text)],+              "age" .= object ["type" .= ("integer" :: Text)],+              "location" .= object ["type" .= ("geo_point" :: Text)],+              "extra" .= object ["type" .= ("keyword" :: Text)]+            ]+      ] -getServerVersion :: IO (Maybe SemVer.Version)+getServerVersion :: IO (Either String SemVer.Version) getServerVersion = fmap extractVersion <$> withTestEnv getStatus   where-    extractVersion              = versionNumber . number . version+    extractVersion = versionNumber . number . version -createExampleIndex :: (MonadBH m) => m Reply+createExampleIndex :: (MonadBH m) => m (BHResponse Acknowledged) createExampleIndex =   createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) testIndex -deleteExampleIndex :: (MonadBH m) => m Reply+deleteExampleIndex :: (MonadBH m) => m (BHResponse Acknowledged) deleteExampleIndex =   deleteIndex testIndex -validateStatus :: Show body => Response body -> Int -> Expectation+validateStatus :: Show body => BHResponse body -> Int -> Expectation validateStatus resp expected =   if actual == expected     then return ()     else expectationFailure ("Expected " <> show expected <> " but got " <> show actual <> ": " <> show body)   where-    actual = NHTS.statusCode (responseStatus resp)-    body = responseBody resp+    actual = NHTS.statusCode (responseStatus $ getResponse resp)+    body = responseBody $ getResponse resp  data TweetMapping = TweetMapping deriving (Eq, Show)  instance ToJSON TweetMapping where   toJSON TweetMapping =-    object ["properties" .=-      object [ "user"     .= object [ "type"    .= ("text" :: Text)-                                    , "fielddata" .= True-                                    ]+    object+      [ "properties"+          .= object+            [ "user"+                .= object+                  [ "type" .= ("text" :: Text),+                    "fielddata" .= True+                  ],               -- Serializing the date as a date is breaking other tests, mysteriously.               -- , "postDate" .= object [ "type"   .= ("date" :: Text)               --                        , "format" .= ("YYYY-MM-dd`T`HH:mm:ss.SSSZZ" :: Text)]-              , "message"  .= object ["type" .= ("text" :: Text)]-              , "age"      .= object ["type" .= ("integer" :: Text)]-              , "location" .= object ["type" .= ("geo_point" :: Text)]-              , "extra"    .= object ["type" .= ("keyword" :: Text)]-              ]]+              "message" .= object ["type" .= ("text" :: Text)],+              "age" .= object ["type" .= ("integer" :: Text)],+              "location" .= object ["type" .= ("geo_point" :: Text)],+              "extra" .= object ["type" .= ("keyword" :: Text)]+            ]+      ]  exampleTweet :: Tweet-exampleTweet = Tweet { user     = "bitemyapp"-                     , postDate = UTCTime-                                  (ModifiedJulianDay 55000)-                                  (secondsToDiffTime 10)-                     , message  = "Use haskell!"-                     , age      = 10000-                     , location = Location 40.12 (-71.34)-                     , extra = Nothing }+exampleTweet =+  Tweet+    { user = "bitemyapp",+      postDate =+        UTCTime+          (ModifiedJulianDay 55000)+          (secondsToDiffTime 10),+      message = "Use haskell!",+      age = 10000,+      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" }+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"+    }  exampleTweetWithAge :: Int -> Tweet-exampleTweetWithAge age = Tweet { user     = "bitemyapp"-                                , postDate = UTCTime-                                            (ModifiedJulianDay 55000)-                                            (secondsToDiffTime 10)-                                , message  = "Use haskell!"-                                , age      = age-                                , location = Location 40.12 (-71.34)-                                , extra = Nothing }+exampleTweetWithAge age' =+  Tweet+    { user = "bitemyapp",+      postDate =+        UTCTime+          (ModifiedJulianDay 55000)+          (secondsToDiffTime 10),+      message = "Use haskell!",+      age = age',+      location = Location 40.12 (-71.34),+      extra = Nothing+    }  newAge :: Int newAge = 31337@@ -128,22 +157,27 @@  tweetPatch :: Value tweetPatch =-  object [ "age" .= newAge-         , "user" .= newUser-         ]+  object+    [ "age" .= newAge,+      "user" .= newUser+    ]  patchedTweet :: Tweet-patchedTweet = exampleTweet{age = newAge, user = newUser}+patchedTweet = exampleTweet {age = newAge, user = newUser}  otherTweet :: Tweet-otherTweet = Tweet { user     = "notmyapp"-                   , postDate = UTCTime-                                (ModifiedJulianDay 55000)-                                (secondsToDiffTime 11)-                   , message  = "Use haskell!"-                   , age      = 1000-                   , location = Location 40.12 (-71.34)-                   , extra = Nothing }+otherTweet =+  Tweet+    { user = "notmyapp",+      postDate =+        UTCTime+          (ModifiedJulianDay 55000)+          (secondsToDiffTime 11),+      message = "Use haskell!",+      age = 1000,+      location = Location 40.12 (-71.34),+      extra = Nothing+    }  resetIndex :: BH IO () resetIndex = do@@ -152,25 +186,25 @@   _ <- putMapping testIndex TweetMapping   return () -insertData :: BH IO Reply+insertData :: BH IO (BHResponse IndexedDocument) insertData = do   resetIndex   insertData' defaultIndexDocumentSettings -insertData' :: IndexDocumentSettings -> BH IO Reply+insertData' :: IndexDocumentSettings -> BH IO (BHResponse IndexedDocument) insertData' ids = do   r <- indexDocument testIndex ids exampleTweet (DocId "1")   _ <- refreshIndex testIndex   return r -insertTweetWithDocId :: Tweet -> Text -> BH IO Reply+insertTweetWithDocId :: Tweet -> Text -> BH IO (BHResponse IndexedDocument) insertTweetWithDocId tweet docId = do   let ids = defaultIndexDocumentSettings   r <- indexDocument testIndex ids tweet (DocId docId)   _ <- refreshIndex testIndex   return r -updateData :: BH IO Reply+updateData :: BH IO (BHResponse IndexedDocument) updateData = do   r <- updateDocument testIndex defaultIndexDocumentSettings tweetPatch (DocId "1")   _ <- refreshIndex testIndex@@ -213,31 +247,37 @@  searchExpectAggs :: Search -> BH IO () searchExpectAggs search = do-  reply <- searchByIndex testIndex search+  response <- searchByIndex testIndex search   let isEmpty x = return (M.null x)-  let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)+  let result = decodeResponse response :: Maybe (SearchResult Tweet)   liftIO $     (result >>= aggregations >>= isEmpty) `shouldBe` Just False -searchValidBucketAgg :: (BucketAggregation a, FromJSON a, Show a) =>-                        Search -> Key -> (Key -> AggregationResults -> Maybe (Bucket a)) -> BH IO ()+searchValidBucketAgg ::+  (BucketAggregation a, FromJSON a, Show a) =>+  Search ->+  Key ->+  (Key -> AggregationResults -> Maybe (Bucket a)) ->+  BH IO () searchValidBucketAgg search aggKey extractor = do-  reply <- searchByIndex testIndex search+  response <- searchByIndex testIndex search   let bucketDocs = docCount . head . buckets-  let result = decode (responseBody reply) :: Maybe (SearchResult Tweet)+  let result = decodeResponse response :: Maybe (SearchResult Tweet)   let count = result >>= aggregations >>= extractor aggKey >>= \x -> return (bucketDocs x)   liftIO $     count `shouldBe` Just 1  searchTermsAggHint :: [ExecutionHint] -> BH IO () searchTermsAggHint hints = do-      let terms hint = TermsAgg $ (mkTermsAggregation "user.keyword") { termExecutionHint = Just hint }-      let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint-      forM_ hints $ searchExpectAggs . search-      -- forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)+  let terms hint = TermsAgg $ (mkTermsAggregation "user.keyword") {termExecutionHint = Just hint}+  let search hint = mkAggregateSearch Nothing $ mkAggregations "users" $ terms hint+  forM_ hints $ searchExpectAggs . search -searchTweetHighlight :: Search-                     -> BH IO (Either EsError (Maybe HitHighlight))+-- forM_ hints (\x -> searchValidBucketAgg (search x) "users" toTerms)++searchTweetHighlight ::+  Search ->+  BH IO (Either EsError (Maybe HitHighlight)) searchTweetHighlight search = do   result <- searchTweets search   let tweetHit :: Either EsError (Maybe (Hit Tweet))@@ -250,18 +290,18 @@ searchExpectSource src expected = do   _ <- insertData   let query = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell")-  let search = (mkSearch (Just query) Nothing) { source = Just src }-  reply <- searchByIndex testIndex search-  result <- parseEsResponse reply+  let search = (mkSearch (Just query) Nothing) {source = Just src}+  response <- searchByIndex testIndex search+  result <- parseEsResponse response   let value_ = grabFirst result   liftIO $     value_ `shouldBe` expected  atleast :: SemVer.Version -> IO Bool-atleast v = getServerVersion >>= \x -> return $ x >= Just v+atleast v = getServerVersion >>= \x -> return $ x >= Right v  atmost :: SemVer.Version -> IO Bool-atmost v = getServerVersion >>= \x -> return $ x <= Just v+atmost v = getServerVersion >>= \x -> return $ x <= Right v  is :: SemVer.Version -> IO Bool-is v = getServerVersion >>= \x -> return $ x == Just v+is v = getServerVersion >>= \x -> return $ x == Right v
tests/Test/Count.hs view
@@ -8,9 +8,10 @@ spec :: Spec spec =   describe "Count" $-    it "returns count of a query" $ withTestEnv $ do-      _ <- insertData-      let query = MatchAllQuery Nothing-          count = CountQuery query-      c <- countByIndex testIndex count-      liftIO $ (crCount <$> c) `shouldBe` (Right 1)+    it "returns count of a query" $+      withTestEnv $ do+        _ <- insertData+        let query = MatchAllQuery Nothing+            count = CountQuery query+        c <- countByIndex testIndex count+        liftIO $ (crCount <$> c) `shouldBe` (Right 1)
tests/Test/Documents.hs view
@@ -8,52 +8,60 @@ spec :: Spec spec =   describe "document API" $ do-    it "indexes, updates, gets, and then deletes the generated document" $ withTestEnv $ do-      _ <- insertData-      _ <- updateData-      docInserted <- getDocument testIndex (DocId "1")-      let newTweet = eitherDecode-                     (responseBody docInserted) :: Either String (EsResult Tweet)-      liftIO $ fmap getSource newTweet `shouldBe` Right (Just patchedTweet)+    it "indexes, updates, gets, and then deletes the generated document" $+      withTestEnv $ do+        _ <- insertData+        _ <- updateData+        docInserted <- getDocument testIndex (DocId "1")+        let newTweet =+              eitherDecodeResponse docInserted ::+                Either String (EsResult Tweet)+        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-      docInserted <- getDocument testIndex (DocId "Hello World")-      let newTweet = eitherDecode-                     (responseBody docInserted) :: Either String (EsResult Tweet)-      liftIO $ fmap getSource newTweet `shouldBe` Right (Just exampleTweet)+    it "indexes, gets, and then deletes the generated document with a DocId containing a space" $+      withTestEnv $ do+        _ <- insertWithSpaceInId+        docInserted <- getDocument testIndex (DocId "Hello World")+        let newTweet =+              eitherDecodeResponse docInserted ::+                Either String (EsResult Tweet)+        liftIO $ fmap getSource newTweet `shouldBe` Right (Just exampleTweet) -    it "produces a parseable result when looking up a bogus document" $ withTestEnv $ do-      doc <- getDocument testIndex (DocId "bogus")-      let noTweet = eitherDecode-                    (responseBody doc) :: Either String (EsResult Tweet)-      liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing+    it "produces a parseable result when looking up a bogus document" $+      withTestEnv $ do+        doc <- getDocument testIndex (DocId "bogus")+        let noTweet =+              eitherDecodeResponse doc ::+                Either String (EsResult Tweet)+        liftIO $ fmap foundResult noTweet `shouldBe` Right Nothing -    it "can use optimistic concurrency control" $ withTestEnv $ do-      let ev = ExternalDocVersion minBound-      let cfg = defaultIndexDocumentSettings { idsVersionControl = ExternalGT ev }-      resetIndex-      res <- insertData' cfg-      liftIO $ isCreated res `shouldBe` True-      res' <- insertData' cfg-      liftIO $ isVersionConflict res' `shouldBe` True+    it "can use optimistic concurrency control" $+      withTestEnv $ do+        let ev = ExternalDocVersion minBound+        let cfg = defaultIndexDocumentSettings {idsVersionControl = ExternalGT ev}+        resetIndex+        res <- insertData' cfg+        liftIO $ isCreated res `shouldBe` True+        res' <- insertData' cfg+        liftIO $ isVersionConflict res' `shouldBe` True -    it "indexes two documents in a parent/child relationship and checks that the child exists" $ withTestEnv $ do-      resetIndex-      _ <- putMapping testIndex ConversationMapping+    it "indexes two documents in a parent/child relationship and checks that the child exists" $+      withTestEnv $ do+        resetIndex+        _ <- putMapping testIndex ConversationMapping -      let parentSettings = defaultIndexDocumentSettings { idsJoinRelation = Just (ParentDocument (FieldName "reply_join") (RelationName "message")) }-      let childSettings = defaultIndexDocumentSettings { idsJoinRelation = Just (ChildDocument (FieldName "reply_join") (RelationName "reply") (DocId "1")) }+        let parentSettings = defaultIndexDocumentSettings {idsJoinRelation = Just (ParentDocument (FieldName "reply_join") (RelationName "message"))}+        let childSettings = defaultIndexDocumentSettings {idsJoinRelation = Just (ChildDocument (FieldName "reply_join") (RelationName "reply") (DocId "1"))} -      _ <- indexDocument testIndex parentSettings exampleTweet (DocId "1")-      _ <- indexDocument testIndex childSettings otherTweet (DocId "2")+        _ <- indexDocument testIndex parentSettings exampleTweet (DocId "1")+        _ <- indexDocument testIndex childSettings otherTweet (DocId "2") -      _ <- refreshIndex testIndex+        _ <- refreshIndex testIndex -      let query = QueryHasParentQuery $ HasParentQuery (RelationName "message") (MatchAllQuery Nothing) Nothing Nothing-      let search = mkSearch (Just query) Nothing+        let query = QueryHasParentQuery $ HasParentQuery (RelationName "message") (MatchAllQuery Nothing) Nothing Nothing+        let search = mkSearch (Just query) Nothing -      resp <- searchByIndex testIndex search-      parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))+        resp <- searchByIndex testIndex search+        parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value)) -      liftIO $ fmap (hitsTotal . searchHits) parsed `shouldBe` Right (HitsTotal 1 HTR_EQ)+        liftIO $ fmap (hitsTotal . searchHits) parsed `shouldBe` Right (HitsTotal 1 HTR_EQ)
tests/Test/Generators.hs view
@@ -1,22 +1,19 @@-{-# LANGUAGE CPP                        #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE OverloadedStrings #-}  module Test.Generators where -import           Database.Bloodhound--import           Test.Import--import qualified Data.Aeson.KeyMap   as X+import qualified Data.Aeson.KeyMap as X import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Map as M-import qualified Data.Text as T import qualified Data.SemVer as SemVer--import           Generic.Random-import           Test.ApproxEq+import qualified Data.Text as T+import Database.Bloodhound+import Generic.Random+import Test.ApproxEq+import Test.Import  instance Arbitrary NominalDiffTime where   arbitrary = fromInteger <$> arbitrary@@ -30,15 +27,16 @@   arbitrary = T.pack <$> arbitrary  instance Arbitrary UTCTime where-  arbitrary = UTCTime-          <$> arbitrary-          <*> (fromRational . toRational <$> choose (0::Double, 86400))+  arbitrary =+    UTCTime+      <$> arbitrary+      <*> (fromRational . toRational <$> choose (0 :: Double, 86400))  instance Arbitrary Day where-    arbitrary =-      ModifiedJulianDay . (2000 +) <$> arbitrary-    shrink =-      (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay+  arbitrary =+    ModifiedJulianDay . (2000 +) <$> arbitrary+  shrink =+    (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay  #if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary a => Arbitrary (NonEmpty a) where@@ -49,14 +47,15 @@ arbitraryScore = fmap getPositive <$> arbitrary  instance (Arbitrary a, Typeable a) => Arbitrary (Hit a) where-  arbitrary = Hit <$> arbitrary-                  <*> arbitrary-                  <*> arbitraryScore-                  <*> arbitrary-                  <*> return Nothing-                  <*> arbitrary-                  <*> arbitrary-                  <*> return Nothing+  arbitrary =+    Hit <$> arbitrary+      <*> arbitrary+      <*> arbitraryScore+      <*> arbitrary+      <*> return Nothing+      <*> arbitrary+      <*> arbitrary+      <*> return Nothing  instance Arbitrary HitFields where   arbitrary = pure (HitFields M.empty)@@ -78,41 +77,47 @@     hs <- arbitrary     return $ SearchHits tot score hs - reduceSize :: Gen a -> Gen a reduceSize f = sized $ \n -> resize (n `div` 2) f  arbitraryAlphaNum :: Gen Char-arbitraryAlphaNum = oneof [choose ('a', 'z')-                          ,choose ('A','Z')-                          , choose ('0', '9')]+arbitraryAlphaNum =+  oneof+    [ choose ('a', 'z'),+      choose ('A', 'Z'),+      choose ('0', '9')+    ]  instance Arbitrary RoutingValue where   arbitrary = RoutingValue . T.pack <$> listOf1 arbitraryAlphaNum  instance Arbitrary AliasRouting where-  arbitrary = oneof [allAlias-                    ,one-                    ,theOther-                    ,both']-    where one = GranularAliasRouting-                <$> (Just <$> arbitrary)-                <*> pure Nothing-          theOther = GranularAliasRouting Nothing-                     <$> (Just <$> arbitrary)-          both' = GranularAliasRouting-                 <$> (Just <$> arbitrary)-                 <*> (Just <$> arbitrary)-          allAlias = AllAliasRouting <$> arbitrary--+  arbitrary =+    oneof+      [ allAlias,+        one,+        theOther,+        both'+      ]+    where+      one =+        GranularAliasRouting+          <$> (Just <$> arbitrary)+          <*> pure Nothing+      theOther =+        GranularAliasRouting Nothing+          <$> (Just <$> arbitrary)+      both' =+        GranularAliasRouting+          <$> (Just <$> arbitrary)+          <*> (Just <$> arbitrary)+      allAlias = AllAliasRouting <$> arbitrary  instance Arbitrary FieldName where   arbitrary =-        FieldName+    FieldName       . T.pack-    <$> listOf1 arbitraryAlphaNum-+      <$> listOf1 arbitraryAlphaNum  #if MIN_VERSION_base(4,10,0) -- Test.QuickCheck.Modifiers@@ -128,67 +133,75 @@ #endif instance Arbitrary ScriptFields where   arbitrary =-    pure $ ScriptFields $-      X.fromList []+    pure $+      ScriptFields $+        X.fromList []    shrink = const []  instance Arbitrary ScriptParams where   arbitrary =-    pure $ ScriptParams $-      X.fromList [ ("a", Number 42)-                  , ("b", String "forty two")-                  ]+    pure $+      ScriptParams $+        X.fromList+          [ ("a", Number 42),+            ("b", String "forty two")+          ]    shrink = const []  instance Arbitrary RegexpFlags where-  arbitrary = oneof [ pure AllRegexpFlags-                    , pure NoRegexpFlags-                    , SomeRegexpFlags <$> genUniqueFlags-                    ]-    where genUniqueFlags =-                NE.fromList . L.nub-            <$> listOf1 arbitrary+  arbitrary =+    oneof+      [ pure AllRegexpFlags,+        pure NoRegexpFlags,+        SomeRegexpFlags <$> genUniqueFlags+      ]+    where+      genUniqueFlags =+        NE.fromList . L.nub+          <$> listOf1 arbitrary  instance Arbitrary IndexAliasCreate where   arbitrary =-        IndexAliasCreate-    <$> arbitrary-    <*> reduceSize arbitrary+    IndexAliasCreate+      <$> arbitrary+      <*> reduceSize arbitrary  instance Arbitrary Query where   arbitrary =-    reduceSize-    $ oneof [ TermQuery <$> arbitrary <*> arbitrary-            , TermsQuery <$> arbitrary <*> arbitrary-            , QueryMatchQuery <$> arbitrary-            , QueryMultiMatchQuery <$> arbitrary-            , QueryBoolQuery <$> arbitrary-            , QueryBoostingQuery <$> arbitrary-            , QueryCommonTermsQuery <$> arbitrary-            , ConstantScoreQuery <$> arbitrary <*> arbitrary-            , QueryDisMaxQuery <$> arbitrary-            , QueryFuzzyLikeThisQuery <$> arbitrary-            , QueryFuzzyLikeFieldQuery <$> arbitrary-            , QueryFuzzyQuery <$> arbitrary-            , QueryHasChildQuery <$> arbitrary-            , QueryHasParentQuery <$> arbitrary-            , IdsQuery <$> arbitrary-            , QueryIndicesQuery <$> arbitrary-            , MatchAllQuery <$> arbitrary-            , QueryMoreLikeThisQuery <$> arbitrary-            , QueryMoreLikeThisFieldQuery <$> arbitrary-            , QueryNestedQuery <$> arbitrary-            , QueryPrefixQuery <$> arbitrary-            , QueryQueryStringQuery <$> arbitrary-            , QuerySimpleQueryStringQuery <$> arbitrary-            , QueryRangeQuery <$> arbitrary-            , QueryRegexpQuery <$> arbitrary-            ]-  -- TODO: Implement shrink-  -- shrink = genericShrink+    reduceSize $+      oneof+        [ TermQuery <$> arbitrary <*> arbitrary,+          TermsQuery <$> arbitrary <*> arbitrary,+          QueryMatchQuery <$> arbitrary,+          QueryMultiMatchQuery <$> arbitrary,+          QueryBoolQuery <$> arbitrary,+          QueryBoostingQuery <$> arbitrary,+          QueryCommonTermsQuery <$> arbitrary,+          ConstantScoreQuery <$> arbitrary <*> arbitrary,+          QueryDisMaxQuery <$> arbitrary,+          QueryFuzzyLikeThisQuery <$> arbitrary,+          QueryFuzzyLikeFieldQuery <$> arbitrary,+          QueryFuzzyQuery <$> arbitrary,+          QueryHasChildQuery <$> arbitrary,+          QueryHasParentQuery <$> arbitrary,+          IdsQuery <$> arbitrary,+          QueryIndicesQuery <$> arbitrary,+          MatchAllQuery <$> arbitrary,+          QueryMoreLikeThisQuery <$> arbitrary,+          QueryMoreLikeThisFieldQuery <$> arbitrary,+          QueryNestedQuery <$> arbitrary,+          QueryPrefixQuery <$> arbitrary,+          QueryQueryStringQuery <$> arbitrary,+          QuerySimpleQueryStringQuery <$> arbitrary,+          QueryRangeQuery <$> arbitrary,+          QueryRegexpQuery <$> arbitrary+        ] +-- TODO: Implement shrink+-- shrink = genericShrink+ instance Arbitrary Filter where   arbitrary =     Filter <$> arbitrary@@ -196,24 +209,26 @@     Filter <$> shrink q  instance Arbitrary ReplicaBounds where-  arbitrary = oneof [ replicasBounded-                    , replicasLowerBounded-                    , pure ReplicasUnbounded-                    ]-    where replicasBounded = do-            Positive a <- arbitrary-            Positive b <- arbitrary-            return (ReplicasBounded a b)-          replicasLowerBounded = do-            Positive a <- arbitrary-            return (ReplicasLowerBounded a)+  arbitrary =+    oneof+      [ replicasBounded,+        replicasLowerBounded,+        pure ReplicasUnbounded+      ]+    where+      replicasBounded = do+        Positive a <- arbitrary+        Positive b <- arbitrary+        return (ReplicasBounded a b)+      replicasLowerBounded = do+        Positive a <- arbitrary+        return (ReplicasLowerBounded a)  instance Arbitrary NodeAttrName where   arbitrary =-        NodeAttrName+    NodeAttrName       . T.pack-    <$> listOf1 arbitraryAlphaNum-+      <$> listOf1 arbitraryAlphaNum  instance Arbitrary NodeAttrFilter where   arbitrary = do@@ -222,9 +237,10 @@     let (s, ss) = unpackConsPartial xs         ts = T.pack <$> s :| ss     return (NodeAttrFilter n ts)-      where -- listOf1 means this shouldn't blow up.-            unpackConsPartial (x : xs) = (x, xs)-            unpackConsPartial _ = error "unpackConsPartial failed but shouldn't have"+    where+      -- listOf1 means this shouldn't blow up.+      unpackConsPartial (x : xs) = (x, xs)+      unpackConsPartial _ = error "unpackConsPartial failed but shouldn't have"  instance Arbitrary VersionNumber where   arbitrary = do@@ -240,188 +256,334 @@   shrink (TemplateQueryKeyValuePairs x) = map (TemplateQueryKeyValuePairs . X.fromList) . shrink $ X.toList x  instance Arbitrary IndexName where arbitrary = genericArbitraryU+ instance Arbitrary DocId where arbitrary = genericArbitraryU+ instance Arbitrary Version where arbitrary = genericArbitraryU+ instance Arbitrary BuildHash where arbitrary = genericArbitraryU+ instance Arbitrary IndexAliasRouting where arbitrary = genericArbitraryU+ instance Arbitrary ShardCount where arbitrary = genericArbitraryU+ instance Arbitrary ReplicaCount where arbitrary = genericArbitraryU+ instance Arbitrary TemplateName where arbitrary = genericArbitraryU+ instance Arbitrary IndexPattern where arbitrary = genericArbitraryU+ instance Arbitrary QueryString where arbitrary = genericArbitraryU+ instance Arbitrary CacheName where arbitrary = genericArbitraryU+ instance Arbitrary CacheKey where arbitrary = genericArbitraryU+ instance Arbitrary Existence where arbitrary = genericArbitraryU+ instance Arbitrary CutoffFrequency where arbitrary = genericArbitraryU+ instance Arbitrary Analyzer where arbitrary = genericArbitraryU+ instance Arbitrary MaxExpansions where arbitrary = genericArbitraryU+ instance Arbitrary Lenient where arbitrary = genericArbitraryU+ instance Arbitrary Tiebreaker where arbitrary = genericArbitraryU+ instance Arbitrary Boost where arbitrary = genericArbitraryU+ instance Arbitrary BoostTerms where arbitrary = genericArbitraryU+ instance Arbitrary MinimumMatch where arbitrary = genericArbitraryU+ instance Arbitrary DisableCoord where arbitrary = genericArbitraryU+ instance Arbitrary IgnoreTermFrequency where arbitrary = genericArbitraryU+ instance Arbitrary MinimumTermFrequency where arbitrary = genericArbitraryU+ instance Arbitrary MaxQueryTerms where arbitrary = genericArbitraryU+ instance Arbitrary Fuzziness where arbitrary = genericArbitraryU+ instance Arbitrary PrefixLength where arbitrary = genericArbitraryU+ instance Arbitrary RelationName where arbitrary = genericArbitraryU+ instance Arbitrary PercentMatch where arbitrary = genericArbitraryU+ instance Arbitrary StopWord where arbitrary = genericArbitraryU+ instance Arbitrary QueryPath where arbitrary = genericArbitraryU+ instance Arbitrary AllowLeadingWildcard where arbitrary = genericArbitraryU+ instance Arbitrary LowercaseExpanded where arbitrary = genericArbitraryU+ instance Arbitrary EnablePositionIncrements where arbitrary = genericArbitraryU+ instance Arbitrary AnalyzeWildcard where arbitrary = genericArbitraryU+ instance Arbitrary GeneratePhraseQueries where arbitrary = genericArbitraryU+ instance Arbitrary Locale where arbitrary = genericArbitraryU+ instance Arbitrary MaxWordLength where arbitrary = genericArbitraryU+ instance Arbitrary MinWordLength where arbitrary = genericArbitraryU+ instance Arbitrary PhraseSlop where arbitrary = genericArbitraryU+ instance Arbitrary MinDocFrequency where arbitrary = genericArbitraryU+ instance Arbitrary MaxDocFrequency where arbitrary = genericArbitraryU+ instance Arbitrary Regexp where arbitrary = genericArbitraryU+ instance Arbitrary SimpleQueryStringQuery where arbitrary = genericArbitraryU+ instance Arbitrary FieldOrFields where arbitrary = genericArbitraryU+ instance Arbitrary SimpleQueryFlag where arbitrary = genericArbitraryU+ instance Arbitrary RegexpQuery where arbitrary = genericArbitraryU+ instance Arbitrary QueryStringQuery where arbitrary = genericArbitraryU+ instance Arbitrary RangeQuery where arbitrary = genericArbitraryU+ instance Arbitrary RangeValue where arbitrary = genericArbitraryU+ instance Arbitrary PrefixQuery where arbitrary = genericArbitraryU+ instance Arbitrary NestedQuery where arbitrary = genericArbitraryU+ instance Arbitrary MoreLikeThisFieldQuery where arbitrary = genericArbitraryU+ instance Arbitrary MoreLikeThisQuery where arbitrary = genericArbitraryU+ instance Arbitrary IndicesQuery where arbitrary = genericArbitraryU+ instance Arbitrary IgnoreUnmapped where arbitrary = genericArbitraryU+ instance Arbitrary MinChildren where arbitrary = genericArbitraryU+ instance Arbitrary MaxChildren where arbitrary = genericArbitraryU+ instance Arbitrary AggregateParentScore where arbitrary = genericArbitraryU+ instance Arbitrary HasParentQuery where arbitrary = genericArbitraryU+ instance Arbitrary HasChildQuery where arbitrary = genericArbitraryU+ instance Arbitrary FuzzyQuery where arbitrary = genericArbitraryU+ instance Arbitrary FuzzyLikeFieldQuery where arbitrary = genericArbitraryU+ instance Arbitrary FuzzyLikeThisQuery where arbitrary = genericArbitraryU+ instance Arbitrary DisMaxQuery where arbitrary = genericArbitraryU+ instance Arbitrary CommonTermsQuery where arbitrary = genericArbitraryU+ instance Arbitrary DistanceRange where arbitrary = genericArbitraryU+ instance Arbitrary MultiMatchQuery where arbitrary = genericArbitraryU+ instance Arbitrary LessThanD where arbitrary = genericArbitraryU+ instance Arbitrary LessThanEqD where arbitrary = genericArbitraryU+ instance Arbitrary GreaterThanD where arbitrary = genericArbitraryU+ instance Arbitrary GreaterThanEqD where arbitrary = genericArbitraryU+ instance Arbitrary LessThan where arbitrary = genericArbitraryU+ instance Arbitrary LessThanEq where arbitrary = genericArbitraryU+ instance Arbitrary GreaterThan where arbitrary = genericArbitraryU+ instance Arbitrary GreaterThanEq where arbitrary = genericArbitraryU+ instance Arbitrary GeoPoint where arbitrary = genericArbitraryU+ instance Arbitrary NullValue where arbitrary = genericArbitraryU+ instance Arbitrary MinimumMatchHighLow where arbitrary = genericArbitraryU+ instance Arbitrary CommonMinimumMatch where arbitrary = genericArbitraryU+ instance Arbitrary BoostingQuery where arbitrary = genericArbitraryU+ instance Arbitrary BoolQuery where arbitrary = genericArbitraryU+ instance Arbitrary MatchQuery where arbitrary = genericArbitraryU+ instance Arbitrary MultiMatchQueryType where arbitrary = genericArbitraryU+ instance Arbitrary BooleanOperator where arbitrary = genericArbitraryU+ instance Arbitrary ZeroTermsQuery where arbitrary = genericArbitraryU+ instance Arbitrary MatchQueryType where arbitrary = genericArbitraryU+ instance Arbitrary SearchAliasRouting where arbitrary = genericArbitraryU+ instance Arbitrary ScoreType where arbitrary = genericArbitraryU+ instance Arbitrary Distance where arbitrary = genericArbitraryU+ instance Arbitrary DistanceUnit where arbitrary = genericArbitraryU+ instance Arbitrary DistanceType where arbitrary = genericArbitraryU+ instance Arbitrary OptimizeBbox where arbitrary = genericArbitraryU+ instance Arbitrary GeoBoundingBoxConstraint where arbitrary = genericArbitraryU+ instance Arbitrary GeoFilterType where arbitrary = genericArbitraryU+ instance Arbitrary GeoBoundingBox where arbitrary = genericArbitraryU+ instance Arbitrary LatLon where arbitrary = genericArbitraryU+ instance Arbitrary RangeExecution where arbitrary = genericArbitraryU+ instance Arbitrary RegexpFlag where arbitrary = genericArbitraryU+ instance Arbitrary BoolMatch where arbitrary = genericArbitraryU+ instance Arbitrary Term where arbitrary = genericArbitraryU+ instance Arbitrary IndexMappingsLimits where arbitrary = genericArbitraryU+ instance Arbitrary IndexSettings where arbitrary = genericArbitraryU+ instance Arbitrary TokenChar where arbitrary = genericArbitraryU+ instance Arbitrary Ngram where arbitrary = genericArbitraryU+ instance Arbitrary TokenizerDefinition where arbitrary = genericArbitraryU+ instance Arbitrary TokenFilter where arbitrary = genericArbitraryU+ instance Arbitrary NgramFilter where arbitrary = genericArbitraryU+ instance Arbitrary EdgeNgramFilterSide where arbitrary = genericArbitraryU+ instance Arbitrary TokenFilterDefinition where arbitrary = genericArbitraryU+ instance Arbitrary Language where arbitrary = genericArbitraryU+ instance Arbitrary Shingle where arbitrary = genericArbitraryU  instance Arbitrary CharFilter where arbitrary = genericArbitraryU+ instance Arbitrary AnalyzerDefinition where arbitrary = genericArbitraryU  -- TODO: This should have a proper generator that doesn't -- create garbage that has to be filtered out. instance Arbitrary CharFilterDefinition where   arbitrary =-    oneof [   CharFilterDefinitionMapping-            . chomp <$> arbitrary-          , CharFilterDefinitionPatternReplace-            <$> arbitrary <*> arbitrary <*> arbitrary-                    ]-    where chomp =-              M.map T.strip-            . M.mapKeys (T.replace "=>" "" . T.strip)+    oneof+      [ CharFilterDefinitionMapping+          . chomp+          <$> arbitrary,+        CharFilterDefinitionPatternReplace+          <$> arbitrary <*> arbitrary <*> arbitrary+      ]+    where+      chomp =+        M.map T.strip+          . M.mapKeys (T.replace "=>" "" . T.strip)  instance Arbitrary Analysis where arbitrary = genericArbitraryU+ instance Arbitrary Tokenizer where arbitrary = genericArbitraryU+ instance Arbitrary Compression where arbitrary = genericArbitraryU+ instance Arbitrary Bytes where arbitrary = genericArbitraryU+ instance Arbitrary AllocationPolicy where arbitrary = genericArbitraryU+ instance Arbitrary InitialShardCount where arbitrary = genericArbitraryU+ instance Arbitrary FSType where arbitrary = genericArbitraryU+ instance Arbitrary CompoundFormat where arbitrary = genericArbitraryU+ instance Arbitrary FsSnapshotRepo where arbitrary = genericArbitraryU+ instance Arbitrary SnapshotRepoName where arbitrary = genericArbitraryU+ instance Arbitrary DirectGeneratorSuggestModeTypes where arbitrary = genericArbitraryU+ instance Arbitrary DirectGenerators where arbitrary = genericArbitraryU+ instance Arbitrary PhraseSuggesterCollate where arbitrary = genericArbitraryU+ instance Arbitrary PhraseSuggesterHighlighter where arbitrary = genericArbitraryU+ instance Arbitrary Size where arbitrary = genericArbitraryU+ instance Arbitrary PhraseSuggester where arbitrary = genericArbitraryU+ instance Arbitrary SuggestType where arbitrary = genericArbitraryU+ instance Arbitrary Suggest where arbitrary = genericArbitraryU  instance Arbitrary FunctionScoreQuery where arbitrary = genericArbitraryU  instance Arbitrary FunctionScoreFunction where arbitrary = genericArbitraryU+ instance Arbitrary FunctionScoreFunctions where arbitrary = genericArbitraryU+ instance Arbitrary ComponentFunctionScoreFunction where arbitrary = genericArbitraryU+ instance Arbitrary Script where arbitrary = genericArbitraryU+ instance Arbitrary ScriptLanguage where arbitrary = genericArbitraryU+ instance Arbitrary ScriptSource where arbitrary = genericArbitraryU+ instance Arbitrary ScoreMode where arbitrary = genericArbitraryU+ instance Arbitrary BoostMode where arbitrary = genericArbitraryU+ instance Arbitrary Seed where arbitrary = genericArbitraryU+ instance Arbitrary FieldValueFactor where arbitrary = genericArbitraryU+ instance Arbitrary Weight where arbitrary = genericArbitraryU+ instance Arbitrary Factor where arbitrary = genericArbitraryU+ instance Arbitrary FactorMissingFieldValue where arbitrary = genericArbitraryU+ instance Arbitrary FactorModifier where arbitrary = genericArbitraryU  instance Arbitrary UpdatableIndexSetting where   arbitrary = resize 10 genericArbitraryU -newtype UpdatableIndexSetting' =-  UpdatableIndexSetting' UpdatableIndexSetting+newtype UpdatableIndexSetting'+  = UpdatableIndexSetting' UpdatableIndexSetting   deriving (Show, Eq, ToJSON, FromJSON, ApproxEq, Typeable)  instance Arbitrary UpdatableIndexSetting' where   arbitrary = do     settings <- arbitrary-    return $ UpdatableIndexSetting' $ case settings of-      RoutingAllocationInclude xs ->-        RoutingAllocationInclude (dropDuplicateAttrNames xs)-      RoutingAllocationExclude xs ->-        RoutingAllocationExclude (dropDuplicateAttrNames xs)-      RoutingAllocationRequire xs ->-        RoutingAllocationRequire (dropDuplicateAttrNames xs)-      x -> x+    return $+      UpdatableIndexSetting' $ case settings of+        RoutingAllocationInclude xs ->+          RoutingAllocationInclude (dropDuplicateAttrNames xs)+        RoutingAllocationExclude xs ->+          RoutingAllocationExclude (dropDuplicateAttrNames xs)+        RoutingAllocationRequire xs ->+          RoutingAllocationRequire (dropDuplicateAttrNames xs)+        x -> x     where       dropDuplicateAttrNames =         NE.fromList . L.nubBy sameAttrName . NE.toList
tests/Test/Highlights.hs view
@@ -2,11 +2,10 @@  module Test.Highlights where +import qualified Data.Map as M import Test.Common import Test.Import -import qualified Data.Map as M- initHighlights :: Text -> BH IO (Either EsError (Maybe HitHighlight)) initHighlights fieldName = do   _ <- insertData@@ -19,14 +18,16 @@ spec :: Spec spec =   describe "Highlights API" $ do-    it "returns highlight from query when there should be one" $ withTestEnv $ do-      myHighlight <- initHighlights "message"-      liftIO $-        myHighlight `shouldBe`-          Right (Just (M.fromList [("message", ["Use <em>haskell</em>!"])]))+    it "returns highlight from query when there should be one" $+      withTestEnv $ do+        myHighlight <- initHighlights "message"+        liftIO $+          myHighlight+            `shouldBe` Right (Just (M.fromList [("message", ["Use <em>haskell</em>!"])])) -    it "doesn't return highlight from a query when it shouldn't" $ withTestEnv $ do-      myHighlight <- initHighlights "user"-      liftIO $-        myHighlight `shouldBe`-          Right Nothing+    it "doesn't return highlight from a query when it shouldn't" $+      withTestEnv $ do+        myHighlight <- initHighlights "user"+        liftIO $+          myHighlight+            `shouldBe` Right Nothing
tests/Test/Import.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}  module Test.Import-  ( module X-  , module Test.Import-  ) where-+  ( module X,+    module Test.Import,+  )+where  import Control.Applicative as X import Control.Exception as X (evaluate)@@ -14,13 +14,14 @@ import Data.Aeson as X import Data.Aeson.TH as X import Data.Aeson.Types as X (parseEither)+import qualified Data.List as L+import Data.List.NonEmpty as X (NonEmpty (..)) import Data.Maybe as X-import Data.List.NonEmpty as X (NonEmpty(..)) import Data.Monoid as X import Data.Ord as X (comparing) import Data.Proxy as X import Data.Text as X (Text)-import Data.Time.Calendar as X (Day(..), fromGregorian)+import Data.Time.Calendar as X (Day (..), fromGregorian) import Data.Time.Clock as X import Data.Typeable as X import Database.Bloodhound as X hiding (key)@@ -35,8 +36,6 @@ import Test.QuickCheck.Property.Monoid as X (T (..), eq, prop_Monoid) import Text.Pretty.Simple as X (pPrint) -import qualified Data.List as L- noDuplicates :: Eq a => [a] -> Bool noDuplicates xs = L.nub xs == xs @@ -46,8 +45,8 @@ grabFirst :: Either EsError (SearchResult a) -> Either EsError a grabFirst r =   case fmap (hitSource . head . hits . searchHits) r of-    (Left e)         -> Left e-    (Right Nothing)  -> Left (EsError 500 "Source was missing")+    (Left e) -> Left e+    (Right Nothing) -> Left (EsError 500 "Source was missing")     (Right (Just x)) -> Right x  when' :: Monad m => m Bool -> m () -> m ()
tests/Test/Indices.hs view
@@ -2,11 +2,10 @@  module Test.Indices where -import Test.Common-import Test.Import- import qualified Data.List as L import qualified Data.Map as M+import Test.Common+import Test.Import  checkHasSettings :: [UpdatableIndexSetting] -> BH IO () checkHasSettings settings = do@@ -18,14 +17,15 @@ spec :: Spec spec = do   describe "Index create/delete API" $ do-    it "creates and then deletes the requested index" $ withTestEnv $ do-      -- priming state.-      _ <- deleteExampleIndex-      resp <- createExampleIndex-      deleteResp <- deleteExampleIndex-      liftIO $ do-        validateStatus resp 200-        validateStatus deleteResp 200+    it "creates and then deletes the requested index" $+      withTestEnv $ do+        -- priming state.+        _ <- deleteExampleIndex+        resp <- createExampleIndex+        deleteResp <- deleteExampleIndex+        liftIO $ do+          validateStatus resp 200+          validateStatus deleteResp 200    describe "Index aliases" $ do     let aname = IndexAliasName (IndexName "bloodhound-tests-twitter-1-alias")@@ -38,12 +38,15 @@         resp <- updateIndexAliases (action :| [])         liftIO $ validateStatus resp 200       let cleanup = withTestEnv (updateIndexAliases (RemoveAlias alias :| []))-      (do aliases <- withTestEnv getIndexAliases+      ( do+          aliases <- withTestEnv getIndexAliases           let expected = IndexAliasSummary alias create           case aliases of             Right (IndexAliasesSummary summs) ->               L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected-            Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)) `finally` cleanup+            Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)+        )+        `finally` cleanup     it "allows alias deletion" $ do       aliases <- withTestEnv $ do         resetIndex@@ -54,115 +57,134 @@       -- let expected = IndexAliasSummary alias create       case aliases of         Right (IndexAliasesSummary summs) ->-          L.find ( (== aname)-                   . indexAlias-                   . indexAliasSummaryAlias-                 ) summs-          `shouldBe` Nothing+          L.find+            ( (== aname)+                . indexAlias+                . indexAliasSummaryAlias+            )+            summs+            `shouldBe` Nothing         Left e -> expectationFailure ("Expected an IndexAliasesSummary but got " <> show e)    describe "Index Listing" $ do-    it "returns a list of index names" $ withTestEnv $ do-      _ <- createExampleIndex-      ixns <- listIndices-      liftIO (ixns `shouldContain` [testIndex])+    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-      _ <- createExampleIndex-      let updates = BlocksWrite False :| []-      updateResp <- updateIndexSettings updates testIndex-      liftIO $ validateStatus updateResp 200-      checkHasSettings [BlocksWrite False]+    it "persists settings" $+      withTestEnv $ do+        _ <- deleteExampleIndex+        _ <- createExampleIndex+        let updates = BlocksWrite False :| []+        updateResp <- updateIndexSettings updates testIndex+        liftIO $ validateStatus updateResp 200+        checkHasSettings [BlocksWrite False] -    it "allows total fields to be set" $ withTestEnv $ do-      _ <- deleteExampleIndex-      _ <- createExampleIndex-      let updates = MappingTotalFieldsLimit 2500 :| []-      updateResp <- updateIndexSettings updates testIndex-      liftIO $ validateStatus updateResp 200-      checkHasSettings [MappingTotalFieldsLimit 2500]+    it "allows total fields to be set" $+      withTestEnv $ do+        _ <- deleteExampleIndex+        _ <- createExampleIndex+        let updates = MappingTotalFieldsLimit 2500 :| []+        updateResp <- updateIndexSettings updates testIndex+        liftIO $ validateStatus updateResp 200+        checkHasSettings [MappingTotalFieldsLimit 2500] -    it "allows unassigned.node_left.delayed_timeout to be set" $ withTestEnv $ do-      _ <- deleteExampleIndex-      _ <- createExampleIndex-      let updates = UnassignedNodeLeftDelayedTimeout 10 :| []-      updateResp <- updateIndexSettings updates testIndex-      liftIO $ validateStatus updateResp 200-      checkHasSettings [UnassignedNodeLeftDelayedTimeout 10]+    it "allows unassigned.node_left.delayed_timeout to be set" $+      withTestEnv $ do+        _ <- deleteExampleIndex+        _ <- createExampleIndex+        let updates = UnassignedNodeLeftDelayedTimeout 10 :| []+        updateResp <- updateIndexSettings updates testIndex+        liftIO $ validateStatus updateResp 200+        checkHasSettings [UnassignedNodeLeftDelayedTimeout 10] -    it "accepts customer analyzers" $ withTestEnv $ do-      _ <- deleteExampleIndex-      let analysis = Analysis-            (M.singleton "ex_analyzer"-              ( AnalyzerDefinition-                (Just (Tokenizer "ex_tokenizer"))-                (map TokenFilter-                  [ "ex_filter_lowercase","ex_filter_uppercase","ex_filter_apostrophe"-                  , "ex_filter_reverse","ex_filter_snowball"-                  , "ex_filter_shingle"-                  ]+    it "accepts customer analyzers" $+      withTestEnv $ do+        _ <- deleteExampleIndex+        let analysis =+              Analysis+                ( M.singleton+                    "ex_analyzer"+                    ( AnalyzerDefinition+                        (Just (Tokenizer "ex_tokenizer"))+                        ( map+                            TokenFilter+                            [ "ex_filter_lowercase",+                              "ex_filter_uppercase",+                              "ex_filter_apostrophe",+                              "ex_filter_reverse",+                              "ex_filter_snowball",+                              "ex_filter_shingle"+                            ]+                        )+                        ( map+                            CharFilter+                            ["html_strip", "ex_mapping", "ex_pattern_replace"]+                        )+                    )                 )-                (map CharFilter-                  ["html_strip", "ex_mapping", "ex_pattern_replace"]+                ( M.singleton+                    "ex_tokenizer"+                    ( TokenizerDefinitionNgram+                        (Ngram 3 4 [TokenLetter, TokenDigit])+                    )                 )-              )-            )-            (M.singleton "ex_tokenizer"-              ( TokenizerDefinitionNgram-                ( Ngram 3 4 [TokenLetter,TokenDigit])-              )-            )-            (M.fromList-              [ ("ex_filter_lowercase",TokenFilterDefinitionLowercase (Just Greek))-              , ("ex_filter_uppercase",TokenFilterDefinitionUppercase Nothing)-              , ("ex_filter_apostrophe",TokenFilterDefinitionApostrophe)-              , ("ex_filter_reverse",TokenFilterDefinitionReverse)-              , ("ex_filter_snowball",TokenFilterDefinitionSnowball English)-              , ("ex_filter_shingle",TokenFilterDefinitionShingle (Shingle 3 3 True False " " "_"))-              , ("ex_filter_stemmer",TokenFilterDefinitionStemmer German)-              , ("ex_filter_stop1", TokenFilterDefinitionStop (Left French))-              , ("ex_filter_stop2",-                 TokenFilterDefinitionStop-                 (Right-                  $ map StopWord ["a", "is", "the"]))-             ]-            )-            (M.fromList-             [ ("ex_mapping", CharFilterDefinitionMapping (M.singleton "١" "1"))-             , ("ex_pattern_replace", CharFilterDefinitionPatternReplace "(\\d+)-(?=\\d)" "$1_" Nothing)-             ]-            )-          updates = [AnalysisSetting analysis]-      createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex-      liftIO $ validateStatus createResp 200-      checkHasSettings updates--    it "accepts default compression codec" $ withTestEnv $ do-      _ <- deleteExampleIndex-      let updates = [CompressionSetting CompressionDefault]-      createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex-      liftIO $ validateStatus createResp 200-      checkHasSettings updates+                ( M.fromList+                    [ ("ex_filter_lowercase", TokenFilterDefinitionLowercase (Just Greek)),+                      ("ex_filter_uppercase", TokenFilterDefinitionUppercase Nothing),+                      ("ex_filter_apostrophe", TokenFilterDefinitionApostrophe),+                      ("ex_filter_reverse", TokenFilterDefinitionReverse),+                      ("ex_filter_snowball", TokenFilterDefinitionSnowball English),+                      ("ex_filter_shingle", TokenFilterDefinitionShingle (Shingle 3 3 True False " " "_")),+                      ("ex_filter_stemmer", TokenFilterDefinitionStemmer German),+                      ("ex_filter_stop1", TokenFilterDefinitionStop (Left French)),+                      ( "ex_filter_stop2",+                        TokenFilterDefinitionStop+                          ( Right $+                              map StopWord ["a", "is", "the"]+                          )+                      )+                    ]+                )+                ( M.fromList+                    [ ("ex_mapping", CharFilterDefinitionMapping (M.singleton "١" "1")),+                      ("ex_pattern_replace", CharFilterDefinitionPatternReplace "(\\d+)-(?=\\d)" "$1_" Nothing)+                    ]+                )+            updates = [AnalysisSetting analysis]+        createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex+        liftIO $ validateStatus createResp 200+        checkHasSettings updates -    it "accepts best compression codec" $ withTestEnv $ do-      _ <- deleteExampleIndex-      let updates = [CompressionSetting CompressionBest]-      createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex-      liftIO $ validateStatus createResp 200-      checkHasSettings updates+    it "accepts default compression codec" $+      withTestEnv $ do+        _ <- deleteExampleIndex+        let updates = [CompressionSetting CompressionDefault]+        createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex+        liftIO $ validateStatus createResp 200+        checkHasSettings updates +    it "accepts best compression codec" $+      withTestEnv $ do+        _ <- deleteExampleIndex+        let updates = [CompressionSetting CompressionBest]+        createResp <- createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex+        liftIO $ validateStatus createResp 200+        checkHasSettings updates    describe "Index Optimization" $ do-    it "returns a successful response upon completion" $ withTestEnv $ do-      _ <- createExampleIndex-      resp <- forceMergeIndex (IndexList (testIndex :| [])) defaultForceMergeIndexSettings-      liftIO $ validateStatus resp 200-+    it "returns a successful response upon completion" $+      withTestEnv $ do+        _ <- createExampleIndex+        resp <- forceMergeIndex (IndexList (testIndex :| [])) defaultForceMergeIndexSettings+        liftIO $ validateStatus resp 200    describe "Index flushing" $ do-    it "returns a successful response upon flushing" $ withTestEnv $ do-      _ <- createExampleIndex-      resp <- flushIndex testIndex-      liftIO $ validateStatus resp 200+    it "returns a successful response upon flushing" $+      withTestEnv $ do+        _ <- createExampleIndex+        resp <- flushIndex testIndex+        liftIO $ validateStatus resp 200
tests/Test/JSON.hs view
@@ -1,51 +1,61 @@-{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}  module Test.JSON (spec) where -import Test.Import- import qualified Data.Aeson.KeyMap as X import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Vector as V- import Test.ApproxEq import Test.Generators+import Test.Import -propJSON :: forall a-          . ( Arbitrary a-            , ToJSON a-            , FromJSON a-            , Show a-            , Eq a-            , Typeable a-            )-         => Proxy a -> Spec+propJSON ::+  forall a.+  ( Arbitrary a,+    ToJSON a,+    FromJSON a,+    Show a,+    Eq a,+    Typeable a+  ) =>+  Proxy a ->+  Spec propJSON _ = prop testName $ \(a :: a) ->   let jsonStr = "via " <> BL8.unpack (encode a)-  in counterexample jsonStr (parseEither parseJSON (toJSON a)-                             === Right a)-  where testName = show ty <> " FromJSON/ToJSON roundtrips"-        ty = typeOf (undefined :: a)+   in counterexample+        jsonStr+        ( parseEither parseJSON (toJSON a)+            === Right a+        )+  where+    testName = show ty <> " FromJSON/ToJSON roundtrips"+    ty = typeOf (undefined :: a) -propApproxJSON :: forall a-                . ( Arbitrary a-                  , ToJSON a-                  , FromJSON a-                  , Show a-                  , ApproxEq a-                  , Typeable a-                  )-               => Proxy a -> Spec+propApproxJSON ::+  forall a.+  ( Arbitrary a,+    ToJSON a,+    FromJSON a,+    Show a,+    ApproxEq a,+    Typeable a+  ) =>+  Proxy a ->+  Spec propApproxJSON _ = prop testName $ \(a :: a) ->   let jsonStr = "via " <> BL8.unpack (encode a)-  in counterexample jsonStr (parseEither parseJSON (toJSON a)-                             ==~ Right a)-  where testName = show ty <> " FromJSON/ToJSON roundtrips"-        ty = typeOf (undefined :: a)+   in counterexample+        jsonStr+        ( parseEither parseJSON (toJSON a)+            ==~ Right a+        )+  where+    testName = show ty <> " FromJSON/ToJSON roundtrips"+    ty = typeOf (undefined :: a)  spec :: Spec spec = do@@ -57,38 +67,63 @@       toJSON NoRegexpFlags `shouldBe` String "NONE"      it "generates the correct JSON for SomeRegexpFlags" $-      let flags = AnyString :| [ Automaton-                               , Complement-                               , Empty-                               , Intersection-                               , Interval ]-      in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"+      let flags =+            AnyString+              :| [ Automaton,+                   Complement,+                   Empty,+                   Intersection,+                   Interval+                 ]+       in toJSON (SomeRegexpFlags flags) `shouldBe` String "ANYSTRING|AUTOMATON|COMPLEMENT|EMPTY|INTERSECTION|INTERVAL"      prop "removes duplicates from flags" $ \(flags :: RegexpFlags) ->       let String str = toJSON flags-          flagStrs   = T.splitOn "|" str-      in noDuplicates flagStrs+          flagStrs = T.splitOn "|" str+       in noDuplicates flagStrs    describe "omitNulls" $ do     it "checks that omitNulls drops list elements when it should" $-       let dropped = omitNulls $ [ "test1" .= (toJSON ([] :: [Int]))-                                 , "test2" .= (toJSON ("some value" :: Text))]+      let dropped =+            omitNulls $+              [ "test1" .= (toJSON ([] :: [Int])),+                "test2" .= (toJSON ("some value" :: Text))+              ]        in dropped `shouldBe` Object (X.fromList [("test2", String "some value")])      it "checks that omitNulls doesn't drop list elements when it shouldn't" $-       let notDropped = omitNulls $ [ "test1" .= (toJSON ([1] :: [Int]))-                                    , "test2" .= (toJSON ("some value" :: Text))]-       in notDropped `shouldBe` Object (X.fromList [ ("test1", Array (V.fromList [Number 1.0]))-                                                 , ("test2", String "some value")])+      let notDropped =+            omitNulls $+              [ "test1" .= (toJSON ([1] :: [Int])),+                "test2" .= (toJSON ("some value" :: Text))+              ]+       in notDropped+            `shouldBe` Object+              ( X.fromList+                  [ ("test1", Array (V.fromList [Number 1.0])),+                    ("test2", String "some value")+                  ]+              )     it "checks that omitNulls drops non list elements when it should" $-       let dropped = omitNulls $ [ "test1" .= (toJSON Null)-                                 , "test2" .= (toJSON ("some value" :: Text))]+      let dropped =+            omitNulls $+              [ "test1" .= (toJSON Null),+                "test2" .= (toJSON ("some value" :: Text))+              ]        in dropped `shouldBe` Object (X.fromList [("test2", String "some value")])     it "checks that omitNulls doesn't drop non list elements when it shouldn't" $-       let notDropped = omitNulls $ [ "test1" .= (toJSON (1 :: Int))-                                    , "test2" .= (toJSON ("some value" :: Text))]-       in notDropped `shouldBe` Object (X.fromList [ ("test1", Number 1.0)-                                                   , ("test2", String "some value")])+      let notDropped =+            omitNulls $+              [ "test1" .= (toJSON (1 :: Int)),+                "test2" .= (toJSON ("some value" :: Text))+              ]+       in notDropped+            `shouldBe` Object+              ( X.fromList+                  [ ("test1", Number 1.0),+                    ("test2", String "some value")+                  ]+              )    describe "Exact isomorphism JSON instances" $ do     propJSON (Proxy :: Proxy Version)@@ -190,9 +225,9 @@     propJSON (Proxy :: Proxy RangeExecution)     prop "RegexpFlags FromJSON/ToJSON roundtrips, removing dups " $ \rfs ->       let expected = case rfs of-                       SomeRegexpFlags fs -> SomeRegexpFlags (NE.fromList (L.nub (NE.toList fs)))-                       x -> x-      in parseEither parseJSON (toJSON rfs) === Right expected+            SomeRegexpFlags fs -> SomeRegexpFlags (NE.fromList (L.nub (NE.toList fs)))+            x -> x+       in parseEither parseJSON (toJSON rfs) === Right expected     propJSON (Proxy :: Proxy BoolMatch)     propJSON (Proxy :: Proxy Term)     propJSON (Proxy :: Proxy MultiMatchQuery)
tests/Test/Query.hs view
@@ -2,150 +2,175 @@  module Test.Query where +import qualified Data.Aeson.KeyMap as X import Test.Common import Test.Import -import qualified Data.Aeson.KeyMap as X- spec :: Spec spec =   describe "query API" $ do-    it "returns document for term query and identity filter" $ withTestEnv $ do-      _ <- insertData-      let query = TermQuery (Term "user" "bitemyapp") Nothing-      let filter' = Filter $ MatchAllQuery Nothing-      let search = mkSearch (Just query) (Just filter')-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for term query and identity filter" $+      withTestEnv $ do+        _ <- insertData+        let query = TermQuery (Term "user" "bitemyapp") Nothing+        let filter' = Filter $ MatchAllQuery Nothing+        let search = mkSearch (Just query) (Just filter')+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "handles constant score queries" $ withTestEnv $ do-      _ <- insertData-      let query = TermsQuery "user" ("bitemyapp" :| [])-      let cfQuery = ConstantScoreQuery query (Boost 1.0)-      let filter' = Filter $ MatchAllQuery Nothing-      let search = mkSearch (Just cfQuery) (Just filter')-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "handles constant score queries" $+      withTestEnv $ do+        _ <- insertData+        let query = TermsQuery "user" ("bitemyapp" :| [])+        let cfQuery = ConstantScoreQuery query (Boost 1.0)+        let filter' = Filter $ MatchAllQuery Nothing+        let search = mkSearch (Just cfQuery) (Just filter')+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for terms query and identity filter" $ withTestEnv $ do-      _ <- insertData-      let query = TermsQuery "user" ("bitemyapp" :| [])-      let filter' = Filter $ MatchAllQuery Nothing-      let search = mkSearch (Just query) (Just filter')-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for terms query and identity filter" $+      withTestEnv $ do+        _ <- insertData+        let query = TermsQuery "user" ("bitemyapp" :| [])+        let filter' = Filter $ MatchAllQuery Nothing+        let search = mkSearch (Just query) (Just filter')+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for match query" $ withTestEnv $ do-      _ <- insertData-      let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")-      let search = mkSearch (Just query) Nothing-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for match query" $+      withTestEnv $ do+        _ <- insertData+        let query = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")+        let search = mkSearch (Just query) Nothing+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for match query with fuzziness" $ withTestEnv $ do-      _ <- insertData-      let match = mkMatchQuery (FieldName "user") (QueryString "bidemyapp")-      let query = QueryMatchQuery $ match { matchQueryFuzziness = Just FuzzinessAuto }-      let search = mkSearch (Just query) Nothing-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for match query with fuzziness" $+      withTestEnv $ do+        _ <- insertData+        let match = mkMatchQuery (FieldName "user") (QueryString "bidemyapp")+        let query = QueryMatchQuery $ match {matchQueryFuzziness = Just FuzzinessAuto}+        let search = mkSearch (Just query) Nothing+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for multi-match query" $ withTestEnv $ do-      _ <- insertData-      let flds = [FieldName "user", FieldName "message"]-      let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")-      let search = mkSearch (Just query) Nothing-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for multi-match query" $+      withTestEnv $ do+        _ <- insertData+        let flds = [FieldName "user", FieldName "message"]+        let query = QueryMultiMatchQuery $ mkMultiMatchQuery flds (QueryString "bitemyapp")+        let search = mkSearch (Just query) Nothing+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for multi-match query with a custom tiebreaker" $ withTestEnv $ do-      _ <- insertData-      let tiebreaker = Just $ Tiebreaker 0.3-          flds = [FieldName "user", FieldName "message"]-          multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")-          query =  QueryMultiMatchQuery $ multiQuery' { multiMatchQueryTiebreaker = tiebreaker }-          search = mkSearch (Just query) Nothing-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for multi-match query with a custom tiebreaker" $+      withTestEnv $ do+        _ <- insertData+        let tiebreaker = Just $ Tiebreaker 0.3+            flds = [FieldName "user", FieldName "message"]+            multiQuery' = mkMultiMatchQuery flds (QueryString "bitemyapp")+            query = QueryMultiMatchQuery $ multiQuery' {multiMatchQueryTiebreaker = tiebreaker}+            search = mkSearch (Just query) Nothing+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for bool query" $ withTestEnv $ do-      _ <- insertData-      let innerQuery = QueryMatchQuery $-                       mkMatchQuery (FieldName "user") (QueryString "bitemyapp")-      let query = QueryBoolQuery $-                  mkBoolQuery [innerQuery] [] [] []-      let search = mkSearch (Just query) Nothing-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for bool query" $+      withTestEnv $ do+        _ <- insertData+        let innerQuery =+              QueryMatchQuery $+                mkMatchQuery (FieldName "user") (QueryString "bitemyapp")+        let query =+              QueryBoolQuery $+                mkBoolQuery [innerQuery] [] [] []+        let search = mkSearch (Just query) Nothing+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for boosting query" $ withTestEnv $ do-      _ <- insertData-      let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")-      let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")-      let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)-      let search = mkSearch (Just query) Nothing-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for boosting query" $+      withTestEnv $ do+        _ <- insertData+        let posQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "bitemyapp")+        let negQuery = QueryMatchQuery $ mkMatchQuery (FieldName "user") (QueryString "notmyapp")+        let query = QueryBoostingQuery $ BoostingQuery posQuery negQuery (Boost 0.2)+        let search = mkSearch (Just query) Nothing+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for common terms query" $ withTestEnv $ do-      _ <- insertData-      let query = QueryCommonTermsQuery $-                  CommonTermsQuery (FieldName "user")+    it "returns document for common terms query" $+      withTestEnv $ do+        _ <- insertData+        let query =+              QueryCommonTermsQuery $+                CommonTermsQuery+                  (FieldName "user")                   (QueryString "bitemyapp")                   (CutoffFrequency 0.0001)-                  Or Or Nothing Nothing Nothing Nothing-      let search = mkSearch (Just query) Nothing-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+                  Or+                  Or+                  Nothing+                  Nothing+                  Nothing+                  Nothing+        let search = mkSearch (Just query) Nothing+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet -    it "returns document for template query" $ withTestEnv $ do-      _ <- insertData-      let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }"-          templateParams = TemplateQueryKeyValuePairs $ X.fromList-            [ ("my_field", "user")-            , ("my_value", "bitemyapp")-            ]-          search = mkSearchTemplate (Right query) templateParams-      response <- parseEsResponse =<< searchByIndexTemplate testIndex search-      let myTweet = grabFirst response-      liftIO $ myTweet `shouldBe` Right exampleTweet+    it "returns document for template query" $+      withTestEnv $ do+        _ <- insertData+        let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }"+            templateParams =+              TemplateQueryKeyValuePairs $+                X.fromList+                  [ ("my_field", "user"),+                    ("my_value", "bitemyapp")+                  ]+            search = mkSearchTemplate (Right query) templateParams+        response <- parseEsResponse =<< searchByIndexTemplate testIndex search+        let myTweet = grabFirst response+        liftIO $ myTweet `shouldBe` Right exampleTweet -    it "can save, use, read and delete template queries" $ withTestEnv $ do-      _ <- insertData-      let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }"-          templateParams = TemplateQueryKeyValuePairs $ X.fromList-            [ ("my_field", "user")-            , ("my_value", "bitemyapp")-            ]-          tid = SearchTemplateId "myTemplate"-          search = mkSearchTemplate (Left tid) templateParams-      _ <- storeSearchTemplate tid query-      r1 <- getSearchTemplate tid-      let t1 = eitherDecode $ responseBody r1 :: Either String GetTemplateScript-      liftIO $ t1 `shouldBe` Right (GetTemplateScript {getTemplateScriptLang = Just "mustache", getTemplateScriptSource = Just (SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }"), getTemplateScriptOptions = Nothing, getTemplateScriptId = "myTemplate", getTemplateScriptFound = True})-      response <- parseEsResponse =<< searchByIndexTemplate testIndex search-      _ <- deleteSearchTemplate tid-      r2 <- getSearchTemplate tid-      let myTweet = grabFirst response-          t2 = eitherDecode $ responseBody r2 :: Either String GetTemplateScript-      liftIO $ do-        t2 `shouldBe` Right (GetTemplateScript {getTemplateScriptLang = Nothing, getTemplateScriptSource = Nothing, getTemplateScriptOptions = Nothing, getTemplateScriptId = "myTemplate", getTemplateScriptFound = False})-        myTweet `shouldBe` Right exampleTweet+    it "can save, use, read and delete template queries" $+      withTestEnv $ do+        _ <- insertData+        let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }"+            templateParams =+              TemplateQueryKeyValuePairs $+                X.fromList+                  [ ("my_field", "user"),+                    ("my_value", "bitemyapp")+                  ]+            tid = SearchTemplateId "myTemplate"+            search = mkSearchTemplate (Left tid) templateParams+        _ <- storeSearchTemplate tid query+        r1 <- getSearchTemplate tid+        let t1 = eitherDecodeResponse r1 :: Either String GetTemplateScript+        liftIO $ t1 `shouldBe` Right (GetTemplateScript {getTemplateScriptLang = Just "mustache", getTemplateScriptSource = Just (SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }"), getTemplateScriptOptions = Nothing, getTemplateScriptId = "myTemplate", getTemplateScriptFound = True})+        response <- parseEsResponse =<< searchByIndexTemplate testIndex search+        _ <- deleteSearchTemplate tid+        r2 <- getSearchTemplate tid+        let myTweet = grabFirst response+            t2 = eitherDecodeResponse r2 :: Either String GetTemplateScript+        liftIO $ do+          t2 `shouldBe` Right (GetTemplateScript {getTemplateScriptLang = Nothing, getTemplateScriptSource = Nothing, getTemplateScriptOptions = Nothing, getTemplateScriptId = "myTemplate", getTemplateScriptFound = False})+          myTweet `shouldBe` Right exampleTweet -    it "returns document for wildcard query" $ withTestEnv $ do-      _ <- insertData-      let query = QueryWildcardQuery $ WildcardQuery (FieldName "user") "bitemy*" (Nothing)-      let search = mkSearch (Just query) Nothing-      myTweet <- searchTweet search-      liftIO $-        myTweet `shouldBe` Right exampleTweet+    it "returns document for wildcard query" $+      withTestEnv $ do+        _ <- insertData+        let query = QueryWildcardQuery $ WildcardQuery (FieldName "user") "bitemy*" Nothing+        let search = mkSearch (Just query) Nothing+        myTweet <- searchTweet search+        liftIO $+          myTweet `shouldBe` Right exampleTweet
tests/Test/Script.hs view
@@ -2,34 +2,36 @@  module Test.Script where -import Test.Common-import Test.Import- import qualified Data.Aeson.KeyMap as X import qualified Data.Map as M+import Test.Common+import Test.Import  spec :: Spec spec =   describe "Script" $-    it "returns a transformed document based on the script field" $ withTestEnv $ do-      _ <- insertData-      let query = MatchAllQuery Nothing-          sfv = toJSON $-            Script-            (Just (ScriptLanguage "painless"))-            (ScriptInline "doc['age'].value * 2")-            Nothing-          sf = ScriptFields $-            X.fromList [("test1", sfv)]-          search' = mkSearch (Just query) Nothing-          search = search' { scriptFields = Just sf }-      resp <- searchByIndex testIndex search-      parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))-      case parsed of-        Left e ->-          liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)-        Right sr -> do-          let Just results =-                hitFields (head (hits (searchHits sr)))-          liftIO $-            results `shouldBe` HitFields (M.fromList [("test1", [Number 20000.0])])+    it "returns a transformed document based on the script field" $+      withTestEnv $ do+        _ <- insertData+        let query = MatchAllQuery Nothing+            sfv =+              toJSON $+                Script+                  (Just (ScriptLanguage "painless"))+                  (ScriptInline "doc['age'].value * 2")+                  Nothing+            sf =+              ScriptFields $+                X.fromList [("test1", sfv)]+            search' = mkSearch (Just query) Nothing+            search = search' {scriptFields = Just sf}+        resp <- searchByIndex testIndex search+        parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Value))+        case parsed of+          Left e ->+            liftIO $ expectationFailure ("Expected a script-transformed result but got: " <> show e)+          Right sr -> do+            let Just results =+                  hitFields (head (hits (searchHits sr)))+            liftIO $+              results `shouldBe` HitFields (M.fromList [("test1", [Number 20000.0])])
tests/Test/Snapshots.hs view
@@ -1,19 +1,17 @@-{-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Test.Snapshots (spec) where -import Test.Common-import Test.Import- import qualified Data.Aeson.KeyMap as X import qualified Data.List as L import qualified Data.Text as T import qualified Data.Vector as V import qualified Network.HTTP.Types.Method as NHTM import qualified Network.URI as URI-+import Test.Common import Test.Generators ()+import Test.Import  spec :: Spec spec = do@@ -22,103 +20,122 @@       fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)    describe "Snapshot repos" $ do-    it "always parses all snapshot repos API" $ when' canSnapshot $ withTestEnv $ do-      res <- getSnapshotRepos AllSnapshotRepos-      liftIO $ case res of-        Left e -> expectationFailure ("Expected a right but got Left " <> show e)-        Right _ -> return ()+    it "always parses all snapshot repos API" $+      when' canSnapshot $+        withTestEnv $ do+          res <- getSnapshotRepos AllSnapshotRepos+          liftIO $ case res of+            Left e -> expectationFailure ("Expected a right but got Left " <> show e)+            Right _ -> return () -    it "finds an existing list of repos" $ when' canSnapshot $ withTestEnv $ do-      let r1n = SnapshotRepoName "bloodhound-repo1"-      let r2n = SnapshotRepoName "bloodhound-repo2"-      withSnapshotRepo r1n $ \r1 ->-        withSnapshotRepo r2n $ \r2 -> do-          repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))-          liftIO $ case repos of-            Right xs -> do-              let srt = L.sortBy (comparing gSnapshotRepoName)-              srt xs `shouldBe` srt [r1, r2]-            Left e -> expectationFailure (show e)+    it "finds an existing list of repos" $+      when' canSnapshot $+        withTestEnv $ do+          let r1n = SnapshotRepoName "bloodhound-repo1"+          let r2n = SnapshotRepoName "bloodhound-repo2"+          withSnapshotRepo r1n $ \r1 ->+            withSnapshotRepo r2n $ \r2 -> do+              repos <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))+              liftIO $ case repos of+                Right xs -> do+                  let srt = L.sortOn gSnapshotRepoName+                  srt xs `shouldBe` srt [r1, r2]+                Left e -> expectationFailure (show e) -    it "creates and updates with updateSnapshotRepo" $ when' canSnapshot $ withTestEnv $ do-      let r1n = SnapshotRepoName "bloodhound-repo1"-      withSnapshotRepo r1n $ \r1 -> do-        let Just (String dir) = X.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))-        let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing-        resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression-        liftIO (validateStatus resp 200)-        Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))-        liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)+    it "creates and updates with updateSnapshotRepo" $+      when' canSnapshot $+        withTestEnv $ do+          let r1n = SnapshotRepoName "bloodhound-repo1"+          withSnapshotRepo r1n $ \r1 -> do+            let Just (String dir) = X.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))+            let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing+            resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression+            liftIO (validateStatus resp 200)+            Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))+            liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)      -- verify came around in 1.4 it seems-    it "can verify existing repos" $ when' canSnapshot $ withTestEnv $ do-      let r1n = SnapshotRepoName "bloodhound-repo1"-      withSnapshotRepo r1n $ \_ -> do-        res <- verifySnapshotRepo r1n-        liftIO $ case res of-          Right (SnapshotVerification vs)-            | null vs -> expectationFailure "Expected nonempty set of verifying nodes"-            | otherwise -> return ()-          Left e -> expectationFailure (show e)+    it "can verify existing repos" $+      when' canSnapshot $+        withTestEnv $ do+          let r1n = SnapshotRepoName "bloodhound-repo1"+          withSnapshotRepo r1n $ \_ -> do+            res <- verifySnapshotRepo r1n+            liftIO $ case res of+              Right (SnapshotVerification vs)+                | null vs -> expectationFailure "Expected nonempty set of verifying nodes"+                | otherwise -> return ()+              Left e -> expectationFailure (show e)    describe "Snapshots" $ do-    it "always parses all snapshots API" $ when' canSnapshot $ withTestEnv $ do-      let r1n = SnapshotRepoName "bloodhound-repo1"-      withSnapshotRepo r1n $ \_ -> do-        res <- getSnapshots r1n AllSnapshots-        liftIO $ case res of-          Left e -> expectationFailure ("Expected a right but got Left " <> show e)-          Right _ -> return ()+    it "always parses all snapshots API" $+      when' canSnapshot $+        withTestEnv $ do+          let r1n = SnapshotRepoName "bloodhound-repo1"+          withSnapshotRepo r1n $ \_ -> do+            res <- getSnapshots r1n AllSnapshots+            liftIO $ case res of+              Left e -> expectationFailure ("Expected a right but got Left " <> show e)+              Right _ -> return () -    it "can parse a snapshot that it created" $ when' canSnapshot $ withTestEnv $ do-      let r1n = SnapshotRepoName "bloodhound-repo1"-      withSnapshotRepo r1n $ \_ -> do-        let s1n = SnapshotName "example-snapshot"-        withSnapshot r1n s1n $ do-          res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))-          liftIO $ case res of-            Right [snap]-              | snapInfoState snap == SnapshotSuccess &&-                snapInfoName snap == s1n -> return ()-              | otherwise -> expectationFailure (show snap)-            Right [] -> expectationFailure "There were no snapshots"-            Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))-            Left e -> expectationFailure (show e)+    it "can parse a snapshot that it created" $+      when' canSnapshot $+        withTestEnv $ do+          let r1n = SnapshotRepoName "bloodhound-repo1"+          withSnapshotRepo r1n $ \_ -> do+            let s1n = SnapshotName "example-snapshot"+            withSnapshot r1n s1n $ do+              res <- getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))+              liftIO $ case res of+                Right [snap]+                  | snapInfoState snap == SnapshotSuccess+                      && snapInfoName snap == s1n ->+                    return ()+                  | otherwise -> expectationFailure (show snap)+                Right [] -> expectationFailure "There were no snapshots"+                Right snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))+                Left e -> expectationFailure (show e)    describe "Snapshot restore" $ do-    it "can restore a snapshot that we create" $ when' canSnapshot $ withTestEnv $ do-      let r1n = SnapshotRepoName "bloodhound-repo1"-      withSnapshotRepo r1n $ \_ -> do-        let s1n = SnapshotName "example-snapshot"-        withSnapshot r1n s1n $ do-          let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True }-          -- have to close an index to restore it-          resp1 <- closeIndex testIndex-          liftIO (validateStatus resp1 200)-          resp2 <- restoreSnapshot r1n s1n settings-          liftIO (validateStatus resp2 200)+    it "can restore a snapshot that we create" $+      when' canSnapshot $+        withTestEnv $ do+          let r1n = SnapshotRepoName "bloodhound-repo1"+          withSnapshotRepo r1n $ \_ -> do+            let s1n = SnapshotName "example-snapshot"+            withSnapshot r1n s1n $ do+              let settings = defaultSnapshotRestoreSettings {snapRestoreWaitForCompletion = True}+              -- have to close an index to restore it+              resp1 <- closeIndex testIndex+              liftIO (validateStatus resp1 200)+              resp2 <- restoreSnapshot r1n s1n settings+              liftIO (validateStatus resp2 200) -    it "can restore and rename" $ when' canSnapshot $ withTestEnv $ do-      let r1n = SnapshotRepoName "bloodhound-repo1"-      withSnapshotRepo r1n $ \_ -> do-        let s1n = SnapshotName "example-snapshot"-        withSnapshot r1n s1n $ do-          let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"-          let replace = RRTLit "restored-" :| [RRSubWholeMatch]-          let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"-          let overrides = RestoreIndexSettings { restoreOverrideReplicas = Just (ReplicaCount 0) }-          let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True-                                                        , snapRestoreRenamePattern = Just pat-                                                        , snapRestoreRenameReplacement = Just replace-                                                        , snapRestoreIndexSettingsOverrides = Just overrides-                                                        }-          -- have to close an index to restore it-          let go = do-                resp <- restoreSnapshot r1n s1n settings-                liftIO (validateStatus resp 200)-                exists <- indexExists expectedIndex-                liftIO (exists `shouldBe` True)-          go `finally` deleteIndex expectedIndex+    it "can restore and rename" $+      when' canSnapshot $+        withTestEnv $ do+          let r1n = SnapshotRepoName "bloodhound-repo1"+          withSnapshotRepo r1n $ \_ -> do+            let s1n = SnapshotName "example-snapshot"+            withSnapshot r1n s1n $ do+              let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"+              let replace = RRTLit "restored-" :| [RRSubWholeMatch]+              let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1"+              let overrides = RestoreIndexSettings {restoreOverrideReplicas = Just (ReplicaCount 0)}+              let settings =+                    defaultSnapshotRestoreSettings+                      { snapRestoreWaitForCompletion = True,+                        snapRestoreRenamePattern = Just pat,+                        snapRestoreRenameReplacement = Just replace,+                        snapRestoreIndexSettingsOverrides = Just overrides+                      }+              -- have to close an index to restore it+              let go = do+                    resp <- restoreSnapshot r1n s1n settings+                    liftIO (validateStatus resp 200)+                    exists <- indexExists expectedIndex+                    liftIO (exists `shouldBe` True)+              go `finally` deleteIndex expectedIndex  -- | Get configured repo paths for snapshotting. Note that by default -- this is not enabled and if we are over es 1.5, we won't be able to@@ -130,15 +147,16 @@   let Server s = bhServer bhe   let tUrl = s <> "/" <> "_nodes"   initReq <- parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack tUrl))-  let req = setRequestIgnoreStatus $ initReq { method = NHTM.methodGet }-  Right (Object o) <- parseEsResponse =<< liftIO (httpLbs req (bhManager bhe))-  return $ fromMaybe mempty $ do-    Object nodes <- X.lookup "nodes" o-    Object firstNode <- snd <$> headMay (X.toList nodes)-    Object settings <- X.lookup "settings" firstNode-    Object path <- X.lookup "path" settings-    Array repo <- X.lookup "repo" path-    return [ T.unpack t | String t <- V.toList repo]+  let req = setRequestIgnoreStatus $ initReq {method = NHTM.methodGet}+  Right (Object o) <- parseEsResponse . BHResponse =<< liftIO (httpLbs req (bhManager bhe))+  return $+    fromMaybe mempty $ do+      Object nodes <- X.lookup "nodes" o+      Object firstNode <- snd <$> headMay (X.toList nodes)+      Object settings <- X.lookup "settings" firstNode+      Object path <- X.lookup "path" settings+      Array repo <- X.lookup "repo" path+      return [T.unpack t | String t <- V.toList repo]  -- | 1.5 and earlier don't care about repo paths canSnapshot :: IO Bool@@ -146,20 +164,20 @@   repoPaths <- getRepoPaths   return (not (null repoPaths)) -withSnapshotRepo-    :: ( MonadMask m-       , MonadBH m-       )-    => SnapshotRepoName-    -> (GenericSnapshotRepo -> m a)-    -> m a+withSnapshotRepo ::+  ( MonadMask m,+    MonadBH m+  ) =>+  SnapshotRepoName ->+  (GenericSnapshotRepo -> m a) ->+  m a withSnapshotRepo srn@(SnapshotRepoName n) f = do   repoPaths <- liftIO getRepoPaths   -- we'll use the first repo path if available, otherwise system temp   -- dir. Note that this will fail on ES > 1.6, so be sure you use   -- @when' canSnapshot@.   case repoPaths of-    (firstRepoPath:_) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f+    (firstRepoPath : _) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f     [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f   where     alloc dir = do@@ -173,24 +191,25 @@       resp <- deleteSnapshotRepo gSnapshotRepoName       liftIO (validateStatus resp 200) --withSnapshot-    :: ( MonadMask m-       , MonadBH m-       )-    => SnapshotRepoName-    -> SnapshotName-    -> m a-    -> m a+withSnapshot ::+  ( MonadMask m,+    MonadBH m+  ) =>+  SnapshotRepoName ->+  SnapshotName ->+  m a ->+  m a withSnapshot srn sn = bracket_ alloc free   where     alloc = do       resp <- createSnapshot srn sn createSettings       liftIO (validateStatus resp 200)     -- We'll make this synchronous for testing purposes-    createSettings = defaultSnapshotCreateSettings { snapWaitForCompletion = True-                                                   , snapIndices = Just (IndexList (testIndex :| []))-                                                   -- We don't actually need to back up any data-                                                   }+    createSettings =+      defaultSnapshotCreateSettings+        { snapWaitForCompletion = True,+          snapIndices = Just (IndexList (testIndex :| []))+          -- We don't actually need to back up any data+        }     free =       deleteSnapshot srn sn
tests/Test/Sorting.hs view
@@ -8,28 +8,30 @@ spec :: Spec spec =   describe "sorting" $-    it "returns documents in the right order" $ withTestEnv $ do-      _ <- insertData-      _ <- insertOther-      let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending-      let search = Search-                    { queryBody       = Nothing-                    , filterBody      = Nothing-                    , sortBody        = Just [sortSpec]-                    , aggBody         = Nothing-                    , highlight       = Nothing-                    , trackSortScores = False-                    , from            = From 0-                    , size            = Size 10-                    , searchType      = SearchTypeDfsQueryThenFetch-                    , searchAfterKey  = Nothing-                    , fields          = Nothing-                    , scriptFields    = Nothing-                    , source          = Nothing-                    , suggestBody     = Nothing-                    , pointInTime     = Nothing-                    }-      result <- searchTweets search-      let myTweet = grabFirst result-      liftIO $-        myTweet `shouldBe` Right otherTweet+    it "returns documents in the right order" $+      withTestEnv $ do+        _ <- insertData+        _ <- insertOther+        let sortSpec = DefaultSortSpec $ mkSort (FieldName "age") Ascending+        let search =+              Search+                { queryBody = Nothing,+                  filterBody = Nothing,+                  sortBody = Just [sortSpec],+                  aggBody = Nothing,+                  highlight = Nothing,+                  trackSortScores = False,+                  from = From 0,+                  size = Size 10,+                  searchType = SearchTypeDfsQueryThenFetch,+                  searchAfterKey = Nothing,+                  fields = Nothing,+                  scriptFields = Nothing,+                  source = Nothing,+                  suggestBody = Nothing,+                  pointInTime = Nothing+                }+        result <- searchTweets search+        let myTweet = grabFirst result+        liftIO $+          myTweet `shouldBe` Right otherTweet
tests/Test/SourceFiltering.hs view
@@ -2,36 +2,42 @@  module Test.SourceFiltering where +import qualified Data.Aeson.KeyMap as X import Test.Common import Test.Import-import qualified Data.Aeson.KeyMap as X  spec :: Spec spec =   describe "Source filtering" $ do--    it "doesn't include source when sources are disabled" $ withTestEnv $-      searchExpectSource-        NoSource-        (Left (EsError 500 "Source was missing"))+    it "doesn't include source when sources are disabled" $+      withTestEnv $+        searchExpectSource+          NoSource+          (Left (EsError 500 "Source was missing")) -    it "includes a source" $ withTestEnv $-      searchExpectSource-        (SourcePatterns (PopPattern (Pattern "message")))-        (Right (Object (X.fromList [("message", String "Use haskell!")])))+    it "includes a source" $+      withTestEnv $+        searchExpectSource+          (SourcePatterns (PopPattern (Pattern "message")))+          (Right (Object (X.fromList [("message", String "Use haskell!")]))) -    it "includes sources" $ withTestEnv $-      searchExpectSource-        (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))-        (Right (Object (X.fromList [("user",String "bitemyapp"),("message", String "Use haskell!")])))+    it "includes sources" $+      withTestEnv $+        searchExpectSource+          (SourcePatterns (PopPatterns [Pattern "user", Pattern "message"]))+          (Right (Object (X.fromList [("user", String "bitemyapp"), ("message", String "Use haskell!")]))) -    it "includes source patterns" $ withTestEnv $-      searchExpectSource-        (SourcePatterns (PopPattern (Pattern "*ge")))-        (Right (Object (X.fromList [("age", Number 10000),("message", String "Use haskell!")])))+    it "includes source patterns" $+      withTestEnv $+        searchExpectSource+          (SourcePatterns (PopPattern (Pattern "*ge")))+          (Right (Object (X.fromList [("age", Number 10000), ("message", String "Use haskell!")]))) -    it "excludes source patterns" $ withTestEnv $-      searchExpectSource-        (SourceIncludeExclude (Include [])-        (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"]))-        (Right (Object (X.fromList [("user",String "bitemyapp")])))+    it "excludes source patterns" $+      withTestEnv $+        searchExpectSource+          ( SourceIncludeExclude+              (Include [])+              (Exclude [Pattern "l*", Pattern "*ge", Pattern "postDate", Pattern "extra"])+          )+          (Right (Object (X.fromList [("user", String "bitemyapp")])))
tests/Test/Suggest.hs view
@@ -8,16 +8,17 @@ spec :: Spec spec =   describe "Suggest" $-    it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do-      _ <- insertData-      let query = QueryMatchNoneQuery-          phraseSuggester = mkPhraseSuggester (FieldName "message")-          namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)-          search' = mkSearch (Just query) Nothing-          search = search' { suggestBody = Just namedSuggester }-          expectedText = Just "use haskell"-      resp <- searchByIndex testIndex search-      parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))-      case parsed of-        Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)-        Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses  <$> suggest sr) `shouldBe` expectedText+    it "returns a search suggestion using the phrase suggester" $+      withTestEnv $ do+        _ <- insertData+        let query = QueryMatchNoneQuery+            phraseSuggester = mkPhraseSuggester (FieldName "message")+            namedSuggester = Suggest "Use haskel" "suggest_name" (SuggestTypePhraseSuggester phraseSuggester)+            search' = mkSearch (Just query) Nothing+            search = search' {suggestBody = Just namedSuggester}+            expectedText = Just "use haskell"+        resp <- searchByIndex testIndex search+        parsed <- parseEsResponse resp :: BH IO (Either EsError (SearchResult Tweet))+        case parsed of+          Left e -> liftIO $ expectationFailure ("Expected an search suggestion but got " <> show e)+          Right sr -> liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText
tests/Test/Templates.hs view
@@ -8,19 +8,23 @@ spec :: Spec spec =   describe "template API" $ do-    it "can create a template" $ withTestEnv $ do-      let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1) defaultIndexMappingsLimits)) (toJSON TweetMapping)-      resp <- putTemplate idxTpl (TemplateName "tweet-tpl")-      liftIO $ validateStatus resp 200+    it "can create a template" $+      withTestEnv $ do+        let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1) defaultIndexMappingsLimits)) (toJSON TweetMapping)+        resp <- putTemplate idxTpl (TemplateName "tweet-tpl")+        liftIO $ validateStatus resp 200 -    it "can detect if a template exists" $ withTestEnv $ do-      exists <- templateExists (TemplateName "tweet-tpl")-      liftIO $ exists `shouldBe` True+    it "can detect if a template exists" $+      withTestEnv $ do+        exists <- templateExists (TemplateName "tweet-tpl")+        liftIO $ exists `shouldBe` True -    it "can delete a template" $ withTestEnv $ do-      resp <- deleteTemplate (TemplateName "tweet-tpl")-      liftIO $ validateStatus resp 200+    it "can delete a template" $+      withTestEnv $ do+        resp <- deleteTemplate (TemplateName "tweet-tpl")+        liftIO $ validateStatus resp 200 -    it "can detect if a template doesn't exist" $ withTestEnv $ do-      exists <- templateExists (TemplateName "tweet-tpl")-      liftIO $ exists `shouldBe` False+    it "can detect if a template doesn't exist" $+      withTestEnv $ do+        exists <- templateExists (TemplateName "tweet-tpl")+        liftIO $ exists `shouldBe` False
tests/tests.hs view
@@ -1,29 +1,24 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-#if __GLASGOW_HASKELL__ < 800-{-# OPTIONS_GHC -fcontext-stack=100 #-}-#endif #if __GLASGOW_HASKELL__ >= 802 {-# LANGUAGE MonoLocalBinds #-} #endif module Main where -import           Test.Common-import           Test.Import--import           Prelude- import qualified Data.Aeson as Aeson import qualified Data.Text as Text import qualified Test.Aggregation as Aggregation import qualified Test.BulkAPI as Bulk+import Test.Common+import qualified Test.Count as Count import qualified Test.Documents as Documents import qualified Test.Highlights as Highlights+import Test.Import import qualified Test.Indices as Indices import qualified Test.JSON as JSON import qualified Test.Query as Query@@ -33,7 +28,7 @@ import qualified Test.SourceFiltering as SourceFiltering import qualified Test.Suggest as Suggest import qualified Test.Templates as Templates-import qualified Test.Count as Count+import Prelude  main :: IO () main = hspec $ do@@ -52,44 +47,49 @@   Templates.spec   Count.spec -  describe "error parsing"  $-    it "can parse EsErrors for >= 2.0" $ withTestEnv $ do-      res <- getDocument (IndexName "bogus") (DocId "bogus_as_well")-      let errorResp = eitherDecode (responseBody res)-      liftIO (errorResp `shouldBe` Right (EsError 404 "no such index [bogus]"))+  describe "error parsing" $+    it "can parse EsErrors for >= 2.0" $+      withTestEnv $ do+        res <- getDocument @() (IndexName "bogus") (DocId "bogus_as_well")+        errorResp <- parseEsResponse res+        liftIO (errorResp `shouldBe` Left (EsError 404 "no such index [bogus]"))    describe "Monoid (SearchHits a)" $-    prop "abides the monoid laws" $ eq $-      prop_Monoid (T :: T (SearchHits ()))+    prop "abides the monoid laws" $+      eq $+        prop_Monoid (T :: T (SearchHits ()))    describe "mkDocVersion" $     prop "can never construct an out of range docVersion" $ \i ->       let res = mkDocVersion i-      in case res of-        Nothing -> property True-        Just dv -> (dv >= minBound) .&&.-                   (dv <= maxBound) .&&.-                   docVersionNumber dv === i+       in case res of+            Nothing -> property True+            Just dv ->+              (dv >= minBound)+                .&&. (dv <= maxBound)+                .&&. docVersionNumber dv === i    describe "getNodesInfo" $-     it "fetches the responding node when LocalNode is used" $ withTestEnv $ do-       res <- getNodesInfo LocalNode-       liftIO $ case res of-         -- This is really just a smoke test for response-         -- parsing. Node info is so variable, there's not much I can-         -- assert here.-         Right NodesInfo {..} -> length nodesInfo `shouldBe` 1-         Left e -> expectationFailure ("Expected NodesInfo but got " <> show e)+    it "fetches the responding node when LocalNode is used" $+      withTestEnv $ do+        res <- getNodesInfo LocalNode+        liftIO $ case res of+          -- This is really just a smoke test for response+          -- parsing. Node info is so variable, there's not much I can+          -- assert here.+          Right NodesInfo {..} -> length nodesInfo `shouldBe` 1+          Left e -> expectationFailure ("Expected NodesInfo but got " <> show e)    describe "getNodesStats" $-     it "fetches the responding node when LocalNode is used" $ withTestEnv $ do-       res <- getNodesStats LocalNode-       liftIO $ case res of-         -- This is really just a smoke test for response-         -- parsing. Node stats is so variable, there's not much I can-         -- assert here.-         Right NodesStats {..} -> length nodesStats `shouldBe` 1-         Left e -> expectationFailure ("Expected NodesStats but got " <> show e)+    it "fetches the responding node when LocalNode is used" $+      withTestEnv $ do+        res <- getNodesStats LocalNode+        liftIO $ case res of+          -- This is really just a smoke test for response+          -- parsing. Node stats is so variable, there's not much I can+          -- assert here.+          Right NodesStats {..} -> length nodesStats `shouldBe` 1+          Left e -> expectationFailure ("Expected NodesStats but got " <> show e)    describe "Enum DocVersion" $     it "follows the laws of Enum, Bounded" $ do@@ -102,82 +102,94 @@       enumFromThen minBound (pred maxBound :: DocVersion) `shouldBe` [minBound, pred maxBound]    describe "Scan & Scroll API" $-    it "returns documents using the scan&scroll API" $ withTestEnv $ do-      _ <- insertData-      _ <- insertOther-      let search =-            (mkSearch-             (Just $ MatchAllQuery Nothing) Nothing)-             { size = Size 1 }-      regular_search <- searchTweet search-      scan_search' <- scanSearch testIndex search :: BH IO [Hit Tweet]-      let scan_search = map hitSource scan_search'-      liftIO $-        regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored-      liftIO $-        scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]+    it "returns documents using the scan&scroll API" $+      withTestEnv $ do+        _ <- insertData+        _ <- insertOther+        let search =+              ( mkSearch+                  (Just $ MatchAllQuery Nothing)+                  Nothing+              )+                { size = Size 1+                }+        regular_search <- searchTweet search+        scan_search' <- scanSearch testIndex search :: BH IO [Hit Tweet]+        let scan_search = map hitSource scan_search'+        liftIO $+          regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored+        liftIO $+          scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]    describe "Point in time (PIT) API" $ do-    it "returns a single document using the point in time (PIT) API" $ withTestEnv $ do-      _ <- insertData-      _ <- insertOther-      let search =-            (mkSearch-             (Just $ MatchAllQuery Nothing) Nothing)-             { size = Size 1 }-      regular_search <- searchTweet search-      pit_search' <- pitSearch testIndex search :: BH IO [Hit Tweet]-      let pit_search = map hitSource pit_search'-      liftIO $-        regular_search `shouldBe` Right exampleTweet -- Check that the size restriction is being honored-      liftIO $-        pit_search `shouldMatchList` [Just exampleTweet]-    it "returns many documents using the point in time (PIT) API" $ withTestEnv $ do-      resetIndex-      let ids = [1..1000]-      let docs = map exampleTweetWithAge ids-      let docIds = map (Text.pack . show) ids-      mapM_ (uncurry insertTweetWithDocId) (docs `zip` docIds)-      let sort = mkSort (FieldName "postDate") Ascending-      let search =-            (mkSearch-             (Just $ MatchAllQuery Nothing) Nothing)-             {sortBody= Just [DefaultSortSpec sort]}-      scan_search' <- scanSearch testIndex search :: BH IO [Hit Tweet]-      let scan_search = map hitSource scan_search'-      pit_search' <- pitSearch testIndex search :: BH IO [Hit Tweet]-      let pit_search = map hitSource pit_search'-      let expectedHits = map Just docs-      liftIO $-        scan_search `shouldMatchList` expectedHits-      liftIO $-        pit_search `shouldMatchList` expectedHits-+    it "returns a single document using the point in time (PIT) API" $+      withTestEnv $ do+        _ <- insertData+        _ <- insertOther+        let search =+              ( mkSearch+                  (Just $ MatchAllQuery Nothing)+                  Nothing+              )+                { size = Size 1+                }+        regular_search <- searchTweet search+        pit_search' <- pitSearch testIndex search :: BH IO [Hit Tweet]+        let pit_search = map hitSource pit_search'+        liftIO $+          regular_search `shouldBe` Right exampleTweet -- Check that the size restriction is being honored+        liftIO $+          pit_search `shouldMatchList` [Just exampleTweet] -- TODO+    it "returns many documents using the point in time (PIT) API" $+      withTestEnv $ do+        resetIndex+        let ids = [1 .. 1000]+        let docs = map exampleTweetWithAge ids+        let docIds = map (Text.pack . show) ids+        mapM_ (uncurry insertTweetWithDocId) (docs `zip` docIds)+        let sort = mkSort (FieldName "postDate") Ascending+        let search =+              ( mkSearch+                  (Just $ MatchAllQuery Nothing)+                  Nothing+              )+                { sortBody = Just [DefaultSortSpec sort]+                }+        scan_search' <- scanSearch testIndex search :: BH IO [Hit Tweet]+        let scan_search = map hitSource scan_search'+        pit_search' <- pitSearch testIndex search :: BH IO [Hit Tweet]+        let pit_search = map hitSource pit_search'+        let expectedHits = map Just docs+        liftIO $+          scan_search `shouldMatchList` expectedHits+        liftIO $+          pit_search `shouldMatchList` expectedHits   describe "Search After API" $-    it "returns document for search after query" $ withTestEnv $ do-      _ <- insertData-      _ <- insertOther-      let-        sortSpec = DefaultSortSpec $ mkSort (FieldName "user") Ascending-        searchAfterKey = [Aeson.toJSON ("bitemyapp" :: String)]-        search = Search-                  { queryBody       = Nothing-                  , filterBody      = Nothing-                  , sortBody        = Just [sortSpec]-                  , aggBody         = Nothing-                  , highlight       = Nothing-                  , trackSortScores = False-                  , from            = From 0-                  , size            = Size 10-                  , searchType      = SearchTypeDfsQueryThenFetch-                  , searchAfterKey  = Just searchAfterKey-                  , fields          = Nothing-                  , scriptFields    = Nothing-                  , source          = Nothing-                  , suggestBody     = Nothing-                  , pointInTime     = Nothing-                  }-      result <- searchTweets search-      let myTweet = grabFirst result-      liftIO $-        myTweet `shouldBe` Right otherTweet+    it "returns document for search after query" $+      withTestEnv $ do+        _ <- insertData+        _ <- insertOther+        let sortSpec = DefaultSortSpec $ mkSort (FieldName "user") Ascending+            searchAfterKey = [Aeson.toJSON ("bitemyapp" :: String)]+            search =+              Search+                { queryBody = Nothing,+                  filterBody = Nothing,+                  sortBody = Just [sortSpec],+                  aggBody = Nothing,+                  highlight = Nothing,+                  trackSortScores = False,+                  from = From 0,+                  size = Size 10,+                  searchType = SearchTypeDfsQueryThenFetch,+                  searchAfterKey = Just searchAfterKey,+                  fields = Nothing,+                  scriptFields = Nothing,+                  source = Nothing,+                  suggestBody = Nothing,+                  pointInTime = Nothing+                }+        result <- searchTweets search+        let myTweet = grabFirst result+        liftIO $+          myTweet `shouldBe` Right otherTweet