jn
/
punkshell
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1226 Commits
1 Branch
1 Tag
192 MiB
 
 
 
 
 
 
Tree: 5e9f1c75fc
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '5e9f1c75fc'
${ noResults }
punkshell/scriptlib/developer/assetorigin_check.tcl

460 lines
19 KiB
Raw Blame History

# assetorigin_check.tcl - advisory provenance checker for *.assetorigin.toml
# asset sidecars (G-135; format documented in src/assets/logo/AGENTS.md).
#
# Plain Tcl, no dependencies, no rasterizer, no external binaries - runs under
# any tclsh 8.6+ and any punkshell runtime. Sibling to goals_lint.tcl and
# architecture_lint.tcl. Advisory only: nothing consumes its exit code to gate
# a build.
#
# Each examined asset classifies as exactly ONE of six states, evaluated in
# table order with the first match winning:
# 1 unrecorded no (usable) sidecar for the file - fully supported, silent
# 2 artifact-absent a sidecar exists but its paired asset does not
# 3 replaced asset present, hash differs from the record (regardless
# of source state) - the asset changed since recording
# 4 source-absent asset matches, a recorded source is not present
# 5 stale asset matches, source present but its hash differs - the
# source changed since the artifact was generated
# 6 verified asset matches and every other hash the record carries
# matches too
# Hash comparisons apply only to hashes actually recorded: a source named
# without a source_hash contributes only a presence check. A record whose
# schema is unrecognised, or which carries no usable artifact hash, is ignored
# (the asset classifies unrecorded) - tolerance over error, so a future writer
# cannot break this reader.
#
# usage:
# tclsh scriptlib/developer/assetorigin_check.tcl check ?-all? ?path ...?
# Find *.assetorigin.toml sidecars under the given files/directories and
# classify each paired asset. Default paths: src/ (minus buildsuites/),
# scriptlib/ and goals/ under the repo root containing this script - the
# versioned territory where records live; .git and _build subtrees are
# always skipped. Build outputs (bin/, root modules/ and lib/) and
# reference material are walked only when named explicitly. Findings
# (artifact-absent, replaced, source-absent, stale) print one line each;
# verified and ignored records are counted, and listed too with -all.
# Exit 0 when every record checks out (only verified/unrecorded), else 1.
# tclsh scriptlib/developer/assetorigin_check.tcl status <path> ?<path>...?
# Classify the named assets, one line each, unrecorded included; a
# .assetorigin.toml path names its paired asset. Always exit 0.
# tclsh scriptlib/developer/assetorigin_check.tcl selftest ?-keep?
# Build fixtures in a temp dir demonstrating all six states and the
# precedence/tolerance rules, verify each classification (plus sha256
# test vectors); exit 0 on pass. -keep retains the fixture dir.
set SIDECAR_SUFFIX .assetorigin.toml
# ---------------------------------------------------------------- sha256 (pure Tcl)
# Same algorithm embedded in src/assets/logo/make-ico.tcl; duplicated so each
# script stays runnable standalone under a stock tclsh.
namespace eval sha256 {
variable K {
0x428a2f98 0x71374491 0xb5c0fbcf 0xe9b5dba5 0x3956c25b 0x59f111f1 0x923f82a4 0xab1c5ed5
0xd807aa98 0x12835b01 0x243185be 0x550c7dc3 0x72be5d74 0x80deb1fe 0x9bdc06a7 0xc19bf174
0xe49b69c1 0xefbe4786 0x0fc19dc6 0x240ca1cc 0x2de92c6f 0x4a7484aa 0x5cb0a9dc 0x76f988da
0x983e5152 0xa831c66d 0xb00327c8 0xbf597fc7 0xc6e00bf3 0xd5a79147 0x06ca6351 0x14292967
0x27b70a85 0x2e1b2138 0x4d2c6dfc 0x53380d13 0x650a7354 0x766a0abb 0x81c2c92e 0x92722c85
0xa2bfe8a1 0xa81a664b 0xc24b8b70 0xc76c51a3 0xd192e819 0xd6990624 0xf40e3585 0x106aa070
0x19a4c116 0x1e376c08 0x2748774c 0x34b0bcb5 0x391c0cb3 0x4ed8aa4a 0x5b9cca4f 0x682e6ff3
0x748f82ee 0x78a5636f 0x84c87814 0x8cc70208 0x90befffa 0xa4506ceb 0xbef9a3f7 0xc67178f2
}
proc hex {data} {
variable K
set bitlen [expr {wide([string length $data]) * 8}]
append data \x80
set pad [expr {(56 - [string length $data] % 64 + 64) % 64}]
append data [string repeat \x00 $pad] [binary format W $bitlen]
set h0 0x6a09e667; set h1 0xbb67ae85; set h2 0x3c6ef372; set h3 0xa54ff53a
set h4 0x510e527f; set h5 0x9b05688c; set h6 0x1f83d9ab; set h7 0x5be0cd19
set n [string length $data]
for {set off 0} {$off < $n} {incr off 64} {
binary scan [string range $data $off [expr {$off + 63}]] Iu16 w
for {set t 16} {$t < 64} {incr t} {
set x [lindex $w [expr {$t - 15}]]
set s0 [expr {((($x >> 7) | ($x << 25)) ^ (($x >> 18) | ($x << 14)) ^ ($x >> 3)) & 0xffffffff}]
set x [lindex $w [expr {$t - 2}]]
set s1 [expr {((($x >> 17) | ($x << 15)) ^ (($x >> 19) | ($x << 13)) ^ ($x >> 10)) & 0xffffffff}]
lappend w [expr {([lindex $w [expr {$t - 16}]] + $s0 + [lindex $w [expr {$t - 7}]] + $s1) & 0xffffffff}]
}
set a $h0; set b $h1; set c $h2; set d $h3
set e $h4; set f $h5; set g $h6; set h $h7
for {set t 0} {$t < 64} {incr t} {
set S1 [expr {((($e >> 6) | ($e << 26)) ^ (($e >> 11) | ($e << 21)) ^ (($e >> 25) | ($e << 7))) & 0xffffffff}]
set ch [expr {(($e & $f) ^ (~$e & $g)) & 0xffffffff}]
set T1 [expr {($h + $S1 + $ch + [lindex $K $t] + [lindex $w $t]) & 0xffffffff}]
set S0 [expr {((($a >> 2) | ($a << 30)) ^ (($a >> 13) | ($a << 19)) ^ (($a >> 22) | ($a << 10))) & 0xffffffff}]
set maj [expr {($a & $b) ^ ($a & $c) ^ ($b & $c)}]
set T2 [expr {($S0 + $maj) & 0xffffffff}]
set h $g; set g $f; set f $e; set e [expr {($d + $T1) & 0xffffffff}]
set d $c; set c $b; set b $a; set a [expr {($T1 + $T2) & 0xffffffff}]
}
set h0 [expr {($h0 + $a) & 0xffffffff}]; set h1 [expr {($h1 + $b) & 0xffffffff}]
set h2 [expr {($h2 + $c) & 0xffffffff}]; set h3 [expr {($h3 + $d) & 0xffffffff}]
set h4 [expr {($h4 + $e) & 0xffffffff}]; set h5 [expr {($h5 + $f) & 0xffffffff}]
set h6 [expr {($h6 + $g) & 0xffffffff}]; set h7 [expr {($h7 + $h) & 0xffffffff}]
}
return [format %08x%08x%08x%08x%08x%08x%08x%08x $h0 $h1 $h2 $h3 $h4 $h5 $h6 $h7]
}
proc file_hex {path} {
set f [open $path rb]
set data [read $f]
close $f
return [hex $data]
}
}
# ---------------------------------------------------------------- record reader
# Tolerant flat-TOML subset reader for schema-1 sidecars. Returns a key->value
# dict of the root table. Comments, blank lines and unparseable lines are
# skipped; parsing stops at the first [table]/[[array]] header (TOML guarantees
# root-table keys precede any table, and schema 1 defines none); basic "..."
# and literal '...' strings and bare scalars are understood; duplicate keys:
# last one wins.
proc sidecar_parse {path} {
set f [open $path rb]
set raw [read $f]
close $f
set text [encoding convertfrom utf-8 $raw]
set kv [dict create]
foreach line [split $text \n] {
set line [string trim [string map [list \r {}] $line]]
if {$line eq "" || [string index $line 0] eq "#"} continue
if {[string index $line 0] eq "\["} break
set eq [string first = $line]
if {$eq < 1} continue
set key [string trim [string range $line 0 [expr {$eq - 1}]]]
set val [string trim [string range $line [expr {$eq + 1}] end]]
if {$key eq ""} continue
set c0 [string index $val 0]
if {$c0 eq "\""} {
set out ""
set ok 0
set n [string length $val]
for {set i 1} {$i < $n} {incr i} {
set ch [string index $val $i]
if {$ch eq "\\"} {
incr i
set esc [string index $val $i]
switch -- $esc {
\" {append out \"}
\\ {append out \\}
n {append out \n}
t {append out \t}
r {append out \r}
default {append out \\$esc}
}
} elseif {$ch eq "\""} {
set ok 1
break
} else {
append out $ch
}
}
if {!$ok} continue
set val $out
} elseif {$c0 eq "'"} {
set end [string first ' $val 1]
if {$end < 0} continue
set val [string range $val 1 [expr {$end - 1}]]
} else {
set cmt [string first # $val]
if {$cmt >= 0} {
set val [string trim [string range $val 0 [expr {$cmt - 1}]]]
}
}
dict set kv $key $val
}
return $kv
}
# A recorded hash usable by this reader: "sha256:<64 hex>". Anything else
# (absent key, unrecognised algorithm prefix, malformed hex) returns "" and is
# treated as not recorded.
proc hash_recorded {kv key} {
if {![dict exists $kv $key]} {return ""}
set v [dict get $kv $key]
if {[string match sha256:* $v]} {
set hexpart [string tolower [string range $v 7 end]]
if {[string length $hexpart] == 64 && [string is xdigit -strict $hexpart]} {
return $hexpart
}
}
return ""
}
# ---------------------------------------------------------------- classification
# Classify the asset paired with (or lacking) a sidecar. Returns {state detail}.
proc classify {asset} {
global SIDECAR_SUFFIX
set sidecar $asset$SIDECAR_SUFFIX
if {![file exists $sidecar]} {
return [list unrecorded ""]
}
if {[catch {sidecar_parse $sidecar} kv]} {
return [list unrecorded "sidecar unreadable, ignored: $kv"]
}
if {![dict exists $kv schema] || [dict get $kv schema] ne "1"} {
set s [expr {[dict exists $kv schema] ? [dict get $kv schema] : "missing"}]
return [list unrecorded "sidecar ignored: schema $s not recognised"]
}
set arthash [hash_recorded $kv hash]
if {$arthash eq ""} {
return [list unrecorded "sidecar ignored: no usable artifact hash"]
}
if {![file exists $asset]} {
return [list artifact-absent "sidecar present, its paired asset is gone"]
}
if {[sha256::file_hex $asset] ne $arthash} {
return [list replaced "asset hash differs from the record"]
}
if {[dict exists $kv source]} {
set srcref [dict get $kv source]
set src [file join [file dirname $asset] $srcref]
if {![file exists $src]} {
return [list source-absent "recorded source $srcref not present"]
}
set srchash [hash_recorded $kv source_hash]
if {$srchash ne "" && [sha256::file_hex $src] ne $srchash} {
return [list stale "source $srcref changed since the artifact was generated"]
}
}
return [list verified ""]
}
# ---------------------------------------------------------------- scanning
proc find_sidecars {paths {skipdirs {}}} {
global SIDECAR_SUFFIX
set skips {}
foreach s $skipdirs {
lappend skips [file normalize $s]
}
set found {}
set queue {}
foreach p $paths {
lappend queue [file normalize $p]
}
while {[llength $queue]} {
set p [lindex $queue 0]
set queue [lrange $queue 1 end]
if {[file isdirectory $p]} {
if {[file tail $p] in {.git _build} || $p in $skips} continue
foreach sub [lsort [glob -nocomplain -directory $p *]] {
lappend queue $sub
}
} elseif {[string match *$SIDECAR_SUFFIX $p]} {
lappend found $p
}
}
return [lsort -unique $found]
}
proc display_path {path root} {
set np [file normalize $path]
set nr [file normalize $root]
if {[string equal -nocase -length [expr {[string length $nr] + 1}] $np "$nr/"]} {
return [string range $np [expr {[string length $nr] + 1}] end]
}
return $np
}
# ---------------------------------------------------------------- subcommands
proc cmd_check {argl} {
global SIDECAR_SUFFIX
set all 0
set paths {}
foreach a $argl {
if {$a eq "-all"} {set all 1} else {lappend paths $a}
}
set root [file dirname [file dirname [file dirname [file normalize [info script]]]]]
set skipdirs {}
if {![llength $paths]} {
set paths [list [file join $root src] [file join $root scriptlib] [file join $root goals]]
set skipdirs [list [file join $root src buildsuites]]
}
set sidecars [find_sidecars $paths $skipdirs]
set counts [dict create]
set findings 0
foreach sc $sidecars {
set asset [string range $sc 0 end-[string length $SIDECAR_SUFFIX]]
lassign [classify $asset] state detail
dict incr counts $state
set line "$state: [display_path $asset $root]"
if {$detail ne ""} {append line " ($detail)"}
if {$state in {artifact-absent replaced source-absent stale}} {
incr findings
puts $line
} elseif {$all} {
puts $line
}
}
set summary {}
foreach state {verified unrecorded artifact-absent replaced source-absent stale} {
if {[dict exists $counts $state]} {
lappend summary "[dict get $counts $state] $state"
}
}
if {![llength $sidecars]} {
puts "assetorigin_check: no sidecars found"
} else {
puts "assetorigin_check: [llength $sidecars] record(s): [join $summary {, }]"
}
exit [expr {$findings ? 1 : 0}]
}
proc cmd_status {argl} {
global SIDECAR_SUFFIX
if {![llength $argl]} {
puts stderr "status: at least one path required"
exit 2
}
foreach p $argl {
if {[string match *$SIDECAR_SUFFIX $p]} {
set p [string range $p 0 end-[string length $SIDECAR_SUFFIX]]
}
lassign [classify $p] state detail
set line "$state: $p"
if {$detail ne ""} {append line " ($detail)"}
puts $line
}
exit 0
}
proc cmd_selftest {argl} {
set keep [expr {"-keep" in $argl}]
set base ""
foreach v {TEMP TMP TMPDIR} {
if {[info exists ::env($v)] && $::env($v) ne ""} {
set base $::env($v)
break
}
}
if {$base eq ""} {set base /tmp}
set dir [file join $base "assetorigin-selftest-[pid]"]
file delete -force $dir
file mkdir $dir
set pass 0
set fail 0
# sha256 implementation vectors first - the classifications below lean on it
foreach {input want} {
{} e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855
abc ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad
abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq 248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1
} {
set got [sha256::hex $input]
if {$got eq $want} {
incr pass
} else {
incr fail
puts "FAIL sha256 vector [string range $input 0 10]...: got $got want $want"
}
}
proc putfile {path content} {
set f [open $path wb]
puts -nonewline $f $content
close $f
}
proc sidecarfile {dir asset lines} {
putfile [file join $dir "$asset.assetorigin.toml"] "[join $lines \n]\n"
}
set H(src) [sha256::hex "SOURCE-V1"]
set H(old) [sha256::hex "SOURCE-V0"]
putfile [file join $dir s.svg] "SOURCE-V1"
# fixture name -> {asset-content sidecar-lines expected-state note}
# asset-content of "-" means the asset file is not created.
set fixtures {}
lappend fixtures [list a.bin "AAA" \
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"s.svg\"" "source_hash = \"sha256:%S%\""] \
verified "full record, all hashes match"]
lappend fixtures [list b.bin "-" \
[list "schema = 1" "hash = \"sha256:%H_abc%\""] \
artifact-absent "record whose paired asset is gone"]
lappend fixtures [list c.bin "CCC-NEW" \
[list "schema = 1" "hash = \"sha256:%H_abc%\"" "source = \"missing.svg\"" "source_hash = \"sha256:%S%\""] \
replaced "asset changed since recording; wins over its missing source (rule-3 precedence)"]
lappend fixtures [list d.bin "DDD" \
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"nowhere.svg\"" "source_hash = \"sha256:%S%\""] \
source-absent "recorded source not present"]
lappend fixtures [list e.bin "EEE" \
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"s.svg\"" "source_hash = \"sha256:%OLD%\""] \
stale "source changed since the artifact was generated"]
lappend fixtures [list f.bin "FFF" {} unrecorded "no sidecar at all"]
lappend fixtures [list g.bin "GGG" \
[list "schema = 1" "hash = \"sha256:%A%\""] \
verified "hash-only record verifies on the artifact hash alone"]
lappend fixtures [list h.bin "HHH" \
[list "schema = 99" "hash = \"sha256:%A%\""] \
unrecorded "unrecognised schema is ignored, not an error"]
lappend fixtures [list i.bin "III" \
[list "schema = 1" "future_key = \"whatever\"" "hash = \"sha256:%A%\"" "\[future_table\]" "hash = \"sha256:%H_abc%\""] \
verified "unknown keys skipped; root table ends at the first table header"]
lappend fixtures [list j.bin "JJJ" \
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"s.svg\""] \
verified "source named without source_hash is a presence check only"]
lappend fixtures [list k.bin "KKK" \
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"gone.svg\""] \
source-absent "presence check still applies without a source_hash"]
lappend fixtures [list l.bin "LLL" \
[list "schema = 1" "hash = \"sha256:%A%\"" "source = \"s.svg\"" "source_hash = \"sha512:beef\""] \
verified "unrecognised source-hash algorithm treated as not recorded"]
lappend fixtures [list m.bin "MMM" \
[list "schema = 1" "source = \"s.svg\""] \
unrecorded "record without a usable artifact hash is ignored"]
set habc [sha256::hex abc]
foreach fx $fixtures {
lassign $fx name content lines expected note
set asset [file join $dir $name]
if {$content ne "-"} {
putfile $asset $content
}
if {[llength $lines]} {
set subst [list %A% [sha256::hex $content] %S% $H(src) %OLD% $H(old) %H_abc% $habc]
set out {}
foreach l $lines {
lappend out [string map $subst $l]
}
sidecarfile $dir $name $out
}
lassign [classify $asset] state detail
if {$state eq $expected} {
incr pass
puts "PASS $name $state ($note)"
} else {
incr fail
puts "FAIL $name got $state want $expected ($note) $detail"
}
}
set keptnote ""
if {$keep} {
set keptnote " (fixtures kept: $dir)"
}
puts "assetorigin_check selftest: $pass passed, $fail failed$keptnote"
if {!$keep} {
file delete -force $dir
}
exit [expr {$fail ? 1 : 0}]
}
# ---------------------------------------------------------------- dispatch
set cmd [lindex $argv 0]
set rest [lrange $argv 1 end]
switch -- $cmd {
check {cmd_check $rest}
status {cmd_status $rest}
selftest {cmd_selftest $rest}
default {
puts stderr "usage: tclsh assetorigin_check.tcl check ?-all? ?path ...?"
puts stderr " tclsh assetorigin_check.tcl status <path> ?<path>...?"
puts stderr " tclsh assetorigin_check.tcl selftest ?-keep?"
exit 2
}
}