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).
HTTP Basic Authentication
Thanks to Pat Thoyts for this example of use of http authentication:
package require base64 ;# tcllib
package require http ;# tcl
proc buildProxyHeaders {username password} {
return [list "Proxy-Authorization" \
[concat "Basic" [base64::encode $username:$password]]]
}
proc fetch {url} {
set tok [http::geturl $url -headers [buildProxyHeaders]]
...
}Pat mentions that TkChat uses just such an approach.
See also autoproxy for simple handling of proxy authentication. [PT]
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
set res
}Notice the distinct uses of "Authorization" and "Proxy-Authorization", about which PT writes: "Proxy-Authorization is used by HTTP proxy servers to decide if they are going to forward your request. This is typically used by corporate networks to provide accountability for web access. The Authorization header is used to authenticate you to the endpoint server. The Proxy-Authorization will never leave your local network - the Authorization header is passed all the way along to the final host."
HTTP Digest Authentication
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 thes result of Response to Header :) In code:
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; # tcllib
namespace eval digest {
variable version 1.0
variable rcsid {
$Id: 6087,v 1.4 2003-01-24 09:01:17 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 user {} passwd {} 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 {$opts(user) == {} || $opts(passwd) == {}} {
set r [$opts(getinfo) $opts(user) $opts(passwd)]
foreach {opts(user) opts(passwd)} $r {}
}
# Build the response
set A1 [md5::md5 "$opts(user):$opts(realm):$opts(passwd)"]
set A2 [md5::md5 "$opts(cmd):$opts(uri)"]
set nc [format %08u $nc]
switch -exact -- $opts(qop) {
{} {
set response [md5::md5 "$A1:$opts(nonce):$A2"]
}
auth {
set response [md5::md5 "$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)\""
}
}
}