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