#  saslmd5.tcl --
#  
#       This package provides a rudimentary implementation of the client side
#       SASL authentication method using the DIGEST-MD5 mechanism.
#       SASL [RFC 2222]
#       DIGEST-MD5 [RFC 2831]
#       
#  Copyright (c) 2004  Mats Bengtsson
#  
# $Id$

package require base64
package require md5 2.0

package provide saslmd5 1.0


namespace eval saslmd5 {
    
    variable mechanisms "DIGEST-MD5"
    variable needed {user authzid pass realm}
    variable uid 0
    
    set seed [expr {abs([pid]+[clock clicks]%100000)}]
    expr {srand(int($seed))}
}

# "static" methods.

proc saslmd5::mechanisms {} {
    variable mechanisms   
    return $mechanisms
}

proc saslmd5::client_init {args} {
    
    # empty
}

proc saslmd5::decode64 {str} {
    return [::base64::decode $str]
}

proc saslmd5::encode64 {str} {
    return [::base64::encode $str]
}

# create a new instance for a session.

proc saslmd5::client_new {args} {    
    variable uid
    
    puts "saslmd5::client_new"
    set token [namespace current]::[incr uid]
    variable $token
    upvar 0 $token state

    set state(step)       0
    set state(service)    ""
    set state(serverFQDN) ""
    set state(flags)      {}
    
    foreach {key value} $args {
	switch -- $key {
	    -callbacks {
		set_callbacks $token $value
	    }
	    -service - -serverFQDN - -flags {
		set state([string trimleft $key -]) $value
	    }
	    default {
		return -code error "unrocognized option \"$key\""
	    }
	}
    }
    
    proc $token {cmd args}   \
      "eval [namespace current]::cmdproc {$token} \$cmd \$args"

    return $token
}

proc saslmd5::cmdproc {token cmd args} {

    # Which command? Just dispatch the command to the right procedure.
    return [eval {method_$cmd $token} $args]
}

# class methods.

proc saslmd5::method_start {token args} {
    variable $token
    upvar 0 $token state
    variable mechanisms
    
    puts "saslmd5::method_start $args"
    set state(step) 0
    
    foreach {key value} $args {
	switch -- $key {
	    -mechanisms {
		set state(inmechanisms) $value
	    }
	    default {
		# empty
	    }
	}
    }
    if {![info exists state(inmechanisms)]} {
	return -code error "missing a \"-mechanisms\" option"
    }

    # we must have at least on of the servers announced mechanisms
    set match 0
    foreach m $mechanisms {
	if {[set idx [lsearch -exact $state(inmechanisms) $m]] >= 0} {
	    set match 1
	    set mechanism [lindex $state(inmechanisms) $idx]
	    break
	}
    }
    if {!$match} {
	return -code error "the servers mechanisms \"$state(inmechanisms)\"\
	  do not match any of the supported mechanisms \"$mechanisms\""
    }
    set state(step) 1
    
    # continue
    return [list 4 [list mechanism $mechanism output ""]]
}

proc saslmd5::method_step {token args} {
    variable $token
    upvar 0 $token state
    
    puts "saslmd5::method_step $token, $args"
    foreach {key value} $args {
	switch -- $key {
	    -input {
		set challenge $value
	    }
	}
    }
    if {![info exists challenge]} {
	return -code error "must have -input challenge string"
    }
    
    if {$state(step) == 0} {
	return -code error "need to call the 'start' procedure first"
    } elseif {$state(step) == 1} {
	if {![iscapable $token]} {	
	    return -code error "missing one or more callbacks"
	}
	array set challarr [parse_challenge $challenge]
	if {![info exists challarr(nonce)]} {
	    return -code error "challenge missing 'nonce' attribute"
	}
	if {![info exists challarr(algorithm)]} {
	    return -code error "challenge missing 'algorithm' attribute"
	}
	request_userpars $token
	set output [process_challenge $token [array get challarr]]
	incr state(step)
	
	# continue
	set code 4
    } else {
	incr state(step)
	
	# success
	set output ""
	set code 0
    }    
    return [list $code $output]
}

proc saslmd5::method_setprop {token property value} {
    variable $token
    upvar 0 $token state

    # empty
}

proc saslmd5::method_getprop {token property} {
    variable $token
    upvar 0 $token state

    # empty
    return ""
}

proc saslmd5::method_info {args} {
    
    # empty
    return {}
}

proc saslmd5::set_callbacks {token cblist} {
    variable $token
    upvar 0 $token state
    
    puts "saslmd5::set_callbacks cblist=$cblist"
    
    # some of tclsasl's id's are different from the spec's!
    foreach cbpair $cblist {
	foreach {id cbproc} $cbpair {
	    set key $id
	    if {$id == "authname"} {
		set key "authzid"
	    } elseif {$id == "getrealm"} {
		set key "realm"
	    }
	    set state(cb,$key) $cbproc
	}
    }
}

proc saslmd5::iscapable {token} {
    variable $token
    upvar 0 $token state
    variable needed

    puts "saslmd5::iscapable"
    set capable 1
    foreach id $needed {
	if {[info exists state(cb,$id)] && ($state(cb,$id) != {})} {
	    # empty
	} else {
	    set capable 0
	    break
	}
    }
    puts "\t capable=$capable"
    return $capable
}

proc saslmd5::request_userpars {token} {
    variable $token
    upvar 0 $token state
    variable needed

    foreach id $needed {
	if {[info exists state(cb,$id)] && ($state(cb,$id) != {})} {
	    set plist [list id $id]
	    set state(upar,$id) [uplevel #0 $state(cb,$id) [list $plist]]
	} else {
	    return -code error "missing one or more callbacks"
	}
    }
}

proc saslmd5::process_challenge {token challenge} {
    variable $token
    upvar 0 $token state
    
    array set charr $challenge
    
    # users parameters
    set user  $state(upar,user)
    set authz $state(upar,authzid)
    set pass  $state(upar,pass)
    set realm $state(upar,realm)
    
    set host    $state(serverFQDN)
    set service $state(service)
    
    # make a 'cnonce'
    set bytes ""
    for {set n 0} {$n < 32} {incr n} {
	set r [expr {int(256*rand())}]
	append bytes [binary format c $r]
    }
    set cnonce [encode64 $bytes]
    
    # other
    set realm   $host
    set nonce   $charr(nonce)
    set nc      "00000001"
    set diguri  $service/$host
    set qop     "auth"
    
    # test
    if {0} {
	# sasl_mac-ok
	set user    "marilu"
	set realm   "l4l.be"
	set authz   "marilu@l4l.be"
	set pass    "1amason"
	set nonce   "3218253468"
	set nc      "00000001"
	set qop     "auth"
	set diguri  "xmpp/l4l.be"
	set cnonce  "xAtFWjeKrKpSEIrpAcT2HjPDvxqWFqzavMBaUk54ccc="
	# response=1d3628c9fdd344eaeffbe2750cd581c0
	
	# sasl_mac_ok2
	#set once    "1457986605"
	#set cnonce  "vo1DEiI5HVaIcYM37VaJJdnVmhuwtVABIcHnT6EbuRI="
	# response=36132ad6825e05aad5650ccf660f0258
    }
    
    # build 'response' (2.1.2.1   Response-value in RFC 2831)
    set user_lat1  [encoding convertto iso8859-1 $user]
    set realm_lat1 [encoding convertto iso8859-1 $realm]
    set pass_lat1  [encoding convertto iso8859-1 $pass]
    set secret  ${user_lat1}:${realm_lat1}:${pass_lat1}
    set secmd5  [string tolower [::md5::md5 $secret]]
    set tmp     ${nonce}:${cnonce}:${authz}
    set A1      ${secmd5}:${tmp}
    set A2      "AUTHENTICATE:${diguri}"
    set HA1     [string tolower [::md5::md5 -hex $A1]]
    set HA2     [string tolower [::md5::md5 -hex $A2]]
    set KD      ${HA1}:${nonce}:${nc}:${cnonce}:${qop}:${HA2}
    set z       [string tolower [::md5::md5 -hex $KD]]
    
    # build output
    set output ""
    append output "username=\"$user\""
    append output ",realm=\"$realm\""
    append output ",nonce=\"$nonce\""
    append output ",cnonce=\"$cnonce\""
    append output ",nc=\"$nc\""
    append output ",serv-type=\"$service\""
    append output ",host=\"$host\""
    append output ",digest-uri=\"$diguri\""
    append output ",qop=\"$qop\""
    append output ",response=\"$z\""
    append output ",charset=\"utf-8\""
    append output ",authzid=\"$authz\""

    return $output
}

proc saslmd5::parse_challenge {str} {
    
    # this takes a bit of low level processing...
    set challenge {}
    set idx 0
    while {1} {
	set n [string first = $str $idx]
	if {$n == -1} break
	set key [string range $str $idx [expr $n-1]]
	set idx [expr $n+1]
	if {[string index $str $idx] == "\""} {
	    incr idx
	    set n [string first "\"" $str $idx]
	    if {$n == -1} break
	    set value [string range $str $idx [expr $n-1]]
	    set idx [incr n]
	} else {
	    set n [string first , $str $idx]
	    if {$n == -1} {
		set value [string range $str $idx end]
		set idx [expr [string length $str] - 1]
	    } else {
		set value [string range $str $idx [expr $n-1]]
		set idx $n
	    }
	}
	lappend challenge $key $value
	if {[string index $str $idx] != ","} break
	incr idx
    }
    return $challenge
}

proc saslmd5::free {token} {
    variable $token
    upvar 0 $token state
    
    unset -nocomplain state
}

