From f4bd8c30ec749c4b4d4f4d1d14f75ff94d94b7bf Mon Sep 17 00:00:00 2001
From: Aleteoryx <alyx@aleteoryx.me>
Date: Thu, 29 Aug 2024 18:44:16 -0400
Subject: [PATCH] capability requesting

---
 cap.tcl  | 230 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 irc.tcl  |  57 +++-----------
 main.tcl |  42 ++++++++++
 3 files changed, 281 insertions(+), 48 deletions(-)
 create mode 100644 cap.tcl
 create mode 100755 main.tcl

diff --git a/cap.tcl b/cap.tcl
new file mode 100644
index 0000000..7589f6f
--- /dev/null
+++ b/cap.tcl
@@ -0,0 +1,230 @@
+# cap.status:
+# - sent (we have sent CAP LS 302, no terminal reply)
+# - ack-wait (we've sent off the first REQ, wait for an ACK to update state and send END. will only transition when cap.req-inflight == {})
+# - finished (all other CAP negotiation(CAP NEW) is handled asynchronously)
+
+# handling for CAP-related things
+namespace eval ::cap {
+  variable log [logger::init tclircc::cap]
+  variable logp [logger::init tclircc::cap::parser]
+  variable logh [logger::init tclircc::cap::dispatch]
+  proc value_dict str {
+    set ret {}
+    foreach pair [split $str ","] {
+      set value [join [lassign [split $pair "="] key] "="]
+      dict set ret $key $value
+    }
+    return $ret
+  }
+  proc server_nack list {
+    regsub -all { +} $list { } list
+    foreach cap [split [string trim $list] " "] {
+      lappend ret $cap
+    }
+  }
+  proc server_ls list {
+    regsub -all { +} $list { } list
+    foreach cap [split [string trim $list] " "] {
+      set value [join [lassign [split $cap "="] capname] "="]
+      # auto-parse registry capabilities
+      switch -regexp -- $capname {
+        {^(draft/account-registration|draft/metadata-2|draft/multiline|sts)$} {
+          dict set caps $capname [value_dict $value]
+        }
+        {^(account-notify|account-tag|away-notify|batch|cap-notify|draft/channel-rename|draft/chathistory|chghost|echo-message|draft/event-playback|extended-join|extended-monitor|invite-notify|labeled-response|draft/message-redaction|message-tags|draft/metadata-notify-2|multi-prefix|draft/no-implicit-names|draft/pre-away|draft/read-marker|server-time|setname|standard-replies|userhost-in-names)$} {
+          dict set caps $capname available
+        }
+        {^(draft/languages|sasl)$} {
+          dict set caps $capname [split $value ","]
+        }
+        default {
+          dict set caps $capname $value
+        }
+      }
+    }
+    return $caps
+  }
+  proc parse_msg cmdargs {
+    variable logp
+    if {[llength $cmdargs] <= 2} {
+      ${logp}::error "misbehaving server: sent [llength $cmdargs] args for CAP command: $cmdargs"
+      return {success false}
+    }
+    set cmdargs [lassign $cmdargs target cmd]
+    switch -- $cmd {
+      LS {
+        dict set ret type LS
+        if {[llength $cmdargs] ni {1 2}} {
+          ${logp}::error "misbehaving server: sent [expr {[llength $cmdargs]+2}] args for CAP LS command: $cmdargs"
+          return {success false}
+        }
+
+        dict set ret success true
+        if {[llength $cmdargs] == 2} {
+          if {[lindex $cmdargs 0] != "*"} { ${logp}::warn "misbehaving server: sent [lindex $cmdargs 0] instead of * in CAP LS" }
+          dict set ret multiline true
+          dict set ret caps [server_ls [lindex $cmdargs 1]]
+        } else {
+          dict set ret multiline false
+          dict set ret caps [server_ls [lindex $cmdargs 0]]
+        }
+
+        return $ret
+      }
+      NEW {
+        dict set ret type NEW
+        if {[llength $cmdargs] != 1} {
+          ${logp}::error "misbehaving server: sent [expr {[llength $cmdargs]+2}] args for CAP LS command: $cmdargs"
+          return {success false}
+        }
+
+        dict set ret success true
+        dict set ret caps [server_ls [lindex $cmdargs 0]]
+
+        return $ret
+      }
+      DEL {
+        dict set ret type NEW
+        if {[llength $cmdargs] != 1} {
+          ${logp}::error "misbehaving server: sent [expr {[llength $cmdargs]+2}] args for CAP LS command: $cmdargs"
+          return {success false}
+        }
+
+        dict set ret success true
+        dict set ret caps [server_ls [lindex $cmdargs 0]]
+
+        return $ret
+      }
+      ACK {
+        dict set ret type ACK
+        if {[llength $cmdargs] != 1} {
+          ${logp}::error "misbehaving server: sent [expr {[llength $cmdargs]+2}] args for CAP ACK command: $cmdargs"
+          return {success false}
+        }
+        dict set ret success true
+        dict set ret caps [server_nack [lindex $cmdargs 0]]
+      }
+      NAK {
+        dict set ret type NAK
+        if {[llength $cmdargs] != 1} {
+          ${logp}::error "misbehaving server: sent [expr {[llength $cmdargs]+2}] args for CAP NAK command: $cmdargs"
+          return {success false}
+        }
+        dict set ret success true
+        dict set ret caps [server_nack [lindex $cmdargs 0]]
+      }
+      LIST {
+        dict set ret type LIST
+        if {[llength $cmdargs] != 1} {
+          ${logp}::error "misbehaving server: sent [expr {[llength $cmdargs]+2}] args for CAP LIST command: $cmdargs"
+          return {success false}
+        }
+        dict set ret success true
+        dict set ret caps [server_nack [lindex $cmdargs 0]]
+      }
+      default {
+        ${logp}::error "misbehaving server: sent CAP $cmd message"
+        return {success false}
+      }
+    }
+  }
+
+  proc handler dispatch {
+    variable logh
+    ${logh}::debug "handling CAP message"
+
+    set chan [dict get $dispatch chan]
+
+    set parsed [parse_msg [dict get $dispatch params]]
+
+    if ![dict get $parsed success] { ${logh}::error "got bad CAP message: $rawmsg"; return }
+
+    switch -- [dict get $parsed type] {
+      LS {
+        if [dict get $parsed multiline] {
+          ${logh}::debug "accumulating multiline CAP LS"
+          irc::meta set $chan cap ls-buffer [dict merge [irc::meta get $chan cap ls-buffer] [dict get $parsed caps]]
+        } else {
+          set available [dict merge [irc::meta get $chan cap ls-buffer] [dict get $parsed caps]]
+          irc::meta set $chan cap available $available
+          irc::meta set $chan cap ls-buffer {}
+
+          set req_acc {}
+          dict for {cap val} $available {
+            # if we don't have a capability enabled, and we support it, request it
+            if {![irc::meta exists $chan cap enabled $cap] && [irc::meta exists $chan cap supporting $cap]} {
+              # if we don't really support it, continue
+              uplevel #0 [list set capvalue $val]
+              if ![uplevel #0 [irc::meta get $chan cap supporting $cap]] { continue; }
+
+              # this little manouver pushes to the req-inflight stack
+              irc::meta set $chan cap req-inflight [concat [irc::meta get $chan cap req-inflight] [list $cap]]
+              if {[string length [concat $req_acc [list $cap]]] >= 500} {
+                irc::msg send $chan CAP REQ $req_acc
+                set $req_acc {}
+              }
+              lappend req_acc $cap
+            }
+          }
+          if [string length $req_acc] {
+            irc::msg send $chan CAP REQ $req_acc
+          }
+
+          if {[irc::meta get $chan cap status] == "sent"} {
+            irc::meta set $chan cap status "ack-wait"
+          }
+        }
+      }
+      ACK {
+        # move [0-9a-z\-]+ from cap.req-inflight to cap.enabled; remove -[0-9a-z\-]+ from both cap.req-inflight and cap.enabled
+        puts "TODO!"
+      }
+      NAK {
+        # remove from cap.req-inflight
+        puts "TODO!"
+      }
+      NEW {
+        # run cap.supporting handler, if applicable
+        puts "TODO!"
+      }
+      DEL {
+        # remove from cap.req-inflight, possibly add support for cleanup code
+        puts "TODO!"
+      }
+      LIST {
+        # replace cap.available, remove any nonexistent cap.enabled entries, rerun the loop from CAP LS handling
+        puts "TODO!"
+      }
+      default {
+        puts "TODO!"
+      }
+    }
+  }
+
+  proc support {chan cap {script {expr {true}}}} {
+    variable log
+
+    ${log}::info "supporting CAP $cap"
+    # if we're not in early boot, and haven't already requested the capability, request it
+    if {[irc::meta exists $chan cap status] && [irc::meta get $chan cap status] != "sent" && [irc::meta exists $chan cap available $cap] && ![irc::meta exists $chan cap supporting $cap]} {
+      uplevel #0 [list set capvalue [irc::meta get $chan cap available $cap]]
+      if [uplevel #0 $script] {
+        # this little manouver pushes to the req-inflight stack
+        irc::meta set $chan cap req-inflight [concat [irc::meta get $chan cap req-inflight] [list $cap]]
+        irc::msg send $chan CAP REQ $cap
+      }
+    }
+    irc::meta set $chan cap supporting $cap $script
+  }
+
+  proc negotiate {chan} {
+    variable log
+
+    ${log}::info "attempting capability negotiation for $chan ([irc::meta get $chan uri])"
+    irc::meta set $chan cap ls-buffer {}
+    irc::meta set $chan cap req-inflight {}
+    irc::meta set $chan cap handler [irc::handler add $chan CAP { cap::handler $dispatch }]
+    irc::meta set $chan cap status "sent"
+    irc::msg send $chan CAP LS 302
+  }
+}
diff --git a/irc.tcl b/irc.tcl
index 8c680dc..28de430 100644
--- a/irc.tcl
+++ b/irc.tcl
@@ -150,38 +150,39 @@ namespace eval ::irc {
 
   # nodoc
   proc ::irc::int-dictsub args {
-    if [catch { dict {*}$args } result options] {
-      return -options options [regsub {dictionary$} $result "channel meta"]
+    if [catch { uplevel [list dict {*}$args] } result options] {
+      return -options $options [regsub {dictionary$} $result "channel meta"]
     } else {
-      return -options options $result
+      return -options $options $result
     }
   }
 
   # documented
   proc ::irc::meta {subcommand chan args} {
+    variable chan.meta
     switch -- $subcommand {
       exists {
         if ![llength $args] { return -code error "wrong # args: should be \"irc::meta exists chan key ?key ...?\"" }
 
-        ::irc::int-dictsub exists [set chan.handlers($chan)] {*}$args
+        ::irc::int-dictsub exists [set chan.meta($chan)] {*}$args
       }
       unset {
         if ![llength $args] { return -code error "wrong # args: should be \"irc::meta unset chan key ?key ...?\"" }
 
-        ::irc::int-dictsub unset chan.handlers($chan) {*}$args
+        ::irc::int-dictsub unset chan.meta($chan) {*}$args
       }
       get {
-        ::irc::int-dictsub get [set chan.handlers($chan)] {*}$args
+        ::irc::int-dictsub get [set chan.meta($chan)] {*}$args
       }
       set {
         if {[llength $args] < 2} { return -code error "wrong # args: should be \"irc::meta set chan key ?key ...? value\"" }
 
-        ::irc::int-dictsub set chan.handlers($chan) {*}$args
+        ::irc::int-dictsub set chan.meta($chan) {*}$args
       }
       read {
         if [llength $args] { return -code error "wrong # args: should be \"irc::meta read chan\"" }
 
-        set chan.handlers($chan)
+        set chan.meta($chan)
       }
       default { return -code error "unknown subcommand \"$subcommand\": must be exists, get, set, or unset" }
     }
@@ -757,43 +758,3 @@ namespace eval ::irc {
     }
   }
 }
-
-set chan [irc::connect localhost 9999 0]
-puts $chan
-irc::listen on $chan
-
-set ghandler [irc::handler add $chan {FOO GHAND} {puts "global handler called with dispatch [list $dispatch]"}]
-set ihandler [irc::handler add $chan {FOO IHAND} {puts "interp handler called with dispatch [list $dispatch]"} [interp create]]
-set thandler [irc::handler add $chan -thread {FOO THAND} {puts "threaded handler called with dispatch [list $dispatch]"}]
-puts "handlers created:"
-puts "  global   = $ghandler"
-puts "  interp   = $ihandler"
-puts "  threaded = $thandler"
-
-set ilistener [irc::listener add $chan {FOO ILIST} {
-  puts "hello from interp listener with dispatch $dispatch"
-  fileevent $dispatch readable {
-    set line [gets $dispatch]
-    if {$line == "end"} {
-      puts "interp listener exiting!"
-      fileevent $dispatch readable {}
-      selfdestruct
-    }
-    puts "interp listener dispatch read [list $line]" }
-}]
-set tlistener [irc::listener add $chan -thread {FOO TLIST} {
-  puts "hello from threaded listener with dispatch $dispatch and parent $parent"
-  while {[set line [gets $dispatch]] != "end"} {
-    puts "thread listener dispatch read [list $line]"
-  }
-  puts "thread listener exiting!"
-  thread::release
-}]
-
-puts "listeners created:"
-puts "  interp   = $ilistener"
-puts "  threaded = $tlistener"
-
-irc::handler add $chan EVAL { eval {*}[dict get $dispatch params] }
-
-vwait nil
diff --git a/main.tcl b/main.tcl
new file mode 100755
index 0000000..d9f0b9d
--- /dev/null
+++ b/main.tcl
@@ -0,0 +1,42 @@
+#!/bin/env tclsh
+
+lappend auto_path /usr/lib/tcllib1.21
+package require logger
+set log [logger::init tclircc]
+
+source irc.tcl
+source cap.tcl
+
+puts "connecting to testnet.ergo.chat"
+set chan [irc::connect testnet.ergo.chat 6667 0]
+
+irc::handler add $chan * {
+  ${log}::debug [dict get $dispatch rawmsg]
+}
+#irc::handler add $chan CAP {
+#  ${log}::debug "parsing cap ls"
+#  set parsed [cap::parse_msg [dict get $dispatch params]]
+#  dict for {k v} $parsed {
+#    if {$k == "caps"} {
+#      ${log}::debug "$k:"
+#      dict for {k v} $v {
+#        ${log}::debug "  $k: $v"
+#      }
+#    } else {
+#      ${log}::debug "$k: $v"
+#    }
+#  }
+#}
+
+cap::negotiate $chan
+cap::support $chan message-tags
+
+puts [irc::meta get $chan]
+
+irc::listen on $chan
+
+#${log}::info "requesting CAPs"
+#irc::msg send $chan CAP LS 302
+
+${log}::info "entering event loop"
+vwait nil
-- 
2.43.4