#!/bin/tclsh

# handler types:
#   chan <dispatch> <interp> // irc::listener
#   tchan <dispatch> <thread> // irc::listener -thread
#     passes to a pipe to a sub-interpreter/thread
#   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 global scope with dispatch set
#   script <script> <interp> // irc::handler
#     script is to be executed inside interp with dispatch set
#   tscript <script> <thread> // irc::handler -thread
#     script is to be executed inside thread with dispatch as locals
# handler: <patlist> <type> <id> <type args...>

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
  variable chan.interceptors

  # documented
  proc is {type value {cap {}}} {
    # validation helper.
    # cap is a list of negotiated capabilities.
    switch -- $type {
      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 }

      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 }

      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)" }
    }
  }

  # documented
  proc esc {type value} {
    # for escaping specific things
    switch -- $type {
      tags::value {
        string map {"\\"  "\\\\"
                    "\n" {\n}
                    "\r" {\r}
                    {;}  {\:}
                    { }  {\s}} $value
      }

      default { return -code error "unknown type \"$type\": must be tags::value" }
    }
  }

  # documented
  proc unesc {type value} {
    # for unescaping specific things
    # needs to be handled manually due to Quirkiness
    switch -- $type {
      tags::value {
        set ret ""
        set backslash false
        foreach char [split $value ""] {
          if !$backslash {
            if {$char == "\\"} {
              set backslash true
            } else {
              set ret $ret$char
            }
          } else {
            switch $char {
              n { set ret "$ret\n" }
              r { set ret "$ret\r" }
              : { set ret "$ret;" }
              s { set ret "$ret " }

              # covers backslash too
              default { set ret $ret$char }
            }
            set backslash false
          }
        }

        return $ret
      }

      default { return -code error "unknown type \"$type\": must be tags::value" }
    }
  }

  # documented
  proc connect {hostname port {usetls 0}} {
    if $usetls {
      if {[info commands ::tls::socket] == ""} { package require tls }
      set chan [::tls::socket $hostname $port]
      set proto ircs
    } else {
      set chan [socket $hostname $port]
      set proto irc
    }

    irc::enroll $chan [dict create uri      $proto://$hostname:$port \
                                   proto    $proto \
                                   hostname $hostname \
                                   port     $port]

    return $chan
  }

  # documented
  proc enroll {chan {meta {}}} {
    variable chan.meta
    variable chan.handlers
    variable chan.interceptors
    fconfigure $chan -translation crlf -blocking 0
    set chan.meta($chan) $meta
    set chan.handlers($chan) {}
    set chan.interceptors($chan) {}
  }

  # documented
  proc 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" }
    }
  }

  # nodoc
  proc int-dictsub args {
    if [catch { uplevel [list dict {*}$args] } result options] {
      return -options $options [regsub {dictionary$} $result "channel meta"]
    } else {
      return -options $options $result
    }
  }

  # documented
  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 ...?\"" }

        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 ...?\"" }

        int-dictsub unset chan.meta($chan) {*}$args
      }
      get {
        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\"" }

        int-dictsub set chan.meta($chan) {*}$args
      }
      read {
        if [llength $args] { return -code error "wrong # args: should be \"irc::meta read chan\"" }

        set chan.meta($chan)
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be exists, get, set, or unset" }
    }
  }

  # nodoc
  proc int-setaliases {interp} {
    $interp alias irc::is irc::is
    $interp alias irc::msg irc::msg
    $interp alias irc::listener irc::listener
    $interp alias irc::extern irc::extern
    $interp alias irc::handler irc::handler
    $interp alias irc::esc irc::esc
    $interp alias irc::unesc irc::unesc
    $interp alias irc::src irc::src
    $interp alias irc::tags irc::tags
    $interp alias irc::patlist irc::patlist
    $interp alias irc::meta irc::meta
  }

  # nodoc
  proc int-onmsg {chan} {
    set msg [gets $chan]
    if {$msg == ""} { return }

    variable logd
    variable chan.meta
    variable chan.handlers

    irc::msg parse $msg tags src cmd params
    set src ""
    set srcparts ""
    set srctype ""
    if {$src != ""} { 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]

    set matchedany false
    foreach interceptor [set chan.interceptors($chan)] {
      lassign $interceptor id procname
      if {[$procname $dispatch]} {
        ${logd}::debug "message intercepted by interceptor \"$id\", procname \"$procname\""
        ${logd}::debug "contents: $msg"
        return
      }
    }
    foreach handler [set chan.handlers($chan)] {
      set rest [lassign $handler patlist type id]

      set matched false
      foreach msgpat $patlist {
        set parampats [lassign $patlist cmdpat]

        # don't care about extra args to a command, so that the pattern
        # for e.g. a message can just be "PRIVMSG"
        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 }

      set matchedany true
      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
          }
        }
      } result options]] {
        if {$code == 1} {
          ${logd}::error "error in $type handler $id (pattern list: [list $patlist]): $result"
          ${logd}::error "errorInfo: [dict get $options -errorinfo]"
        }
      }
    }
    if !$matchedany {
      ${logd}::warn "unmatched command on channel \"$chan\": $msg"
    }
  }

  # nodoc
  proc int-rminterp {interp} {
    interp delete $interp
  }
  # documented
  proc listener {subcommand chan args} {
    variable chan.handlers
    switch -- $subcommand {
      add {
        set thread false
        if {[lindex $args 0] == "-thread"} {
          set thread true
          set args [lrange $args 1 end]
        }

        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::listener add chan ?-thread? patlist script\"" }
        lassign $args patlist script
        set id [format "%016x" [expr {round(rand() * (2**64))}]]

        if !$thread {
          set interp [interp create]
          irc::int-setaliases $interp
          interp share {} $chan $interp

          lassign [chan pipe] reader writer
          interp transfer {} $reader $interp
          $interp alias selfdestruct ::irc::int-rminterp $interp
          $interp eval [list set dispatch $reader]
          $interp eval [list after idle $script]

          lappend chan.handlers($chan) [list $patlist chan $id $writer $interp]
        } else {
          set thread [thread::create -preserved]
          lassign [chan pipe] reader writer

          thread::transfer $thread $reader
          thread::send -async $thread [list set dispatch $reader]
          thread::send -async $thread [list set parent [thread::id]]
          thread::send -async $thread $script

          lappend chan.handlers($chan) [list $patlist tchan $id $writer $thread]
        }

        return $id
      }
      remove {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
        lassign $args rmid
        set newlist ""
        foreach handler [set chan.handlers($chan)] {
          lassign $handler _ type handlerid writer iot
          if {$handlerid != $rmid || $type ni {chan tchan}} {
            lappend newlist $handler
          } elseif {$type == "chan"} {
            puts $writer end
            flush $writer
          } elseif {$type == "tchan"} {
            puts $writer end
            flush $writer
            thread::release $iot
          }
        }
        set chan.handlers($chan) $newlist
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
    }
  }

  # documented
  proc handler {subcommand chan args} {
    variable chan.handlers
    switch -- $subcommand {
      add {
        set thread false
        if {[lindex $args 0] == "-thread"} {
          set thread true
          set args [lrange $args 1 end]
        }

        if {[llength $args] ni {2 3}} { return -code error "wrong # args: should be \"irc::handlers add chan ?-thread? patlist script ?interp-or-thread?\"" }
        set iot [lassign $args patlist script]
        set id [format "%016x" [expr {round(rand() * (2**64))}]]

        if !$thread {
          if [llength $iot] {
            irc::int-setaliases {*}$iot
            interp share {} $chan {*}$iot
          }

          lappend chan.handlers($chan) [list $patlist script $id $script {*}$iot]
        } else {
          if ![llength $iot] {
            set iot [list [thread::create -preserved]]
          } else {
            thread::preserve {*}$iot
          }

          thread::send -async $iot [list set parent [thread::id]]

          lappend chan.handlers($chan) [list $patlist tscript $id $script {*}$iot]
        }

        return $id
      }
      remove {
        if {[llength args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
        lassign $args rmid
        set newlist ""
        foreach handler [set chan.handlers($chan)] {
          set iot [lassign $handler _ type handlerid _]
          if {$handlerid != $rmid || $type ni {script tscript}} {
            lappend newlist $handler
          } elseif {$type == "script" && [llength $iot]} {
            interp delete {*}$iot
          } elseif {$type == "tscript"} {
            thread::release {*}$iot
          }
        }
        set chan.handlers($chan) $newlist
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
    }
  }

  # nodoc
  proc int-onextern {ichan chan} {
    set msg [gets $ichan]
    if {$msg == ""} return
    puts $chan $msg
    flush $chan
  }
  # documented
  proc extern {subcommand chan args} {
    variable chan.handlers
    switch -- $subcommand {
      add {
        if {[llength $args] != 3} { return -code error "wrong # args: should be \"irc::extern add chan patlist ochan ichan\"" }
        lassign $args patlist ochan ichan
        set id [format "%016x" [expr {round(rand() * (2**64))}]]

        lappend chan.handlers($chan) [list $patlist extern $id $ochan $ichan]

        fileevent $ichan readable [list ::irc::int-onextern $ichan $chan]

        return $id
      }
      remove {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::extern remove chan id\"" }
        lassign $args rmid
        set newlist ""
        foreach handler [set chan.handlers($chan)] {
          lassign $handler _ type handlerid ochan ichan
          if {$handlerid != $rmid || $type != "extern"} {
            lappend newlist $handler
          } else {
            puts $ochan $chan
            puts $ochan end
            close $ichan
          }
        }
        set chan.handler($chan) $newlist
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
    }
  }

  # documented
  proc interceptor {subcommand chan args} {
    variable chan.interceptors
    switch -- $subcommand {
      add {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::interceptor add chan procname\"" }
        lassign $args procname
        set id [format "%016x" [expr {round(rand() * (2**64))}]]

        lappend chan.interceptors($chan) [list $id $procname]

        return $id
      }
      remove {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::interceptor remove chan id\"" }
        lassign $args rmid
        set newlist ""
        foreach interceptor [set chan.interceptor($chan)] {
          lassign $interceptor id procname
          if {$id != $rmid} {
            lappend newlist $interceptor
          }
        }
        set chan.interceptors($chan) $newlist
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
    }
  }

  # documented
  proc patlist {chan id {patlist {}}} {
    if {$patlist != ""} {
      set newlist ""
      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]
        }
      }
    }
  }


  # documented
  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?\"" }
        lassign $args src
        set partsVar ""
        if {[llength $args] == 1} { set partsVar [lindex $args 1] }

        if [irc::is src::user $src] {
          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 $src] {
          if [string length $partsVar] {
            upvar $partsVar parts
            set parts [dict create servername $src]
          }
          return server
        } else { return -code error "argument is not a src" }
      }
      server {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::src server servername\"" }
        lassign $args servername
        if ![irc::is src::servername $servername] { 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 args [lassign $args _ user]
          if ![irc::is src::part $user] { return -code error "-user argument is not a user" }
          set user "!$user"
        }
        set host ""
        if {[lindex $args 0] == "-host"} {
          set args [lassign $args _ host]
          if ![irc::is src::part $host] { return -code error "-host argument is not a host" }
          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" }
    }
  }

  # documented
  proc tags {subcommand args} {
    switch -- $subcommand {
      exists {
        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::tags exists tags key\"" }
        lassign $args tags key

        foreach tag [split $tags ";"] {
          if { ![string first "$key=" $tag] || $tag == $key } { return true }
        }
        return false
      }
      remove {
        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::tags remove tags key\"" }
        lassign $args tags key
        set ret ""

        foreach tag [split $tags ";"] {
          if { [string first "$key=" $tag] && $tag != $key } {
            append ret "$tag;"
          }
        }

        string range $ret 0 end-1
      }
      get {
        if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::tags get tags ?key?\"" }
        set key [lassign $args tags]

        if ![llength $key] {
          set ret ""

          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]]
            lappend ret [list $key $value]
          }
          return $ret
        }

        lassign $key key
        foreach tag [split $tags ";"] {
          if {![string first "$key=" $tag]} {
            return [irc::unesc tags::value [string range $tag [string first = $tag]+1 end]]
          } elseif { $tag == $key } { return "" }
        }

        return -code error "key \"$key\" not known in tags"
      }
      set {
        if {[llength $args] ni {2 3}} { return -code error "wrong # args: should be \"irc::tags set tags key ?value?\"" }
        set value [lassign $args tags key]
        set ret ""

        set found false
        foreach tag [split $tags ";"] {
          if { !$found && ![string first "$key=" $tag] || $tag == $key } {
            if [llength $value] {
              append ret "$key=[irc::esc tags::value {*}$value];"
            } else {
              append ret "$key;"
            }
            set found true
          } else {
            append ret "$tag;"
          }
        }

        if !$found {
          if [llength $value] {
            append ret "$key=[irc::esc tags::value {*}$value];"
          } else {
            append ret "$key;"
          }
        }

        string range $ret 0 end-1
      }

      create {
        set ret ""
        dict for {key value} $args {
          set ret [irc::tags set $ret $key $value]
        }
        return $ret
      }
      merge {
        set ret ""

        foreach tags $args {
          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]
            }
          } elseif [irc::is misc::dict $tags] {
            dict for {key value} $tags {
              set ret [irc::tags set $ret $key $value]
            }
          } else {
            return -code error "argument is not tags or a dict"
          }
        }
        return $ret
      }
      dict {
        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::tags dict tags\"" }
        lassign $args tags

        set ret ""
        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]]
          dict set ret $key $value
        }
        return $ret
      }
      default { return -code error "unknown subcommand \"$subcommand\": must be create, dict, exists, get, merge, remove, or set" }
    }
  }

  # documented
  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 ...? \"" }

        set msg ""

        # TODO: unordered flag parsing
        if {[lindex $args 0] == "-tags"} {
          set args [lassign $args _ tags]
          if {[llength $args] < 3} { return -code error "missing tags dictionary argument to -tags option" }
          set msg "@[irc::tags merge $tags] "
        }

        if {[lindex $args 0] == "-src"} {
          if {[llength $args] < 3} { return -code error "missing src argument to -src option" }
          set args [lassign $args _ src]
          if ![irc::is src $src] { return -code error "-src argument is not a src" }
          append msg ":$src "
        }

        set args [lassign $args cmd]
        if ![irc::is cmd $cmd] { return -code error "invalid irc command \"$cmd\"" }
        append msg "[string toupper $cmd] "

        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 args [lassign $args chan]
        puts $chan "[irc::msg fmt {*}$args]\n"
        flush $chan
      }

      # 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" }
        lassign $args message tagsVar srcVar cmdVar paramsVar
        upvar $tagsVar tags
        upvar $srcVar src
        upvar $cmdVar cmd
        upvar $paramsVar 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" }
    }
  }
}