On the Tcl chat,
JKU pastedbin'ed a
TWAPI based provider for
tcllib's
SASL module. Copied here for safekeeping.
APN 2013-12-14 As of
TWAPI 4.0b25, the code below will not work as the SSPI API has changed (my excuse is that it was marked experimental). I will try and post an edited version later.
package require SASL
package require twapi
namespace eval ::SASL::sspi {
variable sspi_handles
array set sspi_handles {}
}
proc ::SASL::sspi::Cleanup {ctx} {
variable sspi_handles
::twapi::sspi_close_security_context $sspi_handles($ctx)
unset sspi_handles($ctx)
}
proc ::SASL::sspi::clientproc {mech context challenge args} {
upvar #0 $context ctx
variable sspi_handles
if {$ctx(count) == 1} {
if {[info exists sspi_handles($context)]} {
sspi_close_security_context $sspi_handles($context)
}
# Try to get some values from the callback
set cred_opts {}
foreach {type arg} {-user username -password password -domain realm} {
if {![catch "$ctx(callback) [list $context $arg]" res] && $res ne ""} {
dict set cred_opts $type $res
}
}
if {![dict exists $cred_opts -user]} {
dict unset cred_opts -password
dict unset cred_opts -domain
}
set ctx_opts {}
foreach {type arg} {-target target} {
if {![catch "$ctx(callback) [list $context $arg]" res] && $res ne ""} {
dict set ctx_opts $type $res
}
}
set cred [::twapi::sspi_new_credentials -usage outbound -package $mech {*}$cred_opts]
if {[catch {
set sspi_handles($context) [twapi::sspi_client_new_context $cred {*}$ctx_opts]
} res opt]} {
::twapi::sspi_free_credentials $cred
return -options $opt $res
}
::twapi::sspi_free_credentials $cred
trace add variable $context unset [list ::SASL::sspi::Cleanup $context]
}
set res [twapi::sspi_security_context_next $sspi_handles($context) $challenge]
lassign $res cont ctx(response) sspi_handles($context)
switch -exact -- $cont {
continue {
return 1
}
done {
return 0
}
}
}
proc ::SASL::sspi::serverproc {mech context challenge args} {
upvar #0 $context ctx
variable sspi_handles
if {$ctx(count) == 1} {
# allocate twapi stuff..
if {[info exists sspi_handles($context)]} {
sspi_close_security_context $sspi_handles($context)
}
set cred_opts {}
foreach {type arg} {-user username -password password -domain realm} {
if {![catch "$ctx(callback) [list $context $arg]" res] && $res ne ""} {
dict set cred_opts $type $res
}
}
if {![dict exists $cred_opts -user]} {
dict unset cred_opts -password
dict unset cred_opts -domain
}
set ctx_opts {}
foreach {type arg} {-target target} {
if {![catch "$ctx(callback) [list $context $arg]" res] && $res ne ""} {
dict set ctx_opts $type $res
}
}
set cred [::twapi::sspi_new_credentials -usage inbound -package $mech {*}$cred_opts]
if {[catch {
set sspi_handles($context) [twapi::sspi_server_new_context $cred $challenge {*}$ctx_opts]
} res opt]} {
::twapi::sspi_free_credentials $cred
return -options $opt $res
}
::twapi::sspi_free_credentials $cred
trace add variable $context unset [list ::SASL::sspi::Cleanup $context]
set res [twapi::sspi_security_context_next $sspi_handles($context) ""]
} else {
set res [twapi::sspi_security_context_next $sspi_handles($context) $challenge]
}
lassign $res cont ctx(response) sspi_handles($context)
switch -exact -- $cont {
continue {
return 1
}
done {
return 0
}
}
}
proc ::SASL::sspi::Init {} {
foreach pkg [::twapi::sspi_enumerate_packages] {
switch -exact -- $pkg {
Negotiate {set prio 100}
Kerberos {set prio 75}
NTLM {set prio 50}
default {set prio 49}
}
set ccmd [interp alias {} ::SASL::sspi::Client$pkg {} ::SASL::sspi::clientproc $pkg]
set scmd [interp alias {} ::SASL::sspi::Server$pkg {} ::SASL::sspi::serverproc $pkg]
::SASL::register [string toupper $pkg] $prio $ccmd $scmd
if {$pkg eq "Negotiate"} {
# Register as GSS-SPNEGO too
::SASL::register GSS-SPNEGO 90 $ccmd $scmd
}
}
rename ::SASL::sspi::Init {}
}
::SASL::sspi::Init
package provide SASL::sspi 1.0JKU Some notes:
- It used the non-standard parameter "target" for the SPN (necessary for Kerberos)
- Server part not tested.
- It always invokes the callback, not only if it needs some info. Return an empty string to use the default.
- Not sure if I mapped the arguments correctly.
- It uses traces to delete the twapi security context.
- tcllibs SASL only supports uppercase mechanisms. You can register lowercase mechanisms, but you can not use them.
- I guessed the priorities. Negotiate is IMHO the best, because it uses Kerberos and falls back to NTLM.
Example use:
package require ldap
package require SASL::sspi; # Imports twapi too.
set l [ldap::connect [string range [::twapi::find_domain_controller -require directoryservice] 2 end]]
ldap::bindSASL $l
foreach {k v} [lindex [ldap::search $l [::twapi::get_current_user -fullyqualifieddn] objectClass=* {} -scope base] 0 1] {puts "$k\t$v"}schlenk Looks pretty good. Thats surely the correct and secure way to connect tcllib LDAP to an AD domain.
