diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,35 @@ # Changelog +## 0.4.0.0 — 2026-08-17 + +### Added + +- `Kioku.Api.Recall`: `RecallTarget`, which says whether a recall call searches one exact scope + (`ExactScope`) or every scope in one namespace (`NamespaceWide`). `ExactScope (ScopeGlobal ns)` + is the exact global bucket, a request that had no representation before. The wire format carries + a required discriminator with one tag per meaning — `exact_global`, `exact_entity`, + `namespace_wide` — and decoding refuses an unknown tag or a variant carrying a field it has no + meaning for. +- `RecallQuery`, the request a caller composes: a target, query text, a strategy, and a + `RecallLimit` validated to 1–100. It deliberately carries no memory space; that comes from the + `MemoryAccessContext` at execution. +- `legacyRecallTarget`, the migration helper: it maps a pre-target `MemoryScope` to the target + that returns the same rows (`ScopeGlobal ns` to `NamespaceWide ns`). It is not deprecated, + because it is what a migrating caller must call. +- `RecallStrategy` moved here from `kioku-core`'s `Kioku.Recall`, which re-exports it, so an + existing `import Kioku.Recall (RecallStrategy (..))` keeps working. It gained + `recallStrategyText`, `parseRecallStrategy`, `allRecallStrategies`, and a bare-string JSON + encoding. + +- `RecordedPrincipal` and `LegacyPrincipalRef` in `Kioku.Api.Access`: who a stored fact says + acted. Three cases — a principal a directory issued, a pre-memory-space free-text agent label + kept verbatim and marked, and an event that recorded no actor at all. The wire markers + `kioku:legacy:` and `kioku:unattributed` are unambiguous because `mkPrincipalRef` rejects `:`. +- `memoryContextRecordedActor`, the supported way to attribute a write. Attribution comes from the + context that authorized it, never from a separate caller-supplied name. +- `MemoryContextProvider` and `assumeAuthorizedContextProvider`, for background work that + discovers which memory space it belongs to only after claiming it. + ## 0.3.0.0 — 2026-08-05 ### Changed diff --git a/kioku-api.cabal b/kioku-api.cabal --- a/kioku-api.cabal +++ b/kioku-api.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: kioku-api -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Reusable agent memory wire types description: Wire contract for kioku: custom prelude, TypeID identifiers, memory @@ -27,6 +27,7 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Werror=incomplete-patterns common shared default-language: GHC2024 @@ -45,6 +46,9 @@ import: warnings, shared hs-source-dirs: src exposed-modules: + Kioku.Api.Access + Kioku.Api.Access.Internal + Kioku.Api.Recall Kioku.Api.Scope Kioku.Api.Types Kioku.Id @@ -58,3 +62,23 @@ , mmzk-typeid >=0.7 && <0.8 , text >=2.1 && <2.2 , time >=1.12 && <1.15 + +test-suite kioku-api-test + import: warnings, shared + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + Kioku.Api.AccessSpec + Kioku.Api.RecallSpec + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , aeson >=2.2 && <2.3 + , base >=4.21 && <5 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.8 + , kioku-api ^>=0.4.0.0 + , tasty >=1.5 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , text >=2.1 && <2.2 diff --git a/src/Kioku/Api/Access.hs b/src/Kioku/Api/Access.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Api/Access.hs @@ -0,0 +1,198 @@ +-- | Memory spaces, principals, and the authorization context Kioku's core requires. +-- +-- Kioku stores memory. It does not authenticate anyone, hold a roster of users or teams, or +-- decide who may read what — and it takes no dependency on anything that does. What it requires +-- is that somebody else has already decided, and says so by handing it a 'MemoryAccessContext'. +-- +-- There are exactly two ways to obtain one. +-- +-- A trusted in-process host — a CLI, a test, an application that authenticated its user long +-- before it reached the memory layer — calls 'assumeAuthorizedMemoryContext'. Nothing else is +-- required: no directory, no authorization engine, no configuration. This is the ordinary case +-- and it is why Kioku is usable standalone. +-- +-- A host serving untrusted callers uses 'authorizeMemoryAccess', which runs three gates in a +-- fixed order and refuses to skip any of them: +-- +-- 1. a coarse credential claim ('MemoryCoarseScope') proves the caller may talk to Kioku about +-- this /kind/ of action at all; +-- 2. a directory ('PrincipalDirectory') resolves the authenticated subject to a +-- 'PrincipalRef', which is what makes an unlinked credential or a paused agent fail closed; +-- 3. an authorization engine ('PermissionChecker') decides whether that principal may perform +-- this action on /this memory space/. +-- +-- Each gate answers a question the others cannot. A coarse @kioku:read@ scope says nothing about +-- which space; a resolved principal says nothing about permission; and a permission check on a +-- subject nobody vouched for is a check on a string the caller made up. +-- +-- The two seams in steps 2 and 3 are records of plain functions. Kioku names no identity +-- service, and the object type and permission names it asks about come from the host as a +-- 'MemoryAuthorizationBinding'. See @docs\/user\/integrations.md@ for a worked integration. +module Kioku.Api.Access + ( -- * The isolation boundary + MemorySpaceId, + mkMemorySpaceId, + memorySpaceIdText, + legacyMemorySpaceId, + + -- * Principals + PrincipalRef, + mkPrincipalRef, + principalRefText, + MemoryActor (..), + MemoryOwner (..), + actorPrincipal, + ownerPrincipal, + + -- * Principals as they appear on stored facts + LegacyPrincipalRef, + legacyPrincipalRef, + legacyPrincipalRefText, + RecordedPrincipal (..), + recordedPrincipalText, + parseRecordedPrincipal, + + -- * Kioku's own action vocabulary + MemoryPermission (..), + allMemoryPermissions, + memoryPermissionText, + parseMemoryPermission, + + -- * Naming the authorization object, which Kioku does not own + MemoryObjectType, + mkMemoryObjectType, + memoryObjectTypeText, + MemoryPermissionName, + mkMemoryPermissionName, + memoryPermissionNameText, + MemoryCoarseScope, + mkMemoryCoarseScope, + memoryCoarseScopeText, + MemoryObjectRef (..), + memoryObjectRefText, + MemoryPermissionBinding (..), + MemoryAuthorizationBinding, + mkMemoryAuthorizationBinding, + memoryPermissionBinding, + memorySpaceObjectRef, + + -- * Freshness + MemoryDecisionToken, + mkMemoryDecisionToken, + memoryDecisionTokenText, + MemoryFreshness (..), + atLeastAsFresh, + + -- * What an authorization seam answers + MemoryDecisionOutcome (..), + MemoryDecision (..), + + -- * Why access was refused + MemoryAccessDenial (..), + + -- * The authenticated caller + AuthenticatedSubject (..), + + -- * The seams Kioku does not implement + PrincipalDirectory (..), + PermissionChecker (..), + MemoryContextProvider (..), + assumeAuthorizedContextProvider, + + -- * The authorized decision + MemoryAccessContext, + memoryContextSpace, + memoryContextActor, + memoryContextPermissions, + memoryContextDecisionToken, + memoryContextAllows, + memoryContextFreshness, + memoryContextRecordedActor, + assumeAuthorizedMemoryContext, + authorizeMemoryAccess, + ) +where + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set qualified as Set +import Kioku.Api.Access.Internal +import Kioku.Prelude + +-- | Run the three gates for one memory space and a set of requested actions, and mint a +-- 'MemoryAccessContext' only if every one of them passes. +-- +-- The order is fixed and the failures stay distinct. A missing coarse scope, an unresolved +-- principal, a denial, and a conditional answer are four different 'MemoryAccessDenial' +-- constructors, and a caller must keep them apart all the way out: none of them may become a +-- successful recall that happens to return no rows. A caller cannot tell "you may not look here" +-- from "there is nothing here", and only one of those is worth acting on. +-- +-- All requested permissions are checked, not just the first. A context that claimed five +-- permissions on the strength of one check would be exactly the confused-deputy bug the whole +-- boundary exists to prevent. +-- +-- The @freshness@ argument is what a caller passes after writing a grant or a membership: hand +-- back the 'MemoryDecisionToken' from the write (or from a previous decision, via +-- 'memoryContextFreshness') and the check is guaranteed to observe it. Without it a replica that +-- has not caught up can deny a permission that already exists. The minted context carries the +-- token of the last check it ran, so a follow-up read can chain from it. +-- +-- A 'MemoryConditional' answer is treated as a refusal. The relationship exists but is gated on +-- context this request did not supply, and quietly promoting that to an allow is how a +-- time-limited grant becomes a permanent one. +authorizeMemoryAccess :: + (Monad m) => + MemoryAuthorizationBinding -> + PrincipalDirectory m -> + PermissionChecker m -> + MemoryFreshness -> + AuthenticatedSubject -> + MemorySpaceId -> + NonEmpty MemoryPermission -> + m (Either MemoryAccessDenial MemoryAccessContext) +authorizeMemoryAccess binding directory authorizer freshness subject spaceId requested = + case coarseGate of + Left denial -> pure (Left denial) + Right () -> do + resolved <- directory.resolvePrincipal subject.subjectId + case resolved of + Nothing -> pure (Left (MemoryPrincipalUnresolved subject.subjectId)) + Just principal -> checkAll principal Nothing permissions + where + permissions = NonEmpty.toList requested + object = memorySpaceObjectRef binding spaceId + + -- Every requested action must clear its coarse claim before the directory is consulted, so + -- an unauthorized caller cannot use Kioku as an oracle for which subjects exist. + coarseGate = + case filter scopeMissing permissions of + [] -> Right () + permission : _ -> + Left (MemoryCoarseScopeMissing (memoryPermissionBinding binding permission).coarseScope) + + scopeMissing permission = + not (Set.member (memoryPermissionBinding binding permission).coarseScope subject.grantedScopes) + + checkAll principal latestToken = \case + [] -> + pure + ( Right + MemoryAccessContext + { memorySpaceId = spaceId, + actor = MemoryActor principal, + grantedPermissions = Set.fromList permissions, + decisionToken = latestToken + } + ) + permission : rest -> do + decision <- + authorizer.checkMemoryPermission + freshness + principal + (memoryPermissionBinding binding permission).objectPermission + object + case decision.outcome of + MemoryDenied -> pure (Left (MemoryPermissionDenied spaceId permission)) + MemoryConditional obligations -> + pure (Left (MemoryDecisionConditional spaceId permission obligations)) + MemoryAllowed -> checkAll principal (Just decision.checkedAt) rest diff --git a/src/Kioku/Api/Access/Internal.hs b/src/Kioku/Api/Access/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Api/Access/Internal.hs @@ -0,0 +1,694 @@ +-- | The memory-space access vocabulary, with every constructor exposed. +-- +-- This module exists so that an adapter which has already obtained an authorization decision +-- by some other route can build a 'MemoryAccessContext' directly. Everything here is also +-- re-exported by "Kioku.Api.Access" /except/ the 'MemoryAccessContext' data constructor, which +-- is the one value in this vocabulary that asserts "a decision was made and it said yes". +-- +-- Importing this module is a deliberate act. If you find yourself reaching for it because +-- 'Kioku.Api.Access.authorizeMemoryAccess' is inconvenient, use +-- 'Kioku.Api.Access.assumeAuthorizedMemoryContext' instead: it says the same thing, in one +-- grep-able name, and a reviewer can see it. +module Kioku.Api.Access.Internal + ( -- * The isolation boundary + MemorySpaceId (..), + mkMemorySpaceId, + memorySpaceIdText, + legacyMemorySpaceId, + + -- * Principals + PrincipalRef (..), + mkPrincipalRef, + principalRefText, + MemoryActor (..), + MemoryOwner (..), + actorPrincipal, + ownerPrincipal, + + -- * Principals as they appear on stored facts + LegacyPrincipalRef (..), + legacyPrincipalRef, + legacyPrincipalRefText, + RecordedPrincipal (..), + recordedPrincipalText, + parseRecordedPrincipal, + + -- * Kioku's own action vocabulary + MemoryPermission (..), + allMemoryPermissions, + memoryPermissionText, + parseMemoryPermission, + + -- * Naming the authorization object (owned by the schema owner, not by Kioku) + MemoryObjectType (..), + mkMemoryObjectType, + memoryObjectTypeText, + MemoryPermissionName (..), + mkMemoryPermissionName, + memoryPermissionNameText, + MemoryCoarseScope (..), + mkMemoryCoarseScope, + memoryCoarseScopeText, + MemoryObjectRef (..), + memoryObjectRefText, + MemoryPermissionBinding (..), + MemoryAuthorizationBinding (..), + mkMemoryAuthorizationBinding, + memoryPermissionBinding, + memorySpaceObjectRef, + + -- * Freshness + MemoryDecisionToken (..), + mkMemoryDecisionToken, + memoryDecisionTokenText, + MemoryFreshness (..), + atLeastAsFresh, + + -- * What an authorization port answers + MemoryDecisionOutcome (..), + MemoryDecision (..), + + -- * Why access was refused + MemoryAccessDenial (..), + + -- * The authenticated caller, before any space-specific work + AuthenticatedSubject (..), + + -- * The seams Kioku does not implement + PrincipalDirectory (..), + PermissionChecker (..), + MemoryContextProvider (..), + assumeAuthorizedContextProvider, + + -- * The authorized decision + MemoryAccessContext (..), + memoryContextSpace, + memoryContextActor, + memoryContextPermissions, + memoryContextDecisionToken, + memoryContextAllows, + memoryContextFreshness, + memoryContextRecordedActor, + assumeAuthorizedMemoryContext, + ) +where + +import Data.Aeson (withText) +import Data.Char qualified as Char +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import Kioku.Prelude + +-- | The outer isolation boundary: everything Kioku stores belongs to exactly one memory space, +-- and a caller authorized for one space is never thereby authorized for another. +-- +-- This is deliberately /not/ a principal id. A person or a team can own or reach many spaces, +-- and "who may touch this space" is a relationship the authorization service answers, not a +-- property of the identifier. It is also deliberately opaque text rather than a Kioku-minted +-- TypeID: a host may create spaces in some other system entirely, and Kioku's job is to carry +-- whatever identifier that owner issues, not to mint one. +-- +-- Compare with 'Kioku.Api.Scope.Namespace', which it does not replace. A namespace organizes +-- memories inside one deployment (@rei@, @mori@, @shikigami@); a memory space isolates them. +-- Two hosts sharing a database are separated by namespace; two tenants who must never see each +-- other's data are separated by memory space. +newtype MemorySpaceId = MemorySpaceId Text + deriving stock (Eq, Ord, Show, Generic) + +-- | Validating constructor. A space id becomes an authorization object id, an indexed database +-- column, and part of a rendered object reference, so it must not contain the characters those +-- encodings give meaning to: @%@, @\/@ and @:@ (reserved by +-- 'Kioku.Api.Scope.mkNamespace' and by the scope-identity encoding) and @#@ (which separates an +-- object from a relation in a relationship tuple). Whitespace and control characters are +-- rejected too — no legitimate identifier contains them, and they corrupt logs and query plans. +mkMemorySpaceId :: Text -> Either Text MemorySpaceId +mkMemorySpaceId = fmap MemorySpaceId . validateOpaqueId "memory space id" reservedRefChars + +memorySpaceIdText :: MemorySpaceId -> Text +memorySpaceIdText (MemorySpaceId value) = value + +-- | The single explicit space that data written before memory spaces existed is backfilled into. +-- +-- The important word is /explicit/. It would be simpler to let a missing space mean "visible +-- everywhere", and that is exactly the mistake this constant exists to prevent: absence of a +-- partition must never read as unrestricted access. An upgraded single-space deployment keeps +-- its old behaviour because all of its rows land in this one space — not because unpartitioned +-- rows are special. +legacyMemorySpaceId :: MemorySpaceId +legacyMemorySpaceId = MemorySpaceId "kioku_legacy" + +-- | A principal identifier issued by whatever directory the host uses, carried verbatim. +-- +-- The wire form is exactly that directory's rendered form — @person_01h9x…@, @team_01h9x…@, +-- @agent_01h9x…@, @service_01h9x…@, @org_01h9x…@ and so on. Kioku stores it, compares it by +-- string equality, and does nothing else with it. In particular it never splits the prefix off +-- to learn the principal's kind, and it holds no profile, handle, membership, or lifecycle +-- state: a paused agent, a departed person, and a renamed team are all the directory's business, +-- and they reach Kioku as a subject that no longer resolves. +newtype PrincipalRef = PrincipalRef Text + deriving stock (Eq, Ord, Show, Generic) + +-- | Validating constructor. This is edge hygiene, not a directory parser: it rejects the empty +-- string, whitespace, control characters, and the @:@ and @#@ that a relationship tuple gives +-- meaning to. It deliberately does not check the prefix against a list of kinds — that list +-- belongs to the directory, and duplicating it here would fork it on the day it grows. +mkPrincipalRef :: Text -> Either Text PrincipalRef +mkPrincipalRef = fmap PrincipalRef . validateOpaqueId "principal reference" tupleRefChars + +principalRefText :: PrincipalRef -> Text +principalRefText (PrincipalRef value) = value + +-- | The principal responsible for an action: whoever the request was authorized as. +newtype MemoryActor = MemoryActor PrincipalRef + deriving stock (Eq, Ord, Show, Generic) + +-- | The principal a memory belongs to, where that differs from the actor. +-- +-- An agent recording on a person's behalf is the motivating case: the actor is the agent, the +-- owner is the person, and later retention or deletion questions are asked about the owner. +newtype MemoryOwner = MemoryOwner PrincipalRef + deriving stock (Eq, Ord, Show, Generic) + +actorPrincipal :: MemoryActor -> PrincipalRef +actorPrincipal (MemoryActor value) = value + +ownerPrincipal :: MemoryOwner -> PrincipalRef +ownerPrincipal (MemoryOwner value) = value + +-- | A free-text agent label from before canonical principals existed, carried verbatim. +-- +-- Kioku's events used to record an @agentId@ that was whatever string the host felt like +-- sending: @rei@, @demo-agent@, @claude@. That is not a principal — nobody issued it, nobody +-- can resolve it, and two hosts can pick the same one — so it must never be laundered into a +-- 'PrincipalRef' by pasting a kind prefix onto it. It is kept exactly as it was written and +-- marked as legacy wherever it appears. +-- +-- The constructor is deliberately total and validates nothing. This value only ever comes from +-- data that is already on disk, and a validating constructor here would mean a historical event +-- that fails to decode — which is to say, an aggregate that can no longer be rebuilt. +newtype LegacyPrincipalRef = LegacyPrincipalRef Text + deriving stock (Eq, Ord, Show, Generic) + +legacyPrincipalRef :: Text -> LegacyPrincipalRef +legacyPrincipalRef = LegacyPrincipalRef + +legacyPrincipalRefText :: LegacyPrincipalRef -> Text +legacyPrincipalRefText (LegacyPrincipalRef value) = value + +-- | Who a stored fact says acted, as far as the event stream knows. +-- +-- Three cases, and the last two exist because history is not uniform. Everything written through +-- the memory-space API names a real principal. Events written before it carry a legacy agent +-- label, or — for the many events that never recorded an agent at all, such as archiving a +-- memory or completing a session — nothing. +-- +-- 'UnattributedPrincipal' is the honest answer for that last group. The alternative is inventing +-- an actor for a fact that did not record one, which would put a fabricated identity into an +-- audit trail. +data RecordedPrincipal + = -- | a principal a directory issued and vouched for + KnownPrincipal !PrincipalRef + | -- | a pre-memory-space free-text agent label, marked as such + LegacyPrincipal !LegacyPrincipalRef + | -- | a pre-memory-space event that recorded no actor + UnattributedPrincipal + deriving stock (Eq, Ord, Show, Generic) + +-- | The canonical text rendering, which is also the wire form. +-- +-- The two non-canonical cases are spelled with a @kioku:@ prefix, and that is unambiguous rather +-- than merely unlikely: 'mkPrincipalRef' rejects @:@ outright, so no principal a directory can +-- issue is spellable as either marker. Round-tripping is exact even for a legacy label that +-- itself begins with @kioku:legacy:@, because only the first marker is stripped. +recordedPrincipalText :: RecordedPrincipal -> Text +recordedPrincipalText = \case + KnownPrincipal principal -> principalRefText principal + LegacyPrincipal legacy -> legacyPrincipalMarker <> legacyPrincipalRefText legacy + UnattributedPrincipal -> unattributedPrincipalMarker + +-- | Parse the rendering above. An unrecognized @kioku:@ form is an error rather than a legacy +-- label, so a marker added by a later version fails loudly here instead of being silently +-- demoted to free text. +parseRecordedPrincipal :: Text -> Either Text RecordedPrincipal +parseRecordedPrincipal value + | value == unattributedPrincipalMarker = Right UnattributedPrincipal + | Just legacy <- Text.stripPrefix legacyPrincipalMarker value = + Right (LegacyPrincipal (LegacyPrincipalRef legacy)) + | Just unknown <- Text.stripPrefix kiokuPrincipalMarker value = + Left ("unknown kioku principal marker: " <> unknown) + | otherwise = KnownPrincipal <$> mkPrincipalRef value + +kiokuPrincipalMarker :: Text +kiokuPrincipalMarker = "kioku:" + +legacyPrincipalMarker :: Text +legacyPrincipalMarker = kiokuPrincipalMarker <> "legacy:" + +unattributedPrincipalMarker :: Text +unattributedPrincipalMarker = kiokuPrincipalMarker <> "unattributed" + +-- | What a caller wants to do to a memory space, in Kioku's own words. +-- +-- These name Kioku's operations, not the authorization service's schema. The mapping from one +-- to the other is a 'MemoryAuthorizationBinding' the host supplies, because the names on the +-- other side belong to whoever owns that schema. +data MemoryPermission + = -- | recall, scene reads, persona reads — anything that returns stored memory + MemoryRead + | -- | record a memory, start a session, append a turn + MemoryRecord + | -- | run distillation, which reads evidence and writes derived memory + MemoryDistill + | -- | forget, retire, or otherwise remove memory + MemoryForget + | -- | administer the space itself, including sharing it with another principal + MemoryAdmin + deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) + +-- | Every permission, in declaration order. Used to prove a binding is total. +allMemoryPermissions :: [MemoryPermission] +allMemoryPermissions = [minBound .. maxBound] + +-- | The stable wire spelling. Changing one of these is a breaking change to stored events. +memoryPermissionText :: MemoryPermission -> Text +memoryPermissionText = \case + MemoryRead -> "read" + MemoryRecord -> "record" + MemoryDistill -> "distill" + MemoryForget -> "forget" + MemoryAdmin -> "admin" + +parseMemoryPermission :: Text -> Either Text MemoryPermission +parseMemoryPermission = \case + "read" -> Right MemoryRead + "record" -> Right MemoryRecord + "distill" -> Right MemoryDistill + "forget" -> Right MemoryForget + "admin" -> Right MemoryAdmin + other -> Left ("unknown memory permission: " <> other) + +-- | The object type a memory space is represented by in the authorization schema. +-- +-- Kioku does not choose this string, because Kioku does not own that schema. The host passes it +-- in through 'mkMemoryAuthorizationBinding'. +newtype MemoryObjectType = MemoryObjectType Text + deriving stock (Eq, Ord, Show, Generic) + +mkMemoryObjectType :: Text -> Either Text MemoryObjectType +mkMemoryObjectType = fmap MemoryObjectType . validateOpaqueId "object type" tupleRefChars + +memoryObjectTypeText :: MemoryObjectType -> Text +memoryObjectTypeText (MemoryObjectType value) = value + +-- | The permission (relation) name asked of the authorization schema. Also not Kioku's to +-- choose — see 'MemoryObjectType'. +newtype MemoryPermissionName = MemoryPermissionName Text + deriving stock (Eq, Ord, Show, Generic) + +mkMemoryPermissionName :: Text -> Either Text MemoryPermissionName +mkMemoryPermissionName = fmap MemoryPermissionName . validateOpaqueId "permission name" tupleRefChars + +memoryPermissionNameText :: MemoryPermissionName -> Text +memoryPermissionNameText (MemoryPermissionName value) = value + +-- | A coarse claim the authentication service must have minted onto the caller's credential +-- before Kioku will do any space-specific work — an OAuth-style scope such as @kioku:read@. +-- +-- It is coarse on purpose: it says "this credential is allowed to talk to Kioku at all about +-- reads", never "…about this space". Passing this gate is necessary and nowhere near sufficient. +newtype MemoryCoarseScope = MemoryCoarseScope Text + deriving stock (Eq, Ord, Show, Generic) + +mkMemoryCoarseScope :: Text -> Either Text MemoryCoarseScope +mkMemoryCoarseScope = fmap MemoryCoarseScope . validateOpaqueId "coarse scope" "" + +memoryCoarseScopeText :: MemoryCoarseScope -> Text +memoryCoarseScopeText (MemoryCoarseScope value) = value + +-- | A concrete object in the authorization schema: a type and an id within that type. +data MemoryObjectRef = MemoryObjectRef + { objectType :: !MemoryObjectType, + objectId :: !Text + } + deriving stock (Eq, Ord, Show, Generic) + +-- | The canonical @type:id@ rendering. Both halves reject @:@ and @#@ at construction, so this +-- rendering is injective: two different object references can never produce the same text. +memoryObjectRefText :: MemoryObjectRef -> Text +memoryObjectRefText ref = memoryObjectTypeText ref.objectType <> ":" <> ref.objectId + +-- | How one Kioku action is expressed on the other side of the boundary. +data MemoryPermissionBinding = MemoryPermissionBinding + { -- | the credential claim the authentication service must have minted + coarseScope :: !MemoryCoarseScope, + -- | the permission asked of the authorization service + objectPermission :: !MemoryPermissionName + } + deriving stock (Eq, Ord, Show, Generic) + +-- | The complete translation from Kioku's actions to a host's identity stack. +-- +-- Kioku ships no default value for this, and that absence is the design. The object type and +-- permission names live in a schema Kioku does not own and which, at the time of writing, does +-- not yet contain a memory-space object at all. Inventing plausible names here would let Kioku +-- claim a compatibility it cannot demonstrate; requiring the host to supply them makes the +-- dependency visible at the call site. +data MemoryAuthorizationBinding = MemoryAuthorizationBinding + { spaceObjectType :: !MemoryObjectType, + permissionBindings :: !(Map MemoryPermission MemoryPermissionBinding) + } + deriving stock (Eq, Show, Generic) + +-- | Build a binding, refusing anything partial. +-- +-- Every one of 'allMemoryPermissions' must be present. A binding with a hole in it would fail +-- at the moment some rarely-exercised path — forgetting, say — first ran in production, which is +-- the worst possible time to discover it. Making construction total makes +-- 'memoryPermissionBinding' total. +mkMemoryAuthorizationBinding :: + MemoryObjectType -> + [(MemoryPermission, MemoryPermissionBinding)] -> + Either Text MemoryAuthorizationBinding +mkMemoryAuthorizationBinding spaceObjectType entries + | not (null missing) = + Left + ( "authorization binding is missing: " + <> Text.intercalate ", " (fmap memoryPermissionText missing) + ) + | otherwise = Right MemoryAuthorizationBinding {spaceObjectType, permissionBindings} + where + permissionBindings = Map.fromList entries + missing = filter (`Map.notMember` permissionBindings) allMemoryPermissions + +-- | Total, because 'mkMemoryAuthorizationBinding' rejects incomplete bindings. +memoryPermissionBinding :: MemoryAuthorizationBinding -> MemoryPermission -> MemoryPermissionBinding +memoryPermissionBinding binding permission = + case Map.lookup permission binding.permissionBindings of + Just found -> found + Nothing -> + -- Unreachable: the smart constructor is the only way to build a binding and it requires + -- every permission. Kept as an error rather than a default so a future constructor that + -- forgets the check fails loudly instead of silently authorizing against the wrong name. + error + ( "kioku: incomplete MemoryAuthorizationBinding, missing " + <> Text.unpack (memoryPermissionText permission) + ) + +-- | The authorization object for a memory space under a given binding. +-- +-- Note what makes two spaces distinct here: the space id, and nothing else. The same namespace +-- and scope in two different spaces produce two different object references, so a decision about +-- one can never be replayed as a decision about the other. +memorySpaceObjectRef :: MemoryAuthorizationBinding -> MemorySpaceId -> MemoryObjectRef +memorySpaceObjectRef binding spaceId = + MemoryObjectRef + { objectType = binding.spaceObjectType, + objectId = memorySpaceIdText spaceId + } + +-- | An opaque token naming the revision an authorization decision was made at. +-- +-- The authorization service mints it; Kioku only carries it. Presenting it on a later call is +-- what makes that call observe at least everything the first one did — the fix for the case +-- where a grant is written, the caller immediately retries, and a replica that has not caught up +-- answers "denied" about a permission that now exists. +newtype MemoryDecisionToken = MemoryDecisionToken Text + deriving stock (Eq, Ord, Show, Generic) + +-- | Wrap a token minted elsewhere. The only rule Kioku imposes is that it is not empty: the +-- encoding belongs entirely to whoever issued it, and an adapter that invented structure here +-- would break the first time that issuer changed its own. +mkMemoryDecisionToken :: Text -> Either Text MemoryDecisionToken +mkMemoryDecisionToken value + | Text.null value = Left "decision token must not be empty" + | otherwise = Right (MemoryDecisionToken value) + +memoryDecisionTokenText :: MemoryDecisionToken -> Text +memoryDecisionTokenText (MemoryDecisionToken value) = value + +-- | How fresh an authorization read has to be. +-- +-- Two cases, not four. The authorization service offers more (an exact snapshot, a fully +-- consistent head read), but Kioku only ever needs "whatever is cheap" and "at least as fresh as +-- this decision", and offering the others would invite a caller to pin a snapshot that ages. +data MemoryFreshness + = -- | cheapest available; may be slightly stale + MemoryFreshnessDefault + | -- | at least as fresh as the named decision + MemoryFreshnessAtLeast !MemoryDecisionToken + deriving stock (Eq, Show, Generic) + +-- | Request a read at least as fresh as a decision already observed. This is what a caller does +-- after a membership or grant write, and what a caller does when retrying a denial that a +-- just-written grant should have turned into an allow. +atLeastAsFresh :: MemoryDecisionToken -> MemoryFreshness +atLeastAsFresh = MemoryFreshnessAtLeast + +-- | What an authorization check can answer. +-- +-- @MemoryConditional@ is the one that catches people out. It means the relationship exists but +-- is gated on context the request did not supply, and it is /not/ an allow. Treating it as one +-- is how a time-limited or condition-limited grant becomes a permanent one. +data MemoryDecisionOutcome + = MemoryAllowed + | MemoryDenied + | -- | names of the unmet conditions + MemoryConditional ![Text] + deriving stock (Eq, Show, Generic) + +-- | A decision, and the revision it was decided at. +data MemoryDecision = MemoryDecision + { outcome :: !MemoryDecisionOutcome, + checkedAt :: !MemoryDecisionToken + } + deriving stock (Eq, Show, Generic) + +-- | Why a request was refused. These stay distinct all the way to the caller. +-- +-- Collapsing them is tempting and wrong. In particular none of them may be turned into a +-- successful recall that happens to return no rows: a caller cannot distinguish "you may not +-- look here" from "there is nothing here", and only one of those is worth retrying with +-- different credentials. +data MemoryAccessDenial + = -- | the credential lacks the coarse claim for this action + MemoryCoarseScopeMissing !MemoryCoarseScope + | -- | the authenticated subject maps to no principal: unlinked, departed, or paused + MemoryPrincipalUnresolved !Text + | -- | the authorization service said no for this space and action + MemoryPermissionDenied !MemorySpaceId !MemoryPermission + | -- | allowed only under conditions the request did not satisfy + MemoryDecisionConditional !MemorySpaceId !MemoryPermission ![Text] + deriving stock (Eq, Show, Generic) + +-- | What the authentication service established: who is calling, and what coarse claims they +-- carry. The subject is the credential's subject identifier, which is /not/ a principal +-- reference — resolving one to the other is the directory's job. +data AuthenticatedSubject = AuthenticatedSubject + { subjectId :: !Text, + grantedScopes :: !(Set MemoryCoarseScope) + } + deriving stock (Eq, Show, Generic) + +-- | The directory seam: turn an authenticated credential subject into a principal reference. +-- +-- 'Nothing' covers every reason a subject has no usable principal — never linked, since removed, +-- or an agent the directory has paused. Kioku deliberately cannot tell those apart, because +-- distinguishing them would mean holding directory state it has no business holding. +-- +-- This is a record of plain functions, not an interface to any particular service. A host wires +-- it to whatever it already has; a host with no directory at all does not build one, and uses +-- 'assumeAuthorizedMemoryContext' instead. +newtype PrincipalDirectory m = PrincipalDirectory + { resolvePrincipal :: Text -> m (Maybe PrincipalRef) + } + +-- | The authorization seam: may this principal do this to this object, read at this freshness? +newtype PermissionChecker m = PermissionChecker + { checkMemoryPermission :: + MemoryFreshness -> + PrincipalRef -> + MemoryPermissionName -> + MemoryObjectRef -> + m MemoryDecision + } + +-- | How a process that /discovers/ its own work obtains authorization for it. +-- +-- Interactive callers arrive holding a context. A background worker does not: it claims a due +-- timer or a queued task, reads which memory space that work belongs to, and only then needs a +-- decision about that space. This is the seam that lets it ask for one without inventing it. +-- +-- A trusted in-process host uses 'assumeAuthorizedContextProvider'. A host behind a service +-- boundary wires this to its own authorizer, typically a partially applied +-- 'Kioku.Api.Access.authorizeMemoryAccess' over the credential the worker runs under. +newtype MemoryContextProvider m = MemoryContextProvider + { contextForSpace :: MemorySpaceId -> m (Either MemoryAccessDenial MemoryAccessContext) + } + +-- | The embedded-host provider: assume authorization for every space, as one named actor. +-- +-- Named to be conspicuous for the same reason 'assumeAuthorizedMemoryContext' is. A worker +-- wired to this one will happily act in any space a timer names. +assumeAuthorizedContextProvider :: (Applicative m) => MemoryActor -> MemoryContextProvider m +assumeAuthorizedContextProvider actor = + MemoryContextProvider (pure . Right . (`assumeAuthorizedMemoryContext` actor)) + +-- | The proof that an authorization decision was made, carried into Kioku's core. +-- +-- Holding one of these means the three gates have already been passed for the listed +-- permissions on the named space. Kioku's core does not re-derive it, cannot re-derive it, and +-- must not proceed without it. +-- +-- The data constructor is not exported from "Kioku.Api.Access" precisely because constructing +-- one is an assertion. Use 'Kioku.Api.Access.authorizeMemoryAccess' to earn one, or +-- 'assumeAuthorizedMemoryContext' to state plainly that you are not checking. +data MemoryAccessContext = MemoryAccessContext + { memorySpaceId :: !MemorySpaceId, + actor :: !MemoryActor, + grantedPermissions :: !(Set MemoryPermission), + decisionToken :: !(Maybe MemoryDecisionToken) + } + deriving stock (Eq, Show, Generic) + +-- Read-only accessors rather than exported field selectors. +-- +-- Exporting the fields would export record-update syntax with them, and +-- @context { grantedPermissions = everything }@ widens an authorized decision without ever +-- naming the constructor — which is the exact hole keeping the constructor internal is meant to +-- close. Reading is safe; rewriting is not. + +memoryContextSpace :: MemoryAccessContext -> MemorySpaceId +memoryContextSpace context = context.memorySpaceId + +memoryContextActor :: MemoryAccessContext -> MemoryActor +memoryContextActor context = context.actor + +memoryContextPermissions :: MemoryAccessContext -> Set MemoryPermission +memoryContextPermissions context = context.grantedPermissions + +-- | The revision this context's decision was made at, if a decision was actually made. +memoryContextDecisionToken :: MemoryAccessContext -> Maybe MemoryDecisionToken +memoryContextDecisionToken context = context.decisionToken + +-- | Was this particular action authorized? A context authorizes exactly the permissions it was +-- minted for, so a read context cannot be spent on a write. +memoryContextAllows :: MemoryPermission -> MemoryAccessContext -> Bool +memoryContextAllows permission context = + Set.member permission context.grantedPermissions + +-- | The actor to record on a fact written under this context. +-- +-- Every write Kioku accepts through the memory-space API is attributed to the principal the +-- context was minted for, never to one the caller names separately. That is what stops a caller +-- authorized as one principal from writing an event claiming another one acted. +memoryContextRecordedActor :: MemoryAccessContext -> RecordedPrincipal +memoryContextRecordedActor context = + KnownPrincipal (actorPrincipal context.actor) + +-- | The freshness a follow-up authorization read should use, given what this context already +-- observed. This is the forwarding rule: a context minted from a real decision pins later reads +-- to at least that revision, and an assumed context pins nothing because it observed nothing. +memoryContextFreshness :: MemoryAccessContext -> MemoryFreshness +memoryContextFreshness context = + maybe MemoryFreshnessDefault MemoryFreshnessAtLeast context.decisionToken + +-- | Build a context without consulting anyone: the embedded-host escape hatch. +-- +-- This is for a single-tenant, in-process host that owns its own database and has no +-- authentication boundary — a CLI, a test, a library embedded in an application that has already +-- authorized the user by other means. It grants every permission on the named space and carries +-- no decision token, because no decision was made. +-- +-- It is named the way it is so that it cannot be used by accident and cannot be missed in +-- review. A service that reaches for this is shipping an unauthenticated endpoint. +assumeAuthorizedMemoryContext :: MemorySpaceId -> MemoryActor -> MemoryAccessContext +assumeAuthorizedMemoryContext memorySpaceId actor = + MemoryAccessContext + { memorySpaceId, + actor, + grantedPermissions = Set.fromList allMemoryPermissions, + decisionToken = Nothing + } + +-- Wire instances. The leaf identifiers cross the wire as plain strings and decode through their +-- validating constructors, so a decoded value obeys the same rules as a constructed one. +-- +-- 'MemoryAccessContext' has none, deliberately. It is a decision, not a document: giving it a +-- 'FromJSON' instance would let an authorized context be written down, stored, and replayed +-- later against a grant that has since been revoked. + +instance ToJSON MemorySpaceId where + toJSON = toJSON . memorySpaceIdText + +instance FromJSON MemorySpaceId where + parseJSON = withText "MemorySpaceId" (orFail . mkMemorySpaceId) + +instance ToJSON PrincipalRef where + toJSON = toJSON . principalRefText + +instance FromJSON PrincipalRef where + parseJSON = withText "PrincipalRef" (orFail . mkPrincipalRef) + +instance ToJSON RecordedPrincipal where + toJSON = toJSON . recordedPrincipalText + +instance FromJSON RecordedPrincipal where + parseJSON = withText "RecordedPrincipal" (orFail . parseRecordedPrincipal) + +instance ToJSON MemoryActor where + toJSON = toJSON . actorPrincipal + +instance FromJSON MemoryActor where + parseJSON = fmap MemoryActor . parseJSON + +instance ToJSON MemoryOwner where + toJSON = toJSON . ownerPrincipal + +instance FromJSON MemoryOwner where + parseJSON = fmap MemoryOwner . parseJSON + +instance ToJSON MemoryPermission where + toJSON = toJSON . memoryPermissionText + +instance FromJSON MemoryPermission where + parseJSON = withText "MemoryPermission" (orFail . parseMemoryPermission) + +instance ToJSON MemoryDecisionToken where + toJSON = toJSON . memoryDecisionTokenText + +instance FromJSON MemoryDecisionToken where + parseJSON = withText "MemoryDecisionToken" (orFail . mkMemoryDecisionToken) + +orFail :: (MonadFail m) => Either Text a -> m a +orFail = either (fail . Text.unpack) pure + +-- | Characters a rendered object reference gives meaning to: @:@ separates type from id and @#@ +-- separates an object from a relation. +tupleRefChars :: Text +tupleRefChars = ":#" + +-- | Everything 'tupleRefChars' reserves, plus the characters Kioku's own scope-identity encoding +-- reserves (see 'Kioku.Api.Scope.mkNamespace'). +reservedRefChars :: Text +reservedRefChars = tupleRefChars <> "%/" + +-- | Shared edge validation for the opaque identifiers Kioku carries but does not own: reject the +-- empty string, anything unprintable, and any character the caller's own encodings reserve. +validateOpaqueId :: Text -> Text -> Text -> Either Text Text +validateOpaqueId label reserved value + | Text.null value = Left (label <> " must not be empty") + | Text.length value > maxOpaqueIdLength = + Left (label <> " must be at most " <> Text.pack (show maxOpaqueIdLength) <> " characters") + | Just offending <- Text.find (\c -> Char.isSpace c || Char.isControl c) value = + Left (label <> " must not contain whitespace or control characters: " <> Text.pack (show offending)) + | Just offending <- Text.find (`Text.elem` reserved) value = + Left (label <> " must not contain " <> Text.singleton offending <> ": " <> value) + | otherwise = Right value + +-- | A bound generous enough for any rendered TypeID or scope name and small enough to keep a +-- hostile caller from turning an identifier column into a blob. +maxOpaqueIdLength :: Int +maxOpaqueIdLength = 128 diff --git a/src/Kioku/Api/Recall.hs b/src/Kioku/Api/Recall.hs new file mode 100644 --- /dev/null +++ b/src/Kioku/Api/Recall.hs @@ -0,0 +1,338 @@ +-- | What a recall call searches, said out loud. +-- +-- Recall has always been able to do two quite different things, and until this module existed it +-- said both of them with the same value. A 'Kioku.Api.Scope.MemoryScope' of +-- @ScopeGlobal (Namespace "mori")@ handed to recall meant /every scope in the namespace/ — the +-- scope filter vanished and entity-scoped rows came back too — while the same value handed to +-- 'Kioku.Recall.getActiveByScope' meant /the global bucket only/. Both behaviours are wanted. +-- Neither is wrong. But one value naming both of them is a defect you cannot see at a call site, +-- and the difference is how many rows a caller gets and which ones. +-- +-- 'RecallTarget' names the two meanings apart: +-- +-- * @'ExactScope' scope@ searches exactly that scope. @'ExactScope' ('Kioku.Api.Scope.ScopeGlobal' +-- ns)@ is the global bucket of @ns@ and nothing else — a request that had no representation at +-- all before this type. +-- * @'NamespaceWide' ns@ searches every scope in @ns@. +-- +-- __The target never selects a tenant.__ A memory space is the isolation boundary +-- ('Kioku.Api.Access.MemorySpaceId'), and it is supplied at execution by the +-- 'Kioku.Api.Access.MemoryAccessContext' that authorized the call — never by the target. +-- "Namespace-wide" therefore means every scope in one namespace /of one already authorized +-- space/. Widening what you search must never widen who you are. +-- +-- Nothing here knows about SQL, PostgreSQL, or the effect stack; this module is the vocabulary, +-- and "Kioku.Recall" is where a target is executed. +module Kioku.Api.Recall + ( -- * What a recall call targets + RecallTarget (..), + recallTargetNamespace, + recallTargetExactScope, + recallTargetIsNamespaceWide, + + -- * Migrating from the overloaded scope + legacyRecallTarget, + + -- * How a recall call searches + RecallStrategy (..), + allRecallStrategies, + recallStrategyText, + parseRecallStrategy, + + -- * How many results it may return + RecallLimit, + mkRecallLimit, + recallLimitInt, + defaultRecallLimit, + maxRecallLimit, + + -- * The request + RecallQuery (..), + mkRecallQuery, + ) +where + +import Data.Aeson (Key, (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types qualified as Aeson (Pair, Parser) +import Data.Text qualified as Text +import Kioku.Api.Scope + ( MemoryScope (..), + Namespace (..), + ScopeKind (..), + mkNamespace, + mkScopeKind, + ) +import Kioku.Prelude + +-- | The two things a recall call can search, kept apart by construction. +-- +-- There is deliberately no third constructor and no \"unspecified\" case. A target that could be +-- absent would immediately grow a default, and the only sensible default for a search is the +-- widest one — which is how the overloaded scope became a hazard in the first place. +data RecallTarget + = -- | Exactly this scope. For @'ScopeGlobal' ns@ that is the global bucket of @ns@: rows + -- recorded with no entity scope. For @'ScopeEntity' ns kind ref@ it is that entity and no + -- other. + ExactScope !MemoryScope + | -- | Every scope in this namespace: the global bucket and every entity scope under it. This + -- is what a pre-'RecallTarget' recall did with a global scope. + NamespaceWide !Namespace + deriving stock (Eq, Show, Generic) + +-- | The namespace a target searches. Every target names exactly one; a target that spanned +-- namespaces has never existed and is not being introduced here. +recallTargetNamespace :: RecallTarget -> Namespace +recallTargetNamespace = \case + ExactScope (ScopeGlobal ns) -> ns + ExactScope (ScopeEntity ns _ _) -> ns + NamespaceWide ns -> ns + +-- | The scope an exact target names, or 'Nothing' for a namespace-wide one. +recallTargetExactScope :: RecallTarget -> Maybe MemoryScope +recallTargetExactScope = \case + ExactScope scope -> Just scope + NamespaceWide _ -> Nothing + +-- | Whether this target widens past a single scope. Worth a name of its own: this is the +-- predicate an audit log, a CLI confirmation, or a policy check actually wants to ask. +recallTargetIsNamespaceWide :: RecallTarget -> Bool +recallTargetIsNamespaceWide = \case + ExactScope _ -> False + NamespaceWide _ -> True + +-- | The target a pre-'RecallTarget' caller was asking for, given the 'MemoryScope' it passed. +-- +-- @ +-- 'ScopeGlobal' ns -> 'NamespaceWide' ns +-- 'ScopeEntity' ns k r -> 'ExactScope' ('ScopeEntity' ns k r) +-- @ +-- +-- Use this exactly once per call site, while migrating, to keep the results you have today. Then +-- decide: if you wanted the global bucket rather than the whole namespace, the answer is +-- @'ExactScope' ('ScopeGlobal' ns)@, which this function deliberately never produces. +-- +-- Mapping the global scope to 'NamespaceWide' rather than to an exact global bucket is the whole +-- point. The opposite mapping would compile, run, and silently return a small fraction of the +-- rows the caller used to get. +legacyRecallTarget :: MemoryScope -> RecallTarget +legacyRecallTarget = \case + ScopeGlobal ns -> NamespaceWide ns + scope@ScopeEntity {} -> ExactScope scope + +-- | Which retrieval channels a recall call runs. +-- +-- This lived in @Kioku.Recall@ until targets became explicit. It belongs beside them: a request +-- is a target, a query, a strategy and a bound, and all four are pure vocabulary that a host, +-- an HTTP service, or an SDK has to be able to name without depending on the runtime. +data RecallStrategy + = -- | Full-text search only. Needs no embedding endpoint. + Keyword + | -- | Vector similarity only. Needs the query embedded. + Embedding + | -- | Both channels, fused by reciprocal rank. The default and what you almost always want. + Hybrid + deriving stock (Generic, Eq, Show, Enum, Bounded) + +-- | Every strategy, in the order they are documented. +allRecallStrategies :: [RecallStrategy] +allRecallStrategies = [minBound .. maxBound] + +-- | The wire and command-line spelling of a strategy. These three strings appear in +-- @kioku recall --strategy@ and in every request body, so changing one is a breaking change. +recallStrategyText :: RecallStrategy -> Text +recallStrategyText = \case + Keyword -> "keyword" + Embedding -> "embedding" + Hybrid -> "hybrid" + +parseRecallStrategy :: Text -> Either Text RecallStrategy +parseRecallStrategy = \case + "keyword" -> Right Keyword + "embedding" -> Right Embedding + "hybrid" -> Right Hybrid + other -> + Left + ( "unknown recall strategy: " + <> other + <> " (expected " + <> Text.intercalate ", " (recallStrategyText <$> allRecallStrategies) + <> ")" + ) + +-- | How many hits a recall call may return: at least one, at most 'maxRecallLimit'. +-- +-- A validated newtype rather than a bare 'Int' because the two ends mean different things and +-- both were previously unenforced at the library boundary. Zero or negative is not \"no limit\", +-- it is a caller bug that silently returns nothing; and an unbounded upper end invites a request +-- for a million rows that the database would have to plan for. The command line has enforced +-- @1-100@ since it was written — this puts the same rule where library callers meet it. +newtype RecallLimit = RecallLimit Int + deriving stock (Eq, Ord, Show, Generic) + +-- | The largest number of hits a single recall call may ask for. +-- +-- 100 matches the range @kioku recall --limit@ has always accepted, and it is also the most a +-- request can produce: each channel contributes at most 50 candidates, so a fused result set +-- holds at most 100 distinct memories. Asking for more has never returned more. +maxRecallLimit :: Int +maxRecallLimit = 100 + +-- | What @kioku recall@ uses when no limit is given. +defaultRecallLimit :: RecallLimit +defaultRecallLimit = RecallLimit 8 + +mkRecallLimit :: Int -> Either Text RecallLimit +mkRecallLimit value + | value < 1 = Left ("recall limit must be at least 1: " <> Text.pack (show value)) + | value > maxRecallLimit = + Left + ( "recall limit must be at most " + <> Text.pack (show maxRecallLimit) + <> ": " + <> Text.pack (show value) + ) + | otherwise = Right (RecallLimit value) + +recallLimitInt :: RecallLimit -> Int +recallLimitInt (RecallLimit value) = value + +-- | Everything a recall call needs except the space it runs in. +-- +-- The memory space is deliberately absent. It comes from the +-- 'Kioku.Api.Access.MemoryAccessContext' passed to 'Kioku.Recall.recall', because a request is +-- something a caller composes and a space is something an authorization decision granted. Keeping +-- them in separate values means no code path can widen a target and a tenancy in one edit. +-- +-- Every field is already validated by its own type, so the record constructor is safe to export: +-- a 'RecallTarget' cannot be ambiguous and a 'RecallLimit' cannot be zero. 'mkRecallQuery' is a +-- convenience for callers holding a plain 'Int'. +-- +-- The query text is /not/ validated. It is user input on its way to +-- @websearch_to_tsquery@, which is total by design and never raises, and rejecting empty or +-- punctuation-only text here would break callers that rely on today's \"no matches\" answer. +data RecallQuery = RecallQuery + { target :: !RecallTarget, + query :: !Text, + strategy :: !RecallStrategy, + maxResults :: !RecallLimit + } + deriving stock (Eq, Show, Generic) + +mkRecallQuery :: RecallTarget -> Text -> RecallStrategy -> Int -> Either Text RecallQuery +mkRecallQuery target query strategy limit = do + maxResults <- mkRecallLimit limit + Right RecallQuery {target, query, strategy, maxResults} + +-- * Wire format + +-- $ +-- The encoding is hand-written rather than derived, and the discriminator is required. Three +-- meanings, three tags, no field whose /absence/ changes what the request means: +-- +-- @ +-- {"kind":"exact_global","namespace":"mori"} +-- {"kind":"exact_entity","namespace":"mori","scope_kind":"repo","scope_ref":"shinzui\/kikan"} +-- {"kind":"namespace_wide","namespace":"mori"} +-- @ +-- +-- A derived encoding would have spelled the two Haskell constructors instead, leaving the +-- exact-global and exact-entity cases separated only by whether @scope_kind@ was present — which +-- is the null-means-something representation this whole change exists to remove, moved from SQL +-- onto the wire. +-- +-- Decoding is strict in both directions: an unknown @kind@ is an error, and a variant carrying a +-- field it has no meaning for ('exact_global' with a @scope_kind@, say) is an error too, rather +-- than a value with a silently ignored field. + +instance ToJSON RecallTarget where + toJSON = \case + ExactScope (ScopeGlobal (Namespace ns)) -> + Aeson.object [pair "kind" exactGlobalTag, pair "namespace" ns] + ExactScope (ScopeEntity (Namespace ns) (ScopeKind kind) ref) -> + Aeson.object + [ pair "kind" exactEntityTag, + pair "namespace" ns, + pair "scope_kind" kind, + pair "scope_ref" ref + ] + NamespaceWide (Namespace ns) -> + Aeson.object [pair "kind" namespaceWideTag, pair "namespace" ns] + +instance FromJSON RecallTarget where + parseJSON = Aeson.withObject "RecallTarget" \o -> do + kind <- o .: "kind" + namespace <- parseValidated mkNamespace =<< o .: "namespace" + scopeKind <- o .:? "scope_kind" + scopeRef <- o .:? "scope_ref" + case (kind :: Text, scopeKind, scopeRef) of + (k, Nothing, Nothing) + | k == exactGlobalTag -> pure (ExactScope (ScopeGlobal namespace)) + | k == namespaceWideTag -> pure (NamespaceWide namespace) + (k, Just kindText, Just ref) + | k == exactEntityTag -> do + entityKind <- parseValidated mkScopeKind kindText + pure (ExactScope (ScopeEntity namespace entityKind ref)) + (k, _, _) + | k `elem` [exactGlobalTag, exactEntityTag, namespaceWideTag] -> + fail + ( "recall target " + <> show k + <> " must carry " + <> ( if k == exactEntityTag + then "both scope_kind and scope_ref" + else "neither scope_kind nor scope_ref" + ) + ) + | otherwise -> + fail + ( "unknown recall target kind: " + <> show k + <> " (expected exact_global, exact_entity or namespace_wide)" + ) + +instance ToJSON RecallStrategy where + toJSON = toJSON . recallStrategyText + +instance FromJSON RecallStrategy where + parseJSON = Aeson.withText "RecallStrategy" (parseValidated parseRecallStrategy) + +instance ToJSON RecallLimit where + toJSON = toJSON . recallLimitInt + +-- | Decoding enforces the same bounds as 'mkRecallLimit'. A newtype validated only on the path +-- the host controls is validated only where nobody attacks it. +instance FromJSON RecallLimit where + parseJSON value = parseValidated mkRecallLimit =<< parseJSON value + +instance ToJSON RecallQuery where + toJSON request = + Aeson.object + [ pair "target" request.target, + pair "query" request.query, + pair "strategy" request.strategy, + pair "max_results" request.maxResults + ] + +instance FromJSON RecallQuery where + parseJSON = Aeson.withObject "RecallQuery" \o -> + RecallQuery + <$> o .: "target" + <*> o .: "query" + <*> o .: "strategy" + <*> o .: "max_results" + +exactGlobalTag, exactEntityTag, namespaceWideTag :: Text +exactGlobalTag = "exact_global" +exactEntityTag = "exact_entity" +namespaceWideTag = "namespace_wide" + +-- | Run one of this project's @Either Text@ validating constructors inside a parser, so a wire +-- value is held to exactly the rule a directly constructed one is. +parseValidated :: (a -> Either Text b) -> a -> Aeson.Parser b +parseValidated validate = either (fail . Text.unpack) pure . validate + +-- | 'Kioku.Prelude' re-exports @Control.Lens@, which owns @(.=)@, so aeson's stays out of scope +-- and object fields are built through this instead. +pair :: (ToJSON v) => Key -> v -> Aeson.Pair +pair key value = (key, toJSON value) diff --git a/test/Kioku/Api/AccessSpec.hs b/test/Kioku/Api/AccessSpec.hs new file mode 100644 --- /dev/null +++ b/test/Kioku/Api/AccessSpec.hs @@ -0,0 +1,350 @@ +-- | Pure wire-format and validation tests for "Kioku.Api.Access". +-- +-- Nothing here touches a database, a network, or any identity service. These tests pin two +-- things: the exact bytes the access vocabulary puts on the wire, and the boundary rules Kioku +-- enforces on identifiers it carries but does not own. +module Kioku.Api.AccessSpec (tests) where + +import Data.Aeson (FromJSON, ToJSON, decode, encode) +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Kioku.Api.Access +import Kioku.Api.Access.Internal qualified as Internal +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Kioku.Api.Access" + [ memorySpaceIdTests, + principalRefTests, + recordedPrincipalTests, + permissionWireTests, + jsonRoundTripTests, + objectRefTests, + bindingTests, + contextTests + ] + +-- | A memory space id is Kioku's own object identifier, so Kioku owns its rules. It has to +-- survive being an authorization object id, an indexed column, and half of a rendered object +-- reference, which is what the reserved characters are about. +memorySpaceIdTests :: TestTree +memorySpaceIdTests = + testGroup + "MemorySpaceId" + [ testCase "accepts an ordinary identifier" do + fmap memorySpaceIdText (mkMemorySpaceId "space_01h9xk3v7hf8b9c0d1e2f3g4h5") + @?= Right "space_01h9xk3v7hf8b9c0d1e2f3g4h5", + testCase "accepts a host-shaped label" do + fmap memorySpaceIdText (mkMemorySpaceId "acme-tenant-3") @?= Right "acme-tenant-3", + testCase "rejects the empty string" do + assertLeft "empty" (mkMemorySpaceId ""), + testGroup + "rejects characters an encoding gives meaning to" + [ testCase (Text.unpack ("contains " <> Text.singleton c)) do + assertLeft ("reserved " <> show c) (mkMemorySpaceId ("space" <> Text.singleton c <> "one")) + | c <- ":#%/" + ], + testCase "rejects whitespace" do + assertLeft "space" (mkMemorySpaceId "space one"), + testCase "rejects control characters" do + assertLeft "control" (mkMemorySpaceId "space\ETXone"), + testCase "rejects an over-long identifier" do + assertLeft "too long" (mkMemorySpaceId (Text.replicate 129 "a")), + testCase "accepts exactly the maximum length" do + assertRight (mkMemorySpaceId (Text.replicate 128 "a")), + testCase "the legacy space is a real, explicit id" do + memorySpaceIdText legacyMemorySpaceId @?= "kioku_legacy", + testCase "the legacy space is not the empty string" do + -- The whole point of a named legacy space is that absence of a partition never means + -- "everywhere". If this ever became empty or defaultable, that guarantee would go. + assertBool "non-empty" (not (Text.null (memorySpaceIdText legacyMemorySpaceId))) + ] + +-- | A principal reference is somebody else's identifier. Kioku validates only what it needs to +-- store and compare the value safely, and deliberately does not know which prefixes exist. +principalRefTests :: TestTree +principalRefTests = + testGroup + "PrincipalRef" + [ testGroup + "accepts every directory-rendered principal form verbatim" + [ testCase (Text.unpack rendered) do + fmap principalRefText (mkPrincipalRef rendered) @?= Right rendered + | rendered <- renderedPrincipals + ], + testCase "accepts a prefix Kioku has never heard of" do + -- This is the load-bearing test for the boundary: Kioku holds no principal-kind + -- vocabulary, so a directory that grows an eighth kind tomorrow needs no change here. + -- A version of this constructor that validated prefixes would fail this case and would + -- have forked the directory's own list. + fmap principalRefText (mkPrincipalRef "workload_01h9xk3v7hf8b9c0d1e2f3g4h5") + @?= Right "workload_01h9xk3v7hf8b9c0d1e2f3g4h5", + testCase "rejects the empty string" do + assertLeft "empty" (mkPrincipalRef ""), + testCase "rejects a tuple separator" do + assertLeft "colon" (mkPrincipalRef "person:01h9xk"), + testCase "rejects a userset separator" do + assertLeft "hash" (mkPrincipalRef "team_01h9xk#member"), + testCase "rejects whitespace" do + assertLeft "space" (mkPrincipalRef "person_01h9 xk"), + testCase "permits characters a space id forbids" do + -- '%' and '/' are reserved by Kioku's own scope encoding, not by anything the directory + -- owns, so they must not be imposed on a value the directory renders. + assertRight (mkPrincipalRef "person_01h9/xk") + ] + +-- | Rendered principal identifiers in the shape a real directory produces: a kind prefix, an +-- underscore, and a base32 UUIDv7 suffix. +renderedPrincipals :: [Text] +renderedPrincipals = + [ "person_01h9xk3v7hf8b9c0d1e2f3g4h5", + "agent_01h9xk3v7hf8b9c0d1e2f3g4h6", + "team_01h9xk3v7hf8b9c0d1e2f3g4h7", + "role_01h9xk3v7hf8b9c0d1e2f3g4h8", + "service_01h9xk3v7hf8b9c0d1e2f3g4h9", + "connector_01h9xk3v7hf8b9c0d1e2f3g4ha", + "org_01h9xk3v7hf8b9c0d1e2f3g4hb" + ] + +-- | A recorded principal is what a stored event says about who acted. The property that matters +-- is that the three cases can never be confused for one another on the wire — in particular that +-- a legacy free-text agent label can never be read back as a principal a directory issued. +recordedPrincipalTests :: TestTree +recordedPrincipalTests = + testGroup + "RecordedPrincipal" + [ testCase "a known principal renders as the bare directory form" do + recordedPrincipalText (KnownPrincipal (expectRight (mkPrincipalRef "agent_01h9xk"))) + @?= "agent_01h9xk", + testCase "a legacy agent label is marked" do + recordedPrincipalText (LegacyPrincipal (legacyPrincipalRef "demo-agent")) + @?= "kioku:legacy:demo-agent", + testCase "an unattributed event says so" do + recordedPrincipalText UnattributedPrincipal @?= "kioku:unattributed", + testCase "a legacy label never parses back as a directory principal" do + -- The load-bearing case. A legacy agentId is a string somebody typed; promoting it to a + -- principal would put an identity nobody issued into an audit trail. + parseRecordedPrincipal "kioku:legacy:demo-agent" + @?= Right (LegacyPrincipal (legacyPrincipalRef "demo-agent")), + testCase "a legacy label that looks like a marker still round-trips" do + roundTripPrincipal (LegacyPrincipal (legacyPrincipalRef "kioku:legacy:nested")), + testCase "a legacy label containing a colon round-trips" do + roundTripPrincipal (LegacyPrincipal (legacyPrincipalRef "rei:coach")), + testCase "an empty legacy label round-trips" do + -- Historical agent ids were unvalidated free text, so decoding one must not fail. + roundTripPrincipal (LegacyPrincipal (legacyPrincipalRef "")), + testCase "an unknown kioku marker is a loud error" do + assertLeft "unknown marker" (parseRecordedPrincipal "kioku:something-new"), + testCase "a directory principal still has to be valid" do + assertLeft "reserved" (parseRecordedPrincipal "person#member"), + testCase "no directory principal can spell either marker" do + -- This is why the marker scheme is unambiguous rather than merely unlikely. + assertLeft "colon" (mkPrincipalRef "kioku:legacy:x") + assertLeft "colon" (mkPrincipalRef "kioku:unattributed"), + testCase "encodes as a bare JSON string" do + LBS8.unpack (encode (LegacyPrincipal (legacyPrincipalRef "demo-agent"))) + @?= "\"kioku:legacy:demo-agent\"", + testCase "a context records its own actor, not a caller-named one" do + memoryContextRecordedActor (assumeAuthorizedMemoryContext spaceOne testActor) + @?= KnownPrincipal (actorPrincipal testActor) + ] + +roundTripPrincipal :: RecordedPrincipal -> IO () +roundTripPrincipal value = + parseRecordedPrincipal (recordedPrincipalText value) @?= Right value + +-- | These five spellings end up inside stored events. Changing one is a breaking change, so it +-- should have to be done on purpose, with this test in the diff. +permissionWireTests :: TestTree +permissionWireTests = + testGroup + "MemoryPermission" + [ testCase "has the expected stable spellings" do + fmap memoryPermissionText allMemoryPermissions + @?= ["read", "record", "distill", "forget", "admin"], + testCase "encodes as a bare JSON string" do + LBS8.unpack (encode MemoryDistill) @?= "\"distill\"", + testCase "parses back from every spelling" do + traverse (parseMemoryPermission . memoryPermissionText) allMemoryPermissions + @?= Right allMemoryPermissions, + testCase "rejects an unknown spelling" do + assertLeft "unknown" (parseMemoryPermission "write"), + testCase "enumerates exactly five actions" do + length allMemoryPermissions @?= 5 + ] + +jsonRoundTripTests :: TestTree +jsonRoundTripTests = + testGroup + "JSON round-trips" + [ roundTrip "MemorySpaceId" (expectRight (mkMemorySpaceId "space_01h9xk")), + roundTrip "PrincipalRef" (expectRight (mkPrincipalRef "person_01h9xk")), + roundTrip "MemoryActor" (MemoryActor (expectRight (mkPrincipalRef "agent_01h9xk"))), + roundTrip "MemoryOwner" (MemoryOwner (expectRight (mkPrincipalRef "person_01h9xk"))), + roundTrip "RecordedPrincipal (known)" (KnownPrincipal (expectRight (mkPrincipalRef "agent_01h9xk"))), + roundTrip "RecordedPrincipal (legacy)" (LegacyPrincipal (legacyPrincipalRef "demo-agent")), + roundTrip "RecordedPrincipal (unattributed)" UnattributedPrincipal, + testGroup + "MemoryPermission" + [roundTrip (show permission) permission | permission <- allMemoryPermissions], + testCase "identifiers cross the wire as bare strings, not objects" do + LBS8.unpack (encode (expectRight (mkMemorySpaceId "space_01h9xk"))) @?= "\"space_01h9xk\"", + testCase "decoding enforces the same rules as constructing" do + -- Without this, a validated newtype is only validated on the path nobody attacks. + decode @MemorySpaceId "\"space:one\"" @?= Nothing, + testCase "decoding rejects an empty principal reference" do + decode @PrincipalRef "\"\"" @?= Nothing + ] + +-- | The object reference is what makes two memory spaces genuinely separate questions to ask an +-- authorization engine. +objectRefTests :: TestTree +objectRefTests = + testGroup + "object references" + [ testCase "renders as type:id" do + memoryObjectRefText (memorySpaceObjectRef testBinding spaceOne) + @?= "memory_space:space_one", + testCase "two spaces produce two different objects" do + assertBool + "distinct" + ( memoryObjectRefText (memorySpaceObjectRef testBinding spaceOne) + /= memoryObjectRefText (memorySpaceObjectRef testBinding spaceTwo) + ), + testCase "the object depends on the space and nothing else" do + -- Namespace and scope organize memory inside a space; they are not part of its identity + -- as an authorization object. Two hosts sharing one space share one object. + memorySpaceObjectRef testBinding spaceOne @?= memorySpaceObjectRef testBinding spaceOne, + testCase "the host names the object type" do + let other = expectRight (mkMemoryAuthorizationBinding (expectRight (mkMemoryObjectType "tenant")) fullBindings) + memoryObjectRefText (memorySpaceObjectRef other spaceOne) @?= "tenant:space_one" + ] + +bindingTests :: TestTree +bindingTests = + testGroup + "MemoryAuthorizationBinding" + [ testCase "rejects a binding with any action missing" do + assertLeft + "incomplete" + ( mkMemoryAuthorizationBinding + (expectRight (mkMemoryObjectType "memory_space")) + (filter ((/= MemoryForget) . fst) fullBindings) + ), + testCase "names the missing actions" do + case mkMemoryAuthorizationBinding + (expectRight (mkMemoryObjectType "memory_space")) + (filter ((`notElem` [MemoryForget, MemoryAdmin]) . fst) fullBindings) of + Right _ -> fail "expected an incomplete binding to be rejected" + Left message -> do + assertBool "names forget" ("forget" `Text.isInfixOf` message) + assertBool "names admin" ("admin" `Text.isInfixOf` message), + testCase "a complete binding resolves every action" do + fmap + (memoryPermissionNameText . objectPermission . memoryPermissionBinding testBinding) + allMemoryPermissions + @?= ["can_read", "can_record", "can_distill", "can_forget", "can_administer"], + testCase "each action carries its own coarse scope" do + fmap + (memoryCoarseScopeText . coarseScope . memoryPermissionBinding testBinding) + allMemoryPermissions + @?= ["kioku:read", "kioku:record", "kioku:distill", "kioku:forget", "kioku:admin"] + ] + +contextTests :: TestTree +contextTests = + testGroup + "MemoryAccessContext" + [ testCase "an assumed context grants every action" do + let context = assumeAuthorizedMemoryContext spaceOne testActor + fmap (`memoryContextAllows` context) allMemoryPermissions + @?= replicate 5 True, + testCase "an assumed context observed nothing, so it pins nothing" do + memoryContextFreshness (assumeAuthorizedMemoryContext spaceOne testActor) + @?= MemoryFreshnessDefault, + testCase "an assumed context names the space it was assumed for" do + memoryContextSpace (assumeAuthorizedMemoryContext spaceOne testActor) @?= spaceOne, + testCase "an assumed context names its actor" do + memoryContextActor (assumeAuthorizedMemoryContext spaceOne testActor) @?= testActor, + testCase "a context carrying a decision pins later reads to it" do + let token = expectRight (mkMemoryDecisionToken "rev-42") + context = + Internal.MemoryAccessContext + { Internal.memorySpaceId = spaceOne, + Internal.actor = testActor, + Internal.grantedPermissions = Set.singleton MemoryRead, + Internal.decisionToken = Just token + } + memoryContextFreshness context @?= atLeastAsFresh token + memoryContextDecisionToken context @?= Just token, + testCase "a read context cannot be spent on a write" do + -- The narrow context above is the one that matters. An assumed context grants + -- everything by construction, so only a minted one can demonstrate that the granted + -- set is actually consulted. + let context = + Internal.MemoryAccessContext + { Internal.memorySpaceId = spaceOne, + Internal.actor = testActor, + Internal.grantedPermissions = Set.singleton MemoryRead, + Internal.decisionToken = Nothing + } + memoryContextAllows MemoryRead context @?= True + memoryContextAllows MemoryForget context @?= False + memoryContextPermissions context @?= Set.singleton MemoryRead + ] + +testActor :: MemoryActor +testActor = MemoryActor (expectRight (mkPrincipalRef "person_01h9xk3v7hf8b9c0d1e2f3g4h5")) + +spaceOne, spaceTwo :: MemorySpaceId +spaceOne = expectRight (mkMemorySpaceId "space_one") +spaceTwo = expectRight (mkMemorySpaceId "space_two") + +-- | A binding a host might plausibly write. Kioku ships no default one, so a test has to supply +-- its own — which is the property being demonstrated as much as it is test scaffolding. +testBinding :: MemoryAuthorizationBinding +testBinding = + expectRight + ( mkMemoryAuthorizationBinding + (expectRight (mkMemoryObjectType "memory_space")) + fullBindings + ) + +fullBindings :: [(MemoryPermission, MemoryPermissionBinding)] +fullBindings = + [ binding MemoryRead "kioku:read" "can_read", + binding MemoryRecord "kioku:record" "can_record", + binding MemoryDistill "kioku:distill" "can_distill", + binding MemoryForget "kioku:forget" "can_forget", + binding MemoryAdmin "kioku:admin" "can_administer" + ] + where + binding permission scope name = + ( permission, + MemoryPermissionBinding + { coarseScope = expectRight (mkMemoryCoarseScope scope), + objectPermission = expectRight (mkMemoryPermissionName name) + } + ) + +roundTrip :: (ToJSON a, FromJSON a, Eq a, Show a) => String -> a -> TestTree +roundTrip name value = + testCase name (decode (encode value) @?= Just value) + +assertLeft :: (Show a) => String -> Either Text a -> IO () +assertLeft label = \case + Left _ -> pure () + Right unexpected -> fail (label <> ": expected rejection, got " <> show unexpected) + +assertRight :: (Show a) => Either Text a -> IO () +assertRight = \case + Right _ -> pure () + Left message -> fail ("expected acceptance, got: " <> Text.unpack message) + +expectRight :: Either Text a -> a +expectRight = either (error . Text.unpack) id diff --git a/test/Kioku/Api/RecallSpec.hs b/test/Kioku/Api/RecallSpec.hs new file mode 100644 --- /dev/null +++ b/test/Kioku/Api/RecallSpec.hs @@ -0,0 +1,277 @@ +-- 'rejects' names the type it is decoding at each call site rather than inferring it from an +-- expected value, because the whole point is that there /is/ no value. +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Pure tests for "Kioku.Api.Recall": the three things a recall call can target, the bytes +-- they put on the wire, and the conversion that keeps a pre-'RecallTarget' caller's results +-- unchanged. +-- +-- Nothing here touches a database. What is being pinned is a vocabulary — specifically that the +-- exact global bucket, the exact entity scope, and the whole namespace are three distinguishable +-- values in Haskell and three distinguishable objects in JSON, which is the property whose +-- absence made @ScopeGlobal@ mean two different things depending on which function received it. +module Kioku.Api.RecallSpec (tests) where + +import Data.Aeson (FromJSON, ToJSON, Value (..), decode, encode) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy (ByteString) +import Data.List (sort) +import Data.Text (Text) +import Data.Text qualified as Text +import Kioku.Api.Recall +import Kioku.Api.Scope (MemoryScope (..), Namespace (..), ScopeKind (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Kioku.Api.Recall" + [ targetDistinctionTests, + legacyConversionTests, + targetWireTests, + targetDecodingTests, + strategyTests, + limitTests, + queryTests + ] + +-- | The whole reason this type exists: three meanings, three values. +targetDistinctionTests :: TestTree +targetDistinctionTests = + testGroup + "the three targets are three values" + [ testCase "the exact global bucket is not the whole namespace" do + assertBool + "distinct" + (ExactScope (ScopeGlobal mori) /= NamespaceWide mori), + testCase "the exact global bucket is not an exact entity" do + assertBool + "distinct" + (ExactScope (ScopeGlobal mori) /= ExactScope moriRepo), + testCase "every target names exactly one namespace" do + fmap + recallTargetNamespace + [ExactScope (ScopeGlobal mori), ExactScope moriRepo, NamespaceWide mori] + @?= [mori, mori, mori], + testCase "only an exact target has a scope" do + recallTargetExactScope (ExactScope moriRepo) @?= Just moriRepo + recallTargetExactScope (NamespaceWide mori) @?= Nothing, + testCase "widening is a question a caller can ask" do + -- An audit line, a CLI confirmation, or a policy check wants this predicate, and none of + -- them should have to pattern-match a scope to compute it. + fmap + recallTargetIsNamespaceWide + [ExactScope (ScopeGlobal mori), ExactScope moriRepo, NamespaceWide mori] + @?= [False, False, True] + ] + +-- | The compatibility mapping. It preserves what a caller gets today, which means it must send +-- the global scope to the /wide/ target — the mapping that returns more rows, not fewer. +legacyConversionTests :: TestTree +legacyConversionTests = + testGroup + "legacyRecallTarget" + [ testCase "a global scope stays namespace-wide" do + legacyRecallTarget (ScopeGlobal mori) @?= NamespaceWide mori, + testCase "an entity scope becomes an exact target" do + legacyRecallTarget moriRepo @?= ExactScope moriRepo, + testCase "it never silently narrows a caller to the global bucket" do + -- The load-bearing case. The other mapping compiles, runs, and returns a small fraction + -- of the rows the caller had yesterday, with no error and no warning. + assertBool + "not narrowed" + (legacyRecallTarget (ScopeGlobal mori) /= ExactScope (ScopeGlobal mori)), + testCase "the exact global bucket is reachable only by asking for it" do + assertBool + "no scope converts to an exact global target" + ( ExactScope (ScopeGlobal mori) + `notElem` fmap legacyRecallTarget [ScopeGlobal mori, moriRepo] + ) + ] + +-- | The wire contract. These three shapes end up in HTTP request bodies and SDK unions, so +-- changing one is a breaking change and should have to be done on purpose, with this test in the +-- diff. +targetWireTests :: TestTree +targetWireTests = + testGroup + "targets on the wire" + [ encodesAs + "exact global" + (ExactScope (ScopeGlobal mori)) + "{\"kind\":\"exact_global\",\"namespace\":\"mori\"}", + encodesAs + "exact entity" + (ExactScope moriRepo) + "{\"kind\":\"exact_entity\",\"namespace\":\"mori\",\"scope_kind\":\"repo\",\"scope_ref\":\"shinzui/kikan\"}", + encodesAs + "namespace wide" + (NamespaceWide mori) + "{\"kind\":\"namespace_wide\",\"namespace\":\"mori\"}", + testCase "the discriminator is what separates exact-global from namespace-wide" do + -- Both carry a namespace and nothing else, so if the tag were dropped or defaulted the + -- two would be the same object — which is the SQL-level defect this vocabulary replaces, + -- moved onto the wire. + assertBool + "distinct encodings" + (encode (ExactScope (ScopeGlobal mori)) /= encode (NamespaceWide mori)), + testGroup + "round-trips" + [ roundTrip "exact global" (ExactScope (ScopeGlobal mori)), + roundTrip "exact entity" (ExactScope moriRepo), + roundTrip "namespace wide" (NamespaceWide mori), + roundTrip "a ref containing a slash" (ExactScope moriRepo), + roundTrip + "a ref containing a colon" + (ExactScope (ScopeEntity mori (ScopeKind "agent") "rei:coach")) + ] + ] + +-- | Decoding is a contract, not a guess. +targetDecodingTests :: TestTree +targetDecodingTests = + testGroup + "decoding refuses what it cannot mean" + [ testCase "an unknown kind is an error, not a default" do + rejects @RecallTarget "{\"kind\":\"everything\",\"namespace\":\"mori\"}", + testCase "a missing kind is an error, not namespace-wide" do + rejects @RecallTarget "{\"namespace\":\"mori\"}", + testCase "an exact global target may not carry a scope kind" do + -- Accepting and ignoring it would let a caller believe they had asked for an entity. + rejects @RecallTarget + "{\"kind\":\"exact_global\",\"namespace\":\"mori\",\"scope_kind\":\"repo\"}", + testCase "a namespace-wide target may not carry scope fields" do + rejects @RecallTarget + "{\"kind\":\"namespace_wide\",\"namespace\":\"mori\",\"scope_kind\":\"repo\",\"scope_ref\":\"x\"}", + testCase "an exact entity target needs both halves of the scope" do + rejects @RecallTarget "{\"kind\":\"exact_entity\",\"namespace\":\"mori\",\"scope_kind\":\"repo\"}" + rejects @RecallTarget "{\"kind\":\"exact_entity\",\"namespace\":\"mori\",\"scope_ref\":\"x\"}" + rejects @RecallTarget "{\"kind\":\"exact_entity\",\"namespace\":\"mori\"}", + testCase "a namespace is held to the same rule as a constructed one" do + -- 'mkNamespace' rejects the characters the scope-identity encoding gives meaning to. A + -- decoder that skipped that check would validate only the path nobody attacks. + rejects @RecallTarget "{\"kind\":\"namespace_wide\",\"namespace\":\"mori/other\"}" + rejects @RecallTarget "{\"kind\":\"namespace_wide\",\"namespace\":\"\"}", + testCase "a scope kind is held to the same rule as a constructed one" do + rejects @RecallTarget + "{\"kind\":\"exact_entity\",\"namespace\":\"mori\",\"scope_kind\":\"re:po\",\"scope_ref\":\"x\"}", + testCase "a scope ref is deliberately free text" do + -- Refs are host-controlled and legitimately contain '/' and ':' — repo-style refs and + -- arbitrary agent names. Validating them here would reject data that already exists. + decode @RecallTarget + "{\"kind\":\"exact_entity\",\"namespace\":\"mori\",\"scope_kind\":\"repo\",\"scope_ref\":\"shinzui/kikan\"}" + @?= Just (ExactScope moriRepo) + ] + +strategyTests :: TestTree +strategyTests = + testGroup + "RecallStrategy" + [ testCase "has the expected stable spellings" do + fmap recallStrategyText allRecallStrategies @?= ["keyword", "embedding", "hybrid"], + testCase "parses back from every spelling" do + traverse (parseRecallStrategy . recallStrategyText) allRecallStrategies + @?= Right allRecallStrategies, + testCase "rejects an unknown spelling, naming the alternatives" do + case parseRecallStrategy "semantic" of + Right unexpected -> fail ("expected rejection, got " <> show unexpected) + Left message -> do + assertBool "names keyword" ("keyword" `Text.isInfixOf` message) + assertBool "names hybrid" ("hybrid" `Text.isInfixOf` message), + testCase "crosses the wire as a bare string" do + encode Hybrid @?= "\"hybrid\"", + testCase "decoding rejects an unknown spelling" do + rejects @RecallStrategy "\"semantic\"", + testGroup + "round-trips" + [roundTrip (show strategy) strategy | strategy <- allRecallStrategies] + ] + +limitTests :: TestTree +limitTests = + testGroup + "RecallLimit" + [ testCase "rejects zero, which silently returns nothing" do + rejected (mkRecallLimit 0), + testCase "rejects a negative limit" do + rejected (mkRecallLimit (-1)), + testCase "accepts both ends of the range" do + fmap recallLimitInt (mkRecallLimit 1) @?= Right 1 + fmap recallLimitInt (mkRecallLimit maxRecallLimit) @?= Right maxRecallLimit, + testCase "rejects one past the maximum" do + rejected (mkRecallLimit (maxRecallLimit + 1)), + testCase "the maximum is the most a fused result set can hold" do + -- Each channel contributes at most 50 candidates, so 100 distinct memories is the + -- ceiling. A larger limit has never returned more rows; it only widened what the + -- database was asked to plan for. + maxRecallLimit @?= 100, + testCase "the default is what the command line has always used" do + recallLimitInt defaultRecallLimit @?= 8, + testCase "crosses the wire as a bare number" do + encode defaultRecallLimit @?= "8", + testCase "decoding enforces the same bounds as constructing" do + rejects @RecallLimit "0" + rejects @RecallLimit "101" + ] + +queryTests :: TestTree +queryTests = + testGroup + "RecallQuery" + [ testCase "the smart constructor validates the limit and nothing else" do + fmap (\q -> q.target) (mkRecallQuery (NamespaceWide mori) "commit style" Hybrid 8) + @?= Right (NamespaceWide mori) + rejected (mkRecallQuery (NamespaceWide mori) "commit style" Hybrid 0), + testCase "empty query text is accepted, because websearch_to_tsquery accepts it" do + -- Today an empty or punctuation-only query returns no matches rather than an error. + -- Rejecting it here would be a behaviour change for every caller that relies on that. + fmap (\q -> q.query) (mkRecallQuery (NamespaceWide mori) "" Keyword 8) @?= Right "", + encodesAs + "a whole request" + (expectRight (mkRecallQuery (ExactScope moriRepo) "commit style" Hybrid 8)) + "{\"target\":{\"kind\":\"exact_entity\",\"namespace\":\"mori\",\"scope_kind\":\"repo\",\ + \\"scope_ref\":\"shinzui/kikan\"},\"query\":\"commit style\",\"strategy\":\"hybrid\",\ + \\"max_results\":8}", + roundTrip + "a whole request round-trips" + (expectRight (mkRecallQuery (NamespaceWide mori) "commit style" Keyword 3)), + testCase "a request has exactly four fields, and none of them is a memory space" do + -- The space comes from the MemoryAccessContext at execution. If it were a field here, a + -- caller composing a request could widen a target and a tenancy in one edit. + case decode @Value (encode (expectRight (mkRecallQuery (NamespaceWide mori) "q" Hybrid 3))) of + Just (Object fields) -> + sort (KeyMap.keys fields) @?= ["max_results", "query", "strategy", "target"] + other -> fail ("expected a JSON object, got " <> show other) + ] + +mori :: Namespace +mori = Namespace "mori" + +moriRepo :: MemoryScope +moriRepo = ScopeEntity mori (ScopeKind "repo") "shinzui/kikan" + +-- | Compare the encoding as a decoded 'Value' rather than as bytes: aeson's object key order is +-- unspecified, and pinning it would make this test fail for a reason that is not a contract +-- change. +encodesAs :: (ToJSON a) => String -> a -> ByteString -> TestTree +encodesAs name value expected = + testCase name (decode @Value (encode value) @?= decode @Value expected) + +roundTrip :: (ToJSON a, FromJSON a, Eq a, Show a) => String -> a -> TestTree +roundTrip name value = + testCase name (decode (encode value) @?= Just value) + +rejects :: forall a. (FromJSON a, Show a) => ByteString -> IO () +rejects raw = + case decode @a raw of + Nothing -> pure () + Just unexpected -> fail ("expected rejection of " <> show raw <> ", got " <> show unexpected) + +rejected :: (Show a) => Either Text a -> IO () +rejected = \case + Left _ -> pure () + Right unexpected -> fail ("expected rejection, got " <> show unexpected) + +expectRight :: Either Text a -> a +expectRight = either (error . Text.unpack) id diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import Kioku.Api.AccessSpec qualified as AccessSpec +import Kioku.Api.RecallSpec qualified as RecallSpec +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + defaultMain $ + testGroup + "kioku-api" + [ AccessSpec.tests, + RecallSpec.tests + ]