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