# small 9p implementation in tcl by Axel.Belinfante@cs.utwente.nl

# it needs tclDES from http://tcldes.sourceforge.net/
# I have used version 0.8 with good success

# this is based on the python 9P implementation by Tim Newsham.
# http://lava.net/~newsham/plan9/

package require tclDES

namespace eval p9sk1 {
	variable TickReqLen 141
	variable TickLen 72
	variable AuthLen 13

	variable AuthTreq 1
	variable AuthChal 2
	variable AuthPass 3
	variable AuthOK 4
	variable AuthErr 5 
	variable AuthMod 6 

	variable AuthTs 64
	variable AuthTc 65 
	variable AuthAs 66
	variable AuthAc 67
	variable AuthTp 68
	variable AuthHr 69

	variable AUTHPORT 567

	variable _par [list \
	0x01 0x02 0x04 0x07 0x08 0x0b 0x0d 0x0e \
	0x10 0x13 0x15 0x16 0x19 0x1a 0x1c 0x1f \
	0x20 0x23 0x25 0x26 0x29 0x2a 0x2c 0x2f \
	0x31 0x32 0x34 0x37 0x38 0x3b 0x3d 0x3e \
	0x40 0x43 0x45 0x46 0x49 0x4a 0x4c 0x4f \
	0x51 0x52 0x54 0x57 0x58 0x5b 0x5d 0x5e \
	0x61 0x62 0x64 0x67 0x68 0x6b 0x6d 0x6e \
	0x70 0x73 0x75 0x76 0x79 0x7a 0x7c 0x7f \
	0x80 0x83 0x85 0x86 0x89 0x8a 0x8c 0x8f \
	0x91 0x92 0x94 0x97 0x98 0x9b 0x9d 0x9e \
	0xa1 0xa2 0xa4 0xa7 0xa8 0xab 0xad 0xae \
	0xb0 0xb3 0xb5 0xb6 0xb9 0xba 0xbc 0xbf \
	0xc1 0xc2 0xc4 0xc7 0xc8 0xcb 0xcd 0xce \
	0xd0 0xd3 0xd5 0xd6 0xd9 0xda 0xdc 0xdf \
	0xe0 0xe3 0xe5 0xe6 0xe9 0xea 0xec 0xef \
	0xf1 0xf2 0xf4 0xf7 0xf8 0xfb 0xfd 0xfe \
	]

}
proc p9sk1::pad {str l {padch {}}} {
	set n [expr $l - [string length $str]]
	set s $str
	if {$padch == {}} {
		set padch [binary format x]
	}
	append s [string repeat $padch $n]
	return $s
} 



# Expand a 7-byte DES key into an 8-byte DES key
proc p9sk1::expandKey {key} {
	variable _par

	binary scan $key c* tbuf
	set k {}
	foreach x $tbuf {
		lappend k [expr $x & 0xff]
	}
	lappend k64 [expr  [lindex $k 0] >> 1]
	lappend k64 [expr ([lindex $k 1] >> 2) | ([lindex $k 0] << 6)]
	lappend k64 [expr ([lindex $k 2] >> 3) | ([lindex $k 1] << 5)]
	lappend k64 [expr ([lindex $k 3] >> 4) | ([lindex $k 2] << 4)]
	lappend k64 [expr ([lindex $k 4] >> 5) | ([lindex $k 3] << 3)]
	lappend k64 [expr ([lindex $k 5] >> 6) | ([lindex $k 4] << 2)]
	lappend k64 [expr ([lindex $k 6] >> 7) | ([lindex $k 5] << 1)]
	lappend k64 [expr  [lindex $k 6] << 0]
	foreach x $k64 {
		lappend r [lindex $_par [expr $x & 0x7f]]
	}
	return [binary format c* $r]
}
proc p9sk1::newKey {key} {
	set e [expandKey $key]
	return [::des::keyset create $e]
}
proc p9sk1::encrypt {key msg} {
	set r [::des::encrypt $key $msg]
	return $r
}
proc p9sk1::decrypt {key msg} {
	set r [::des::decrypt $key $msg]
	return $r
}
proc p9sk1::makeKey {password} {
	set password [string range $password 0 26]
	append password [binary format x]
	set n [expr [string length $password] - 1]
	set password [p9sk1::pad $password 28 { }]
	set buf $password
	while {1} {
		set ts [string range $buf 0 7]
		binary scan $ts c* tl
		set t {}
		foreach x $tl {
			lappend t [expr $x & 0xff]
		}
		set i 0
		set k {}
		while {$i < 7} {
			lappend k [expr ([lindex $t $i] >> $i) + ([lindex $t [expr $i + 1]] << (8-($i + 1))) & 0xff]
			incr i
		}
		set key [binary format c* $k]
		if {$n <= 8} {
			return $key
		}
		incr n -8
		if {$n < 8} {
			set buf [string range $buf $n end]
		} else {
			set buf [string range $buf 8 end]
		}
		set buf [string replace $buf 0 7 [::p9sk1::encrypt [newKey $key] [string range $buf 0 7]]]
	}
}

# XXX This is *NOT* a secure way to generate random strings!
# This should be fixed if this code is ever used in a serious manner.
proc p9sk1::randChars {n} {
	set i 0
	while {$i < $n} {
		lappend r [expr int(rand()*255)]
		incr i
	}
	return [binary format c* $r]
}

namespace eval 9p::marshal {
#	upvar #0 C_[set self](ks) ks
#	upvar #0 C_[set self](kn) kn

#	set ks None
#	set kn None
}

proc 9p::marshal::setKs {self k} {
	upvar #0 C_[set self](ks) ks

	set ks [::p9sk1::newKey $k]
}
proc 9p::marshal::setKn {self k} {
	upvar #0 C_[set self](kn) kn

	set kn [::p9sk1::newKey $k]
}
proc 9p::marshal::encrypt {self n key} {
	set idx [expr [lenBuf $self] - $n]
	incr n -1
	set dummy 0
	while {$dummy < [expr $n / 7]} {
		set end  [expr $idx + 8 -1]
		replaceBuf $self $idx $end [::p9sk1::encrypt $key [rangeBuf $self $idx $end]]
		incr idx 7
		incr dummy
	}
	if {$n % 7} {
		set end  [expr [lenBuf $self] - 1]
		set start  [expr $end - 8 + 1]
		replaceBuf $self $start $end [::p9sk1::encrypt $key [rangeBuf $self $start $end]]
	}
}
proc 9p::marshal::decrypt {self n key} {
	upvar #0 C_[set self](kn) kn

	if {[string compare $key None] == 0} {
		return
	}

	set m [expr $n -1 ]
	if {$m % 7} {
		set start [expr $n - 8]
		set end  [expr $n - 1]
		replaceBuf $self $start $end [::p9sk1::decrypt $key [rangeBuf $self $start $end]]
	}
	set idx [expr $m - ($m % 7)]
	set dummy 0
	while {$dummy < [expr $m / 7]} {
		incr idx -7
		set end  [expr $idx + 8 - 1]
		replaceBuf $self $idx $end [::p9sk1::decrypt $key [rangeBuf $self $idx $end]]
		incr dummy
	}
}
proc 9p::marshal::encPad {self x l} {
	encX $self [::p9sk1::pad  $x $l]
}
proc 9p::marshal::decPad {self l} {
	set x [decX $self $l]
	set z [binary format x]
	set idx [string first $z $x]
	if {$idx >= 0} {
		set x [string range $x 0 [expr $idx - 1]]
	}
	return $x
}
proc 9p::marshal::encChal {self x} {
	checkLen $x 8
	encX $self $x
}
proc 9p::marshal::decChal {self} {
	set r [decX $self 8]
	return $r
}
proc 9p::marshal::encTicketReq {self x} {
	enc1 $self [lindex $x 0]		;# type
	encPad $self [lindex $x 1] 28	;# authid
	encPad $self [lindex $x 2] 48	;# authdom
	encChal $self [lindex $x 3]		;# chal
	encPad $self [lindex $x 4] 28	;# hostid
	encPad $self [lindex $x 5] 28	;# uid
}
proc 9p::marshal::decTicketReq {self} {
	set r [list \
		[dec1 $self]	\
		[decPad $self 28] \
		[decPad $self 48] \
		[decChal $self] \
		[decPad $self 28] \
		[decPad $self 28] \
	]
	return $r
}
proc 9p::marshal::encTicket {self x} {
	upvar #0 C_[set self](ks) ks

	set num [lindex $x 0]
	set chal [lindex $x 1]
	set cuid [lindex $x 2]
	set suid [lindex $x 3]
	set key [lindex $x 4]

	checkLen $key 7

	enc1 $self $num
	encChal $self $chal
	encPad $self $cuid 28
	encPad $self $suid 28
	encX $sel $key

	encrypt $self [expr 1 + 8 + 28 + 28 + 7] $ks
}
proc 9p::marshal::decTicket {self} {
	upvar #0 C_[set self](ks) ks

	decrypt $self [expr 1 + 8 + 28 + 28 + 7] $ks
	set r [list \
		[dec1 $self]	\
		[decChal $self] \
		[decPad $self 28] \
		[decPad $self 28] \
		[decX $self 7] \
	]
	return $r
}
proc 9p::marshal::encAuth {self x} {
	upvar #0 C_[set self](kn) kn

	set num [lindex $x 0]
	set chal [lindex $x 1]
	set id [lindex $x 2]
	enc1 $self $num
	encChal $self $chal
	enc4 $self $id
	encrypt $self [expr 1 + 8 + 4] $kn
}
proc 9p::marshal::decAuth {self} {
	upvar #0 C_[set self](kn) kn

	decrypt $self [expr 1 + 8 + 4] $kn
	set r [list \
		[dec1 $self]	\
		[decChal $self] \
		[dec4 $self] \
	]
	return $r
}
proc 9p::marshal::encTattach {self x} {
	set tick [lindex $x 0]
	set auth [lindex $x 1]
	checkLen $tick 72
	encX $self $tick
	encAuth $self $auth
}
proc 9p::marshal::decTattach {self} {
	set r [list \
		[decX $self 72] \
		[decAuth $self] \
	]
	return $r
}

#	Connect to the auth server and request a set of tickets.
#	Con is an open handle to the auth server, sk1 is a handle
#	to a P9sk1 marshaller with Kc set and treq is a ticket request.
#	Return the (opaque) server ticket and the (decoded) client ticket.
proc p9sk1::getTicket {con sk1 treq} {
	variable AuthOK
	variable AuthErr

	::9p::marshal::setBuf $sk1 ""
	::9p::marshal::encTicketReq $sk1 $treq
	set x [::9p::marshal::getBuf $sk1]
	::9p::marshal::swrite $con $x
	set ch [::9p::marshal::sread $con 1]
	if {$ch == [binary format c $AuthErr]} {
		set err [::9p::marshal::sread $con 64]
		error "AuthsrvError $err"
	} elseif  {$ch != [binary format c $AuthOK]} {
		error "AuthsrvError invalid reply type [::9p::_dump $ch]"
	}
	set ctick [::9p::marshal::sread $con 72]
	set stick [::9p::marshal::sread $con 72]
	if {[expr [string length $ctick] + [string length $stick]] != [expr 2*72]} {
		error "AuthsrvError short auth reply"
	}
	::9p::marshal::setBuf $sk1 $ctick
	set ctl [::9p::marshal::decTicket $sk1]
	set r [list $ctl $stick]
	return $r
}

#	Authenticate ourselves to the server.
#	Cl is a P9 RpcClient, afid is the fid to use, user is the
#	user name, Kc is the user's key, authsrv and authport specify
#	the auth server to use for requesting tickets.
#
#	XXX perhaps better if the auth server can be prompted for
#	based on the domain in the negotiation.
proc p9sk1::clientAuth {cl afid user Kc authsrv {authport 567}} {
	variable TickReqLen
	variable AuthLen
	variable AuthTreq
	variable AuthTc
	variable AuthAc
	variable AuthAs

	set CHc [randChars 8]
	set sk1 aapje
	::9p::marshal::setKs $sk1 $Kc
	::9p::afidopen $cl $afid
	set gen 0

	# negotiate
	set proto [::9p::read $cl $afid 128]
	set v2 0
	if {[string compare [string range $proto 0 9] {v.2 p9sk1@}] == 0} {
		set v2 1
		set proto [string range $proto 4 end]
	}
	if {[string compare [string range $proto 0 5] {p9sk1@}] != 0} {
		error "AuthError unknown protocol $proto"
	}
	set idx [string first @ $proto]
	::9p::write $cl $afid [string replace $proto $idx $idx { }]
	if {$v2} {
		set ok [::9p::read $cl $afid 3]
		if {[string compare $ok OK[binary format x]] != 0} {
			error "AuthError v.2 protocol botch"
		}
	}
	
	# Tsession
	::9p::marshal::setBuf $sk1 ""
	::9p::marshal::encChal $sk1 $CHc
	::9p::write $cl $afid [::9p::marshal::getBuf $sk1]

	# Rsession
	::9p::marshal::setBuf $sk1 [::9p::read $cl $afid $TickReqLen]
	set treq [::9p::marshal::decTicketReq $sk1]
	if {$v2 && [lindex $treq 0] == 0} {
		# kenfs is fast and loose with auth formats
		set treq [lreplace $treq 0 0 $AuthTreq]
	}
	if {[lindex $treq 0] != $AuthTreq} {
		error "AuthError bad server"
	}
	set CHs [lindex $treq 3]

	# request ticket from authsrv
	set treq [lreplace $treq end-1 end $user $user]
	puts stderr "connecting to tcp!$authsrv!$authport"
	set asock [socket $authsrv $authport]
	fconfigure $asock -translation binary

	set ticket [getTicket $asock $sk1 $treq] ;# XXX catch
	set ctick [lindex $ticket 0]
	set stick [lindex $ticket 1]
	set num [lindex $ctick 0]
	set CHs2 [lindex $ctick 1]
	set cuid [lindex $ctick 2]
	set suid [lindex $ctick 3]
	set Kn [lindex $ctick 4]
	close $asock
	if {$num != $AuthTc || $CHs != $CHs2} {
		error "AuthError bad password for $user or bad auth server"
	} elseif {$num != $AuthTc} {
		error "AuthError bad password for $user"
	} elseif {$CHs != $CHs2} {
		error "bad auth server"
	}
	::9p::marshal::setKn $sk1 $Kn

	# Tattach
	::9p::marshal::setBuf $sk1 ""
	::9p::marshal::encTattach $sk1 [list $stick [list $AuthAc $CHs $gen]]
	set b [::9p::marshal::getBuf $sk1]
	::9p::write $cl $afid $b
	
	set a [::9p::read $cl $afid $AuthLen]
	::9p::marshal::setBuf $sk1 $a
	set r [::9p::marshal::decAuth $sk1]
	set num [lindex $r 0]
	set CHc2 [lindex $r 1]
	set gen2 [lindex $r 2]
	if {$num != $AuthAs || $CHc2 != $CHc} {
		# XXX check gen2 for replay
		error "AuthError bad server"
	}
	
	return
}