Posted to tcl by __used at Sun Jul 03 19:18:44 GMT 2022view raw

  1. #!/usr/bin/env tclsh
  2. #
  3. # Minimal IRCd server in Tcl
  4. # Copyright (C) 2004 Salvatore Sanfilippo <antirez@invece.org>
  5.  
  6. # TODO
  7. #
  8. # Case insensitive channels/nicks
  9. # - more about MODE
  10. # - KICK
  11. # - BAN
  12. # - FLOOD LIMIT
  13. #
  14. # When one changes nick the notification should reach every
  15. # user just one time.
  16.  
  17. set ::Version "0.1b"
  18. # __used 20220703
  19. # - reformatted source \t -> ' '; bumped version
  20. # + TLS
  21. # status: tls 1.7.16 fails to set up tls sock with irssi as client,
  22. # error: wrong version number (on tls protocol)
  23. set ::DoTLS 1
  24.  
  25. if {$::DoTLS} {
  26. if {[catch {package require tls} err]} {
  27. puts "DoTLS: $err"
  28. exit 1
  29. }
  30. puts "DoTLS: $err"
  31. }
  32.  
  33. # Procedures to get/set state
  34. foreach procname { config clientState clientHost clientNick clientPort
  35. clientRealName clientUser clientVirtualHost
  36. nickToFd channelInfo} \
  37. {
  38. proc $procname {key args} [string map [list %%procname%% $procname] {
  39. switch -- [llength $args] {
  40. 0 {
  41. if {[info exists ::%%procname%%($key)]} {
  42. set ::%%procname%%($key)
  43. } else {
  44. return {}
  45. }
  46. }
  47. 1 {
  48. set newval [lindex $args 0]
  49. if {$newval eq {}} {
  50. catch {unset ::%%procname%%($key)}
  51. } else {
  52. set ::%%procname%%($key) $newval
  53. }
  54. }
  55. default {return -code error "Wrong # of args for 'config'"}
  56. }
  57. }]
  58. }
  59.  
  60. proc dbgtls {args} {
  61. puts stderr "dbgtls: $args"
  62. }
  63.  
  64. # TLS in 2022 requires this hack:
  65. # note tls:socket (ONE colon)
  66. proc tls:socket args {
  67. set opts [lrange $args 0 end-2]
  68. set host [lindex $args end-1]
  69. set port [lindex $args end]
  70. # in tls 1.7.16 from Devuan Beowulf (tcl 8.6.9), these should be def.
  71. # BROKEN on connect
  72. set s [::tls::socket \
  73. -command dbgtls \
  74. -tls1 1 \
  75. -tls1.1 1 \
  76. -tls1.2 1 \
  77. -autoservername true \
  78. -servername $host {*}$opts $host $port \
  79. ]
  80. # ::tls::handshake $s
  81. return $s
  82. }
  83.  
  84. # Implementation
  85. proc debug msg {
  86. if {[config debugmessages]} {
  87. puts $msg
  88. }
  89. }
  90.  
  91. proc handleNewConnection {fd host port} {
  92. clientState $fd UNREGISTERED
  93. clientHost $fd [lindex [fconfigure $fd -peername] 1]
  94. clientPort $fd $port
  95. clientNick $fd {}
  96. clientUser $fd {}
  97. clientVirtualHost $fd {}
  98. clientRealName $fd {}
  99. fconfigure $fd -blocking 0
  100. fileevent $fd readable [list handleClientInputWrapper $fd]
  101. rawMsg $fd "NOTICE AUTH :[config version] initialized, welcome."
  102. }
  103.  
  104. proc ircWrite {fd msg} {
  105. catch {
  106. puts $fd $msg
  107. flush $fd
  108. }
  109. }
  110.  
  111. proc rawMsg {fd msg} {
  112. ircWrite $fd ":[config hostname] $msg"
  113. }
  114.  
  115. proc serverClientMsg {fd code msg} {
  116. ircWrite $fd ":[config hostname] $code [clientNick $fd] $msg"
  117. }
  118.  
  119. # This just calls handleClientInput, but catch every error reporting
  120. # it to standard output to avoid that the application can fail
  121. # even if the error is non critical.
  122. proc handleClientInputWrapper fd {
  123. if {[catch {handleClientInput $fd} retval]} {
  124. debug "IRCD runtime error:\n$::errorInfo"
  125. debug "-----------------"
  126. # Better to wait one second... the error may be
  127. # present before than the read operation and the
  128. # handler will be fired again. To avoid to consume all
  129. # the CPU in a busy infinite loop we need to sleep one second
  130. # for every error.
  131. after 1000
  132. }
  133. return $retval
  134. }
  135.  
  136. proc handleClientInput fd {
  137. if {[catch {fconfigure $fd}]} return
  138. if {[eof $fd]} {
  139. handleClientQuit $fd "EOF from client"
  140. return
  141. }
  142. if {[catch {gets $fd line} err]} {
  143. handleClientQuit $fd "I/O error: $err"
  144. return
  145. }
  146. if {$line eq {}} return
  147. set line [string trim $line]
  148. debug "([clientState $fd]:$fd) [clientNick $fd] -> '$line'"
  149. if {[clientState $fd] eq {UNREGISTERED}} {
  150. if {[regexp -nocase {NICK +([^ ]+)$} $line -> nick]} {
  151. if {[nickToFd $nick] ne {}} {
  152. rawMsg $fd "433 * $nick :Nickname is already in use."
  153. return
  154. }
  155. clientNick $fd $nick
  156. nickToFd $nick $fd
  157. if {[clientUser $fd] ne {}} {
  158. registerClient $fd
  159. }
  160. } elseif {[regexp -nocase {USER +([^ ]+) +([^ ]+) +([^ ]+) +(.+)$} \
  161. $line -> user mode virtualhost realname]} \
  162. {
  163. stripColon realname
  164. clientUser $fd $user
  165. clientVirtualHost $virtualhost
  166. clientRealName $fd $realname
  167. if {[clientNick $fd] ne {}} {
  168. registerClient $fd
  169. }
  170. }
  171. } elseif {[clientState $fd] eq {REGISTERED}} {
  172. # The big regexps if/else. This are the commands supported currently.
  173. if {[regexp -nocase {JOIN +([^ ]+)$} $line -> channel]} {
  174. handleClientJoin $fd $channel
  175. } elseif {[regexp -nocase {^PING +([^ ]+) *(.*)$} $line -> pingmsg _]} {
  176. handleClientPing $fd $pingmsg
  177. } elseif {[regexp -nocase {^PRIVMSG +([^ ]+) +(.*)$} $line \
  178. -> target msg]} \
  179. {
  180. handleClientPrivmsg PRIVMSG $fd $target $msg
  181. } elseif {[regexp -nocase {^NOTICE +([^ ]+) +(.*)$} $line \
  182. -> target msg]} \
  183. {
  184. handleClientPrivmsg NOTICE $fd $target $msg
  185. } elseif {[regexp -nocase {^PART +([^ ]+) *(.*)$} $line \
  186. -> channel msg]} \
  187. {
  188. handleClientPart $fd PART $channel $msg
  189. } elseif {[regexp -nocase {^QUIT *(.*)$} $line -> msg]} {
  190. handleClientQuit $fd $msg
  191. } elseif {[regexp -nocase {^NICK +([^ ]+)$} $line -> nick]} {
  192. handleClientNick $fd $nick
  193. } elseif {[regexp -nocase {^TOPIC +([^ ]+) *(.*)$} $line \
  194. -> channel topic]} \
  195. {
  196. handleClientTopic $fd $channel $topic
  197. } elseif {[regexp -nocase {^LIST *(.*)$} $line -> channel]} {
  198. handleClientList $fd $channel
  199. } elseif {[regexp -nocase {^WHOIS +(.+)$} $line -> nick]} {
  200. handleClientWhois $fd $nick
  201. } elseif {[regexp -nocase {^WHO +([^ ]+) *(.*)$} $line -> channel _]} {
  202. handleClientWho $fd $channel
  203. } elseif {[regexp -nocase {^MODE +([^ ]+) *(.*)$} $line -> target rest]} {
  204. handleClientMode $fd $target $rest
  205. } elseif {[regexp -nocase {^USERHOST +(.+)$} $line -> nicks]} {
  206. handleClientUserhost $fd $nicks
  207. } elseif {[regexp -nocase {^RELOAD +(.+)$} $line -> password]} {
  208. handleClientReload $fd $password
  209. } else {
  210. set cmd [lindex [split $line] 0]
  211. serverClientMsg $fd 421 "$cmd :Unknown command"
  212. }
  213. }
  214. }
  215.  
  216. proc registerClient fd {
  217. clientState $fd REGISTERED
  218. serverClientMsg $fd 001 ":Welcome to this IRC server [clientNick $fd]"
  219. serverClientMsg $fd 002 ":Your host is [config hostname], running version [config version]"
  220. serverClientMsg $fd 003 ":This server was created ... I don't know"
  221. serverClientMsg $fd 004 "[config hostname] [config version] aAbBcCdDeEfFGhHiIjkKlLmMnNopPQrRsStUvVwWxXyYzZ0123459*@ bcdefFhiIklmnoPqstv"
  222. }
  223.  
  224. proc freeClient fd {
  225. clientState fd {}
  226. nickToFd [clientNick $fd] {}
  227. close $fd
  228. }
  229.  
  230. proc stripColon varname {
  231. upvar 1 $varname v
  232. if {[string index $v 0] eq {:}} {
  233. set v [string range $v 1 end]
  234. }
  235. }
  236.  
  237. # Remove extra spaces separating words.
  238. # For example " a b c d " is turned into "a b c d"
  239. proc stripExtraSpaces varname {
  240. upvar 1 $varname v
  241. set oldstr {}
  242. while {$oldstr ne $v} {
  243. set oldstr $v
  244. set v [string map {{ } { }} $v]
  245. }
  246. set v [string trim $v]
  247. }
  248.  
  249. proc noNickChannel {fd target} {
  250. serverClientMsg $fd 401 "$target :No such nick/channel"
  251. }
  252.  
  253. proc channelInfoOrReturn {fd channel} {
  254. if {[set info [channelInfo $channel]] eq {}} {
  255. noNickChannel $fd $channel
  256. return -code return
  257. }
  258. return $info
  259. }
  260.  
  261. proc nickFdOrReturn {fd nick} {
  262. if {[set targetfd [nickToFd $nick]] eq {}} {
  263. noNickChannel $fd $nick
  264. return -code return
  265. }
  266. return $targetfd
  267. }
  268.  
  269. proc handleClientQuit {fd msg} {
  270. if {[catch {fconfigure $fd}]} return
  271. debug "*** Quitting $fd ([clientNick $fd])"
  272. set channels [clientChannels $fd]
  273. foreach channel $channels {
  274. handleClientPart $fd QUIT $channel $msg
  275. }
  276. freeClient $fd
  277. }
  278.  
  279. proc handleClientJoin {fd channels} {
  280. foreach channel [split $channels ,] {
  281. if {[string index $channel 0] ne {#}} {
  282. serverClientMsg $fd 403 "$channel :That channel doesn't exis"
  283. continue
  284. }
  285. if {[channelInfo $channel] eq {}} {
  286. channelInfo $channel [list {} {} {}]; # empty topic, no users.
  287. }
  288. if {[clientInChannel $fd $channel]} {
  289. continue; # User already in this channel
  290. }
  291. foreach {topic userlist usermode} [channelInfo $channel] break
  292. if {[llength $userlist]} {
  293. lappend usermode {}
  294. } else {
  295. lappend usermode {@}
  296. }
  297. lappend userlist $fd
  298. channelInfo $channel [list $topic $userlist $usermode]
  299. userMessage $channel $fd "JOIN :$channel"
  300. sendTopicMessage $fd $channel
  301. sendWhoMessage $fd $channel
  302. }
  303. }
  304.  
  305. proc userMessage {channel userfd msg args} {
  306. array set sent {}
  307. if {[string index $channel 0] eq {#}} {
  308. channelInfoOrReturn $userfd $channel
  309. foreach {topic userlist usermode} [channelInfo $channel] break
  310. } else {
  311. set userlist $channel
  312. }
  313. set user ":[clientNick $userfd]!~[clientUser $userfd]@[clientHost $userfd]"
  314. foreach fd $userlist {
  315. if {[lsearch $args -noself] != -1 && $fd eq $userfd} continue
  316. ircWrite $fd "$user $msg"
  317. }
  318. }
  319.  
  320. proc userChannelsMessage {fd msg} {
  321. set channels [clientChannels $fd]
  322. foreach channel $channels {
  323. userMessage $channel $fd $msg
  324. }
  325. }
  326.  
  327. proc allChannels {} {
  328. array names ::channelInfo
  329. }
  330.  
  331. # Note that this does not scale well if there are many
  332. # channels. For now data structures are designed to make
  333. # the code little. The solution is to duplicate this information
  334. # into the client state, so that every client have an associated
  335. # list of channels.
  336. proc clientChannels fd {
  337. set res {}
  338. foreach channel [allChannels] {
  339. if {[clientInChannel $fd $channel]} {
  340. lappend res $channel
  341. }
  342. }
  343. return $res
  344. }
  345.  
  346. proc clientInChannel {fd channel} {
  347. set userlist [lindex [channelInfo $channel] 1]
  348. expr {[lsearch -exact $userlist $fd] != -1}
  349. }
  350.  
  351. proc clientModeInChannel {fd channel} {
  352. foreach {topic userlist usermode} [channelInfo $channel] break
  353. foreach u $userlist m $usermode {
  354. if {$u eq $fd} {
  355. return $m
  356. }
  357. }
  358. return {}
  359. }
  360.  
  361. proc setClientModeInChannel {fd channel mode} {
  362. foreach {topic userlist usermode} [channelInfo $channel] break
  363. set i 0
  364. foreach u $userlist m $usermode {
  365. if {$u eq $fd} {
  366. lset usermode $i $mode
  367. channelInfo $channel [list $topic $userlist $usermode]
  368. return $mode
  369. }
  370. incr i
  371. }
  372. }
  373.  
  374. proc handleClientPart {fd cmd channels msg} {
  375. stripColon msg
  376. foreach channel [split $channels ,] {
  377. foreach {topic userlist usermode} [channelInfoOrReturn $fd $channel] break
  378. if {$cmd eq {QUIT}} {
  379. userMessage $channel $fd "$cmd $msg" -noself
  380. } else {
  381. userMessage $channel $fd "$cmd $channel $msg"
  382. }
  383. if {[set pos [lsearch -exact $userlist $fd]] != -1} {
  384. set userlist [lreplace $userlist $pos $pos]
  385. set usermode [lreplace $usermode $pos $pos]
  386. }
  387. if {[llength $userlist] == 0} {
  388. # Delete the channel if it's the last user
  389. channelInfo $channel {}
  390. } else {
  391. channelInfo $channel [list $topic $userlist $usermode]
  392. }
  393. }
  394. }
  395.  
  396. proc handleClientPing {fd pingmsg} {
  397. rawMsg $fd "PONG [config hostname] :$pingmsg"
  398. }
  399.  
  400. proc handleClientPrivmsg {irccmd fd target msg} {
  401. stripColon msg
  402. if {[string index $target 0] eq {#}} {
  403. channelInfoOrReturn $fd $target
  404. if {[config debugchannel] && \
  405. [string range $target 1 end] eq [config reloadpasswd]} \
  406. {
  407. catch $msg msg
  408. userMessage $target $fd "$irccmd $target :$msg"
  409. } else {
  410. userMessage $target $fd "$irccmd $target :$msg" -noself
  411. }
  412. } else {
  413. set targetfd [nickFdOrReturn $fd $target]
  414. userMessage $targetfd $fd "$irccmd $target :$msg"
  415. }
  416. }
  417.  
  418. proc handleClientNick {fd nick} {
  419. stripColon nick
  420. set oldnick [clientNick $fd]
  421. if {[nickToFd $nick] ne {}} {
  422. rawMsg $fd "433 * $nick :Nickname is already in use."
  423. return
  424. }
  425. userChannelsMessage $fd "NICK :$nick"
  426. clientNick $fd $nick
  427. nickToFd $nick $fd
  428. nickToFd $oldnick {} ; # Remove the old nick from the list
  429. }
  430.  
  431. proc handleClientTopic {fd channel topic} {
  432. stripColon topic
  433. channelInfoOrReturn $fd $channel
  434. if {[string trim $topic] eq {}} {
  435. sendTopicMessage $fd $channel
  436. } else {
  437. foreach {_ userlist usermode} [channelInfo $channel] break
  438. channelInfo $channel [list $topic $userlist $usermode]
  439. userMessage $channel $fd "TOPIC $channel :$topic"
  440. }
  441. }
  442.  
  443. proc handleClientList {fd target} {
  444. stripColon target
  445. set target [string trim $target]
  446. serverClientMsg $fd 321 "Channel :Users Name"
  447. foreach channel [allChannels] {
  448. if {$target ne {} && ![string equal -nocase $target $channel]} continue
  449. foreach {topic userlist usermode} [channelInfo $channel] break
  450. serverClientMsg $fd 322 "$channel [llength $userlist] :$topic"
  451. }
  452. serverClientMsg $fd 323 ":End of /LIST"
  453. }
  454.  
  455. proc handleClientWhois {fd nick} {
  456. set targetfd [nickFdOrReturn $fd $nick]
  457. set chans [clientChannels $targetfd]
  458. serverClientMsg $fd 311 "$nick ~[clientUser $targetfd] [clientHost $targetfd] * :[clientRealName $targetfd]"
  459. if {[llength $chans]} {
  460. serverClientMsg $fd 319 "$nick :[join $chans]"
  461. }
  462. serverClientMsg $fd 312 "$nick [config hostname] :[config hostname]"
  463. serverClientMsg $fd 318 "$nick :End of /WHOIS list."
  464. }
  465.  
  466. proc handleClientWho {fd channel} {
  467. foreach {topic userlist usermode} [channelInfoOrReturn $fd $channel] break
  468. foreach userfd $userlist mode $usermode {
  469. serverClientMsg $fd 352 "$channel ~[clientUser $userfd] [clientHost $userfd] [config hostname] $mode[clientNick $userfd] H :0 [clientRealName $userfd]"
  470. }
  471. serverClientMsg $fd 315 "$channel :End of /WHO list."
  472. }
  473.  
  474. # This is a work in progress. Support for OP/DEOP is implemented.
  475. proc handleClientMode {fd target rest} {
  476. set argv {}
  477. foreach token [split $rest] {
  478. if {$token ne {}} {
  479. lappend argv $token
  480. }
  481. }
  482. if {[string index $target 0] eq {#}} {
  483. # Channel mode handling
  484. if {[llength $argv] == 2} {
  485. switch -- [lindex $argv 0] {
  486. -o - +o {
  487. set nick [lindex $argv 1]
  488. set nickfd [nickFdOrReturn $fd $nick]
  489. if {[clientModeInChannel $fd $target] ne {@}} {
  490. serverClientMsg $fd 482 \
  491. "$target :You need to be a channel operator to do that"
  492. return
  493. }
  494. set newmode [switch -- [lindex $argv 0] {
  495. +o {concat @}
  496. -o {concat {}}
  497. }]
  498. setClientModeInChannel $nickfd $target $newmode
  499. userMessage $target $fd "MODE $target $rest"
  500. }
  501. }
  502. }
  503. } else {
  504. # User mode handling
  505. }
  506. }
  507.  
  508. proc handleClientUserhost {fd nicks} {
  509. stripExtraSpaces nicks
  510. set res {}
  511. foreach nick [split $nicks] {
  512. if {[set nickfd [nickToFd $nick]] eq {}} continue
  513. append res "$nick=+~[clientUser $nickfd]@[clientHost $nickfd] "
  514. }
  515. serverClientMsg $fd 302 ":[string trim $res]"
  516. }
  517.  
  518. proc handleClientReload {fd password} {
  519. if {$password eq [config reloadpasswd]} {
  520. source [info script]
  521. }
  522. }
  523.  
  524. proc sendTopicMessage {fd channel} {
  525. foreach {topic userlist usermode} [channelInfo $channel] break
  526. if {$topic ne {}} {
  527. serverClientMsg $fd 332 "$channel :$topic"
  528. } else {
  529. serverClientMsg $fd 331 "$channel :There isn't a topic."
  530. }
  531. }
  532.  
  533. proc sendWhoMessage {fd channel} {
  534. set nick [clientNick $fd]
  535. foreach {topic userlist usermode} [channelInfo $channel] break
  536. set users {}
  537. foreach fd $userlist mode $usermode {
  538. append users "$mode[clientNick $fd] "
  539. }
  540. set users [string range $users 0 end-1]
  541. serverClientMsg $fd 353 "= $channel :$users"
  542. serverClientMsg $fd 366 "$channel :End of /NAMES list."
  543. }
  544.  
  545. # Initialization
  546. proc init {} {
  547. set ::initialized 1
  548. if {$::DoTLS} {
  549. tls:socket -server handleNewConnection [config tcpport]
  550. } else {
  551. socket -server handleNewConnection [config tcpport]
  552. }
  553. vwait forever
  554. }
  555.  
  556. config hostname localhost
  557. if {!$::DoTLS} {
  558. config tcpport 6667
  559. } else {
  560. config tcpport 6697
  561. }
  562. config defchan #tclircd
  563. config version "TclIRCD-$::Version"
  564. config reloadpasswd "sfkjsdlf939393"
  565. config debugchannel 0 ; # Warning, don't change it if you don't know well.
  566. config debugmessages 1
  567.  
  568. # Initialize only if it is not a 'reaload'.
  569. if {![info exists ::initialized]} {
  570. puts "Starting: DoTLS:$::DoTLS;\nhostname:[config hostname]; tcpport:[config tcpport]; defchan:[config defchan]"
  571. init
  572. }
  573.