# Minimal IRCd server in Tcl # Copyright (C) 2004 Salvatore Sanfilippo # TODO # # Case insensitive channels/nicks # - more about MODE # - KICK # - BAN # - FLOOD LIMIT # # When one changes nick the notification should reach every # user just one time. # Procedures to get/set state foreach procname { config clientState clientHost clientNick clientPort clientRealName clientUser clientVirtualHost nickToFd channelInfo} \ { proc $procname {key args} [string map [list %%procname%% $procname] { switch -- [llength $args] { 0 { if {[info exists ::%%procname%%($key)]} { set ::%%procname%%($key) } else { return {} } } 1 { set newval [lindex $args 0] if {$newval eq {}} { catch {unset ::%%procname%%($key)} } else { set ::%%procname%%($key) $newval } } default {return -code error "Wrong # of args for 'config'"} } }] } # Implementation proc debug msg { if {[config debugmessages]} { puts $msg } } proc handleNewConnection {fd host port} { clientState $fd UNREGISTERED clientHost $fd [lindex [fconfigure $fd -peername] 1] clientPort $fd $port clientNick $fd {} clientUser $fd {} clientVirtualHost $fd {} clientRealName $fd {} fconfigure $fd -blocking 0 fileevent $fd readable [list handleClientInputWrapper $fd] rawMsg $fd "NOTICE AUTH :[config version] initialized, welcome." } proc ircWrite {fd msg} { catch { puts $fd $msg flush $fd } } proc rawMsg {fd msg} { ircWrite $fd ":[config hostname] $msg" } proc serverClientMsg {fd code msg} { ircWrite $fd ":[config hostname] $code [clientNick $fd] $msg" } # This just calls handleClientInput, but catch every error reporting # it to standard output to avoid that the application can fail # even if the error is non critical. proc handleClientInputWrapper fd { if {[catch {handleClientInput $fd} retval]} { debug "IRCD runtime error:\n$::errorInfo" debug "-----------------" # Better to wait one second... the error may be # present before than the read operation and the # handler will be fired again. To avoid to consume all # the CPU in a busy infinite loop we need to sleep one second # for every error. after 1000 } return $retval } proc handleClientInput fd { if {[catch {fconfigure $fd}]} return if {[eof $fd]} { handleClientQuit $fd "EOF from client" return } if {[catch {gets $fd line} err]} { handleClientQuit $fd "I/O error: $err" return } if {$line eq {}} return set line [string trim $line] debug "([clientState $fd]:$fd) [clientNick $fd] -> '$line'" if {[clientState $fd] eq {UNREGISTERED}} { if {[regexp -nocase {NICK +([^ ]+)$} $line -> nick]} { stripColon nick if {[nickToFd $nick] ne {}} { rawMsg $fd "433 * $nick :Nickname is already in use." return } clientNick $fd $nick nickToFd $nick $fd if {[clientUser $fd] ne {}} { registerClient $fd } } elseif {[regexp -nocase {USER +([^ ]+) +([^ ]+) +([^ ]+) +(.+)$} \ $line -> user mode virtualhost realname]} \ { stripColon realname clientUser $fd $user clientVirtualHost $fd $virtualhost clientRealName $fd $realname if {[clientNick $fd] ne {}} { registerClient $fd } } } elseif {[clientState $fd] eq {REGISTERED}} { # The big regexps if/else. This are the commands supported currently. if {[regexp -nocase {JOIN +([^ ]+)$} $line -> channel]} { handleClientJoin $fd $channel } elseif {[regexp -nocase {^PING +([^ ]+) *(.*)$} $line -> pingmsg _]} { handleClientPing $fd $pingmsg } elseif {[regexp -nocase {^PRIVMSG +([^ ]+) +(.*)$} $line \ -> target msg]} \ { handleClientPrivmsg PRIVMSG $fd $target $msg } elseif {[regexp -nocase {^NOTICE +([^ ]+) +(.*)$} $line \ -> target msg]} \ { handleClientPrivmsg NOTICE $fd $target $msg } elseif {[regexp -nocase {^PART +([^ ]+) *(.*)$} $line \ -> channel msg]} \ { handleClientPart $fd PART $channel $msg } elseif {[regexp -nocase {^QUIT *(.*)$} $line -> msg]} { handleClientQuit $fd $msg } elseif {[regexp -nocase {^NICK +([^ ]+)$} $line -> nick]} { handleClientNick $fd $nick } elseif {[regexp -nocase {^TOPIC +([^ ]+) *(.*)$} $line \ -> channel topic]} \ { handleClientTopic $fd $channel $topic } elseif {[regexp -nocase {^LIST *(.*)$} $line -> channel]} { handleClientList $fd $channel } elseif {[regexp -nocase {^WHOIS +(.+)$} $line -> nick]} { handleClientWhois $fd $nick } elseif {[regexp -nocase {^WHO *$} $line ->]} { handleClientWho $fd "" } elseif {[regexp -nocase {^WHO +([^ ]+) *(.*)$} $line -> channel _]} { handleClientWho $fd $channel } elseif {[regexp -nocase {^MODE +([^ ]+) *(.*)$} $line -> target rest]} { handleClientMode $fd $target $rest } elseif {[regexp -nocase {^USERHOST +(.+)$} $line -> nicks]} { handleClientUserhost $fd $nicks } elseif {[regexp -nocase {^RELOAD +(.+)$} $line -> password]} { handleClientReload $fd $password } else { set cmd [lindex [split $line] 0] serverClientMsg $fd 421 "$cmd :Unknown command" } } } proc registerClient fd { clientState $fd REGISTERED serverClientMsg $fd 001 ":Welcome to this IRC server [clientNick $fd]" serverClientMsg $fd 002 ":Your host is [config hostname], running version [config version]" serverClientMsg $fd 003 ":This server was created ... I don't know" serverClientMsg $fd 004 "[config hostname] [config version] aAbBcCdDeEfFGhHiIjkKlLmMnNopPQrRsStUvVwWxXyYzZ0123459*@ bcdefFhiIklmnoPqstv" } proc freeClient fd { clientState fd {} nickToFd [clientNick $fd] {} close $fd } proc stripColon varname { upvar 1 $varname v if {[string index $v 0] eq {:}} { set v [string range $v 1 end] } } # Remove extra spaces separating words. # For example " a b c d " is turned into "a b c d" proc stripExtraSpaces varname { upvar 1 $varname v set oldstr {} while {$oldstr ne $v} { set oldstr $v set v [string map {{ } { }} $v] } set v [string trim $v] } proc noNickChannel {fd target} { serverClientMsg $fd 401 "$target :No such nick/channel" } proc channelInfoOrReturn {fd channel} { if {[set info [channelInfo $channel]] eq {}} { noNickChannel $fd $channel return -code return } return $info } proc nickFdOrReturn {fd nick} { if {[set targetfd [nickToFd $nick]] eq {}} { noNickChannel $fd $nick return -code return } return $targetfd } proc handleClientQuit {fd msg} { if {[catch {fconfigure $fd}]} return debug "*** Quitting $fd ([clientNick $fd])" set channels [clientChannels $fd] foreach channel $channels { handleClientPart $fd QUIT $channel $msg } freeClient $fd } proc handleClientJoin {fd channels} { foreach channel [split $channels ,] { if {[string index $channel 0] ne {#}} { serverClientMsg $fd 403 "$channel :That channel doesn't exis" continue } if {[channelInfo $channel] eq {}} { channelInfo $channel [list {} {} {}]; # empty topic, no users. } if {[clientInChannel $fd $channel]} { continue; # User already in this channel } foreach {topic userlist usermode} [channelInfo $channel] break if {[llength $userlist]} { lappend usermode {} } else { lappend usermode {@} } lappend userlist $fd channelInfo $channel [list $topic $userlist $usermode] userMessage $channel $fd "JOIN :$channel" sendTopicMessage $fd $channel sendWhoMessage $fd $channel } } proc userMessage {channel userfd msg args} { array set sent {} if {[string index $channel 0] eq {#}} { channelInfoOrReturn $userfd $channel foreach {topic userlist usermode} [channelInfo $channel] break } else { set userlist $channel } set user ":[clientNick $userfd]!~[clientUser $userfd]@[clientHost $userfd]" foreach fd $userlist { if {[lsearch $args -noself] != -1 && $fd eq $userfd} continue ircWrite $fd "$user $msg" } } proc userChannelsMessage {fd msg} { set channels [clientChannels $fd] foreach channel $channels { userMessage $channel $fd $msg } } proc allChannels {} { set retval [array names ::channelInfo] # Remove this hidden channel from the list set removeIdx [lsearch -exact $retval "#[config reloadpasswd]"] if {$removeIdx != -1} { set retval [lreplace $retval $removeIdx $removeIdx] } return $retval } # Note that this does not scale well if there are many # channels. For now data structures are designed to make # the code little. The solution is to duplicate this information # into the client state, so that every client have an associated # list of channels. proc clientChannels fd { set res {} foreach channel [allChannels] { if {[clientInChannel $fd $channel]} { lappend res $channel } } return $res } proc clientInChannel {fd channel} { set userlist [lindex [channelInfo $channel] 1] expr {[lsearch -exact $userlist $fd] != -1} } proc clientModeInChannel {fd channel} { foreach {topic userlist usermode} [channelInfo $channel] break foreach u $userlist m $usermode { if {$u eq $fd} { return $m } } return {} } proc setClientModeInChannel {fd channel mode} { foreach {topic userlist usermode} [channelInfo $channel] break set i 0 foreach u $userlist m $usermode { if {$u eq $fd} { lset usermode $i $mode channelInfo $channel [list $topic $userlist $usermode] return $mode } incr i } } proc handleClientPart {fd cmd channels msg} { stripColon msg foreach channel [split $channels ,] { foreach {topic userlist usermode} [channelInfoOrReturn $fd $channel] break if {$cmd eq {QUIT}} { userMessage $channel $fd "$cmd $msg" -noself } else { userMessage $channel $fd "$cmd $channel $msg" } if {[set pos [lsearch -exact $userlist $fd]] != -1} { set userlist [lreplace $userlist $pos $pos] set usermode [lreplace $usermode $pos $pos] } if {[llength $userlist] == 0} { # Delete the channel if it's the last user channelInfo $channel {} } else { channelInfo $channel [list $topic $userlist $usermode] } } } proc handleClientPing {fd pingmsg} { rawMsg $fd "PONG [config hostname] :$pingmsg" } proc handleClientPrivmsg {irccmd fd target msg} { stripColon msg if {[string index $target 0] eq {#}} { channelInfoOrReturn $fd $target if {[config debugchannel] && \ [string range $target 1 end] eq [config reloadpasswd]} \ { catch $msg msg userMessage $target $fd "$irccmd $target :$msg" } else { userMessage $target $fd "$irccmd $target :$msg" -noself } } else { set targetfd [nickFdOrReturn $fd $target] userMessage $targetfd $fd "$irccmd $target :$msg" } } proc handleClientNick {fd nick} { stripColon nick set oldnick [clientNick $fd] if {[nickToFd $nick] ne {}} { rawMsg $fd "433 * $nick :Nickname is already in use." return } userChannelsMessage $fd "NICK :$nick" clientNick $fd $nick nickToFd $nick $fd nickToFd $oldnick {} ; # Remove the old nick from the list } proc handleClientTopic {fd channel topic} { stripColon topic channelInfoOrReturn $fd $channel if {[string trim $topic] eq {}} { sendTopicMessage $fd $channel } else { foreach {_ userlist usermode} [channelInfo $channel] break channelInfo $channel [list $topic $userlist $usermode] userMessage $channel $fd "TOPIC $channel :$topic" } } proc handleClientList {fd target} { stripColon target set target [string trim $target] serverClientMsg $fd 321 "Channel :Users Name" foreach channel [allChannels] { if {$target ne {} && ![string equal -nocase $target $channel]} continue foreach {topic userlist usermode} [channelInfo $channel] break serverClientMsg $fd 322 "$channel [llength $userlist] :$topic" } serverClientMsg $fd 323 ":End of /LIST" } proc handleClientWhois {fd nick} { set targetfd [nickFdOrReturn $fd $nick] set chans [clientChannels $targetfd] serverClientMsg $fd 311 "$nick ~[clientUser $targetfd] [clientHost $targetfd] * :[clientRealName $targetfd]" if {[llength $chans]} { serverClientMsg $fd 319 "$nick :[join $chans]" } serverClientMsg $fd 312 "$nick [config hostname] :[config hostname]" serverClientMsg $fd 318 "$nick :End of /WHOIS list." } proc handleClientWho {fd channel} { if {$channel eq ""} { foreach {nick userfd} [array get ::nickToFd] { serverClientMsg $fd 352 "## ~[clientUser $userfd] [clientHost $userfd] [config hostname] [clientNick $userfd] H :0 [clientRealName $userfd]" } } else { foreach {topic userlist usermode} [channelInfoOrReturn $fd $channel] break foreach userfd $userlist mode $usermode { serverClientMsg $fd 352 "$channel ~[clientUser $userfd] [clientHost $userfd] [config hostname] $mode[clientNick $userfd] H :0 [clientRealName $userfd]" } } serverClientMsg $fd 315 "$channel :End of /WHO list." } # This is a work in progress. Support for OP/DEOP is implemented. proc handleClientMode {fd target rest} { set argv {} foreach token [split $rest] { if {$token ne {}} { lappend argv $token } } if {[string index $target 0] eq {#}} { # Channel mode handling if {[llength $argv] == 2} { switch -- [lindex $argv 0] { -o - +o { set nick [lindex $argv 1] set nickfd [nickFdOrReturn $fd $nick] if {[clientModeInChannel $fd $target] ne {@}} { serverClientMsg $fd 482 \ "$target :You need to be a channel operator to do that" return } set newmode [switch -- [lindex $argv 0] { +o {concat @} -o {concat {}} }] setClientModeInChannel $nickfd $target $newmode userMessage $target $fd "MODE $target $rest" } } } } else { # User mode handling } } proc handleClientUserhost {fd nicks} { stripExtraSpaces nicks set res {} foreach nick [split $nicks] { if {[set nickfd [nickToFd $nick]] eq {}} continue append res "$nick=+~[clientUser $nickfd]@[clientHost $nickfd] " } serverClientMsg $fd 302 ":[string trim $res]" } proc handleClientReload {fd password} { if {$password eq [config reloadpasswd]} { uplevel #0 [list source [info script]] } } proc sendTopicMessage {fd channel} { foreach {topic userlist usermode} [channelInfo $channel] break if {$topic ne {}} { serverClientMsg $fd 332 "$channel :$topic" } else { serverClientMsg $fd 331 "$channel :There isn't a topic." } } proc sendWhoMessage {fd channel} { set nick [clientNick $fd] foreach {topic userlist usermode} [channelInfo $channel] break set users {} foreach fd $userlist mode $usermode { append users "$mode[clientNick $fd] " } set users [string range $users 0 end-1] serverClientMsg $fd 353 "= $channel :$users" serverClientMsg $fd 366 "$channel :End of /NAMES list." } proc handleLocalCommand {fd ofd} { if {$fd ne ""} { gets $fd line if {[eof $fd] && $line eq ""} { # Do not check for input any more once we get EOF fileevent $fd readable "" return } if {$line eq ""} { return } set cmd "" catch { set cmd [lindex $line 0] } switch -- $cmd { "reloadpasswd" { puts $ofd "Reload password is: [config reloadpasswd]" } "reload" { handleClientReload "" [config reloadpasswd] puts $ofd "Done" } "exit" { exit } default { puts $ofd "Unknown command" } } } puts -nonewline $ofd "> " flush $ofd } # Initialization proc init {} { set ::initialized 1 config reloadpasswd [exec openssl rand -hex 20] if {[config debugchannel]} { handleLocalCommand "" stdout fileevent stdin readable [list handleLocalCommand stdin stdout] } socket -server handleNewConnection [config tcpport] vwait forever } config hostname rkeene.org config tcpport 6667 config version "TclIRCD-0.1a" config debugchannel 0 config debugmessages 0 if {[lsearch -exact $argv "-debug"] != -1} { config debugchannel 1 config debugmessages 1 } # Initialize only if it is not a 'reload'. if {![info exists ::initialized]} { init }