head	1.4;
access;
symbols
	tcllib-1-13:1.4
	tcllib-1-12:1.4
	tklib-0-5:1.4
	tcllib-1-11-1:1.4
	tcllib-1-11:1.4
	tcllib-1-10:1.4
	tcllib-1-9:1.4
	tcllib-1-8:1.4
	tcllib-1-7:1.3
	tcllib-1-6-1:1.2.6.1
	tcllib-1-6-branch:1.2.0.6
	tcllib-1-6:1.2
	tcllib-1-4-0:1.2
	tcllib-1-3-0:1.2
	tcllib-1-2-0:1.2.0.4
	RELEASES:1.2.0.2;
locks; strict;
comment	@# @;


1.4
date	2005.09.01.12.54.17;	author patthoyts;	state Exp;
branches;
next	1.3;

1.3
date	2004.03.09.08.20.18;	author andreas_kupries;	state Exp;
branches;
next	1.2;

1.2
date	2001.12.10.21.47.43;	author patthoyts;	state Exp;
branches
	1.2.6.1;
next	1.1;

1.1
date	2001.11.19.21.02.19;	author andreas_kupries;	state Exp;
branches;
next	;

1.2.6.1
date	2004.05.24.02.58.09;	author andreas_kupries;	state Exp;
branches;
next	;


desc
@@


1.4
log
@Rationalized to a single Tk demo
@
text
@#! /bin/sh
# -*- tcl -*- \
exec wish "$0" ${1+"$@@"}

# tk_smtpd -Copyright (C) 2004 Pat Thoyts <patthoyts@@users.sourceforge.net>
#
# Test of the mail server. All incoming messages are displayed in a 
# message dialog. This version requires smtpd 1.3.0 which has support for
# secure mail transactions. If you have the tls package available then the
# mail connection will be upgraded as per RFC 3207.
#
# For this to work smtpd::configure command must be called with some options
# for the tls::import command. See the tls package documentation and this
# example for details. A server certificate is required as well. A 
# demonstration self-signed certificate is provided.
#
# Usage tk_smtpd 0.0.0.0 8025
#    or tk_smtpd 127.0.0.1 2525
#    or tk_smtpd
# to listen to the default port 25 on all tcp/ip interfaces. 
# Alternatively you may configure the server via the GUI.
#
# -------------------------------------------------------------------------
# This software is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
# more details.
# -------------------------------------------------------------------------

package require Tcl   8.3
package require Tk    8.3
package require mime  1.3
package require smtpd 1.4

variable options
if {![info exists options]} {
    set dir [file dirname [info script]]
    array set options [list \
        loglevel   debug    \
        interface  0.0.0.0  \
        port       2525     \
        usetls     1        \
        require    0        \
        request    1        \
        certfile           [file join $dir server-public.pem] \
        keyfile            [file join $dir server-private.key] \
    ]
}

variable forever
if {![info exists forever]} { set forever 0 }
variable console
if {![info exists console]} { set console 0 }

wm title . "Tcllib SMTPd [package provide smtpd] Demo"
set _dlgid 0

# Handle new mail by raising a message dialog for each recipient.
proc deliverMIME {token} {

    set senders [mime::getheader $token From]
    set recipients [mime::getheader $token To]

    if {[catch {eval array set saddr \
                    [mime::parseaddress [lindex $senders 0]]}]} {
        error "invalid sender address \"$senders\""
    }
    set mail "From $saddr(address) [::smtpd::timestamp]\n"
    append mail [mime::buildmessage $token]
    foreach rcpt $recipients {
        if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} {
            display "To: $addr(address)" $mail
        }
    }
}

proc display {title mail} {
    global _dlgid
    incr _dlgid
    set dlg [toplevel .dlg$_dlgid]
    set txt [text ${dlg}.e -yscrollcommand [list ${dlg}.sb set]]
    set scr [scrollbar ${dlg}.sb -command [list $txt yview]]
    set but [button ${dlg}.b -text "Dismiss" -command [list destroy $dlg]]
    grid $txt $scr -sticky news
    grid $but   -  -sticky ns
    grid rowconfigure    $dlg 0 -weight 1
    grid columnconfigure $dlg 0 -weight 1
    wm title $dlg $title
    $txt insert 0.0 [string map {\r\n \n} $mail]
}

# Accept everyone except those spammers on 192.168.1.* :)
proc validate_host {ipnum} {
    if {[string match "192.168.1.*" $ipnum]} {
        error "your domain is not allowed to post, Spammers!"
    }
}

# Accept mail from anyone except user 'denied'
proc validate_sender {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "denied" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return    
}

# Only reject mail for recipients beginning with 'bogus'
proc validate_recipient {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "bogus*" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return
}

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

proc Start {} {
    variable options
    smtpd::configure \
        -loglevel           $options(loglevel) \
        -deliverMIME        ::deliverMIME \
        -validate_host      ::validate_host \
        -validate_recipient ::validate_recipient \
        -validate_sender    ::validate_sender \
        -certfile           $options(certfile) \
        -keyfile            $options(keyfile) \
        -usetls             $options(usetls) \
        -ssl2               1 \
        -ssl3               1 \
        -tls1               1 \
        -require            $options(require) \
        -request            $options(request) \
        -command            ::smtpd::tlscallback

    smtpd::start $options(interface) $options(port)
}

proc Stop {} {
    smtpd::stop
}

proc Exit {} {
    variable forever
    Stop
    set forever 1
}

proc ${::smtpd::log}::stdoutcmd {level text} {
    .t insert end "$text\n" $level
    .t see end
}

proc tkerror {msg} {
    .t insert end "$msg\n" error
    .t see end
}

proc ToggleConsole {} {
    variable console
    if {[info command console] ne {}} {
        if {$console} {
            console hide ; set console 0
        } else {
            console show ; set console 1
        }
    }
}

# Configure a GUI
proc Main {} {
    variable options
    label .l1 -text "Address" -anchor nw
    entry .e1 -textvariable ::options(interface)
    label .l2 -text "Port" -anchor nw
    entry .e2 -textvariable ::options(port)
    label .l3 -text "Public certificate file" -anchor nw
    entry .e3 -textvariable ::options(certfile)
    label .l4 -text "Private key file" -anchor nw
    entry .e4 -textvariable ::options(keyfile)
    label .l5 -text "Log level" -anchor nw
    entry .e5 -textvariable ::options(loglevel)

    frame .f3 -borderwidth 0
    checkbutton .c1 -text "Support TLS" -variable ::options(usetls)
    checkbutton .c2 -text "Request cerificate" -variable ::options(request)
    checkbutton .c3 -text "Require certificate" -variable ::options(require)
    grid .c1 .c2 .c3 -in .f3 -sticky news

    frame .f1 -borderwidth 0
    text .t -height 10 -yscrollcommand [list .sb set]
    scrollbar .sb -command [list .t yview]
    grid .t .sb -in .f1 -sticky news
    
    frame  .f2 -borderwidth 0
    button .b1 -width -12 -text Start -command Start
    button .b2 -width -12 -text Stop -command Stop
    button .b3 -width -12 -text Exit -command Exit
    grid   .b1 .b2 .b3 -in .f2 -sticky ne -padx 1 -pady 2

    grid .l1 .e1 .l2 .e2  -sticky news
    grid .f3 -   -   -    -sticky news
    grid .l3 .e3 -   -    -sticky news
    grid .l4 .e4 -   -    -sticky news
    grid .f1 -   -   -    -sticky news
    grid .l5 .e5 .f2 -    -sticky ne
    grid rowconfigure    . 4 -weight 1
    grid columnconfigure . 3 -weight 1
    grid rowconfigure    .f1 0 -weight 1
    grid columnconfigure .f1 0 -weight 1

    bind . <F2> {ToggleConsole}
}

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

if {$tcl_interactive } {

    puts {you'll want to issue 'smtpd::start' to begin}

} else {

    if {$argc > 0} {
        set iface [lindex $argv 0]
    }
    if {$argc > 1} {
        set port [lindex $argv 1]
    }

    Main
    tkwait variable forever
    destroy .
}

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


1.3
log
@Unified the startup header of all applications, using
suggestions made by Stuart Cassof <stwo@@telus.net>.
@
text
@d3 1
a3 1
exec tclsh "$0" ${1+"$@@"}
d5 1
a5 1
# tk_smtpd - Copyright (C) 2001 Pat Thoyts <patthoyts@@users.sourceforge.net>
d7 4
a10 2
# Simple test of the mail server. All incoming messages are displayed in a 
# message dialog.
d12 4
a15 1
# This example works nicely under Windows or within tkcon.
d20 2
a21 1
# to listen to the default port 25 on all tcp/ip interfaces.
d30 27
a56 4
package require Tcl 8.3
package require Tk
package require smtpd
wm withdraw .
d59 8
a66 3
proc deliver {sender recipients data} {
    if {[catch {eval array set saddr [mime::parseaddress $sender]}]} {
        error "invalid sender address \"$sender\""
d68 2
a69 3
    set mail "From $saddr(address) [clock format [clock seconds]]"
    append mail "\n" [join $data "\n"]

d72 1
a72 1
            tk_messageBox -title "To: $addr(address)" -message $mail
d77 15
d117 1
a117 6
# Setup the mail server
smtpd::configure \
    -deliver            ::deliver \
    -validate_host      ::validate_host \
    -validate_recipient ::validate_recipient \
    -validate_sender    ::validate_sender
d119 51
a169 3
# Run the server on the default port 25. For unix change to 
# a high numbered port eg: 2525 or 8025 etc with
# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525
d171 41
a211 2
set iface 0.0.0.0
set port 25
d213 1
a213 2
if {$argc > 0} {
    set iface [lindex $argv 0]
d215 19
a233 2
if {$argc > 1} {
    set port [lindex $argv 1]
a235 2
smtpd::start $iface $port

@


1.2
log
@Tidied up the examples, added comments added non-tk example.
@
text
@d2 3
a4 1
#
a22 2
# \
exec wish8.3 "$0" ${1+"$@@"}
d24 2
a26 1
package require Tk
@


1.2.6.1
log
@Downgraded to version 1.3.6, removed -decode extension from
this branch.

Import of ftpd bugfix by Gerald Lester.

Last commit was a bad update, caused duplicates of changes
to appear. Failed testsuite. Removed all the duplicates now.

Fixed SF Tcllib Bug 954328. Mime now adapts at runtime to
whatever version of md5 has been loaded.

Updated test for rewritten adjust which fixed the infinite
looping demonstrated by tests 2.6 and 2.7. Also fixed a var
usage typo which caused a copy of the input to appear in the
output, before the expected formatted result.

Fixed bug in the processing of multi-word section titles for
text based formats.

Fixed bug 951568, regarding the usage of Trf's generic
transform.

Fixed problems with jpeg recognition (was unable to detect a
jpeg file, if it contained exif data).

Changelog for last patch, and updates in related package.

Completed application of code for various fixes.

Rewritten text adjustment and hyphenation, fixing SF TCllib
Bug 882402.

Fixed SF Tcllib Bug 936064, and evals more robust.

Fixed SF Tcllib Bug 893516

Fixed SF Tcllib Patch 763712

Fixed SF Tcllib Patch 758742

Fixed SF Tcllib Bug 620852

Eval usage made more robust and similar.

Fixed SF Tcllib Bug 943146.

Fixed SF Tcllib Bug 940651

SF Tcllib Bug 784519 fixed.

Pat: sak.tcl update for better use of critcl.

Joe: Fix in doctools xml support.

Import bugfix by Pat Thoyts, Handling of data starting with
hyphen/dash

Import of uuencode changes by Jeff Hobbs.

Changed defaults for package 'log'. No output for the all
levels below 'error'.

Unified the startup header of all applications, using
suggestions made by Stuart Cassof <stwo@@telus.net>.

Added testcase for Tcllib SF Bug 860753. The bug itself was
already fixed for Tcllib 1.6.

Fix for bug 899204. Test data file is opened read-only, and
tests made independent of each other.

Bugfix 899152, 899209. Require Tcl 8.2 for installer, delete
file before writing over it.

Import of time fix by Pat Thoyts, patch #905132.

Cleanup fix: Snit depends on Tcl 8.4, this is documented,
however neither package index, nor testsuite enforced the
restriction, allowing for errors. This has been changed now.

Fixed typos
@
text
@d2 1
a2 3
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@@"}

d21 2
d24 1
a24 1
package require Tcl 8.3
a25 1
package require smtpd
@


1.1
log
@
	* smtpd: Example consolidation: Moved the smtpd example to
	'examples' directory.

	* ftp: Implemented FR #481161.

	* ftpd: Added example ftp server used for testing the
	  functionality of FR #481161.


	* ftp.tcl: Tested implementation of FR #481161. Fixed the errors
	  found that way (incomplete cleanup by 'Get', interfered with the
	  following 'Put' command).

	* ftp.tcl, ftp.n: Implemented and documented FR #481161.
@
text
@d1 3
a3 1
# example.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@@users.sourceforge.net>
d6 8
a13 1
# dialog box.
d21 2
d26 1
d28 1
d43 1
d50 1
d59 1
d62 1
a62 1
    if {! [string match "soap*" $addr(local)]} {
d68 1
d75 21
a95 1
smtpd::start
@

