TclGPG  Check-in [7786c1df95]

2015-12-30  Sergei Golovan  <sgolovan@nes.ru>

	* tclgpg.tcl, tclgpg.test: Added incomplete (but usable) support for
	  importing and deleting GPG keys.

	* configure.in: Bumped the package version to 1.1.

2015-12-27  Sergei Golovan  <sgolovan@nes.ru>

	* tclgpg.tcl: Return the 'bad passphrase' error for the case of
	  failure after incorrectly entered passphrase via the pinentry.

	* tclgpg.test: Added a test which ensures that the recipient for
	  encryption can be specified using his key ID.

# configure.in --
#
#	This file is an autoconf script template for TclGPG. It was initially
#	borrowed from
#	http://tcl.cvs.sourceforge.net/viewvc/*checkout*/tcl/sampleextension/
#	and modified.
#
# Copyright (c) 2008-2015 Sergei Golovan <sgolovan@nes.ru>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#-----------------------------------------------------------------------
# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided.  These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
#-----------------------------------------------------------------------

AC_INIT([gpg], [1.1])

#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
# This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
#--------------------------------------------------------------------

    switch -- $operation {
        cancel    { set res [eval [list Cancel   $token] $args] }
        wait      { set res [eval [list Wait     $token] $args] }
        set       { set res [eval [list Set      $token] $args] }
        unset     { set res [eval [list Unset    $token] $args] }
        list-keys { set res [eval [list ListKeys $token] $args] }
        info-key  { set res [eval [list InfoKey  $token] $args] }
        import    { set res [eval [list Import   $token] $args] }
        delete    { set res [eval [list Delete   $token] $args] }
        encrypt   { set res [eval [list Encrypt  $token] $args] }
        sign      { set res [eval [list Sign     $token] $args] }
        verify    { set res [eval [list Verify   $token] $args] }
        decrypt   { set res [eval [list Decrypt  $token] $args] }
        free      { set res [eval [list Free     $token] $args] }
        default   {
            return -code error \

        set gpgChannels [ExecGPG $token decrypt-check --decrypt -- $input]
        return [UseGPG $token decrypt-check $commands $gpgChannels]
    } else {
        set gpgChannels [ExecGPG $token decrypt --decrypt -- $input]
        return [UseGPG $token decrypt $commands $gpgChannels]
    }
}

# ::gpg::Import --
#
#       Import a GPG key from a keyserver, or from an URI, or from a string.
#
# Arguments:
#       token               A GPG context token created in ::gpg::context.

proc ::gpg::Import {token args} {
    variable $token
    upvar 0 $token state

    set commands {}
    set opts {}

    foreach {key val} $args {
        switch -- $key {
            -keyserver {
                set opts [list --keyserver $val]
            }
            -key {
                set arg $val
                set operation --recv-keys
            }
            -uri {
                set arg $val
                set operation --fetch-keys
            }
            -data {
                set arg $val
                set operation --import
            }
            -command {
                set commands [list $val]
            }
            default {
                return -code error \
                       [format "unknown option \"%s\":\
                                must be %s" $key [JoinOptions {-keyserver
                                                               -key
                                                               -uri
                                                               -data
                                                               -command}]]
            }
        }
    }

    if {![info exists operation]} {
        return -code error "one of -key, -uri, or -data options must\
                            be specified"
    }

    if {$operation eq "--import"} {
        set gpgChannels [ExecGPG $token import --batch --import]
        return [UseGPG $token import $commands $gpgChannels $arg]
    } else {
        set gpgChannels [eval ExecGPG $token fetch --batch $opts $operation \
                              -- [list $arg]]
        return [UseGPG $token fetch $commands $gpgChannels]
    }
}

# ::gpg::Delete --
#
#       Delete key from the keyring.
#
# Arguments:
#       token               A GPG context token created in ::gpg::context.
#       -fingerprint fp     A GPG key fingerprint.
#       -command command    (optional, defaults to none) Callback for the
#                           case of asynchronous operation.
#
# Result:
#       An empty string or an error if some options are missing or incorrect,
#       or if the specified key isn't present in the keyring.
#
# Side effects:
#       The specified key is deleted from the keyring.

proc ::gpg::Delete {token args} {
    variable $token
    upvar 0 $token state
    
    set commands {}

    foreach {key val} $args {
        switch -- $key {
            -fingerprint {
                if {![regexp {^[0-9A-F]{40}$} $val]} {
                    return -code error "illegal fingerprint format"
                }
                set fingerprint $val
            }
            -command {
                set commands [list $val]
            }
            default {
                return -code error \
                       [format "unknown option \"%s\":\
                                must be %s" $key [JoinOptions {-fingerprint
                                                               -command}]]
            }
        }
    }

    if {![info exists fingerprint]} {
        return -code error "option -fingerprint is mandatory"
    }

    set gpgChannels [ExecGPG $token delete --batch --delete-key $fingerprint]
    return [UseGPG $token delete $commands $gpgChannels]
}

# ::gpg::ListKeys --
#
#       Return a key list.
#
# Arguments:
#       token               A GPG context token created in ::gpg::context.

proc ::gpg::FindKeys {token operation commands patterns} {

    set channels [eval ExecGPG $token list-keys \
                                      --batch \
                                      --with-colons \
                                      --fixed-list-mode \

                                      --with-fingerprint \
                                      $operation -- $patterns]

    set channels [lrange $channels 1 end]

    # Configure stdout of executed GPG process
    set stdout_fd [lindex $channels 1]

            return {validity ultimate}
        }
    }
}

proc ::gpg::Algorithm {code} {
    switch -- $code {
        1 -
        2 -
        3 {
            # RSA
            return RSA
        }
        16 {
            # Elgamal (encrypt only)

            if {![string match "-----BEGIN PGP SIGNED MESSAGE-----*" $input]} {
                fconfigure $stdin_fd -translation binary -buffering none
            }

            puts -nonewline $stdin_fd $input
            catch {close $stdin_fd}
        }
        import -
        verify {
            # For 'import' $input contains the key to import

            # For 'verify' $input contains a signed material (verifying a detached
            # signature)

            puts -nonewline $stdin_fd $input
            catch {close $stdin_fd}
        }
    }

    if {![info exists state(signatures)]} {
        set state(signatures) {}
    }

    # Parse gpg status output

    set eof 0

    while {[gets $status_fd line] >= 0} {
        Debug 2 $line
        set fields [split $line]

        if {[lindex $fields 0] ne "\[GNUPG:\]"} continue
        set state(output) 1

        switch -- [lindex $fields 1] {
            BEGIN_ENCRYPTION -
            BEGIN_SIGNING {
                set state(keyexpired) 0
                set state(keyrevoked) 0
                if {![SupplyMessage $channels $input]} {

            NODATA -
            UNEXPECTED {
                switch -- $operation {
                    decrypt {
                        set output 0
                        break
                    }
                    import -
                    fetch {
                        set state(import_error) "Invalid data to import"
                    }
                    default {
                        set state(sig:status) nosig
                    }
                }
            }
            INV_RECP {
                switch -- [lindex $fields 2] {

            FAILURE {
                # TODO: Figure out the real reason of failure

                set state(badpassphrase) 1
                set eof 1
                break
            }
            IMPORT_OK {
                set f [lindex $fields 2]
                if {$f == 0} {
                    set flags {unchanged}
                } else {
                    set flags {}
                    if {$f & 1} { lappend flags new_key }
                    if {$f & 2} { lappend flags new_uids }
                    if {$f & 4} { lappend flags new_sigs }
                    if {$f & 8} { lappend flags new_subkeys }
                    if {$f & 16} { lappend flags new_private_key }
                }
                lappend state(import_res) [lindex $fields 3] \
                        [list status ok code $f flags $flags]
            }
            IMPORT_PROBLEM {
                set r [lindex $fields 2]
                switch -- $r {
                    0 { set reason "No specific reason given" }
                    1 { set reason "Invalid Certificate" }
                    2 { set reason "Issuer Certificate missing" }
                    3 { set reason "Certificate Chain too long" }
                    4 { set reason "Error storing certificate" }
                }
                lappend state(import_res) [lindex $fields 3] \
                        [list status error code $r reason $reason]
            }
            IMPORT_RES {
                set count [lindex $fields 2]
                if {$count == 0 && ![info exists state(import_error)]} {
                    # TODO
                    set state(import_error) "No specific reason given"
                }
                set eof 1

                break
            }
            DELETE_PROBLEM {
                switch -- [lindex $fields 2] {
                    0 {
                        # There's no problem
                    }
                    1 {
                        FinishWithError $channels $commands "Key is not found"
                        return
                    }
                    2 {
                        FinishWithError $channels $commands "Cannot delete public key\
                                                             without deleteing the\
                                                             secret key first"
                        return
                    }
                    3 {
                        FinishWithError $channels $commands "Ambiguous key specification"
                        return
                    }
                }
            }
        }
    }

    if {$eof || [eof $status_fd] || [llength $commands] == 0} {
        if {![info exists state(output)]} {
            # If gpg didn't say anything then it's usually a fault

            switch -- $operation {
                delete {
                    # It's OK
                }
                fetch {
                    # Can't connect to a keyserver
                    FinishWithError $channels $commands "Can't connect to a keyserver"
                    return
                }
                decrypt {
                    FinishWithError $channels $commands "Encrypted message is corrupted"
                    return
                }
                default {
                    FinishWithError $channels $commands "Key is unusable"
                    return
                }
            }
        }

        if {[info exists state(import_error)]} {
            FinishWithError $channels $commands $state(import_error)
            return
        }

        if {[info exists state(badpassphrase)] && $state(badpassphrase)} {
            FinishWithError $channels $commands "Bad passphrase"
            return
        }

        if {[info exists state(keyexpired)] && $state(keyexpired)} {
            FinishWithError $channels $commands "Key expired"

        default {
            # There are different statuses
            set status diff
        }
    }

    switch -- $operation {
        delete {
            set data {}
        }
        import -
        fetch {
            set data $state(import_res)
        }
        encrypt -
        sign {
            set data [read $stdout_fd]
        }
        decrypt {
            set plaintext [read $stdout_fd]
            set data [list plaintext $plaintext]

    $r add -name sgolovan@gmail.com -validity full
    $c encrypt -input $message -recipients $r
    list ok ; # only testing non-error status
} -cleanup {
    $c free
    $r free
} -result {ok}

test delete-1.1 {Delete with unknown option} -body {
    set c [::gpg::new]
    $c delete -key 1234567890123456789012345678901234567890
} -cleanup {
    $c free
} -returnCodes error \
-result {unknown option "-key": must be -fingerprint or -command}

test delete-1.2 {Delete without -fingerprint option} -body {
    set c [::gpg::new]
    $c delete
} -cleanup {
    $c free
} -returnCodes error -result {option -fingerprint is mandatory}

test delete-1.3 {Delete with illegal -fingerprint} -body {
    set c [::gpg::new]
    $c delete -fingerprint user@host
} -cleanup {
    $c free
} -returnCodes error -result {illegal fingerprint format}

test delete-1.4 {Delete unexistent key} -body {
    set c [::gpg::new]
    $c delete -fingerprint 1234567890123456789012345678901234567890
} -cleanup {
    $c free
} -returnCodes error -result {Key is not found}

test import-1.1 {Import with unknown option} -body {
    set c [::gpg::new]
    $c import -email user@host
} -cleanup {
    $c free
} -returnCodes error \
-result {unknown option "-email": must be -keyserver, -key, -uri, -data, or -command}

test import-1.2 {Import without required option} -body {
    set c [::gpg::new]
    $c import -keyserver pgp.mit.edu
} -cleanup {
    $c free
} -returnCodes error -result {one of -key, -uri, or -data options must be specified}

test import-1.3 {Import invalid data using -data} -body {
    set c [::gpg::new]
    $c import -data "garbage"
} -cleanup {
    $c free
} -returnCodes error -result {Invalid data to import}

test import-1.4 {Import invalid data using -uri} -body {
    set c [::gpg::new]
    $c import -uri http://sgolovan.nes.ru/tmp/index.html
} -cleanup {
    $c free
} -returnCodes error -result {Invalid data to import}

test import-1.5 {Import using no keyserver} -body {
    # Make sure there's no keyserver in ./gnupg/gpg.conf
    set c [::gpg::new]
    $c import -key 1234567890123456789012345678901234567890
} -cleanup {
    $c free
} -returnCodes error -result {Can't connect to a keyserver}

test import-1.6 {Import using incorrect keyid} -body {
    set c [::gpg::new]
    $c import -keyserver pgp.mit.edu -key 1234567890123456789012345678901234567890
} -cleanup {
    $c free
} -returnCodes error -result {Invalid data to import}

test import-delete-1.1 {Import using -data and delete} -body {
    set c [::gpg::new]
    set r1 [$c import -data \
"-----BEGIN PGP PUBLIC KEY BLOCK-----
Version: GnuPG v1

mQGiBD3/epgRBACVATexq/aL+iJNVUzK/ZtkXWIOZ/Lv23DVDjkF1odIPMWYkkyd
pprcpQpqWKqfnpCPzPtsR0dXhA14lsRd4P3YvL9FqY63NftR0Z9dFuQ87Z+yh/WX
3XZnebJJIHdwZ51Sv6JfHLxgdO7OgXIWYoerxSbgUvwT0tbDDOjs56nnwwCgtrwh
UaU6PzHs8iTM5IztNAQhj4ED/AsvMJdCWUUFxvJCVIA1zEvqUlKcSaUNBqhojPdp
fMKSXBQ9GN9jsh6pWDkemGBUMceD0FOOA29bxushL2Y58tQjcS6F6ZXjIM2nfacf
A64TCIHlfZeDYA0OpNJwxmwzAUFK6wFNpPDOEf8dLLJ1o+KdHfuONCR/g21XUzCp
y36KA/4rvvbcE68pze8wISCM7M5Vdmj9ImVhgkBUsifjco18VhS8AkKiyXajqfs1
EQbNoUnVWbsmY0wkqM9Qzl1SWbVpplGzW2Fv35GbzicN/QBgljxbq5oRxbYs5c5U
UeAYDpKpdVRjy8/dW18Kob/2gs6BduLJA/5oGqnLZt10UbDqobQkU2VyZ2VpIEdv
bG92YW4gPHNlcmdlaUBnb2xvdmFuLmhvbWU+iF4EExECAB4FAkUXn5UCGyMGCwkI
BwMCAxUCAwMWAgECHgECF4AACgkQpHHJ4eTbPPj4cwCePo+kF/l9EUj5qCiVVcBH
hmwo9CQAnAmc4/NQgHQCl9mhsAlKqb1vPs2fuQENBD3/epsQBADkkN6Xyj1Q+Fvn
xHGTU17jTtT1fAkOQ+gWD7KhAYLpUHTI5JW5n0Mn4lbpI7RdL6vCSNvhDzRyc44S
Vi/QdYgNxi8xUw5DI1d6615cx2qYflkgjQ0wGqiiUs7c1T6q+7eA0EXg8FV+ePvc
CfLA+kN8KVoxdNJo9Uz5zZADX+BY1wADBQQAzpfBybP9BE6iLv/d8KpFpp3WJRZ2
9I7q3/ouYB1Txw+tOm8h1S0L8zzao3xBuWW3iNc2YCEFqPLMMJD3Iy57lI/Vu8pI
YZ0DcR37h3Ppli4HFEL6OgrtgCu9E6WUJexdV8wezzInz4n1u2JeI4ImEAErzi7O
5w8ntZmQj2RlSbeIRgQYEQIABgUCPf96mwAKCRCkccnh5Ns8+H3bAJ0TRbZRQ19K
BkCr8K8NDa7pULQCrgCgnJi3bw1maqhFNSVzg05YV8a+9zo=
=mL82
-----END PGP PUBLIC KEY BLOCK-----"]
    set r2 [$c delete -fingerprint EFC4152C70B4E86B9C24F716A471C9E1E4DB3CF8]
    list $r1 $r2
} -cleanup {
    $c free
} -result {{EFC4152C70B4E86B9C24F716A471C9E1E4DB3CF8 {status ok code 1 flags new_key}} {}}


cleanupTests

# vim:ts=8:sw=4:sts=4:et:ft=tcl