From 06819a6b44411bf54ed0e1349fdd2244db470353 Mon Sep 17 00:00:00 2001 From: Michael Xavier Date: Tue, 19 Jul 2016 16:15:17 -0700 Subject: [PATCH] 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