Version 11 of webchain

Updated 2007-12-21 12:14:28 by jdc

Richard Suchenwirth 2007-12-19 - I love the Tcl chatroom. It's like my peer group. So I was quite frustrated when good old Ralfchat (a Perl script) on mini.net was closed down, because that was my only way to participate in the chat from my cellphone.

But isn't Tcl an enabling language? Why not put useful parts from picoIRC 0.2 and Playing CGI together, and build my own bridge between IRC and http? The following script connects to IRC (you may have to fumble with the ircnick, if it is reported as being in use) and collects what is posted to the #tcl channel. It also provides a web server that listens on port 80, and provides the latest posts to the customer there. Also, it accepts posts and posts them to #tcl... It's all quite crude, but what do you expect from less than 90 lines of code, depending on nothing but Tcl? At least, it works quite well from my cell phone, so I can chat from that again (if a server is started).

Here goes:


 #!/usr/bin/env tclsh
 # webchain.tcl - HTTP <-> IRC bridge
 set port      80
 set encoding  iso8859-1 ;# utf-8
 set nick      someone
 set ircserver irc.freenode.org
 set ircport   6667
 set chan      #tcl
 set ircnick   webchain
 set log       {webchain Welcome.}

 proc irc_recv {} {
    gets $::fd line
    if {[string trim $line] ne ""} {puts $line}
    # handle PING messages from server
    if {[lindex [split $line] 0] eq "PING"} {
        send "PONG [info hostname] [lindex [split $line] 1]"; return
    }
    if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \
             nick target msg]} {
        set tag ""
        if [regexp {\001ACTION(.+)\001} $msg -> msg] {set tag italic}
        if [in {azbridge ijchain} $nick] {
            regexp {<([^>]+)>(.+)} $msg -> nick msg
        }
        if {$tag eq "italic"} {set msg <i>$msg</i>}
        lappend ::log $nick $msg
    } else {lappend ::log - <i>$line</i>}
 }
 proc in {list element} {expr {[lsearch -exact $list $element]>=0}}
 proc post msg {
    if [regexp {^/me (.+)} $msg -> action] {set msg "\001ACTION $action\001"}
    foreach line [split $msg \n] {send "PRIVMSG $::chan :<$::nick> $line"}
 }
 proc send str {puts $::fd $str; flush $::fd}
 proc answer {sock host2 port2} {
    fileevent $sock readable [list serve $sock]
 }
 proc encmap enc {string map {utf- UTF iso ISO-} $enc}
 proc serve sock {
     fconfigure $sock -blocking 0 -encoding $::encoding
     gets $sock line
     if {[fblocked $sock]} return
     fileevent $sock readable ""
    set args ""
     regexp {(/[^ ?]*)\??([^ ]*)?} $line -> tail args
     puts $sock "HTTP/1.0 200 OK"
     puts $sock "Content-Type: text/html;charset=$[encmap $::encoding]\n"
     puts $sock <html><head><title>webchain</title></head><body>
     array set a [concat {MSG "" NICK "" CNT 30} [kvsplit $args]]
     if {$a(MSG) ne ""} {
         lappend ::log $a(NICK) $a(MSG)
         set ::log [lrange $::log end-999 end]
         set ::nick $a(NICK)
         post $a(MSG)
     }
     foreach {nick post} [lrange $::log end-[expr {$a(CNT)*2-1}] end] {
         puts $sock "<b>$nick:</b> $post<br/>"
     }
     puts $sock "<hr/><form id='cpost' action='/_post' method='get'>
    <input id='cmsg' name='MSG' size='80' value='' /><br/>
    Nick: <input id='cnick' name='NICK' size='6' value='$a(NICK)' />
    Lines: <input id='ccnt' name='CNT' size='1' value='$a(CNT)' />
    <input type='submit' value='Go' /></form>"
     puts $sock </body></html>
     close $sock
 }
 proc kvsplit kv {
    set res ""
    foreach i [split $kv &] {
        foreach {k v} [split $i =] break
        lappend res $k [unescape $v]
    }
    set res
 }
 proc unescape str {
    regsub -all {%(..)} [string map {+ " "} $str] {\u00\1} str
    subst $str
 }

#-- connect to IRC...

 set ::fd [socket $::ircserver $::ircport]
 send "NICK $::ircnick"
 send "USER $::ircnick 0 * :Tcl user"
 send "JOIN $::chan"
 fileevent $::fd readable irc_recv
 socket -server answer $port
 puts "Server ready..."
 vwait forever

jdc I made some changes to the original scripts from RS:

  • Quoted special html characters
  • Set encoding of IRC channel to utf-8
  • Convert data posted by browser to utf-8
  • Added headers to pass W3C xhtml validation and to make the Nokia xhtml browser work
  • Added error when posting without specifying a nick name
  • Added logging
  • Added coloring of your own posts
  • Added favicon support (thanks stevel)
  • Added redirect after post (thanks stevel and validuser)
#!/usr/bin/env tclsh
# webchain.tcl - HTTP <-> IRC bridge
package require html

set encoding  iso8859-1 ;# utf-8
set nick      someone
set ircserver irc.freenode.org
set ircport   6667
set chan      #tcl
set ircnick   webchain
set log       {webchain Welcome.}

set webchainserver <host>
set webchainport   <port>

proc irc_recv {} {
    gets $::fd line
    string trim $line
    # handle PING messages from server
    if {[lindex [split $line] 0] eq "PING"} {
        send "PONG [info hostname] [lindex [split $line] 1]"; return
    }
    if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \
	     nick target msg]} {
	set tag ""
	if [regexp {\001ACTION(.+)\001} $msg -> msg] {set tag italic}
	if [in {azbridge ijchain} $nick] {
	    regexp {<([^>]+)>(.+)} $msg -> nick msg
	}
	if {$tag eq "italic"} {
            lappend ::log [::html::quoteFormValue $nick] <i>[::html::quoteFormValue $msg]</i>
        } else {
            lappend ::log [::html::quoteFormValue $nick] [::html::quoteFormValue $msg]
        }
    } else {lappend ::log - <i>[::html::quoteFormValue $line]</i>}
}
proc in {list element} {expr {[lsearch -exact $list $element]>=0}}
proc post msg { 
    if [regexp {^/me (.+)} $msg -> action] {
	foreach line [split $action \n] {send "PRIVMSG $::chan :* $::nick $line"}
    } else {
	foreach line [split $msg \n] {send "PRIVMSG $::chan :<$::nick> $line"}
    }
}
proc send str {
    puts $::fd $str; flush $::fd
}
proc answer {sock host2 port2} {
    fileevent $sock readable [list serve $sock $host2 $port2]
}
proc encmap enc {string map {utf- UTF iso ISO-} $enc}
proc serve {sock host2 port2} {
    fconfigure $sock -blocking 0 -encoding utf-8
    gets $sock line
    puts "[clock seconds] $sock $host2 $port2 $line"
    if {[fblocked $sock]} return
    fileevent $sock readable ""
    set args ""
    regexp {(/[^ ?]*)\??([^ ]*)?} $line -> tail args
    if {$tail eq "/favicon.ico"} {
	puts $sock "HTTP/1.0 200 OK"
	puts $sock "Content-Type: image/vnd.microsoft.icon"
	puts $sock "Content-Length: [file size favicon.ico]\n"
	fconfigure $sock -translation binary -buffering full	
	set file [open favicon.ico r]
	fconfigure $file -translation binary -blocking 1
	fcopy $file $sock -command [list done $file $sock]
    } else {
	array set a [concat {MSG "" NICK "" CNT 30} [kvsplit $args]]
	if {![string is integer -strict $a(CNT)]} { set a(CNT) 30 }
	set a(NICK) [string map {" " _} $a(NICK)]
	set enick [::html::quoteFormValue $a(NICK)]
	if {$tail eq "/_post" && $a(NICK) ne ""} {
	    puts $sock "HTTP/1.0 302 FOUND"
	    puts $sock "Location: http://$::webchainserver:$::webchainport/?NICK=$enick&CNT=$a(CNT)#end"
	} else {
	    puts $sock "HTTP/1.0 200 OK"
	}
	puts $sock "Content-Type: text/html;charset=UTF-8\n"
	puts $sock "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1.dtd\">"
	puts $sock "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang='en'  lang='en'><head><title>webchain</title>"
	puts $sock "<style type='text/css'>a.my_posts {color: blue;}</style>"
	puts $sock "</head><body>"
	if {$tail eq "/_post"} {
	    if {$a(NICK) ne ""} {
		set enick [::html::quoteFormValue $a(NICK)]
		if {$a(MSG) ne ""} {
		    if [regexp {^/me (.+)} $a(MSG) -> action] {
			lappend ::log $enick <i>[::html::quoteFormValue $action]</i>
		    } else {
			lappend ::log $enick [::html::quoteFormValue $a(MSG)]
		    }
		    set ::log [lrange $::log end-999 end]
		    set ::nick $a(NICK)
		    post $a(MSG)
		    set a(MSG) ""
		}
		puts $sock "If your browser doesn't automatically redirect, click <a href='http://$::webchainserver:$::webchainport/?NICK=[::html::quoteFormValue $a(NICK)]&CNT=$a(CNT)#end'>here</a>"
	    } else { 
		puts $sock "<p>You can not post without entering a nick name!</p>"
		puts $sock "<hr/><form id='cpost' action='/_post' method='get'>"
		puts $sock "<p><input id='cmsg' name='MSG' size='80' value='[::html::quoteFormValue $a(MSG)]' /></p>"
		puts $sock "<p>Nick: <input id='cnick' name='NICK' size='8' value='[::html::quoteFormValue $a(NICK)]' />"
		puts $sock "Lines: <input id='ccnt' name='CNT' size='2' value='$a(CNT)' />"
		puts $sock "<input type='submit' value='Go' /></p></form><a id='end'/>"
	    }
	} else {
	    foreach {nick post} [lrange $::log end-[expr {$a(CNT)*2-1}] end] {
		if {$nick eq $enick} { set style my_posts } else { set style other_posts }
		puts $sock "<a class='$style'><b>$nick:</b> $post</a><br/>"
	    }
	    puts $sock "<hr/><form id='cpost' action='/_post' method='get'>"
	    puts $sock "<p><input id='cmsg' name='MSG' size='80' value='' /></p>"
	    puts $sock "<p>Nick: <input id='cnick' name='NICK' size='8' value='[::html::quoteFormValue $a(NICK)]' />"
	    puts $sock "Lines: <input id='ccnt' name='CNT' size='2' value='$a(CNT)' />"
	    puts $sock "<input type='submit' value='Go' /></p></form><a id='end'/>"
	}
	puts $sock </body></html>
	close $sock
    }
}
proc done {inChan outChan args} {
    close $inChan
    close $outChan
}
proc kvsplit kv {
    set res ""
    foreach i [split $kv &] {
	foreach {k v} [split $i =] break
	lappend res $k [unescape $v]
    }
    set res
}
proc unescape str {
    set str [string map [list + { } "\\" "\\\\"] $str]
    regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str
    set str [subst -novariable -nocommand $str]
    set str [encoding convertfrom utf-8 $str]
    string trim $str
}
#-- connect to IRC...
set ::fd [socket $::ircserver $::ircport]
fconfigure $::fd -encoding utf-8
send "NICK $::ircnick"
send "USER $::ircnick 0 * :Tcl user"
send "JOIN $::chan"
fileevent $::fd readable irc_recv
#-- start server
socket -server answer $webchainport
puts "Server ready..."
vwait forever

RFox added flying pig logo. jdc sorry, lost that mod in my latest version :-(