BrowseReads.hs

module Test.BrowseReads (spec) where

import Control.Lens ((&), (.~), (^.))
import Control.Monad (forM_, void)
import Data.Aeson qualified as Aeson
import Data.Char (chr)
import Data.Generics.Labels ()
import Data.List (sort)
import Data.Text (Text)
import Data.Text qualified as T
import Data.UUID qualified as UUID
import Data.Vector qualified as V
import Kiroku.Store
import Test.Helpers (makeEvent, withTestStore, withTestStoreSettings)
import Test.Hspec

page :: Int -> BrowsePageSize
page n = either (error . show) (\p -> p) (mkBrowsePageSize n)

names :: V.Vector StreamInfo -> [Text]
names = map (\s -> let StreamName n = s ^. #name in n) . V.toList

seed :: KirokuStore -> [Text] -> IO ()
seed store = mapM_ $ \name -> do
  result <- runStoreIO store $ appendToStream (StreamName name) NoStream [makeEvent "Created" (Aeson.object [])]
  result `shouldSatisfy` either (const False) (const True)

spec :: Spec
spec = describe "browse reads" $ do
  it "validates bounded page sizes" $ do
    forM_ [minBound, -1, 0, 1002, maxBound] $ \n -> mkBrowsePageSize n `shouldBe` Left (InvalidBrowsePageSize n)
    forM_ [1, 1000, 1001] $ \n -> fmap browsePageSizeValue (mkBrowsePageSize n) `shouldBe` Right (fromIntegral n)
  around withTestStore $ do
    it "excludes only the reserved all row and pages in UTF-8 byte order" $ \store -> do
      runStoreIO store (listStreams Nothing Nothing Nothing (page 10)) `shouldReturn` Right V.empty
      let values = ["orders-2", "orders", "orders-1", "$all-x", "singleton", "é-1", "Z-1", "-empty-category"]
      seed store values
      Right first <- runStoreIO store $ listStreams Nothing Nothing Nothing (page 3)
      names first `shouldBe` take 3 (sort values)
      Right rest <- runStoreIO store $ listStreams Nothing Nothing (Just (StreamName (last (names first)))) (page 100)
      names first <> names rest `shouldBe` sort values
      runStoreIO store (listStreams Nothing Nothing (Just (StreamName (last (sort values)))) (page 10)) `shouldReturn` Right V.empty
    it "intersects exact categories, literal prefixes and exclusive cursors" $ \store -> do
      let maxScalar = T.singleton (chr 0x10ffff)
          values = ["orders", "orders-1", "orders-2", "orders:other-1", "orders_-1", "orders%-1", "$all-x", "-a", "é-a", "é-a", maxScalar, maxScalar <> "-a", "\xD7FF-a", "\xE000-a"]
      seed store values
      forM_ [Nothing, Just (CategoryName "orders"), Just (CategoryName ""), Just (CategoryName "$all"), Just (CategoryName "not-a-category"), Just (CategoryName maxScalar)] $ \category ->
        forM_ [Nothing, Just "", Just "orders", Just "orders-", Just "orders%", Just "orders_", Just "absent", Just "é", Just maxScalar, Just "\xD7FF"] $ \prefix ->
          forM_ [Nothing, Just (StreamName "orders"), Just (StreamName "orders-1"), Just (StreamName "zzz")] $ \cursor -> do
            let expected = sort [v | v <- values, maybe True (== categoryName (StreamName v)) category, maybe True (`T.isPrefixOf` v) prefix, maybe True (\(StreamName c) -> v > c) cursor]
            Right actual <- runStoreIO store $ listStreams category prefix cursor (page 100)
            names actual `shouldBe` expected
    it "enumerates distinct categories including bare and empty categories" $ \store -> do
      seed store ["orders", "orders-1", "orders-2", "$all-x", "-a", "singleton"]
      Right first <- runStoreIO store $ listCategories Nothing (page 2)
      V.toList first `shouldBe` [CategoryName "", CategoryName "$all"]
      Right rest <- runStoreIO store $ listCategories (Just (V.last first)) (page 10)
      V.toList rest `shouldBe` [CategoryName "orders", CategoryName "singleton"]
    it "keeps soft-deleted summaries and removes hard-deleted summaries" $ \store -> do
      seed store ["orders-soft", "orders-hard"]
      void $ runStoreIO store $ softDeleteStream (StreamName "orders-soft")
      void $ runStoreIO store $ setStreamTruncateBefore (StreamName "orders-soft") (StreamVersion 1)
      void $ runStoreIO store $ hardDeleteStream (StreamName "orders-hard")
      Right rows <- runStoreIO store $ listStreams Nothing Nothing Nothing (page 10)
      names rows `shouldBe` ["orders-soft"]
      (V.head rows ^. #deletedAt) `shouldSatisfy` maybe False (const True)
    it "returns the canonical global row once even when linked, then nothing after hard deletion" $ \store -> do
      seed store ["orders-1"]
      Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) 10
      let event = V.head events
      Right _ <- runStoreIO store $ linkToStream (StreamName "links-1") [event ^. #eventId]
      runStoreIO store (getEvent (event ^. #eventId)) `shouldReturn` Right (Just event)
      runStoreIO store (getEvent (EventId UUID.nil)) `shouldReturn` Right Nothing
      Right _ <- runStoreIO store $ hardDeleteStream (StreamName "orders-1")
      runStoreIO store (getEvent (event ^. #eventId)) `shouldReturn` Right Nothing
  it "applies the configured decode hook to event lookup" $ do
    let marker = Aeson.object ["decoded" Aeson..= True]
        hook event = pure (Right (event & #metadata .~ Just marker))
    withTestStoreSettings (\settings -> settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook}) $ \store -> do
      seed store ["orders-1"]
      Right events <- runStoreIO store $ readAllForward (GlobalPosition 0) 10
      Right (Just event) <- runStoreIO store $ getEvent (V.head events ^. #eventId)
      (event ^. #metadata) `shouldBe` Just marker

  it "propagates typed decode failure from event lookup" $ do
    let hook event = pure (Left (DecodeFailure (event ^. #eventId) "failure"))
    withTestStoreSettings (\settings -> settings & #storeSettings .~ defaultStoreSettings {decodeHook = Just hook}) $ \store -> do
      seed store ["orders-1"]
      Right rows <- runStoreIO store $ readStreamForward (StreamName "missing") (StreamVersion 0) 1
      rows `shouldBe` V.empty
      -- Use the append-provided id to avoid decoding a fixture through the failing hook.
      let event = makeEvent "Created" (Aeson.object []) & #eventId .~ Just (EventId UUID.nil)
      Right _ <- runStoreIO store $ appendToStream (StreamName "orders-2") NoStream [event]
      runStoreIO store (getEvent (EventId UUID.nil)) `shouldReturn` Left (EventDecodeFailed (DecodeFailure (EventId UUID.nil) "failure"))