bloodhound-1.0.0.0: tests/Test/SLMSpec.hs
{-# LANGUAGE OverloadedStrings #-}
module Test.SLMSpec (spec) where
import Data.Aeson
import Data.ByteString.Lazy.Char8 qualified as LBS
import Database.Bloodhound.Common.Requests qualified as Common
import TestsUtils.Import
import Prelude
samplePutBodyBytes :: LBS.ByteString
samplePutBodyBytes =
"{\
\ \"schedule\": \"0 30 1 * * ?\",\
\ \"name\": \"<nightly-snapshots-{now/d}>\",\
\ \"repository\": \"my-repo\",\
\ \"config\": {\
\ \"ignore_unavailable\": false,\
\ \"include_global_state\": false,\
\ \"indices\": [\"data-*\", \"important\"],\
\ \"partial\": false\
\ },\
\ \"retention\": {\
\ \"expire_after\": \"30d\",\
\ \"min_count\": 5,\
\ \"max_count\": 50\
\ }\
\}"
-- | Minimal @GET /_slm/policy@ response: outer object keyed by policy id,
-- each value carrying the @version@ / @modified_date@ / @policy@ fields.
sampleListResponseBytes :: LBS.ByteString
sampleListResponseBytes =
"{\
\ \"nightly-snapshots\": {\
\ \"version\": 7,\
\ \"modified_date\": 1716940800000,\
\ \"modified_date_string\": \"Wed May 28 20:00:00 UTC 2024\",\
\ \"policy\": {\
\ \"schedule\": \"0 30 1 * * ?\",\
\ \"name\": \"<nightly-snapshots-{now/d}>\",\
\ \"repository\": \"my-repo\",\
\ \"retention\": {\"expire_after\": \"30d\", \"min_count\": 5, \"max_count\": 50}\
\ }\
\ }\
\}"
-- | Same policy but with @modified_date@ as an ISO-8601 string (ES 7.17+
-- shape — drops the @*_string@ sibling).
sampleListResponseDateStringBytes :: LBS.ByteString
sampleListResponseDateStringBytes =
"{\
\ \"nightly-snapshots\": {\
\ \"version\": 12,\
\ \"modified_date\": \"2024-05-29T13:37:00.000Z\",\
\ \"policy\": {\
\ \"schedule\": \"0 30 1 * * ?\",\
\ \"name\": \"<nightly-snapshots-{now/d}>\",\
\ \"repository\": \"my-repo\"\
\ }\
\ }\
\}"
spec :: Spec
spec = describe "Snapshot Lifecycle Management (SLM) API" $ do
describe "SLMPolicyId JSON" $ do
it "round-trips as a bare JSON string" $ do
let Just decoded = decode "\"my-policy\"" :: Maybe SLMPolicyId
unSLMPolicyId decoded `shouldBe` "my-policy"
encode (SLMPolicyId "my-policy") `shouldBe` "\"my-policy\""
it "rejects a non-string value" $ do
let decoded = decode "42" :: Maybe SLMPolicyId
decoded `shouldBe` Nothing
describe "SLMPolicy JSON (PUT body)" $ do
it "encodes the carried Value verbatim (no 'policy' wrapping)" $ do
let body = object ["schedule" .= String "0 0 1 * * ?"]
encoded = encode (SLMPolicy body)
encoded `shouldBe` "{\"schedule\":\"0 0 1 * * ?\"}"
it "decodes an object body verbatim" $ do
let Just decoded = decode samplePutBodyBytes :: Maybe SLMPolicy
Just expected = decode samplePutBodyBytes :: Maybe Value
unSLMPolicy decoded `shouldBe` expected
it "round-trips through ToJSON/FromJSON" $ do
let Just decoded = decode samplePutBodyBytes :: Maybe SLMPolicy
(decode . encode) decoded `shouldBe` Just decoded
it "rejects a non-object body (array)" $ do
let decoded = decode "[1,2,3]" :: Maybe SLMPolicy
decoded `shouldBe` Nothing
it "rejects a non-object body (bare number)" $ do
let decoded = decode "5" :: Maybe SLMPolicy
decoded `shouldBe` Nothing
it "rejects invalid JSON" $ do
let decoded = decode "{ this is not json" :: Maybe SLMPolicy
decoded `shouldBe` Nothing
describe "SLMPolicyInfo JSON" $ do
it "round-trips via the SLMPolicies wrapper (id preserved from key)" $ do
let Just decoded = decode sampleListResponseBytes :: Maybe SLMPolicies
infos = unSLMPolicies decoded
length infos `shouldBe` 1
let info = head infos
slmPolicyInfoId info `shouldBe` SLMPolicyId "nightly-snapshots"
slmPolicyInfoVersion info `shouldBe` Just 7
slmPolicyInfoModifiedDate info `shouldBe` Just 1716940800000
slmPolicyInfoModifiedDateString info `shouldBe` Just "Wed May 28 20:00:00 UTC 2024"
it "parses the modified_date-as-ISO-8601-string shape (ES 7.17+)" $ do
let Just decoded = decode sampleListResponseDateStringBytes :: Maybe SLMPolicies
info = head (unSLMPolicies decoded)
slmPolicyInfoModifiedDate info `shouldBe` Nothing
slmPolicyInfoModifiedDateString info `shouldBe` Just "2024-05-29T13:37:00.000Z"
it "stamps a placeholder id when decoded standalone (overridden by SLMPolicies)" $ do
let body =
object
[ "version" .= (7 :: Int),
"policy" .= object ["schedule" .= String "0 30 1 * * ?"]
]
Just decoded = decode (encode body) :: Maybe SLMPolicyInfo
slmPolicyInfoId decoded `shouldBe` SLMPolicyId ""
it "standalone round-trip is stable (ToJSON does not emit the id)" $ do
let body =
object
[ "version" .= (3 :: Int),
"policy" .= object ["schedule" .= String "x"]
]
Just decoded = decode (encode body) :: Maybe SLMPolicyInfo
reencoded = encode decoded
Just decodedAgain = decode reencoded :: Maybe SLMPolicyInfo
decodedAgain `shouldBe` decoded
-- The placeholder id survives the cycle; the body has no "id" key
-- because 'ToJSON' deliberately does not emit 'slmPolicyInfoId'.
slmPolicyInfoId decodedAgain `shouldBe` SLMPolicyId ""
it "tolerates unknown sibling fields (forward-compatible)" $ do
let bytes =
encode
( object
[ "version" .= (1 :: Int),
"policy" .= object ["schedule" .= String "x"],
"stats" .= object ["runs" .= (3 :: Int)]
]
)
Just decoded = decode bytes :: Maybe SLMPolicyInfo
slmPolicyInfoVersion decoded `shouldBe` Just 1
it "rejects an object missing the 'policy' field" $ do
let bytes = encode (object ["version" .= (1 :: Int)])
decoded = decode bytes :: Maybe SLMPolicyInfo
decoded `shouldBe` Nothing
it "tolerates missing optional fields" $ do
let body = object ["policy" .= object []]
Just decoded = decode (encode body) :: Maybe SLMPolicyInfo
slmPolicyInfoVersion decoded `shouldBe` Nothing
slmPolicyInfoModifiedDate decoded `shouldBe` Nothing
slmPolicyInfoModifiedDateString decoded `shouldBe` Nothing
describe "SLMPolicies JSON" $ do
it "round-trips a multi-policy response preserving ids" $ do
let multi =
object
[ "policy-a"
.= object
[ "version" .= (1 :: Int),
"policy" .= object ["schedule" .= String "a"]
],
"policy-b"
.= object
[ "version" .= (2 :: Int),
"policy" .= object ["schedule" .= String "b"]
]
]
Just decoded = decode (encode multi) :: Maybe SLMPolicies
length (unSLMPolicies decoded) `shouldBe` 2
map (unSLMPolicyId . slmPolicyInfoId) (unSLMPolicies decoded)
`shouldMatchList` ["policy-a", "policy-b"]
(decode . encode) decoded `shouldBe` Just decoded
it "decodes an empty policy object as an empty list" $ do
let Just decoded = decode "{}" :: Maybe SLMPolicies
unSLMPolicies decoded `shouldBe` []
it "rejects a non-object response (array)" $ do
let decoded = decode "[]" :: Maybe SLMPolicies
decoded `shouldBe` Nothing
describe "SLMExecutionResult JSON" $ do
it "decodes {\"snapshot_name\": \"...\"} into a SnapshotName" $ do
let Just decoded = decode "{\"snapshot_name\":\"<nightly-2026-06-21.000001>\"}" :: Maybe SLMExecutionResult
slmExecutionSnapshot decoded `shouldBe` SnapshotName "<nightly-2026-06-21.000001>"
it "round-trips through ToJSON/FromJSON" $ do
let result = SLMExecutionResult (SnapshotName "snap-1")
(decode . encode) result `shouldBe` Just result
it "rejects an object missing 'snapshot_name'" $ do
let decoded = decode "{\"acknowledged\":true}" :: Maybe SLMExecutionResult
decoded `shouldBe` Nothing
it "rejects a non-object body" $ do
let decoded = decode "\"just-a-string\"" :: Maybe SLMExecutionResult
decoded `shouldBe` Nothing
describe "SLMOperationMode JSON" $ do
it "round-trips all three documented modes" $ do
encode SLMOperationModeRunning `shouldBe` "\"RUNNING\""
encode SLMOperationModeStopping `shouldBe` "\"STOPPING\""
encode SLMOperationModeStopped `shouldBe` "\"STOPPED\""
decode "\"RUNNING\"" `shouldBe` Just SLMOperationModeRunning
decode "\"STOPPING\"" `shouldBe` Just SLMOperationModeStopping
decode "\"STOPPED\"" `shouldBe` Just SLMOperationModeStopped
it "rejects an unknown mode" $ do
let decoded = decode "\"PAUSED\"" :: Maybe SLMOperationMode
decoded `shouldBe` Nothing
it "rejects a non-string value" $ do
let decoded = decode "42" :: Maybe SLMOperationMode
decoded `shouldBe` Nothing
describe "SLMStatus JSON" $ do
it "decodes a full status response with all fields" $ do
let bytes =
"{\
\ \"operation_mode\": \"RUNNING\",\
\ \"snapshot_deletion_count\": 3,\
\ \"snapshot_creation_count\": 42\
\}"
Just decoded = decode bytes :: Maybe SLMStatus
slmStatusOperationMode decoded `shouldBe` SLMOperationModeRunning
slmStatusSnapshotCreationCount decoded `shouldBe` Just 42
slmStatusSnapshotDeletionCount decoded `shouldBe` Just 3
it "decodes a status response with only operation_mode (older ES)" $ do
let Just decoded = decode "{\"operation_mode\":\"STOPPED\"}" :: Maybe SLMStatus
slmStatusOperationMode decoded `shouldBe` SLMOperationModeStopped
slmStatusSnapshotCreationCount decoded `shouldBe` Nothing
slmStatusSnapshotDeletionCount decoded `shouldBe` Nothing
it "tolerates unknown forward-compatible fields" $ do
let bytes =
"{\
\ \"operation_mode\": \"STOPPING\",\
\ \"retention_runs\": 7,\
\ \"policy_protection_indicator\": {\"enabled\": true}\
\}"
Just decoded = decode bytes :: Maybe SLMStatus
slmStatusOperationMode decoded `shouldBe` SLMOperationModeStopping
it "rejects a status response missing operation_mode" $ do
let decoded = decode "{\"snapshot_creation_count\":1}" :: Maybe SLMStatus
decoded `shouldBe` Nothing
it "round-trips through ToJSON/FromJSON" $ do
let status = SLMStatus {slmStatusOperationMode = SLMOperationModeRunning, slmStatusSnapshotCreationCount = Just 5, slmStatusSnapshotDeletionCount = Nothing}
(decode . encode) status `shouldBe` Just status
describe "putSLMPolicy endpoint shape" $ do
let body = SLMPolicy (object ["schedule" .= String "0 0 1 * * ?"])
req = Common.putSLMPolicy (SLMPolicyId "my-policy") body
it "PUTs /_slm/policy/{id}" $ do
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "policy", "my-policy"]
it "uses the PUT method" $ do
bhRequestMethod req `shouldBe` "PUT"
it "attaches the encoded policy as the request body" $ do
bhRequestBody req `shouldBe` Just (encode body)
it "carries no query string" $ do
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []
it "uses a distinct id in the path when given a different SLMPolicyId" $ do
let req' = Common.putSLMPolicy (SLMPolicyId "other") body
getRawEndpoint (bhRequestEndpoint req') `shouldBe` ["_slm", "policy", "other"]
describe "getSLMPolicy endpoint shape" $ do
it "GETs /_slm/policy when given Nothing" $ do
let req = Common.getSLMPolicy Nothing
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "policy"]
it "GETs /_slm/policy/{id} when given a Just id" $ do
let req = Common.getSLMPolicy (Just (SLMPolicyId "nightly"))
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "policy", "nightly"]
it "uses the GET method" $ do
let req = Common.getSLMPolicy Nothing
bhRequestMethod req `shouldBe` "GET"
it "carries no request body" $ do
let req = Common.getSLMPolicy Nothing
bhRequestBody req `shouldBe` Nothing
it "carries no query string for either variant" $ do
let reqAll = Common.getSLMPolicy Nothing
reqOne = Common.getSLMPolicy (Just (SLMPolicyId "x"))
getRawEndpointQueries (bhRequestEndpoint reqAll) `shouldBe` []
getRawEndpointQueries (bhRequestEndpoint reqOne) `shouldBe` []
describe "deleteSLMPolicy endpoint shape" $ do
let req = Common.deleteSLMPolicy (SLMPolicyId "stale")
it "DELETEs /_slm/policy/{id}" $ do
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "policy", "stale"]
it "uses the DELETE method" $ do
bhRequestMethod req `shouldBe` "DELETE"
it "carries no request body" $ do
bhRequestBody req `shouldBe` Nothing
it "carries no query string" $ do
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []
it "substitutes the id into the path" $ do
let req' = Common.deleteSLMPolicy (SLMPolicyId "other")
getRawEndpoint (bhRequestEndpoint req') `shouldBe` ["_slm", "policy", "other"]
describe "executeSLMPolicy endpoint shape" $ do
let req = Common.executeSLMPolicy (SLMPolicyId "nightly")
it "POSTs /_slm/execute/{id}" $ do
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "execute", "nightly"]
it "uses the POST method" $ do
bhRequestMethod req `shouldBe` "POST"
it "sends an empty body" $ do
bhRequestBody req `shouldBe` Just ""
it "carries no query string" $ do
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []
it "substitutes the id into the path" $ do
let req' = Common.executeSLMPolicy (SLMPolicyId "hourly")
getRawEndpoint (bhRequestEndpoint req') `shouldBe` ["_slm", "execute", "hourly"]
describe "getSLMStatus endpoint shape" $ do
let req = Common.getSLMStatus
it "GETs /_slm/status" $ do
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "status"]
it "uses the GET method" $ do
bhRequestMethod req `shouldBe` "GET"
it "carries no request body" $ do
bhRequestBody req `shouldBe` Nothing
it "carries no query string" $ do
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []
describe "stopSLM endpoint shape" $ do
let req = Common.stopSLM
it "POSTs /_slm/stop" $ do
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "stop"]
it "uses the POST method" $ do
bhRequestMethod req `shouldBe` "POST"
it "sends an empty body" $ do
bhRequestBody req `shouldBe` Just ""
it "carries no query string" $ do
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []
describe "startSLM endpoint shape" $ do
let req = Common.startSLM
it "POSTs /_slm/start" $ do
getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "start"]
it "uses the POST method" $ do
bhRequestMethod req `shouldBe` "POST"
it "sends an empty body" $ do
bhRequestBody req `shouldBe` Just ""
it "carries no query string" $ do
getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` []