shikumi-tools 0.2.0.0 → 0.3.0.0

raw patch · 26 files changed

+922/−156 lines, 26 filesdep ~baikaidep ~shikumidep ~shikumi-toolsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: baikai, shikumi, shikumi-tools

API changes (from Hackage documentation)

Files

• CHANGELOG.md +25/−0
• shikumi-tools.cabal +6/−6
• src/Shikumi/Agent/ReAct.hs +62/−18
• src/Shikumi/CodeExec/CodeAct.hs +71/−21
• src/Shikumi/CodeExec/Interpreter.hs +23/−14
• src/Shikumi/CodeExec/ProgramOfThought.hs +4/−5
• src/Shikumi/Tool.hs +27/−9
• src/Shikumi/Tool/Builtin/Fs.hs +46/−23
• src/Shikumi/Tool/Builtin/Shell.hs +9/−2
• src/Shikumi/Tool/Builtin/Web.hs +3/−3
• src/Shikumi/Tool/Env.hs +25/−6
• src/Shikumi/Tool/Web.hs +113/−21
• test/BuiltinAcceptanceSpec.hs +4/−1
• test/CodeActSpec.hs +99/−6
• test/CompactionSpec.hs +31/−1
• test/EnvSpec.hs +16/−1
• test/Fixtures.hs +5/−1
• test/FsSpec.hs +81/−2
• test/MockLLM.hs +10/−3
• test/ProgramOfThoughtSpec.hs +7/−3
• test/ProtocolSpec.hs +31/−3
• test/ReActSpec.hs +98/−2
• test/RestrictedSpec.hs +8/−0
• test/SchemaSpec.hs +34/−1
• test/ToolSpec.hs +27/−3
• test/WebSpec.hs +57/−1

@@ -2,6 +2,31 @@  ## Unreleased +## 0.3.0.0 - 2026-07-05++### Added++- ReAct exposes `Proposal`, `renderStepLine`, and `summaryStep`; native ReAct+  turns can dispatch multiple tool calls in order before the next model turn.+- `CodeActConfig` now includes trajectory compaction settings, matching the ReAct+  context-window recovery path.+- Tooling exposes infrastructure-error classification, fetch-policy controls,+  capped HTTP response reading, and symlink information in directory listings.++### Changed++- **BREAKING** `ProtocolImpl.parsePropose` now returns `Proposal` instead of+  `Action`, and trajectories can contain the new `Summarized` action injected by+  compaction.+- **BREAKING** `CodeActConfig` record construction requires the new `compaction`+  field.+- Tool bodies now rethrow budget and context-window exhaustion instead of feeding+  them back to the model as recoverable observations.+- Built-in filesystem, shell, and web tools are hardened: execution timeouts are+  clamped, default fetch policy rejects common local/private targets, and fetches+  cap bytes while streaming.+- Refreshed the internal `shikumi` bound for the `0.3` series.+ ## 0.2.0.0 - 2026-06-28  ### Added

@@ -1,6 +1,6 @@ cabal-version:   3.4 name:            shikumi-tools-version:         0.2.0.0+version:         0.3.0.0 synopsis:   Typed tools and ReAct agents for shikumi LM programs (EP-11) @@ -58,7 +58,7 @@    build-depends:     , aeson-    , baikai           >=0.2      && <0.3+    , baikai           >=0.3      && <0.4     , base             >=4.20     && <5     , bytestring     , containers@@ -72,7 +72,7 @@     , lens             ^>=5.3     , process     , regex-tdfa-    , shikumi          ^>=0.2.0.0+    , shikumi          ^>=0.3.0.0     , text             ^>=2.1     , vector @@ -102,7 +102,7 @@    build-depends:     , aeson-    , baikai         >=0.2      && <0.3+    , baikai         >=0.3      && <0.4     , base     , bytestring     , containers@@ -111,8 +111,8 @@     , filepath     , generic-lens     , lens-    , shikumi        ^>=0.2.0.0-    , shikumi-tools  ^>=0.2.0.0+    , shikumi        ^>=0.3.0.0+    , shikumi-tools  ^>=0.3.0.0     , tasty     , tasty-hunit     , text

@@ -38,12 +38,15 @@     reactWithTrajectory,      -- * The protocol seam+    Proposal (..),     ProtocolImpl (..),     resolveProtocolKind,     resolveProtocol,      -- * Rendering (exposed for tests/inspection)     renderTrajectory,+    renderStepLine,+    summaryStep,   ) where @@ -71,6 +74,8 @@ import Data.Aeson.KeyMap qualified as KM import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels ()+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE import Data.Proxy (Proxy (..)) import Data.Text (Text) import Data.Text qualified as T@@ -81,7 +86,7 @@ import Effectful.Error.Static (Error, catchError, throwError) import GHC.Generics (Generic) import Shikumi.Adapter (ModelCapability (..), ToPrompt (toPrompt), attachSchema, capabilityFor)-import Shikumi.Compaction (CompactionConfig, compactTail, defaultCompactionConfig, usageExceedsWindow)+import Shikumi.Compaction (CompactionConfig (..), compactTail, defaultCompactionConfig, usageExceedsWindow) import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (LLM, complete) import Shikumi.Program (Program (FMap), embed)@@ -93,11 +98,16 @@ -- The trajectory data model -- --------------------------------------------------------------------------- --- | What the model decided to do at a step: invoke a named tool with a raw JSON--- arguments object, or declare it is finished.+-- | What happened at a step: the model invoked a named tool with a raw JSON+-- arguments object, declared it is finished, or the framework injected a+-- compaction summary. data Action   = CallTool !Text !Value   | Finish+  | -- | Injected by compaction: this step's observation carries a model-written+    -- summary of earlier steps that were folded away. Never produced by the+    -- model and never dispatched as a tool.+    Summarized   deriving stock (Show, Eq, Generic)  -- | One recorded (thought, action, observation) step. @observation@ is 'Nothing'@@ -171,7 +181,8 @@ react sig reg cfg = FMap fst (reactWithTrajectory sig reg cfg)  -- | Build a ReAct agent that also returns the recorded 'Trajectory', for--- evaluators/optimizers and tests that assert on the steps.+-- evaluators/optimizers and tests that assert on the steps. When compaction ran,+-- the trajectory contains 'Summarized' steps whose observations carry the summary. reactWithTrajectory ::   forall i o.   (ToPrompt i, ToSchema o, FromModel o, Validatable o) =>@@ -199,7 +210,9 @@     impl :: ProtocolImpl i o     impl = resolveProtocol (protocol cfg) _Model sig reg -    -- Propose -> dispatch -> observe, accumulating steps (newest first).+    -- Propose -> dispatch -> observe, accumulating steps (newest first). The+    -- iteration counter advances once per model turn, even when a native model+    -- proposes several tool calls in that turn.     loop :: Int -> [Step] -> Eff es Trajectory     loop iter acc       | iter >= maxIters cfg =@@ -208,12 +221,10 @@           (accForPrompt, resp) <- completeProposeRecover acc           case parsePropose impl resp of             Left perr -> loop (iter + 1) (correctiveStep perr : accForPrompt)-            Right (th, Finish) ->+            Right (th, ProposeFinish) ->               pure (Trajectory (V.fromList (reverse (Step th Finish Nothing : accForPrompt))) TerminatedFinish)-            Right (th, CallTool nm args) -> do-              res <- runToolCall reg (mkToolCall nm args)-              let obs = either renderToolError id res-                  acc' = Step th (CallTool nm args) (Just obs) : accForPrompt+            Right (th, ProposeCalls calls) -> do+              acc' <- dispatchCalls th calls accForPrompt               acc'' <- compactAcc (resp ^. #model) (resp ^. #message . #usage) acc'               loop (iter + 1) acc'' @@ -226,6 +237,8 @@         catchError           ((traj,) <$> complete _Model ctx opts)           ( \_cs -> \case+              e@(ContextWindowExceeded {})+                | not (enabled (compaction cfg)) -> throwError e               ContextWindowExceeded {} -> do                 compacted <- forceCompactTrajectory traj                 let (ctx', opts') = renderExtract impl i compacted@@ -241,6 +254,8 @@       catchError         ((acc,) <$> complete _Model ctx opts)         ( \_cs -> \case+            e@(ContextWindowExceeded {})+              | not (enabled (compaction cfg)) -> throwError e             ContextWindowExceeded {} -> do               compacted <- forceCompactAcc acc               let (ctx', opts') = renderPropose impl i (soFar compacted)@@ -262,14 +277,27 @@       compacted <- compactTail (compaction cfg) _Model renderStepLine summaryStep (V.toList (steps traj))       pure (traj {steps = V.fromList compacted}) +    dispatchCalls :: Text -> NonEmpty (Text, Value) -> [Step] -> Eff es [Step]+    dispatchCalls th calls acc0 = do+      (_, acc') <- foldl dispatchOne (pure (True, acc0)) (NE.toList calls)+      pure acc'+      where+        dispatchOne mState (nm, args) = do+          (isFirst, acc) <- mState+          res <- runToolCall reg (mkToolCall nm args)+          let obs = either renderToolError id res+              stepThought = if isFirst then th else ""+              step = Step stepThought (CallTool nm args) (Just obs)+          pure (False, step : acc)+     -- A trajectory view of the steps gathered so far (termination is irrelevant     -- for the propose render).     soFar :: [Step] -> Trajectory     soFar acc = Trajectory (V.fromList (reverse acc)) TerminatedFinish  -- | Build a synthetic step recording an unparseable proposal, so the corrective--- text reaches the model on the next turn (the empty tool name is a sentinel that--- is never dispatched).+-- text reaches the model on the next turn. The empty 'CallTool' name is a+-- documented sentinel only for corrective feedback and is never dispatched. correctiveStep :: Text -> Step correctiveStep perr =   Step@@ -283,7 +311,7 @@ summaryStep summaryText =   Step     { thought = "(compacted summary of earlier steps)",-      action = CallTool "" Null,+      action = Summarized,       observation = Just summaryText     } @@ -299,12 +327,17 @@ -- The protocol seam -- --------------------------------------------------------------------------- +-- | What one model turn proposed: finish, or one-or-more tool calls to execute+-- in order before the next model turn.+data Proposal = ProposeFinish | ProposeCalls !(NonEmpty (Text, Value))+  deriving stock (Show, Eq, Generic)+ -- | The protocol-specific rendering/parsing the loop depends on. Both the native -- and the prompt implementations satisfy this interface, so the loop body is -- identical under either seam. data ProtocolImpl i o = ProtocolImpl   { renderPropose :: !(i -> Trajectory -> (Context, Options)),-    parsePropose :: !(Response -> Either Text (Text, Action)),+    parsePropose :: !(Response -> Either Text (Text, Proposal)),     renderExtract :: !(i -> Trajectory -> (Context, Options)),     parseExtract :: !(Response -> Either ShikumiError o)   }@@ -355,7 +388,7 @@                 <> proposeGrammar             msg = user (taskBlock i <> "\n\n" <> historyBlock traj)          in (buildCtx sys [msg] V.empty Nothing, _Options),-      parsePropose = \resp -> parseActionText (responseText resp),+      parsePropose = \resp -> actionToProposal <$> parseActionText (responseText resp),       renderExtract = \i traj ->         let sys =               getInstruction sig@@ -385,11 +418,15 @@             msg = user (taskBlock i <> "\n\n" <> historyBlock traj)             opts = _Options & #toolChoice .~ Just ToolChoiceAuto          in (buildCtx sys [msg] (registryBaikai reg) Nothing, opts),-      -- A tool-call block -> CallTool; no tool call (plain text) -> Finish.+      -- Tool-call blocks -> calls executed in order; no tool call (plain text) -> finish.       parsePropose = \resp ->         case toolCallsOf resp of-          (tc : _) -> Right (responseText resp, CallTool (tc ^. #name) (tc ^. #arguments))-          [] -> Right (responseText resp, Finish),+          [] -> Right (responseText resp, ProposeFinish)+          (tc : tcs) ->+            Right+              ( responseText resp,+                ProposeCalls (fmap (\c -> (c ^. #name, c ^. #arguments)) (tc :| tcs))+              ),       renderExtract = \i traj ->         let sys =               getInstruction sig@@ -439,6 +476,7 @@         <> maybe "" ("; observation: " <>) (observation s)     renderAction Finish = "finish"     renderAction (CallTool nm args) = "call " <> nm <> " " <> encodeText args+    renderAction Summarized = "summary of earlier steps"  -- | The tool menu: each tool's name, description, and compact argument schema. toolMenu :: ToolRegistry -> Text@@ -512,6 +550,12 @@       Right (CallTool nm (maybe (Object KM.empty) id (KM.lookup "args" o)))   | otherwise = Left "action must be {\"finish\":true} or {\"tool\":..,\"args\":..}" parseAction _ = Left "action must be a JSON object"++actionToProposal :: (Text, Action) -> (Text, Proposal)+actionToProposal (th, Finish) = (th, ProposeFinish)+actionToProposal (th, CallTool nm args) = (th, ProposeCalls ((nm, args) :| []))+actionToProposal (_, Summarized) =+  error "internal invariant violated: Summarized is never parsed from model output"  -- | Strip a leading/trailing Markdown code fence (```… / ```json … ```), if any, -- so a fenced JSON reply still decodes. Falls back to the input unchanged.

@@ -25,8 +25,8 @@   ) where -import Baikai (ToolCall, _Model, _ToolCall)-import Control.Lens ((&), (.~))+import Baikai (Model, Response, ToolCall, Usage, _Model, _ToolCall)+import Control.Lens ((&), (.~), (^.)) import Data.Aeson (Value (..), eitherDecodeStrict) import Data.Aeson.KeyMap qualified as KM import Data.Generics.Labels ()@@ -36,27 +36,35 @@ import Data.Text.Encoding (encodeUtf8) import Data.Vector qualified as V import Effectful (Eff, (:>))-import Effectful.Error.Static (Error, throwError)+import Effectful.Error.Static (Error, catchError, throwError) import Shikumi.Adapter (ToPrompt (toPrompt), responseText)-import Shikumi.Agent.ReAct (Action (..), Step (..), Termination (..), Trajectory (..), renderTrajectory)+import Shikumi.Agent.ReAct (Action (..), Step (..), Termination (..), Trajectory (..), renderStepLine, renderTrajectory, summaryStep) import Shikumi.CodeExec.Interpreter (CodeInterpreter (..), restrictedInterpreter) import Shikumi.CodeExec.Prompt (encodeText, schemaInstruction, simpleContext, stripFences)-import Shikumi.Error (ShikumiError)+import Shikumi.Compaction (CompactionConfig (..), compactTail, defaultCompactionConfig, usageExceedsWindow)+import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (LLM, complete) import Shikumi.Program (Program (FMap), embed) import Shikumi.Schema (FromModel, ToSchema, Validatable, parseOutput, toSchema) import Shikumi.Signature (Signature, getInstruction) import Shikumi.Tool (ToolRegistry, registryTools, renderToolError, runToolCall, someToolDescription, someToolName, someToolSchema) --- | How @codeAct@ runs: the hard iteration cap and the sandbox.+-- | How @codeAct@ runs: the hard iteration cap, the sandbox, and trajectory+-- compaction for long runs. data CodeActConfig = CodeActConfig   { maxIters :: !Int,-    interpreter :: !CodeInterpreter+    interpreter :: !CodeInterpreter,+    compaction :: !CompactionConfig   }  -- | Five iterations, the hermetic 'restrictedInterpreter'. defaultCodeActConfig :: CodeActConfig-defaultCodeActConfig = CodeActConfig {maxIters = 5, interpreter = restrictedInterpreter}+defaultCodeActConfig =+  CodeActConfig+    { maxIters = 5,+      interpreter = restrictedInterpreter,+      compaction = defaultCompactionConfig+    }  -- | Build a @codeAct@ agent returning the typed answer, dropping the trajectory. codeAct ::@@ -85,8 +93,8 @@   i ->   Eff es (o, Trajectory) codeActLoop cfg sig reg i = do-  traj <- loop 0 []-  o <- extract traj+  traj0 <- loop 0 []+  (o, traj) <- extract traj0   pure (o, traj)   where     loop :: Int -> [Step] -> Eff es Trajectory@@ -94,16 +102,16 @@       | iter >= maxIters cfg =           pure (Trajectory (V.fromList (reverse acc)) (TerminatedMaxIters iter))       | otherwise = do-          let (ctx, opts) = simpleContext turnSys (turnUser acc)-          resp <- complete _Model ctx opts+          (accForPrompt, resp) <- completeTurnRecover acc           case parseCodeReply (responseText resp) of-            Left perr -> loop (iter + 1) (correctiveStep perr : acc)+            Left perr -> loop (iter + 1) (correctiveStep perr : accForPrompt)             Right (code, finished) -> do               (act, obs) <- runAction code               let step = Step {thought = "", action = act, observation = Just obs}+              acc' <- compactAcc (resp ^. #model) (resp ^. #message . #usage) (step : accForPrompt)               if finished-                then pure (Trajectory (V.fromList (reverse (step : acc))) TerminatedFinish)-                else loop (iter + 1) (step : acc)+                then pure (Trajectory (V.fromList (reverse acc')) TerminatedFinish)+                else loop (iter + 1) acc'      -- A tool call snippet (call("name", args)) dispatches through runToolCall; any     -- other snippet runs in the sandbox. Both produce an observation text.@@ -114,15 +122,57 @@         pure (CallTool nm args, either renderToolError id res)       Nothing -> do         r <- runCode (interpreter cfg) code-        pure (CallTool "exec" (String code), either id id r)+        pure (CallTool "exec" (String code), either ("Error: code failed: " <>) id r) -    extract :: Trajectory -> Eff es o+    extract :: Trajectory -> Eff es (o, Trajectory)     extract traj = do       let prompt = "Task:\n" <> toPrompt i <> "\n\nTrajectory:\n" <> renderTrajectory traj           (ctx, opts) = simpleContext extractSys prompt-      resp <- complete _Model ctx opts-      either throwError pure (parseOutput (stripFences (responseText resp)))+      (trajForExtract, resp) <-+        catchError+          ((traj,) <$> complete _Model ctx opts)+          ( \_cs -> \case+              e@(ContextWindowExceeded {})+                | not (enabled (compaction cfg)) -> throwError e+              ContextWindowExceeded {} -> do+                compacted <- forceCompactTrajectory traj+                let prompt' = "Task:\n" <> toPrompt i <> "\n\nTrajectory:\n" <> renderTrajectory compacted+                    (ctx', opts') = simpleContext extractSys prompt'+                (compacted,) <$> complete _Model ctx' opts'+              e -> throwError e+          )+      o <- either throwError pure (parseOutput (stripFences (responseText resp)))+      pure (o, trajForExtract) +    completeTurnRecover :: [Step] -> Eff es ([Step], Response)+    completeTurnRecover acc = do+      let (ctx, opts) = simpleContext turnSys (turnUser acc)+      catchError+        ((acc,) <$> complete _Model ctx opts)+        ( \_cs -> \case+            e@(ContextWindowExceeded {})+              | not (enabled (compaction cfg)) -> throwError e+            ContextWindowExceeded {} -> do+              compacted <- forceCompactAcc acc+              let (ctx', opts') = simpleContext turnSys (turnUser compacted)+              (compacted,) <$> complete _Model ctx' opts'+            e -> throwError e+        )++    compactAcc :: Model -> Usage -> [Step] -> Eff es [Step]+    compactAcc model usage acc+      | usageExceedsWindow (compaction cfg) model usage = forceCompactAcc acc+      | otherwise = pure acc++    forceCompactAcc :: [Step] -> Eff es [Step]+    forceCompactAcc acc =+      reverse <$> compactTail (compaction cfg) _Model renderStepLine summaryStep (reverse acc)++    forceCompactTrajectory :: Trajectory -> Eff es Trajectory+    forceCompactTrajectory traj = do+      compacted <- compactTail (compaction cfg) _Model renderStepLine summaryStep (V.toList (steps traj))+      pure (traj {steps = V.fromList compacted})+     turnUser acc =       "Task:\n"         <> toPrompt i@@ -193,6 +243,6 @@ codeActGuide :: Text codeActGuide =   "Each turn, reply with exactly one JSON object {\"code\": \"<snippet>\", \"finished\": <true|false>}. "-    <> "The snippet runs in a restricted interpreter (arithmetic + - * /, strings with ++ and "-    <> "len/upper/lower, lists with sum/length/concat). To call a tool, make the snippet exactly "+    <> "The snippet runs in a restricted interpreter (arithmetic + - * / with unary minus, "+    <> "strings with escapes, ++, and len/upper/lower, lists with sum/length/concat). To call a tool, make the snippet exactly "     <> "call(\"<toolName>\", <argsJSON>). Set finished to true once you have the answer."

@@ -22,19 +22,23 @@ -- to enforce, at minimum: no network; no host filesystem access beyond a single fresh -- scratch dir; no environment inheritance; CPU/memory/wall-clock limits (killing the -- child and surfacing a 'Shikumi.Error.Timeout'); and loud failure (any limit breach--- becomes a 'Shikumi.Error.ShikumiError', never a silent empty result). Because such--- a subprocess needs @IOE@, which the @Embed@ row lacks, it could only be offered--- through a separate @IOE@-bearing entry point, never inside the composable--- @programOfThought@/@codeAct@ programs.+-- becomes a 'Shikumi.Error.ShikumiError', never a silent empty result). The effect+-- row does not type-enforce purity: the built-in tool environments already perform+-- real IO inside the same row via 'Shikumi.Tool.Env.toolIO' and+-- 'Shikumi.Tool.Web.httpIO'. The hermeticity of the shipped interpreters is a+-- property of their construction, so any future subprocess interpreter must be+-- gated by explicit configuration and documentation, not assumed impossible by the+-- types. -- -- == The restricted DSL -- -- A single expression (optionally prefixed @result = @), built from: integer and--- rational literals and @+ - * /@ with parentheses; string literals with @++@--- concatenation and the functions @len@, @upper@, @lower@; and list literals @[a, b,--- …]@ with @sum@, @length@, @concat@. The value of the expression is rendered to--- text as the output. A parse error, an unknown identifier/function, a type error,--- division by zero, or exceeding the step cap is returned as @Left \<message\>@.+-- rational literals, unary minus, and @+ - * /@ with parentheses; string literals+-- with @\"@, @\\@, @\n@, and @\t@ escapes plus @++@ concatenation and the functions+-- @len@, @upper@, @lower@; and list literals @[a, b, …]@ with @sum@, @length@,+-- @concat@. The value of the expression is rendered to text as the output. A parse+-- error, an unknown identifier/function, a type error, division by zero, or+-- exceeding the step cap is returned as @Left \<message\>@. module Shikumi.CodeExec.Interpreter   ( -- * The interpreter value     CodeInterpreter (..),@@ -142,11 +146,7 @@            in case readNum numStr of                 Just r -> (TNum r :) <$> go rest                 Nothing -> Left ("bad number literal: " <> T.pack numStr)-      | c == '"' =-          let (str, rest) = break (== '"') cs-           in case rest of-                ('"' : rest') -> (TStr (T.pack str) :) <$> go rest'-                _ -> Left "unterminated string literal"+      | c == '"' = lexString [] cs       | isAlpha c || c == '_' =           let (ident, rest) = span (\x -> isAlphaNum x || x == '_') (c : cs)            in (identTok ident :) <$> go rest@@ -167,6 +167,14 @@     identTok s = TIdent (T.pack s)     readNum :: String -> Maybe Rational     readNum s = (fromInteger <$> (readMaybe s :: Maybe Integer)) <|> (toRational <$> (readMaybe s :: Maybe Double))+    lexString _ [] = Left "unterminated string literal"+    lexString acc ('"' : rest) = (TStr (T.pack (reverse acc)) :) <$> go rest+    lexString acc ('\\' : '"' : rest) = lexString ('"' : acc) rest+    lexString acc ('\\' : '\\' : rest) = lexString ('\\' : acc) rest+    lexString acc ('\\' : 'n' : rest) = lexString ('\n' : acc) rest+    lexString acc ('\\' : 't' : rest) = lexString ('\t' : acc) rest+    lexString _ ('\\' : esc : _) = Left ("unsupported string escape: \\" <> T.singleton esc)+    lexString acc (x : rest) = lexString (x : acc) rest  -- --------------------------------------------------------------------------- -- Parser (recursive descent)@@ -218,6 +226,7 @@     goMul l ts = Right (l, ts)  parseFactor :: P Expr+parseFactor (TMinus : ts) = parseFactor ts >>= \(e, ts') -> Right (EBin Sub (ENum 0) e, ts') parseFactor (TNum n : ts) = Right (ENum n, ts) parseFactor (TStr s : ts) = Right (EStr s, ts) parseFactor (TLParen : ts) = do

@@ -83,9 +83,7 @@         Left err           | iter + 1 >= maxIters cfg ->               throwError-                ( ProviderFailure-                    ("programOfThought: code failed after " <> tshow (iter + 1) <> " attempts: " <> err)-                )+                (CodeExecFailed ("programOfThought: code failed after " <> tshow (iter + 1) <> " attempts: " <> err))           | otherwise -> go (iter + 1) (Just (code, err))      -- Generate (first attempt) or regenerate (with the previous code + error).@@ -121,8 +119,9 @@ dslGuide :: Text dslGuide =   "Write a snippet in a restricted language that computes the answer. It supports "-    <> "integer/rational arithmetic (+ - * /) with parentheses, string literals with ++ and "-    <> "len/upper/lower, and lists with sum/length/concat. The value of the final expression "+    <> "integer/rational arithmetic (+ - * /), unary minus, and parentheses; string literals "+    <> "with escapes (\\\", \\\\, \\n, \\t), ++, len/upper/lower; and lists with "+    <> "sum/length/concat. The value of the final expression "     <> "(optionally written `result = <expr>`) is the answer."  tshow :: (Show a) => a -> Text

@@ -42,6 +42,7 @@      -- * The typed error and the wire round-trip     ToolError (..),+    isInfraToolError,     renderToolError,     runToolCall,   )@@ -61,7 +62,7 @@ import Data.Vector (Vector) import Data.Vector qualified as V import Effectful (Eff, (:>))-import Effectful.Error.Static (Error, catchError)+import Effectful.Error.Static (Error, catchError, throwError) import Shikumi.Error (ShikumiError (..)) import Shikumi.LLM (LLM) import Shikumi.Schema (FromModel, ToSchema, Validatable, fromModelChecked, toSchema)@@ -134,9 +135,10 @@ lowerSomeTool (SomeTool t) = lowerTool t  -- | Run an erased tool against a raw JSON arguments object: decode to the hidden--- @i@, run the body, encode the @o@ to text. Total: a decode failure becomes--- 'ToolArgsInvalid' and a body that throws a 'ShikumiError' becomes 'ToolRunFailed'--- — it never throws to the caller.+-- @i@, run the body, encode the @o@ to text. A decode failure becomes+-- 'ToolArgsInvalid', a body that throws a recoverable 'ShikumiError' becomes+-- 'ToolRunFailed', and a body that throws an infrastructure error+-- ('isInfraToolError') rethrows to abort the caller's loop. runErased ::   (LLM :> es, Error ShikumiError :> es) =>   SomeTool ->@@ -147,7 +149,10 @@     Left err -> pure (Left (ToolArgsInvalid (name t) (shikumiErrorText err)))     Right i ->       (Right . encodeText <$> run t i)-        `catchError` \_cs e -> pure (Left (ToolRunFailed (name t) (shikumiErrorText e)))+        `catchError` \_cs e ->+          if isInfraToolError e+            then throwError e+            else pure (Left (ToolRunFailed (name t) (shikumiErrorText e)))  -- | A heterogeneous tool set, keyed by tool name for O(log n) dispatch. newtype ToolRegistry = ToolRegistry (Map Text SomeTool)@@ -176,10 +181,10 @@ -- The typed error and the wire round-trip -- --------------------------------------------------------------------------- --- | A tool-call failure carried as a /value/, never an exception. The agent feeds--- the rendered text back to the model as an observation so it can recover, and--- records it in the trajectory; only infrastructure faults bubble up as a--- 'ShikumiError'.+-- | A tool-call failure carried as a /value/. The agent feeds the rendered text+-- back to the model as an observation so it can recover, and records it in the+-- trajectory; infrastructure faults ('isInfraToolError': budget and+-- context-window exhaustion) bubble up as a 'ShikumiError' and abort the loop. data ToolError   = -- | the model named a tool the registry does not have     ToolNotFound !Text@@ -226,3 +231,16 @@   ContextWindowExceeded t -> t   Timeout t -> t   BudgetExceeded t -> t+  CodeExecFailed t -> t++-- | Which 'ShikumiError's must escape the agent loop rather than become+-- observations. Budget and context-window exhaustion are infrastructure faults:+-- the model cannot recover from them by reading an observation, and continuing+-- the loop would either overspend (budget) or deterministically re-fail+-- (context window). Everything else is a tool-level failure the model may route+-- around, so it is fed back as a 'ToolRunFailed' observation.+isInfraToolError :: ShikumiError -> Bool+isInfraToolError = \case+  BudgetExceeded {} -> True+  ContextWindowExceeded {} -> True+  _ -> False

@@ -46,7 +46,7 @@ import GHC.Generics (Generic) import Shikumi.Adapter (ToPrompt) import Shikumi.Error (ShikumiError (..))-import Shikumi.Schema (FromModel (..), ToSchema (..), fromModel)+import Shikumi.Schema (FromModel (..), ToSchema (..), Validatable, fromModel) import Shikumi.Tool (Tool, mkTool) import Shikumi.Tool.Env   ( EnvRow,@@ -69,7 +69,7 @@     limit :: !(Maybe Int)   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (ToSchema, FromModel, ToPrompt)+  deriving anyclass (ToSchema, FromModel, ToPrompt, Validatable)  data ReadResp = ReadResp   { content :: !Text,@@ -84,7 +84,7 @@     content :: !Text   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (ToSchema, FromModel, ToPrompt)+  deriving anyclass (ToSchema, FromModel, ToPrompt, Validatable)  data WriteResp = WriteResp   { path :: !Text,@@ -100,7 +100,7 @@     replaceAll :: !(Maybe Bool)   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (ToSchema, FromModel, ToPrompt)+  deriving anyclass (ToSchema, FromModel, ToPrompt, Validatable)  data EditResp = EditResp   { path :: !Text,@@ -116,11 +116,12 @@     ignoreCase :: !(Maybe Bool)   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (ToPrompt)+  deriving anyclass (ToPrompt, Validatable)  instance ToSchema GrepReq where   toSchema _ =     toolInputSchema+      ["pattern"]       [ ("pattern", toSchema (Proxy :: Proxy Text)),         ("path", toSchema (Proxy :: Proxy (Maybe Text))),         ("glob", toSchema (Proxy :: Proxy (Maybe Text))),@@ -157,11 +158,12 @@     path :: !(Maybe Text)   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (ToPrompt)+  deriving anyclass (ToPrompt, Validatable)  instance ToSchema GlobReq where   toSchema _ =     toolInputSchema+      ["pattern"]       [ ("pattern", toSchema (Proxy :: Proxy Text)),         ("path", toSchema (Proxy :: Proxy (Maybe Text)))       ]@@ -189,7 +191,7 @@         start = max 0 (maybe 0 id (req ^. #offset))         afterOffset = drop start allLines         selected = maybe afterOffset (`take` afterOffset) (req ^. #limit)-        wasTruncated = start > 0 || length selected < length afterOffset+        wasTruncated = length selected < length afterOffset     pure ReadResp {content = T.unlines selected, lineCount = length selected, truncated = wasTruncated}  writeTool :: ToolEnv -> Tool WriteReq WriteResp@@ -286,15 +288,15 @@         }   if result ^. #exitCode == 0     then do-      let found = take maxResults (filter (not . T.null) (T.lines (result ^. #stdout)))-      pure (Just GlobResp {paths = sort found, truncated = length found >= maxResults})+      let (found, wasTruncated) = capResults maxResults (filter (not . T.null) (T.lines (result ^. #stdout)))+      pure (Just GlobResp {paths = sort found, truncated = wasTruncated})     else pure Nothing  grepFallback :: (EnvRow es) => ToolEnv -> Text -> GrepReq -> Eff es GrepResp grepFallback env root req = do   regex <- compileRegex (req ^. #patternText) (maybe False id (req ^. #ignoreCase))   paths <- walkFiles env root-  let globOk p = maybe True (`globMatches` p) (req ^. #glob)+  let globOk p = maybe True (\g -> globMatches root g p) (req ^. #glob)   matches <-     fmap concat $       traverse@@ -304,14 +306,14 @@               else pure []         )         paths-  let limited = take maxResults matches-  pure GrepResp {matches = limited, truncated = length matches > maxResults}+  let (limited, wasTruncated) = capResults maxResults matches+  pure GrepResp {matches = limited, truncated = wasTruncated}  globFallback :: (EnvRow es) => ToolEnv -> Text -> Text -> Eff es GlobResp globFallback env root pat = do   paths <- walkFiles env root-  let found = sort (take maxResults (filter (globMatches pat) paths))-  pure GlobResp {paths = found, truncated = length found >= maxResults}+  let (found, wasTruncated) = capResults maxResults (filter (globMatches root pat) paths)+  pure GlobResp {paths = sort found, truncated = wasTruncated}  grepFile :: (EnvRow es) => ToolEnv -> Regex -> Text -> Eff es [GrepMatch] grepFile env regex filePath = do@@ -330,6 +332,8 @@             ]     _ -> pure [] +-- | Walk regular files under a root without following directory symlinks. This+-- mirrors fd's default posture and prevents symlink cycles from multiplying work. walkFiles :: (EnvRow es) => ToolEnv -> Text -> Eff es [Text] walkFiles env root = go 0 root   where@@ -341,7 +345,7 @@             traverse               ( \entry -> do                   let child = joinPathText dir (entry ^. #name)-                  if entry ^. #isDir+                  if entry ^. #isDir && not (entry ^. #isSymlink)                     then                       if skipDirName (entry ^. #name)                         then pure []@@ -352,8 +356,8 @@  parseRgJson :: Text -> GrepResp parseRgJson output =-  let matches = take maxResults (mapMaybe parseLine (T.lines output))-   in GrepResp {matches, truncated = length matches >= maxResults}+  let (matches, wasTruncated) = capResults maxResults (mapMaybe parseLine (T.lines output))+   in GrepResp {matches, truncated = wasTruncated}   where     parseLine line = do       Object obj <- either (const Nothing) Just (eitherDecodeStrict (TE.encodeUtf8 line))@@ -376,19 +380,33 @@ regexMatches :: Regex -> Text -> Bool regexMatches regex haystack = matchTest regex (T.unpack haystack) -globMatches :: Text -> Text -> Bool-globMatches pat candidate =-  T.unpack candidate =~ ("^" <> T.unpack (globToRegex pat) <> "$" :: String)+globMatches :: Text -> Text -> Text -> Bool+globMatches root pat candidate+  | "/" `T.isInfixOf` pat = matchGlob pat (relativeTo root candidate)+  | otherwise = matchGlob pat (basenameOf candidate) +matchGlob :: Text -> Text -> Bool+matchGlob pat s =+  T.unpack s =~ ("^" <> T.unpack (globToRegex pat) <> "$" :: String)+ globToRegex :: Text -> Text globToRegex = go . T.unpack   where     go [] = ""+    go ('*' : '*' : '/' : rest) = "(.*/)?" <> go rest     go ('*' : '*' : rest) = ".*" <> go rest     go ('*' : rest) = "[^/]*" <> go rest     go ('?' : rest) = "[^/]" <> go rest     go (c : rest) = T.pack (escapeRegex c) <> go rest +relativeTo :: Text -> Text -> Text+relativeTo root path =+  let rootSlash = T.dropWhileEnd (== '/') root <> "/"+   in maybe path id (T.stripPrefix rootSlash path)++basenameOf :: Text -> Text+basenameOf = snd . T.breakOnEnd "/"+ replaceFirstCount :: Text -> Text -> Text -> (Text, Int) replaceFirstCount old new src =   let (before, after) = T.breakOn old src@@ -442,12 +460,17 @@ throwValidation :: (EnvRow es) => Text -> Eff es a throwValidation = throwError . ValidationFailure -toolInputSchema :: [(Text, Value)] -> Value-toolInputSchema fields =+capResults :: Int -> [a] -> ([a], Bool)+capResults n xs =+  let (kept, rest) = splitAt n xs+   in (kept, not (null rest))++toolInputSchema :: [Text] -> [(Text, Value)] -> Value+toolInputSchema requiredFields fields =   object     [ "type" .= ("object" :: Text),       "properties" .= object (map (\(key, value) -> Key.fromText key .= value) fields),-      "required" .= (["pattern"] :: [Text]),+      "required" .= requiredFields,       "additionalProperties" .= False     ] 

@@ -1,4 +1,11 @@ -- | Built-in shell tool over 'ToolEnv.exec'.+--+-- Security posture: 'bashTool' executes arbitrary model-chosen shell commands+-- through the supplied 'ToolEnv', with whatever filesystem access, environment,+-- and process privileges that environment grants. With 'localToolEnv' this is+-- deliberately non-hermetic host execution for trusted, local, single-operator+-- workflows. Sandboxing is achieved by supplying a confining 'ToolEnv', not by+-- this module. module Shikumi.Tool.Builtin.Shell   ( BashReq (..),     BashResp (..),@@ -12,7 +19,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import Shikumi.Adapter (ToPrompt)-import Shikumi.Schema (FromModel, ToSchema)+import Shikumi.Schema (FromModel, ToSchema, Validatable) import Shikumi.Tool (Tool, mkTool) import Shikumi.Tool.Env (ExecRequest (..), ToolEnv (..)) @@ -23,7 +30,7 @@     stdin :: !(Maybe Text)   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (ToSchema, FromModel, ToPrompt)+  deriving anyclass (ToSchema, FromModel, ToPrompt, Validatable)  data BashResp = BashResp   { exitCode :: !Int,

@@ -12,7 +12,7 @@ import Data.Text (Text) import GHC.Generics (Generic) import Shikumi.Adapter (ToPrompt)-import Shikumi.Schema (FromModel, ToSchema)+import Shikumi.Schema (FromModel, ToSchema, Validatable) import Shikumi.Tool (Tool, mkTool) import Shikumi.Tool.Web (FetchResult, SearchResult, WebClient (..)) @@ -21,14 +21,14 @@     maxBytes :: !(Maybe Int)   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (ToSchema, FromModel, ToPrompt)+  deriving anyclass (ToSchema, FromModel, ToPrompt, Validatable)  data SearchReq = SearchReq   { query :: !Text,     maxResults :: !(Maybe Int)   }   deriving stock (Generic, Show, Eq)-  deriving anyclass (ToSchema, FromModel, ToPrompt)+  deriving anyclass (ToSchema, FromModel, ToPrompt, Validatable)  webFetchTool :: WebClient -> Tool FetchReq FetchResult webFetchTool client =

@@ -6,6 +6,13 @@ -- Filesystem and process-backed tools should depend on this record instead of -- calling the host operating system directly. A future sandbox can provide a -- different 'ToolEnv' value while the tool definitions stay unchanged.+--+-- Security posture: 'localToolEnv' is deliberately non-hermetic. It has full+-- access to the host filesystem paths and inherited environment visible to the+-- current process, and it can execute arbitrary shell commands with the current+-- user's privileges. Its filesystem and process IO is performed inside the+-- @(LLM, Error ShikumiError)@ row via 'unsafeEff_'. Supply a different 'ToolEnv'+-- to confine tools; this module is the sandboxing seam, not the sandbox. module Shikumi.Tool.Env   ( Path,     EnvRow,@@ -68,7 +75,8 @@  data DirEntry = DirEntry   { name :: !Text,-    isDir :: !Bool+    isDir :: !Bool,+    isSymlink :: !Bool   }   deriving stock (Generic, Show, Eq)   deriving anyclass (ToJSON)@@ -101,7 +109,7 @@  localExec :: (EnvRow es) => ExecRequest -> Eff es ExecResult localExec req = do-  let effectiveTimeoutMs = timeoutMsOrDefault (req ^. #timeoutMs)+  let effectiveTimeoutMs = effectiveTimeout (req ^. #timeoutMs)   result <-     toolIO "exec" $       Timeout.timeout (effectiveTimeoutMs * 1000) $@@ -145,8 +153,10 @@   names <- Dir.listDirectory dir   traverse     ( \entry -> do-        isDir <- Dir.doesDirectoryExist (dir <> "/" <> entry)-        pure DirEntry {name = T.pack entry, isDir}+        let child = dir <> "/" <> entry+        isSymlink <- Dir.pathIsSymbolicLink child+        isDir <- Dir.doesDirectoryExist child+        pure DirEntry {name = T.pack entry, isDir, isSymlink}     )     names @@ -170,8 +180,17 @@     Left (err :: IOException) ->       throwError (ProviderFailure ("tool env: " <> label <> ": " <> T.pack (show err))) -timeoutMsOrDefault :: Maybe Int -> Int-timeoutMsOrDefault = maybe 60000 id+-- | Clamp a model-supplied timeout into [1 ms, 'maxExecTimeoutMs']. Unclamped,+-- a non-positive value disables the timeout entirely and a huge value can+-- overflow the microsecond multiplication in 'localExec'.+effectiveTimeout :: Maybe Int -> Int+effectiveTimeout = max 1 . min maxExecTimeoutMs . maybe defaultExecTimeoutMs id++defaultExecTimeoutMs :: Int+defaultExecTimeoutMs = 60000++maxExecTimeoutMs :: Int+maxExecTimeoutMs = 600000  exitCodeInt :: ExitCode -> Int exitCodeInt ExitSuccess = 0

@@ -5,23 +5,34 @@ -- -- 'web_fetch' is functional with only a TLS 'Manager'. 'web_search' requires a -- configured provider because search APIs need provider-specific credentials.+--+-- Security posture: the default fetch policy denies non-http(s) schemes and the+-- most common SSRF destinations (loopback, link-local, and RFC-1918 private host+-- literals) before opening a connection, and caps response bytes while reading.+-- It does not resolve hostnames to detect private addresses behind DNS; supply a+-- stricter 'FetchPolicy' through 'localWebClientWith' when deployments need that. module Shikumi.Tool.Web   ( FetchResult (..),     SearchHit (..),     SearchResult (..),     SearchConfig (..),+    FetchPolicy (..),+    defaultFetchPolicy,+    checkFetchUrl,+    readCapped,     WebClient (..),     localWebClient,+    localWebClientWith,     newTlsManager,     Manager,   ) where -import Control.Exception (try)+import Control.Exception (SomeException, try) import Control.Lens ((^.)) import Data.Aeson (FromJSON, ToJSON, eitherDecode)+import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as B8-import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as T@@ -34,18 +45,23 @@ import Network.HTTP.Client   ( HttpException,     Manager,+    Request,+    brRead,+    host,     httpLbs,     parseRequest,     responseBody,     responseHeaders,     responseStatus,     setQueryString,+    withResponse,   ) import Network.HTTP.Client.TLS qualified as TLS import Network.HTTP.Types.Header (ResponseHeaders) import Network.HTTP.Types.Status (statusCode) import Shikumi.Error (ShikumiError (..)) import Shikumi.Tool.Env (EnvRow)+import Text.Read (readMaybe)  data FetchResult = FetchResult   { status :: !Int,@@ -75,38 +91,114 @@   deriving stock (Generic, Show, Eq)   deriving anyclass (ToJSON) +data FetchPolicy = FetchPolicy+  { maxResponseBytes :: !Int,+    checkUrl :: !(Text -> Either Text ())+  }++defaultFetchPolicy :: FetchPolicy+defaultFetchPolicy =+  FetchPolicy+    { maxResponseBytes = 5 * 1024 * 1024,+      checkUrl = defaultCheckUrl+    }+ data WebClient = WebClient   { webFetch :: forall es. (EnvRow es) => Text -> Maybe Int -> Eff es FetchResult,     webSearch :: forall es. (EnvRow es) => Text -> Maybe Int -> Eff es SearchResult   }  localWebClient :: Manager -> Maybe SearchConfig -> WebClient-localWebClient manager searchConfig =+localWebClient = localWebClientWith defaultFetchPolicy++localWebClientWith :: FetchPolicy -> Manager -> Maybe SearchConfig -> WebClient+localWebClientWith policy manager searchConfig =   WebClient-    { webFetch = \url maxBytes -> localFetch manager url maxBytes,+    { webFetch = \url maxBytes -> localFetch policy manager url maxBytes,       webSearch = \query maxResults -> localSearch manager searchConfig query maxResults     }  newTlsManager :: IO Manager newTlsManager = TLS.newTlsManager -localFetch :: (EnvRow es) => Manager -> Text -> Maybe Int -> Eff es FetchResult-localFetch manager url maxBytes = do-  response <- httpIO "web_fetch" $ do-    request <- parseRequest (T.unpack url)-    httpLbs request manager-  let maxBodyBytes = max 0 (maybe 100000 id maxBytes)-      rawBody = responseBody response-      limitedBody = LBS.take (fromIntegral maxBodyBytes) rawBody-      truncated = LBS.length rawBody > fromIntegral maxBodyBytes-      decodedBody = TE.decodeUtf8With lenientDecode (LBS.toStrict limitedBody)-  pure-    FetchResult-      { status = statusCode (responseStatus response),-        contentType = contentTypeOf (responseHeaders response),-        body = decodedBody,-        truncated-      }+localFetch :: (EnvRow es) => FetchPolicy -> Manager -> Text -> Maybe Int -> Eff es FetchResult+localFetch policy manager url maxBytes =+  case checkFetchUrl policy url of+    Left reason ->+      throwError (ValidationFailure ("web_fetch: refused by fetch policy: " <> reason))+    Right () -> do+      let maxBodyBytes = min (maxResponseBytes policy) (max 0 (maybe 100000 id maxBytes))+      (st, ct, bodyBytes, wasTruncated) <- httpIO "web_fetch" $ do+        request <- parseRequest (T.unpack url)+        withResponse request manager $ \response -> do+          (bytes, cut) <- readCapped maxBodyBytes (brRead (responseBody response))+          pure (statusCode (responseStatus response), contentTypeOf (responseHeaders response), bytes, cut)+      let decodedBody = TE.decodeUtf8With lenientDecode bodyBytes+      pure+        FetchResult+          { status = st,+            contentType = ct,+            body = decodedBody,+            truncated = wasTruncated+          }++checkFetchUrl :: FetchPolicy -> Text -> Either Text ()+checkFetchUrl policy = checkUrl policy++defaultCheckUrl :: Text -> Either Text ()+defaultCheckUrl url+  | not ("http://" `T.isPrefixOf` lowerUrl || "https://" `T.isPrefixOf` lowerUrl) =+      Left "scheme must be http or https"+  | otherwise =+      case parseRequest (T.unpack url) :: Either SomeException Request of+        Left err -> Left ("invalid URL: " <> T.pack (show err))+        Right request ->+          let hostText = T.toLower (TE.decodeUtf8With lenientDecode (host request))+           in if deniedHost hostText+                then Left ("host is not allowed by default fetch policy: " <> hostText)+                else Right ()+  where+    lowerUrl = T.toLower url++deniedHost :: Text -> Bool+deniedHost h =+  h+    `elem` [ "localhost",+             "localhost.",+             "0.0.0.0",+             "::1",+             "[::1]"+           ]+    || "127." `T.isPrefixOf` h+    || "169.254." `T.isPrefixOf` h+    || "10." `T.isPrefixOf` h+    || "192.168." `T.isPrefixOf` h+    || is172Private h++is172Private :: Text -> Bool+is172Private h =+  case traverse readInt (T.splitOn "." h) of+    Just [first, second, _, _] -> first == 172 && second >= 16 && second <= 31+    _ -> False+  where+    readInt :: Text -> Maybe Int+    readInt = readMaybe . T.unpack++readCapped :: Int -> IO BS.ByteString -> IO (BS.ByteString, Bool)+readCapped cap next = go 0 []+  where+    go n acc = do+      chunk <- next+      if BS.null chunk+        then pure (BS.concat (reverse acc), False)+        else do+          let n' = n + BS.length chunk+          if n' >= cap+            then do+              let keep = BS.take (cap - n) chunk+              more <- if n' > cap then pure True else (not . BS.null) <$> next+              pure (BS.concat (reverse (keep : acc)), more)+            else go n' (chunk : acc)  localSearch :: (EnvRow es) => Manager -> Maybe SearchConfig -> Text -> Maybe Int -> Eff es SearchResult localSearch _ Nothing _ _ =

@@ -25,7 +25,7 @@     defaultReActConfig,     reactWithTrajectory,   )-import Shikumi.Schema (FromModel, ToSchema)+import Shikumi.Schema (FromModel, ToSchema, Validatable) import Shikumi.Signature (Signature, mkSignature) import Shikumi.Tool.Builtin (builtinRegistry) import Shikumi.Tool.Env (localToolEnv)@@ -43,6 +43,8 @@   deriving stock (Generic, Show, Eq)   deriving anyclass (ToSchema, FromModel, ToPrompt) +instance Validatable WorkAnswer+ tests :: TestTree tests =   testGroup@@ -122,6 +124,7 @@ toolNames = foldMap $ \step -> case action step of   CallTool name _ -> [name]   Finish -> []+  Summarized -> []  assertObservation :: String -> Text -> Step -> IO () assertObservation label needle step =

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}  -- | EP-27 M3: @codeAct@ — a multi-turn loop whose action is a code snippet that may -- call provided tools. Verified hermetically: a snippet calls a registered tool@@ -7,20 +8,30 @@ -- typed answer is extracted. module CodeActSpec (tests) where +import Baikai (_Model)+import Control.Lens ((&), (.~)) import Data.Aeson (object, (.=))+import Data.Generics.Labels () import Data.Text (Text)+import Data.Text qualified as T import Data.Vector qualified as V+import Effectful (runEff)+import Effectful.Error.Static (runErrorNoCallStack) import GHC.Generics (Generic)-import MockLLM (mkTextResponse, runAgent)+import MockLLM (mkTextResponse, mkUsageResponse, runAgent, runMockLLMThrowingOn) import Shikumi.Adapter (ToPrompt)-import Shikumi.Agent.ReAct (Step (..), Termination (..), Trajectory (..))-import Shikumi.CodeExec.CodeAct (codeActWithTrajectory, defaultCodeActConfig)+import Shikumi.Agent.ReAct (Action (..), Step (..), Termination (..), Trajectory (..))+import Shikumi.CodeExec.CodeAct (CodeActConfig (..), codeActWithTrajectory, defaultCodeActConfig)+import Shikumi.CodeExec.Interpreter (CodeInterpreter (..)) import Shikumi.CodeExec.Prompt (encodeText)-import Shikumi.Schema (FromModel, ToSchema)+import Shikumi.Compaction (CompactionConfig (..), defaultCompactionConfig)+import Shikumi.Error (ShikumiError (..))+import Shikumi.Program (runProgram)+import Shikumi.Schema (FromModel, ToSchema, Validatable) import Shikumi.Signature (Signature, mkSignature) import Shikumi.Tool (SomeTool (..), Tool, ToolRegistry, mkRegistry, mkTool) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))  newtype Task = Task {task :: Text}   deriving stock (Generic, Show, Eq)@@ -30,10 +41,14 @@   deriving stock (Generic, Show, Eq)   deriving anyclass (ToSchema, FromModel, ToPrompt) +instance Validatable CalcAnswer+ newtype AddIn = AddIn {n :: Int}   deriving stock (Generic, Show, Eq)   deriving anyclass (ToSchema, FromModel) +instance Validatable AddIn+ -- | A tool that adds one to its argument. addOneTool :: Tool AddIn Int addOneTool = mkTool "addOne" "Add one to the integer n." (\(AddIn k) -> pure (k + 1))@@ -41,6 +56,9 @@ registry :: ToolRegistry registry = mkRegistry [SomeTool addOneTool] +alwaysFail :: CodeInterpreter+alwaysFail = CodeInterpreter (\_ -> pure (Left "sandbox disabled"))+ sig :: Signature Task CalcAnswer sig = mkSignature "Answer the task, using tools from code when helpful." @@ -70,5 +88,80 @@             termination traj @?= TerminatedFinish             -- the first step's observation is the tool result (addOne 41 = 42)             observation (V.head (steps traj)) @?= Just "42"-          Left e -> assertFailure ("expected a typed answer, got " <> show e)+          Left e -> assertFailure ("expected a typed answer, got " <> show e),+      testCase "interpreter errors are tagged in observations" $ do+        let cfg = defaultCodeActConfig {interpreter = alwaysFail}+            script =+              [ mkTextResponse (turn "1 / 0" True),+                mkTextResponse "{\"value\": 0}"+              ]+        out <- runAgent script (codeActWithTrajectory cfg sig registry) (Task "try bad code")+        case out of+          Right (_answer, traj) -> case V.toList (steps traj) of+            [Step {observation = Just obs}] ->+              assertBool "observation tags code failure" ("Error: code failed: sandbox disabled" `T.isInfixOf` obs)+            other -> assertFailure ("expected one code step, got " <> show other)+          Left e -> assertFailure ("expected a typed answer, got " <> show e),+      testCase "usage-triggered compaction injects a summarized CodeAct step" $ do+        let cfg =+              defaultCodeActConfig+                { maxIters = 3,+                  compaction = defaultCompactionConfig {reserveTokens = 10, keepRecent = 1}+                }+            model = _Model & #contextWindow .~ 100+            script =+              [ mkUsageResponse model 10 (turn "result = 1" False),+                mkUsageResponse model 90 (turn "result = 2" False),+                mkTextResponse "summary of the first code step",+                mkUsageResponse model 10 (turn "result = 42" True),+                mkTextResponse "{\"value\": 42}"+              ]+        out <- runAgent script (codeActWithTrajectory cfg sig registry) (Task "compute 42")+        case out of+          Right (answer, traj) -> do+            answer @?= CalcAnswer 42+            assertBool "trajectory contains summary step" (any ((== Summarized) . action) (V.toList (steps traj)))+          Left e -> assertFailure ("expected a typed answer, got " <> show e),+      testCase "context overflow is caught, compacted, and retried once" $ do+        let cfg =+              defaultCodeActConfig+                { maxIters = 3,+                  compaction = defaultCompactionConfig {reserveTokens = 10, keepRecent = 0}+                }+            script =+              [ mkTextResponse (turn "result = 1" False),+                mkTextResponse "reactive summary",+                mkTextResponse (turn "result = 42" True),+                mkTextResponse "{\"value\": 42}"+              ]+            prog = codeActWithTrajectory cfg sig registry+        out <-+          runEff+            . runErrorNoCallStack @ShikumiError+            . runMockLLMThrowingOn [2] (ContextWindowExceeded "context length exceeded") script+            $ runProgram prog (Task "compute 42")+        case out of+          Right (answer, traj) -> do+            answer @?= CalcAnswer 42+            assertBool "trajectory contains reactive summary step" (any ((== Summarized) . action) (V.toList (steps traj)))+          Left e -> assertFailure ("expected a typed answer, got " <> show e),+      testCase "disabled CodeAct compaction propagates context overflow" $ do+        let cfg =+              defaultCodeActConfig+                { maxIters = 3,+                  compaction = defaultCompactionConfig {enabled = False, reserveTokens = 10, keepRecent = 0}+                }+            script =+              [ mkTextResponse (turn "result = 1" False),+                mkTextResponse "unused summary",+                mkTextResponse (turn "result = 42" True),+                mkTextResponse "{\"value\": 42}"+              ]+            prog = codeActWithTrajectory cfg sig registry+        out <-+          runEff+            . runErrorNoCallStack @ShikumiError+            . runMockLLMThrowingOn [2] (ContextWindowExceeded "context length exceeded") script+            $ runProgram prog (Task "compute 42")+        out @?= Left (ContextWindowExceeded "context length exceeded")     ]

@@ -2,6 +2,7 @@  import Baikai (_Model, _Usage) import Control.Lens ((&), (.~))+import Data.Aeson (Value (..)) import Data.Generics.Labels () import Data.Text (Text) import Data.Vector qualified as V@@ -63,6 +64,11 @@           runEffMock [mkTextResponse "S"] $             compactTail cfg _Model id ("summary:" <>) (["e1", "e2", "e3", "e4", "e5", "e6"] :: [Text])         res @?= Right ["summary:S", "e5", "e6"],+      testCase "compactTail with enabled=False is the identity and calls no model" $ do+        let cfg = defaultCompactionConfig {enabled = False, keepRecent = 0}+            items = ["e1", "e2", "e3"] :: [Text]+        res <- runEffMock [] $ compactTail cfg _Model id ("summary:" <>) items+        res @?= Right items,       testCase "agent on tiny window compacts and completes" $ do         let cfg =               defaultReActConfig@@ -85,6 +91,7 @@             termination traj @?= TerminatedFinish             let ss = V.toList (steps traj)             assertBool "trajectory contains a summary step" (any isSummary ss)+            assertBool "summary path does not use empty corrective tool sentinel" (not (any isEmptyToolCall ss))             case ss of               [summary, recent, finish] -> do                 assertBool "first step is summary" (isSummary summary)@@ -118,6 +125,26 @@           Right (_ :: WeatherResp, traj) ->             assertBool "trajectory contains a summary step after recovery" (any isSummary (V.toList (steps traj)))           Left e -> assertFailure ("agent failed: " <> show e),+      testCase "reactive compaction is skipped when disabled" $ do+        let cfg =+              defaultReActConfig+                { maxIters = 5,+                  protocol = ProtocolPrompt,+                  compaction = defaultCompactionConfig {enabled = False, reserveTokens = 10, keepRecent = 0}+                }+            script =+              [ mkUsageResponse (_Model & #contextWindow .~ 100) 10 (callReply "first"),+                mkTextResponse "unused summary",+                mkTextResponse finishReply,+                mkTextResponse extractReply+              ]+            prog = reactWithTrajectory weatherSignature weatherRegistry cfg+        res <-+          runEff+            . runErrorNoCallStack @ShikumiError+            . runMockLLMThrowingOn [2] (ContextWindowExceeded "context length exceeded") script+            $ runProgram prog weatherQuestion+        res @?= Left (ContextWindowExceeded "context length exceeded"),       testCase "extract overflow is caught, compacted, and retried once" $ do         let cfg =               defaultReActConfig@@ -176,4 +203,7 @@ extractReply = "{\"tempC\": 12.0, \"summary\": \"mild\"}"  isSummary :: Step -> Bool-isSummary s = thought s == "(compacted summary of earlier steps)"+isSummary s = action s == Summarized++isEmptyToolCall :: Step -> Bool+isEmptyToolCall s = action s == CallTool "" Null

@@ -8,6 +8,7 @@ import Data.List (find) import Data.Text qualified as T import MockLLM (runEffMock)+import Shikumi.Error (ShikumiError (..)) import Shikumi.Tool.Env   ( DirEntry,     ExecRequest (..),@@ -74,7 +75,21 @@             nestedGone @?= True             execResult ^. #exitCode @?= 0             assertBool "exec stdout includes hello" ("hello" `T.isInfixOf` (execResult ^. #stdout))-            assertBool "cwd returns an absolute path" ("/" `T.isPrefixOf` cwd)+            assertBool "cwd returns an absolute path" ("/" `T.isPrefixOf` cwd),+      testCase "a negative exec timeout is clamped, not disabled" $ do+        result <-+          runEffMock [] $+            envExec+              localToolEnv+              ExecRequest+                { command = "sleep 2",+                  cwd = Nothing,+                  stdin = Nothing,+                  timeoutMs = Just (-1)+                }+        case result of+          Left (Timeout msg) -> assertBool "timeout message names timeout" ("timed out" `T.isInfixOf` msg)+          other -> assertFailure ("expected Timeout for clamped negative timeout, got " <> show other)     ]  freshTempDir :: IO FilePath

@@ -35,7 +35,7 @@ import GHC.Generics (Generic) import MockLLM (mkTextResponse, mkToolCallResponse) import Shikumi.Adapter (ToPrompt)-import Shikumi.Schema (FromModel, ToSchema)+import Shikumi.Schema (FromModel, ToSchema, Validatable) import Shikumi.Signature (Signature, mkSignature) import Shikumi.Tool (SomeTool (..), Tool, ToolRegistry, mkRegistry, mkTool) @@ -47,9 +47,13 @@   deriving stock (Generic, Show, Eq)   deriving anyclass (ToSchema, FromModel, ToPrompt) +instance Validatable WeatherReq+ data WeatherResp = WeatherResp {tempC :: !Double, summary :: !Text}   deriving stock (Generic, Show, Eq)   deriving anyclass (ToSchema, FromModel, ToJSON, ToPrompt)++instance Validatable WeatherResp  newtype AnswerWeatherQuestion = AnswerWeatherQuestion {question :: Text}   deriving stock (Generic, Show, Eq)

@@ -2,9 +2,10 @@  module FsSpec (tests) where -import Control.Exception (bracket)+import Control.Exception (IOException, bracket, try) import Control.Lens ((^.)) import Data.ByteString qualified as BS+import Data.Foldable (traverse_) import Data.List (sort) import Data.Text (Text) import Data.Text qualified as T@@ -119,7 +120,85 @@                 GrepReq {patternText = "[", path = Just (T.pack root), glob = Nothing, ignoreCase = Nothing}           case result of             Left (ValidationFailure msg) -> assertBool "mentions invalid regex" ("invalid regex" `T.isInfixOf` msg)-            other -> assertFailure ("expected ValidationFailure, got " <> show other)+            other -> assertFailure ("expected ValidationFailure, got " <> show other),+      testCase "fast and fallback agree on non-** glob patterns" $+        withTempDir "glob-parity" $ \root -> do+          let top = T.pack (root </> "top.txt")+              nestedDir = T.pack (root </> "sub")+              nested = T.pack (root </> "sub" </> "nested.txt")+          result <-+            runEffMock [] $ do+              envWriteFile localToolEnv top "marker top\n"+              envMkdir localToolEnv nestedDir+              envWriteFile localToolEnv nested "marker nested\n"+              fastGlob <- run (globTool localToolEnv) GlobReq {patternText = "*.txt", path = Just (T.pack root)}+              fallbackGlob <- run (globTool noFastToolEnv) GlobReq {patternText = "*.txt", path = Just (T.pack root)}+              fastGrep <-+                run+                  (grepTool localToolEnv)+                  GrepReq {patternText = "marker", path = Just (T.pack root), glob = Just "*.txt", ignoreCase = Nothing}+              fallbackGrep <-+                run+                  (grepTool noFastToolEnv)+                  GrepReq {patternText = "marker", path = Just (T.pack root), glob = Just "*.txt", ignoreCase = Nothing}+              relativeGlob <- run (globTool noFastToolEnv) GlobReq {patternText = "sub/*.txt", path = Just (T.pack root)}+              pure (fastGlob, fallbackGlob, fastGrep, fallbackGrep, relativeGlob)+          case result of+            Left err -> assertFailure ("glob parity failed: " <> show err)+            Right (fastGlob, fallbackGlob, fastGrep, fallbackGrep, relativeGlob) -> do+              sort (fastGlob ^. #paths) @?= sort [top, nested]+              sort (fallbackGlob ^. #paths) @?= sort [top, nested]+              normalizeMatches (fastGrep ^. #matches) @?= normalizeMatches (fallbackGrep ^. #matches)+              assertBool "grep sees nested txt file" (any (\m -> m ^. #file == nested) (fallbackGrep ^. #matches))+              relativeGlob ^. #paths @?= [nested],+      testCase "read truncated flag reflects omitted trailing lines only" $+        withTempDir "read-truncated" $ \root -> do+          let file = T.pack (root </> "three.txt")+          result <-+            runEffMock [] $ do+              envWriteFile localToolEnv file "one\ntwo\nthree\n"+              offsetToEnd <- run (readTool localToolEnv) ReadReq {path = file, offset = Just 1, limit = Nothing}+              firstLine <- run (readTool localToolEnv) ReadReq {path = file, offset = Just 0, limit = Just 1}+              pure (offsetToEnd, firstLine)+          case result of+            Left err -> assertFailure ("read failed: " <> show err)+            Right (offsetToEnd, firstLine) -> do+              offsetToEnd ^. #content @?= "two\nthree\n"+              offsetToEnd ^. #truncated @?= False+              firstLine ^. #content @?= "one\n"+              firstLine ^. #truncated @?= True,+      testCase "glob at exactly maxResults is not marked truncated" $+        withTempDir "glob-cap" $ \root -> do+          result <-+            runEffMock [] $ do+              traverse_+                ( \n ->+                    envWriteFile+                      localToolEnv+                      (T.pack (root </> ("f" <> show (n :: Int) <> ".txt")))+                      "x"+                )+                [0 .. 999]+              run (globTool noFastToolEnv) GlobReq {patternText = "*.txt", path = Just (T.pack root)}+          case result of+            Left err -> assertFailure ("glob failed: " <> show err)+            Right resp -> do+              length (resp ^. #paths) @?= 1000+              resp ^. #truncated @?= False,+      testCase "walk does not follow directory symlinks" $+        withTempDir "symlink-loop" $ \root -> do+          let file = T.pack (root </> "real.txt")+          created <- try (Dir.createDirectoryLink root (root </> "loop")) :: IO (Either IOException ())+          case created of+            Left _ -> assertBool "directory symlink creation unsupported; skipping" True+            Right () -> do+              result <-+                runEffMock [] $ do+                  envWriteFile localToolEnv file "real\n"+                  run (globTool noFastToolEnv) GlobReq {patternText = "*.txt", path = Just (T.pack root)}+              case result of+                Left err -> assertFailure ("glob failed: " <> show err)+                Right resp -> resp ^. #paths @?= [file]     ]  withTempDir :: FilePath -> (FilePath -> IO a) -> IO a

@@ -14,6 +14,7 @@     mkTextResponse,     mkUsageResponse,     mkToolCallResponse,+    mkToolCallsResponse,   ) where @@ -121,9 +122,15 @@  -- | An assistant 'Response' carrying a single native tool-call block. mkToolCallResponse :: Text -> Text -> Value -> Response-mkToolCallResponse callId nm args =+mkToolCallResponse callId nm args = mkToolCallsResponse [(callId, nm, args)]++-- | An assistant 'Response' carrying several native tool-call blocks in order.+mkToolCallsResponse :: [(Text, Text, Value)] -> Response+mkToolCallsResponse calls =   _Response     & #message       . #content-      .~ V.singleton-        (AssistantToolCall (_ToolCall & #id_ .~ callId & #name .~ nm & #arguments .~ args))+      .~ V.fromList+        [ AssistantToolCall (_ToolCall & #id_ .~ callId & #name .~ nm & #arguments .~ args)+        | (callId, nm, args) <- calls+        ]

@@ -10,6 +10,7 @@ module ProgramOfThoughtSpec (tests) where  import Data.Text (Text)+import Data.Text qualified as T import GHC.Generics (Generic) import MockLLM (mkTextResponse, runAgent) import Shikumi.Adapter (ToPrompt)@@ -18,7 +19,7 @@ import Shikumi.Error (ShikumiError (..)) import Shikumi.Module (predict) import Shikumi.Program (foldParams)-import Shikumi.Schema (FromModel, ToSchema)+import Shikumi.Schema (FromModel, ToSchema, Validatable) import Shikumi.Signature (Signature, mkSignature) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))@@ -31,6 +32,8 @@   deriving stock (Generic, Show, Eq)   deriving anyclass (ToSchema, FromModel, ToPrompt) +instance Validatable CalcAnswer+ sig :: Signature Task CalcAnswer sig = mkSignature "Compute the requested arithmetic result." @@ -64,8 +67,9 @@             (programOfThoughtWith (PoTConfig {maxIters = 2, interpreter = alwaysFail}) sig)             (Task "multiply 37 by 19 and add 6")         case out of-          Left (ProviderFailure _) -> pure ()-          other -> assertFailure ("expected ProviderFailure, got " <> show other),+          Left (CodeExecFailed msg) ->+            assertBool "message names exhausted code attempts" ("code failed after 2 attempts" `T.isInfixOf` msg)+          other -> assertFailure ("expected CodeExecFailed, got " <> show other),       testCase "error-then-fix: first snippet errors in the sandbox, second succeeds" $ do         -- 1/0 really errors in restrictedInterpreter -> regenerate -> 6 succeeds         out <-

@@ -8,7 +8,9 @@  import Baikai (Api (..), _Model) import Control.Lens ((&), (.~))+import Data.Aeson (object, (.=)) import Data.Generics.Labels ()+import Data.Text (Text) import Data.Vector qualified as V import Fixtures   ( WeatherResp,@@ -19,9 +21,11 @@     weatherRegistry,     weatherSignature,   )-import MockLLM (runAgent)+import MockLLM (mkTextResponse, mkToolCallsResponse, runAgent) import Shikumi.Agent.ReAct-  ( Termination (..),+  ( Action (..),+    Step (..),+    Termination (..),     ToolProtocol (..),     Trajectory (..),     defaultReActConfig,@@ -58,5 +62,29 @@       testCase "ProtocolAuto picks prompt for a CLI model" $         resolveProtocolKind ProtocolAuto (_Model & #api .~ AnthropicMessagesCli) @?= ProtocolPrompt,       testCase "ProtocolAuto picks native for a native-capable model" $-        resolveProtocolKind ProtocolAuto (_Model & #provider .~ "openai" & #api .~ OpenAIChatCompletions) @?= ProtocolNative+        resolveProtocolKind ProtocolAuto (_Model & #provider .~ "openai" & #api .~ OpenAIChatCompletions) @?= ProtocolNative,+      testCase "native turn with two tool calls executes both in order" $ do+        let parisArgs = object ["city" .= ("Paris" :: Text), "units" .= ("c" :: Text)]+            londonArgs = object ["city" .= ("London" :: Text), "units" .= ("c" :: Text)]+            script =+              [ mkToolCallsResponse [("c1", "get_weather", parisArgs), ("c2", "get_weather", londonArgs)],+                mkTextResponse "done",+                mkTextResponse "{\"tempC\": 12.0, \"summary\": \"mild\"}"+              ]+        out <-+          runAgent+            script+            (reactWithTrajectory weatherSignature weatherRegistry (defaultReActConfig & #protocol .~ ProtocolNative))+            weatherQuestion+        case out of+          Right (answer :: WeatherResp, traj) -> do+            answer @?= expectedWeather+            termination traj @?= TerminatedFinish+            case V.toList (steps traj) of+              [s1, s2, s3] -> do+                action s1 @?= CallTool "get_weather" parisArgs+                action s2 @?= CallTool "get_weather" londonArgs+                action s3 @?= Finish+              other -> assertFailure ("expected two tool-call steps followed by finish, got " <> show other)+          Left err -> assertFailure ("native multi-call run failed: " <> show err)     ]

@@ -1,13 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | M2: the ReAct loop as a 'Program', driven by a mock LM. A scripted tool-call -- then finish yields the typed answer plus a two-step trajectory; a script that -- never finishes stops at @maxIters@ and still extracts a best-effort answer. module ReActSpec (tests) where +import Baikai (Response) import Control.Lens ((&), (.~)) import Data.Generics.Labels ()+import Data.Text qualified as T import Data.Vector qualified as V+import Effectful.Error.Static (throwError) import Fixtures-  ( WeatherResp,+  ( WeatherReq,+    WeatherResp,     expectedWeather,     maxItersScript,     promptScript,@@ -15,7 +21,7 @@     weatherRegistry,     weatherSignature,   )-import MockLLM (runAgent)+import MockLLM (mkTextResponse, runAgent) import Shikumi.Agent.ReAct   ( Action (..),     Step (..),@@ -24,9 +30,55 @@     defaultReActConfig,     reactWithTrajectory,   )+import Shikumi.Error (ShikumiError (..))+import Shikumi.Tool (SomeTool (..), Tool, ToolRegistry, mkRegistry, mkTool) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) +budgetTool :: Tool WeatherReq WeatherResp+budgetTool =+  mkTool "burn_budget" "Always exceeds the budget." $ \_req ->+    throwError (BudgetExceeded "ceiling reached")++flakyTool :: Tool WeatherReq WeatherResp+flakyTool =+  mkTool "flaky" "Always fails validation." $ \_req ->+    throwError (ValidationFailure "nothing to see")++budgetRegistry :: ToolRegistry+budgetRegistry = mkRegistry [SomeTool budgetTool]++flakyRegistry :: ToolRegistry+flakyRegistry = mkRegistry [SomeTool flakyTool]++extractReply :: T.Text+extractReply = "{\"tempC\": 12.0, \"summary\": \"mild\"}"++finishReply :: T.Text+finishReply = "{\"thought\": \"I have the forecast.\", \"action\": {\"finish\": true}}"++proposeBudgetReply :: T.Text+proposeBudgetReply =+  "{\"thought\": \"I should spend.\", \"action\": {\"tool\": \"burn_budget\", \"args\": {\"city\": \"Paris\", \"units\": \"c\"}}}"++proposeFlakyReply :: T.Text+proposeFlakyReply =+  "{\"thought\": \"I should try a flaky lookup.\", \"action\": {\"tool\": \"flaky\", \"args\": {\"city\": \"Paris\", \"units\": \"c\"}}}"++budgetScript :: [Response]+budgetScript =+  [ mkTextResponse proposeBudgetReply,+    mkTextResponse finishReply,+    mkTextResponse extractReply+  ]++flakyScript :: [Response]+flakyScript =+  [ mkTextResponse proposeFlakyReply,+    mkTextResponse finishReply,+    mkTextResponse extractReply+  ]+ tests :: TestTree tests =   testGroup@@ -62,5 +114,49 @@           Right (o :: WeatherResp, traj) -> do             termination traj @?= TerminatedMaxIters 1             o @?= expectedWeather+          Left e -> assertFailure ("agent failed: " <> show e),+      testCase "a tool throwing BudgetExceeded aborts the loop" $ do+        res <-+          runAgent+            budgetScript+            (reactWithTrajectory weatherSignature budgetRegistry defaultReActConfig)+            weatherQuestion+        case res of+          Left (BudgetExceeded msg) -> msg @?= "ceiling reached"+          other -> assertFailure ("expected escaped BudgetExceeded, got " <> show other),+      testCase "a tool throwing a recoverable error yields an observation and the loop continues" $ do+        res <-+          runAgent+            flakyScript+            (reactWithTrajectory weatherSignature flakyRegistry defaultReActConfig)+            weatherQuestion+        case res of+          Right (o :: WeatherResp, traj) -> do+            o @?= expectedWeather+            termination traj @?= TerminatedFinish+            case V.toList (steps traj) of+              (Step {action = CallTool nm _, observation = Just obs} : _) -> do+                nm @?= "flaky"+                assertBool "observation is a rendered tool failure" ("failed" `T.isInfixOf` obs)+                assertBool "observation includes validation reason" ("nothing to see" `T.isInfixOf` obs)+              other -> assertFailure ("expected first step to be flaky tool call with observation, got " <> show other)+          Left e -> assertFailure ("agent failed: " <> show e),+      testCase "an unparseable reply produces a corrective step and the loop recovers" $ do+        res <-+          runAgent+            (mkTextResponse "this is not json" : promptScript)+            (reactWithTrajectory weatherSignature weatherRegistry defaultReActConfig)+            weatherQuestion+        case res of+          Right (o :: WeatherResp, traj) -> do+            o @?= expectedWeather+            assertBool+              "trajectory contains corrective parse feedback"+              (any hasCorrectiveObservation (V.toList (steps traj)))           Left e -> assertFailure ("agent failed: " <> show e)     ]++hasCorrectiveObservation :: Step -> Bool+hasCorrectiveObservation Step {observation = Just obs} =+  "not a valid action JSON object" `T.isInfixOf` obs+hasCorrectiveObservation _ = False

@@ -33,10 +33,18 @@         runRestricted "result = 42" @?= Right "42",       testCase "parentheses override precedence" $         runRestricted "(2 + 3) * 4" @?= Right "20",+      testCase "unary minus works for literals, products, and parenthesized expressions" $ do+        runRestricted "-3" @?= Right "-3"+        runRestricted "2 * -3" @?= Right "-6"+        runRestricted "-(2 + 3)" @?= Right "-5",       testCase "1 / 0 reports a division error" $         assertLeftMentions "division" (runRestricted "1 / 0"),       testCase "len(\"hello\") evaluates to 5" $         runRestricted "len(\"hello\")" @?= Right "5",+      testCase "string escapes parse in literals" $ do+        runRestricted "\"a\\\"b\"" @?= Right "a\"b"+        runRestricted "\"a\\\\b\"" @?= Right "a\\b"+        runRestricted "\"a\\n\\t\"" @?= Right "a\n\t",       testCase "upper(\"ab\") ++ \"C\" concatenates to ABC" $         runRestricted "upper(\"ab\") ++ \"C\"" @?= Right "ABC",       testCase "sum([1, 2, 3]) evaluates to 6" $

@@ -2,8 +2,13 @@ -- input record, frozen against "Shikumi.Schema"'s real generator output. module SchemaSpec (tests) where +import Data.Aeson (Value, object, (.=))+import Data.Proxy (Proxy (..))+import Data.Text (Text) import Fixtures (expectedReqSchema, weatherTool)+import Shikumi.Schema (toSchema) import Shikumi.Tool (toolSchemaOf)+import Shikumi.Tool.Builtin.Fs (GlobReq, GrepReq) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -12,5 +17,33 @@   testGroup     "Schema"     [ testCase "derives WeatherReq argument schema" $-        toolSchemaOf weatherTool @?= expectedReqSchema+        toolSchemaOf weatherTool @?= expectedReqSchema,+      testCase "pins grep and glob request schemas" $ do+        toSchema (Proxy :: Proxy GrepReq)+          @?= object+            [ "type" .= ("object" :: Text),+              "properties"+                .= object+                  [ "pattern" .= toSchema (Proxy :: Proxy Text),+                    "path" .= toSchema (Proxy :: Proxy (Maybe Text)),+                    "glob" .= toSchema (Proxy :: Proxy (Maybe Text)),+                    "ignoreCase" .= toSchema (Proxy :: Proxy (Maybe Bool))+                  ],+              "required" .= (["pattern"] :: [Text]),+              "additionalProperties" .= False+            ]+        toSchema (Proxy :: Proxy GlobReq) @?= expectedGlobReqSchema+    ]++expectedGlobReqSchema :: Value+expectedGlobReqSchema =+  object+    [ "type" .= ("object" :: Text),+      "properties"+        .= object+          [ "pattern" .= toSchema (Proxy :: Proxy Text),+            "path" .= toSchema (Proxy :: Proxy (Maybe Text))+          ],+      "required" .= (["pattern"] :: [Text]),+      "additionalProperties" .= False     ]

@@ -11,15 +11,27 @@ import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as T-import Fixtures (weatherArgs, weatherRegistry)+import Effectful.Error.Static (throwError)+import Fixtures (WeatherReq, WeatherResp, weatherArgs, weatherRegistry) import MockLLM (runEffMock)-import Shikumi.Tool (ToolError (..), runToolCall)+import Shikumi.Error (ShikumiError (..))+import Shikumi.Tool (SomeTool (..), Tool, ToolError (..), mkRegistry, mkTool, runToolCall) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))  tc :: Text -> Value -> ToolCall tc nm args = _ToolCall & #name .~ nm & #arguments .~ args +budgetTool :: Tool WeatherReq WeatherResp+budgetTool =+  mkTool "burn_budget" "Always exceeds the budget." $ \_req ->+    throwError (BudgetExceeded "ceiling reached")++flakyTool :: Tool WeatherReq WeatherResp+flakyTool =+  mkTool "flaky" "Always fails validation." $ \_req ->+    throwError (ValidationFailure "nothing to see")+ tests :: TestTree tests =   testGroup@@ -38,5 +50,17 @@         res <- runEffMock [] (runToolCall weatherRegistry (tc "nope" (object [])))         case res of           Right (Left (ToolNotFound nm)) -> nm @?= "nope"-          other -> assertFailure ("expected ToolNotFound, got " <> show other)+          other -> assertFailure ("expected ToolNotFound, got " <> show other),+      testCase "a tool body throwing BudgetExceeded escapes as ShikumiError" $ do+        res <- runEffMock [] (runToolCall (mkRegistry [SomeTool budgetTool]) (tc "burn_budget" weatherArgs))+        case res of+          Left (BudgetExceeded msg) -> msg @?= "ceiling reached"+          other -> assertFailure ("expected escaped BudgetExceeded, got " <> show other),+      testCase "a tool body throwing ValidationFailure becomes ToolRunFailed" $ do+        res <- runEffMock [] (runToolCall (mkRegistry [SomeTool flakyTool]) (tc "flaky" weatherArgs))+        case res of+          Right (Left (ToolRunFailed nm msg)) -> do+            nm @?= "flaky"+            assertBool "message includes validation reason" ("nothing to see" `T.isInfixOf` msg)+          other -> assertFailure ("expected ToolRunFailed, got " <> show other)     ]

@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}  module WebSpec (tests) where@@ -5,10 +6,13 @@ import Baikai (ToolCall, _ToolCall) import Control.Lens ((&), (.~)) import Data.Aeson (Value, object, (.=))+import Data.ByteString qualified as BS import Data.Generics.Labels ()+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import Data.Text (Text) import Data.Text qualified as T import MockLLM (runEffMock)+import Shikumi.Error (ShikumiError (..)) import Shikumi.Tool (SomeTool (..), ToolRegistry, mkRegistry, runToolCall) import Shikumi.Tool.Builtin.Web (webFetchTool, webSearchTool) import Shikumi.Tool.Web@@ -16,12 +20,15 @@     SearchHit (..),     SearchResult (..),     WebClient (..),+    checkFetchUrl,+    defaultFetchPolicy,     localWebClient,     newTlsManager,+    readCapped,   ) import System.Environment (lookupEnv) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertBool, assertFailure, testCase)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))  tc :: Text -> Value -> ToolCall tc nm args = _ToolCall & #name .~ nm & #arguments .~ args@@ -63,6 +70,38 @@             assertBool "observation includes title" ("Stub Result" `T.isInfixOf` obs)             assertBool "observation includes url" ("https://example.test/result" `T.isInfixOf` obs)           other -> assertFailure ("expected web_search observation, got " <> show other),+      testCase "default fetch policy refuses metadata, loopback, and private hosts" $ do+        checkFetchUrl defaultFetchPolicy "https://example.com/x" @?= Right ()+        assertDenied "ftp://example.com"+        assertDenied "http://localhost:8080/"+        assertDenied "http://127.0.0.1/"+        assertDenied "http://169.254.169.254/latest/meta-data/"+        assertDenied "http://192.168.1.5/"+        assertDenied "http://172.20.0.1/",+      testCase "readCapped stops at the cap without draining the stream" $ do+        countRef <- newIORef (0 :: Int)+        (bytes, wasTruncated) <- readCapped 2048 (countedInfiniteChunk countRef)+        count <- readIORef countRef+        BS.length bytes @?= 2048+        wasTruncated @?= True+        assertBool "consumed at most one chunk past cap" (count <= 3),+      testCase "readCapped reports exact cap as not truncated when stream ends" $ do+        ref <- newIORef [BS.replicate 1024 97, BS.replicate 1024 98, BS.empty]+        (bytes, wasTruncated) <- readCapped 2048 (popChunk ref)+        BS.length bytes @?= 2048+        wasTruncated @?= False,+      testCase "fetch of a denied URL fails fast with ValidationFailure" $ do+        manager <- newTlsManager+        result <-+          runEffMock [] $+            webFetch+              (localWebClient manager Nothing)+              "http://169.254.169.254/latest/meta-data/"+              Nothing+        case result of+          Left (ValidationFailure msg) ->+            assertBool "mentions policy refusal" ("refused by fetch policy" `T.isInfixOf` msg)+          other -> assertFailure ("expected ValidationFailure from fetch policy, got " <> show other),       testCase "live web_fetch is gated by SHIKUMI_NET_TESTS" $ do         enabled <- lookupEnv "SHIKUMI_NET_TESTS"         case enabled of@@ -81,6 +120,23 @@               Right (Left err) -> assertFailure ("live web_fetch returned tool error: " <> show err)               Left err -> assertFailure ("live web_fetch failed: " <> show err)     ]++assertDenied :: Text -> IO ()+assertDenied url =+  case checkFetchUrl defaultFetchPolicy url of+    Left _ -> pure ()+    Right () -> assertFailure ("expected fetch policy to deny " <> T.unpack url)++countedInfiniteChunk :: IORef Int -> IO BS.ByteString+countedInfiniteChunk ref = do+  atomicModifyIORef' ref (\n -> (n + 1, ()))+  pure (BS.replicate 1024 120)++popChunk :: IORef [BS.ByteString] -> IO BS.ByteString+popChunk ref =+  atomicModifyIORef' ref $ \case+    [] -> ([], BS.empty)+    x : xs -> (xs, x)  stubRegistry :: ToolRegistry stubRegistry = mkRegistry [SomeTool (webFetchTool stubWebClient), SomeTool (webSearchTool stubWebClient)]