From c1e9562b7a4dc4f00d93c17ac50b8697b613582c Mon Sep 17 00:00:00 2001
From: aleteoryx <alyx@aleteoryx.me>
Date: Sun, 10 Nov 2024 15:35:28 -0500
Subject: [PATCH] plugin loading prompts

---
 db/main.tcl             |   9 +++
 migrate_core.tcl        |   5 +-
 plugins.tcl             | 167 +++++++++++++++++++++++++++++++++++++---
 testplugin/manifest.tcl |   5 +-
 threads.tcl             |  49 +++++++++++-
 5 files changed, 222 insertions(+), 13 deletions(-)

diff --git a/db/main.tcl b/db/main.tcl
index fe649ad..fe14208 100644
--- a/db/main.tcl
+++ b/db/main.tcl
@@ -27,3 +27,12 @@ proc path_to_core {} {
   global data_dir
   return [file join $data_dir core.db]
 }
+
+proc backup {} {
+  global log data_dir
+  set backup_dir [string cat $data_dir _backup_ [clock microseconds]]
+  ${log}::info "backing up data directory to $backup_dir..."
+  file copy $data_dir $backup_dir
+  ${log}::info "backup to $backup_dir complete!"
+  return $backup_dir
+}
diff --git a/migrate_core.tcl b/migrate_core.tcl
index d2edaa7..d4e110d 100644
--- a/migrate_core.tcl
+++ b/migrate_core.tcl
@@ -8,8 +8,9 @@ migrator eval {
 CREATE TABLE plugins (slug TEXT NOT NULL, -- corresponds directly to manifest
                       namespace TEXT NOT NULL, -- corresponds directly to manifest
                       version TEXT NOT NULL, -- corresponds directly to manifest
-                      hashes TEXT NOT NULL, -- dict of path -> hash
-                      trusted BOOL NOT NULL, -- bypass security checks for plugins with this name
+                      manifest_hash TEXT NOT NULL, -- sha256
+                      trusted_until TEXT NOT NULL, -- ignore manifest changes if loading before timestamp
+                      updated_on TEXT NOT NULL, -- date of last update
                       priority INTEGER NOT NULL, -- load priority
                       PRIMARY KEY (slug, namespace));
   }
diff --git a/plugins.tcl b/plugins.tcl
index 39b8495..bcb325f 100644
--- a/plugins.tcl
+++ b/plugins.tcl
@@ -34,7 +34,7 @@ namespace eval plugins {
     version {$val != ""} }
   variable mf_optional {
     description 1
-    author 1
+    authors 1
     license 1 }
   variable mf_procs {
     
@@ -102,7 +102,7 @@ namespace eval plugins {
 
   proc enroll_interp {tid iid} {}
 
-  proc load {dir {allow_internal 0}} {
+  proc load {dir {skip_prompt 0}} {
     variable log
     variable manifest_reader
 
@@ -170,22 +170,171 @@ namespace eval plugins {
     set pl_slug [dict get $manifest slug]
     set pl_version [dict get $manifest version]
 
-    ${log}::debug "manifest loaded: ${pl_name} (${pl_namespace}::${pl_slug}) v[join ${pl_version} .]"
+    set pl_qslug "${pl_namespace}::${pl_slug}"
+    set pl_verstr "v[join $pl_version .]"
+
+    # qualified slug
+    dict set manifest qslug $pl_qslug
+    dict set manifest verstr $pl_verstr
+
+    ${log}::debug "manifest loaded: $pl_name (${pl_qslug}) $pl_verstr"
 
     set stored [core_db eval {
-      SELECT hashes, version, trusted FROM plugins
+      SELECT manifest_hash, version, trusted_until FROM plugins
         WHERE slug = $pl_slug
           AND namespace = $pl_namespace}]
 
+#    load_license manifest
+
     if ![llength $stored] {
-      puts "new plugin"
+      tailcall int_load_new $skip_prompt $manifest $dir
     } else {
-      lassign $stored st_hashes st_version st_trusted
+      lassign $stored st_mf_hash st_version st_trusted_till
       switch -- [vercmp $pl_version $st_version] {
-        0 { puts "same version" }
-       -1 { puts "older version" }
-        1 { puts "newer version" }
+        0 { tailcall int_load_existing $manifest $dir $mf_path $st_mf_hash $st_trusted_till }
+        1 { tailcall int_load_updated $skip_prompt $manifest $dir $st_version $st_trusted_till }
+       -1 { tailcall int_load_old $manifest $dir $st_version }
+      }
+    }
+  }
+
+  proc int_load_new {skip_prompt manifest dir} {
+    variable log
+    ${log}::info "installing new plugin [dict get $manifest qslug]"
+
+    if {!$skip_prompt} {
+      set manifest [list $manifest]
+      set dir [list $dir]
+      t::exec tclircc::ui {
+        set manifest %manifest
+        tk_messageBox -type yesno \
+          -title "Plugin Installation" \
+          -icon "question" \
+          -message "Do you want to install \"[dict get $manifest name]\"?" \
+          -detail [string cat \
+            "[dict get $manifest qslug] [dict get $manifest verstr]" \
+            "\nBy [join [dict get $manifest authors] ,]." \
+            "\n\n[dict get $manifest license]" ]
+      } {
+        set manifest %manifest
+        switch -- $result {
+          yes {
+            ::plugins::install $manifest %dir
+          }
+          no {
+            set log %log
+            ${log}::info "user cancelled installation of plugin [dict get $manifest qslug]"
+          }
+        }
       }
+    } else {
+      install $manifest $dir
     }
   }
+  proc int_load_existing {manifest dir mf_path mf_hash trusted_till} {
+    variable log
+    ${log}::debug "loading existing plugin [dict get $manifest qslug]"
+
+    if {$trusted_till >= [clock seconds]} {
+      install $manifest $dir
+    } elseif {[sha2::sha256 -file $mf_path] == $mf_hash} {
+      install $manifest $dir
+    } else {
+      ${log}::warn "plugin may have been tampered with!"
+
+      set manifest [list $manifest]
+      set dir [list $dir]
+      t::exec tclircc::ui {
+        set manifest %manifest
+        tk_messageBox -type yesno \
+          -title "Plugin Tampering Detected!" \
+          -icon "warning" \
+          -message "\"[dict get $manifest name]\" ([dict get $manifest qslug]) has been edited since last load!" \
+          -detail [string cat \
+            "This may indicate a security compromise, do you want to continue loading it?" \
+            " (If you are doing plugin development, set the \"Trusted Until\" option!)"]
+      } {
+        set manifest %manifest
+        set log %log
+        switch -- $result {
+          yes {
+            ${log}::warn "loading [dict get $manifest qslug] despite potential tampering!"
+            ::plugins::install $manifest %dir
+          }
+          no {
+            ${log}::info "not loading [dict get $manifest qslug] due to tampering"
+          }
+        }
+      }
+    }
+  }
+  proc int_load_updated {skip_prompt manifest dir version trusted_till} {
+    variable log
+    ${log}::info "updating plugin [dict get $manifest qslug] (v[join $version .] -> [dict get $manifest verstr])"
+
+    if {!$skip_prompt && [clock seconds] > $trusted_till} {
+      set manifest [list $manifest]
+      set dir [list $dir]
+      t::exec tclircc::ui {
+        set manifest %manifest
+        tk_messageBox -type yesno \
+          -title "Plugin Update" \
+          -icon "question" \
+          -message "Do you want to update \"[dict get $manifest name]\"?" \
+          -detail [string cat \
+            "[dict get $manifest qslug] [dict get $manifest verstr]" \
+            "\nBy [join [dict get $manifest authors] ,]." \
+            "\n\n[dict get $manifest license]" ]
+      } {
+        set manifest %manifest
+        switch -- $result {
+          yes {
+            ::plugins::install $manifest %dir
+          }
+          no {
+            set log %log
+            ${log}::info "user cancelled update of plugin [dict get $manifest qslug]"
+          }
+        }
+      }
+    } else {
+      install $manifest $dir
+    }
+  }
+  proc int_load_old {manifest dir version} {
+    variable log
+    ${log}::warn "attempting to load older version of [dict get $manifest qslug] (v[join $version .] -> [dict get $manifest verstr])"
+
+    set verstr [list "v[join $version .]"]
+    set manifest [list $manifest]
+    set dir [list $dir]
+    t::exec tclircc::ui {
+      set manifest %manifest
+      tk_messageBox -type yesno \
+        -title "Plugin Downgrade!" \
+        -icon "warning" \
+        -message [string cat \
+          "Are you sure you want to downgrade \"[dict get $manifest name]" \
+          "\" ([dict get $manifest qslug])? A database backup will be made." ] \
+        -detail [string cat \
+          "Last saw " %verstr ", attempting to load [dict get $manifest verstr]."]
+    } {
+      set manifest %manifest
+      set log %log
+      switch -- $result {
+        yes {
+          ${log}::warn "downgrading [dict get $manifest qslug]! making a backup!"
+          t::exec tclircc::db backup {
+            ::plugins::install $manifest %dir
+          }
+        }
+        no {
+          ${log}::info "not downgrading [dict get $manifest qslug]"
+        }
+      }
+    }
+  }
+  proc install {manifest dir} {
+
+  }
 }
diff --git a/testplugin/manifest.tcl b/testplugin/manifest.tcl
index 8440ed8..beebcde 100644
--- a/testplugin/manifest.tcl
+++ b/testplugin/manifest.tcl
@@ -1,4 +1,7 @@
 set name "test plugin"
 set slug "test"
 set namespace "aleteoryx"
-set version {0 0 1}
+set version {0 0}
+
+set authors {Aleteoryx <alyx@aleteoryx.me>}
+set license spdx:WTFPL
diff --git a/threads.tcl b/threads.tcl
index 6a207bb..67b1f1c 100644
--- a/threads.tcl
+++ b/threads.tcl
@@ -5,6 +5,7 @@ namespace eval threads {
   variable t_ns_script {
     namespace eval ::t {
       variable ns
+      variable self
       proc update {} {
         variable ns
         thread::send -head [set ns(main)] threads::update
@@ -17,9 +18,55 @@ namespace eval threads {
         variable log
         parray t::ns
       }
+      proc util_pctsub {script} {
+        set new_script {}
+        set idx 0
+        while {[set subst_start [string first "%" $script $idx]] != -1} {
+          append new_script [string range $script $idx $subst_start-1]
+          if {[string index $script $subst_start+1] == "%"} {
+            append new_script %
+            set idx [expr {$subst_start + 2}]
+            continue
+          }
+          regexp -start [expr {$subst_start + 1}] -indices {[^A-Za-z0-9_:]} $script match
+          if {[llength $match]} {
+            lassign $match subst_end
+            set subst_end $subst_end-1
+          } else {
+            set subst_end [string length $script]
+          }
+          upvar [string range $script $subst_start+1 $subst_end] subst_data
+          append new_script $subst_data
+          set idx [expr $subst_end + 1]
+        }
+        append new_script [string range $script $idx end]
+
+        return $new_script
+      }
+      proc exec {name script {followup {}}} {
+        variable ns
+        variable self
+
+        set script [uplevel [list ::t::util_pctsub $script]]
+        set followup [uplevel [list ::t::util_pctsub $followup]]
+
+        if [string length $followup] {
+          set realscript {
+            set result [eval %script]
+            set script [concat [list set result $result] ";" %followup]
+            thread::send -async [t::ns %self] $script
+          }
+          regsub %self $realscript [list $self] realscript
+          regsub %followup $realscript [list $followup] realscript
+          regsub %script $realscript [list $script] script
+        }
+
+        thread::send -async [set ns($name)] $script
+      }
     }
   }
   eval $t_ns_script
+  set ::t::self "main"
 
   proc manage {tid name} {
     variable threads
@@ -28,7 +75,7 @@ namespace eval threads {
     dict set threads $name $tid
     ${log}::debug "managing thread $tid as \"$name\""
 
-    thread::send -head $tid $t_ns_script
+    thread::send -head $tid [concat $t_ns_script ";" [list set ::t::self $name]]
 
     ::threads::update
   }
-- 
2.45.2