#!/bin/sh
# the next line restarts using tclsh \
    exec tclsh "$0" "$@"

# Integrity check via md5sum postfixed to the message
# Auto reload of keyring if it changed since the last reload

set encrircHomePath [file dirname [info script]]
set auto_path [concat [list $encrircHomePath] $auto_path]

package require blowfish
package require md5 1.4.3

if {[catch {package require tls}]} {
    set ::havessl 1
} else {
    set ::havessl 0
}

################################################################################
# Message encryption
################################################################################

proc strSetSize {len str} {
    set str [string range $str 0 [expr {$len-1}]]
    set l [string length $str]
    return $str[string repeat " " [expr {$len-$l}]]
}

proc getBlowfishToken {key iv} {
    set key [binary format H* $key]
    set iv  [binary format H* $iv]
    if {![info exists ::bfTokens($key)]} {
	set ::bfTokens($key) [::blowfish::Init cbc $key $iv]
    } else {
	set $::bfTokens($key)\(I) $iv
	return $::bfTokens($key)
    }
}

proc encryptRawMessage {msg key iv} {
    set msg [strSetSize 80 $msg]
    set hmac [::md5::hmac $key $msg]

    set token [getBlowfishToken $key $iv]
    set c [::blowfish::Encrypt $token $msg$hmac]

    binary scan $c H* c
    return $c
}

proc decryptRawMessage {msg key iv} {
    set msg [binary format H* $msg]

    set token [getBlowfishToken $key $iv]
    set p [::blowfish::Decrypt $token $msg]
    set hmac [string range $p end-31 end]
    set p [string range $p 0 end-32]
    set hmac2 [::md5::hmac $key $p]
    if {$hmac ne $hmac2} {
	return "encrirc: Corrputed message received. Attack in act?"
    }
    return [string trim $p]
}

proc getRandIv {} {
    string range [md5::md5 [clock clicks]] 0 15
}

proc getKeyId key {
    string range [md5::md5 $key] 0 15
}

proc encryptMessage {msg key} {
    set iv [getRandIv]
    set keyid [getKeyId $key]
    return "$keyid|$iv|[encryptRawMessage $msg $key $iv]"
}

# Return an empty string on success, an error message on error.
proc decryptMessage {msg resvar} {
    upvar 1 $resvar res
    if {[llength [set splitted [split $msg |]]] != 3} {
	return "Bad message format."
    }
    foreach {keyid iv msg} $splitted break
    set key [getKeyFromId $keyid]
    if {$key eq {}} {
	return "No key with id '$keyid' found"
    }
    set res [decryptRawMessage $msg $key $iv]
    return {}
}

################################################################################
# Key scheduling
################################################################################

set ::keyring {}

proc addKey {key nicklist} {
    lappend ::keyring $key [getKeyId $key] $nicklist
    set key {0123456789ABCDEFF0E1D2C3B4A59687}
}

proc getKeyFromId keyid {
    foreach {key id nicklist} $::keyring {
	if {$id eq $keyid} {
	    return $key
	}
    }
    return {}
}

proc getKeyFromNick nick {
    foreach {key id nicklist} $::keyring {
	foreach n $nicklist {
	    if {[string match -nocase $n $nick]} {
		return $key
	    }
	}
    }
    return {}
}

proc loadKeyring filename {
    set fd [open $filename]
    set linenum 0
    set ::keyring {}
    while {[gets $fd line] != -1} {
	if {[string trim $line] eq {}} continue
	if {[string index $line 0] eq {#}} continue
	incr linenum
	set key [string range $line 0 31]
	set nicklist [string range $line 33 end]
	set nl {}
	foreach n [split $nicklist] {
	    if {$n eq {}} continue
	    lappend nl $n
	}
	if {[string length $key] != 32 || [llength $nl] == 0} {
	    errorMsg "Warning: invalid key in keyring at line $linenum"
	    continue
	}
	addKey $key $nl
	puts "Loaded key for $nicklist"
    }
}

proc loadKeyringLoop filename {
    if {[catch {
	if {![info exists ::keyringLastMtime]} {set ::keyringLastMtime 0}
	if {$::keyringLastMtime != [file mtime $filename]} {
	    set ::keyringLastMtime [file mtime $filename]
	    loadKeyring $filename
	    ircMsg "Keyring reloaded (modification time changed)"
	}
    } errmsg]} \
    {
	errorMsg "Error while reloading the keyring: $errmsg"
	errorMsg "Nex retry in 15 seconds."
	catch {unset ::keyringLastMtime}
    }
    after 15000 [list loadKeyringLoop $filename]
}

################################################################################
# I/O
################################################################################

set ::clientfd {}
set ::serverfd {}
set ::ircserver {}
set ::ircport {}
set ::ircssl {}
set ::proxyport 8000
set ::sslserver 0

proc errorMsg msg {
    puts $msg
    ircMsg $msg
}

proc ircMsg {msg {fd {}}} {
    if {$fd eq {}} {
	set fd $::clientfd
    }
    if {$::clientfd ne {}} {
	catch {
	    puts $fd ":encrirc NOTICE AUTH :$msg"
	    flush $fd
	}
    }
}

proc proxyInit {} {
    socket -server proxyAccept $::proxyport
}

proc proxyCleanup {} {
    catch {
	close $::clientfd
	close $::serverfd
    }
    set ::clientfd {}
    set ::serverfd {}
}

proc proxyAccept {fd host port} {
    if {$::clientfd ne {}} {
	ircMsg "Sorry, the proxy is already busy with another connection"
	close $fd
	return
    }
    set ::clientfd $fd
    ircMsg "Welcome to encrirc, connecting to $::ircserver port $::ircport"
    if {[catch {
	if {[string range $::ircport end-3 end] eq {/ssl}} {
	    set ::sslserver 1
	    set port [string range $::ircport 0 end-4]
	    set ::serverfd [tls::socket $::ircserver $port]
	    fconfigure $::serverfd -translation crlf
	} else {
	    set ::sslserver 0
	    set ::serverfd [socket $::ircserver $::ircport]
	}
    } errmsg]} {
	ircMsg "I/O error conneting to the server: $errmsg"
	proxyCleanup
    }
    fileevent $::clientfd readable [list clientReadableHandler $::clientfd]
    fileevent $::serverfd readable [list serverReadableHandler $::serverfd]
    ircMsg "Connected."
}

proc clientReadableHandler fd {
    if {[eof $fd] || [catch {gets $fd line}]} {
	proxyCleanup
	return
    }
    if {[catch {
	puts "client->server $line"
	if {[regexp -nocase {^PRIVMSG +([\?#][^ ]+) +:{0,1}(.*)} $line -> \
	    target msg]} \
	{
	    if {[string index $target 0] eq {?}} {
		set target [string range $target 1 end]
		set ischannel 0
	    } else {
		set ischannel 1
	    }
	    set key [getKeyFromNick $target]
	    if {$ischannel && $key ne {} && \
	        [string range $msg 0 9] eq {plaintext:}} \
	    {
	    	set line "PRIVMSG $target :[string range $msg 10 end]"
	    } elseif {!($key eq {} && $ischannel)} {
		    if {$key eq {}} {
			ircMsg "No such key for nick '$target'"
			return
		    }
		    set msg ">encrirc<[encryptMessage $msg $key]"
		    set line "PRIVMSG $target :$msg"
	    }
	}
	puts $::serverfd $line
	flush $::serverfd
    } err]} {
	puts stderr "*** client I/O error: $err"
    }
}

proc serverReadableHandler fd {
    if {[eof $fd] || [catch {gets $fd line}]} {
	proxyCleanup
	return
    }
    if {[catch {
	puts "server->client $line"
	if {[regexp -nocase {^:([^ !]+)(![^ @]+@[^ ]+ +PRIVMSG +[^ ]+) +:{0,1}>encrirc<(.*)} $line -> srcnick prefix encr]} \
	{
	    set err [decryptMessage $encr p]
	    if {$err eq {}} {
		set line ":?$srcnick$prefix :E| $p"
	    } else {
		ircMsg "No matching key found for the above message."
	    }
	}
	puts $::clientfd $line
	flush $::clientfd
    } err]} {
	puts stderr "*** server I/O error: $err"
    }
}

################################################################################
# Key generation
################################################################################

proc getRandomKey {} {
    set len 16
    set fd [open /dev/urandom]
    set r [read $fd $len]
    binary scan $r "H*" retval
    return $retval
}

proc genKey nicklist {
    puts "Please move your mouse if the key generation is slow..."
    set key [getRandomKey]
    puts {}
    puts "The new keyring entry is:\n"
    puts "$key [join $nicklist]\n"
    puts "Cut&Paste it in your keyring."
    puts "Remember to send it to the IRC user you want to talk via PGP or GPG"
}

################################################################################
# Main
################################################################################

set badarity 0
if {[lindex $argv 0] eq {genkey}} {
    if {[llength $argv] < 2} {
	set badarity 1
    }
} else {
    if {[llength $argv] != 4} {
	set badarity 1
    }
}

if {$badarity} {
    puts "--- How to start the encrirc proxy ---"
    puts "Usage: encrirc <localport> <server> <port\[/ssl\]> <keyring file>"
    puts "Example: encrirc 8000 irc.freenode.org 6667 /home/antirez/.encrirc/keys"
    puts "Example: encrirc 8000 irc.azzurra.org 9999/ssl /tmp/keys"
    puts ""
    puts "In both the examples, connect with your irc client to 127.0.0.1 8000"
    puts "with something like: /server 127.0.0.1 8000"
    puts ""
    puts "--- How to generate new keys ---"
    puts "Usage: encrirc genkey <nick1> \[nick2\] ... \[nickN\]"
    puts "Example: encrirc genkey antirez antirez_ antiz"
    puts ""
    exit
}

# Key generation?
if {[lindex $argv 0] eq {genkey}} {
    genKey [lrange $argv 1 end]
    exit
}

foreach {::proxyport ::ircserver ::ircport ::keyring} $argv break

loadKeyringLoop $::keyring
proxyInit
vwait forever
