From 4f60dac8f9eee7c7596cb848c1043dfea0fd58a0 Mon Sep 17 00:00:00 2001
From: Aleteoryx <alyx@aleteoryx.me>
Date: Sat, 3 Aug 2024 02:20:24 +0100
Subject: [PATCH] protocol done, but for 2 listener types and some polish

---
 irc.tcl | 436 +++++++++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 385 insertions(+), 51 deletions(-)

diff --git a/irc.tcl b/irc.tcl
index b1a639f02391d0f832422c7254dc0544d8812f0e..b8772f717fda532d57995d7fcd63a7774d080ad8 100755
--- a/irc.tcl
+++ b/irc.tcl
@@ -1,22 +1,47 @@
 #!/bin/tclsh
 
+# handler types:
+#   chan <chanid> <interp> // irc::listener
+#     passes to a pipe to a sub-interpreter
+#   extern <ochanid> <ichanid> // irc::extern
+#     dispatches chan+raw IRC to generic IPC ochanid
+#     for non-tcl plugins
+#     ichanid is listened on for IRC commands to send over the socket
+#   script <script> // irc::handler
+#     script is to be executed in a sub-interpreter with dispatch as locals
+#   script <script> <interp> // irc::handler
+#     script is to be executed inside interp with dispatch as locals
+# handler: <patlist> <type> <id> <type args...>
+
 namespace eval ::irc {
+  variable chanmeta
+
   proc ::irc::is {type value {cap {}}} {
     # validation helper.
     # cap is a list of negotiated capabilities.
     switch -- $type {
-      command { regexp {^([a-zA-Z]+|[0-9]{3})$} $value }
-      command::named { regexp {^[a-zA-Z]+$} $value }
-      command::numeric { regexp {^[0-9]{3}$} $value }
+      cmd { regexp {^([a-zA-Z]+|[0-9]{3})$} $value }
+      cmd::named { regexp {^[a-zA-Z]+$} $value }
+      cmd::numeric { regexp {^[0-9]{3}$} $value }
 
       tags { regexp {^\+?([^\r\n\0 ;/]/)?[a-zA-Z0-9\-]+(=[^\r\n\0; ]*)?(;\+?([^\r\n\0 ;/]/)?[a-zA-Z0-9\-]+(=[^\r\n\0; ]*)?)*$} $value }
       tags::tag { regexp {^\+?([^\r\n\0 ;/]/)?[a-zA-Z0-9\-]+(=[^\r\n\0; ]*)?$} $value }
       tags::key { regexp {^\+?([^\r\n\0 ;/]/)?[a-zA-Z0-9\-]+$} $value }
       tags::value { regexp {^[^\r\n\0; ]*$} $value }
 
-      misc::dict { expr {![string is list $value] || [llength $value] % 2 == 1}}
+      src { regexp {^([^$: ,*?!@.][^ ,*?!@.]*(![^$: ,*?!@][^ ,*?!@]*)?(@[^$: ,*?!@][^ ,*?!@]*)?|[^$: ,*?!@][^ ,*?!@]*)$} $value }
+      src::user { regexp {^[^$: ,*?!@.][^ ,*?!@.]*(![^$: ,*?!@][^ ,*?!@]*)?(@[^$: ,*?!@][^ ,*?!@]*)?$} $value }
+      src::servername { regexp {^[^$: ,*?!@][^ ,*?!@]*$} $value }
+      src::part { regexp {^[^$: ,*?!@][^ ,*?!@]*$} $value }
+
+      nick { regexp {^[^$: ,*?!@.][^ ,*?!@.]*$} $value }
+
+      msg::param { regexp {^[^\0\n\r: ]+$} $value }
+      msg::trailing { regexp {^[^\0\n\r]+$} $value }
 
-      default { return -code error "unknown subcommand \"$subcommand\": must be command(|::named|::numeric), tags(|::tag|::key|::value), or misc::dict" }
+      misc::dict { expr {![string is list $value] || [llength $value] % 2 == 0}}
+
+      default { return -code error "unknown type \"$type\": must be cmd(|::named|::numeric), misc::dict, src(|::server|::user), or tags(|::key|::tag|::value)" }
     }
   }
 
@@ -31,7 +56,7 @@ namespace eval ::irc {
                     { }  {\s}} $value
       }
 
-      default { return -code error "unknown subcommand \"$subcommand\": must be tags::value" }
+      default { return -code error "unknown type \"$type\": must be tags::value" }
     }
   }
 
@@ -47,17 +72,17 @@ namespace eval ::irc {
             if {$char == "\\"} {
               set backslash true
             } else {
-              set ret [string cat $ret $char]
+              set ret $ret$char
             }
           } else {
             switch $char {
-              n { set ret [string cat $ret "\n"] }
-              r { set ret [string cat $ret "\r"] }
-              : { set ret [string cat $ret ";"] }
-              s { set ret [string cat $ret " "] }
+              n { set ret "$ret\n" }
+              r { set ret "$ret\r" }
+              : { set ret "$ret;" }
+              s { set ret "$ret " }
 
               # covers backslash too
-              default { set ret [string cat $ret $char] }
+              default { set ret $ret$char }
             }
             set backslash false
           }
@@ -66,16 +91,246 @@ namespace eval ::irc {
         return $ret
       }
 
-      default { return -code error "unknown subcommand \"$subcommand\": must be tags::value" }
+      default { return -code error "unknown type \"$type\": must be tags::value" }
     }
   }
 
   proc ::irc::connect {hostname port {usetls 1}} {
+    variable chanmeta
     if $usetls {
       if {[info commands ::tls::socket] == ""} { package require tls }
-      ::tls::socket $hostname $port
+      set chan [::tls::socket $hostname $port]
+      set proto ircs
     } else {
-      socket hostname port
+      set chan [socket $hostname $port]
+      set proto irc
+    }
+
+    irc::enroll $chan [dict create uri      $proto://$hostname:$port \
+                                   proto    $proto \
+                                   hostname $hostname \
+                                   port     $port]
+  }
+
+  proc ::irc::enroll {chan {meta {}}}
+    fconfigure $chan -translation crlf -blocking 0
+    dict set meta chan $chan
+    dict set meta handlers {}
+    set chanmeta($chan) $meta
+  }
+
+  proc ::irc::listen {subcommand chan} {
+    switch -- $subcommand {
+      on {
+        fileevent $chan readable [list ::irc::int-onmsg $chan]
+      }
+      off {
+        set oldfe [fileevent $chan readable]
+        if {[fileevent $chan readable] != [list ::irc::int-onmsg $chan]} {
+          return -code error "channel \"$chan\" not listening for irc"
+        } else { fileevent $chan readable "" }
+      }
+      default { return -code error "unknown subcommand \"$subcommand\": must be off or on" }
+    }
+  }
+
+  proc ::irc::int-setaliases {interp} {
+    $interp alias irc::is
+    $interp alias irc::msg
+    $interp alias irc::listener
+    $interp alias irc::esc
+    $interp alias irc::unesc
+    $interp alias irc::src
+    $interp alias irc::tags
+  }
+
+  proc ::irc::int-onmsg {chan} {
+    set msg [gets $chan]
+    if {$msg == ""} { return }
+
+    variable chanmeta
+
+    irc::msg parse $msg tags src cmd params
+    set srctype [irc::src parse $src srcparts]
+
+    set dispatch [dict create rawmsg $msg \
+                              chan $chan \
+                              tags $tags \
+                              src $src \
+                              srctype $srctype \
+                              srcparts $srcparts \
+                              cmd $cmd \
+                              params $params \
+                              meta [dict remove [dict get chanmeta($chan)] handlers]]
+
+    foreach handler [dict get chanmeta($chan) handlers] {
+      set patlist [lindex $handler 0]
+      set type [lindex $handler 1]
+      set id [lindex $handler 2]
+
+      set matched false
+      foreach msgpat $patlist {
+        set cmdpat [lindex [lindex $handler 0] 0]
+        set parampats [lrange [lindex $handler 0] 1 end]
+
+        if {[llength $parampats] > [llength $params]} { continue }
+        if ![string match $cmdpat $cmd] { continue }
+
+        set bailed false
+        foreach parampat $parampats param [lrange $params 0 [llength $parampats]-1] {
+          if ![string match $parampat $param] { set bailed true; break }
+        }
+        if $bailed { continue }
+
+        set matched true
+        break
+      }
+      if !$matched { continue }
+
+      switch -- $type {
+        chan {
+          set chanid [lindex $handler 3]
+          puts $chanid $dispatch
+          flush $chanid
+        }
+        extern {
+          set ochanid [lindex $handler 3]
+          puts $ochanid $chan
+          puts $ochanid $msg
+          flush $ochanid
+        }
+        script {
+          set script [lindex $handler 3]
+          if {[llength $handler] == 5} {
+            set interp [lindex $handler 4]
+          } else {
+            set interp [interp create]
+            irc::int-setaliases $interp
+            interp share {} $chan $interp
+          }
+          $interp eval dict with $dispatch {}
+          $interp eval after 0 $script
+        }
+      }
+    }
+  }
+
+  proc ::irc::listener {subcommand chan args} {
+    variable chanmeta
+    switch -- $subcommand {
+      add {
+        if {[llength args] != 2} { return -code error "wrong # args: should be \"irc::listener add chan patlist script\"" }
+        set patlist [lindex $args 0]
+        set script [lindex $args 1]
+        set id [format "%016x" [expr {round(rand() * (2**64))}]]
+
+        set interp [interp create]
+        irc::int-setaliases $interp
+        interp share {} $chan $interp
+
+        set pipe [chan pipe]
+        set reader [lindex $pipe 0]
+        interp transfer {} $reader $interp
+        $interp eval set chan $reader
+        $interp eval after 0 $script
+
+        dict lappend chanmeta($chan) handlers [list $patlist chan $id [lindex $pipe 1] $interp]
+
+        return $id
+      }
+      remove {
+        if {[llength args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
+        set newlist ""
+        foreach handler [dict get chanmeta($chan) handlers] {
+          if {[lindex $handler 2] != $args} {
+            lappend newlist $handler
+          } else {
+            puts [lindex $handler 3] end
+            flush [lindex $handler 3]
+          }
+        }
+        dict set chanmeta($chan) handlers $newlist
+      }
+      patlist {
+        if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::listener patlist chan id ?patlist?\"" }
+        set id [lindex $args 0]
+
+        if {[llength $args] == 2}
+          set newlist ""
+          set patlist [lindex $args 1]
+          foreach handler [dict get chanmeta($chan) handlers] {
+            if {[lindex $handler 2] != $id} {
+              lset handler 0 $patlist
+            }
+            lappend newlist $handler
+          }
+          dict set chanmeta($chan) handlers $newlist
+          return $patlist
+        } else {
+          foreach handler [dict get chanmeta($chan) handlers] {
+            if {[lindex $handler 2] != $id} {
+              return [lindex $handler 0]
+            }
+          }
+        }
+      }
+      default { return -code error "unknown subcommand \"$subcommand\": must be add, patlist, or remove" }
+    }
+  }
+
+  proc ::irc::src {subcommand args} {
+    switch -- $subcommand {
+      parse {
+        if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::src parse src ?partsVar?\"" }
+        set src [lindex $args 0]
+        set partsVar ""
+        if {[llength $args] == 1} { set partsVar [lindex $args 1] }
+
+        if [irc::is src::user] {
+          if [string length $partsVar] {
+            upvar $partsVar parts
+            regexp {^([^!@]+)(?:!([^@]+))?(?:@(.+))?$} $src _ nick username host
+            set parts [dict create nick $nick username $username host $host]
+          }
+          return user
+        } elseif [irc::is src::servername] {
+          if [string length $partsVar] {
+            upvar $partsVar parts
+            set parts [dict create servername $src]
+          }
+          return server
+        } else { return -code error "argument is not a src" }
+      }
+      servername {
+        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::src server servername\"" }
+        if ![irc::is src::servername $args] { return -code error "argument is not a servername" }
+        return $args
+      }
+      user {
+        if {[llength $args] ni {1 3 5}} { return -code error "wrong # args: should be \"irc::src user ?-user user? ?-host host? nick\"" }
+
+        set user ""
+        if {[lindex $args 0] == "-user"} {
+          set user [lindex $args 1]
+          if ![irc::is src::part $user] { return -code error "-user argument is not a user" }
+          set args [lrange $args 2 end]
+          set user "!$user"
+        }
+        set host ""
+        if {[lindex $args 0] == "-host"} {
+          set host [lindex $args 1]
+          if ![irc::is src::part $host] { return -code error "-host argument is not a host" }
+          set args [lrange $args 2 end]
+          set host "@$host"
+        }
+
+        if {[llength $args] != 1} { return -code error "bad option: should be \"irc::src user ?-user user? ?-host host? nick\"" }
+
+        if ![irc::is src::nick $args] { return -code error "argument is not a nick" }
+
+        return $args$user$host
+      }
+      default { return -code error "unknown subcommand \"$subcommand\": must be parse, servername, or user" }
     }
   }
 
@@ -99,7 +354,7 @@ namespace eval ::irc {
 
         foreach tag [split $tags ";"] {
           if { [string first "$key=" $tag] && $tag != $key } {
-            set ret [string cat $ret $tag ";"]
+            append ret "$tag;"
           }
         }
 
@@ -115,7 +370,7 @@ namespace eval ::irc {
           foreach tag [split $tags ";"] {
             set split [string first = $tag]
             set key [string range $tag 0 $split-1]
-            set value [::irc::unesc tags::value [string range $tag $split+1 end]]
+            set value [irc::unesc tags::value [string range $tag $split+1 end]]
             lappend ret [list $key $value]
           }
           return $ret
@@ -123,7 +378,7 @@ namespace eval ::irc {
 
         foreach tag [split $tags ";"] {
           if {![string first "$key=" $tag]} {
-            return [::irc::unesc tags::value [string range $tag [string first = $tag]+1 end]]
+            return [irc::unesc tags::value [string range $tag [string first = $tag]+1 end]]
           } elseif { $tag == $key } { return "" }
         }
 
@@ -140,21 +395,21 @@ namespace eval ::irc {
         foreach tag [split $tags ";"] {
           if { !$found && ![string first "$key=" $tag] || $tag == $key } {
             if {$value != ""} {
-              set ret [string cat $ret $key = [::irc::esc tags::value $value] ";"]
+              append ret "$key=[irc::esc tags::value $value];"
             } else {
-              set ret [string cat $ret $key ";"]
+              append ret "$key;"
             }
             set found true
           } else {
-            set ret [string cat $ret $tag ";"]
+            append ret "$tag;"
           }
         }
 
         if !$found {
           if {$value != ""} {
-            set ret [string cat $ret $key = [::irc::esc tags::value $value] ";"]
+            append ret "$key=[irc::esc tags::value $value];"
           } else {
-            set ret [string cat $ret $key ";"]
+            append ret "$key;"
           }
         }
 
@@ -164,7 +419,7 @@ namespace eval ::irc {
       create {
         set ret ""
         dict for {key value} $args {
-          set ret [::irc::tags set $ret $key $value]
+          set ret [irc::tags set $ret $key $value]
         }
         return $ret
       }
@@ -172,16 +427,16 @@ namespace eval ::irc {
         set ret ""
 
         foreach tags $args {
-          if [::irc::is tags $tags] {
+          if [irc::is tags $tags] {
             foreach tag [split $tags ";"] {
               set split [string first = $tag]
               set key [string range $tag 0 $split-1]
-              set value [::irc::unesc tags::value [string range $tag $split+1 end]]
-              set ret [::irc::tags set $ret $key $value]
+              set value [irc::unesc tags::value [string range $tag $split+1 end]]
+              set ret [irc::tags set $ret $key $value]
             }
-          } elseif [::irc::is misc::dict $tags] {
+          } elseif [irc::is misc::dict $tags] {
             dict for {key value} $tags {
-              set ret [::irc::tags set $ret $key $value]
+              set ret [irc::tags set $ret $key $value]
             }
           } else {
             return -code error "argument is not tags or a dict"
@@ -197,7 +452,7 @@ namespace eval ::irc {
         foreach tag [split $tags ";"] {
           set split [string first = $tag]
           set key [string range $tag 0 $split-1]
-          set value [::irc::unesc tags::value [string range $tag $split+1 end]]
+          set value [irc::unesc tags::value [string range $tag $split+1 end]]
           dict set ret $key $value
         }
         return $ret
@@ -206,31 +461,110 @@ namespace eval ::irc {
     }
   }
 
-  proc ::irc::cmd {subcommand args} {
+  proc ::irc::msg {subcommand args} {
     switch -- $subcommand {
       fmt {
-        if [llength $args] {
-          set tags ""
-          if {[lindex $args 0] == "-tags"} {
-            if {[llength $args] < 3} { return -code error "missing tags dictionary argument to -tags option" }
-            set tags [::irc::tags merge [lindex $args 0]]
-            set args [lrange $args 2 end]
-          }
-          # TODO: source generation/parsing, actual command formatting
-          set source ""
-          if {[lindex $args 0] == "-tags"} {
-            if {[llength $args] < 3} { return -code error "missing tags map argument to -tags option" }
-            set tags [lindex $args 0]
-            set args [lrange $args 2 end]
-          }
+        if ![llength $args] { return -code error "wrong # args: should be \"irc::msg fmt ?-tags tags? ?-src src? cmd ?arg ...? \"" }
+
+        set msg ""
 
-          set cmd [lindex $args 0]
-          if ![::irc::is command $cmd] { return -code error "invalid irc command \"$cmd\"" }
-          set cmd [string toupper $cmd]
-        } else { return -code error "wrong # args: should be \"irc::cmd fmt ?-tags tags? ?-source source? command ?arg ...? \"" }
+        # TODO: unordered flag parsing
+        if {[lindex $args 0] == "-tags"} {
+          if {[llength $args] < 3} { return -code error "missing tags dictionary argument to -tags option" }
+          set msg "@[irc::tags merge [lindex $args 1]] "
+          set args [lrange $args 2 end]
+        }
+
+        if {[lindex $args 0] == "-src"} {
+          if {[llength $args] < 3} { return -code error "missing src argument to -src option" }
+          set src [lindex $args 1]
+          if ![irc::is src $src] { return -code error "-src argument is not a src" }
+          append msg ":$src "
+          set args [lrange $args 2 end]
+        }
+
+        set cmd [lindex $args 0]
+        if ![irc::is cmd $cmd] { return -code error "invalid irc command \"$cmd\"" }
+        append msg "[string toupper $cmd] "
+
+        set args [lrange $args 1 end]
+
+        if ![llength $args] { return [string range $msg 0 end-1] }
+
+        set trailing [lindex $args end]
+        set params [lrange $args 0 end-1]
+
+        foreach param $params {
+          if ![irc::is msg::param $param] { return -code error "invalid irc parameter \"$param\"" }
+          append msg "$param "
+        }
+
+        if ![irc::is msg::trailing $trailing] { return -code error "invalid irc trailing \"$trailing\"" }
+        append msg ":$trailing"
+
+        return $msg
+      }
+      send {
+        if {[llength $args] < 2} { return -code error "wrong # args: should be \"irc::msg send chan ?-tags tags? ?-src src? cmd ?arg ...? \"" }
+        set chan [lindex $args 0]
+        set args [lrange $args 1 end]
+        puts $chan "[irc::msg fmt {*}$args]\n"
+        flush $chan
       }
-      send { ... }
-      default { return -code error "unknown subcommand \"$subcommand\": must be fmt or send" }
+
+      # this parser is pretty lazy, and does not do validation.
+      # there's no risks, but it might behave oddly with a broken server.
+      parse {
+        if {[llength $args] != 5} { return -code error "wrong # args: should be irc::msg parse message tagsVar srcVar cmdVar paramsVar" }
+        set message [lindex $args 0]
+        upvar [lindex $args 1] tags
+        upvar [lindex $args 2] src
+        upvar [lindex $args 3] cmd
+        upvar [lindex $args 4] params
+
+        # tags
+        set tags ""
+        if ![string first @ $message] {
+          set tagsend [string first " " $message]
+          set tags [string range $message 1 $tagsend-1]
+          set message [string range $message $tagsend+1 end]
+        }
+
+        # src
+        set src ""
+        if ![set srcend [string first : $message]] {
+          set srcend [string first " " $message]
+          set src [string range $message 1 $srcend-1]
+          set message [string range $message $srcend+1 end]
+        }
+
+        # solo command
+        if {[string first " " $message] == -1} {
+          set cmd $message
+          set params ""
+          return
+        }
+
+        # command w/ args
+        set cmdend [string first " " $message]
+        set cmd [string range $message 0 $cmdend-1]
+        set message [string range $message $cmdend+1 end]
+
+        # trailing
+        set trailing ""
+        if {[set trailingstart [string first : $message]] != -1} {
+          set trailing [list [string range $message $trailingstart+1 end]]
+          set message [string range $message 0 $trailingstart-1]
+        }
+
+        # params
+        regsub { +} [string trim $message " "] " " message
+        set params [concat [split $message " "] $trailing]
+      }
+      default { return -code error "unknown subcommand \"$subcommand\": must be fmt, parse, or send" }
     }
   }
 }
+
+irc::msg parse [gets stdin] tags src cmd params
+puts "tags: \"$tags\"\nsrc: \"$src\"\nparams: \"$cmd\"\nparams: \"$params\""