saint-graves/sica-fondt
1
0
Fork 0
mirror of https://github.com/SHOGGOTH-SECTOR/sica-fondt.git synced 2026-09-30 01:15:10 +00:00
Code Issues Packages Projects Releases Wiki Activity

Add Gen.03 organ-systems core: Ada Medium, Soul/Tarot, trust boundary, Hermes MCP bridge

Browse Source 
Implements the Gen.03 organ-systems body in SPARK/Ada (Jorvik, No_Exceptions):

- Shared types (mafiabot_types): Bounded_Text, Operation_Status, Organ_Id,
  Provenance_Tag, fixed-point drive/ratio/cost/axis types.
- Config loader: SPARK-safe flat key-value parser (no heap/exceptions/finalization).
- Trust boundary: blocklist substring matching, provenance enforcement,
  tick-based rate limiting, Trust_Guard protected object.
- Soul / Silicon Dawn Tarot: 56-card alphabet, Celtic Cross spread, Big-3
  identity anchors. The cross accretes from the cognitive loops (2 cards per
  layer at steps 6/9/13, stave of 4 at step 17) rather than being drawn whole.
- Sessions: Soul_State is now keyed by (uid, channel, server). Each session
  has its own card pool, cross, and output counter; the Big-3 identity is
  global. A formed cross is held for the session (or 17 outputs, whichever is
  longer). Two users on two channels never share a deck or a cross.
- Ada Medium: 23-step forward-only inference cycle wiring the cognitive loops,
  Celtic Cross injection, and outbound trust screening per session.
- Hermes MCP stdio bridge: JSON-RPC over stdin/stdout (initialize, tools/list,
  tools/call), SOUL.md generation, verbatim id echo. SPARK_Mode Off for I/O;
  trust checks run in proven code first.
- Main driver: organ init -> SOUL.md publish -> MCP serve loop.
- Tests: soul, trust, cycle (session formation/isolation), config.

Fixes an orchestrator bug where step 1 advanced onto Phase_Input after Reset,
failing every cycle.

Note: requires GNAT/Alire to build; no Ada toolchain in this environment, so
compilation and gnatprove must run in CI.
This commit is contained in:
gravermistakes
2026-06-09 21:50:50 +00:00
parent ca3e1c4441
commit 42ef321c4c
24 changed files with 2787 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files
mafiabot_core/src/protocol/hermes_protocol.adb
+320
View File
@@ -0,0 +1,320 @@
-- Hermes MCP stdio bridge body.
-- SPARK_Mode Off: Ada.Text_IO is not analysable by SPARK. All trust-boundary
-- screening happens in proven code (Ada_Medium / Trust_Boundary) before any
-- procedure here is called. The global No_Exceptions restriction still applies,
-- so I/O is written to avoid raising (End_Of_File guards, bounded Get_Line).
with Ada.Text_IO;
with Ada.Environment_Variables;
package body Hermes_Protocol
with SPARK_Mode => Off
is
-- -------------------------------------------------------------------
-- Buffer append helpers (truncate silently at Max_JSON_Length)
procedure Append (Buf : in out JSON_Buffer; S : in String) is
Avail : constant Natural := Max_JSON_Length - Buf.Length;
N : constant Natural := (if S'Length <= Avail then S'Length else Avail);
begin
if N > 0 then
Buf.Data (Buf.Length + 1 .. Buf.Length + N) :=
S (S'First .. S'First + N - 1);
Buf.Length := Buf.Length + N;
end if;
end Append;
procedure Append (Buf : in out JSON_Buffer; T : in Bounded_Text) is
begin
Append (Buf, T.Data (1 .. T.Length));
end Append;
-- Append a string with the minimal JSON escaping needed for safety.
procedure Append_Escaped (Buf : in out JSON_Buffer; S : in String) is
begin
for I in S'Range loop
case S (I) is
when '"' => Append (Buf, "\""");
when '\' => Append (Buf, "\\");
when ASCII.LF => Append (Buf, "\n");
when ASCII.CR => Append (Buf, "\r");
when ASCII.HT => Append (Buf, "\t");
when others => Append (Buf, (1 => S (I)));
end case;
end loop;
end Append_Escaped;
procedure Append_Escaped (Buf : in out JSON_Buffer; T : in Bounded_Text) is
begin
Append_Escaped (Buf, T.Data (1 .. T.Length));
end Append_Escaped;
-- -------------------------------------------------------------------
procedure Read_Message
(Buf : out JSON_Buffer;
Status : out Operation_Status)
is
use Ada.Text_IO;
Line : String (1 .. Max_JSON_Length);
Last : Natural;
begin
Buf := (Data => (others => ' '), Length => 0);
-- Guard EOF so Get_Line cannot raise End_Error under No_Exceptions.
if End_Of_File then
Status := Error_Invalid_State; -- stdin closed: caller shuts down
return;
end if;
Get_Line (Line, Last);
if Last > 0 then
Buf.Data (1 .. Last) := Line (1 .. Last);
Buf.Length := Last;
end if;
Status := OK;
end Read_Message;
procedure Write_Message (Buf : in JSON_Buffer) is
use Ada.Text_IO;
begin
Put (Buf.Data (1 .. Buf.Length));
New_Line;
Flush;
end Write_Message;
-- -------------------------------------------------------------------
-- Minimal `"key": "value"` extractor. Not a full JSON parser: it finds
-- the first occurrence of the quoted key, the following colon, then the
-- next quoted string, and copies that as the value.
procedure Extract_Field
(Buf : in JSON_Buffer;
Key : in String;
Value : out Bounded_Text)
is
Quoted : constant String := '"' & Key & '"';
I : Natural := 1;
Found : Natural := 0;
begin
Value := (Data => (others => ' '), Length => 0);
if Quoted'Length = 0 or else Buf.Length < Quoted'Length then
return;
end if;
-- Locate the key.
while I <= Buf.Length - Quoted'Length + 1 loop
if Buf.Data (I .. I + Quoted'Length - 1) = Quoted then
Found := I + Quoted'Length;
exit;
end if;
I := I + 1;
end loop;
if Found = 0 then
return;
end if;
-- Skip whitespace and the colon.
I := Found;
while I <= Buf.Length
and then (Buf.Data (I) = ' ' or else Buf.Data (I) = ':'
or else Buf.Data (I) = ASCII.HT)
loop
I := I + 1;
end loop;
-- Expect an opening quote.
if I > Buf.Length or else Buf.Data (I) /= '"' then
return;
end if;
I := I + 1; -- first char of the value
-- Copy until the closing quote (honouring backslash escapes minimally).
while I <= Buf.Length and then Buf.Data (I) /= '"' loop
if Buf.Data (I) = '\' and then I < Buf.Length then
I := I + 1; -- take the escaped char literally
end if;
if Value.Length < Max_Text_Length then
Value.Length := Value.Length + 1;
Value.Data (Value.Length) := Buf.Data (I);
end if;
I := I + 1;
end loop;
end Extract_Field;
procedure Extract_Raw_Field
(Buf : in JSON_Buffer;
Key : in String;
Value : out Bounded_Text)
is
Quoted : constant String := '"' & Key & '"';
I : Natural := 1;
Found : Natural := 0;
begin
Value := Make_Text ("null");
if Quoted'Length = 0 or else Buf.Length < Quoted'Length then
return;
end if;
while I <= Buf.Length - Quoted'Length + 1 loop
if Buf.Data (I .. I + Quoted'Length - 1) = Quoted then
Found := I + Quoted'Length;
exit;
end if;
I := I + 1;
end loop;
if Found = 0 then
return;
end if;
I := Found;
while I <= Buf.Length
and then (Buf.Data (I) = ' ' or else Buf.Data (I) = ':'
or else Buf.Data (I) = ASCII.HT)
loop
I := I + 1;
end loop;
if I > Buf.Length then
return;
end if;
Value := (Data => (others => ' '), Length => 0);
if Buf.Data (I) = '"' then
-- Quoted string: copy through the closing quote, inclusive.
Value.Length := 1;
Value.Data (1) := '"';
I := I + 1;
while I <= Buf.Length and then Buf.Data (I) /= '"' loop
if Buf.Data (I) = '\' and then I < Buf.Length then
if Value.Length < Max_Text_Length then
Value.Length := Value.Length + 1;
Value.Data (Value.Length) := Buf.Data (I);
end if;
I := I + 1;
end if;
if Value.Length < Max_Text_Length then
Value.Length := Value.Length + 1;
Value.Data (Value.Length) := Buf.Data (I);
end if;
I := I + 1;
end loop;
if Value.Length < Max_Text_Length then
Value.Length := Value.Length + 1;
Value.Data (Value.Length) := '"';
end if;
else
-- Bare token: copy until a structural delimiter.
while I <= Buf.Length
and then Buf.Data (I) /= ',' and then Buf.Data (I) /= '}'
and then Buf.Data (I) /= ' ' and then Buf.Data (I) /= ASCII.HT
loop
if Value.Length < Max_Text_Length then
Value.Length := Value.Length + 1;
Value.Data (Value.Length) := Buf.Data (I);
end if;
I := I + 1;
end loop;
end if;
if Value.Length = 0 then
Value := Make_Text ("null");
end if;
end Extract_Raw_Field;
-- -------------------------------------------------------------------
procedure Write_Soul_MD
(Content : in Bounded_Text;
Status : out Operation_Status)
is
use Ada.Text_IO;
F : File_Type;
begin
Status := Error_Config;
if not Ada.Environment_Variables.Exists ("HOME") then
return;
end if;
declare
Home : constant String := Ada.Environment_Variables.Value ("HOME");
Path : constant String := Home & "/.hermes/SOUL.md";
begin
-- Assumes ~/.hermes exists (Hermes owns that directory).
Create (F, Out_File, Path);
Put (F, Content.Data (1 .. Content.Length));
Close (F);
Status := OK;
end;
end Write_Soul_MD;
-- -------------------------------------------------------------------
-- JSON-RPC response builders
procedure Make_Init_Response
(Id : in Bounded_Text;
Buf : out JSON_Buffer)
is
begin
Buf := (Data => (others => ' '), Length => 0);
Append (Buf, "{""jsonrpc"":""2.0"",""id"":");
Append (Buf, Id);
Append (Buf, ",""result"":{""protocolVersion"":""2024-11-05"",");
Append (Buf, """capabilities"":{""tools"":{}},");
Append (Buf,
"""serverInfo"":{""name"":""mafiabot_core"",""version"":""gen03""}}}");
end Make_Init_Response;
procedure Make_Tools_List_Response
(Id : in Bounded_Text;
Buf : out JSON_Buffer)
is
begin
Buf := (Data => (others => ' '), Length => 0);
Append (Buf, "{""jsonrpc"":""2.0"",""id"":");
Append (Buf, Id);
Append (Buf, ",""result"":{""tools"":[{""name"":""infer"",");
Append (Buf,
"""description"":""Run the Gen.03 23-step organ-systems inference "
& "cycle over an input and return the enriched cognition context."",");
Append (Buf,
"""inputSchema"":{""type"":""object"",""properties"":"
& "{""input"":{""type"":""string"",""description"":"
& """The user message to reason over.""}},""required"":[""input""]}");
Append (Buf, "}]}}");
end Make_Tools_List_Response;
procedure Make_Tool_Result_Response
(Id : in Bounded_Text;
Result : in Bounded_Text;
Buf : out JSON_Buffer)
is
begin
Buf := (Data => (others => ' '), Length => 0);
Append (Buf, "{""jsonrpc"":""2.0"",""id"":");
Append (Buf, Id);
Append (Buf, ",""result"":{""content"":[{""type"":""text"",""text"":""");
Append_Escaped (Buf, Result);
Append (Buf, """}]}}");
end Make_Tool_Result_Response;
procedure Make_Error_Response
(Id : in Bounded_Text;
Code : in Integer;
Message : in String;
Buf : out JSON_Buffer)
is
Code_Img : constant String := Integer'Image (Code);
-- Integer'Image leads with a space for non-negatives; strip it.
Code_Str : constant String :=
(if Code_Img'Length > 0 and then Code_Img (Code_Img'First) = ' '
then Code_Img (Code_Img'First + 1 .. Code_Img'Last)
else Code_Img);
begin
Buf := (Data => (others => ' '), Length => 0);
Append (Buf, "{""jsonrpc"":""2.0"",""id"":");
Append (Buf, Id);
Append (Buf, ",""error"":{""code"":");
Append (Buf, Code_Str);
Append (Buf, ",""message"":""");
Append_Escaped (Buf, Message);
Append (Buf, """}}");
end Make_Error_Response;
end Hermes_Protocol;
mafiabot_core/src/protocol/hermes_protocol.ads
+74
View File
@@ -0,0 +1,74 @@
-- Hermes MCP stdio bridge.
-- SPARK_Mode Off sections are justified: trust boundary checks happen
-- in SPARK-proven code (Ada_Medium / Trust_Boundary) before any I/O call.
-- This package handles only the process boundary crossing.
with Mafiabot_Types; use Mafiabot_Types;
package Hermes_Protocol
with SPARK_Mode => Off -- Ada.Text_IO is not SPARK-compatible
is
Max_JSON_Length : constant := 8192;
-- Raw JSON buffer (stack-allocated, 8 KiB)
subtype JSON_Length is Natural range 0 .. Max_JSON_Length;
type JSON_Buffer is record
Data : String (1 .. Max_JSON_Length) := (others => ' ');
Length : JSON_Length := 0;
end record;
-- Read one JSON-RPC message from stdin (newline-delimited).
-- Returns Error_Overflow if the line exceeds Max_JSON_Length.
procedure Read_Message
(Buf : out JSON_Buffer;
Status : out Operation_Status);
-- Write one JSON-RPC response to stdout followed by a newline.
procedure Write_Message (Buf : in JSON_Buffer);
-- Extract the string value for a top-level JSON key.
-- Simple state machine: finds `"key": "value"` patterns only.
-- Returns empty Bounded_Text if the key is absent.
procedure Extract_Field
(Buf : in JSON_Buffer;
Key : in String;
Value : out Bounded_Text);
-- Extract the RAW value token for a key, verbatim, preserving its JSON
-- type: a quoted string keeps its quotes, a number/literal is copied as
-- digits. Used for `id`, which must be echoed back unchanged. Returns the
-- literal `null` if the key is absent.
procedure Extract_Raw_Field
(Buf : in JSON_Buffer;
Key : in String;
Value : out Bounded_Text);
-- Write the SOUL.md content to ~/.hermes/SOUL.md.
procedure Write_Soul_MD
(Content : in Bounded_Text;
Status : out Operation_Status);
-- Build the standard MCP initialize response.
procedure Make_Init_Response
(Id : in Bounded_Text;
Buf : out JSON_Buffer);
-- Build the tools/list response exposing the inference cycle tool.
procedure Make_Tools_List_Response
(Id : in Bounded_Text;
Buf : out JSON_Buffer);
-- Build a tools/call result response wrapping the inference output.
procedure Make_Tool_Result_Response
(Id : in Bounded_Text;
Result : in Bounded_Text;
Buf : out JSON_Buffer);
-- Build a JSON-RPC error response.
procedure Make_Error_Response
(Id : in Bounded_Text;
Code : in Integer;
Message : in String;
Buf : out JSON_Buffer);
end Hermes_Protocol;