#!/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 {
      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)" }
    }
  }

  proc ::irc::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" }
    }
  }

  proc ::irc::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" }
    }
  }

  proc ::irc::connect {hostname port {usetls 1}} {
    variable chanmeta
    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]
  }

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

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

        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\"" }
        set tags [lindex $args 0]
        set ret ""
        set key [lindex $args 1]

        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 tags [lindex $args 0]
        set key [if {[llength $args] == 2} {lindex $args 1}]

        if {$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
        }

        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 tags [lindex $args 0]
        set ret ""
        set key [lindex $args 1]
        set value [if {[llength $args] == 3} { lindex $args 2 }]
        set found false

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

        if !$found {
          if {$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\"" }
        set tags [lindex $args 0]

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

  proc ::irc::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"} {
          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
      }

      # 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\""