VisibleGlobalHeadPosition.hs

{-# LANGUAGE TypeApplications #-}

module Test.VisibleGlobalHeadPosition (spec) where

import Control.Lens ((&), (.~), (^.))
import Data.Aeson qualified as Aeson
import Data.Generics.Labels ()
import Data.IORef (modifyIORef', newIORef, readIORef)
import Effectful (runEff)
import Effectful.Error.Static (runErrorNoCallStack)
import Kiroku.Store
import Test.Helpers (makeEvent, withTestStore, withTestStoreSettings)
import Test.Hspec

spec :: Spec
spec = describe "visible global head position" $ do
    it "returns zero for an empty migrated store through both public runners" $
        withTestStore $ \store -> do
            runStoreIO store visibleGlobalHeadPosition
                `shouldReturn` Right (GlobalPosition 0)

            resourceResult <-
                runEff
                    . runErrorNoCallStack @StoreError
                    . runKirokuStoreWith store
                    . runStoreResource
                    $ visibleGlobalHeadPosition
            resourceResult `shouldBe` Right (GlobalPosition 0)

    it "returns the greatest appended position" $
        withTestStore $ \store -> do
            appendEvents store (StreamName "visible-head-populated") 3
            runStoreIO store visibleGlobalHeadPosition
                `shouldReturn` Right (GlobalPosition 3)

    it "falls back across hard-deleted tails while the append frontier stays monotonic" $
        withTestStore $ \store -> do
            let first = StreamName "visible-head-first"
                middle = StreamName "visible-head-middle"
                lastStream = StreamName "visible-head-last"
            appendEvents store first 1
            appendEvents store middle 1
            appendEvents store lastStream 1

            Right (Just _) <- runStoreIO store $ hardDeleteStream middle
            assertHeadAndFrontier store 3 3

            Right (Just _) <- runStoreIO store $ hardDeleteStream lastStream
            assertHeadAndFrontier store 1 3

            Right (Just _) <- runStoreIO store $ hardDeleteStream first
            assertHeadAndFrontier store 0 3

    it "keeps logically truncated and soft-deleted events visible in $all" $
        withTestStore $ \store -> do
            let name = StreamName "visible-head-logical-lifecycle"
            appendEvents store name 3

            Right (Just _) <-
                runStoreIO store $
                    setStreamTruncateBefore name (StreamVersion 3)
            runStoreIO store visibleGlobalHeadPosition
                `shouldReturn` Right (GlobalPosition 3)

            Right (Just _) <- runStoreIO store $ softDeleteStream name
            runStoreIO store visibleGlobalHeadPosition
                `shouldReturn` Right (GlobalPosition 3)

    it "does not invoke the event decode hook" $ do
        decodeCalls <- newIORef (0 :: Int)
        let failingHook event = do
                modifyIORef' decodeCalls (+ 1)
                ioError (userError ("unexpected decode of " <> show (event ^. #eventId)))
            tweak settings =
                settings
                    & #storeSettings
                        .~ defaultStoreSettings{decodeHook = Just failingHook}
        withTestStoreSettings tweak $ \store -> do
            appendEvents store (StreamName "visible-head-no-decode") 1

            runStoreIO store visibleGlobalHeadPosition
                `shouldReturn` Right (GlobalPosition 1)
            readIORef decodeCalls `shouldReturn` 0

appendEvents :: KirokuStore -> StreamName -> Int -> IO ()
appendEvents store name count = do
    let events =
            [ makeEvent "VisibleHeadEvent" (Aeson.object [("ordinal", Aeson.Number (fromIntegral ordinal))])
            | ordinal <- [1 .. count]
            ]
    result <- runStoreIO store $ appendToStream name NoStream events
    case result of
        Left err -> expectationFailure ("append failed: " <> show err)
        Right _ -> pure ()

assertHeadAndFrontier :: KirokuStore -> Integer -> Integer -> IO ()
assertHeadAndFrontier store expectedHead expectedFrontier = do
    runStoreIO store visibleGlobalHeadPosition
        `shouldReturn` Right (GlobalPosition (fromIntegral expectedHead))
    result <- runStoreIO store subscriptionCheckpointInventory
    case result of
        Left err -> expectationFailure ("inventory read failed: " <> show err)
        Right inventory ->
            inventory ^. #storePosition
                `shouldBe` GlobalPosition (fromIntegral expectedFrontier)