From 06819a6b44411bf54ed0e1349fdd2244db470353 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Tue, 19 Jul 2016 16:15:17 -0700 Subject: [PATCH 01/11] WIP snapshot-restore API Snapshots API partly implemented. First trivial test case is passing. This could get tricky as our test suite spans many versions. For instance, 1.7 is when patterns got introduced. --- bloodhound.cabal | 4 +- src/Database/Bloodhound/Client.hs | 81 ++++++++- src/Database/Bloodhound/Types.hs | 195 +++++++++++++++++++++- src/Database/Bloodhound/Types/Internal.hs | 4 +- stack-7.10.yaml | 1 + tests/tests.hs | 16 +- 6 files changed, 291 insertions(+), 10 deletions(-) diff --git a/bloodhound.cabal b/bloodhound.cabal index 0104a58..2e8125c 100644 --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -73,7 +73,9 @@ test-suite tests mtl, quickcheck-properties, derive, - errors + errors, + resourcet, + temporary-resourcet default-language: Haskell2010 test-suite doctests diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs index 71d95a0..9fd439f 100644 --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -59,6 +59,10 @@ module Database.Bloodhound.Client , mkShardCount , mkReplicaCount , getStatus + , getSnapshotRepos + , updateSnapshotRepo + , verifySnapshotRepo + , deleteSnapshotRepo , encodeBulkOperations , encodeBulkOperation -- * Authentication @@ -72,7 +76,7 @@ module Database.Bloodhound.Client where import qualified Blaze.ByteString.Builder as BB -import Control.Applicative +import Control.Applicative as A import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class @@ -183,7 +187,7 @@ dispatch :: MonadBH m -> m Reply dispatch dMethod url body = do initReq <- liftIO $ parseUrl' url - reqHook <- bhRequestHook <$> getBHEnv + reqHook <- bhRequestHook A.<$> getBHEnv let reqBody = RequestBodyLBS $ fromMaybe emptyBody body req <- liftIO $ reqHook $ setRequestIgnoreStatus $ initReq { method = dMethod , requestBody = reqBody } @@ -260,6 +264,79 @@ getStatus = do 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) . HM.toList + go rawName = withObject "GenericSnapshotRepo" $ \o -> + GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type" + <*> o .: "settings" + + +-- | Create or update a snapshot repo +updateSnapshotRepo + :: ( MonadBH m + , SnapshotRepo repo + ) + => SnapshotRepoUpdateSettings + -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure + -> repo + -> m Reply --TODO: more specific? +updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = bindM2 post url (return (Just body)) + where + url = addQuery params <$> joinPath ["_snapshots", snapshotRepoName gSnapshotRepoName] + params + | repoUpdateVerify = [] + | otherwise = [("verify", Just "false")] + body = encode $ object [ "types" .= gSnapshotRepoName + , "settings" .= gSnapshotRepoSettings + ] + GenericSnapshotRepo {..} = toGSnapshotRepo repo + + + +-- | Verify if a snapshot repo is working. +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] + + -- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'. -- -- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs index cd1e1ab..0d888df 100644 --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -5,10 +5,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -- {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NamedFieldPuns #-} ------------------------------------------------------------------------------- -- | @@ -69,6 +69,9 @@ module Database.Bloodhound.Types , AllocationPolicy(..) , ReplicaBounds(..) , Bytes(..) + , gigabytes + , megabytes + , kilobytes , FSType(..) , InitialShardCount(..) , NodeAttrFilter(..) @@ -235,6 +238,21 @@ module Database.Bloodhound.Types , CollectionMode(..) , TermOrder(..) , TermInclusion(..) + , SnapshotRepoSelection(..) + , GenericSnapshotRepo(..) + , SnapshotRepo(..) + , SnapshotRepoConversionError(..) + , SnapshotRepoType(..) + , GenericSnapshotRepoSettings(..) + , SnapshotRepoUpdateSettings(..) + , defaultSnapshotRepoUpdateSettings + , SnapshotRepoName(..) + , SnapshotRepoPattern(..) + , SnapshotVerification(..) + , SnapshotNodeVerification(..) + , FullNodeId(..) + , NodeName(..) + , FsSnapshotRepo(..) , Aggregation(..) , Aggregations @@ -275,7 +293,7 @@ module Database.Bloodhound.Types , EsPassword(..) ) where -import Control.Applicative +import Control.Applicative as A import Control.Monad.Catch import Control.Monad.Except import Control.Monad.Reader @@ -283,7 +301,7 @@ import Control.Monad.State import Control.Monad.Writer import Data.Aeson import Data.Aeson.Types (Pair, Parser, emptyObject, - parseMaybe) + parseEither, parseMaybe) import qualified Data.ByteString.Lazy.Char8 as L import Data.Char import Data.Hashable (Hashable) @@ -332,7 +350,7 @@ mkBHEnv s m = BHEnv s m return newtype BH m a = BH { unBH :: ReaderT BHEnv m a } deriving ( Functor - , Applicative + , A.Applicative , Monad , MonadIO , MonadState s @@ -483,8 +501,31 @@ data ReplicaBounds = ReplicasBounded Int Int | ReplicasUnbounded deriving (Eq, Read, Show, Generic, Typeable) +-- | 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, Read, Show, Generic, Typeable, 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, Read, Show, Generic, Typeable, Ord) @@ -3625,3 +3666,149 @@ 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, Generic, Show, Typeable) + + +-- | 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, Generic, Show, Typeable) + +-- | The unique name of a snapshot repository. +newtype SnapshotRepoName = SnapshotRepoName { snapshotRepoName :: Text } + deriving (Eq, Generic, Show, Typeable, 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, Generic, Show, Typeable) + + +newtype SnapshotRepoType = SnapshotRepoType { snapshotRepoType :: Text } + deriving (Eq, Generic, Show, Typeable, ToJSON, FromJSON) + + +-- | Opaque representation of snapshot repo settings. Instances of +-- 'SnapshotRepo' will produce this. +newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings { gSnapshotRepoSettingsObject :: Object } + deriving (Eq, Generic, Show, Typeable, ToJSON, FromJSON) + + +-- | The result of running 'verifySnapshotRepo'. --TODO: more detail once you know what a failure looks like +newtype SnapshotVerification = SnapshotVerification { snapshotNodeVerifications :: [SnapshotNodeVerification] } + deriving (Eq, Generic, Show, Typeable) + + +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" + + +data SnapshotNodeVerification = SnapshotNodeVerification { + snvFullId :: FullNodeId + , snvNodeName :: NodeName + } deriving (Eq, Generic, Show, Typeable) + + +-- | Unique, automatically-generated name assigned to nodes that are +-- usually returned in node-oriented APIs. +newtype FullNodeId = FullNodeId { fullNodeId :: Text } + deriving (Eq, Generic, Show, Typeable, FromJSON) + + +newtype NodeName = NodeName { nodeName :: Text } + deriving (Eq, Generic, Show, Typeable, FromJSON) + + +data 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, Generic, Typeable) + + +-- | Reasonable defaults for repo creation/update +-- +-- * repoUpdateVerify True +defaultSnapshotRepoUpdateSettings :: SnapshotRepoUpdateSettings +defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True + + +-- | A filesystem-based snapshot repo that ships with elasticsearch. +data FsSnapshotRepo = FsSnapshotRepo { + fsrName :: SnapshotRepoName + , fsrLocation :: FilePath + , fsrCompressMetadata :: Bool + , fsrChunkSize :: Maybe Bytes + , fsrMaxRestoreBytesPerSec :: Maybe Bytes + , fsrMaxSnapshotBytesPerSec :: Maybe Bytes + } deriving (Eq, Generic, Show, Typeable) + + +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 $ do + 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) + + +--TODO: test what error case looks like +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 + -- ^ Expected type + SnapshotRepoType + -- ^ Actual type + | OtherRepoConversionError Text + deriving (Show, Eq, Generic, Typeable) + + +instance Exception SnapshotRepoConversionError diff --git a/src/Database/Bloodhound/Types/Internal.hs b/src/Database/Bloodhound/Types/Internal.hs index 7563385..50281b4 100644 --- a/src/Database/Bloodhound/Types/Internal.hs +++ b/src/Database/Bloodhound/Types/Internal.hs @@ -22,7 +22,7 @@ module Database.Bloodhound.Types.Internal ) where -import Control.Applicative +import Control.Applicative as A import Control.Monad.Reader import Data.Text (Text) import Data.Typeable (Typeable) @@ -51,6 +51,6 @@ newtype Server = Server Text deriving (Eq, Show, Generic, Typeable) 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 +class (Functor m, A.Applicative m, MonadIO m) => MonadBH m where getBHEnv :: m BHEnv diff --git a/stack-7.10.yaml b/stack-7.10.yaml index 1e93b76..0dec2b3 100644 --- a/stack-7.10.yaml +++ b/stack-7.10.yaml @@ -13,4 +13,5 @@ extra-deps: - quickcheck-properties-0.1 - semigroups-0.18.0.1 - uri-bytestring-0.1.9 +- temporary-resourcet-0.1.0.0 resolver: lts-5.1 diff --git a/tests/tests.hs b/tests/tests.hs index 95e15af..5bd050e 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -14,6 +14,7 @@ import Control.Error import Control.Exception import Control.Monad import Control.Monad.Reader +import Control.Monad.Trans.Resource import Data.Aeson import Data.Aeson.Types (parseEither) import qualified Data.ByteString.Lazy.Char8 as BL8 @@ -38,6 +39,7 @@ import GHC.Generics as G import Network.HTTP.Client hiding (Proxy) import qualified Network.HTTP.Types.Status as NHTS import Prelude hiding (filter) +import System.IO.Temp import Test.Hspec import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid) @@ -773,7 +775,8 @@ $(derive makeArbitrary ''AllocationPolicy) $(derive makeArbitrary ''InitialShardCount) $(derive makeArbitrary ''FSType) $(derive makeArbitrary ''CompoundFormat) - +$(derive makeArbitrary ''FsSnapshotRepo) +$(derive makeArbitrary ''SnapshotRepoName) main :: IO () main = hspec $ do @@ -1365,6 +1368,17 @@ main = hspec $ do (dv <= maxBound) .&&. docVersionNumber dv === i + describe "FsSnapshotRepo" $ do + prop "SnapshotRepo laws" $ \fsr -> + fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo) + + describe "snapshot repos" $ do + it "always parses all snapshots API" $ withTestEnv $ do + res <- getSnapshotRepos AllSnapshotRepos + liftIO $ case res of + Left e -> expectationFailure ("Expected a right but got Left " <> show e) + Right _ -> return () + describe "Enum DocVersion" $ do it "follows the laws of Enum, Bounded" $ do evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall From abb7052f57f3cecd028564abb087be5444ebbb2f Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 20 Jul 2016 10:58:21 -0700 Subject: [PATCH 02/11] Tests passing with snapshots repo API --- bloodhound.cabal | 5 ++- src/Database/Bloodhound/Client.hs | 43 ++++++++++--------- src/Database/Bloodhound/Types.hs | 44 +++++++++++-------- tests/tests.hs | 71 ++++++++++++++++++++++++++++--- 4 files changed, 118 insertions(+), 45 deletions(-) diff --git a/bloodhound.cabal b/bloodhound.cabal index 2e8125c..565ab64 100644 --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -74,8 +74,9 @@ test-suite tests quickcheck-properties, derive, errors, - resourcet, - temporary-resourcet + exceptions, + temporary, + unix default-language: Haskell2010 test-suite doctests diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs index 9fd439f..ca12fe9 100644 --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -75,32 +75,33 @@ module Database.Bloodhound.Client ) where -import qualified Blaze.ByteString.Builder as BB -import Control.Applicative as A +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.ByteString.Lazy.Builder -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HM +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Foldable (toList) +import qualified Data.HashMap.Strict as HM import Data.Ix -import qualified Data.List as LS (filter, foldl') -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (catMaybes, fromMaybe, isJust) +import qualified Data.List as LS (filter, foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, fromMaybe, + isJust) import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +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 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 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 @@ -291,7 +292,7 @@ instance FromJSON GSRs where parseJSON = withObject "Collection of GenericSnapshotRepo" parse where parse = fmap GSRs . mapM (uncurry go) . HM.toList - go rawName = withObject "GenericSnapshotRepo" $ \o -> + go rawName = withObject "GenericSnapshotRepo" $ \o -> do GenericSnapshotRepo (SnapshotRepoName rawName) <$> o .: "type" <*> o .: "settings" @@ -304,14 +305,14 @@ updateSnapshotRepo => SnapshotRepoUpdateSettings -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure -> repo - -> m Reply --TODO: more specific? + -> m Reply updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = bindM2 post url (return (Just body)) where - url = addQuery params <$> joinPath ["_snapshots", snapshotRepoName gSnapshotRepoName] + url = addQuery params <$> joinPath ["_snapshot", snapshotRepoName gSnapshotRepoName] params | repoUpdateVerify = [] | otherwise = [("verify", Just "false")] - body = encode $ object [ "types" .= gSnapshotRepoName + body = encode $ object [ "type" .= gSnapshotRepoType , "settings" .= gSnapshotRepoSettings ] GenericSnapshotRepo {..} = toGSnapshotRepo repo diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs index 0d888df..e6e3344 100644 --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -2988,7 +2988,7 @@ instance FromJSON UpdatableIndexSetting where <|> blocksWrite `taggedAt` ["blocks", "write"] <|> blocksMetaData `taggedAt` ["blocks", "metadata"] where taggedAt f ks = taggedAt' f (Object o) ks - taggedAt' f v [] = f =<< (parseJSON v <|> (parseJSON =<< unStringlyTypeJSON v)) + 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 @@ -3030,18 +3030,17 @@ instance FromJSON IndexSettingsSummary where redundant (NumberOfReplicas _) = True redundant _ = False --- | For some reason in the settings API, all leaf values get returned +-- | For some reason in several settings APIs, all leaf values get returned -- as strings. This function attepmts to recover from this for all --- non-recursive JSON types. If nothing can be done or the same value --- would be return, it returns 'mzero' -unStringlyTypeJSON :: MonadPlus m => Value -> m Value -unStringlyTypeJSON (String "true") = return (Bool True) -unStringlyTypeJSON (String "false") = return (Bool False) -unStringlyTypeJSON (String "null") = return Null -unStringlyTypeJSON (String t) = case readMay (T.unpack t) of - Just n -> return (Number n) - Nothing -> mzero -unStringlyTypeJSON _ = mzero +-- non-recursive JSON types. If nothing can be done, the value is left alone. +unStringlyTypeJSON :: Value -> Value +unStringlyTypeJSON (String "true") = Bool True +unStringlyTypeJSON (String "false") = Bool False +unStringlyTypeJSON (String "null") = Null +unStringlyTypeJSON v@(String t) = case readMay (T.unpack t) of + Just n -> Number n + Nothing -> v +unStringlyTypeJSON v = v parseSettings :: Object -> Parser [UpdatableIndexSetting] @@ -3680,7 +3679,7 @@ data SnapshotRepoPattern = ExactRepo SnapshotRepoName -- | The unique name of a snapshot repository. newtype SnapshotRepoName = SnapshotRepoName { snapshotRepoName :: Text } - deriving (Eq, Generic, Show, Typeable, ToJSON, FromJSON) + deriving (Eq, Ord, Generic, Show, Typeable, ToJSON, FromJSON) -- | A generic representation of a snapshot repo. This is what gets @@ -3696,16 +3695,27 @@ data GenericSnapshotRepo = GenericSnapshotRepo { } deriving (Eq, Generic, Show, Typeable) +instance SnapshotRepo GenericSnapshotRepo where + toGSnapshotRepo = id + fromGSnapshotRepo = Right + + newtype SnapshotRepoType = SnapshotRepoType { snapshotRepoType :: Text } - deriving (Eq, Generic, Show, Typeable, ToJSON, FromJSON) + deriving (Eq, Ord, Generic, Show, Typeable, ToJSON, FromJSON) -- | Opaque representation of snapshot repo settings. Instances of -- 'SnapshotRepo' will produce this. newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings { gSnapshotRepoSettingsObject :: Object } - deriving (Eq, Generic, Show, Typeable, ToJSON, FromJSON) + deriving (Eq, Generic, Show, Typeable, 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'. --TODO: more detail once you know what a failure looks like newtype SnapshotVerification = SnapshotVerification { snapshotNodeVerifications :: [SnapshotNodeVerification] } deriving (Eq, Generic, Show, Typeable) @@ -3730,11 +3740,11 @@ data SnapshotNodeVerification = SnapshotNodeVerification { -- | Unique, automatically-generated name assigned to nodes that are -- usually returned in node-oriented APIs. newtype FullNodeId = FullNodeId { fullNodeId :: Text } - deriving (Eq, Generic, Show, Typeable, FromJSON) + deriving (Eq, Ord, Generic, Show, Typeable, FromJSON) newtype NodeName = NodeName { nodeName :: Text } - deriving (Eq, Generic, Show, Typeable, FromJSON) + deriving (Eq, Ord, Generic, Show, Typeable, FromJSON) data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings { diff --git a/tests/tests.hs b/tests/tests.hs index 5bd050e..66b1b82 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} @@ -11,10 +12,10 @@ module Main where import Control.Applicative import Control.Error -import Control.Exception +import Control.Exception (evaluate) import Control.Monad +import Control.Monad.Catch import Control.Monad.Reader -import Control.Monad.Trans.Resource import Data.Aeson import Data.Aeson.Types (parseEither) import qualified Data.ByteString.Lazy.Char8 as BL8 @@ -26,6 +27,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as M import Data.Monoid +import Data.Ord (comparing) import Data.Proxy import Data.Text (Text) import qualified Data.Text as T @@ -40,6 +42,7 @@ import Network.HTTP.Client hiding (Proxy) import qualified Network.HTTP.Types.Status as NHTS import Prelude hiding (filter) import System.IO.Temp +import System.Posix.Files import Test.Hspec import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid) @@ -56,10 +59,14 @@ testMapping = MappingName "tweet" withTestEnv :: BH IO a -> IO a withTestEnv = withBH defaultManagerSettings testServer -validateStatus :: Response body -> Int -> Expectation +validateStatus :: Show body => Response body -> Int -> Expectation validateStatus resp expected = - (NHTS.statusCode $ responseStatus resp) - `shouldBe` (expected :: Int) + 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 createExampleIndex :: BH IO Reply createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex @@ -314,6 +321,28 @@ searchExpectSource src expected = do liftIO $ value `shouldBe` expected +withSnapshotRepo + :: ( MonadMask m + , MonadBH m + ) + => SnapshotRepoName + -> (GenericSnapshotRepo -> m a) + -> m a +withSnapshotRepo srn@(SnapshotRepoName n) f = + withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f + where + alloc dir = do + liftIO (setFileMode dir mode) + let repo = FsSnapshotRepo srn dir True Nothing Nothing Nothing + resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo + liftIO (validateStatus resp 200) + return (toGSnapshotRepo repo) + mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes + free GenericSnapshotRepo {..} = do + resp <- deleteSnapshotRepo gSnapshotRepoName + liftIO (validateStatus resp 200) + + data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show) instance FromJSON BulkTest where parseJSON = genericParseJSON defaultOptions @@ -1379,6 +1408,38 @@ main = hspec $ do Left e -> expectationFailure ("Expected a right but got Left " <> show e) Right _ -> return () + it "finds an existing list of repos" $ 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 "creates and updates with updateSnapshotRepo" $ withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \r1 -> do + let Just (String dir) = HM.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 "can verify existing repos" $ 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 "Enum DocVersion" $ do it "follows the laws of Enum, Bounded" $ do evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall From 841dfa7079b3a4c5f66452fa53ea49db8052cbc4 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 20 Jul 2016 15:28:21 -0700 Subject: [PATCH 03/11] Add and test snapshot apis --- src/Database/Bloodhound/Client.hs | 71 ++++++++++++++++- src/Database/Bloodhound/Types.hs | 122 +++++++++++++++++++++++++++++- tests/tests.hs | 53 ++++++++++++- 3 files changed, 237 insertions(+), 9 deletions(-) diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs index ca12fe9..35f2cae 100644 --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -63,6 +63,9 @@ module Database.Bloodhound.Client , updateSnapshotRepo , verifySnapshotRepo , deleteSnapshotRepo + , createSnapshot + , getSnapshots + , deleteSnapshot , encodeBulkOperations , encodeBulkOperation -- * Authentication @@ -306,7 +309,8 @@ updateSnapshotRepo -- ^ Use 'defaultSnapshotRepoUpdateSettings' if unsure -> repo -> m Reply -updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = bindM2 post url (return (Just body)) +updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = + bindM2 put url (return (Just body)) where url = addQuery params <$> joinPath ["_snapshot", snapshotRepoName gSnapshotRepoName] params @@ -338,6 +342,64 @@ deleteSnapshotRepo (SnapshotRepoName n) = delete =<< url url = joinPath ["_snapshot", n] +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" .=) . renderIndices <$> snapIndices + , Just ("ignore_unavailable" .= snapIgnoreUnavailable) + , Just ("ignore_global_state" .= snapIncludeGlobalState) + , Just ("partial" .= snapPartial) + ] + renderIndices (i :| is) = T.intercalate "," (renderIndex <$> (i:is)) + renderIndex (IndexName n) = n + + +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" + + +deleteSnapshot :: MonadBH m => SnapshotRepoName -> SnapshotName -> m Reply +deleteSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) = + delete =<< url + where + url = joinPath ["_snapshot", repoName, snapName] + + -- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'. -- -- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") @@ -417,8 +479,6 @@ optimizeIndex ixs IndexOptimizationSettings {..} = , Just ("flush", Just (boolQP flushAfterOptimize)) ] indexName = indexSelectionName ixs - boolQP True = "true" - boolQP False = "false" body = Nothing @@ -934,3 +994,8 @@ 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" diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs index e6e3344..6d8c615 100644 --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -253,6 +253,13 @@ module Database.Bloodhound.Types , FullNodeId(..) , NodeName(..) , FsSnapshotRepo(..) + , SnapshotCreateSettings(..) + , defaultSnapshotCreateSettings + , SnapshotSelection(..) + , SnapshotPattern(..) + , SnapshotInfo(..) + , SnapshotName(..) + , SnapshotState(..) , Aggregation(..) , Aggregations @@ -3672,7 +3679,7 @@ data SnapshotRepoSelection = SnapshotRepoList (NonEmpty SnapshotRepoPattern) -- | 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 +-- e.g. @RepoPattern "foo*"@ __NOTE__:@ Patterns are not supported on ES < 1.7 data SnapshotRepoPattern = ExactRepo SnapshotRepoName | RepoPattern Text deriving (Eq, Generic, Show, Typeable) @@ -3716,7 +3723,7 @@ newtype GenericSnapshotRepoSettings = GenericSnapshotRepoSettings { gSnapshotRep instance FromJSON GenericSnapshotRepoSettings where parseJSON = fmap (GenericSnapshotRepoSettings . fmap unStringlyTypeJSON). parseJSON --- | The result of running 'verifySnapshotRepo'. --TODO: more detail once you know what a failure looks like +-- | The result of running 'verifySnapshotRepo'. newtype SnapshotVerification = SnapshotVerification { snapshotNodeVerifications :: [SnapshotNodeVerification] } deriving (Eq, Generic, Show, Typeable) @@ -3797,7 +3804,6 @@ instance SnapshotRepo FsSnapshotRepo where | otherwise = Left (RepoTypeMismatch fsRepoType gSnapshotRepoType) ---TODO: test what error case looks like parseRepo :: Parser a -> Either SnapshotRepoConversionError a parseRepo parser = case parseEither (const parser) () of Left e -> Left (OtherRepoConversionError (T.pack e)) @@ -3822,3 +3828,113 @@ data SnapshotRepoConversionError = RepoTypeMismatch SnapshotRepoType 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 (NonEmpty IndexName) + -- ^ 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? + } + + +-- | Reasonable defaults for snapshot creation +-- +-- * snapWaitForCompletion False +-- * snapIndices Nothing +-- * snapIgnoreUnavailable False +-- * snapIncludeGlobalState True +-- * snapPartial False +defaultSnapshotCreateSettings :: SnapshotCreateSettings +defaultSnapshotCreateSettings = + SnapshotCreateSettings False Nothing False True False + + +data SnapshotSelection = SnapshotList (NonEmpty SnapshotPattern) + | AllSnapshots deriving (Eq, Generic, Show, Typeable) + + +-- | 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, Generic, Show, Typeable) + + +-- | General information about the state of a snapshot. Has some +-- redundancies with 'SnapshotStatus' +data SnapshotInfo = SnapshotInfo { + snapInfoShards :: ShardResult + --TODO: what does failures produce? list of what? + , snapInfoDuration :: NominalDiffTime + , snapInfoEndTime :: UTCTime + , snapInfoStartTime :: UTCTime + , snapInfoState :: SnapshotState + , snapInfoIndices :: [IndexName] + , snapInfoName :: SnapshotName + } deriving (Eq, Generic, Show, Typeable) + + +instance FromJSON SnapshotInfo where + parseJSON = withObject "SnapshotInfo" parse + where + parse o = SnapshotInfo <$> o .: "shards" + <*> (unMS <$> o .: "duration_in_millis") + <*> (posixMS <$> o .: "end_time_in_millis") + <*> (posixMS <$> o .: "start_time_in_millis") + <*> o .: "state" + <*> o .: "indices" + <*> o .: "snapshot" + +-- | Milliseconds +newtype MS = MS NominalDiffTime + + +-- keeps the unexported constructor warnings at bay +unMS :: MS -> NominalDiffTime +unMS (MS t) = t + + +instance FromJSON MS where + parseJSON = withScientific "MS" (return . MS . parse) + where + parse n = fromInteger ((truncate n) * 1000) + + +data SnapshotState = SnapshotInit + | SnapshotStarted + | SnapshotSuccess + | SnapshotFailed + | SnapshotAborted + | SnapshotMissing + | SnapshotWaiting + deriving (Show, Eq, Generic, Typeable) + +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) + + +newtype SnapshotName = SnapshotName { snapshotName :: Text } + deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON) diff --git a/tests/tests.hs b/tests/tests.hs index 66b1b82..f64d792 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -68,9 +68,9 @@ validateStatus resp expected = actual = NHTS.statusCode (responseStatus resp) body = responseBody resp -createExampleIndex :: BH IO Reply +createExampleIndex :: (MonadBH m) => m Reply createExampleIndex = createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0)) testIndex -deleteExampleIndex :: BH IO Reply +deleteExampleIndex :: (MonadBH m) => m Reply deleteExampleIndex = deleteIndex testIndex data ServerVersion = ServerVersion Int Int Int deriving (Show, Eq, Ord) @@ -343,6 +343,29 @@ withSnapshotRepo srn@(SnapshotRepoName n) f = liftIO (validateStatus resp 200) +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 (testIndex :| []) + -- We don't actually need to back up any data + } + free = do + deleteSnapshot srn sn + + + data BulkTest = BulkTest { name :: Text } deriving (Eq, Generic, Show) instance FromJSON BulkTest where parseJSON = genericParseJSON defaultOptions @@ -1402,7 +1425,7 @@ main = hspec $ do fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo) describe "snapshot repos" $ do - it "always parses all snapshots API" $ withTestEnv $ do + it "always parses all snapshot repos API" $ withTestEnv $ do res <- getSnapshotRepos AllSnapshotRepos liftIO $ case res of Left e -> expectationFailure ("Expected a right but got Left " <> show e) @@ -1440,6 +1463,30 @@ main = hspec $ do | otherwise -> return () Left e -> expectationFailure (show e) + describe "snapshots" $ do + it "always parses all snapshots API" $ 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" $ 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 "Enum DocVersion" $ do it "follows the laws of Enum, Bounded" $ do evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall From 051a15ec053e3065346f36e9d5e13a975eb92acd Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Wed, 20 Jul 2016 16:47:07 -0700 Subject: [PATCH 04/11] WIP testing restore API --- src/Database/Bloodhound/Client.hs | 40 +++++++++- src/Database/Bloodhound/Types.hs | 119 ++++++++++++++++++++++++++++-- tests/tests.hs | 3 + 3 files changed, 152 insertions(+), 10 deletions(-) diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs index 35f2cae..2bf20f1 100644 --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -66,6 +66,7 @@ module Database.Bloodhound.Client , createSnapshot , getSnapshots , deleteSnapshot + , restoreSnapshot , encodeBulkOperations , encodeBulkOperation -- * Authentication @@ -361,7 +362,11 @@ createSnapshot (SnapshotRepoName repoName) , Just ("ignore_global_state" .= snapIncludeGlobalState) , Just ("partial" .= snapPartial) ] - renderIndices (i :| is) = T.intercalate "," (renderIndex <$> (i:is)) + + +renderIndices :: NonEmpty IndexName -> Text +renderIndices (i :| is) = T.intercalate "," (renderIndex <$> (i:is)) + where renderIndex (IndexName n) = n @@ -400,6 +405,37 @@ deleteSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) = url = joinPath ["_snapshot", repoName, snapName] +-- | Restore a snapshot to the cluster See +-- +-- 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 put 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" .=) . renderIndices <$> snapRestoreIndices + , Just ("ignore_unavailable" .= snapRestoreIgnoreUnavailable) + , Just ("include_global_state" .= snapRestoreIncludeGlobalState) + , ("rename_pattern" .=) <$> snapRestoreRenamePattern + , ("rename_replacement" .=) . renderTokens <$> snapRestoreRenameReplacement + , Just ("include_aliases" .= snapRestoreIncludeAliases) + ] + renderTokens (t :| ts) = mconcat (renderToken <$> (t:ts)) + renderToken (RRTLit t) = t + renderToken RRSubWholeMatch = "$0" + renderToken (RRSubGroup g) = T.pack (show (rrGroupRefNum g)) + + -- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'. -- -- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") @@ -484,7 +520,7 @@ optimizeIndex ixs IndexOptimizationSettings {..} = ------------------------------------------------------------------------------- indexSelectionName :: IndexSelection -> Text -indexSelectionName (IndexList names) = T.intercalate "," [n | IndexName n <- toList names] +indexSelectionName (IndexList names) = renderIndices names indexSelectionName AllIndexes = "_all" deepMerge :: [Object] -> Object diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs index 6d8c615..6b95469 100644 --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -260,6 +260,13 @@ module Database.Bloodhound.Types , SnapshotInfo(..) , SnapshotName(..) , SnapshotState(..) + , SnapshotRestoreSettings(..) + , defaultSnapshotRestoreSettings + , RestoreRenamePattern(..) + , RestoreRenameToken(..) + , RRGroupRefNum + , rrGroupRefNum + , mkRRGroupRefNum , Aggregation(..) , Aggregations @@ -3831,23 +3838,23 @@ instance Exception SnapshotRepoConversionError data SnapshotCreateSettings = SnapshotCreateSettings { - snapWaitForCompletion :: Bool + snapWaitForCompletion :: Bool -- ^ Should the API call return immediately after initializing - -- the snapshot or wait until completed. Note that if this is + -- 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 (NonEmpty IndexName) + , snapIndices :: Maybe (NonEmpty IndexName) -- ^ Nothing will snapshot all indices. Just [] is permissable and -- will essentially be a no-op snapshot. - , snapIgnoreUnavailable :: Bool + , 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 + , snapPartial :: Bool -- ^ If some indices failed to snapshot (e.g. if not all primary -- shards are available), should the process proceed? - } + } deriving (Eq, Generic, Show, Typeable) -- | Reasonable defaults for snapshot creation @@ -3858,8 +3865,13 @@ data SnapshotCreateSettings = SnapshotCreateSettings { -- * snapIncludeGlobalState True -- * snapPartial False defaultSnapshotCreateSettings :: SnapshotCreateSettings -defaultSnapshotCreateSettings = - SnapshotCreateSettings False Nothing False True False +defaultSnapshotCreateSettings = SnapshotCreateSettings { + snapWaitForCompletion = False + , snapIndices = Nothing + , snapIgnoreUnavailable = False + , snapIncludeGlobalState = True + , snapPartial = False + } data SnapshotSelection = SnapshotList (NonEmpty SnapshotPattern) @@ -3938,3 +3950,94 @@ instance FromJSON SnapshotState where newtype SnapshotName = SnapshotName { snapshotName :: Text } deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON) + + +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 (NonEmpty IndexName) + -- ^ 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. + } deriving (Eq, Generic, Show, Typeable) +--TODO: temporary settings changes + +-- | Regex-stype pattern, e.g. "index_(.+)" to match index names +newtype RestoreRenamePattern = RestoreRenamePattern { rrPattern :: Text } + deriving (Show, Eq, Generic, Typeable, 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 +-- 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 (Show, Eq, Generic, Typeable) + + +-- | A group number for regex matching. Only values from 1-9 are +-- supported. Construct with mkRRGroupRefNum +newtype RRGroupRefNum = RRGroupRefNum { rrGroupRefNum :: Int } + deriving (Show, Eq, Generic, Typeable, Ord) + +instance Bounded RRGroupRefNum where + minBound = RRGroupRefNum 1 + maxBound = RRGroupRefNum 9 + + + +-- | Only allows valid group number references (0-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 +defaultSnapshotRestoreSettings :: SnapshotRestoreSettings +defaultSnapshotRestoreSettings = SnapshotRestoreSettings { + snapRestoreWaitForCompletion = False + , snapRestoreIndices = Nothing + , snapRestoreIgnoreUnavailable = False + , snapRestoreIncludeGlobalState = True + , snapRestoreRenamePattern = Nothing + , snapRestoreRenameReplacement = Nothing + , snapRestorePartial = False + , snapRestoreIncludeAliases = True + } diff --git a/tests/tests.hs b/tests/tests.hs index f64d792..f2346dc 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1487,6 +1487,9 @@ main = hspec $ do 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" pending + describe "Enum DocVersion" $ do it "follows the laws of Enum, Bounded" $ do evaluate (succ maxBound :: DocVersion) `shouldThrow` anyErrorCall From a451b84b8d9c59949a47157c45c1fda6f3551f1e Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Thu, 21 Jul 2016 09:26:31 -0700 Subject: [PATCH 05/11] Test restore API --- src/Database/Bloodhound/Client.hs | 4 +++- src/Database/Bloodhound/Types.hs | 29 +++++++++++++++++++++++++- tests/tests.hs | 34 ++++++++++++++++++++++++++++++- 3 files changed, 64 insertions(+), 3 deletions(-) diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs index 2bf20f1..2426c8b 100644 --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -418,7 +418,7 @@ restoreSnapshot -> m Reply restoreSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) - SnapshotRestoreSettings {..} = bindM2 put url (return (Just body)) + SnapshotRestoreSettings {..} = bindM2 post url (return (Just body)) where url = addQuery params <$> joinPath ["_snapshot", repoName, snapName, "_restore"] params = [("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion))] @@ -429,6 +429,8 @@ restoreSnapshot (SnapshotRepoName repoName) , ("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 diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs index 6b95469..73aab69 100644 --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -267,6 +267,7 @@ module Database.Bloodhound.Types , RRGroupRefNum , rrGroupRefNum , mkRRGroupRefNum + , RestoreIndexSettings(..) , Aggregation(..) , Aggregations @@ -3979,8 +3980,16 @@ data SnapshotRestoreSettings = SnapshotRestoreSettings { , snapRestoreIncludeAliases :: Bool -- ^ Should the restore also restore the aliases captured in the -- snapshot. + , snapRestoreIndexSettingsOverrides :: Maybe RestoreIndexSettings + -- ^ Settings to apply during the restore process. + , 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, Generic, Show, Typeable) ---TODO: temporary settings changes -- | Regex-stype pattern, e.g. "index_(.+)" to match index names newtype RestoreRenamePattern = RestoreRenamePattern { rrPattern :: Text } @@ -4030,6 +4039,8 @@ mkRRGroupRefNum i -- * snapRestoreRenameReplacement Nothing -- * snapRestorePartial False -- * snapRestoreIncludeAliases True +-- * snapRestoreIndexSettingsOverrides Nothing +-- * snapRestoreIgnoreIndexSettings Nothing defaultSnapshotRestoreSettings :: SnapshotRestoreSettings defaultSnapshotRestoreSettings = SnapshotRestoreSettings { snapRestoreWaitForCompletion = False @@ -4040,4 +4051,20 @@ defaultSnapshotRestoreSettings = SnapshotRestoreSettings { , 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. +data RestoreIndexSettings = RestoreIndexSettings { + restoreOverrideReplicas :: Maybe ReplicaCount + } deriving (Show, Eq, Generic, Typeable) + + +instance ToJSON RestoreIndexSettings where + toJSON RestoreIndexSettings {..} = object prs + where + prs = catMaybes [("index.number_of_replicas" .=) <$> restoreOverrideReplicas] diff --git a/tests/tests.hs b/tests/tests.hs index f2346dc..c22ba08 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1488,7 +1488,39 @@ main = hspec $ do Left e -> expectationFailure (show e) describe "snapshot restore" $ do - it "can restore a snapshot that we create" pending + it "can restore a snapshot that we create" $ 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" $ 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 describe "Enum DocVersion" $ do it "follows the laws of Enum, Bounded" $ do From 42040f8318af28b7b68722394426ccd29c5253a7 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Thu, 21 Jul 2016 10:35:09 -0700 Subject: [PATCH 06/11] Wrap up feature --- src/Database/Bloodhound/Client.hs | 6 ++-- src/Database/Bloodhound/Types.hs | 51 +++++++++++++++++++++++-------- 2 files changed, 43 insertions(+), 14 deletions(-) diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs index 2426c8b..e0c6cf5 100644 --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -343,6 +343,7 @@ deleteSnapshotRepo (SnapshotRepoName n) = delete =<< url url = joinPath ["_snapshot", n] +-- | Create and start a snapshot createSnapshot :: (MonadBH m) => SnapshotRepoName @@ -370,14 +371,14 @@ renderIndices (i :| is) = T.intercalate "," (renderIndex <$> (i:is)) 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]) + -> m (Either EsError [SnapshotInfo]) getSnapshots (SnapshotRepoName repoName) sel = fmap (fmap unSIs) . parseEsResponse =<< get =<< url where @@ -398,6 +399,7 @@ instance FromJSON SIs 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 diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs index 73aab69..a1c0dfc 100644 --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -258,6 +258,8 @@ module Database.Bloodhound.Types , SnapshotSelection(..) , SnapshotPattern(..) , SnapshotInfo(..) + , SnapshotShardFailure(..) + , ShardId(..) , SnapshotName(..) , SnapshotState(..) , SnapshotRestoreSettings(..) @@ -3687,7 +3689,7 @@ data SnapshotRepoSelection = SnapshotRepoList (NonEmpty SnapshotRepoPattern) -- | 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 +-- e.g. @RepoPattern "foo*"@ __NOTE__: Patterns are not supported on ES < 1.7 data SnapshotRepoPattern = ExactRepo SnapshotRepoName | RepoPattern Text deriving (Eq, Generic, Show, Typeable) @@ -3746,6 +3748,7 @@ instance FromJSON SnapshotVerification where SnapshotNodeVerification (FullNodeId rawFullId) <$> o .: "name" +-- | A node that has verified a snapshot data SnapshotNodeVerification = SnapshotNodeVerification { snvFullId :: FullNodeId , snvNodeName :: NodeName @@ -3758,6 +3761,8 @@ newtype FullNodeId = FullNodeId { fullNodeId :: Text } deriving (Eq, Ord, Generic, Show, Typeable, 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, Generic, Show, Typeable, FromJSON) @@ -3778,14 +3783,19 @@ defaultSnapshotRepoUpdateSettings :: SnapshotRepoUpdateSettings defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True --- | A filesystem-based snapshot repo that ships with elasticsearch. +-- | 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, Generic, Show, Typeable) @@ -3827,10 +3837,8 @@ class SnapshotRepo r where fromGSnapshotRepo :: GenericSnapshotRepo -> Either SnapshotRepoConversionError r -data SnapshotRepoConversionError = RepoTypeMismatch SnapshotRepoType - -- ^ Expected type - SnapshotRepoType - -- ^ Actual type +data SnapshotRepoConversionError = RepoTypeMismatch SnapshotRepoType SnapshotRepoType + -- ^ Expected type and actual type | OtherRepoConversionError Text deriving (Show, Eq, Generic, Typeable) @@ -3891,7 +3899,7 @@ data SnapshotPattern = ExactSnap SnapshotName -- redundancies with 'SnapshotStatus' data SnapshotInfo = SnapshotInfo { snapInfoShards :: ShardResult - --TODO: what does failures produce? list of what? + , snapInfoFailures :: [SnapshotShardFailure] , snapInfoDuration :: NominalDiffTime , snapInfoEndTime :: UTCTime , snapInfoStartTime :: UTCTime @@ -3905,6 +3913,7 @@ 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") @@ -3912,6 +3921,26 @@ instance FromJSON SnapshotInfo where <*> 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, Generic, Typeable) + + +instance FromJSON SnapshotShardFailure where + parseJSON = withObject "SnapshotShardFailure" parse + where + parse o = SnapshotShardFailure <$> o .: "index" + <*> o .:? "node_id" + <*> o .: "reason" + <*> o .: "shard_id" + + +newtype ShardId = ShardId { shardId :: Int } + deriving (Eq, Show, Generic, Typeable, FromJSON) + -- | Milliseconds newtype MS = MS NominalDiffTime @@ -3999,8 +4028,7 @@ newtype RestoreRenamePattern = RestoreRenamePattern { rrPattern :: Text } -- | 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 --- to find out more if you're into that sort of thing. +-- to find out more if you're into that sort of thing. data RestoreRenameToken = RRTLit Text -- ^ Just a literal string of characters | RRSubWholeMatch @@ -4011,7 +4039,7 @@ data RestoreRenameToken = RRTLit Text -- | A group number for regex matching. Only values from 1-9 are --- supported. Construct with mkRRGroupRefNum +-- supported. Construct with 'mkRRGroupRefNum' newtype RRGroupRefNum = RRGroupRefNum { rrGroupRefNum :: Int } deriving (Show, Eq, Generic, Typeable, Ord) @@ -4020,8 +4048,7 @@ instance Bounded RRGroupRefNum where maxBound = RRGroupRefNum 9 - --- | Only allows valid group number references (0-9). +-- | Only allows valid group number references (1-9). mkRRGroupRefNum :: Int -> Maybe RRGroupRefNum mkRRGroupRefNum i | i >= (rrGroupRefNum minBound) && i <= (rrGroupRefNum maxBound) = From ac5d6f68276df166030e22513625e5c3ad8d15ce Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Mon, 25 Jul 2016 09:30:51 -0700 Subject: [PATCH 07/11] Use IndexSelection for snapshot/restore In the future, IndexSelection can fully support multi-index syntax, so we should have any API that supports that syntax using IndexSelection so it gets upgrades for free. --- src/Database/Bloodhound/Client.hs | 32 +++++++++++++++---------------- src/Database/Bloodhound/Types.hs | 5 +++-- tests/tests.hs | 2 +- 3 files changed, 19 insertions(+), 20 deletions(-) diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs index e0c6cf5..980a082 100644 --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -358,15 +358,16 @@ createSnapshot (SnapshotRepoName repoName) url = addQuery params <$> joinPath ["_snapshot", repoName, snapName] params = [("wait_for_completion", Just (boolQP snapWaitForCompletion))] body = encode $ object prs - prs = catMaybes [ ("indices" .=) . renderIndices <$> snapIndices + prs = catMaybes [ ("indices" .=) . indexSelectionName <$> snapIndices , Just ("ignore_unavailable" .= snapIgnoreUnavailable) , Just ("ignore_global_state" .= snapIncludeGlobalState) , Just ("partial" .= snapPartial) ] -renderIndices :: NonEmpty IndexName -> Text -renderIndices (i :| is) = T.intercalate "," (renderIndex <$> (i:is)) +indexSelectionName :: IndexSelection -> Text +indexSelectionName AllIndexes = "_all" +indexSelectionName (IndexList (i :| is)) = T.intercalate "," (renderIndex <$> (i:is)) where renderIndex (IndexName n) = n @@ -425,15 +426,17 @@ restoreSnapshot (SnapshotRepoName repoName) url = addQuery params <$> joinPath ["_snapshot", repoName, snapName, "_restore"] params = [("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion))] body = encode (object prs) - prs = catMaybes [ ("indices" .=) . renderIndices <$> 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 - ] + + + 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" @@ -522,11 +525,6 @@ optimizeIndex ixs IndexOptimizationSettings {..} = body = Nothing -------------------------------------------------------------------------------- -indexSelectionName :: IndexSelection -> Text -indexSelectionName (IndexList names) = renderIndices names -indexSelectionName AllIndexes = "_all" - deepMerge :: [Object] -> Object deepMerge = LS.foldl' go mempty where go acc = LS.foldl' go' acc . HM.toList diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs index a1c0dfc..5f2a1b4 100644 --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -861,6 +861,7 @@ newtype IndexName = IndexName Text deriving (Eq, Generic, Read, Show, ToJSON, Fr {-| '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 . 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, Generic, Show, Typeable) @@ -3853,7 +3854,7 @@ data SnapshotCreateSettings = SnapshotCreateSettings { -- enabled it could wait a long time, so you should adjust your -- 'ManagerSettings' accordingly to set long timeouts or -- explicitly handle timeouts. - , snapIndices :: Maybe (NonEmpty IndexName) + , snapIndices :: Maybe IndexSelection -- ^ Nothing will snapshot all indices. Just [] is permissable and -- will essentially be a no-op snapshot. , snapIgnoreUnavailable :: Bool @@ -3989,7 +3990,7 @@ data SnapshotRestoreSettings = SnapshotRestoreSettings { -- enabled, it could wait a long time, so you should adjust your -- 'ManagerSettings' accordingly to set long timeouts or -- explicitly handle timeouts. - , snapRestoreIndices :: Maybe (NonEmpty IndexName) + , snapRestoreIndices :: Maybe IndexSelection -- ^ Nothing will restore all indices in the snapshot. Just [] is -- permissable and will essentially be a no-op restore. , snapRestoreIgnoreUnavailable :: Bool diff --git a/tests/tests.hs b/tests/tests.hs index c22ba08..4a9a384 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -358,7 +358,7 @@ withSnapshot srn sn = bracket_ alloc free liftIO (validateStatus resp 200) -- We'll make this synchronous for testing purposes createSettings = defaultSnapshotCreateSettings { snapWaitForCompletion = True - , snapIndices = Just (testIndex :| []) + , snapIndices = Just (IndexList (testIndex :| [])) -- We don't actually need to back up any data } free = do From 0164535ce996392ecabfd92f196947f4bdbebd2e Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Fri, 29 Jul 2016 12:55:50 -0700 Subject: [PATCH 08/11] Do some toggling in test around version: - sets up a snapshot repo in travis so versions newer than 1.5 can test snapshots - does not test snapshots if the system is incapable. I can't in good conscience modify a developer's ES config for the sake of testing, so on your local machine if you have no repo configured and ES >= 1.6, we skip snapshot tests. - Disable problematic snapshot options for old versions of ES in test. Add warning to the docs. --- .travis.yml | 2 + bloodhound.cabal | 3 +- src/Database/Bloodhound/Types.hs | 4 +- tests/tests.hs | 69 ++++++++++++++++++++++++++------ 4 files changed, 64 insertions(+), 14 deletions(-) diff --git a/.travis.yml b/.travis.yml index 81a19d9..f2e8cfe 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,6 +29,8 @@ install: # elasticsearch - wget --no-check-certificate https://download.elastic.co/elasticsearch/elasticsearch/elasticsearch-$ESVER.tar.gz - tar xzf elasticsearch-$ESVER.tar.gz + # set up a repo for snapshot testing. Required in ES >= 1.6 + - echo "path.repo = [\"/tmp\"]" >> ./elasticsearch-$ESVER/elasticsearch.yml - ./elasticsearch-$ESVER/bin/elasticsearch & script: diff --git a/bloodhound.cabal b/bloodhound.cabal index bb5dce6..5c75dfb 100644 --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -76,7 +76,8 @@ test-suite tests errors, exceptions, temporary, - unix + unix, + network-uri default-language: Haskell2010 test-suite doctests diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs index 5f2a1b4..7c36d17 100644 --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -4011,7 +4011,9 @@ data SnapshotRestoreSettings = SnapshotRestoreSettings { -- ^ Should the restore also restore the aliases captured in the -- snapshot. , snapRestoreIndexSettingsOverrides :: Maybe RestoreIndexSettings - -- ^ Settings to apply during the restore process. + -- ^ 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 diff --git a/tests/tests.hs b/tests/tests.hs index 4a9a384..356f93d 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -39,7 +39,9 @@ import qualified Data.Vector as V import Database.Bloodhound import GHC.Generics as G import Network.HTTP.Client hiding (Proxy) +import qualified Network.HTTP.Types.Method as NHTM import qualified Network.HTTP.Types.Status as NHTS +import qualified Network.URI as URI import Prelude hiding (filter) import System.IO.Temp import System.Posix.Files @@ -49,6 +51,7 @@ import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck + testServer :: Server testServer = Server "http://localhost:9200" testIndex :: IndexName @@ -84,6 +87,12 @@ es12 = ServerVersion 1 2 0 es11 :: ServerVersion es11 = ServerVersion 1 1 0 +es15 :: ServerVersion +es15 = ServerVersion 1 5 0 + +es16 :: ServerVersion +es16 = ServerVersion 1 6 0 + serverBranch :: ServerVersion -> ServerVersion serverBranch (ServerVersion majorVer minorVer patchVer) = ServerVersion majorVer minorVer patchVer @@ -101,6 +110,33 @@ getServerVersion = liftM extractVersion (withTestEnv getStatus) parseVersion v = map toInt (version' v) extractVersion = join . liftM (mkServerVersion . parseVersion) +-- | 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 +-- test snapshotting. Note that this can and should be part of the +-- client functionality in a much less ad-hoc incarnation. +getRepoPaths :: IO [FilePath] +getRepoPaths = withTestEnv $ do + bhe <- getBHEnv + 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 <- HM.lookup "nodes" o + Object firstNode <- snd <$> headMay (HM.toList nodes) + Object settings <- HM.lookup "settings" firstNode + Object path <- HM.lookup "path" settings + Array repo <- HM.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 +canSnapshot = do + caresAboutRepos <- atleast es16 + repoPaths <- getRepoPaths + return (not caresAboutRepos || not (null (repoPaths))) + testServerBranch :: IO (Maybe ServerVersion) testServerBranch = getServerVersion >>= \v -> return $ liftM serverBranch v @@ -328,12 +364,18 @@ withSnapshotRepo => SnapshotRepoName -> (GenericSnapshotRepo -> m a) -> m a -withSnapshotRepo srn@(SnapshotRepoName n) f = - withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f +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 + [] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f where alloc dir = do liftIO (setFileMode dir mode) - let repo = FsSnapshotRepo srn dir True Nothing Nothing Nothing + let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing resp <- updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo liftIO (validateStatus resp 200) return (toGSnapshotRepo repo) @@ -1425,13 +1467,13 @@ main = hspec $ do fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo) describe "snapshot repos" $ do - it "always parses all snapshot repos API" $ withTestEnv $ 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 "finds an existing list of repos" $ withTestEnv $ do + it "finds an existing list of repos" $ when' canSnapshot $ withTestEnv $ do let r1n = SnapshotRepoName "bloodhound-repo1" let r2n = SnapshotRepoName "bloodhound-repo2" withSnapshotRepo r1n $ \r1 -> @@ -1443,7 +1485,7 @@ main = hspec $ do srt xs `shouldBe` srt [r1, r2] Left e -> expectationFailure (show e) - it "creates and updates with updateSnapshotRepo" $ withTestEnv $ do + it "creates and updates with updateSnapshotRepo" $ when' canSnapshot $ withTestEnv $ do let r1n = SnapshotRepoName "bloodhound-repo1" withSnapshotRepo r1n $ \r1 -> do let Just (String dir) = HM.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1)) @@ -1453,7 +1495,7 @@ main = hspec $ do Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [])) liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression) - it "can verify existing repos" $ withTestEnv $ do + it "can verify existing repos" $ when' canSnapshot $ withTestEnv $ do let r1n = SnapshotRepoName "bloodhound-repo1" withSnapshotRepo r1n $ \_ -> do res <- verifySnapshotRepo r1n @@ -1464,7 +1506,7 @@ main = hspec $ do Left e -> expectationFailure (show e) describe "snapshots" $ do - it "always parses all snapshots API" $ withTestEnv $ do + it "always parses all snapshots API" $ when' canSnapshot $ withTestEnv $ do let r1n = SnapshotRepoName "bloodhound-repo1" withSnapshotRepo r1n $ \_ -> do res <- getSnapshots r1n AllSnapshots @@ -1472,7 +1514,7 @@ main = hspec $ do Left e -> expectationFailure ("Expected a right but got Left " <> show e) Right _ -> return () - it "can parse a snapshot that it created" $ withTestEnv $ do + 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" @@ -1488,7 +1530,7 @@ main = hspec $ do Left e -> expectationFailure (show e) describe "snapshot restore" $ do - it "can restore a snapshot that we create" $ withTestEnv $ 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" @@ -1500,7 +1542,7 @@ main = hspec $ do resp2 <- restoreSnapshot r1n s1n settings liftIO (validateStatus resp2 200) - it "can restore and rename" $ withTestEnv $ do + it "can restore and rename" $ when' canSnapshot $ withTestEnv $ do let r1n = SnapshotRepoName "bloodhound-repo1" withSnapshotRepo r1n $ \_ -> do let s1n = SnapshotName "example-snapshot" @@ -1508,11 +1550,14 @@ main = hspec $ do let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)" let replace = RRTLit "restored-" :| [RRSubWholeMatch] let expectedIndex = IndexName "restored-bloodhound-tests-twitter-1" + oldEnoughForOverrides <- liftIO (atleast es15) let overrides = RestoreIndexSettings { restoreOverrideReplicas = Just (ReplicaCount 0) } let settings = defaultSnapshotRestoreSettings { snapRestoreWaitForCompletion = True , snapRestoreRenamePattern = Just pat , snapRestoreRenameReplacement = Just replace - , snapRestoreIndexSettingsOverrides = Just overrides + , snapRestoreIndexSettingsOverrides = if oldEnoughForOverrides + then Just overrides + else Nothing } -- have to close an index to restore it let go = do From 3db652beb878eb03d25cf54b66384dada770dd24 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Fri, 29 Jul 2016 14:46:49 -0700 Subject: [PATCH 09/11] No verification in ES < 1.4 --- tests/tests.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/tests/tests.hs b/tests/tests.hs index 356f93d..f171fbb 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -87,6 +87,9 @@ es12 = ServerVersion 1 2 0 es11 :: ServerVersion es11 = ServerVersion 1 1 0 +es14 :: ServerVersion +es14 = ServerVersion 1 4 0 + es15 :: ServerVersion es15 = ServerVersion 1 5 0 @@ -1495,7 +1498,8 @@ main = hspec $ do Right [roundtrippedNoCompression] <- getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [])) liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression) - it "can verify existing repos" $ when' canSnapshot $ withTestEnv $ do + -- verify came around in 1.4 it seems + it "can verify existing repos" $ when' canSnapshot $ when' (atleast es14) $ withTestEnv $ do let r1n = SnapshotRepoName "bloodhound-repo1" withSnapshotRepo r1n $ \_ -> do res <- verifySnapshotRepo r1n From 8a66203662423d970e11fd8b2bf3ed668c874763 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Fri, 29 Jul 2016 15:03:04 -0700 Subject: [PATCH 10/11] Deprecate es 1.2.4 for tests I could either do this or disable snapshot restore testing on 1.2, but the ES website doesn't even *keep* docs on es 1.2 anymore so I can't really find out how the API differs. I figure that's a fairly strong signal that we could just not support that version offically anymore. --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index f2e8cfe..459aaa1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,7 +10,7 @@ env: # - GHCVER=7.6.3 ESVER=1.6.0 # Deprecated # - GHCVER=7.8.3 ESVER=1.0.3 # Deprecated # - GHCVER=7.8.3 ESVER=1.1.2 # Deprecated - - GHCVER=7.8 ESVER=1.2.4 + # - GHCVER=7.8 ESVER=1.2.4 # deprecated - GHCVER=7.8 ESVER=1.3.6 - GHCVER=7.8 ESVER=1.4.1 - GHCVER=7.10 ESVER=1.5.2 From 5d76570d2887788d2ada5bf6850cd9090a9395c8 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Fri, 29 Jul 2016 16:15:31 -0700 Subject: [PATCH 11/11] Add note about verify API [ci skip] --- src/Database/Bloodhound/Client.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Database/Bloodhound/Client.hs b/src/Database/Bloodhound/Client.hs index 980a082..aabbda2 100644 --- a/src/Database/Bloodhound/Client.hs +++ b/src/Database/Bloodhound/Client.hs @@ -324,7 +324,9 @@ updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = --- | Verify if a snapshot repo is working. +-- | 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