1# gtoken.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# This is an implementation of Google's X-GOOGLE-TOKEN authentication 4# mechanism. This actually passes the login details to the Google 5# accounts server which gives us a short lived token that may be passed 6# over an insecure link. 7# 8# ------------------------------------------------------------------------- 9# See the file "license.terms" for information on usage and redistribution 10# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11# ------------------------------------------------------------------------- 12 13package require Tcl 8.2 14package require SASL 15package require http 2 16package require tls 17 18namespace eval ::SASL { 19 namespace eval XGoogleToken { 20 variable version 1.0.1 21 variable rcsid {$Id: gtoken.tcl,v 1.4 2007/08/26 00:36:45 patthoyts Exp $} 22 variable URLa https://www.google.com/accounts/ClientAuth 23 variable URLb https://www.google.com/accounts/IssueAuthToken 24 25 # Should use autoproxy and register autoproxy::tls_socket 26 # Leave to application author? 27 if {![info exists ::http::urlTypes(https)]} { 28 http::register https 443 tls::socket 29 } 30 } 31} 32 33proc ::SASL::XGoogleToken::client {context challenge args} { 34 upvar #0 $context ctx 35 variable URLa 36 variable URLb 37 set reply "" 38 set err "" 39 40 if {$ctx(step) != 0} { 41 return -code error "unexpected state: X-GOOGLE-TOKEN has only 1 step" 42 } 43 set username [eval $ctx(callback) [list $context username]] 44 set password [eval $ctx(callback) [list $context password]] 45 set query [http::formatQuery Email $username Passwd $password \ 46 PersistentCookie false source googletalk] 47 set tok [http::geturl $URLa -query $query -timeout 30000] 48 if {[http::status $tok] eq "ok"} { 49 foreach line [split [http::data $tok] \n] { 50 array set g [split $line =] 51 } 52 if {![info exists g(Error)]} { 53 set query [http::formatQuery SID $g(SID) LSID $g(LSID) \ 54 service mail Session true] 55 set tok2 [http::geturl $URLb -query $query -timeout 30000] 56 57 if {[http::status $tok2] eq "ok"} { 58 set reply "\0$username\0[http::data $tok2]" 59 } else { 60 set err [http::error $tok2] 61 } 62 http::cleanup $tok2 63 } else { 64 set err "Invalid username or password" 65 } 66 } else { 67 set err [http::error $tok] 68 } 69 http::cleanup $tok 70 71 if {[string length $err] > 0} { 72 return -code error $err 73 } else { 74 set ctx(response) $reply 75 incr ctx(step) 76 } 77 return 0 78} 79 80# ------------------------------------------------------------------------- 81 82# Register this SASL mechanism with the Tcllib SASL package. 83# 84if {[llength [package provide SASL]] != 0} { 85 ::SASL::register X-GOOGLE-TOKEN 40 ::SASL::XGoogleToken::client 86} 87 88package provide SASL::XGoogleToken $::SASL::XGoogleToken::version 89 90# ------------------------------------------------------------------------- 91# 92# Local variables: 93# indent-tabs-mode: nil 94# End: 95