webchain
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)
- Added URL detection (copied from WubWikit)
- Added emoticons (copied from tkchat), you'll need to download the emoticons as used by tkchat and stored them in the same directory as this script.
- Made number of posts in cache configurable
- Optimised for small screen devices
To enable the URL detection and emoticons, check the checkbox next to the number of lines entry. On some mobile browsers (e.g. opera mini), you may need to disable the 'mobile view' to be able to see the emoticons.
#!/usr/bin/env tclsh
# webchain.tcl - HTTP <-> IRC bridge
catch {console show}
lappend auto_path /target/staff/decoster/activetcl/8.4.11.2/lib
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 <server>
set webchainport <port>
set webchainnposts 1000
#Taken from tclers.tk/~jabber/emoticons/emoticons.tcl and tkchat
proc SmileId { name n triggers } {
foreach arg $triggers {
set ::IMG($arg) $name
if { [string is alnum -strict -failindex i $arg] } {
lappend ids "\1$arg\2"
} elseif { [string is alnum -strict [string index $arg end]] } {
if {$i > 0} {
lappend ids "\1$arg\2"
} else {
lappend ids "\3$arg\2"
}
} else {
if {$i > 0} {
lappend ids "\1$arg"
} else {
lappend ids "\3$arg"
}
}
}
set ids [join $ids "\0"]
set map [list \
| \\| ( \\( ) \\) \[ \\\[ \
- \\- . \\. * \\* ? \\? \
\\ \\\\ ^ \\^ $ \\$ \1 \\m \
\2 \\M \3 \\Y \0 | \
]
# If we ever change this to use () capturing, change tkchat::Insert too.
if { [info exists ::IMGre] } {
append ::IMGre |[string map $map $ids]
} else {
set ::IMGre [string map $map $ids]
}
}
SmileId cry 1 {":-(" ":^(" ":("}
SmileId grrr 1 {"8-(" "8^(" "8(" "8-|" "8^|" "8|"}
SmileId LOL-anim 1 {LOL lol}
SmileId mad 1 {">:(" ">:-(" ">:^("}
SmileId oh 1 {":-o" ":^o" ":o" ":-O" ":^O" ":O"}
SmileId smile 1 {":-)" ":^)" ":)"}
SmileId smile-big 1 {":-D" ":^D" ":D"}
SmileId smile-dork 1 {"<:-)" "<:^)" "<:)"}
SmileId smile-glasses 1 {"8-)" "8^)" "8)"}
SmileId smile-tongue-anim 1 {":-p" ":^p" ":p"}
SmileId smirk-glasses 1 {";/" ";-/" ";^/" ":/" ":-/" ":^/" "8/" "8-/" "8^/"}
SmileId tongue2 1 {":-P" ":^P" ":P"}
SmileId updown 1 {"(:" "(^:" "(-:"}
SmileId wink-anim 1 {";-)" ";^)" ";)"}
SmileId blush 1 {":-\}" ":^\}" ":8\}" ":\}"}
SmileId coffee 1 LP
SmileId lunch 1 {|O| |o| |0|}
SmileId snooze 1 {zz zzz zzZ zZZ ZZZ ZZ}
SmileId beer 1 "|_P"
SmileId cyclops 1 {"O-\]" "O-)" "0-\]" "0-)"}
SmileId donuts 1 "donuts"
SmileId bug 1 {"bug #" "bug#"}
SmileId wave 2 {~~~ waves}
SmileId phone 3 {"on the phone"}
SmileId yawn 3 {yawn yawns}
SmileId applause 2 {applause applauds}
set content_type(.ico) image/vnd.microsoft.icon
set content_type(.gif) imagegif
proc make_href {url} {
return "<a href='[::html::quoteFormValue $url]'>[::html::quoteFormValue $url]</a>"
}
proc make_iref {emo} {
return "<img src='/$::IMG($emo).gif' alt='[::html::quoteFormValue $emo]'>"
}
proc sfrmt {msg} {
set i 0
set n 0
set hmsg ""
foreach match [regexp -inline -all -indices -- $::IMGre $msg] {
lassign $match start end
set emo [string range $msg $start $end]
append hmsg [string range $msg $i [expr {$start-1}]]
append hmsg [make_iref $emo]
set i [expr {$end+1}]
}
if { $i <= [string length $msg] } {
append hmsg [string range $msg $i end]
}
return $hmsg
}
proc hfrmt {msg} {
set i 0
set n 0
set hmsg ""
foreach match [regexp -inline -all -indices -- {(https?|ftp|news|mailto|file):([^\s:]\S*[^\]\)\s\.,!\?;:'>"])} $msg] { ;# keep emacs happy "])
if { $n % 3 == 0 } {
lassign $match start end
set url [string range $msg $start $end]
append hmsg [sfrmt [string range $msg $i [expr {$start-1}]]]
append hmsg [make_href $url]
set i [expr {$end+1}]
}
incr n
}
if { $i <= [string length $msg] } {
append hmsg [sfrmt [string range $msg $i end]]
}
return $hmsg
}
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
} elseif [regexp {\001(VERSION)\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> <i>[hfrmt $msg]</i>
} else {
lappend ::log [::html::quoteFormValue $nick] [::html::quoteFormValue $msg] [hfrmt $msg]
}
} else {
lappend ::log - <i>[::html::quoteFormValue $line]</i> <i>[hfrmt $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 { [string match "/*.gif" $tail] || [string match "/*.ico" $tail] } {
set fnm [string range $tail 1 end]
if {[catch {set fileChannel [open $fnm RDONLY] } ]} {
puts $sock "HTTP/1.0 404 Not found\n"
puts $sock "<html><head><title><No such URL.></title></head>"
puts $sock "<body><center>"
puts $sock "The URL you requested does not exist on this site."
puts $sock "</center></body></html>"
close $sock
} else {
fconfigure $fileChannel -translation binary
fconfigure $sock -translation binary -buffering full
puts $sock "HTTP/1.0 200 OK"
puts $sock "Content-Type: image/$::content_type([file extension $fnm])"
puts $sock "Content-Length: [file size $fnm]\n"
fcopy $fileChannel $sock -command [list done $fileChannel $sock]
}
} else {
array set a [concat {MSG "" NICK "" CNT 30 GR 0} [kvsplit $args]]
if {![string is integer -strict $a(CNT)]} { set a(CNT) 30 }
if {![string is integer -strict $a(GR)]} { set a(GR) 0 }
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)&GR=$a(GR)#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'>p.my_posts {color: blue; margin: 0;} p.other_posts {margin: 0;}</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> <i>[hfrmt $action]</i>
} else {
lappend ::log $enick [::html::quoteFormValue $a(MSG)] [hfrmt $a(MSG)]
}
set ::log [lrange $::log end-[expr {$::webchainnposts*3-1}] 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)&GR=$a(GR)#end'>here</a>"
} else {
puts $sock "<p>You can not post without entering a nick name!</p>"
hform $sock a
}
} else {
foreach {nick post hpost} [lrange $::log end-[expr {$a(CNT)*3-1}] end] {
if {$nick eq $enick} { set style my_posts } else { set style other_posts }
if { $a(GR) } {
puts $sock "<p class='$style'><b>$nick:</b> $hpost</p>"
} else {
puts $sock "<p class='$style'><b>$nick:</b> $post</p>"
}
}
set a(MSG) ""
hform $sock a
}
puts $sock </body></html>
close $sock
}
}
proc hform { sock anm } {
upvar $anm a
puts $sock "<hr/><form id='cpost' action='/_post' method='get'>"
puts $sock "<p><input id='cmsg' name='MSG' size='128' value='[::html::quoteFormValue $a(MSG)]' /></p>"
puts $sock "<p>Nick <input id='cnick' name='NICK' size='6' value='[::html::quoteFormValue $a(NICK)]' />"
puts $sock "Lines <input id='ccnt' name='CNT' size='2' value='$a(CNT)' />"
puts $sock "<input type='checkbox' id='cgr' name='GR' value='1' [lindex {{} {checked='checked'}} $a(GR)]/>"
puts $sock "<input type='submit' value='Go' /></p></form><p><a id='end'></a></p>"
}
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
socket -server answer $webchainport
puts "Server ready..."
vwait foreverRFox added flying pig logo. jdc sorry, lost that mod in my latest version :-(
jdc 29-jan-2008 Starting from the version above, I made wubchain.
Wubchain is a webchat powered by Wub and tclxmppd .
The code can be found here .
jdc 25-feb-2008 A wubchain screenshot taken by RS on his phone running PocketIE:
jdc 2-oct-2008 A screenshot wubchain in Google Chrome:
jdc 9-sep-2009 A screenshot from an Android phone make by Pat Thoyts:
9-sep-2009 A screenshot from a BlackBerry Tour, taken by Gerry Snyder:
LV I had problems with wubchain today. I am using, unfortunately, Windows NT SP 3 (I think), and I.E. 7. I was able to log into wubchain. It insisted on scrolling all the history off the top of the screen, leaving me only the input line. But I could live with that. Unfortunately, posting to wubchain did not display on my screen unless I logged off and back on again. This wasn't immediately obvious, and I thought wubchain was just terribly slow. But after 5 minutes of attending refresh, etc. I finally tried logging off and back on and there were my messages, along with a response.
It's a shame it doesn't work better, because it is the only access I have to the tcl chat area.
jdc 10-sep-2009 Larry, are you still seeing this problem?
jdc 7-aug-2012: Wubchain no longer running, I stopped the server due to limited number of users.