From 534b37f72db19331c8b197f43620af0455f0f830 Mon Sep 17 00:00:00 2001
From: Aleteoryx <alyx@aleteoryx.me>
Date: Fri, 30 Aug 2024 18:12:48 -0400
Subject: [PATCH] CAP fully implemented

Implements: https://todo.amehut.dev/~aleteoryx/tclircc/8
---
 cap.tcl  |  41 +++++++++++++------
 irc.tcl  | 117 ++++++++++++++++++++++++++++++-------------------------
 main.tcl |   5 ++-
 3 files changed, 97 insertions(+), 66 deletions(-)

diff --git a/cap.tcl b/cap.tcl
index 1caf809..c7212db 100644
--- a/cap.tcl
+++ b/cap.tcl
@@ -29,6 +29,7 @@ namespace eval ::cap {
   }
   proc server_ls list {
     regsub -all { +} $list { } list
+    set caps {}
     foreach cap [split [string trim $list] " "] {
       set value [join [lassign [split $cap "="] capname] "="]
       # auto-parse registry capabilities
@@ -123,7 +124,7 @@ namespace eval ::cap {
         }
 
         dict set ret success true
-        dict set ret caps [server_ls [lindex $cmdargs 0]]
+        dict set ret caps [server_nack [lindex $cmdargs 0]]
 
         return $ret
       }
@@ -188,6 +189,13 @@ namespace eval ::cap {
     }
   }
 
+  proc req-cap {chan cap} {
+    variable log
+    ${log}::debug "attempting to negotiate $cap"
+    irc::meta set $chan cap req-inflight $cap set
+    irc::msg send $chan CAP REQ $cap
+  }
+
   proc handler dispatch {
     variable logh
     ${logh}::debug "handling CAP message"
@@ -196,7 +204,7 @@ namespace eval ::cap {
 
     set parsed [parse_msg [dict get $dispatch params]]
 
-    if ![dict get $parsed success] { ${logh}::error "got bad CAP message: $rawmsg"; return }
+    if ![dict get $parsed success] { ${logh}::error "got bad CAP message: [dict get $dispatch rawmsg]"; return }
 
     switch -- [dict get $parsed type] {
       LS {
@@ -238,7 +246,9 @@ namespace eval ::cap {
         }
       }
       ACK {
+        # TODO: hook for ACKed CAPs
         foreach cap [dict get $parsed caps] {
+          ${logh}::info "CAP ACK: $cap"
           irc::meta unset $chan cap req-inflight $cap
           irc::meta set $chan cap to-change $cap set
         }
@@ -246,24 +256,32 @@ namespace eval ::cap {
       }
       NAK {
         foreach cap [dict get $parsed caps] {
+          ${logh}::warn "CAP NAK: $cap"
           irc::meta unset $chan cap req-inflight $cap
         }
         apply-caps $chan
       }
       NEW {
-        # run cap.supporting handler, if applicable
-        puts "TODO!"
+        dict for {cap val} [dict get $parsed caps] {
+          # TODO: interface to check when CAPs change parameters and toggle them
+          irc::meta set $chan cap available $cap $val
+          if {![irc::meta exists $chan cap enabled $cap] && [test-cap $chan $cap $val]} {
+            req-cap $chan $cap
+          }
+        }
       }
       DEL {
-        # remove from cap.req-inflight, possibly add support for cleanup code
-        puts "TODO!"
+        foreach cap [dict get $parsed caps] {
+          # TODO: cleanup hook for disabled CAPs
+          irc::meta unset $chan cap available $cap
+          irc::meta unset $chan cap enabled $cap
+        }
       }
       LIST {
-        # replace cap.available, remove any nonexistent cap.enabled entries, rerun the loop from CAP LS handling
-        puts "TODO!"
-      }
-      default {
-        puts "TODO!"
+        irc::meta set $chan cap enabled {}
+        foreach cap [dict get $parsed caps] {
+          irc::meta set $chan cap enabled $cap set
+        }
       }
     }
   }
@@ -289,6 +307,7 @@ namespace eval ::cap {
 
     ${log}::info "attempting capability negotiation for $chan ([irc::meta get $chan uri])"
     irc::meta set $chan cap ls-buffer {}
+    irc::meta set $chan cap to-change {}
     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"
diff --git a/irc.tcl b/irc.tcl
index 28de430..57113c4 100644
--- a/irc.tcl
+++ b/irc.tcl
@@ -19,11 +19,14 @@
 package require Thread
 
 namespace eval ::irc {
+  variable log [logger::init tclircc::irc]
+  variable logd [logger::init tclircc::irc::dispatch]
+  variable logp [logger::init tclircc::irc::proto]
   variable chan.meta
   variable chan.handlers
 
   # documented
-  proc ::irc::is {type value {cap {}}} {
+  proc is {type value {cap {}}} {
     # validation helper.
     # cap is a list of negotiated capabilities.
     switch -- $type {
@@ -53,7 +56,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::esc {type value} {
+  proc esc {type value} {
     # for escaping specific things
     switch -- $type {
       tags::value {
@@ -69,7 +72,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::unesc {type value} {
+  proc unesc {type value} {
     # for unescaping specific things
     # needs to be handled manually due to Quirkiness
     switch -- $type {
@@ -105,7 +108,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::connect {hostname port {usetls 0}} {
+  proc connect {hostname port {usetls 0}} {
     if $usetls {
       if {[info commands ::tls::socket] == ""} { package require tls }
       set chan [::tls::socket $hostname $port]
@@ -124,7 +127,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::enroll {chan {meta {}}} {
+  proc enroll {chan {meta {}}} {
     variable chan.meta
     variable chan.handlers
     fconfigure $chan -translation crlf -blocking 0
@@ -133,7 +136,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::listen {subcommand chan} {
+  proc listen {subcommand chan} {
     switch -- $subcommand {
       on {
         fileevent $chan readable [list ::irc::int-onmsg $chan]
@@ -149,7 +152,7 @@ namespace eval ::irc {
   }
 
   # nodoc
-  proc ::irc::int-dictsub args {
+  proc int-dictsub args {
     if [catch { uplevel [list dict {*}$args] } result options] {
       return -options $options [regsub {dictionary$} $result "channel meta"]
     } else {
@@ -158,26 +161,26 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::meta {subcommand chan args} {
+  proc 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.meta($chan)] {*}$args
+        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.meta($chan) {*}$args
+        int-dictsub unset chan.meta($chan) {*}$args
       }
       get {
-        ::irc::int-dictsub get [set chan.meta($chan)] {*}$args
+        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.meta($chan) {*}$args
+        int-dictsub set chan.meta($chan) {*}$args
       }
       read {
         if [llength $args] { return -code error "wrong # args: should be \"irc::meta read chan\"" }
@@ -189,7 +192,7 @@ namespace eval ::irc {
   }
 
   # nodoc
-  proc ::irc::int-setaliases {interp} {
+  proc int-setaliases {interp} {
     $interp alias irc::is irc::is
     $interp alias irc::msg irc::msg
     $interp alias irc::listener irc::listener
@@ -204,10 +207,11 @@ namespace eval ::irc {
   }
 
   # nodoc
-  proc ::irc::int-onmsg {chan} {
+  proc int-onmsg {chan} {
     set msg [gets $chan]
     if {$msg == ""} { return }
 
+    variable logd
     variable chan.meta
     variable chan.handlers
 
@@ -249,38 +253,45 @@ namespace eval ::irc {
       if !$matched { continue }
 
       set matchedany true
-      switch -- $type {
-        chan {
-          lassign $rest writer interp
-          puts $writer $dispatch
-          flush $writer
-        }
-        tchan {
-          lassign $rest writer thread
-          puts $writer $dispatch
-          flush $writer
-        }
-        extern {
-          lassign $rest ochan ichan
-          puts $ochan $chan
-          puts $ochan $msg
-          flush $ochan
-        }
-        script {
-          set interp [lassign $rest script]
-          if [llength $interp] {
-            set interp [lindex $interp 0]
-            {*}$interp eval [list set dispatch $dispatch]
-            {*}$interp eval $script
-          } else {
-            uplevel #0 [list set dispatch $dispatch]
-            uplevel #0 $script
+      if [set code [catch {
+        switch -- $type {
+          chan {
+            lassign $rest writer interp
+            puts $writer $dispatch
+            flush $writer
+          }
+          tchan {
+            lassign $rest writer thread
+            puts $writer $dispatch
+            flush $writer
+          }
+          extern {
+            lassign $rest ochan ichan
+            puts $ochan $chan
+            puts $ochan $msg
+            flush $ochan
+          }
+          script {
+            set interp [lassign $rest script]
+            if [llength $interp] {
+              set interp [lindex $interp 0]
+              {*}$interp eval [list set dispatch $dispatch]
+              {*}$interp eval $script
+            } else {
+              uplevel #0 [list set dispatch $dispatch]
+              uplevel #0 $script
+            }
+          }
+          tscript {
+            lassign $rest script thread
+            thread::send -async $thread [list set dispatch $dispatch]
+            thread::send -async $thread $script
           }
         }
-        tscript {
-          lassign $rest script thread
-          thread::send -async $thread [list set dispatch $dispatch]
-          thread::send -async $thread $script
+      } result options]] {
+        if {$code == 1} {
+          ${logd}::error "error in $type handler $id (pattern list: [list $patlist]): $result"
+          ${logd}::error "errorInfo: [dict get $options -errorinfo]"
         }
       }
     }
@@ -290,11 +301,11 @@ namespace eval ::irc {
   }
 
   # nodoc
-  proc ::irc::int-rminterp {interp} {
+  proc int-rminterp {interp} {
     interp delete $interp
   }
   # documented
-  proc ::irc::listener {subcommand chan args} {
+  proc listener {subcommand chan args} {
     variable chan.handlers
     switch -- $subcommand {
       add {
@@ -358,7 +369,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::handler {subcommand chan args} {
+  proc handler {subcommand chan args} {
     variable chan.handlers
     switch -- $subcommand {
       add {
@@ -414,14 +425,14 @@ namespace eval ::irc {
   }
 
   # nodoc
-  proc ::irc::int-onextern {ichan chan} {
+  proc int-onextern {ichan chan} {
     set msg [gets $ichan]
     if {$msg == ""} return
     puts $chan $msg
     flush $chan
   }
   # documented
-  proc ::irc::extern {subcommand chan args} {
+  proc extern {subcommand chan args} {
     variable chan.handlers
     switch -- $subcommand {
       add {
@@ -455,7 +466,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::patlist {chan id {patlist {}}} {
+  proc patlist {chan id {patlist {}}} {
     if {$patlist != ""} {
       set newlist ""
       foreach handler [dict get chanmeta($chan) handlers] {
@@ -477,7 +488,7 @@ namespace eval ::irc {
 
 
   # documented
-  proc ::irc::src {subcommand args} {
+  proc src {subcommand args} {
     switch -- $subcommand {
       parse {
         if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::src parse src ?partsVar?\"" }
@@ -533,7 +544,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::tags {subcommand args} {
+  proc tags {subcommand args} {
     switch -- $subcommand {
       exists {
         if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::tags exists tags key\"" }
@@ -658,7 +669,7 @@ namespace eval ::irc {
   }
 
   # documented
-  proc ::irc::msg {subcommand args} {
+  proc msg {subcommand args} {
     switch -- $subcommand {
       fmt {
         if ![llength $args] { return -code error "wrong # args: should be \"irc::msg fmt ?-tags tags? ?-src src? cmd ?arg ...? \"" }
diff --git a/main.tcl b/main.tcl
index 74f8e7f..8a86524 100755
--- a/main.tcl
+++ b/main.tcl
@@ -7,8 +7,9 @@ set log [logger::init tclircc]
 source irc.tcl
 source cap.tcl
 
-puts "connecting to testnet.ergo.chat"
-set chan [irc::connect testnet.ergo.chat 6697 1]
+#puts "connecting to testnet.ergo.chat"
+#set chan [irc::connect testnet.ergo.chat 6697 1]
+set chan [irc::connect localhost 8000 0]
 
 irc::handler add $chan * {
   ${log}::debug [dict get $dispatch rawmsg]
-- 
2.43.4