A cap.tcl => cap.tcl +230 -0
@@ 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
+ }
+}
M irc.tcl => irc.tcl +9 -48
@@ 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
A main.tcl => main.tcl +42 -0
@@ 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