HTTP has a number of possible authentication schemes. In practice you are only likely to have to deal with Basic and NTLM (which is a Microsoft specific one).
D. J. Hagberg styles much the same as
proc geturl_auth {url username password} {
set auth "Basic [base64::encode $username:$password]"
set headerl [list Authorization $auth]
set tok [http::geturl $url -headers $headerl]
set res [http::data $tok]
http::cleanup $tok
return $res
}With TCL8.6+, the first line of the proc may be replaced by:
set auth "Basic [binary encode base64 $username:$password]"
Thanks to Pat Thoyts for this example of use of http authentication for proxies:
package require base64 ;# tcllib
package require http ;# tcl
proc buildProxyHeaders {username password} {
return [list "Proxy-Authorization" \
[concat "Basic" [base64::encode $username:$password]]]
}
# Example...
proc fetch {url} {
set tok [http::geturl $url -headers [buildProxyHeaders USERNAME PASSWORD]]
# Process returned HTML ...
http::cleanup $tok
}Pat mentions that TkChat uses just such an approach.
Notice the distinct uses of "Authorization" and "Proxy-Authorization", about which PT writes:
See also autoproxy for simple handling of proxy authentication. [PT]
MC, June 7, 2006: Now that the SASL module in tcllib has support for NTLM, does anyone have a simillar example using NTLM-authentication?
D. Holmes, June 20, 2006: Regarding the request for an NTLM example, I dug into this and found that it won't work with the http package. NTLM requires keep-alive (or http 1.1) to work. I wish http 1.1 (with ntlm and other authentication) into the core. Anyway, I tried the SASL module for http athentication with NTLM and it failed. I ended up using the ntlm code in tkabber with a hacked up chunk of code from http to receive http/1.1
This is a much better authentication method than Basic. However, it isn't much used yet. The following package illustrates how to generate the Digest header on demand. At some point this will be made more useful to HTTP clients.
Currently to use this you would pass your http package token to the Parse method to have it return the options needed for the Response command. To generate the http header, you pass this result of to Header In code terms:
set hdr {}
while {1} {
set tok [http::geturl http:/www.authenticate/ -headers $hdr]
if {[http::ncode $tok] == 401} {
set args [digest::Parse $tok]
set hdr [list Authorization [eval [list digest::Header] $args]]
http::cleanup $tok
} else {
break
}
}# digest.tcl - Copyright (C) 2002 Pat Thoyts <[email protected]> # # Implement HTTP Digest Authentication # # # The page handler needs to process headers. If we receive a # 401 Unauthorised or the proxy equivalent we may get: # WWW-Authenticate: Digest # realm="[email protected]", # qop="auth,auth-int", # nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093", # opaque="5ccc069c403ebaf9f0171e9517f40e41" # # qop auth as below, auth-int includes a md5 sum of the page data too. # No qop means a different final response calculation (without nonce values). # # After a successful transaction you get an Authentication-Info header. # The nextnonce value should be used to calculation the next Authentication # header # You may get a rspauth which can be used by the client to validate the # server's response. package require http 2.0; # tcl core package require md5 2.0; # tcllib namespace eval digest { variable version 1.0 variable rcsid { $Id: 6087,v 1.13 2006-06-21 06:00:24 jcw Exp $ } variable noncecount if {![info exists noncecount]} { array set noncecount {} } } proc digest::Header {args} { foreach {elt val} [eval Response $args] { lappend r "$elt=\"$val\"" } return [concat Digest [join $r ", "]] } proc digest::Parse {token} { upvar $token state set r {} if {$state(querylength) < 1} { lappend r -cmd GET } else { lappend r -cmd POST } lappend r -uri $state(url) set ndx [lsearch -exact $state(meta) "WWW-Authenticate"] if {$ndx < 0} { return -code error "no WWW-Authenticate header found" } incr ndx set auth [lindex $state(meta) $ndx] if {![string match Digest* $auth]} { return -code error "this is not Digest auth" } foreach pair [split [string range $auth 7 end] ","] { regexp {([^=]+)=(.*)} [string trim $pair] -> name value lappend r -$name [string trim $value "\""] } return $r } proc digest::GetUserInfo {{user {}} {passwd {}}} { package require BWidget return [PasswdDlg .digestUserDetails \ -parent {} \ -transient 0 \ -logintext $user \ -passwdtext $passwd] } proc digest::Response {args} { variable noncecount array set opts [list qop {} \ getinfo [namespace origin GetUserInfo]] foreach {opt value} $args { switch -glob -- $opt { -get* { if {[info command $value] == {}} { return -code error "invalid argument:\ \"$value\" is not a command" } set opts(getinfo) $value } -us* { set opts(user) $value } -p* { set opts(passwd) $value } -nonce { set opts(nonce) $value } -qop { set opts(qop) $value } -realm { set opts(realm) $value } -cmd { set opts(cmd) $value } -uri { set opts(uri) $value } -op* { set opts(opaque) $value } -cnon* { set opts(cnonce) $value } -algo* { set opts(alogrithm) $value } -domain { set opts(domain) $value} default { return -code error "invalid option \"$opt\": must be one of\ -username, -password, -getinfo, -nonce, -qop, -realm,\ -cmd, -uri, -operation, -algorithm, -domain or -cnonce" } } } # Check we have everything we need. foreach elt [list nonce realm cmd uri] { if {![info exists opts($elt)]} { return -code error "invalid arguments: \"$elt\" must be supplied" } } # For testing - permit the client nonce value to be specified. if {![info exists opts(cnonce)]} { set opts(cnonce) [format %08x [clock clicks]] } # Only MD5 is acceptable as a calculation algorithm (sec: 3.2.1) if {[info exists opts(algorithm)]} { if {![string match "MD5*" $opts(algorithm)]} { return -code error "invalid algorithm spceified:\ \"$opts(algorithm)\" is not supported." } } # Calculate the nonce count value: - check server as well as realm? if {![info exists noncecount($opts(nonce))]} { set noncecount($opts(nonce)) 0 } set nc [incr noncecount($opts(nonce))] # Prompt for password and user interactively if not supplied. if {![info exists opts(user)] || ![info exists opts(passwd)]} { append opts(user) "" append opts(passwd) "" set r [$opts(getinfo) $opts(user) $opts(passwd)] foreach {opts(user) opts(passwd)} $r {} } # Build the response set A1 [string tolower [md5::md5 -hex "$opts(user):$opts(realm):$opts(passwd)"]] set A2 [string tolower [md5::md5 -hex "$opts(cmd):$opts(uri)"]] set nc [format %08u $nc] switch -exact -- $opts(qop) { {} { set response [string tolower [md5::md5 -hex "$A1:$opts(nonce):$A2"]] } auth { set response [string tolower [md5::md5 -hex "$A1:$opts(nonce):$nc:$opts(cnonce):$opts(qop):$A2"]] } default { return -code error "" } } set result [list \ username $opts(user) \ realm $opts(realm) \ nonce $opts(nonce) \ uri $opts(uri) \ qop $opts(qop) \ nc $nc \ cnonce $opts(cnonce) \ response $response] if {[info exists opts(opaque)]} { lappend result opaque $opts(opaque) } return $result } # ------------------------------------------------------------------------- package provide digest $::digest::version # ------------------------------------------------------------------------- # Validation: see RFC2617 section 3.5 # We should be producing a header like: # Digest username="Mufasa", # realm="[email protected]", # nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093", # uri="/dir/index.html", # qop="auth", # nc="00000001", # cnonce="0a4f113b", # response="6629fae49393a05397450978507c4ef1", # opaque="5ccc069c403ebaf9f0171e9517f40e41" proc digest::Test {} { set r [digest::Response -user Mufasa \ -pass "Circle Of Life" \ -realm "[email protected]" \ -qop "auth" \ -nonce "dcd98b7102dd2f0e8b11d0f600bfb0c093" \ -opaque "5ccc069c403ebaf9f0171e9517f40e41" \ -uri "/dir/index.html" \ -cmd "GET" \ -cnonce "0a4f113b"] } proc digest::Validate {} { variable noncecount array set valid { username "Mufasa" realm "[email protected]" nonce "dcd98b7102dd2f0e8b11d0f600bfb0c093" uri "/dir/index.html" qop "auth" nc "00000001" cnonce "0a4f113b" response "6629fae49393a05397450978507c4ef1" opaque "5ccc069c403ebaf9f0171e9517f40e41" } array set test [Test] # account for multiple runs of the test (nc is incremented) set valid(nc) [format %08u $noncecount($valid(nonce))] foreach key [array names valid] { if {[string compare $valid($key) $test($key)] != 0} { return -code error "validation error: for \"$key\"\ \"$test($key)\" should be \"$valid($key)\"" } } }
JKU I wrote a wrapper around http::geturl to support proxy and web authentication. With some modification, it could also follow redirects.
It uses SASL for the authentication stuff. If you plan to use it with Tcl < 8.6, you have to replace the binary encode and binary decode calls with calls to the base64 package.
If you want SSO or Kerberos see SASL and TWAPI.
package require SASL
package require http
namespace eval ::http::SASL {
# Use tailcall if it is there.
if {[llength [namespace which -command ::tailcall]]} {
variable tailcall ::tailcall
} else {
variable tailcall {}
}
variable reqid 0
variable geturl ::http::geturl
}
proc ::http::SASL::GetVar {} {
variable reqid
return "::http::SASL::req[incr reqid]"
}
proc ::http::SASL::geturl {url args} {
variable tailcall
set reqt [GetVar]
upvar #0 $reqt req
set req(url) $url
# parse args
set opts {}
foreach {k v} $args {
set k [::tcl::prefix match -error {-level 1} {
-binary
-blocksize
-channel
-command
-handler
-headers
-keepalive
-method
-myaddr
-progress
-protocol
-query
-queryblocksize
-querychannel
-queryprogress
-strict
-timeout
-type
-validate
} $k]
dict set opts $k $v
}
set req(-async) 0
if {[dict exists $opts -command]} {
set req(-command) [dict get $opts -command]
set req(-async) 1
dict set opts -command [list ::http::SASL::GetUrlCB $reqt]
}
set req(-opts) $opts
set req(-nextopts) $opts
{*}$tailcall GetUrl $reqt
}
proc ::http::SASL::GetUrl {reqt} {
variable tailcall
variable geturl
upvar #0 $reqt req
set req(token) [$geturl $req(url) {*}$req(-nextopts)]
if {!$req(-async)} {
{*}$tailcall GetUrlCB $reqt $req(token)
}
}
proc ::http::SASL::GetUrlCB {reqt tok} {
variable tailcall
upvar #0 $reqt req
switch -glob -- [http::ncode $tok] {
407 {
set opts $req(-opts)
if {![info exists req(proxy-auth-method)]} {
set srvm {}
foreach {k v} [http::meta $tok] {
if {$k eq "Proxy-Authenticate"} {lappend srvm [string toupper $v]}
}
set selm {}
foreach mech [::SASL::mechanisms] {
if {$mech in $srvm} {
# Found a mechanism
set selm $mech
break
}
}
if {$selm eq {}} {
Result $tok
}
set req(proxy-auth-method) $selm
#puts "Use $selm"
set req(proxy-auth-ctx) [SASL::new -callback [list ::http::SASL::Proxy-SASLCB $reqt] -mechanism $req(proxy-auth-method)]
set challenge {}
} else {
# TODO: challenge handling
lassign [split [dict get [http::meta $tok] Proxy-Authenticate]] method challenge
if {[string toupper $method] ne $req(proxy-auth-method)} {
#puts "got method $method"
Result $tok
}
set challenge [binary decode base64 $challenge]
}
set more [SASL::step $req(proxy-auth-ctx) $challenge]
dict lappend opts -headers Proxy-Authorization "$req(proxy-auth-method) [binary encode base64 [SASL::response $req(proxy-auth-ctx)]]"
#if {$more && ![dict exists $opts -headers Proxy-Connection]} {
dict lappend opts -headers Proxy-Connection Keep-Alive
dict set opts -keepalive 1
#}
if {!$more} {SASL::cleanup $tok}
set req(-nextopts) $opts
}
401 {
set opts $req(-opts)
if {![info exists req(www-auth-method)]} {
set srvm {}
foreach {k v} [http::meta $tok] {
if {$k eq "WWW-Authenticate"} {dict set srvm [string toupper $v] $v}
}
set selm {}
foreach mech [::SASL::mechanisms] {
if {$mech in [dict keys $srvm]} {
# Found a mechanism
set selm [dict get $srvm $mech]
break
}
}
if {$selm eq {}} {
Result $tok
}
set req(www-auth-method) $selm
#puts "Use $selm"
set req(www-auth-ctx) [SASL::new -callback [list ::http::SASL::WWW-SASLCB $reqt] -mechanism $req(www-auth-method)]
set challenge {}
} else {
# TODO: challenge handling
lassign [split [dict get [http::meta $tok] WWW-Authenticate]] method challenge
if {[string toupper $method] ne [string toupper $req(www-auth-method)]} {
##puts "got method $method"
Result $tok
}
set challenge [binary decode base64 $challenge]
}
set more [SASL::step $req(www-auth-ctx) $challenge]
dict lappend opts -headers Authorization "$req(www-auth-method) [binary encode base64 [SASL::response $req(www-auth-ctx)]]"
dict set opts -keepalive 1
if {!$more} {SASL::cleanup $tok}
set req(-nextopts) $opts
}
default {
Result $tok
}
}
#puts "Next round $req(-nextopts)"
update
http::cleanup $tok
{*}$tailcall GetUrl $reqt
}
proc ::http::SASL::Result {res} {
#puts "Result $res"
upvar 1 reqt reqt
upvar #0 $reqt req
if {[info exists req(-command)]} {
uplevel #0 [linsert $req(-command) end $res]
return -level 2
} else {
return -level 1 -code return $res
}
}
proc ::http::SASL::Proxy-SASLCB {reqt ctx cmd args} {
switch -exact -- $cmd {
login {return ""}
username {return ""}
password {return ""}
realm {return ""}
hostname {return [info hostname]}
target {
# use the hostname of the last proxy
return [http::config -proxyhost]
}
default {return -code error unexpected}
}
}
proc ::http::SASL::WWW-SASLCB {reqt ctx cmd args} {
switch -exact -- $cmd {
login {return ""}
username {return ""}
password {return ""}
realm {return ""}
hostname {return [info hostname]}
target {
upvar #0 $reqt req
if {![info exists req(host)]} {
# Calculate the host
set URLmatcher {(?x) # this is _expanded_ syntax
^
(?: (\w+) : ) ? # <protocol scheme>
(?: //
(?:
(
[^@/\#?]+ # <userinfo part of authority>
) @
)?
( # <host part of authority>
[^/:\#?]+ | # host name or IPv4 address
\[ [^/\#?]+ \] # IPv6 address in square brackets
)
(?: : (\d+) )? # <port part of authority>
)?
( / [^\#]*)? # <path> (including query)
(?: \# (.*) )? # <fragment>
$
}
regexp -- $URLmatcher $req(url) -> proto user host port srvurl
set req(host) $host
}
return HTTP/$req(host)
}
default {return -code error unexpected}
}
}
package provide http::SASL 1.0Note: For Kerberos, you need to use the full qualified name, not the short name of the server. (and I'm not sure what the right SPN for the proxy is) If you want, you could do it with some DNS lookups.
If you want to do that for each http::geturl, then this could (not tested) work:
rename ::http::geturl ::http::geturl_orig
set ::http::SASL::geturl ::http::geturl_orig
interp alias {} ::http::geturl {} ::http::SASL::geturlWorks for me. TODO: allow custom SASL callbacks. I don't need them with SASL and TWAPI through.
ALX 2016-03-17 10:18:00
Simple HTTP Authentication Wrapper for http::geturl RFC 2617
See also: