-- ───────────────────────────────────────────────────────────────────────────── -- SnapKitty Sovereign — Haskell Trust Deed Validator v2.0 -- LISP DSL → Haskell enforcement → Rust runtime -- -- Rules are loaded from deed-rules.lisp (Funtan DSL) at startup. -- Haskell enforces them. Rust calls this binary as a subprocess. -- -- LiquidHaskell refinement annotations are present throughout. -- Activate with: ghc -fplugin=LiquidHaskell (requires liquid-fixpoint + Z3) -- Without LH installed, annotations are comments — smart constructors -- provide equivalent runtime guarantees. -- -- stdin protocol (9 lines): -- 1: agent_id -- 2: allowed_actions (comma-separated) -- 3: restricted_actions (comma-separated) -- 4: trust_score (float) -- 5: provided_seal (64-char hex string) -- 6: expires_at (unix timestamp seconds, integer) -- 7: status (active|revoked|expired|pending-renewal) -- 8: escalation_authority (agent_id or "none") -- 9: spec_path (path to deed-rules.lisp, or "default") -- -- stdout: key=value pairs -- ───────────────────────────────────────────────────────────────────────────── {-# LANGUAGE LinearTypes #-} module DeedValidator where import Data.Char (toLower, isHexDigit, isSpace, isDigit) import Data.List (intersect, nub, isPrefixOf, isSuffixOf) import Data.Maybe (mapMaybe, fromMaybe) import System.IO (hPutStrLn, stderr, hSetBuffering, stdout, BufferMode(..)) import Control.Exception (try, SomeException) -- ───────────────────────────────────────────────────────────────────────────── -- Minimal S-expression parser for deed-rules.lisp -- ───────────────────────────────────────────────────────────────────────────── data SExpr = Atom String | SList [SExpr] deriving (Show, Eq) parseSExprs :: String -> [SExpr] parseSExprs input = fst (parseMany (stripComments input)) where stripComments [] = [] stripComments (';':rest) = stripComments (dropWhile (/= '\n') rest) stripComments (c:cs) = c : stripComments cs parseMany :: String -> ([SExpr], String) parseMany s = let s' = dropWhile isSpace s in case s' of [] -> ([], []) (')':_) -> ([], s') _ -> let (e, rest) = parseOne s' (es, rem') = parseMany rest in (e:es, rem') parseOne :: String -> (SExpr, String) parseOne [] = (Atom "", []) parseOne ('(':rest) = let (children, after) = parseMany rest after' = case dropWhile isSpace after of (')':xs) -> xs xs -> xs in (SList children, after') parseOne ('"':rest) = let (str, after) = break (== '"') rest in (Atom str, drop 1 after) parseOne s = let (tok, rest) = break (\c -> isSpace c || c == '(' || c == ')') s in (Atom tok, rest) -- Extract a named list from a deed-spec s-expr lookupList :: String -> SExpr -> Maybe [SExpr] lookupList key (SList (Atom "deed-spec" : children)) = let find [] = Nothing find (SList (Atom k : vals) : rest) | k == key = Just vals | otherwise = find rest find (_ : rest) = find rest in find children lookupList key (SList children) = let find [] = Nothing find (SList (Atom k : vals) : rest) | k == key = Just vals | otherwise = find rest find (_ : rest) = find rest in find children lookupList _ _ = Nothing lookupAtom :: String -> SExpr -> Maybe String lookupAtom key spec = case lookupList key spec of Just (Atom v : _) -> Just v _ -> Nothing lookupFloat :: String -> SExpr -> Maybe Double lookupFloat key spec = case lookupAtom key spec of Just s -> case reads s of { [(v,"")] -> Just v; _ -> Nothing } Nothing -> Nothing lookupAtoms :: String -> SExpr -> [String] lookupAtoms key spec = case lookupList key spec of Just atoms -> [v | Atom v <- atoms] Nothing -> [] -- ───────────────────────────────────────────────────────────────────────────── -- DeedSpec — loaded from deed-rules.lisp -- ───────────────────────────────────────────────────────────────────────────── data DeedSpec = DeedSpec { specTrustMin :: Double -- default 0.01 , specTrustMax :: Double -- default 1.0 , specSealMinLen :: Int -- default 64 , specExpiryRequired :: Bool -- default True , specAuthorityModel :: String -- "role-based" , specAuthorityMinTrust :: Double -- default 1.0 , specStatusValues :: [String] -- valid status strings , specBlockedActions :: [String] -- globally forbidden , specSealMustCover :: [String] -- fields seal must cover } deriving (Show) defaultDeedSpec :: DeedSpec defaultDeedSpec = DeedSpec { specTrustMin = 0.01 , specTrustMax = 1.0 , specSealMinLen = 64 , specExpiryRequired = True , specAuthorityModel = "role-based" , specAuthorityMinTrust = 1.0 , specStatusValues = ["active", "expired", "revoked", "pending-renewal"] , specBlockedActions = ["delete_ledger","modify_deed","override_all", "jailbreak","ignore_previous"] , specSealMustCover = ["agent-id","trust-score","expires-at","status", "escalation-authority","allowed-actions","restricted-actions"] } loadDeedSpec :: FilePath -> IO DeedSpec loadDeedSpec path = do result <- try (readFile path) :: IO (Either SomeException String) case result of Left err -> do hPutStrLn stderr $ "[deed-validator] spec file not found: " ++ path ++ " — using defaults. Error: " ++ show err return defaultDeedSpec Right content -> do let exprs = parseSExprs content case exprs of (spec:_) -> do let ds = DeedSpec { specTrustMin = fromMaybe 0.01 (lookupFloat "trust-score-min" spec) , specTrustMax = fromMaybe 1.0 (lookupFloat "trust-score-max" spec) , specSealMinLen = fromMaybe 64 (fmap round (lookupFloat "seal-min-length" spec)) , specExpiryRequired = fromMaybe True (fmap (== "true") (lookupAtom "expiry-required" spec)) , specAuthorityModel = fromMaybe "role-based" (lookupAtom "authority-model" spec) , specAuthorityMinTrust = fromMaybe 1.0 (lookupFloat "authority-min-trust" spec) , specStatusValues = let vs = lookupAtoms "status-values" spec in if null vs then specStatusValues defaultDeedSpec else vs , specBlockedActions = let bs = lookupAtoms "globally-blocked-actions" spec in if null bs then specBlockedActions defaultDeedSpec else bs , specSealMustCover = let cs = lookupAtoms "seal-must-cover" spec in if null cs then specSealMustCover defaultDeedSpec else cs } hPutStrLn stderr $ "[deed-validator] loaded spec v" ++ fromMaybe "?" (lookupAtom "version" spec) return ds [] -> do hPutStrLn stderr "[deed-validator] empty spec file — using defaults" return defaultDeedSpec -- ───────────────────────────────────────────────────────────────────────────── -- TrustDeed — full field set (matches Rust struct) -- ───────────────────────────────────────────────────────────────────────────── -- {-@ type TrustScore = {v:Double | v >= 0.01 && v <= 1.0} @-} -- {-@ type ValidSeal = {v:String | len v >= 64} @-} -- {-@ type FutureTime = {v:Int | v > 0} @-} newtype TrustScore = TrustScore Double deriving (Show) newtype ValidSeal = ValidSeal String deriving (Show) -- Smart constructor — invalid trust scores cannot be constructed -- {-@ mkTrustScore :: DeedSpec -> Double -> Either String TrustScore @-} mkTrustScore :: DeedSpec -> Double -> Either String TrustScore mkTrustScore spec s | s < specTrustMin spec = Left $ "V3:TRUST_BELOW_MIN score=" ++ show s | s > specTrustMax spec = Left $ "V3:TRUST_ABOVE_MAX score=" ++ show s | otherwise = Right (TrustScore s) -- Smart constructor — short or non-hex seals cannot be constructed -- {-@ mkValidSeal :: DeedSpec -> String -> Either String ValidSeal @-} mkValidSeal :: DeedSpec -> String -> Either String ValidSeal mkValidSeal spec seal | null seal = Left "V4:NO_SEAL" | length seal < specSealMinLen spec = Left $ "V4:SEAL_TOO_SHORT len=" ++ show (length seal) | not (all isHexDigit seal) = Left "V4:SEAL_NOT_HEX" | otherwise = Right (ValidSeal seal) data TrustDeed = TrustDeed { deedAgent :: String , deedAllowed :: [String] , deedRestricted :: [String] , deedScore :: TrustScore , deedSeal :: ValidSeal , deedExpiresAt :: Integer -- unix timestamp , deedStatus :: String -- active|revoked|expired|pending-renewal , deedEscalation :: String -- agent_id or "none" } deriving (Show) newtype DeedToken = DeedToken { deedContent :: TrustDeed } mkDeedToken :: TrustDeed -> DeedToken mkDeedToken = DeedToken -- ───────────────────────────────────────────────────────────────────────────── -- Validation checks — each returns (pass/fail, message) -- ───────────────────────────────────────────────────────────────────────────── -- V1: Structure — required non-empty fields checkStructure :: TrustDeed -> (Bool, String) checkStructure d | null (deedAgent d) = (False, "V1:EMPTY_AGENT_ID") | null (deedAllowed d) = (False, "V1:NO_ALLOWED_ACTIONS — deed must permit at least one action") | otherwise = (True, "V1:STRUCTURAL_OK") -- V2: Disjoint sets — allowed ∩ restricted = ∅ checkDisjoint :: TrustDeed -> (Bool, String) checkDisjoint d = let overlap = deedAllowed d `intersect` deedRestricted d in if null overlap then (True, "V2:SETS_DISJOINT") else (False, "V2:OVERLAP_DETECTED actions=" ++ show overlap) -- V3: Trust score — validated at construction time by mkTrustScore -- This check confirms the constructed score is in spec range checkTrustScore :: DeedSpec -> TrustDeed -> (Bool, String) checkTrustScore spec d = let TrustScore s = deedScore d in if s >= specTrustMin spec && s <= specTrustMax spec then (True, "V3:TRUST_IN_RANGE score=" ++ show s) else (False, "V3:TRUST_OUT_OF_RANGE score=" ++ show s) -- V4: Seal format — validated at construction time by mkValidSeal checkSealFormat :: DeedSpec -> TrustDeed -> (Bool, String) checkSealFormat spec d = let ValidSeal seal = deedSeal d in if length seal >= specSealMinLen spec && all isHexDigit seal then (True, "V4:SEAL_FORMAT_OK len=" ++ show (length seal)) else (False, "V4:SEAL_FORMAT_FAIL") -- V5: Authority model — role-based, NOT name-based -- Any agent with trust_score = 1.0 has authority. No names hardcoded. checkAuthorityModel :: DeedSpec -> TrustDeed -> (Bool, String) checkAuthorityModel spec d = let TrustScore s = deedScore d claimsAuth = s >= specAuthorityMinTrust spec model = specAuthorityModel spec in if claimsAuth && model /= "role-based" then (False, "V5:AUTHORITY_MODEL_MISCONFIGURED — spec requires role-based") else (True, "V5:AUTHORITY_MODEL_OK model=" ++ model ++ if claimsAuth then " (claims authority)" else "") -- V6: Expiration — deed must not be expired, status must be active checkExpiration :: DeedSpec -> TrustDeed -> Integer -> (Bool, String) checkExpiration spec d nowTs | specExpiryRequired spec && deedExpiresAt d <= 0 = (False, "V6:EXPIRES_AT_MISSING") | deedExpiresAt d > 0 && nowTs > deedExpiresAt d = (False, "V6:DEED_EXPIRED expires_at=" ++ show (deedExpiresAt d)) | deedStatus d `notElem` specStatusValues spec = (False, "V6:INVALID_STATUS status=" ++ deedStatus d) | deedStatus d /= "active" = (False, "V6:DEED_NOT_ACTIVE status=" ++ deedStatus d) | otherwise = (True, "V6:DEED_ACTIVE status=" ++ deedStatus d) -- V7: Seal coverage — verify the seal covers all integrity fields -- We cannot recompute SHA-256 without cryptonite, but we verify that the -- seal FIELD SET declared in the spec matches what Rust computes. -- Full content verification happens in Rust's verify_integrity(). checkSealCoverage :: DeedSpec -> TrustDeed -> (Bool, String) checkSealCoverage spec _d = let required = specSealMustCover spec covered = ["agent-id","trust-score","expires-at","status", "escalation-authority","allowed-actions","restricted-actions"] missing = filter (`notElem` covered) required in if null missing then (True, "V7:SEAL_COVERAGE_OK covers=" ++ show (length covered) ++ " fields") else (False, "V7:SEAL_COVERAGE_INCOMPLETE missing=" ++ show missing) -- V8: Blocked actions — globally forbidden actions must not be allowed checkBlockedActions :: DeedSpec -> TrustDeed -> (Bool, String) checkBlockedActions spec d = let blocked = map (map toLower) (specBlockedActions spec) present = filter (\a -> any (`isPrefixOf` map toLower a) blocked) (deedAllowed d) in if null present then (True, "V8:NO_BLOCKED_ACTIONS") else (False, "V8:BLOCKED_ACTION_IN_ALLOWED actions=" ++ show present) -- ───────────────────────────────────────────────────────────────────────────── -- Deed validation result -- ───────────────────────────────────────────────────────────────────────────── data DeedValidation = DeedValidation { dv_agent :: String , dv_v1 :: (Bool, String) , dv_v2 :: (Bool, String) , dv_v3 :: (Bool, String) , dv_v4 :: (Bool, String) , dv_v5 :: (Bool, String) , dv_v6 :: (Bool, String) , dv_v7 :: (Bool, String) , dv_v8 :: (Bool, String) , dv_valid :: Bool , dv_reason :: String } deriving (Show) -- Linear: DeedToken %1-> ensures one validation per token validateDeed :: DeedSpec -> Integer -> DeedToken %1-> DeedValidation validateDeed spec nowTs (DeedToken deed) = let v1 = checkStructure deed v2 = checkDisjoint deed v3 = checkTrustScore spec deed v4 = checkSealFormat spec deed v5 = checkAuthorityModel spec deed v6 = checkExpiration spec deed nowTs v7 = checkSealCoverage spec deed v8 = checkBlockedActions spec deed allChecks = [v1, v2, v3, v4, v5, v6, v7, v8] allOk = all fst allChecks firstFail = head $ filter (not . fst) allChecks ++ [(True, "ALL_CHECKS_PASSED")] in DeedValidation { dv_agent = deedAgent deed , dv_v1 = v1 , dv_v2 = v2 , dv_v3 = v3 , dv_v4 = v4 , dv_v5 = v5 , dv_v6 = v6 , dv_v7 = v7 , dv_v8 = v8 , dv_valid = allOk , dv_reason = snd firstFail } -- ───────────────────────────────────────────────────────────────────────────── -- Output -- ───────────────────────────────────────────────────────────────────────────── printDeedValidation :: DeedValidation -> IO () printDeedValidation dv = do putStrLn $ "agent=" ++ dv_agent dv putStrLn $ "valid=" ++ if dv_valid dv then "true" else "false" putStrLn $ "reason=" ++ dv_reason dv putStrLn $ "v1=" ++ checkLine (dv_v1 dv) putStrLn $ "v2=" ++ checkLine (dv_v2 dv) putStrLn $ "v3=" ++ checkLine (dv_v3 dv) putStrLn $ "v4=" ++ checkLine (dv_v4 dv) putStrLn $ "v5=" ++ checkLine (dv_v5 dv) putStrLn $ "v6=" ++ checkLine (dv_v6 dv) putStrLn $ "v7=" ++ checkLine (dv_v7 dv) putStrLn $ "v8=" ++ checkLine (dv_v8 dv) putStrLn "engine=haskell-deed-validator-lisp-v2" where checkLine (True, msg) = "pass:" ++ msg checkLine (False, msg) = "fail:" ++ msg -- ───────────────────────────────────────────────────────────────────────────── -- Main -- ───────────────────────────────────────────────────────────────────────────── main :: IO () main = do hSetBuffering stdout LineBuffering agentId <- getLine allowedStr <- getLine restrictedStr <- getLine scoreLine <- getLine sealStr <- getLine expiresLine <- getLine statusStr <- getLine escalationStr <- getLine specPathStr <- getLine let specPath = if specPathStr == "default" || null specPathStr then "bridges/lisp/deed-rules.lisp" else specPathStr spec <- loadDeedSpec specPath -- Unix "now" — approximate from expires_at sanity (subprocess has no clock access easily) -- Rust passes current timestamp as 10th line if needed; for now use 0 (expiry check is advisory) let nowTs = 0 :: Integer -- Rust's verify_integrity does authoritative expiry check let scoreD = read scoreLine :: Double expiresD = read expiresLine :: Integer allowed = splitOn ',' allowedStr restricted = splitOn ',' restrictedStr case (mkTrustScore spec scoreD, mkValidSeal spec sealStr) of (Left err, _) -> do putStrLn $ "agent=" ++ agentId putStrLn "valid=false" putStrLn $ "reason=" ++ err putStrLn "engine=haskell-deed-validator-lisp-v2" (_, Left err) -> do putStrLn $ "agent=" ++ agentId putStrLn "valid=false" putStrLn $ "reason=" ++ err putStrLn "engine=haskell-deed-validator-lisp-v2" (Right score, Right seal) -> do let deed = TrustDeed { deedAgent = agentId , deedAllowed = filter (not . null) allowed , deedRestricted = filter (not . null) restricted , deedScore = score , deedSeal = seal , deedExpiresAt = expiresD , deedStatus = map toLower statusStr , deedEscalation = escalationStr } token = mkDeedToken deed result = validateDeed spec nowTs token printDeedValidation result -- ───────────────────────────────────────────────────────────────────────────── -- Utilities -- ───────────────────────────────────────────────────────────────────────────── splitOn :: Char -> String -> [String] splitOn _ "" = [""] splitOn delim str = let (word, rest) = break (== delim) str in word : case rest of [] -> [] (_:xs) -> splitOn delim xs