From 59555e2c6591b0f33ae0aa5e91c63a02f797e8e6 Mon Sep 17 00:00:00 2001 From: Aleteoryx Date: Sun, 29 Dec 2024 02:29:49 -0500 Subject: [PATCH] ui work, prepping for network add ui --- src/db.tcl | 88 +++++++++++++++++++++++++++++++++++ src/db/networks.tcl | 17 +++++++ src/deps.tcl | 3 ++ src/history.tcl | 42 +++++++++++++++++ src/main.tcl | 19 +++++++- src/migrate_core.tcl | 59 ------------------------ src/persist.tcl | 2 + src/ui.tcl | 106 +++++++++++++++++++++++++++++++++++++++++++ src/util.tcl | 5 ++ 9 files changed, 280 insertions(+), 61 deletions(-) create mode 100644 src/db.tcl create mode 100644 src/db/networks.tcl create mode 100644 src/history.tcl delete mode 100644 src/migrate_core.tcl create mode 100644 src/ui.tcl create mode 100644 src/util.tcl diff --git a/src/db.tcl b/src/db.tcl new file mode 100644 index 0000000..2dac793 --- /dev/null +++ b/src/db.tcl @@ -0,0 +1,88 @@ +#*** +# [manpage_begin migrate_core tclircc 0.0.1] +# [titledesc {Script migrate_core.tcl}] +# [description] + +# TODO: make this more robust maybe + +namespace eval db { + variable log [logger::init tclircc::db] + variable logc [logger::init tclircc::db::cleanup] + variable autocleanup_dbs {} + variable autocleanup_steps {} + variable autocleanup_task {} +} + +proc db::cleanup {} { + variable autocleanup_dbs + variable autocleanup_steps + variable logc + foreach db $autocleanup_dbs { + ${logc}::debug "cleaning up \"$db\"..." + if [dict exists $autocleanup_steps $db] { + ${logc}::debug "executing additional script on \"$db\"..." + $db eval [dict get $autocleanup_steps $db] + } + $db eval { VACUUM; } + ${logc}::debug "cleaned up \"$db\"!" + } +} +proc db::autocleanup {interval} { + variable autocleanup_task + db::cleanup + set autocleanup_task [after $interval [list db::autocleanup $interval]] +} + +proc db::init_core {data_dir} { + variable autocleanup_dbs + sqlite3 core_db [file join $data_dir core.db] + lappend autocleanup_dbs core_db + + interp create migrator + + migrator eval { + lappend migrations 0 {init networks} { + CREATE TABLE networks (name TEXT NOT NULL, + servers TEXT NOT NULL, + autoconnect BOOL NOT NULL DEFAULT 0, + creds TEXT NOT NULL DEFAULT ''); + } + } + + migrator alias core_db core_db + migrator eval { + package require logger + package require Tk + wm withdraw . + + set log [logger::init tclircc::db::migrate] + + ${log}::debug "starting migrations" + if ![core_db eval { + SELECT count(*) FROM sqlite_master WHERE name="_migrations"}] { + ${log}::info "initializing core db!" + core_db eval {CREATE TABLE _migrations (id INTEGER PRIMARY KEY, date TEXT)} + } + + foreach {id name contents} $migrations { + # TODO: debug interpolation? + if ![core_db eval "SELECT count(*) FROM _migrations WHERE id=$id"] { + ${log}::info "performing migration $id: $name" + core_db eval BEGIN + set migrationdate [clock seconds] + core_db eval $contents + core_db eval "INSERT INTO _migrations (id, date) VALUES ($id, $migrationdate)" + set last $id + core_db eval COMMIT + } elseif [info exists last] { + ${log}::warn "completed migrations exist after incomplete migration $last, core database may be corrupted!" + } + } + + ${log}::info "core db migrated!" + } + interp delete migrator +} + +#*** +# [manpage_end] diff --git a/src/db/networks.tcl b/src/db/networks.tcl new file mode 100644 index 0000000..7e59856 --- /dev/null +++ b/src/db/networks.tcl @@ -0,0 +1,17 @@ +namespace eval db::networks {} + +proc db::networks::ls {db} { + set ret {} + $db eval {SELECT rowid as id, * FROM networks;} network { + set ndict {} + foreach k $network(*) { + dict set ndict $k [set network($k)] + } + lappend ret $ndict + } + return $ret +} + +proc db::networks::add {db name servers} { + $db eval {INSERT INTO networks VALUES ($name $servers);} +} diff --git a/src/deps.tcl b/src/deps.tcl index 0b32aed..25294cc 100644 --- a/src/deps.tcl +++ b/src/deps.tcl @@ -4,6 +4,9 @@ set deps { sqlite3 3.47 tls 1.7 logger 0.9 + md5 2.0 + tcl::chan::random 1.0 + tcl::randomseed 1.0 } set missing {} diff --git a/src/history.tcl b/src/history.tcl new file mode 100644 index 0000000..38bae98 --- /dev/null +++ b/src/history.tcl @@ -0,0 +1,42 @@ +namespace eval hist { + variable known_channels +} + +# channel names can't contain spaces +proc hist::to_tablename {chan} { + regsub {\\} $chan { s} chan + regsub {"} $chan { q} chan + return $chan +} + +proc hist::ensure {db chan} { + variable known_channels + set chan [hist::to_tablename $chan] + if [dict exists [set known_channels($db)] $chan] { return } + + if ![$db exists {SELECT * FROM sqlite_master WHERE type='table' AND name=$chan}] { + $db eval "CREATE TABLE \"$chan\" (id TEXT NOT NULL PRIMARY KEY, src TEXT NOT NULL, msg TEXT NOT NULL, ts INTEGER NOT NULL, metadata TEXT NOT NULL);" + $db eval "CREATE INDEX \"${chan}_src\" ON \"$chan\" (src);" + $db eval "CREATE INDEX \"${chan}_ts\" ON \"$chan\" (ts);" + } + dict set known_channels($db) $chan {} + + set cleanup_script {} + foreach chan [dict keys [set known_channels($db)]] { + append cleanup_script "REINDEX \"$chan\"; REINDEX \"${chan}_src\"; REINDEX \"${chan}_ts\"; " + } + + dict set ::db::autocleanup_steps $db $cleanup_script +} + +proc hist::put {db chan source message timestamp metadata} { + set chan [hist::to_tablename $chan] + hist::ensure $db $chan +} + +proc hist::open {db path} { + variable known_channels + sqlite3 $db $path + set known_channels($db) {} + lappend ::db::autocleanup_dbs $db +} diff --git a/src/main.tcl b/src/main.tcl index 72cf0c5..a4efd5e 100755 --- a/src/main.tcl +++ b/src/main.tcl @@ -1,5 +1,7 @@ #!/bin/env tclsh +set version 0.0.1 + set boot_dir [pwd] cd [file dirname [dict get [info frame [info frame]] file]] @@ -8,9 +10,22 @@ puts "pwd=[pwd]" source persist.tcl source deps.tcl +source util.tcl set log [logger::init tclircc::main] -sqlite3 core_db [file join $data_dir core.db] +source db.tcl +db::init_core $data_dir +source db/networks.tcl + +source history.tcl +hist::open hist_db [file join $data_dir foo.db] +hist::ensure hist_db #foo + +# cleanup every 6 hours, should be heuristic-driven eventually +db::autocleanup [expr {6 * 60 * 60 * 1000}] -source migrate_core.tcl +source ui.tcl +wm withdraw . +toplevel .mainwin +ui::basic::setup .mainwin diff --git a/src/migrate_core.tcl b/src/migrate_core.tcl deleted file mode 100644 index dda4a3d..0000000 --- a/src/migrate_core.tcl +++ /dev/null @@ -1,59 +0,0 @@ -#*** -# [manpage_begin migrate_core tclircc 0.0.1] -# [titledesc {Script migrate_core.tcl}] -# [description] - -# TODO: make this more robust maybe - -interp create migrator - -migrator eval { - lappend migrations 0 {init plugins} { --- init plugins -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 - 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)); - } -} - -migrator alias db core_db -migrator eval { - package require logger - package require Tk - wm withdraw . - - set log [logger::init tclircc::db::migrate] - - ${log}::debug "starting migrations" - if ![db eval { - SELECT count(*) FROM sqlite_master WHERE name="_migrations"}] { - ${log}::info "initializing core db!" - db eval {CREATE TABLE _migrations (id INTEGER PRIMARY KEY, date TEXT)} - } - - foreach {id name contents} $migrations { - # TODO: debug interpolation? - if ![db eval "SELECT count(*) FROM _migrations WHERE id=$id"] { - ${log}::info "performing migration $id: $name" - db eval BEGIN - set migrationdate [clock seconds] - db eval $contents - db eval "INSERT INTO _migrations (id, date) VALUES ($id, $migrationdate)" - set last $id - db eval COMMIT - } elseif [info exists last] { - ${log}::warn "completed migrations exist after incomplete migration $last, core database may be corrupted!" - } - } - - ${log}::info "core db migrated!" -} -interp delete migrator - -#*** -# [manpage_end] diff --git a/src/persist.tcl b/src/persist.tcl index f9597b3..23c8db0 100644 --- a/src/persist.tcl +++ b/src/persist.tcl @@ -15,3 +15,5 @@ switch -- [set tcl_platform(platform)] { return -code error {Unknown platform, can't store config.} } } + +file mkdir $data_dir diff --git a/src/ui.tcl b/src/ui.tcl new file mode 100644 index 0000000..38f3339 --- /dev/null +++ b/src/ui.tcl @@ -0,0 +1,106 @@ +namespace eval ui {} +namespace eval ui::basic {} + +proc ui::basic::setup {mount} { + global version + + menu $mount.menu + $mount configure -menu "$mount.menu" + + menu $mount.menu.conn + menu $mount.menu.server + + menu $mount.menu.me + $mount.menu.me add command -label "About" -command [subst { + tk_messageBox -title "About tclircc" \ + -message "tclircc $version" \ + -detail "by Aleteoryx\nhttps://amehut.dev/~aleteoryx/tclircc\n\nThis software is in the public domain." \ + -type ok \ + -parent $mount }] + + $mount.menu add cascade -label "connections" -menu $mount.menu.conn + $mount.menu add cascade -label "networks" -menu $mount.menu.network + $mount.menu add cascade -label "tclircc" -menu $mount.menu.me +} +proc ui::basic::teardown {mount} { + destroy $mount.menu +} + +namespace eval ui::form { + variable forms + variable form_n 0 +} + +proc ui::form::show {title heading fields check finish cancel} { + variable forms + variable form_n + set tl .form$form_n + incr form_n + + set forms(${tl}) [list fields $fields check $check finish $finish cancel $cancel] + + set pad_n 0 + + toplevel $tl + wm title $tl $title + label $tl.heading -text $heading -font TkHeadingFont + pack $tl.heading -side top + frame $tl.pad$pad_n -height 10 + pack $tl.pad$pad_n -side top + incr pad_n + + foreach {framed text widget name args} $fields { + if {$framed} { + frame $tl.field_$name + label $tl.field_$name.lbl -text $text + $widget $tl.field_$name.wgt {*}$args ::ui::form::forms(${tl}:$name) + pack $tl.field_$name.lbl -side left + pack $tl.field_$name.wgt -side right + pack $tl.field_$name -side top -anchor w + } else { + label $tl.field_${name}_lbl -text $text + $widget $tl.field_${name}_wgt {*}$args ::ui::form::forms(${tl}:$name) + pack $tl.field_${name}_lbl -side top -anchor w + pack $tl.field_${name}_wgt -side top -anchor w + } + label $tl.field_${name}_err -height 0 + pack $tl.field_${name}_err -side top -anchor w + frame $tl.pad$pad_n -height 10 + pack $tl.pad$pad_n -side top + incr pad_n + } + + frame $tl.buttons + button $tl.buttons.cancel -text "Cancel" -command [concat [list set tl $tl] {; + array unset ::ui::form::forms($tl) + array unset ::ui::form::forms(${tl}:*) + destroy $tl + eval [dict get [set ::ui::form::forms($tl)] cancel] + }] + button $tl.buttons.ok -text "Ok" -command [concat [list set tl $tl] {; + set formdata {} + foreach {framed text widget name args} [dict get [set ::ui::form::forms($tl)] fields] { + dict set formdata $name [set ::ui::form::forms(${tl}:$name)] + } + + if {[set errs [eval [dict get [set ::ui::form::forms($tl)] check]]] != {}} { + ... + } else { + array unset ::ui::form::forms($tl) + array unset ::ui::form::forms(${tl}:*) + destroy $tl + eval [dict get [set ::ui::form::forms($tl)] finish] + } + }] + bind $tl { + if {[info exists ::ui::form::forms(%W)]} { + array unset ::ui::form::forms(%W) + array unset ::ui::form::forms(%W:*) + eval [dict get [set ::ui::form::forms(%W)] cancel] + } + } + + pack $tl.buttons.cancel -side left + pack $tl.buttons.ok -side left + pack $tl.buttons -side top -anchor w +} diff --git a/src/util.tcl b/src/util.tcl new file mode 100644 index 0000000..ecda2aa --- /dev/null +++ b/src/util.tcl @@ -0,0 +1,5 @@ +set randchan [tcl::chan::random [tcl::randomseed]] +proc rand_hex {} { + global randchan + return [binary encode hex [read randchan 8]] +} -- 2.45.2