Stream.hs

{- | A phantom-typed handle to a single event stream.

'Stream' wraps a 'StreamName' but carries a phantom type parameter @a@
identifying /which/ aggregate or event stream the name belongs to. This
lets the rest of the framework demand, say, a @Stream Order@ rather than a
bare 'StreamName', so a name for one aggregate cannot be passed where
another is expected. The wrapper is otherwise transparent — use 'stream'
to construct one and 'streamName' to recover the underlying name.
-}
module Keiro.Stream (
    Stream (..),
    stream,
    streamName,
    mapStreamName,

    -- * Safe, category-based construction
    StreamCategory,
    categoryText,
    CategoryError (..),
    category,
    categoryUnsafe,
    categoryName,
    StreamIdSegment (..),
    entityStream,
    entityStreamId,
)
where

import Data.Char qualified as Char
import Data.Text qualified as Text
import GHC.Stack (HasCallStack)
import Keiro.Prelude
import Kiroku.Store.Types (CategoryName (..), StreamName (..))
import Kiroku.Store.Types qualified as Store

-- | A 'StreamName' tagged with the phantom type @a@ of the stream it names.
newtype Stream a = Stream
    { name :: StreamName
    }
    deriving stock (Generic, Eq, Ord, Show)

-- | Build a 'Stream' handle from a raw stream-name 'Text'.
stream :: Text -> Stream a
stream name = Stream{name = StreamName name}

-- | Recover the underlying 'StreamName' from a 'Stream' handle.
streamName :: Stream a -> StreamName
streamName value = value ^. #name

{- | Transform the underlying 'StreamName' while preserving the phantom
type. Handy for namespacing or prefixing a stream name without losing the
compile-time tag.
-}
mapStreamName :: (StreamName -> StreamName) -> Stream a -> Stream a
mapStreamName f value = value & #name %~ f

{- | A validated stream /category/: the prefix that precedes the first @-@ in
every stream name belonging to this family. Kiroku defines a stream's category
as the substring before its first @-@ (see 'Kiroku.Store.Types.categoryName'),
so a category must itself contain no @-@. Carries the same phantom type @a@ as
the 'Stream' handles it produces. Write a compound category in camelCase (e.g.
@"hospitalSurge"@ for a saga over hospital surges); @:@ is reserved for the
workflow stream family (@wf:\<name\>@).

Named 'StreamCategory' (not @Category@) to avoid clashing with the
'Kiroku.Store.Subscription.Types.Category' subscription-target constructor,
which consumer code commonly imports alongside this module.
-}
newtype StreamCategory a = StreamCategory {categoryTextOf :: Text}
    deriving stock (Generic, Eq, Ord, Show)

-- | Why a 'Text' is not a valid 'StreamCategory'.
data CategoryError
    = -- | the empty string
      CategoryEmpty
    | -- | contains the reserved @-@ category/id boundary
      CategoryContainsSeparator !Text
    | -- | equals a store-reserved name (@$all@)
      CategoryReserved !Text
    | -- | contains whitespace or a control character
      CategoryContainsIllegalChar !Char !Text
    deriving stock (Eq, Show, Generic)

{- | Validate a 'Text' as a 'Category'. Rejects the empty string, any text
containing @-@ (Kiroku's category/id boundary, which would make 'categoryName'
ambiguous), whitespace/control characters, and the reserved name @$all@.
-}
category :: Text -> Either CategoryError (StreamCategory a)
category t
    | Text.null t = Left CategoryEmpty
    | t == "$all" = Left (CategoryReserved t)
    | Text.isInfixOf "-" t = Left (CategoryContainsSeparator t)
    | Just illegal <- Text.find (\c -> Char.isSpace c || Char.isControl c) t =
        Left (CategoryContainsIllegalChar illegal t)
    | otherwise = Right (StreamCategory t)

-- | Recover the validated category text.
categoryText :: StreamCategory a -> Text
categoryText (StreamCategory t) = t

{- | Partial constructor for static, known-good category literals at definition
sites. Calls 'error' on an invalid category; never pass user input. Intended for
top-level @fooCategory = categoryUnsafe "foo"@.
-}
categoryUnsafe :: (HasCallStack) => Text -> StreamCategory a
categoryUnsafe t =
    case category t of
        Right value -> value
        Left err -> error ("Keiro.Stream.categoryUnsafe: invalid category " <> show t <> ": " <> show err)

{- | The 'CategoryName' for category-scoped reads
('Kiroku.Store.Read.readCategory') and category subscription targets. For any
@cat@ and id segment, @categoryName cat@ equals
@Kiroku.Store.Types.categoryName (streamName (entityStream cat id))@ — the
category rule is single-sourced in kiroku.
-}
categoryName :: StreamCategory a -> CategoryName
categoryName (StreamCategory t) = CategoryName t

{- | Render a value as the /id segment/ of a stream name (the part after the
first @-@). The id may itself contain @-@ without corrupting the leading
category, but must be non-blank to keep the stream name distinct from a bare
category read.
-}
class StreamIdSegment i where
    renderIdSegment :: i -> Text

instance StreamIdSegment Text where
    renderIdSegment = id

instance StreamIdSegment String where
    renderIdSegment = Text.pack

{- | Build the per-entity 'Stream' handle for an aggregate instance, rendering
@\<category\>-\<id\>@. The phantom type is carried from the 'StreamCategory', so
the result is correctly tagged. The actual name mechanics are delegated to
kiroku's 'Store.streamNameInCategory', keeping the category rule single-sourced
in the store.
-}
entityStream :: (HasCallStack) => StreamCategory a -> Text -> Stream a
entityStream (StreamCategory c) idSeg =
    if Text.null (Text.strip idSeg)
        then error ("Keiro.Stream.entityStream: blank id segment for category " <> show c)
        else Stream{name = Store.streamNameInCategory (CategoryName c) idSeg}

{- | 'entityStream' for a typed id with a 'StreamIdSegment' instance. Domain id
types typically add @instance StreamIdSegment FooId where renderIdSegment =
Text.pack . show@.
-}
entityStreamId :: (HasCallStack, StreamIdSegment i) => StreamCategory a -> i -> Stream a
entityStreamId c = entityStream c . renderIdSegment