diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,22 @@ ## Unreleased +## 0.4.0.0 — 2026-09-08 + +- Add per-attempt observers to bare/resilient runtimes and a bounded, thread-safe billing collector with exact cost persistence and explicit unknown usage. Observer exceptions propagate without retry; no additional budget charge occurs. `LLMConfig.observer` is a public record addition requiring a PVP major review. + +- Add `Shikumi.LLM.Defaults`: invocation-scoped thinking, speed, token and evidence defaults with fill-only precedence for blocking and streaming calls. Zero default ceilings raise `ValidationFailure`. Additive public API requires a PVP minor release; existing unreleased major changes still govern the next release. + +- Add continuation origin/prefix guards shared by routing and transport. `routeLLM` now requires `Error ShikumiError`; this public constraint change requires a PVP major review at release. + +- Preserve structured transport failures in `ProviderError BaikaiError` and expose `renderShikumiError`. Blocking and streaming calls retry only typed rate limits/transient failures; refusals, auth, unavailable-provider, process and unknown failures are terminal. Legacy `ProviderFailure` and malformed stream terminals retain retry behavior. The added public sum constructor requires a PVP major bump at release; exhaustive downstream matches must handle it. + +- Upgrade the dependency on `mori://shinzui/baikai/packages/baikai` to `>=0.7.0.0 && <0.8`. Require the Claude and OpenAI providers at `0.7.0.0` and Effectful at `0.4.0.1`; recognize OpenAI Responses as native structured-output capable. + +- Decode nested XML records and arrays with bounded, balanced parsing. Add `nestedXmlAdapter` with `ToJSON` output demonstrations and schema guides; preserve legacy XML rendering and JSON-in-tag container decoding. XML required strings now retain literal `null`. + +- Add `CaptureCodec`, `PredictCaptured`, and `predictCaptured` for opt-in typed node capture. Ordinary prediction constraints and parameter serialization are unchanged. Public GADT matches must handle the new constructor; all core traversals preserve codecs. + ## 0.3.0.3 — 2026-08-29 ### Changed diff --git a/shikumi.cabal b/shikumi.cabal --- a/shikumi.cabal +++ b/shikumi.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: shikumi -version: 0.3.0.3 +version: 0.4.0.0 synopsis: Typed, structured, evaluable LM programs over baikai category: AI description: @@ -39,6 +39,9 @@ Shikumi.Error Shikumi.LLM Shikumi.LLM.Budget + Shikumi.LLM.Continuation + Shikumi.LLM.Defaults + Shikumi.LLM.Observation Shikumi.Module Shikumi.Multimodal Shikumi.Prelude @@ -51,25 +54,26 @@ Shikumi.Signature Shikumi.Stream + other-modules: Shikumi.Adapter.Xml build-depends: - , aeson >=2.2 && <2.3 - , baikai >=0.6 && <0.7 - , baikai-claude >=0.6 && <0.7 - , baikai-effectful >=0.4 && <0.5 - , baikai-openai >=0.6 && <0.7 - , base >=4.20 && <5 - , base64-bytestring >=1.2 && <1.3 - , bytestring >=0.11 && <0.13 - , containers >=0.6 && <0.9 - , effectful >=2.5 && <2.7 - , filepath >=1.4 && <1.6 - , generic-lens >=2.2 && <2.4 + , aeson >=2.2 && <2.3 + , baikai >=0.7.0.0 && <0.8 + , baikai-claude >=0.7.0.0 && <0.8 + , baikai-effectful >=0.4.0.1 && <0.5 + , baikai-openai >=0.7.0.0 && <0.8 + , base >=4.20 && <5 + , base64-bytestring >=1.2 && <1.3 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.9 + , effectful >=2.5 && <2.7 + , filepath >=1.4 && <1.6 + , generic-lens >=2.2 && <2.4 , lens ^>=5.3 - , scientific >=0.3 && <0.4 - , stm >=2.5 && <2.6 + , scientific >=0.3 && <0.4 + , stm >=2.5 && <2.6 , text ^>=2.1 - , time >=1.12 && <1.17 - , vector >=0.13 && <0.14 + , time >=1.12 && <1.17 + , vector >=0.13 && <0.14 test-suite shikumi-test import: common-options @@ -81,6 +85,7 @@ AdapterSpec CombinatorSpec ConstraintSpec + ContinuationSpec EndToEndSpec ErrorSpec Fixtures @@ -95,7 +100,9 @@ ProgramSpec RefineSpec RefineStub + RequestDefaultsSpec ResilienceSpec + ResponsesSpec RoutingSpec SchemaSpec SerializeSpec @@ -109,10 +116,10 @@ build-depends: , aeson - , baikai >=0.6 && <0.7 - , baikai-claude >=0.6 && <0.7 - , baikai-effectful >=0.4 && <0.5 - , baikai-openai >=0.6 && <0.7 + , baikai >=0.7.0.0 && <0.8 + , baikai-claude >=0.7.0.0 && <0.8 + , baikai-effectful >=0.4.0.1 && <0.5 + , baikai-openai >=0.7.0.0 && <0.8 , base , base64-bytestring , bytestring @@ -122,7 +129,7 @@ , generic-lens , lens , QuickCheck - , shikumi ^>=0.3.0.0 + , shikumi ^>=0.4.0.0 , stm , streamly-core , tasty diff --git a/src/Shikumi/Adapter.hs b/src/Shikumi/Adapter.hs --- a/src/Shikumi/Adapter.hs +++ b/src/Shikumi/Adapter.hs @@ -8,10 +8,10 @@ -- @render@ builds a baikai @Context@+@Options@; @parse@ decodes a baikai -- @Response@ into the typed output via "Shikumi.Schema". -- --- Two adapters ship. The native-schema adapter is the reliable path (the provider --- enforces the JSON schema); the prompt-based fallback renders @[[ ## field ## ]]@ --- sections and re-parses them, for models without native structured output. --- 'capabilityFor' selects per model. +-- The native-schema adapter uses provider-enforced JSON; the prompt-based fallback +-- renders @[[ ## field ## ]]@ sections for models without native structured output. +-- 'capabilityFor' selects between them per model. Two opt-in XML adapters share +-- bounded nested decoding and offer legacy or structured demonstration rendering. -- -- Native structured output is wired through a private /metadata channel/ (EP-14). -- Because a 'Program' renders before the ambient model is known (the model is @@ -44,6 +44,7 @@ nativeAdapter, fallbackAdapter, xmlAdapter, + nestedXmlAdapter, adapterFor, attachSchema, responseText, @@ -92,6 +93,7 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Vector qualified as V import GHC.Generics +import Shikumi.Adapter.Xml (decodeXmlFields, renderXmlFields, xmlSchemaGuide) import Shikumi.Error (ShikumiError (..)) import Shikumi.Multimodal (GImageFieldNames (..), GImageFields (..), Image, imageToContent) import Shikumi.Schema (FromModel, ToSchema, Validatable, deriveSchema, fromModelChecked) @@ -188,6 +190,7 @@ capabilityFor :: Model -> ModelCapability capabilityFor m = case (m ^. #provider, m ^. #api) of ("openai", OpenAIChatCompletions) -> NativeSchema + ("openai", OpenAIResponses) -> NativeSchema ("anthropic", AnthropicMessages) -> NativeSchema _ -> PromptFallback @@ -307,9 +310,9 @@ -- | The XML adapter (EP-26). A third wire format on the same typed seam: @render@ -- asks the model to wrap each output field in @\…\@ tags, and -- @parse@ reads those tags back. Some models follow an XML shape more reliably than --- JSON or the @[[ ## … ## ]]@ markers. Reuses the same 'sectionsToObject' + --- 'fromModelChecked' decode path as 'fallbackAdapter', so nested records and lists --- in tags coerce the same way. +-- JSON or the @[[ ## … ## ]]@ markers. Both XML adapters decode nested elements +-- and legacy JSON-in-tag containers through 'fromModelChecked'. This adapter +-- retains its historical flattened demonstration rendering. -- -- Reachability: 'xmlAdapter' is /not/ selectable by the runtime router. The router -- ("Shikumi.Routing".@routeLLM@) picks between the native and fallback wire shapes @@ -330,11 +333,26 @@ let sys = systemHeader sig <> xmlOutputGuide sig ctx = buildContext sys (xmlDemoMessages sig ++ [userTurn i]) in (ctx, emptyOptions), - parse = \sig resp -> + parse = \_sig resp -> decodeXmlFields (deriveSchema @o) (responseText resp) >>= fromModelChecked + } + +-- | Nested XML guides and faithful structured demonstrations (EP-55). Requires +-- 'Aeson.ToJSON' for outputs; inputs still use 'ToPrompt'. Supports generated +-- records, arrays, scalars and nullable schemas; other schema forms render an +-- escaped JSON fallback. Parsing is shared with 'xmlAdapter'. Opt-in only. +nestedXmlAdapter :: + forall i o. + (ToSchema o, FromModel o, Validatable o, ToPrompt i, Aeson.ToJSON o) => + Adapter i o +nestedXmlAdapter = + Adapter + { render = \sig i -> let names = map fieldName (outputFields sig) - sections = parseXmlTags names (responseText resp) - obj = sectionsToObject (deriveSchema @o) sections - in fromModelChecked obj + schema = deriveSchema @o + sys = systemHeader sig <> xmlSchemaGuide names schema + demos = concat [[userTurn di, assistant (renderXmlFields names schema (toJSON o))] | Demo di o <- getDemos sig] + in (buildContext sys (demos ++ [userTurn i]), emptyOptions), + parse = \_sig resp -> decodeXmlFields (deriveSchema @o) (responseText resp) >>= fromModelChecked } -- --------------------------------------------------------------------------- @@ -484,29 +502,6 @@ flush (Just (name, buf)) acc | name == "completed" = acc | otherwise = Map.insert name (T.strip (T.unlines buf)) acc - --- | Extract @\…\@ sections into a name->text map. Only names that --- appear as output fields are kept (so stray tags are ignored, DSPy parity), and --- the first match per name wins. The content is whatever lies between the first --- @\@ and its next @\@ — a non-greedy match, the same as DSPy's --- @\<(?P\\\w+)\>(?P\.*?)\@ with DOTALL. -parseXmlTags :: [Text] -> Text -> Map Text Text -parseXmlTags names body = - Map.fromList [(nm, inner) | nm <- names, Just inner <- [extractTag nm body]] - --- | The text between the first @\@ and its next @\@, trimmed; --- 'Nothing' if either tag is absent. -extractTag :: Text -> Text -> Maybe Text -extractTag nm body = - let open = openTag nm - close = closeTag nm - (_, afterOpen) = T.breakOn open body - in if T.null afterOpen - then Nothing - else - let rest = T.drop (T.length open) afterOpen - (inner, afterClose) = T.breakOn close rest - in if T.null afterClose then Nothing else Just (T.strip inner) -- | Recognize a @[[ ## name ## ]]@ marker line. markerName :: Text -> Maybe Text diff --git a/src/Shikumi/Adapter/Xml.hs b/src/Shikumi/Adapter/Xml.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/Adapter/Xml.hs @@ -0,0 +1,233 @@ +-- | Bounded model-output XML fragments, not a general XML processor. +module Shikumi.Adapter.Xml (decodeXmlFields, renderXmlFields, xmlSchemaGuide) where + +import Data.Aeson (Object, Value (..), eitherDecodeStrict, encode) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.Char (chr, isAlpha, isAlphaNum, ord) +import Data.List (sortOn) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Vector qualified as V +import Shikumi.Error (ShikumiError (..)) + +-- Offsets count Unicode code points, starting at zero. CDATA provenance matters +-- for the nullable literal string "null". +data Node = Element !Int !Text [Node] | Content !Bool !Text + +data Cursor = Cursor !Int !Text + +failure :: Int -> Text -> Either ShikumiError a +failure pos msg = Left (SchemaMismatch ("XML: offset " <> T.pack (show pos) <> ": " <> msg)) + +advance :: Text -> Cursor -> Cursor +advance consumed (Cursor pos rest) = Cursor (pos + T.length consumed) (T.drop (T.length consumed) rest) + +xmlSpace :: Char -> Bool +xmlSpace c = c `elem` [' ', '\t', '\r', '\n'] + +validChar :: Char -> Bool +validChar c = let n = ord c in n == 9 || n == 10 || n == 13 || (n >= 32 && n <= 0xD7FF) || (n >= 0xE000 && n <= 0xFFFD) || (n >= 0x10000 && n <= 0x10FFFF) + +-- Siblings accumulate tail-recursively; only element nesting consumes depth. +fragment :: Int -> Maybe Text -> Cursor -> Either ShikumiError ([Node], Cursor) +fragment depth closing = go [] + where + go acc cur@(Cursor pos rest) + | T.null rest = case closing of + Nothing -> Right (reverse acc, cur) + Just name -> failure pos ("unterminated element " <> name) + | "" cur + if "--" `T.isInfixOf` body || "-" `T.isSuffixOf` body then failure pos "invalid comment" else go acc next + | "" cur + go (Content True body : acc) next + | " name) + | "= 64 then failure pos "depth limit 64 exceeded" else Right () + (name, selfClosing, next) <- tag False cur + (children, after) <- if selfClosing then Right ([], next) else fragment (depth + 1) (Just name) next + go (Element pos name children : acc) after + | otherwise = do + let (raw, _) = T.breakOn "<" rest + if "]]>" `T.isInfixOf` raw then failure pos "CDATA terminator outside CDATA" else Right () + decoded <- if closing == Nothing then Right raw else entities pos raw + go (Content False decoded : acc) (advance raw cur) + + delimited start end cur@(Cursor pos rest) = + let (body, suffix) = T.breakOn end (T.drop (T.length start) rest) + in if T.null suffix + then failure pos ("unterminated " <> start) + else Right (body, advance (start <> body <> end) cur) + +tag :: Bool -> Cursor -> Either ShikumiError (Text, Bool, Cursor) +tag closing cur@(Cursor pos rest) = + let prefix = if closing then " isAlphaNum c || c `elem` ['_', '-', '.']) (T.drop (T.length prefix) rest) + spaces = T.takeWhile xmlSpace suffix + end = T.dropWhile xmlSpace suffix + finish token self = Right (name, self, advance (prefix <> name <> spaces <> token) cur) + in case T.uncons name of + Just (c, _) + | isAlpha c || c == '_' -> + if ">" `T.isPrefixOf` end + then finish ">" False + else + if not closing && "/>" `T.isPrefixOf` end + then finish "/>" True + else failure pos "attributes, namespaces, or malformed tag are unsupported" + _ -> failure pos "invalid element name" + +entities :: Int -> Text -> Either ShikumiError Text +entities = go [] + where + go acc pos raw = + let (plain, suffix) = T.breakOn "&" raw + at = pos + T.length plain + in if T.null suffix + then Right (T.concat (reverse (plain : acc))) + else + let (ref, end) = T.breakOn ";" (T.drop 1 suffix) + in if T.null end + then failure at "unterminated entity" + else do + value <- case ref of + "amp" -> Right "&" + "lt" -> Right "<" + "gt" -> Right ">" + "quot" -> Right "\"" + "apos" -> Right "'" + _ + | Just digits <- T.stripPrefix "#x" ref -> numeric at 16 digits + | Just digits <- T.stripPrefix "#" ref -> numeric at 10 digits + | otherwise -> failure at "unknown entity" + go (value : plain : acc) (at + T.length ref + 2) (T.drop 1 end) + numeric pos base digits = + let digit c + | c >= '0' && c <= '9' = ord c - ord '0' + | c >= 'a' && c <= 'f' = 10 + ord c - ord 'a' + | c >= 'A' && c <= 'F' = 10 + ord c - ord 'A' + | otherwise = base + step n c = if n > 0x10FFFF || digit c >= base then 0x110000 else n * base + digit c + value = T.foldl' step 0 digits + in if T.null digits || value > 0x10FFFF || not (validChar (chr value)) + then failure pos "invalid Unicode character reference" + else Right (T.singleton (chr value)) + +property :: Key.Key -> Value -> Value +property key (Object obj) = maybe Null id (KM.lookup key obj) +property _ _ = Null + +properties :: Value -> Object +properties schema = case property "properties" schema of Object p -> p; _ -> KM.empty + +nonNull :: Value -> Value +nonNull schema = case property "anyOf" schema of + Array alts -> case V.toList alts of + [a, b] + | property "type" a == String "null" -> nonNull b + | property "type" b == String "null" -> nonNull a + _ -> schema + _ -> schema + +nullable :: Value -> Bool +nullable schema = + property "type" schema == String "null" || case property "anyOf" schema of + Array alts -> any nullable alts + _ -> False + +jsonText :: Text -> Value +jsonText raw = either (const (String raw)) id (eitherDecodeStrict (encodeUtf8 raw)) + +-- | Parse the entire fragment before selecting known top-level properties. +decodeXmlFields :: Value -> Text -> Either ShikumiError Value +decodeXmlFields schema body + | T.length body > 1048576 = failure 0 "input length limit 1048576 exceeded" + | Just pos <- T.findIndex (not . validChar) body = failure pos "invalid XML character" + | otherwise = do + (nodes, _) <- fragment 0 Nothing (Cursor 0 body) + objectFields schema nodes + +objectFields :: Value -> [Node] -> Either ShikumiError Value +objectFields schema nodes = Object . KM.fromList <$> traverse convert selected + where + present = KM.fromListWith (\_ first -> first) [(Key.fromText name, node) | node@(Element _ name _) <- nodes] + selected = [(key, s, node) | (key, s) <- KM.toList (properties schema), Just node <- [KM.lookup key present]] + convert (key, s, node) = (key,) <$> elementValue s node + +elementValue :: Value -> Node -> Either ShikumiError Value +elementValue schema (Element pos _ nodes) + | null children && nullable schema && raw == "null" && not cdata = Right Null + | null children = Right $ case kind of + String "string" -> String raw + String "object" | T.null raw -> Object KM.empty + String "array" | T.null raw -> Array V.empty + _ -> jsonText raw + | not (T.null raw) = failure pos "non-whitespace text mixed with child elements" + | kind == String "object" = objectFields inner children + | kind == String "array" = do + values <- traverse item children + Right (Array (V.fromList values)) + | otherwise = failure pos "scalar field contains child elements" + where + inner = nonNull schema + kind = property "type" inner + children = [node | node@Element {} <- nodes] + raw = T.strip (T.concat [t | Content _ t <- nodes]) + cdata = or [flag | Content flag _ <- nodes] + item node@(Element p name _) + | name == "item" = elementValue (property "items" inner) node + | otherwise = failure p "array children must be item elements" + item _ = failure pos "invalid array content" +elementValue _ _ = failure 0 "expected element" + +escape :: Text -> Text +escape = T.replace ">" ">" . T.replace "<" "<" . T.replace "&" "&" + +json :: Value -> Text +json = decodeUtf8 . LBS.toStrict . encode + +wrap :: Text -> Text -> Text +wrap name body = "<" <> name <> ">" <> body <> " name <> ">" + +-- | Signature order at the root, lexical property order within records. +renderXmlFields :: [Text] -> Value -> Value -> Text +renderXmlFields names schema value = T.unlines [renderElement name (property (Key.fromText name) (Object (properties schema))) v | name <- names, Just v <- [lookupValue name value]] + where + lookupValue name (Object obj) = KM.lookup (Key.fromText name) obj + lookupValue _ _ = Nothing + +renderElement :: Text -> Value -> Value -> Text +renderElement name schema value = wrap name body + where + inner = nonNull schema + body = case (property "type" inner, value) of + (_, Null) -> "null" + (String "object", Object obj) -> T.concat [renderElement (Key.toText k) (property k (Object (properties inner))) v | (k, v) <- sortOn fst (KM.toList obj)] + (String "array", Array values) -> T.concat [renderElement "item" (property "items" inner) v | v <- V.toList values] + (String "string", String t) + | nullable schema && T.strip t == "null" -> " T.replace "]]>" "]]]]>" t <> "]]>" + | otherwise -> escape t + _ -> escape (json value) + +-- | Guide for generated record/array/scalar/nullable schemas. Other hand-written +-- schema forms use escaped JSON values and are checked by the typed decoder. +xmlSchemaGuide :: [Text] -> Value -> Text +xmlSchemaGuide names schema = + "Reply with these XML fields (no attributes or namespaces). Escape &, < and > in text.\n" + <> "Arrays use repeated elements; empty containers may self-close. Nullable fields may be omitted or contain null; use for a nullable literal string.\n" + <> T.unlines [guide name (property (Key.fromText name) (Object (properties schema))) | name <- names] + where + guide name s = wrap name $ case property "type" (nonNull s) of + String "object" -> T.concat [guide (Key.toText k) v | (k, v) <- sortOn fst (KM.toList (properties (nonNull s)))] + String "array" -> guide "item" (property "items" (nonNull s)) <> guide "item" (property "items" (nonNull s)) + String t -> "[" <> t <> "]" + _ -> "[escaped JSON value]" diff --git a/src/Shikumi/Error.hs b/src/Shikumi/Error.hs --- a/src/Shikumi/Error.hs +++ b/src/Shikumi/Error.hs @@ -8,10 +8,11 @@ ( ShikumiError (..), fromBaikaiError, isTransient, + renderShikumiError, ) where -import Baikai.Error (BaikaiError (..), ErrorCategory (..)) +import Baikai.Error (BaikaiError (..), ErrorCategory (..), isRetryable) import Data.Text (Text) import Data.Text qualified as T @@ -28,13 +29,15 @@ SchemaMismatch !Text | -- | a typed value failed a user/program validation rule ValidationFailure !Text - | -- | the provider/transport failed (mapped from baikai) + | -- | Legacy unclassified failure supplied by callers or scripted interpreters. ProviderFailure !Text + | -- | Structured transport failure, including verbatim refusal metadata. + ProviderError !BaikaiError | -- | the prompt exceeded the model's context window ContextWindowExceeded !Text | -- | the call exceeded its time budget Timeout !Text - | -- | the running cost ceiling was reached; the call was refused + | -- | a configured resource allowance was exhausted (cost, calls or session size) BudgetExceeded !Text | -- | generated code failed after exhausting correction attempts CodeExecFailed !Text @@ -50,20 +53,34 @@ DecodeFailure -> InvalidJSON (message e) InvalidRequest -> SchemaMismatch ("invalid request: " <> message e) ContextOverflow -> ContextWindowExceeded (message e) - ProcessFailure -> - ProviderFailure $ - case exitCode e of - Just n -> "process exited " <> T.pack (show n) <> ": " <> message e - Nothing -> message e - _ -> ProviderFailure (message e) + _ -> ProviderError e --- | Which errors are worth retrying. Provider/transport failures and timeouts are --- transient; decode, schema, validation, budget, and code-execution failures are --- deterministic and retrying cannot fix them. Centralizing the policy here keeps --- it auditable (the resilience interpreter in "Shikumi.LLM" consults exactly this --- predicate). +-- | Human-readable detail without dumping the transport record. Baikai's +-- message is its safe-to-log description; opaque request/response data is absent. +renderShikumiError :: ShikumiError -> Text +renderShikumiError = \case + ProviderError e -> + "provider " + <> T.pack (show (category e)) + <> maybe "" (\n -> " (exit " <> T.pack (show n) <> ")") (exitCode e) + <> ": " + <> message e + InvalidJSON t -> t + MissingField t -> "missing field " <> t + SchemaMismatch t -> t + ValidationFailure t -> t + ProviderFailure t -> t + ContextWindowExceeded t -> t + Timeout t -> t + BudgetExceeded t -> t + CodeExecFailed t -> t + +-- | Retry only typed rate limits and transient failures, using Baikai's +-- classification. Legacy text failures and timeouts retain their retry policy. +-- Unknown/process errors and refusals are terminal; never infer from prose. isTransient :: ShikumiError -> Bool isTransient = \case + ProviderError e -> isRetryable e ProviderFailure {} -> True Timeout {} -> True _ -> False diff --git a/src/Shikumi/LLM.hs b/src/Shikumi/LLM.hs --- a/src/Shikumi/LLM.hs +++ b/src/Shikumi/LLM.hs @@ -7,7 +7,7 @@ -- -- The effect exposes two operations ('Complete', 'Stream'). The bare interpreters -- 'runLLM' / 'runLLMWith' map baikai's 'BaikaiError' into 'ShikumiError' and do --- nothing else. The resilient interpreter 'runLLMResilient' adds the production +-- validate continuation compatibility before transport. The resilient interpreter 'runLLMResilient' adds the production -- features baikai deliberately omits: retries with exponential backoff, an -- in-flight rate limit, and a US-dollar budget ceiling. -- @@ -26,6 +26,7 @@ -- * Bare interpreters runLLM, runLLMWith, + runLLMWithObserver, -- * Resilience RetryPolicy (..), @@ -59,6 +60,7 @@ import Baikai.Effectful qualified as BE import Baikai.Error (BaikaiError) import Baikai.Provider.Registry (ProviderRegistry) +import Baikai.Usage qualified as U import Control.Concurrent.STM ( TVar, modifyTVar', @@ -71,6 +73,8 @@ import Data.Generics.Labels () import Data.Maybe (fromMaybe, mapMaybe) import Data.Text qualified as T +import Data.Time.Clock (getCurrentTime) +import Data.Unique (hashUnique, newUnique) import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, IOE, liftIO, (:>)) import Effectful.Concurrent (Concurrent, threadDelay) import Effectful.Concurrent.STM (atomically) @@ -79,6 +83,8 @@ import Effectful.Exception (bracket_, try) import Shikumi.Error (ShikumiError (..), fromBaikaiError, isTransient) import Shikumi.LLM.Budget (Budget, admitCall, recordCost) +import Shikumi.LLM.Continuation +import Shikumi.LLM.Observation qualified as O -- | The provider-neutral LM effect. 'Complete' is a blocking completion; -- 'Stream' returns the assembled list of typed events so callers that need @@ -116,7 +122,7 @@ (IOE :> es, Error ShikumiError :> es) => Eff (LLM : es) a -> Eff es a -runLLM = reinterpret_ runBaikai bareHandler +runLLM = reinterpret_ runBaikai (bareHandler O.noObservation) -- | Bare interpreter over an explicit registry. runLLMWith :: @@ -124,8 +130,12 @@ ProviderRegistry -> Eff (LLM : es) a -> Eff es a -runLLMWith reg = reinterpret_ (runBaikaiWith reg) bareHandler +runLLMWith reg = runLLMWithObserver reg O.noObservation +-- | Observe bare transport calls. Callback exceptions propagate without retries. +runLLMWithObserver :: (IOE :> es, Error ShikumiError :> es) => ProviderRegistry -> O.LLMObserver -> Eff (LLM : es) a -> Eff es a +runLLMWithObserver reg observer = reinterpret_ (runBaikaiWith reg) (bareHandler observer) + -- | The bare handler, shared by both interpreters. It runs in the handler stack -- (@Baikai : es@), so it can call the @Baikai@ transport effect and throw -- through the @Error ShikumiError@ effect. The blocking path routes baikai's @@ -136,15 +146,77 @@ -- 'stream' never receive an in-band error terminal and resilience/decoding treat -- both operations identically. bareHandler :: - (Baikai :> es, Error ShikumiError :> es) => - LLM (Eff localEs) a -> - Eff es a -bareHandler = \case + (IOE :> es, Baikai :> es, Error ShikumiError :> es) => + O.LLMObserver -> LLM (Eff localEs) a -> Eff es a +bareHandler observer op = do + cid <- liftIO freshCallId + transportAttempt observer Nothing cid 1 op + +freshCallId :: IO T.Text +freshCallId = (T.pack . ("call-" <>) . show . hashUnique) <$> newUnique + +-- The callback sits outside the typed transport try; its exceptions cannot +-- become retryable provider errors, even if the callback throws BaikaiError. +transportAttempt :: + (IOE :> es, Baikai :> es, Error ShikumiError :> es) => + O.LLMObserver -> Maybe Budget -> T.Text -> Int -> LLM (Eff localEs) a -> Eff es a +transportAttempt observer mb cid ordinal op = case op of Complete m c o -> do - res <- try @BaikaiError (BE.complete m c o) - either (throwError . fromBaikaiError) raiseResponseError res - Stream m c o -> BE.streamCollect m c o >>= raiseStreamError + either throwError pure (validateRequestContinuation m c o) + start <- liftIO getCurrentTime + res <- try @BaikaiError (BE.complete m c (stripContinuationMetadata o)) + case res of + Left be -> do + emit m O.CompletionCall start (Just (fromBaikaiError be)) Nothing Nothing + throwError (fromBaikaiError be) + Right resp -> do + liftIO (chargeBudget mb resp) + emit + m + O.CompletionCall + start + (fromBaikaiError <$> responseError resp) + (availableUsage (resp ^. #message . #usage)) + (O.observedModelOf (resp ^. #evidence)) + raiseResponseError resp + Stream m c o -> do + either throwError pure (validateRequestContinuation m c o) + start <- liftIO getCurrentTime + res <- try @BaikaiError (BE.streamCollect m c (stripContinuationMetadata o)) + case res of + Left be -> do + emit m O.StreamCall start (Just (fromBaikaiError be)) Nothing Nothing + throwError (fromBaikaiError be) + Right evs -> do + liftIO (chargeBudgetFromEvents mb evs) + let terminals = [tp | ev <- evs, tp <- case ev of EventDone t -> [t]; EventError t -> [t]; _ -> []] + terminal = case terminals of t : _ -> Just t; [] -> Nothing + usage = terminal >>= \t -> case t ^. #message of AssistantMessage p -> availableUsage (p ^. #usage); _ -> Nothing + err = case [streamTerminalError t | EventError t <- evs] of e : _ -> Just e; [] -> Nothing + emit m O.StreamCall start err usage (terminal >>= O.observedModelOf . (^. #evidence)) + raiseStreamError evs + where + emit m kind start err usage observed = liftIO $ do + end <- getCurrentTime + observer + ( O.LLMObservation + cid + ordinal + kind + (m ^. #modelId) + (m ^. #provider) + observed + (O.errorClass <$> err) + (O.UsageRecord <$> usage) + start + end + ) +-- Baikai represents thrown transport errors with the additive zero. It carries +-- no observation; a reported zero has availability/basis and is retained. +availableUsage :: U.Usage -> Maybe U.Usage +availableUsage u = if u == U.zeroUsage then Nothing else Just u + -- --------------------------------------------------------------------------- -- Resilience: retries, rate limiting, budget -- --------------------------------------------------------------------------- @@ -182,7 +254,9 @@ -- | 'Nothing' = unbounded concurrency rateLimit :: !(Maybe RateLimiter), -- | which baikai registry to dispatch against - registry :: !ProviderRegistry + registry :: !ProviderRegistry, + -- | Optional per-attempt accounting; never charges budgets itself. + observer :: !(Maybe O.LLMObserver) } -- | A config with default retries, no budget, and no rate limit, dispatching @@ -193,40 +267,23 @@ { retryPolicy = defaultRetryPolicy, budget = Nothing, rateLimit = Nothing, - registry = reg + registry = reg, + observer = Nothing } -- | The resilient interpreter. Each operation is wrapped, outermost to -- innermost, by: budget check → rate-limit acquire → retry loop → the @Baikai@ --- transport call. The budget is reserved once before the attempts and charged --- once after success; retries re-run only the transport call. +-- transport call. Budget admission happens once before the attempts; each +-- response or stream terminal is charged before success or failure is raised. runLLMResilient :: (IOE :> es, Concurrent :> es, Error ShikumiError :> es) => LLMConfig -> Eff (LLM : es) a -> Eff es a -runLLMResilient cfg = reinterpret_ (runBaikaiWith (registry cfg)) $ \case - Complete m c o -> - withBudget mb . withRateLimit mr . retrying rp $ do - res <- try @BaikaiError (BE.complete m c o) - case res of - Left be -> throwError (fromBaikaiError be) - Right resp -> do - -- Charge before raising: an error-shaped 'Response' may still carry - -- billable usage (mirrors 'chargeBudgetFromEvents' on the stream path). - liftIO (chargeBudget mb resp) - raiseResponseError resp - Stream m c o -> - withBudget mb . withRateLimit mr . retrying rp $ do - evs <- BE.streamCollect m c o - -- Charge from the terminal payload (success /or/ error) before raising: a - -- failed stream may still have consumed billable tokens. - liftIO (chargeBudgetFromEvents mb evs) - raiseStreamError evs - where - mb = budget cfg - mr = rateLimit cfg - rp = retryPolicy cfg +runLLMResilient cfg = reinterpret_ (runBaikaiWith (registry cfg)) $ \op -> do + cid <- liftIO freshCallId + withBudget (budget cfg) . withRateLimit (rateLimit cfg) $ + retrying (retryPolicy cfg) (\ordinal -> transportAttempt (fromMaybe O.noObservation (observer cfg)) (budget cfg) cid ordinal op) -- | Optimistic pre-call budget gate (admission, not reservation). Refuses the -- call with 'BudgetExceeded' when the recorded running total has already reached @@ -264,12 +321,12 @@ retrying :: (Concurrent :> es, Error ShikumiError :> es) => RetryPolicy -> - Eff es a -> + (Int -> Eff es a) -> Eff es a retrying pol act = go 1 where go attempt = - act `catchError` \_cs e -> + act attempt `catchError` \_cs e -> if isTransient e && attempt < maxAttempts pol then do threadDelay (backoffMicros pol attempt) @@ -292,18 +349,9 @@ responseCostUSD :: Response -> Rational responseCostUSD resp = resp ^. #message . #usage . #cost . #usd --- | Enforce the stream-error posture: a terminal 'EventError' becomes an --- out-of-band 'ShikumiError' — a 'ProviderFailure' carrying the terminal message's --- @errorMessage@ (or the stop reason if none). A successful event list passes --- through unchanged, so callers of 'stream' never see an in-band error terminal. --- Because both interpreters call this /inside/ their retry loop, a transient stream --- failure is retried exactly like a blocking one ('ProviderFailure' is transient --- per 'isTransient'). --- --- The baikai version shikumi pins does not attach a structured 'BaikaiError' to a --- terminal payload (its @TerminalPayload@ is @{reason, message}@; the failure detail --- lives in the assembled message's @errorMessage@ and @stopReason@), so all stream --- failures map to 'ProviderFailure' rather than through 'fromBaikaiError'. +-- | Raise structured terminal failures through the same mapping as blocking +-- calls. Only malformed third-party terminals without errorInfo use the legacy +-- text fallback. Successful event lists pass through unchanged. raiseStreamError :: (Error ShikumiError :> es) => [AssistantMessageEvent] -> Eff es [AssistantMessageEvent] raiseStreamError evs = case [tp | EventError tp <- evs] of @@ -316,7 +364,7 @@ -- 'responseError' is populated. Convert that in-band failure into the same -- out-of-band 'ShikumiError' the rest of shikumi consumes, so an error response -- never masquerades as success and 'runLLMResilient' still retries transient --- failures (a 'ProviderFailure' thrown /inside/ the retry loop). A success +-- failures (a classified error thrown /inside/ the retry loop). A success -- passes through unchanged. raiseResponseError :: (Error ShikumiError :> es) => Response -> Eff es Response @@ -326,7 +374,9 @@ -- | Map a terminal 'EventError' payload to a 'ShikumiError'. streamTerminalError :: TerminalPayload -> ShikumiError -streamTerminalError tp = ProviderFailure ("stream failed: " <> detail) +streamTerminalError tp = case tp ^. #errorInfo of + Just err -> fromBaikaiError err + Nothing -> ProviderFailure ("stream failed: " <> detail) where detail = case tp ^. #message of AssistantMessage p -> fromMaybe (T.pack (show (tp ^. #reason))) (p ^. #errorMessage) diff --git a/src/Shikumi/LLM/Continuation.hs b/src/Shikumi/LLM/Continuation.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/LLM/Continuation.hs @@ -0,0 +1,115 @@ +-- | Pure continuation checks shared by routing, memoization and transport. +-- Request identity is not provider attestation. No credentials are persisted. +module Shikumi.LLM.Continuation + ( RequestOrigin, + requestOrigin, + originModel, + opaqueThinking, + hasOpaqueContinuation, + contextIdentity, + stampContinuation, + validateRequestContinuation, + stripContinuationMetadata, + validateReplayOrigin, + ) +where + +import Baikai qualified as B +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (unless) +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (parseEither) +import Data.Generics.Labels () +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import GHC.Generics (Generic) +import Shikumi.Error (ShikumiError (ValidationFailure)) + +data RequestOrigin = RequestOrigin + { provider :: !Text, + api :: !B.Api, + model :: !Text, + endpoint :: !Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | Endpoints containing query strings or userinfo may contain credentials. +-- Refuse to persist them; callers can restart with a credential-free endpoint. +requestOrigin :: B.Model -> Maybe RequestOrigin +requestOrigin m + | any T.null [m ^. #provider, m ^. #modelId, m ^. #baseUrl] = Nothing + | m ^. #api == B.Custom "" = Nothing + | T.any (`elem` ("?@#" :: String)) (m ^. #baseUrl) = Nothing + | otherwise = Just (RequestOrigin (m ^. #provider) (m ^. #api) (m ^. #modelId) (m ^. #baseUrl)) + +-- | Minimal explicit request identity. Credentials and compatibility settings +-- must be supplied by the caller's runtime/router, never by a checkpoint. +originModel :: RequestOrigin -> B.Model +originModel (RequestOrigin p a m e) = B.mkModel a m e & #provider .~ p + +opaqueThinking :: B.ThinkingContent -> Bool +opaqueThinking t = isJust (t ^. #signature) || t ^. #redacted || isJust (t ^. #replayState) + +hasOpaqueContinuation :: [B.Message] -> Bool +hasOpaqueContinuation = any (\case B.AssistantMessage p -> any block (p ^. #content); _ -> False) + where + block (B.AssistantThinking t) = opaqueThinking t + block _ = False + +-- | Exact ordered request projection; only message construction timestamps go. +contextIdentity :: B.Context -> Value +contextIdentity c = object ["system" .= (c ^. #systemPrompt), "tools" .= (c ^. #tools), "messages" .= map messageIdentity (V.toList (c ^. #messages))] + where + messageIdentity m = case toJSON m of + Object fields -> Object (case KM.lookup "contents" fields of Just v -> KM.insert "contents" (dropTimestamp v) fields; Nothing -> fields) + v -> v + dropTimestamp (Object fields) = Object (KM.delete "timestamp" fields) + dropTimestamp v = v + +continuationKey :: Text +continuationKey = "shikumi.continuation.v1" + +stampContinuation :: Maybe RequestOrigin -> Maybe Value -> B.Options -> B.Options +stampContinuation origin prefix o = o & #metadata .~ Map.insert continuationKey (object ["origin" .= origin, "prefix" .= prefix]) (o ^. #metadata) + +stripContinuationMetadata :: B.Options -> B.Options +stripContinuationMetadata o = o & #metadata .~ Map.delete continuationKey (o ^. #metadata) + +failure :: Text -> Either ShikumiError a +failure t = Left (ValidationFailure ("ReAct continuation: " <> t <> "; explicitly restart from a caller-approved summary")) + +-- | Also check returned Responses replay before tools can execute. Aliases are +-- compared to replay scope, never to optional observed-provider model evidence. +validateReplayOrigin :: B.Model -> [B.Message] -> Either ShikumiError () +validateReplayOrigin m msgs = mapM_ check [r | B.AssistantMessage p <- msgs, B.AssistantThinking t <- V.toList (p ^. #content), Just r <- [t ^. #replayState]] + where + check r = unless (r ^. #replayApi == m ^. #api && r ^. #replayModel == m ^. #modelId) (failure "replay API/model differs from resolved request") + +validateRequestContinuation :: B.Model -> B.Context -> B.Options -> Either ShikumiError () +validateRequestContinuation m c o = do + let opaque = hasOpaqueContinuation (V.toList (c ^. #messages)) + case Map.lookup continuationKey (o ^. #metadata) of + Nothing -> unless (not opaque) (failure "opaque history has no origin expectation") + Just value -> case parseEither (withObject "continuation" (\v -> (,) <$> v .: "origin" <*> v .: "prefix")) value of + Left _ -> failure "malformed expectation" + Right (origin, prefix) -> do + case origin of + Just expected -> unless (requestOrigin m == Just expected) (failure "provider/API/model/endpoint changed or unresolved") + Nothing -> unless (not opaque) (failure "opaque history has unknown request origin") + case prefix of + Nothing -> unless (not opaque) (failure "opaque history has no protected prefix") + Just protected -> unless (prefixMatches protected (contextIdentity c)) (failure "protected system/tools/message prefix changed") + validateReplayOrigin m (V.toList (c ^. #messages)) + where + prefixMatches (Object old) (Object new) = + KM.lookup "system" old == KM.lookup "system" new + && KM.lookup "tools" old == KM.lookup "tools" new + && case (KM.lookup "messages" old, KM.lookup "messages" new) of + (Just (Array before), Just (Array after)) -> V.length before <= V.length after && before == V.take (V.length before) after + _ -> False + prefixMatches _ _ = False diff --git a/src/Shikumi/LLM/Defaults.hs b/src/Shikumi/LLM/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/LLM/Defaults.hs @@ -0,0 +1,65 @@ +-- | Invocation-scoped, fill-only defaults for every LLM operation. +-- Compose the base interpreter with cache/trace, then 'withRequestDefaults', +-- then routing. The rightmost wrapper sees the originating call first. +module Shikumi.LLM.Defaults + ( RequestDefaults (..), + emptyRequestDefaults, + applyRequestDefaults, + withRequestDefaults, + ) +where + +import Baikai (Options) +import Baikai.Evidence (EvidenceRequest) +import Baikai.Speed (Speed) +import Baikai.ThinkingLevel (ThinkingLevel) +import Control.Applicative ((<|>)) +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (when) +import Data.Generics.Labels () +import Effectful (Eff, (:>)) +import Effectful.Dispatch.Dynamic (interpose) +import Effectful.Error.Static (Error, throwError) +import Numeric.Natural (Natural) +import Shikumi.Error (ShikumiError (ValidationFailure)) +import Shikumi.LLM (LLM (..), complete, stream) + +-- | Only request preferences belong here. Models, schemas, tools, credentials, +-- temperatures and private continuation metadata remain owned by their callers. +-- Evidence is replaced as a whole; requested settings are not provider evidence. +data RequestDefaults = RequestDefaults + { defaultThinking :: !(Maybe ThinkingLevel), + defaultSpeed :: !(Maybe Speed), + defaultMaxTokens :: !(Maybe Natural), + defaultEvidence :: !(Maybe EvidenceRequest) + } + deriving stock (Eq, Show) + +-- | No implicit reasoning, fast mode, token ceiling or evidence collection. +emptyRequestDefaults :: RequestDefaults +emptyRequestDefaults = RequestDefaults Nothing Nothing Nothing Nothing + +-- | Fill absent options only. This pure merge does not validate token ceilings; +-- use 'withRequestDefaults' to reject a zero configured default before execution. +applyRequestDefaults :: RequestDefaults -> Options -> Options +applyRequestDefaults defaults opts = + opts + & #thinking .~ (opts ^. #thinking <|> defaultThinking defaults) + & #speed .~ (opts ^. #speed <|> defaultSpeed defaults) + & #maxTokens .~ (opts ^. #maxTokens <|> defaultMaxTokens defaults) + & #evidence .~ (opts ^. #evidence <|> defaultEvidence defaults) + +-- | Apply the same merge to blocking and streaming calls. Per-call values win; +-- the innermost default scope fills first and therefore wins over outer scopes. +-- A zero default ceiling is invalid even when a call supplies its own ceiling. +-- No mutable state is shared between invocations. +withRequestDefaults :: (LLM :> es, Error ShikumiError :> es) => RequestDefaults -> Eff es a -> Eff es a +withRequestDefaults defaults action = do + when (defaultMaxTokens defaults == Just 0) $ + throwError (ValidationFailure "request defaults: defaultMaxTokens must be positive") + interpose + ( \_ -> \case + Complete model ctx opts -> complete model ctx (applyRequestDefaults defaults opts) + Stream model ctx opts -> stream model ctx (applyRequestDefaults defaults opts) + ) + action diff --git a/src/Shikumi/LLM/Observation.hs b/src/Shikumi/LLM/Observation.hs new file mode 100644 --- /dev/null +++ b/src/Shikumi/LLM/Observation.hs @@ -0,0 +1,180 @@ +-- | Run-local transport billing. Observations contain identity and accounting, +-- never prompts, outputs, credentials, or provider error messages. Observer IO +-- exceptions propagate outside provider retry classification. Cancellation emits +-- no synthetic terminal. Create a separate collector for each run. +module Shikumi.LLM.Observation + ( LLMObservation (..), + CallKind (..), + LLMObserver, + noObservation, + BillingSummary (..), + emptyBillingSummary, + newBillingCollector, + newBillingCollectorWithLimit, + renderBillingSummary, + usageUnknown, + observedModelOf, + errorClass, + UsageRecord (..), + ) +where + +import Baikai.Cost qualified as C +import Baikai.Error qualified as BE +import Baikai.Evidence qualified as E +import Baikai.Usage qualified as U +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString.Lazy qualified as BL +import Data.IORef +import Data.Maybe (isNothing) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Shikumi.Error (ShikumiError (..)) + +-- | A local wrapper avoids adding competing orphan decoders. The exact rational +-- cost is encoded separately from the canonical provider usage JSON. +newtype UsageRecord = UsageRecord {getUsage :: U.Usage} + deriving stock (Eq, Show) + +instance ToJSON UsageRecord where + toJSON (UsageRecord u) = object ["usage" .= u, "exactCost" .= exactCost (U.cost u)] + where + exactCost c = let b = C.breakdown c in [C.usd c, C.inputUsd b, C.outputUsd b, C.cachedInputUsd b, C.cachedWriteUsd b] + +instance FromJSON UsageRecord where + parseJSON = withObject "UsageRecord" $ \o -> do + v <- o .: "usage" + ns <- o .: "exactCost" :: Parser [Rational] + c <- case ns of + [a, b, c, d, e] -> pure (C.Cost a (C.CostBreakdown b c d e) mempty) + _ -> fail "exactCost must contain five rational amounts" + withObject + "Usage" + ( \u -> do + cv <- u .: "cost" + basis <- withObject "Cost" (\x -> x .:? "basis" .!= mempty) cv + UsageRecord + <$> ( U.Usage + <$> u .: "input_tokens" + <*> u .: "output_tokens" + <*> u .: "cache_read_tokens" + <*> u .: "cache_write_tokens" + <*> u .:? "reasoning_tokens" + <*> u .: "total_tokens" + <*> u .:? "availability" + <*> pure c {C.basis = basis} + ) + ) + v + +data CallKind = CompletionCall | StreamCall + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +-- | callId identifies a logical invocation within this process; attempt is +-- one-based within it. No structural node attribution is implied. +data LLMObservation = LLMObservation + { callId :: !Text, + attempt :: !Int, + callKind :: !CallKind, + requestedModel :: !Text, + requestedProvider :: !Text, + observedModel :: !(Maybe Text), + terminalError :: !(Maybe Text), + usage :: !(Maybe UsageRecord), + startedAt :: !UTCTime, + endedAt :: !UTCTime + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +type LLMObserver = LLMObservation -> IO () + +noObservation :: LLMObserver +noObservation _ = pure () + +observedModelOf :: Maybe E.ModelCallEvidence -> Maybe Text +observedModelOf e = e >>= E.observedValue . E.observedModel + +-- | Stable classification only: raw messages can include provider output. +errorClass :: ShikumiError -> Text +errorClass = \case + ProviderError e -> T.pack (show (BE.category e)) + ProviderFailure _ -> "ProviderFailure" + InvalidJSON _ -> "InvalidJSON" + MissingField _ -> "MissingField" + SchemaMismatch _ -> "SchemaMismatch" + ValidationFailure _ -> "ValidationFailure" + ContextWindowExceeded _ -> "ContextWindowExceeded" + Timeout _ -> "Timeout" + BudgetExceeded _ -> "BudgetExceeded" + CodeExecFailed _ -> "CodeExecFailed" + +-- | Unknown includes absent/legacy quality metadata and partially missing or +-- inconsistent counters. Available numeric components still contribute to sums. +usageUnknown :: Maybe UsageRecord -> Bool +usageUnknown Nothing = True +usageUnknown (Just (UsageRecord u)) = case U.availability u of + Nothing -> True + Just a -> not (Set.null (U.missingCategories a)) || U.inconsistent a + +data BillingSummary = BillingSummary + { completedAttempts :: !Int, + failedAttempts :: !Int, + unknownUsageAttempts :: !Int, + observedUsage :: !UsageRecord, + retainedAttempts :: ![LLMObservation], + detailTruncated :: !Bool + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +emptyBillingSummary :: BillingSummary +emptyBillingSummary = BillingSummary 0 0 0 (UsageRecord mempty) [] False + +-- | Aggregate only by default. Opt in to bounded detail with the other constructor. +newBillingCollector :: IO (LLMObserver, IO BillingSummary) +newBillingCollector = newBillingCollectorWithLimit 0 + +-- | Negative limits are treated as zero. Counts and sums continue after the +-- detail limit, using an atomic strict update safe for concurrent evaluations. +newBillingCollectorWithLimit :: Int -> IO (LLMObserver, IO BillingSummary) +newBillingCollectorWithLimit limit = do + ref <- newIORef emptyBillingSummary + let observe o = atomicModifyIORef' ref $ \s -> + let n = completedAttempts s + failedAttempts s + ok = isNothing (terminalError o) + u = maybe mempty getUsage (usage o) + totalUsage = getUsage (observedUsage s) <> u + next = + BillingSummary + (completedAttempts s + if ok then 1 else 0) + (failedAttempts s + if ok then 0 else 1) + (unknownUsageAttempts s + if usageUnknown (usage o) then 1 else 0) + (UsageRecord totalUsage) + (if n < max 0 limit then o : retainedAttempts s else retainedAttempts s) + (detailTruncated s || n >= max 0 limit) + in next `seq` (next, ()) + pure (observe, (\s -> s {retainedAttempts = reverse (retainedAttempts s)}) <$> readIORef ref) + +renderBillingSummary :: BillingSummary -> Text +renderBillingSummary s = + "transport billing: completed=" + <> t (completedAttempts s) + <> " failed=" + <> t (failedAttempts s) + <> " unknown-usage=" + <> t (unknownUsageAttempts s) + <> " observed-usd=" + <> t (C.usd (U.cost (getUsage (observedUsage s)))) + <> " detail-truncated=" + <> t (detailTruncated s) + <> "\ntransport quality: " + <> TE.decodeUtf8 (BL.toStrict (encode (observedUsage s))) + where + t :: (Show a) => a -> Text; t = T.pack . show diff --git a/src/Shikumi/Module.hs b/src/Shikumi/Module.hs --- a/src/Shikumi/Module.hs +++ b/src/Shikumi/Module.hs @@ -21,6 +21,7 @@ -- lives here. See the plan's Decision Log. module Shikumi.Module ( predict, + predictCaptured, chainOfThought, chainOfThoughtRaw, twoStep, @@ -30,7 +31,7 @@ import Baikai (emptyContext, emptyModel, emptyOptions, user) import Control.Lens ((&), (.~)) -import Data.Aeson (Object, Value (Object)) +import Data.Aeson (Object, ToJSON (..), Value (Object)) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KM import Data.Generics.Labels () @@ -43,8 +44,8 @@ import Shikumi.Adapter (Adapter (..), ToPrompt (..), fallbackAdapter, responseText) import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (complete) -import Shikumi.Program (Program (FMap, Predict), embed, emptyParams) -import Shikumi.Schema (FromModel (..), ToSchema (..), Validatable (..)) +import Shikumi.Program (CaptureCodec (..), Program (FMap, Predict, PredictCaptured), embed, emptyParams) +import Shikumi.Schema (FromModel (..), ToSchema (..), Validatable (..), deriveSchema) import Shikumi.Schema.Types ( FieldMeta (..), FieldPath, @@ -64,6 +65,22 @@ Signature i o -> Program i o predict sig = Predict sig emptyParams + +-- | Opt in to typed observation and node-local demonstration recovery. +predictCaptured :: + forall i o. + ( FromModel i, + FromModel o, + ToSchema i, + ToSchema o, + ToJSON i, + ToJSON o, + Validatable o, + ToPrompt i, + ToPrompt o + ) => + Signature i o -> Program i o +predictCaptured sig = PredictCaptured (CaptureCodec toJSON toJSON (deriveSchema @i) (deriveSchema @o)) sig emptyParams -- --------------------------------------------------------------------------- -- Chain of thought diff --git a/src/Shikumi/Program.hs b/src/Shikumi/Program.hs --- a/src/Shikumi/Program.hs +++ b/src/Shikumi/Program.hs @@ -31,6 +31,7 @@ ( -- * The representation Program ( Predict, + PredictCaptured, Compose, FMap, Map, @@ -42,6 +43,7 @@ Ensemble, Embed ), + CaptureCodec (..), Params (..), Demo (..), emptyParams, @@ -186,7 +188,19 @@ -- 'Predict' captures the adapter/decode dictionaries existentially so that -- 'runProgram' can recover them by pattern-matching — this is what lets a program -- be rewritten as data while staying type-checked. +-- | Explicit wire encoders and schema evidence. Functions stay in the template; +-- parameter artifacts never serialize them. +data CaptureCodec i o = CaptureCodec + { encodeCaptureInput :: i -> Value, + encodeCaptureOutput :: o -> Value, + captureInputSchema :: Value, + captureOutputSchema :: Value + } + data Program i o where + PredictCaptured :: + (FromModel i, FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) => + CaptureCodec i o -> Signature i o -> Params -> Program i o Predict :: (FromModel i, FromModel o, ToSchema o, Validatable o, ToPrompt i, ToPrompt o) => Signature i o -> @@ -271,6 +285,7 @@ i -> Eff es o runProgram (Predict sig ps) i = runPredict sig ps i +runProgram (PredictCaptured _ sig ps) i = runPredict sig ps i runProgram (Compose f g) i = runProgram f i >>= runProgram g runProgram (FMap k p) i = k <$> runProgram p i runProgram (Map _ p) xs = traverse (runProgram p) xs @@ -295,6 +310,7 @@ i -> Eff es o runProgramConc (Predict sig ps) i = runPredict sig ps i +runProgramConc (PredictCaptured _ sig ps) i = runPredict sig ps i runProgramConc (Compose f g) i = runProgramConc f i >>= runProgramConc g runProgramConc (FMap k p) i = k <$> runProgramConc p i runProgramConc (Map w p) xs = pooledMapConcurrentlyN (max 1 w) (runProgramConc p) xs @@ -477,6 +493,7 @@ -- @lens@ @Traversal'@ laws; use it directly with @toListOf@/@over@/@set@. paramsTraversal :: (Applicative f) => (Params -> f Params) -> Program i o -> f (Program i o) paramsTraversal h (Predict sig ps) = Predict sig <$> h ps +paramsTraversal h (PredictCaptured codec sig ps) = PredictCaptured codec sig <$> h ps paramsTraversal h (Compose f g) = Compose <$> paramsTraversal h f <*> paramsTraversal h g paramsTraversal h (FMap k p) = FMap k <$> paramsTraversal h p paramsTraversal h (Map w p) = Map w <$> paramsTraversal h p @@ -513,6 +530,7 @@ nodeFieldsIndexed = go where go :: forall x y. Program x y -> [NodeFields] + go (PredictCaptured _ sig ps) = go (Predict sig ps) go (Predict sig _) = [NodeFields (map fieldName (inputFields sig)) (map fieldName (outputFields sig))] go (Compose a b) = go a ++ go b @@ -538,6 +556,7 @@ where go :: forall x y. Program x y -> [Text] go (Predict sig _) = [getInstruction sig] + go (PredictCaptured _ sig _) = [getInstruction sig] go (Compose a b) = go a ++ go b go (FMap _ p) = go p go (Map _ p) = go p @@ -562,6 +581,7 @@ where go :: forall x y. Int -> Program x y -> (Program x y, Int) go idx (Predict sig ps) = (Predict sig (if idx == n then f ps else ps), idx + 1) + go idx (PredictCaptured codec sig ps) = (PredictCaptured codec sig (if idx == n then f ps else ps), idx + 1) go idx (Compose a b) = let (a', idx') = go idx a (b', idx'') = go idx' b @@ -647,6 +667,7 @@ -- changes (parameters do not affect shape). programShape :: Program i o -> ProgramShape programShape (Predict sig _) = ShapePredict (sigLabel sig) +programShape (PredictCaptured _ sig _) = ShapePredict (sigLabel sig) programShape (Compose a b) = ShapeCompose (programShape a) (programShape b) programShape (FMap _ p) = ShapeFMap (programShape p) programShape (Map w p) = ShapeMap w (programShape p) @@ -682,7 +703,9 @@ n = length (foldParams prog) go :: forall x y. [Params] -> Program x y -> (Program x y, [Params]) go (q : qs) (Predict sig _) = (Predict sig q, qs) + go (q : qs) (PredictCaptured codec sig _) = (PredictCaptured codec sig q, qs) go qs (Predict sig old) = (Predict sig old, qs) -- unreachable after the length guard + go qs (PredictCaptured codec sig old) = (PredictCaptured codec sig old, qs) -- unreachable after the length guard go qs (Compose a b) = let (a', qs') = go qs a (b', qs'') = go qs' b diff --git a/src/Shikumi/Routing.hs b/src/Shikumi/Routing.hs --- a/src/Shikumi/Routing.hs +++ b/src/Shikumi/Routing.hs @@ -20,7 +20,9 @@ -- @Options.responseFormat@ from the stamped schema and swaps the marker @Context@ -- (system prompt + demo assistant turns) for the stamped native-format alternative; -- sets @Options.temperature@ when stamped; and in all cases strips the private keys --- before forwarding the call to the real @LLM@ interpreter beneath it. +-- before forwarding the call to the real @LLM@ interpreter beneath it. Continuation +-- expectations survive routing and are validated here, then again before cache +-- lookup and final transport; only the transport boundary removes them. -- -- Install order (mirroring @runTrace . runKeyedLLM . tracedLLM@): 'runRouting' is -- /outer/ of the real @LLM@ interpreter, which is /outer/ of 'routeLLM' (the @@ -54,6 +56,7 @@ import Data.Vector qualified as V import Effectful (Dispatch (Dynamic), DispatchOf, Eff, Effect, (:>)) import Effectful.Dispatch.Dynamic (interpose, interpret, send) +import Effectful.Error.Static (Error, throwError) import Shikumi.Adapter ( ModelCapability (..), capabilityFor, @@ -62,7 +65,9 @@ metaResponseSchemaKey, metaTemperatureKey, ) +import Shikumi.Error (ShikumiError) import Shikumi.LLM (LLM (..), complete, stream) +import Shikumi.LLM.Continuation (validateRequestContinuation) -- | The ambient model-routing effect. Its single operation reads the model every -- 'Predict' node should dispatch against. It is supplied by an interpreter at the @@ -90,23 +95,25 @@ -- one for native-capable models) and stripped. The two operations are rewritten -- identically through the single 'translateForWire', so a streamed call gets the -- same real model id and wire options a blocking call does. -routeLLM :: (Routing :> es, LLM :> es) => Eff es a -> Eff es a +routeLLM :: (Routing :> es, LLM :> es, Error ShikumiError :> es) => Eff es a -> Eff es a routeLLM = interpose $ \_ -> \case Complete _placeholder ctx opts -> do m <- currentModel let (ctx', opts') = translateForWire m ctx opts + either throwError pure (validateRequestContinuation m ctx' opts') complete m ctx' opts' Stream _placeholder ctx opts -> do m <- currentModel let (ctx', opts') = translateForWire m ctx opts + either throwError pure (validateRequestContinuation m ctx' opts') stream m ctx' opts' -- | Realize the private request-metadata channel against the real model. For a -- native-capable model: attach the native @responseFormat@ from the stamped -- schema, and swap the marker-format 'Context' (system prompt + demo assistant -- turns) for the stamped native-format alternative. In all cases: set --- @temperature@ when one was stamped, and strip every private @shikumi.*@ key so --- nothing private reaches the transport. Fallback-capability models keep the +-- @temperature@ when one was stamped, and strip the four rendering keys. +-- Continuation expectations remain available for later boundary checks. Fallback-capability models keep the -- marker 'Context' unchanged; non-'Predict' @Complete@ calls (no stamps) are never -- rewritten. translateForWire :: Model -> Context -> Options -> (Context, Options) diff --git a/src/Shikumi/Stream.hs b/src/Shikumi/Stream.hs --- a/src/Shikumi/Stream.hs +++ b/src/Shikumi/Stream.hs @@ -67,7 +67,7 @@ import Shikumi.LLM (LLM, stream) import Shikumi.Program ( Params, - Program (Compose, Embed, FMap, MajorityVote, Map, Parallel, Predict, Retry, RetryWhen, Validate), + Program (Compose, Embed, FMap, MajorityVote, Map, Parallel, Predict, PredictCaptured, Retry, RetryWhen, Validate), acceptOrReject, effectiveSignature, parseResponse, @@ -219,6 +219,7 @@ (StreamEvent -> Eff es ()) -> Eff es o streamProgram prog i cb = case prog of + PredictCaptured _ sig ps -> streamPredict sig ps i cb Predict sig ps -> streamPredict sig ps i cb Compose f g -> bracketNode cb $ do b <- streamProgram f i cb diff --git a/test/AdapterSpec.hs b/test/AdapterSpec.hs --- a/test/AdapterSpec.hs +++ b/test/AdapterSpec.hs @@ -98,6 +98,8 @@ "AdapterSpec" [ testCase "capabilityFor: Anthropic messages -> NativeSchema" $ capabilityFor anthropicModel @?= NativeSchema, + testCase "capabilityFor: OpenAI Responses -> NativeSchema" $ + capabilityFor (emptyModel & #provider .~ "openai" & #api .~ OpenAIResponses) @?= NativeSchema, testCase "capabilityFor: Custom (ollama) host -> PromptFallback" $ capabilityFor ollamaModel @?= PromptFallback, testCase "fallback render: system prompt has the instruction and field markers" $ do diff --git a/test/ContinuationSpec.hs b/test/ContinuationSpec.hs new file mode 100644 --- /dev/null +++ b/test/ContinuationSpec.hs @@ -0,0 +1,93 @@ +module ContinuationSpec (tests) where + +import Baikai qualified as B +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (Value (..)) +import Data.Generics.Labels () +import Data.IORef +import Data.Map.Strict qualified as Map +import Data.Vector qualified as V +import Effectful (runEff) +import Effectful.Concurrent (runConcurrent) +import Effectful.Error.Static (runErrorNoCallStack) +import Shikumi.Error (ShikumiError (..)) +import Shikumi.LLM +import Shikumi.LLM.Continuation +import Shikumi.Routing (routeLLM, runRouting) +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +model :: B.Model +model = B.mkModel (B.Custom "continuation-test") "model" "https://provider.example" + +context :: B.Context +context = B.emptyContext & #systemPrompt .~ Just "system" & #messages .~ V.fromList [B.user "input", B.AssistantMessage (B.emptyResponse ^. #message & #content .~ V.singleton (B.AssistantThinking (B.ThinkingContent "" (Just "signature") False Nothing)))] + +options :: B.Options +options = stampContinuation (requestOrigin model) (Just (contextIdentity context)) B.emptyOptions + +tests :: TestTree +tests = + testGroup + "Continuation" + [ testCase "ordered prefix permits only append and construction timestamp changes" $ do + validateRequestContinuation model context options @?= Right () + let appended = context & #messages .~ (context ^. #messages <> V.singleton (B.user "next")) + validateRequestContinuation model appended options @?= Right () + let timestamped = context & #messages .~ V.map (\case B.AssistantMessage p -> B.AssistantMessage (p & #timestamp .~ Just (read "2026-09-08 00:00:00 UTC")); x -> x) (context ^. #messages) + validateRequestContinuation model timestamped options @?= Right () + mapM_ + (\c -> assertRejected (validateRequestContinuation model c options)) + [context & #systemPrompt .~ Just "different", context & #messages .~ V.reverse (context ^. #messages), context & #tools .~ V.singleton B.emptyTool], + testCase "unknown and malformed expectations reject opaque history" $ do + assertRejected (validateRequestContinuation model context B.emptyOptions) + assertRejected (validateRequestContinuation model context (stampContinuation Nothing Nothing B.emptyOptions)) + assertRejected (validateRequestContinuation model context (B.emptyOptions & #metadata .~ Map.singleton "shikumi.continuation.v1" (String "bad"))), + testCase "bare, resilient and routed calls reject changed targets before transport" $ do + (reg, seen) <- recordingRegistry + let changed = [model & #modelId .~ "other", model & #api .~ B.OpenAIResponses, model & #provider .~ "other", model & #baseUrl .~ "https://other.example"] + mapM_ + ( \m -> do + runEff (runErrorNoCallStack @ShikumiError (runLLMWith reg (complete m context options))) >>= assertRejected + runEff (runErrorNoCallStack @ShikumiError (runLLMWith reg (stream m context options))) >>= assertRejected + runEff (runErrorNoCallStack @ShikumiError (runConcurrent (runLLMResilient (defaultLLMConfig reg) (complete m context options)))) >>= assertRejected + runEff (runErrorNoCallStack @ShikumiError (runConcurrent (runLLMResilient (defaultLLMConfig reg) (stream m context options)))) >>= assertRejected + runEff (runErrorNoCallStack @ShikumiError (runRouting m (runLLMWith reg (routeLLM (complete B.emptyModel context options))))) >>= assertRejected + ) + changed + readIORef seen >>= (@?= []), + testCase "compatible route preserves payload and strips only private continuation metadata" $ do + (reg, seen) <- recordingRegistry + let opts = options & #metadata .~ Map.insert "public" (String "value") (options ^. #metadata) + result <- runEff . runErrorNoCallStack @ShikumiError . runRouting model . runLLMWith reg . routeLLM $ complete B.emptyModel context opts + case result of Left e -> assertFailure (show e); Right _ -> pure () + readIORef seen >>= (@?= [(context, stripContinuationMetadata opts)]), + testCase "Responses replay scope is cross-checked independently of expectation" $ do + let replay = B.ThinkingReplay B.OpenAIResponses "other" V.empty + msg = B.AssistantMessage (B.emptyResponse ^. #message & #content .~ V.singleton (B.AssistantThinking (B.ThinkingContent "" Nothing False (Just replay)))) + assertRejected (validateReplayOrigin model [msg]), + testCase "credentials never enter request-origin records" $ do + requestOrigin (model & #baseUrl .~ "https://user:secret@provider.example") @?= Nothing + requestOrigin (model & #baseUrl .~ "https://provider.example?key=secret") @?= Nothing + ] + +assertRejected :: Either ShikumiError a -> Assertion +assertRejected (Left (ValidationFailure _)) = pure () +assertRejected _ = assertFailure "expected local continuation validation failure" + +recordingRegistry :: IO (B.ProviderRegistry, IORef [(B.Context, B.Options)]) +recordingRegistry = do + seen <- newIORef [] + reg <- B.newProviderRegistry + B.registerApiProviderWith + reg + ( ( B.apiProviderWith + (model ^. #api) + (\_ c o -> Stream.concatEffect $ modifyIORef' seen (<> [(c, o)]) >> pure (Stream.fromList [])) + (\m c o -> modifyIORef' seen (<> [(c, o)]) >> pure (B.emptyResponse & #model .~ m)) + ) + { B.describeThinking = \_ _ -> B.noThinkingRequested + } + ) + pure (reg, seen) diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -8,6 +8,7 @@ ( ShikumiError (..), fromBaikaiError, isTransient, + renderShikumiError, ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -16,14 +17,14 @@ tests = testGroup "ErrorSpec" - [ testCase "maps providerError -> ProviderFailure" $ - fromBaikaiError (providerError "x") @?= ProviderFailure "x", + [ testCase "maps providerError -> ProviderError" $ + fromBaikaiError (providerError "x") @?= ProviderError (providerError "x"), testCase "maps decodeError -> InvalidJSON" $ fromBaikaiError (decodeError "y") @?= InvalidJSON "y", testCase "maps invalidRequest -> SchemaMismatch" $ fromBaikaiError (invalidRequest "z") @?= SchemaMismatch "invalid request: z", - testCase "maps processError -> ProviderFailure" $ - fromBaikaiError (processError 2 "boom") @?= ProviderFailure "process exited 2: boom", + testCase "maps processError -> ProviderError" $ + fromBaikaiError (processError 2 "boom") @?= ProviderError (processError 2 "boom"), testCase "maps ContextOverflow -> ContextWindowExceeded" $ fromBaikaiError BaikaiError @@ -31,6 +32,7 @@ message = "context length exceeded", httpStatus = Just 400, retryAfterSeconds = Nothing, + refusalCategory = Nothing, exitCode = Nothing } @?= ContextWindowExceeded "context length exceeded", @@ -43,5 +45,28 @@ isTransient (InvalidJSON "") @?= False isTransient (MissingField "") @?= False isTransient (ValidationFailure "") @?= False - isTransient (CodeExecFailed "") @?= False + isTransient (CodeExecFailed "") @?= False, + testGroup + "released categories" + [ testCase (show cat) $ do + let e = (providerError "detail") {category = cat, httpStatus = Just 403, retryAfterSeconds = Just 7, exitCode = Just 2, refusalCategory = Just "future_policy"} + expected = case cat of + DecodeFailure -> InvalidJSON "detail" + InvalidRequest -> SchemaMismatch "invalid request: detail" + ContextOverflow -> ContextWindowExceeded "detail" + _ -> ProviderError e + fromBaikaiError e @?= expected + isTransient expected @?= (cat `elem` [RateLimited, TransientError]) + | cat <- [AuthError, RateLimited, ContextOverflow, InvalidRequest, ContentFiltered, TransientError, DecodeFailure, ProcessFailure, ProviderUnavailable, OtherError] + ], + testGroup + "refusal categories retained verbatim" + [ testCase (show rc) $ do + let e = (providerError "refused") {category = ContentFiltered, refusalCategory = rc} + fromBaikaiError e @?= ProviderError e + | rc <- [Nothing, Just "policy_example", Just "future_category"] + ], + testCase "readable structured error" $ do + renderShikumiError (ProviderError (processError 2 "boom")) @?= "provider ProcessFailure (exit 2): boom" + renderShikumiError (ProviderFailure "legacy") @?= "legacy" ] diff --git a/test/LLMSpec.hs b/test/LLMSpec.hs --- a/test/LLMSpec.hs +++ b/test/LLMSpec.hs @@ -30,13 +30,13 @@ r <- complete stubModel stubContext stubOptions pure (flattenAssistantText (flattenAssistantBlocks r)) res @?= Right "hello from stub", - testCase "unregistered tag -> ProviderFailure" $ do + testCase "unregistered tag -> ProviderError" $ do reg <- newProviderRegistry -- empty registry: no handler for the stub tag res <- runEff . runErrorNoCallStack @ShikumiError . runLLMWith reg $ do r <- complete stubModel stubContext stubOptions pure (flattenAssistantText (flattenAssistantBlocks r)) case res of - Left (ProviderFailure _) -> pure () - other -> assertFailure ("expected Left (ProviderFailure ...), got " <> show other) + Left (ProviderError _) -> pure () + other -> assertFailure ("expected Left (ProviderError ...), got " <> show other) ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,6 +5,7 @@ import AdapterSpec qualified import CombinatorSpec qualified import ConstraintSpec qualified +import ContinuationSpec qualified import EndToEndSpec qualified import ErrorSpec qualified import LLMSpec qualified @@ -16,7 +17,9 @@ import ProgramAcceptanceSpec qualified import ProgramSpec qualified import RefineSpec qualified +import RequestDefaultsSpec qualified import ResilienceSpec qualified +import ResponsesSpec qualified import RoutingSpec qualified import SchemaSpec qualified import SerializeSpec qualified @@ -32,7 +35,10 @@ defaultMain $ testGroup "shikumi" - [ ErrorSpec.tests, + [ ResponsesSpec.tests, + RequestDefaultsSpec.tests, + ContinuationSpec.tests, + ErrorSpec.tests, SchemaSpec.tests, SignatureSpec.tests, AdapterSpec.tests, diff --git a/test/ModuleSpec.hs b/test/ModuleSpec.hs --- a/test/ModuleSpec.hs +++ b/test/ModuleSpec.hs @@ -6,7 +6,7 @@ import Control.Lens ((&), (.~)) import Data.Generics.Labels () -import Data.IORef (newIORef) +import Data.IORef (newIORef, readIORef) import Effectful (runEff) import Effectful.Error.Static (runErrorNoCallStack) import ProgramFixtures @@ -14,12 +14,14 @@ Topic (..), markerBody, mkResponse, + outlineResponse, + runFullRecordingLLM, runScriptedLLM, topicToOutline, topicToVerdict, ) import Shikumi.Error (ShikumiError (..)) -import Shikumi.Module (WithReasoning (..), chainOfThought, chainOfThoughtRaw, predict) +import Shikumi.Module (WithReasoning (..), chainOfThought, chainOfThoughtRaw, predict, predictCaptured) import Shikumi.Program (emptyParams, foldParams, mapParamsAt, runProgram) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -28,7 +30,17 @@ tests = testGroup "ModuleSpec" - [ testCase "predict builds a single default-parameter node" $ + [ testCase "captured prediction preserves requests and decoded output" $ do + let run p = do + replies <- newIORef [outlineResponse] + requests <- newIORef [] + result <- runEff . runErrorNoCallStack @ShikumiError . runFullRecordingLLM requests replies $ runProgram p (Topic "haskell") + sent <- readIORef requests + pure (result, sent) + ordinary <- run (predict topicToOutline) + captured <- run (predictCaptured topicToOutline) + captured @?= ordinary, + testCase "predict builds a single default-parameter node" $ foldParams (predict topicToOutline) @?= [emptyParams], testCase "chainOfThoughtRaw yields a WithReasoning value through the stub" $ do ref <- diff --git a/test/ProgramFixtures.hs b/test/ProgramFixtures.hs --- a/test/ProgramFixtures.hs +++ b/test/ProgramFixtures.hs @@ -29,6 +29,7 @@ -- * Fake LLM interpreters runScriptedLLM, runRecordingLLM, + runFullRecordingLLM, ) where @@ -40,6 +41,7 @@ emptyTextContent, ) import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (ToJSON) import Data.Generics.Labels () import Data.IORef (IORef, atomicModifyIORef', modifyIORef') import Data.Maybe (fromMaybe) @@ -61,6 +63,8 @@ newtype Topic = Topic {subject :: Text} deriving stock (Generic, Show, Eq) +instance ToJSON Topic + instance ToSchema Topic instance FromModel Topic @@ -72,6 +76,8 @@ newtype Outline = Outline {points :: [Text]} deriving stock (Generic, Show, Eq) +instance ToJSON Outline + instance ToSchema Outline instance FromModel Outline @@ -188,6 +194,14 @@ runRecordingLLM capture ref = interpret $ \_ -> \case Complete _ ctx _ -> do liftIO (modifyIORef' capture (++ [renderedPrompt ctx])) + liftIO (pop ref) + Stream _ _ _ -> pure [] + +-- | Capture every request component, including demos and routing metadata. +runFullRecordingLLM :: (IOE :> es) => IORef [Text] -> IORef [Response] -> Eff (LLM : es) a -> Eff es a +runFullRecordingLLM capture ref = interpret $ \_ -> \case + Complete model ctx opts -> do + liftIO (modifyIORef' capture (++ [T.pack (show (model, ctx, opts))])) liftIO (pop ref) Stream _ _ _ -> pure [] diff --git a/test/RequestDefaultsSpec.hs b/test/RequestDefaultsSpec.hs new file mode 100644 --- /dev/null +++ b/test/RequestDefaultsSpec.hs @@ -0,0 +1,108 @@ +module RequestDefaultsSpec (tests) where + +import Baikai (ToolChoice (..), emptyContext, emptyModel, emptyOptions, emptyResponse) +import Baikai.Evidence qualified as E +import Baikai.Speed (Speed (..)) +import Baikai.ThinkingLevel (ThinkingLevel (..)) +import Control.Concurrent (forkFinally, newEmptyMVar, putMVar, takeMVar) +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (Value (..)) +import Data.Generics.Labels () +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Effectful (liftIO, runEff) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.Error.Static (runErrorNoCallStack) +import Shikumi.Error (ShikumiError (..), isTransient) +import Shikumi.LLM (LLM (..), complete, stream) +import Shikumi.LLM.Defaults +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + +defaults :: RequestDefaults +defaults = RequestDefaults (Just ThinkingHigh) (Just SpeedFast) (Just 4096) (Just (E.evidenceRequest "default")) + +tests :: TestTree +tests = + testGroup + "Request defaults" + [ testCase "empty is identity and unrelated policy and metadata survive" $ do + let opts = + emptyOptions + & #temperature .~ Just 0.7 + & #toolChoice .~ Just ToolChoiceAuto + & #metadata .~ Map.fromList [("shikumi.continuation.v1", String "protected"), ("schema", Bool True)] + applyRequestDefaults emptyRequestDefaults opts @?= opts + let merged = applyRequestDefaults defaults opts + merged ^. #temperature @?= opts ^. #temperature + merged ^. #toolChoice @?= opts ^. #toolChoice + merged ^. #metadata @?= opts ^. #metadata + merged @?= (opts & #thinking .~ Just ThinkingHigh & #speed .~ Just SpeedFast & #maxTokens .~ Just 4096 & #evidence .~ defaultEvidence defaults), + testCase "explicit fields and whole evidence object override every default" $ do + let evidence = (E.evidenceRequest "explicit") {E.strictness = E.EvidenceRequired E.EvidenceFullyObserved, E.attempt = 3, E.supersedes = Just "previous"} + opts = emptyOptions & #thinking .~ Just ThinkingLow & #speed .~ Just SpeedStandard & #maxTokens .~ Just 12 & #evidence .~ Just evidence + applyRequestDefaults defaults opts @?= opts + applyRequestDefaults defaults (applyRequestDefaults defaults emptyOptions) @?= applyRequestDefaults defaults emptyOptions, + testCase "blocking and streaming use nearest scope and preserve explicit values" $ do + ref <- newIORef [] + result <- runEff + . runErrorNoCallStack @ShikumiError + . interpret + ( \_ -> \case + Complete _ _ o -> liftIO (modifyIORef' ref (++ [o])) >> pure emptyResponse + Stream _ _ o -> liftIO (modifyIORef' ref (++ [o])) >> pure [] + ) + . withRequestDefaults defaults + $ do + _ <- complete emptyModel emptyContext emptyOptions + withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just SpeedStandard}) $ do + _ <- stream emptyModel emptyContext emptyOptions + _ <- complete emptyModel emptyContext (emptyOptions & #speed .~ Just SpeedFast) + pure () + result @?= Right () + captured <- readIORef ref + map (^. #speed) captured @?= [Just SpeedFast, Just SpeedStandard, Just SpeedFast] + map (^. #thinking) captured @?= replicate 3 (Just ThinkingHigh) + map (^. #evidence) captured @?= replicate 3 (defaultEvidence defaults), + testCase "zero default ceiling rejects before either dispatch or action" $ do + ref <- newIORef (0 :: Int) + result <- runEff + . runErrorNoCallStack @ShikumiError + . interpret + ( \_ -> \case + Complete {} -> liftIO (modifyIORef' ref (+ 1)) >> pure emptyResponse + Stream {} -> liftIO (modifyIORef' ref (+ 1)) >> pure [] + ) + . withRequestDefaults (defaults {defaultMaxTokens = Just 0}) + $ do + liftIO (modifyIORef' ref (+ 1)) + _ <- complete emptyModel emptyContext (emptyOptions & #maxTokens .~ Just 12) + pure () + result @?= Left (ValidationFailure "request defaults: defaultMaxTokens must be positive") + readIORef ref >>= (@?= 0) + isTransient (ValidationFailure "invalid configuration") @?= False, + testCase "concurrent invocations retain independent settings" $ do + let run :: Speed -> IO [Maybe Speed] + run speed = do + ref <- newIORef [] + r <- runEff + . runErrorNoCallStack @ShikumiError + . interpret + ( \_ -> \case + Complete _ _ o -> liftIO (modifyIORef' ref (++ [o ^. #speed])) >> pure emptyResponse + Stream _ _ o -> liftIO (modifyIORef' ref (++ [o ^. #speed])) >> pure [] + ) + . withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just speed}) + $ do + _ <- complete emptyModel emptyContext emptyOptions + _ <- stream emptyModel emptyContext emptyOptions + pure () + r @?= Right () + readIORef ref + a <- newEmptyMVar + b <- newEmptyMVar + _ <- forkFinally (run SpeedFast) (putMVar a) + _ <- forkFinally (run SpeedStandard) (putMVar b) + takeMVar a >>= either (assertFailure . show) (@?= replicate 2 (Just SpeedFast)) + takeMVar b >>= either (assertFailure . show) (@?= replicate 2 (Just SpeedStandard)) + ] diff --git a/test/ResilienceSpec.hs b/test/ResilienceSpec.hs --- a/test/ResilienceSpec.hs +++ b/test/ResilienceSpec.hs @@ -5,16 +5,20 @@ module ResilienceSpec (tests) where import Baikai (AssistantMessageEvent (..), flattenAssistantBlocks) +import Baikai.Error (BaikaiError (..), ErrorCategory (..), providerError) import Control.Concurrent (forkIO) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM (newTVarIO, readTVarIO) +import Control.Exception (AsyncException (ThreadKilled), throwIO, try) +import Control.Lens ((^.)) +import Data.Aeson (eitherDecode, encode) import Data.IORef (newIORef, readIORef) import Data.Ratio ((%)) import Effectful (runEff) import Effectful.Concurrent (runConcurrent) import Effectful.Concurrent.Async (mapConcurrently) import Effectful.Error.Static (runErrorNoCallStack) -import Shikumi.Error (ShikumiError (..)) +import Shikumi.Error (ShikumiError (..), fromBaikaiError) import Shikumi.LLM ( LLMConfig (..), RetryPolicy (..), @@ -25,15 +29,19 @@ stream, ) import Shikumi.LLM.Budget (newBudget, spentUSD) +import Shikumi.LLM.Observation qualified as O import StubProvider ( budgetBarrierStubRegistry, + classifiedStubRegistry, concurrencyStubRegistry, costStubRegistry, + exceptionStubRegistry, failingStreamCostStubRegistry, failingStreamStubRegistry, failingStubRegistry, flattenAssistantText, invalidStubRegistry, + retryStreamCostStubRegistry, stubContext, stubModel, stubOptions, @@ -45,8 +53,61 @@ tests = testGroup "ResilienceSpec" - [ testCase "retry recovers after 2 failures" $ do + [ testCase "EP-61: retry emits two correlated attempts and retains failure cost" $ do + (observe, snapshot) <- O.newBillingCollectorWithLimit 10 ref <- newIORef 0 + reg <- retryStreamCostStubRegistry ref 1 (1 % 3) "ok" + let cfg = (defaultLLMConfig reg) {observer = Just observe, retryPolicy = RetryPolicy 2 0 0} + result <- + runEff . runConcurrent . runErrorNoCallStack @ShikumiError . runLLMResilient cfg $ + stream stubModel stubContext stubOptions + assertBool "retry succeeded" (either (const False) (const True) result) + summary <- snapshot + O.completedAttempts summary @?= 1 + O.failedAttempts summary @?= 1 + (O.getUsage (O.observedUsage summary) ^. #cost . #usd) @?= (1 % 3) + map O.attempt (O.retainedAttempts summary) @?= [1, 2] + case O.retainedAttempts summary of + [a, b] -> O.callId a @?= O.callId b + _ -> assertFailure "expected two attempts" + eitherDecode (encode summary) @?= Right summary, + testCase "EP-61: thrown transport failure has no invented usage" $ do + ref <- newIORef 0 + reg <- failingStubRegistry ref 1 "ok" + (observe, snapshot) <- O.newBillingCollectorWithLimit 2 + _ <- runText ((defaultLLMConfig reg) {observer = Just observe, retryPolicy = RetryPolicy 2 0 0}) + summary <- snapshot + case O.retainedAttempts summary of + first : _ -> O.usage first @?= Nothing + [] -> assertFailure "no attempt observed", + testCase "EP-61: bounded collector keeps exact totals after detail truncation" $ do + (observe, snapshot) <- O.newBillingCollectorWithLimit 1 + reg <- costStubRegistry (1 % 3) "ok" + let cfg = (defaultLLMConfig reg) {observer = Just observe} + _ <- runText cfg + _ <- runText cfg + summary <- snapshot + O.completedAttempts summary @?= 2 + O.unknownUsageAttempts summary @?= 2 + length (O.retainedAttempts summary) @?= 1 + O.detailTruncated summary @?= True + (O.getUsage (O.observedUsage summary) ^. #cost . #usd) @?= (2 % 3), + testCase "EP-61: callback BaikaiError propagates without another transport attempt" $ do + ref <- newIORef 0 + reg <- failingStubRegistry ref 0 "ok" + let err = (providerError "observer failed") {category = TransientError} + cfg = (defaultLLMConfig reg) {observer = Just (\_ -> throwIO err)} + result <- try @BaikaiError (runText cfg) + result @?= Left err + readIORef ref >>= (@?= 1), + testCase "EP-61: cancellation emits no synthetic success" $ do + (observe, snapshot) <- O.newBillingCollector + reg <- exceptionStubRegistry (throwIO ThreadKilled) + result <- try @AsyncException (runText ((defaultLLMConfig reg) {observer = Just observe})) + result @?= Left ThreadKilled + snapshot >>= (@?= O.emptyBillingSummary), + testCase "retry recovers after 2 failures" $ do + ref <- newIORef 0 reg <- failingStubRegistry ref 2 "ok" let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5} res <- runText cfg @@ -59,7 +120,7 @@ let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 2 1 5} res <- runText cfg case res of - Left (ProviderFailure _) -> pure () + Left (ProviderError _) -> pure () other -> assertFailure ("expected Left (ProviderFailure ...), got " <> show other) n <- readIORef ref n @?= 2, @@ -156,7 +217,29 @@ res2 <- runStream cfg case res2 of Left (BudgetExceeded _) -> pure () - other -> assertFailure ("expected Left (BudgetExceeded ...) after the failed call charged, got " <> show other) + other -> assertFailure ("expected Left (BudgetExceeded ...) after the failed call charged, got " <> show other), + testGroup + "classified attempts across APIs" + [ testCase (show (cat, streaming, thrown)) $ do + ref <- newIORef 0 + let err = (providerError "refused") {category = cat, refusalCategory = Just "policy_example"} + retryable = cat `elem` [RateLimited, TransientError] + cost = 1 % 100 + reg <- classifiedStubRegistry ref 1 err thrown cost + b <- newBudget Nothing + let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5, budget = Just b} + result <- if streaming then fmap (fmap (const "ok")) (runStream cfg) else runText cfg + result @?= if retryable then Right "ok" else Left (fromBaikaiError err) + readIORef ref >>= (@?= if retryable then 2 else 1) + spentUSD b >>= (@?= if thrown then 0 else cost) + | cat <- [AuthError, RateLimited, ContentFiltered, TransientError, ProviderUnavailable, ProcessFailure, OtherError, InvalidRequest, ContextOverflow, DecodeFailure], + (streaming, thrown) <- [(False, False), (False, True), (True, False)] + ], + testCase "cancellation escapes without retry" $ do + reg <- exceptionStubRegistry (throwIO ThreadKilled) + let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5} + result <- try @AsyncException (runText cfg) + result @?= Left ThreadKilled ] where runText cfg = diff --git a/test/ResponsesSpec.hs b/test/ResponsesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesSpec.hs @@ -0,0 +1,45 @@ +module ResponsesSpec (tests) where + +import Baikai qualified as B +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (Value (..), object, (.=)) +import Data.Generics.Labels () +import Data.IORef +import Effectful (liftIO, runEff) +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.Error.Static (runErrorNoCallStack) +import Shikumi.Adapter (ModelCapability (..), attachSchema, capabilityFor) +import Shikumi.Error (ShikumiError) +import Shikumi.LLM qualified as L +import Shikumi.Routing (routeLLM, runRouting) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testCase "Responses routes strict native schemas for both operations" $ do + let model = B.mkModel B.OpenAIResponses "fixture" "https://example.invalid" & #provider .~ "openai" + schema = object ["type" .= String "object", "properties" .= object []] + case capabilityFor model of NativeSchema -> pure (); _ -> assertFailure "Responses must be native" + seen <- newIORef [] + result <- runEff + . runErrorNoCallStack @ShikumiError + . runRouting model + . interpret + ( \_ -> \case + L.Complete m _ o -> liftIO (modifyIORef' seen (<> [(m, o)])) >> pure B.emptyResponse + L.Stream m _ o -> liftIO (modifyIORef' seen (<> [(m, o)])) >> pure [] + ) + . routeLLM + $ do + _ <- L.complete B.emptyModel B.emptyContext (attachSchema schema B.emptyOptions) + _ <- L.stream B.emptyModel B.emptyContext (attachSchema schema B.emptyOptions) + pure () + result @?= Right () + recorded <- readIORef seen + length recorded @?= 2 + mapM_ + ( \(m, o) -> do + m ^. #api @?= B.OpenAIResponses + o ^. #responseFormat @?= Just (B.JsonSchema (B.jsonSchemaFormat "output" schema & #strict .~ True)) + ) + recorded diff --git a/test/RoutingSpec.hs b/test/RoutingSpec.hs --- a/test/RoutingSpec.hs +++ b/test/RoutingSpec.hs @@ -25,6 +25,7 @@ jsonSchemaFormat, ) import Baikai.Models.Generated (openai_gpt_4o_mini) +import Baikai.Speed (Speed (..)) import Control.Lens ((^.)) import Data.Aeson (Value (..), eitherDecodeStrict, object, (.=)) import Data.Aeson.KeyMap qualified as KM @@ -47,6 +48,7 @@ import Shikumi.Combinator (majorityVote, majorityVoteBy) import Shikumi.Error (ShikumiError) import Shikumi.LLM (LLM (..), Response) +import Shikumi.LLM.Defaults import Shikumi.Module (predict) import Shikumi.Program ( Demo (..), @@ -112,10 +114,13 @@ . runErrorNoCallStack @ShikumiError . runRouting model . runCapturingLLM ref outlineResponse + . withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just SpeedFast}) . routeLLM $ runProgram prog input assertBool "routed program decodes without error" (isRight res) - readIORef ref + captured <- readIORef ref + map (\(_, _, o) -> o ^. #speed) captured @?= replicate (length captured) (Just SpeedFast) + pure captured -- | As 'captureRouted' but under the concurrent executor. captureRoutedConc :: Model -> Program Topic Outline -> Topic -> IO [(Model, Context, Options)] @@ -127,10 +132,13 @@ . runConcurrent . runRouting model . runCapturingLLM ref outlineResponse + . withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just SpeedFast}) . routeLLM $ runProgramConc prog input assertBool "routed program decodes without error" (isRight res) - readIORef ref + captured <- readIORef ref + map (\(_, _, o) -> o ^. #speed) captured @?= replicate (length captured) (Just SpeedFast) + pure captured isRight :: Either a b -> Bool isRight = either (const False) (const True) @@ -259,12 +267,14 @@ . runErrorNoCallStack @ShikumiError . runRouting openai_gpt_4o_mini . runCapturingLLM ref outlineResponse + . withRequestDefaults (emptyRequestDefaults {defaultSpeed = Just SpeedFast}) . routeLLM $ streamProgram (predict topicToOutline) (Topic "cats") (\_ -> pure ()) assertBool "routed streaming program decodes without error" (isRight res) captured <- readIORef ref case captured of [(m, _, o)] -> do + o ^. #speed @?= Just SpeedFast m ^. #modelId @?= openai_gpt_4o_mini ^. #modelId o ^. #responseFormat @?= Just (JsonSchema ((jsonSchemaFormat "output" (deriveSchema @Outline)) {strict = True})) diff --git a/test/StubProvider.hs b/test/StubProvider.hs --- a/test/StubProvider.hs +++ b/test/StubProvider.hs @@ -17,8 +17,11 @@ failingStubRegistry, failingStreamStubRegistry, failingStreamCostStubRegistry, + retryStreamCostStubRegistry, invalidStubRegistry, concurrencyStubRegistry, + classifiedStubRegistry, + exceptionStubRegistry, ) where @@ -152,7 +155,7 @@ if a >= n then pure () else retry pure (stubResponse t & #message . #usage . #cost . #usd .~ cost) --- | A registry whose @complete@ throws 'providerError' (a transient failure) the +-- | A registry whose @complete@ throws a typed transient failure the -- first @failTimes@ calls, then returns the given text. The 'IORef' records the -- total number of attempts (used by the retry tests). failingStubRegistry :: IORef Int -> Int -> Text -> IO ProviderRegistry @@ -160,7 +163,7 @@ mkRegistry t $ \_ _ _ -> do n <- atomicModifyIORef' ref (\k -> (k + 1, k + 1)) if n <= failTimes - then throwIO (providerError ("stub transient failure #" <> T.pack (show n))) + then throwIO ((providerError ("stub transient failure #" <> T.pack (show n))) {category = TransientError}) else pure (stubResponse t) -- | A terminal-failing event sequence: an 'EventError' whose assembled message @@ -206,6 +209,27 @@ } pure reg +retryStreamCostStubRegistry :: IORef Int -> Int -> Rational -> Text -> IO ProviderRegistry +retryStreamCostStubRegistry ref failTimes cost t = do + reg <- newProviderRegistry + registerApiProviderWith + reg + ( apiProviderWith + stubApi + ( \_ _ _ -> Stream.concatEffect $ do + n <- atomicModifyIORef' ref (\k -> (k + 1, k + 1)) + pure $ + Stream.fromList $ + if n <= failTimes + then streamErrorEvents cost ("stub stream failure #" <> T.pack (show n)) + else stubEvents t + ) + (\_ _ _ -> pure (stubResponse t)) + ) + { describeThinking = stubDescribeThinking + } + pure reg + -- | A registry whose /stream/ always fails with a terminal 'EventError' carrying -- the given dollar cost, so a test can assert the budget is charged even though the -- stream failed. @@ -245,3 +269,36 @@ c <- readTVar cur modifyTVar' mx (max c) leave = atomically (modifyTVar' cur (subtract 1)) + +-- | Exercise in-band, thrown, and streamed classified failures with attempt costs. +classifiedStubRegistry :: IORef Int -> Int -> BaikaiError -> Bool -> Rational -> IO ProviderRegistry +classifiedStubRegistry ref failTimes err thrown cost = do + let next = atomicModifyIORef' ref (\n -> (n + 1, n < failTimes)) + payload = stubPayloadWith "partial" & #usage . #cost . #usd .~ cost & #errorMessage .~ Just "legacy text disagrees" & #stopReason .~ ErrorReason + response = stubResponse "partial" & #message .~ payload & #errorInfo .~ Just err + reg <- newProviderRegistry + registerApiProviderWith + reg + ( apiProviderWith + stubApi + ( \_ _ _ -> Stream.concatEffect $ do + failed <- next + pure + ( Stream.fromList + ( if failed + then [EventStart (StartPayload (AssistantMessage (stubPayloadWith "")) Nothing), EventError (errorTerminal Nothing Nothing ErrorReason (AssistantMessage payload) err)] + else stubEvents "ok" + ) + ) + ) + ( \_ _ _ -> do + failed <- next + if failed then if thrown then throwIO err else pure response else pure (stubResponse "ok") + ) + ) + { describeThinking = stubDescribeThinking + } + pure reg + +exceptionStubRegistry :: IO Response -> IO ProviderRegistry +exceptionStubRegistry action = mkRegistry "" (\_ _ _ -> action) diff --git a/test/TwoStepSpec.hs b/test/TwoStepSpec.hs --- a/test/TwoStepSpec.hs +++ b/test/TwoStepSpec.hs @@ -11,6 +11,7 @@ emptyResponse, emptyTextContent, ) +import Baikai.Error (contentFiltered) import Control.Lens ((&), (.~)) import Data.Generics.Labels () import Data.IORef (newIORef, readIORef) @@ -18,14 +19,18 @@ import Data.Text qualified as T import Data.Vector qualified as V import Effectful (runEff) +import Effectful.Concurrent (runConcurrent) import Effectful.Error.Static (runErrorNoCallStack) import Fixtures (Article, Author (..), Sentiment (..), Summary (..), sampleArticle, sampleSummary) import ProgramFixtures (runScriptedLLM) -import Shikumi.Error (ShikumiError) +import Shikumi.Error (ShikumiError (..)) +import Shikumi.LLM (LLMConfig (..), RetryPolicy (..), defaultLLMConfig, runLLMResilient) import Shikumi.Module (twoStep) import Shikumi.Program (Program, runProgram) +import Shikumi.Routing (routeLLM, runRouting) import Shikumi.Schema.Types (field) import Shikumi.Signature (Demo (..), Signature, mkSignature, setDemos) +import StubProvider (classifiedStubRegistry, stubModel) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -93,5 +98,13 @@ runEff . runErrorNoCallStack @ShikumiError . runScriptedLLM ref $ runProgram prog sampleArticle remaining <- readIORef ref - length remaining @?= 0 + length remaining @?= 0, + testCase "refusal prevents the extraction call" $ do + ref <- newIORef 0 + let err = contentFiltered "refused" + reg <- classifiedStubRegistry ref 1 err False 0 + let cfg = (defaultLLMConfig reg) {retryPolicy = RetryPolicy 3 1 5} + out <- runEff . runConcurrent . runErrorNoCallStack @ShikumiError . runRouting stubModel . runLLMResilient cfg . routeLLM $ runProgram prog sampleArticle + out @?= Left (ProviderError err) + readIORef ref >>= (@?= 1) ] diff --git a/test/XmlAdapterSpec.hs b/test/XmlAdapterSpec.hs --- a/test/XmlAdapterSpec.hs +++ b/test/XmlAdapterSpec.hs @@ -1,28 +1,32 @@ --- | EP-26 M1: 'Shikumi.Adapter.xmlAdapter'. A third wire format on the typed seam. --- @render@ asks for @…@ tags; @parse@ reads them back into the --- typed output via the same 'sectionsToObject' + decode path the fallback adapter --- uses, so a missing tag yields the same located 'MissingField'. +{-# LANGUAGE DataKinds #-} + module XmlAdapterSpec (tests) where import Baikai ( AssistantContent (..), + Context, + Message (..), Response, + TextContent (..), emptyResponse, emptyTextContent, ) import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (ToJSON, object, (.=)) import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Vector qualified as V import Fixtures (Article, Author (..), Sentiment (..), Summary (..), sampleArticle, sampleSummary) -import Shikumi.Adapter (Adapter (..), xmlAdapter) +import GHC.Generics (Generic) +import Shikumi.Adapter (Adapter (..), ToPrompt, nestedXmlAdapter, xmlAdapter) import Shikumi.Error (ShikumiError (..)) -import Shikumi.Schema.Types (field) +import Shikumi.Schema (FromModel, ToSchema (..), Validatable) +import Shikumi.Schema.Types (Constrained, Constraint (..), field) import Shikumi.Signature (Demo (..), Signature, mkSignature, setDemos) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) sig :: Signature Article Summary sig = setDemos [Demo sampleArticle sampleSummary] (mkSignature "Summarize the article") @@ -90,7 +94,8 @@ tests = testGroup "XmlAdapterSpec" - [ testCase "xml render: system prompt has the instruction and an XML tag" $ do + [ nestedTests, + testCase "xml render: system prompt has the instruction and an XML tag" $ do T.isInfixOf "Summarize the article" (sysOf xmlAdapter) @?= True T.isInfixOf "" (sysOf xmlAdapter) @?= True, testCase "xml parse: tagged body decodes to the expected Summary" $ @@ -98,3 +103,148 @@ testCase "xml parse: a missing tag -> MissingField (located)" $ parse xmlAdapter sig (mkResponse xmlBodyNoBullets) @?= Left (MissingField "bullets") ] + +-- Separate fixtures keep the richer codec independent of ToPrompt flattening. +data Person = Person {label :: Text, count :: Int} + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, ToSchema, FromModel) + +newtype Meta = Meta {optional :: Maybe Text} + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, ToSchema, FromModel) + +data Envelope = Envelope + { people :: [Person], + matrix :: [[Int]], + metadata :: Meta, + literal :: Text, + maybeText :: Maybe Text, + flag :: Bool, + ratio :: Double + } + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, ToSchema, FromModel, Validatable) + +newtype Limited = Limited {value :: Constrained '[ 'MinLen 3] Text} + deriving stock (Generic, Show, Eq) + deriving anyclass (ToPrompt, ToSchema, FromModel, Validatable) + +-- A hand-written union is outside the generated-schema subset and uses JSON. +newtype Manual = Manual {manual :: Text} + deriving stock (Generic, Show, Eq) + deriving anyclass (ToJSON, FromModel, Validatable) + +instance ToSchema Manual where + toSchema _ = object ["type" .= ("object" :: Text), "properties" .= object ["manual" .= object ["anyOf" .= [object ["type" .= ("string" :: Text)], object ["type" .= ("integer" :: Text)]]]]] + +envelopeSig :: Signature Article Envelope +envelopeSig = mkSignature "Encode all nested fields" + +example :: Envelope +example = Envelope [Person "Ada & " 2, Person "Lin" 3] [[1, 2], [], [3]] (Meta Nothing) "null" (Just "null") True 1.25 + +assistantBodies :: Context -> [Text] +assistantBodies ctx = [T.concat [t | AssistantText (TextContent t) <- V.toList (p ^. #content)] | AssistantMessage p <- V.toList (ctx ^. #messages)] + +rendered :: Envelope -> [Text] +rendered value = assistantBodies (fst (render nestedXmlAdapter (setDemos [Demo sampleArticle value] envelopeSig) sampleArticle)) + +decodeEnvelope :: Text -> Either ShikumiError Envelope +decodeEnvelope = parse nestedXmlAdapter envelopeSig . mkResponse + +nestedBody :: Text +nestedBody = T.replace "{\"name\": \"Ada\"}" "Ada" $ T.replace "[\"records in\", \"records out\", \"errors are typed\"]" "records inrecords outerrors are typed" xmlBody + +nestedTests :: TestTree +nestedTests = + testGroup + "nested codec" + [ testCase "nested record and list agree with legacy JSON containers" $ + parse xmlAdapter sig (mkResponse nestedBody) @?= Right expectedSummary, + testCase "same-name nesting balances and unknown properties are ignored" $ + parse xmlAdapter sig (mkResponse (T.replace "" "" nestedBody)) @?= Right expectedSummary, + testCase "first complete duplicate wins, unknown top-level ignored, prose allowed" $ + parse xmlAdapter sig (mkResponse ("Here is the answer & details. " <> nestedBody <> "wrong")) @?= Right expectedSummary, + testCase "nested occurrence cannot satisfy missing outer field" $ + parse xmlAdapter sig (mkResponse (T.replace "" "" (T.replace "{\"name\": \"Ada\"}" "Ada" xmlBodyNoBullets))) @?= Left (MissingField "bullets"), + testCase "missing nested field retains path" $ + parse xmlAdapter sig (mkResponse (T.replace "Ada" "" nestedBody)) @?= Left (MissingField "author.name"), + testCase "record validation still executes" $ + parse xmlAdapter sig (mkResponse (T.replace "records in" "" nestedBody)) @?= Left (ValidationFailure "bullets: must have 3 to 5 items"), + testCase "declared field constraints execute" $ + parse xmlAdapter (mkSignature "Validate" :: Signature Article Limited) (mkResponse "x") @?= Left (ValidationFailure "value: minLength 3 violated"), + testCase "nested demos round-trip records, matrices, null strings and numeric/boolean scalars" $ + mapM_ + ( \v -> case rendered v of + [body] -> decodeEnvelope body @?= Right v + bodies -> assertFailure (show bodies) + ) + [example, example {people = [], matrix = [], literal = "", maybeText = Nothing, flag = False, ratio = -2.5}, example {literal = "a ]]> b & c\nd", maybeText = Just ""}], + testCase "manual union schemas use escaped JSON fallback" $ do + let manualSig = setDemos [Demo sampleArticle (Manual "a < b")] (mkSignature "Manual") + ctx = fst (render nestedXmlAdapter manualSig sampleArticle) + assistantBodies ctx @?= ["\"a < b\"\n"] + map (parse nestedXmlAdapter manualSig . mkResponse) (assistantBodies ctx) @?= [Right (Manual "a < b")], + testCase "renderer preserves top-level order and distinguishes null spellings" $ + case rendered example of + [body] -> do + T.isPrefixOf "" body @?= True + T.isInfixOf "null" body @?= True + T.isInfixOf "" body @?= True + T.isInfixOf "2