bloodhound-1.0.0.0: tests/Test/SnapshotsSpec.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Test.SnapshotsSpec (spec) where
import Control.Monad.Catch (MonadMask, bracket, bracket_, finally)
import Data.Aeson.KeyMap qualified as X
import Data.HashMap.Strict qualified as HM
import Data.List qualified as L
import Data.Text qualified as T
import Data.Vector qualified as V
import Network.HTTP.Types.Method qualified as NHTM
import TestsUtils.Common
import TestsUtils.Generators ()
import TestsUtils.Import
spec :: Spec
spec = do
describe "FsSnapshotRepo" $
prop "SnapshotRepo laws" $ \fsr ->
fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo)
describe "SnapshotStatus JSON parsing" $ do
let inProgressBody =
"{\"snapshots\":[{\"snapshot\":\"snap-1\",\"repository\":\"repo-1\",\"uuid\":\"abc-123\",\"state\":\"STARTED\",\"include_global_state\":true,\"shards_stats\":{\"initializing\":0,\"started\":1,\"finalizing\":0,\"done\":1,\"failed\":0,\"total\":2},\"stats\":{\"incremental\":{\"file_count\":4,\"size_in_bytes\":5412},\"total\":{\"file_count\":4,\"size_in_bytes\":5412},\"start_time_in_millis\":1750452674327,\"time_in_millis\":189},\"indices\":{\"index-1\":{\"shards_stats\":{\"initializing\":0,\"started\":1,\"finalizing\":0,\"done\":0,\"failed\":0,\"total\":1},\"stats\":{\"incremental\":{\"file_count\":2,\"size_in_bytes\":100},\"total\":{\"file_count\":2,\"size_in_bytes\":100}},\"shards\":{\"0\":{\"stage\":\"STARTED\",\"stats\":{\"incremental\":{\"file_count\":1,\"size_in_bytes\":50}},\"node\":\"VJzy6aKJSVKwcfjIFBPXxw\"},\"1\":{\"stage\":\"FAILURE\",\"reason\":\"disk full\",\"node\":\"VJzy6aKJSVKwcfjIFBPXxw\"}}}}}]}"
minimalBody =
"{\"snapshots\":[{\"snapshot\":\"snap-2\",\"repository\":\"repo-1\",\"uuid\":\"def-456\",\"state\":\"SUCCESS\",\"include_global_state\":false,\"shards_stats\":{\"initializing\":0,\"started\":0,\"finalizing\":0,\"done\":2,\"failed\":0,\"total\":2}}]}"
it "parses a full in-progress status response" $
case parseEither parseJSON =<< eitherDecode inProgressBody :: Either String SSs of
Right (SSs [status]) -> do
snapshotStatusSnapshot status `shouldBe` SnapshotName "snap-1"
snapshotStatusRepository status `shouldBe` SnapshotRepoName "repo-1"
snapshotStatusUuid status `shouldBe` "abc-123"
snapshotStatusState status `shouldBe` SnapshotStarted
snapshotStatusIncludeGlobalState status `shouldBe` True
snapShardStatsTotal (snapshotStatusShardsStats status) `shouldBe` 2
HM.keys (snapshotStatusIndices status) `shouldBe` ["index-1"]
other -> expectationFailure ("expected singleton SnapshotStatus list, got " <> show other)
it "captures the FAILURE shard stage and reason field" $
case parseEither parseJSON =<< eitherDecode inProgressBody :: Either String SSs of
Right (SSs [status]) -> do
let indices = snapshotStatusIndices status
Just indexStatus = HM.lookup "index-1" indices
Just failedShard = HM.lookup "1" (sisShards indexStatus)
snapShardStatusStage failedShard `shouldBe` ShardSnapshotFailure
snapShardStatusReason failedShard `shouldBe` Just "disk full"
other -> expectationFailure ("expected singleton SnapshotStatus list, got " <> show other)
it "parses a minimal completed snapshot status" $
case parseEither parseJSON =<< eitherDecode minimalBody :: Either String SSs of
Right (SSs [status]) -> do
snapshotStatusState status `shouldBe` SnapshotSuccess
snapshotStatusIndices status `shouldBe` mempty
snapshotStatusStats status `shouldBe` Nothing
other -> expectationFailure ("expected minimal parse, got " <> show other)
it "rejects an invalid shard stage token" $ do
let bad =
"{\"snapshot\":\"s\",\"repository\":\"r\",\"uuid\":\"u\",\"state\":\"SUCCESS\",\"shards_stats\":{\"initializing\":0,\"started\":0,\"finalizing\":0,\"done\":0,\"failed\":0,\"total\":0},\"indices\":{\"i\":{\"shards_stats\":{\"initializing\":0,\"started\":0,\"finalizing\":0,\"done\":0,\"failed\":0,\"total\":0},\"shards\":{\"0\":{\"stage\":\"BOGUS\"}}}}}"
case parseEither parseJSON =<< eitherDecode bad :: Either String SnapshotStatus of
Left _ -> return ()
Right v -> expectationFailure ("expected stage parsing failure, got " <> show v)
describe "SnapshotInfo JSON parsing" $ do
let -- Realistic modern (ES 7+/OS) response carrying the six
-- optional fields. The other fields mirror what the server
-- returns for a completed snapshot.
fullBody =
"{\"snapshots\":[{\"snapshot\":\"snap-1\",\"repository\":\"repo-1\",\"uuid\":\"abc-123\",\"state\":\"SUCCESS\",\"version_id\":8170000,\"version\":\"8.17.0\",\"include_global_state\":true,\"metadata\":{\"created_by\":\"backup-job\"},\"data_streams\":[\"logs-stream\",\"metrics-stream\"],\"feature_states\":[{\"feature_name\":\"kibana\",\"indices\":[\".kibana_1\"]},{\"feature_name\":\"transforms\",\"indices\":[\".transform-indices-000001\"]}],\"shards\":{\"total\":2,\"successful\":2,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":134,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674327,\"indices\":[\"index-1\"]}]}"
-- Older server response (pre-ES 7) without any of the six
-- optional fields. Must still parse with all six accessors
-- returning 'Nothing'.
legacyBody =
"{\"snapshots\":[{\"snapshot\":\"snap-2\",\"state\":\"SUCCESS\",\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":50,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674411,\"indices\":[]}]}"
it "parses the modern fields (version_id, version, include_global_state, metadata)" $
case parseEither parseJSON =<< eitherDecode fullBody :: Either String SIs of
Right (SIs [info]) -> do
snapInfoName info `shouldBe` SnapshotName "snap-1"
-- 'snapInfoUuid' is introduced in bloodhound-kc1; pin it
-- here so future refactors don't drop the field. The
-- fixture carries @"uuid":"abc-123"@.
snapInfoUuid info `shouldBe` Just "abc-123"
snapInfoState info `shouldBe` SnapshotSuccess
snapInfoVersionId info `shouldBe` Just 8170000
snapInfoVersion info `shouldBe` Just "8.17.0"
snapInfoIncludeGlobalState info `shouldBe` Just True
-- metadata preserved verbatim as a JSON object
case snapInfoMetadata info of
Just o -> X.lookup "created_by" o `shouldBe` Just "backup-job"
Nothing -> expectationFailure "expected metadata object, got Nothing"
snapInfoDataStreams info `shouldBe` Just ["logs-stream", "metrics-stream"]
case snapInfoFeatureStates info of
Just [fs1, fs2] -> do
snapshotFeatureStateName fs1 `shouldBe` "kibana"
map unIndexName (snapshotFeatureStateIndices fs1) `shouldBe` [".kibana_1"]
snapshotFeatureStateName fs2 `shouldBe` "transforms"
map unIndexName (snapshotFeatureStateIndices fs2)
`shouldBe` [".transform-indices-000001"]
other ->
expectationFailure ("expected two feature states, got " <> show other)
other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other)
it "leaves the new fields as Nothing when absent (legacy payloads)" $
case parseEither parseJSON =<< eitherDecode legacyBody :: Either String SIs of
Right (SIs [info]) -> do
snapInfoName info `shouldBe` SnapshotName "snap-2"
snapInfoUuid info `shouldBe` Nothing
snapInfoVersionId info `shouldBe` Nothing
snapInfoVersion info `shouldBe` Nothing
snapInfoIncludeGlobalState info `shouldBe` Nothing
snapInfoMetadata info `shouldBe` Nothing
snapInfoDataStreams info `shouldBe` Nothing
snapInfoFeatureStates info `shouldBe` Nothing
other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other)
it "parses data_streams and feature_states from a minimal body" $ do
let dataStreamsBody =
"{\"snapshots\":[{\"snapshot\":\"snap-ds\",\"state\":\"SUCCESS\",\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":10,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674451,\"indices\":[],\"data_streams\":[\"logs\",\"metrics\"],\"feature_states\":[{\"feature_name\":\"geoip\",\"indices\":[\".geoip_databases\"]}]}]}"
case parseEither parseJSON =<< eitherDecode dataStreamsBody :: Either String SIs of
Right (SIs [info]) -> do
snapInfoName info `shouldBe` SnapshotName "snap-ds"
snapInfoDataStreams info `shouldBe` Just ["logs", "metrics"]
case snapInfoFeatureStates info of
Just [fs] -> do
snapshotFeatureStateName fs `shouldBe` "geoip"
map unIndexName (snapshotFeatureStateIndices fs)
`shouldBe` [".geoip_databases"]
other ->
expectationFailure ("expected one feature state, got " <> show other)
other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other)
it "treats empty arrays as Just [] and supports field asymmetry" $ do
-- feature_states present but empty: Just [], NOT Nothing. And
-- the two fields are independent (data_streams populated here).
let asymBody =
"{\"snapshots\":[{\"snapshot\":\"snap-asym\",\"state\":\"SUCCESS\",\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":10,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674451,\"indices\":[],\"data_streams\":[\"logs\"],\"feature_states\":[]}]}"
case parseEither parseJSON =<< eitherDecode asymBody :: Either String SIs of
Right (SIs [info]) -> do
snapInfoName info `shouldBe` SnapshotName "snap-asym"
snapInfoDataStreams info `shouldBe` Just ["logs"]
snapInfoFeatureStates info `shouldBe` Just []
other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other)
it "parses an empty metadata object as Just (preserved verbatim)" $ do
let emptyMetaBody =
"{\"snapshots\":[{\"snapshot\":\"snap-3\",\"state\":\"SUCCESS\",\"version_id\":7170000,\"version\":\"7.17.0\",\"include_global_state\":false,\"metadata\":{},\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":10,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674451,\"indices\":[]}]}"
case parseEither parseJSON =<< eitherDecode emptyMetaBody :: Either String SIs of
Right (SIs [info]) -> do
snapInfoName info `shouldBe` SnapshotName "snap-3"
-- metadata is present (not Nothing) but empty
snapInfoMetadata info `shouldSatisfy` isJust
case snapInfoMetadata info of
Just o -> X.null o `shouldBe` True
Nothing -> return ()
other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other)
describe "CreateSnapshotResponse JSON parsing" $ do
-- wait_for_completion=false (the default): the server returns
-- {"acknowledged": <bool>}.
it "decodes the acknowledged shape (wait_for_completion=false)" $ do
let body = "{\"acknowledged\":true}"
case parseEither parseJSON =<< eitherDecode body :: Either String CreateSnapshotResponse of
Right (CreateSnapshotAcknowledged (Acknowledged ack)) -> ack `shouldBe` True
other ->
expectationFailure ("expected CreateSnapshotAcknowledged, got " <> show other)
-- wait_for_completion=true: the server returns a full snapshot
-- object {"snapshot": {…}} with the SnapshotInfo shape.
it "decodes the completed snapshot shape (wait_for_completion=true)" $ do
let body =
"{\"snapshot\":{\"snapshot\":\"snap-1\",\"uuid\":\"abc-123\",\
\\"state\":\"SUCCESS\",\
\\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\
\\"failures\":[],\"duration_in_millis\":50,\
\\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674411,\
\\"indices\":[]}}"
case parseEither parseJSON =<< eitherDecode body :: Either String CreateSnapshotResponse of
Right (CreateSnapshotCompleted (SnapshotResponse info)) -> do
snapInfoName info `shouldBe` SnapshotName "snap-1"
snapInfoUuid info `shouldBe` Just "abc-123"
snapInfoState info `shouldBe` SnapshotSuccess
other ->
expectationFailure ("expected CreateSnapshotCompleted, got " <> show other)
-- When both keys are present (ES never legitimately returns both),
-- the @"snapshot"@ key takes priority, matching the documented
-- wait_for_completion=true shape.
it "prefers the snapshot key when both snapshot and acknowledged are present" $ do
let body =
"{\"acknowledged\":true,\"snapshot\":{\"snapshot\":\"snap-1\",\"state\":\"SUCCESS\",\
\\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\
\\"failures\":[],\"duration_in_millis\":50,\
\\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674411,\
\\"indices\":[]}}"
case parseEither parseJSON =<< eitherDecode body :: Either String CreateSnapshotResponse of
Right completed@(CreateSnapshotCompleted _) -> completed `seq` return ()
other ->
expectationFailure ("expected CreateSnapshotCompleted, got " <> show other)
it "rejects an object with neither acknowledged nor snapshot" $ do
let body = "{\"foo\":1}"
case parseEither parseJSON =<< eitherDecode body :: Either String CreateSnapshotResponse of
Right other -> expectationFailure ("expected parse failure, got " <> show other)
Left _ -> return ()
describe "SnapshotSelectionOptions params" $ do
it "defaultSnapshotSelectionOptions renders no query string" $
snapshotSelectionOptionsParams defaultSnapshotSelectionOptions `shouldBe` []
it "renders every field when set" $ do
let opts =
defaultSnapshotSelectionOptions
{ ssoMasterTimeout = Just (TimeUnitSeconds, 30),
ssoVerbose = Just True,
ssoIndexDetails = Just False,
ssoIncludeRepository = Just True,
ssoSort = Just SortSnapshotByDuration,
ssoOrder = Just SortOrderDesc,
ssoSize = Just 10,
ssoOffset = Just 0,
ssoAfter = Just "snap-1",
ssoFromSortValue = Just "2020-01-01T00:00:00Z",
ssoIgnoreUnavailableSnapshots = Just True,
ssoIndexNames = Just False,
ssoSlmPolicyFilter = Just "policy-1"
}
L.sortOn fst (snapshotSelectionOptionsParams opts)
`shouldBe` L.sortOn
fst
[ ("master_timeout", Just "30s"),
("verbose", Just "true"),
("index_details", Just "false"),
("include_repository", Just "true"),
("sort", Just "duration"),
("order", Just "desc"),
("size", Just "10"),
("offset", Just "0"),
("after", Just "snap-1"),
("from_sort_value", Just "2020-01-01T00:00:00Z"),
("ignore_unavailable", Just "true"),
("index_names", Just "false"),
("slm_policy_filter", Just "policy-1")
]
it "renders each SnapshotSortField wire token" $
map renderSnapshotSortField [SortSnapshotByStartTime, SortSnapshotByDuration, SortSnapshotByName, SortSnapshotByRepository, SortSnapshotByIndices]
`shouldBe` ["start_time", "duration", "name", "repository", "indices"]
it "renders each SnapshotSortOrder wire token" $
map renderSnapshotSortOrder [SortOrderAsc, SortOrderDesc]
`shouldBe` ["asc", "desc"]
it "omits every new field by default" $
snapshotSelectionOptionsParams defaultSnapshotSelectionOptions `shouldBe` []
describe "SnapshotMasterTimeoutOptions params" $ do
it "defaultSnapshotMasterTimeoutOptions renders no query string" $
snapshotMasterTimeoutOptionsParams defaultSnapshotMasterTimeoutOptions `shouldBe` []
it "renders master_timeout when set" $ do
let opts = defaultSnapshotMasterTimeoutOptions {smtoMasterTimeout = Just (TimeUnitSeconds, 30)}
snapshotMasterTimeoutOptionsParams opts `shouldBe` [("master_timeout", Just "30s")]
it "renders master_timeout with each TimeUnits suffix" $ do
let mk u = defaultSnapshotMasterTimeoutOptions {smtoMasterTimeout = Just (u, 5)}
map snapshotMasterTimeoutOptionsParams (map mk [TimeUnitDays, TimeUnitHours, TimeUnitMinutes, TimeUnitSeconds, TimeUnitMilliseconds])
`shouldBe` [ [("master_timeout", Just "5d")],
[("master_timeout", Just "5h")],
[("master_timeout", Just "5m")],
[("master_timeout", Just "5s")],
[("master_timeout", Just "5ms")]
]
-- ------------------------------------------------------------------ --
-- Endpoint shape: pure checks against the BHRequest value; no live --
-- backend needed. Mirrors the putILMPolicy / updateClusterSettings --
-- shape tests. --
-- ------------------------------------------------------------------ --
describe "createSnapshot endpoint shape" $ do
let repo = SnapshotRepoName "repo-1"
snap = SnapshotName "snap-1"
it "POSTs /_snapshot/{repo}/{snap} with only wait_for_completion by default" $ do
let req = createSnapshot repo snap defaultSnapshotCreateSettings
bhRequestMethod req `shouldBe` "POST"
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "repo-1", "snap-1"]
L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req))
`shouldBe` L.sortOn fst [("wait_for_completion", Just "false")]
it "omits master_timeout when snapMasterTimeout is Nothing" $
( lookup "master_timeout" . getRawEndpointQueries . bhRequestEndpoint $
createSnapshot repo snap defaultSnapshotCreateSettings
)
`shouldBe` Nothing
it "forwards master_timeout when snapMasterTimeout is set" $ do
let settings = defaultSnapshotCreateSettings {snapMasterTimeout = Just (TimeUnitMilliseconds, 500)}
req = createSnapshot repo snap settings
lookup "master_timeout" (getRawEndpointQueries (bhRequestEndpoint req)) `shouldBe` Just (Just "500ms")
it "omits metadata and feature_states from the body when Nothing" $ do
let req = createSnapshot repo snap defaultSnapshotCreateSettings
case decode =<< bhRequestBody req :: Maybe Object of
Just o -> do
X.lookup "metadata" o `shouldBe` Nothing
X.lookup "feature_states" o `shouldBe` Nothing
Nothing -> expectationFailure "expected a JSON object body"
it "includes metadata and feature_states in the body when set" $ do
let settings =
defaultSnapshotCreateSettings
{ snapMetadata = Just (X.singleton "created_by" (String "backup-job")),
snapFeatureStates = Just ("data_streams" :| ["templates"])
}
req = createSnapshot repo snap settings
case decode =<< bhRequestBody req :: Maybe Object of
Just o -> do
X.lookup "metadata" o `shouldBe` Just (object ["created_by" .= ("backup-job" :: Text)])
X.lookup "feature_states" o `shouldBe` Just (toJSON (["data_streams", "templates"] :: [Text]))
Nothing -> expectationFailure "expected a JSON object body"
it "serializes snapIncludeGlobalState under include_global_state (regression: was ignore_global_state)" $ do
let reqOn = createSnapshot repo snap defaultSnapshotCreateSettings {snapIncludeGlobalState = True}
reqOff = createSnapshot repo snap defaultSnapshotCreateSettings {snapIncludeGlobalState = False}
case decode =<< bhRequestBody reqOn :: Maybe Object of
Just o -> do
X.lookup "include_global_state" o `shouldBe` Just (Bool True)
X.lookup "ignore_global_state" o `shouldBe` Nothing
Nothing -> expectationFailure "expected a JSON object body for snapIncludeGlobalState=True"
case decode =<< bhRequestBody reqOff :: Maybe Object of
Just o -> do
X.lookup "include_global_state" o `shouldBe` Just (Bool False)
X.lookup "ignore_global_state" o `shouldBe` Nothing
Nothing -> expectationFailure "expected a JSON object body for snapIncludeGlobalState=False"
describe "restoreSnapshot endpoint shape" $ do
let repo = SnapshotRepoName "repo-1"
snap = SnapshotName "snap-1"
it "forwards master_timeout via snapRestoreMasterTimeout" $ do
let settings = defaultSnapshotRestoreSettings {snapRestoreMasterTimeout = Just (TimeUnitSeconds, 30)}
req = restoreSnapshot repo snap settings
lookup "master_timeout" (getRawEndpointQueries (bhRequestEndpoint req)) `shouldBe` Just (Just "30s")
it "omits master_timeout by default" $
( lookup "master_timeout" . getRawEndpointQueries . bhRequestEndpoint $
restoreSnapshot repo snap defaultSnapshotRestoreSettings
)
`shouldBe` Nothing
describe "updateSnapshotRepo endpoint shape" $ do
it "forwards master_timeout and verify=false" $ do
let settings =
defaultSnapshotRepoUpdateSettings
{ repoUpdateVerify = False,
repoUpdateMasterTimeout = Just (TimeUnitSeconds, 30)
}
repo = FsSnapshotRepo (SnapshotRepoName "r") "/tmp/r" True Nothing Nothing Nothing
req = updateSnapshotRepo settings repo
L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req))
`shouldBe` [("master_timeout", Just "30s"), ("verify", Just "false")]
it "emits only master_timeout when verify=True (default)" $ do
let settings = defaultSnapshotRepoUpdateSettings {repoUpdateMasterTimeout = Just (TimeUnitMinutes, 1)}
repo = FsSnapshotRepo (SnapshotRepoName "r") "/tmp/r" True Nothing Nothing Nothing
req = updateSnapshotRepo settings repo
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "1m")]
it "forwards timeout alongside master_timeout and verify=false" $ do
let settings =
defaultSnapshotRepoUpdateSettings
{ repoUpdateVerify = False,
repoUpdateMasterTimeout = Just (TimeUnitSeconds, 30),
repoUpdateTimeout = Just (TimeUnitMinutes, 1)
}
repo = FsSnapshotRepo (SnapshotRepoName "r") "/tmp/r" True Nothing Nothing Nothing
req = updateSnapshotRepo settings repo
L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req))
`shouldBe` [ ("master_timeout", Just "30s"),
("timeout", Just "1m"),
("verify", Just "false")
]
it "omits timeout by default" $
( lookup "timeout" . getRawEndpointQueries . bhRequestEndpoint $
updateSnapshotRepo
defaultSnapshotRepoUpdateSettings
(FsSnapshotRepo (SnapshotRepoName "r") "/tmp/r" True Nothing Nothing Nothing)
)
`shouldBe` Nothing
describe "snapshot *With endpoint shapes" $ do
it "getSnapshotReposWith attaches master_timeout and local" $ do
let opts =
defaultSnapshotRepoGetOptions
{ srgoLocal = Just True,
srgoMasterTimeout = Just (TimeUnitSeconds, 30)
}
req = getSnapshotReposWith AllSnapshotRepos opts
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "_all"]
L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req))
`shouldBe` [("local", Just "true"), ("master_timeout", Just "30s")]
it "omits local by default in getSnapshotReposWith" $
( lookup "local" . getRawEndpointQueries . bhRequestEndpoint $
getSnapshotReposWith AllSnapshotRepos defaultSnapshotRepoGetOptions
)
`shouldBe` Nothing
it "getSnapshotReposWith default mirrors getSnapshotRepos" $ do
let viaPlain = getSnapshotRepos AllSnapshotRepos
viaWith = getSnapshotReposWith AllSnapshotRepos defaultSnapshotRepoGetOptions
getRawEndpointQueries (bhRequestEndpoint viaPlain)
`shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith)
it "verifySnapshotRepoWith attaches master_timeout and timeout" $ do
let opts =
defaultSnapshotRepoTimeoutOptions
{ srtoTimeout = Just (TimeUnitSeconds, 30),
srtoMasterTimeout = Just (TimeUnitMinutes, 1)
}
req = verifySnapshotRepoWith (SnapshotRepoName "r") opts
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "r", "_verify"]
L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req))
`shouldBe` [("master_timeout", Just "1m"), ("timeout", Just "30s")]
it "verifySnapshotRepoWith default mirrors verifySnapshotRepo" $ do
let viaPlain = verifySnapshotRepo (SnapshotRepoName "r")
viaWith = verifySnapshotRepoWith (SnapshotRepoName "r") defaultSnapshotRepoTimeoutOptions
getRawEndpointQueries (bhRequestEndpoint viaPlain)
`shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith)
it "deleteSnapshotRepoWith attaches master_timeout and timeout" $ do
let opts =
defaultSnapshotRepoTimeoutOptions
{ srtoTimeout = Just (TimeUnitSeconds, 30),
srtoMasterTimeout = Just (TimeUnitMinutes, 1)
}
req = deleteSnapshotRepoWith (SnapshotRepoName "r") opts
bhRequestMethod req `shouldBe` "DELETE"
L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req))
`shouldBe` [("master_timeout", Just "1m"), ("timeout", Just "30s")]
it "deleteSnapshotRepoWith default mirrors deleteSnapshotRepo" $ do
let viaPlain = deleteSnapshotRepo (SnapshotRepoName "r")
viaWith = deleteSnapshotRepoWith (SnapshotRepoName "r") defaultSnapshotRepoTimeoutOptions
getRawEndpointQueries (bhRequestEndpoint viaPlain)
`shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith)
it "deleteSnapshotWith attaches master_timeout" $ do
let opts = defaultSnapshotMasterTimeoutOptions {smtoMasterTimeout = Just (TimeUnitSeconds, 30)}
req = deleteSnapshotWith (SnapshotRepoName "r") (SnapshotName "s") opts
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "r", "s"]
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "30s")]
it "getSnapshotStatusWith attaches master_timeout and ignore_unavailable" $ do
let opts =
defaultSnapshotStatusOptions
{ sstoIgnoreUnavailable = Just True,
sstoMasterTimeout = Just (TimeUnitSeconds, 30)
}
req = getSnapshotStatusWith (SnapshotRepoName "r") (SnapshotName "s") opts
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "r", "s", "_status"]
L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req))
`shouldBe` [("ignore_unavailable", Just "true"), ("master_timeout", Just "30s")]
it "getSnapshotStatusWith default mirrors getSnapshotStatus" $ do
let viaPlain = getSnapshotStatus (SnapshotRepoName "r") (SnapshotName "s")
viaWith =
getSnapshotStatusWith
(SnapshotRepoName "r")
(SnapshotName "s")
defaultSnapshotStatusOptions
getRawEndpointQueries (bhRequestEndpoint viaPlain)
`shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith)
describe "cleanupSnapshotRepo endpoint shape" $ do
let repo = SnapshotRepoName "repo-1"
it "POSTs /_snapshot/{repo}/_cleanup with empty body by default" $ do
let req = cleanupSnapshotRepo repo
bhRequestMethod req `shouldBe` "POST"
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "repo-1", "_cleanup"]
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []
bhRequestBody req `shouldBe` Just ""
it "omits master_timeout by default" $
( lookup "master_timeout" . getRawEndpointQueries . bhRequestEndpoint $
cleanupSnapshotRepo repo
)
`shouldBe` Nothing
describe "cleanupSnapshotRepoWith endpoint shape" $ do
let repo = SnapshotRepoName "r"
opts = defaultSnapshotMasterTimeoutOptions {smtoMasterTimeout = Just (TimeUnitSeconds, 30)}
it "attaches master_timeout when set" $ do
let req = cleanupSnapshotRepoWith repo opts
bhRequestMethod req `shouldBe` "POST"
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "r", "_cleanup"]
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "30s")]
it "default mirrors cleanupSnapshotRepo byte-for-byte" $ do
let viaPlain = cleanupSnapshotRepo repo
viaWith = cleanupSnapshotRepoWith repo defaultSnapshotMasterTimeoutOptions
getRawEndpoint (bhRequestEndpoint viaPlain) `shouldBe` getRawEndpoint (bhRequestEndpoint viaWith)
getRawEndpointQueries (bhRequestEndpoint viaPlain) `shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith)
bhRequestMethod viaPlain `shouldBe` bhRequestMethod viaWith
bhRequestBody viaPlain `shouldBe` bhRequestBody viaWith
describe "SnapshotCleanupResult JSON parsing" $ do
let typicalBody = "{\"results\":{\"deleted_bytes\":20,\"deleted_blobs\":5}}"
zeroBody = "{\"results\":{\"deleted_bytes\":0,\"deleted_blobs\":0}}"
it "parses a typical cleanup response" $
case parseEither parseJSON =<< eitherDecode typicalBody :: Either String SnapshotCleanupResult of
Right result -> do
snapshotCleanupDeletedBytes result `shouldBe` 20
snapshotCleanupDeletedBlobs result `shouldBe` 5
other -> expectationFailure ("expected SnapshotCleanupResult, got " <> show other)
it "parses a nothing-to-cleanup response (zero counts)" $
case parseEither parseJSON =<< eitherDecode zeroBody :: Either String SnapshotCleanupResult of
Right result -> do
snapshotCleanupDeletedBytes result `shouldBe` 0
snapshotCleanupDeletedBlobs result `shouldBe` 0
other -> expectationFailure ("expected zero SnapshotCleanupResult, got " <> show other)
it "rejects a payload missing the results wrapper" $ do
let bad = "{\"deleted_bytes\":20,\"deleted_blobs\":5}"
case parseEither parseJSON =<< eitherDecode bad :: Either String SnapshotCleanupResult of
Left _ -> return ()
Right v -> expectationFailure ("expected parse failure, got " <> show v)
describe "cloneSnapshot endpoint shape" $ do
let repo = SnapshotRepoName "repo-1"
src = SnapshotName "snap-1"
target = SnapshotName "clone-1"
it "PUTs /_snapshot/{repo}/{src}/_clone/{target} with target in path, not body" $ do
let req = cloneSnapshot repo src target defaultSnapshotCloneSettings
bhRequestMethod req `shouldBe` "PUT"
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "repo-1", "snap-1", "_clone", "clone-1"]
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []
case decode =<< bhRequestBody req :: Maybe Object of
Just o -> X.lookup "target" o `shouldBe` Nothing
Nothing -> expectationFailure "expected a JSON object body"
it "omits indices from the body when snapCloneIndices is Nothing" $ do
let req = cloneSnapshot repo src target defaultSnapshotCloneSettings
case decode =<< bhRequestBody req :: Maybe Object of
Just o -> X.lookup "indices" o `shouldBe` Nothing
Nothing -> expectationFailure "expected a JSON object body"
it "serializes snapCloneIndices as a comma-separated string under indices" $ do
let settings =
defaultSnapshotCloneSettings
{ snapCloneIndices = Just (IndexList ([qqIndexName|idx-a|] :| [[qqIndexName|idx-b|]]))
}
req = cloneSnapshot repo src target settings
case decode =<< bhRequestBody req :: Maybe Object of
Just o -> X.lookup "indices" o `shouldBe` Just (String "idx-a,idx-b")
Nothing -> expectationFailure "expected a JSON object body"
it "renders AllIndexes as \"_all\" under indices" $ do
let settings = defaultSnapshotCloneSettings {snapCloneIndices = Just AllIndexes}
req = cloneSnapshot repo src target settings
case decode =<< bhRequestBody req :: Maybe Object of
Just o -> X.lookup "indices" o `shouldBe` Just (String "_all")
Nothing -> expectationFailure "expected a JSON object body"
it "omits master_timeout by default" $
( lookup "master_timeout" . getRawEndpointQueries . bhRequestEndpoint $
cloneSnapshot repo src target defaultSnapshotCloneSettings
)
`shouldBe` Nothing
it "forwards master_timeout when snapCloneMasterTimeout is set" $ do
let settings = defaultSnapshotCloneSettings {snapCloneMasterTimeout = Just (TimeUnitSeconds, 30)}
req = cloneSnapshot repo src target settings
lookup "master_timeout" (getRawEndpointQueries (bhRequestEndpoint req)) `shouldBe` Just (Just "30s")
describe "Snapshot repos" $ do
it "always parses all snapshot repos API" $
when' canSnapshot $
withTestEnv $ do
res <- tryPerformBHRequest $ getSnapshotRepos AllSnapshotRepos
liftIO $ case res of
Left e -> expectationFailure ("Expected a right but got Left " <> show e)
Right _ -> return ()
it "finds an existing list of repos" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
let r2n = SnapshotRepoName "bloodhound-repo2"
withSnapshotRepo r1n $ \r1 ->
withSnapshotRepo r2n $ \r2 -> do
repos <- performBHRequest $ getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| [ExactRepo r2n]))
let srt = L.sortOn gSnapshotRepoName
liftIO $ srt repos `shouldBe` srt [r1, r2]
it "creates and updates with updateSnapshotRepo" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
withSnapshotRepo r1n $ \r1 -> do
let Just (String dir) = X.lookup "location" (gSnapshotRepoSettingsObject (gSnapshotRepoSettings r1))
let noCompression = FsSnapshotRepo r1n (T.unpack dir) False Nothing Nothing Nothing
resp <- performBHRequest $ updateSnapshotRepo defaultSnapshotRepoUpdateSettings noCompression
liftIO $ resp `shouldBe` Acknowledged True
[roundtrippedNoCompression] <- performBHRequest $ getSnapshotRepos (SnapshotRepoList (ExactRepo r1n :| []))
liftIO (roundtrippedNoCompression `shouldBe` toGSnapshotRepo noCompression)
-- verify came around in 1.4 it seems
it "can verify existing repos" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
withSnapshotRepo r1n $ \_ -> do
res <- performBHRequest $ verifySnapshotRepo r1n
liftIO $ case res of
SnapshotVerification vs
| null vs -> expectationFailure "Expected nonempty set of verifying nodes"
| otherwise -> return ()
describe "Snapshots" $ do
it "always parses all snapshots API" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
withSnapshotRepo r1n $ \_ -> do
res <- tryPerformBHRequest $ getSnapshots r1n AllSnapshots
liftIO $ case res of
Left e -> expectationFailure ("Expected a right but got Left " <> show e)
Right _ -> return ()
it "can parse a snapshot that it created" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
withSnapshotRepo r1n $ \_ -> do
let s1n = SnapshotName "example-snapshot"
withSnapshot r1n s1n $ do
res <- performBHRequest $ getSnapshots r1n (SnapshotList (ExactSnap s1n :| []))
liftIO $ case res of
[snap]
| snapInfoState snap == SnapshotSuccess
&& snapInfoName snap == s1n ->
return ()
| otherwise -> expectationFailure (show snap)
[] -> expectationFailure "There were no snapshots"
snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps))
it "getSnapshotsWith default options mirrors getSnapshots and exposes version metadata" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
withSnapshotRepo r1n $ \_ -> do
let s1n = SnapshotName "example-snapshot"
withSnapshot r1n s1n $ do
let sel = SnapshotList (ExactSnap s1n :| [])
viaPlain <- performBHRequest $ getSnapshots r1n sel
viaWith <- performBHRequest $ getSnapshotsWith r1n sel defaultSnapshotSelectionOptions
liftIO $ do
-- Same snapshot name set, proving the default-options
-- wire call is observationally equivalent.
map snapInfoName viaWith `shouldBe` map snapInfoName viaPlain
case viaWith of
[snap]
| snapInfoState snap == SnapshotSuccess -> do
-- version_id/version are emitted by every
-- snapshot-capable server we test against; we
-- assert presence rather than an exact value
-- so the test does not bit-rot across engine
-- versions.
case snapInfoVersionId snap of
Just _ -> return ()
Nothing -> expectationFailure "expected version_id in modern snapshot response"
| otherwise -> expectationFailure ("snapshot not SUCCESS: " <> show snap)
other -> expectationFailure ("expected singleton via getSnapshotsWith, got " <> show other)
it "can fetch shard-level status of a completed snapshot" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
withSnapshotRepo r1n $ \_ -> do
let s1n = SnapshotName "example-snapshot"
withSnapshot r1n s1n $ do
res <- performBHRequest $ getSnapshotStatus r1n s1n
liftIO $ case res of
[status]
| snapshotStatusSnapshot status == s1n
&& snapshotStatusRepository status == r1n
&& snapshotStatusState status == SnapshotSuccess ->
return ()
| otherwise -> expectationFailure (show status)
[] -> expectationFailure "There were no snapshot statuses"
statuses -> expectationFailure ("Expected 1 status but got" <> show (length statuses))
describe "Snapshot restore" $ do
it "can restore a snapshot that we create" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
withSnapshotRepo r1n $ \_ -> do
let s1n = SnapshotName "example-snapshot"
withSnapshot r1n s1n $ do
let settings = defaultSnapshotRestoreSettings {snapRestoreWaitForCompletion = True}
-- have to close an index to restore it
resp1 <- performBHRequest $ closeIndex testIndex
liftIO $ resp1 `shouldBe` Acknowledged True
resp2 <- performBHRequest $ restoreSnapshot r1n s1n settings
liftIO $ resp2 `shouldBe` Accepted True
it "can restore and rename" $
when' canSnapshot $
withTestEnv $ do
let r1n = SnapshotRepoName "bloodhound-repo1"
withSnapshotRepo r1n $ \_ -> do
let s1n = SnapshotName "example-snapshot"
withSnapshot r1n s1n $ do
let pat = RestoreRenamePattern "bloodhound-tests-twitter-(\\d+)"
let replace = RRTLit "restored-" :| [RRSubWholeMatch]
let expectedIndex = [qqIndexName|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 <- performBHRequest $ restoreSnapshot r1n s1n settings
liftIO $ resp `shouldBe` Accepted True
exists <- performBHRequest $ indexExists expectedIndex
liftIO (exists `shouldBe` True)
go `finally` performBHRequest (deleteIndex expectedIndex)
-- | Get configured repo paths for snapshotting. Note that by default
-- this is not enabled and if we are over es 1.5, we won't be able to
-- 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
Object o <-
performBHRequest $ mkSimpleRequest @StatusIndependant NHTM.methodGet $ mkEndpoint ["_nodes"]
return $
fromMaybe mempty $ do
Object nodes <- X.lookup "nodes" o
Object firstNode <- snd <$> headMay (X.toList nodes)
Object settings <- X.lookup "settings" firstNode
Object path <- X.lookup "path" settings
Array repo <- X.lookup "repo" path
return [T.unpack t | String t <- V.toList repo]
-- | 1.5 and earlier don't care about repo paths
canSnapshot :: IO Bool
canSnapshot = do
repoPaths <- getRepoPaths
return (not (null repoPaths))
withSnapshotRepo ::
( MonadMask m,
MonadBH m
) =>
SnapshotRepoName ->
(GenericSnapshotRepo -> m a) ->
m a
withSnapshotRepo srn@(SnapshotRepoName n) f = do
repoPaths <- liftIO getRepoPaths
-- we'll use the first repo path if available, otherwise system temp
-- dir. Note that this will fail on ES > 1.6, so be sure you use
-- @when' canSnapshot@.
case repoPaths of
(firstRepoPath : _) -> withTempDirectory firstRepoPath (T.unpack n) $ \dir -> bracket (alloc dir) free f
[] -> withSystemTempDirectory (T.unpack n) $ \dir -> bracket (alloc dir) free f
where
alloc dir = do
liftIO (setFileMode dir mode)
let repo = FsSnapshotRepo srn "bloodhound-tests-backups" True Nothing Nothing Nothing
resp <- performBHRequest $ updateSnapshotRepo defaultSnapshotRepoUpdateSettings repo
liftIO $ resp `shouldBe` Acknowledged True
return (toGSnapshotRepo repo)
mode = ownerModes `unionFileModes` groupModes `unionFileModes` otherModes
free GenericSnapshotRepo {..} = do
resp <- performBHRequest $ deleteSnapshotRepo gSnapshotRepoName
liftIO $ resp `shouldBe` Acknowledged True
withSnapshot ::
( MonadMask m,
MonadBH m
) =>
SnapshotRepoName ->
SnapshotName ->
m a ->
m a
withSnapshot srn sn = bracket_ alloc free
where
alloc = do
resp <- performBHRequest $ createSnapshot srn sn createSettings
liftIO $
case resp of
-- snapWaitForCompletion=True, so the server returns a full
-- snapshot object, not the {"acknowledged": true} envelope.
CreateSnapshotCompleted (SnapshotResponse info)
| snapInfoState info == SnapshotSuccess -> pure ()
_ ->
expectationFailure $
"expected CreateSnapshotCompleted with a successful snapshot, got: "
<> show resp
-- We'll make this synchronous for testing purposes
createSettings =
defaultSnapshotCreateSettings
{ snapWaitForCompletion = True,
snapIndices = Just (IndexList (testIndex :| []))
-- We don't actually need to back up any data
}
free =
performBHRequest $ deleteSnapshot srn sn