# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package SASL::XGoogleToken 1.0.0
# Meta as::origin http://sf.net/projects/tcllib
# Meta license    BSD
# Meta platform   tcl
# Meta require    http
# Meta require    SASL
# Meta require    {Tcl 8.2}
# Meta require    tls
# @@ Meta End




# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require http
package require SASL
package require Tcl 8.2
package require tls

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide SASL::XGoogleToken 1.0.0

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# gtoken.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# This is an implementation of Google's X-GOOGLE-TOKEN authentication 
# mechanism. This actually passes the login details to the Google
# accounts server which gives us a short lived token that may be passed 
# over an insecure link.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------

package require Tcl 8.2
package require SASL
package require http
package require tls

namespace eval ::SASL {
    namespace eval XGoogleToken {
        variable version 1.0.0
        variable rcsid {$Id: gtoken.tcl,v 1.2 2006/04/26 09:05:11 patthoyts Exp $}
        variable URLa https://www.google.com/accounts/ClientAuth
        variable URLb https://www.google.com/accounts/IssueAuthToken

        # Should use autoproxy and register autoproxy::tls_socket
        # Leave to application author?
        if {![info exists ::http::urlTypes(https)]} {
            http::register https 443 tls::socket
        }
    }
}

proc ::SASL::XGoogleToken::client {context challenge args} {
    upvar #0 $context ctx
    variable URLa
    variable URLb
    set reply ""
    set err ""

    if {$ctx(step) != 0} {
        return -code error "unexpected state: X-GOOGLE-TOKEN has only 1 step"
    }
    set username [eval $ctx(callback) [list $context username]]
    set password [eval $ctx(callback) [list $context password]]
    set query [http::formatQuery Email $username Passwd $password \
                   PersistentCookie false source googletalk]
    set tok [http::geturl $URLa -query $query -timeout 30000]
    if {[http::status $tok] eq "ok"} {
        foreach line [split [http::data $tok] \n] {
            array set g [split $line =]
        }
        set query [http::formatQuery SID $g(SID) LSID $g(LSID) \
                       service mail Session true]
        set tok2 [http::geturl $URLb -query $query -timeout 30000]

        if {[http::status $tok2] eq "ok"} {
            set reply "\0$username\0[http::data $tok2]"
        } else {
            set err [http::error $tok2]
        }
        http::cleanup $tok2
    } else {
        set err [http::error $tok]
    }
    http::cleanup $tok
    
    if {[string length $err] > 0} {
        return -code error $err
    } else {
        set ctx(response) $reply
        incr ctx(step)
    }
    return 0
}

# -------------------------------------------------------------------------

# Register this SASL mechanism with the Tcllib SASL package.
#
if {[llength [package provide SASL]] != 0} {
    ::SASL::register X-GOOGLE-TOKEN 40 ::SASL::XGoogleToken::client
}

package provide SASL::XGoogleToken $::SASL::XGoogleToken::version

# -------------------------------------------------------------------------
#
# Local variables:
# indent-tabs-mode: nil
# End: