#! /bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
# impersonal.tcl - export impersonal mail via the web
#
# (c) 1999 Marshall T. Rose
# Hold harmless the author, and any lawful use is allowed.
#
package require Tcl 8.3
global options
# begin of routines that may be redefined in configFile
proc tclLog {message} {
global options
if {([info exists options(debugP)]) && ($options(debugP) > 0)} {
puts stderr $message
}
if {([string first "DEBUG " $message] == 0) \
|| ([catch { set fd [open $options(logFile) \
{ WRONLY CREAT APPEND }] }])} {
return
}
regsub -all "\n" $message " " message
catch { puts -nonewline $fd \
[format "%s %-8.8s %06d %s\n" \
[clock format [clock seconds] -format "%m/%d %T"] \
personal [expr {[pid]%65535}] $message] }
catch { close $fd }
}
# end of routines that may be redefined in configFile
proc firstext {mime} {
array set props [mime::getproperty $mime]
if {[info exists props(parts)]} {
foreach part $props(parts) {
if {[string compare [firstext $part] ""]} {
return $part
}
}
} else {
switch -- $props(content) {
text/plain
-
text/html {
return $mime
}
}
}
}
proc sanitize {text} {
regsub -all "&" $text {\&} text
regsub -all "<" $text {\<} text
return $text
}
proc cleanup {{message ""} {code 500}} {
global errorCode errorInfo
set ecode $errorCode
set einfo $errorInfo
if {[string compare $message ""]} {
tclLog $message
catch {
puts stdout "HTTP/1.0 $code Server Error
Content-Type: text/html
Status: 500 Server Error
Service Problem
Service Problem
Reason: [sanitize $message]"
if {$code == 505} {
puts stdout "
Stack:
[sanitize $einfo]
"
}
puts stdout ""
}
}
flush stdout
exit 0
}
if {[catch {
set program impersonal
package require mbox 1.0
package require mutl 1.0
package require smtp 1.1
package require Tclx 8.0
# move stdin, close stdin/stderr
dup [set null [open /dev/null { RDWR }]] stderr
set stdin [dup stdin]
dup $null stdin
close $null
fconfigure $stdin -translation crlf
fconfigure stdout -translation crlf
# parse arguments and initialize environment
set program [file tail [file rootname $argv0]]
set configFile .${program}-config.tcl
set debugP 0
set userName ""
for {set argx 0} {$argx < $argc} {incr argx} {
set option [lindex $argv $argx]
if {[incr argx] >= $argc} {
cleanup "missing argument to $option"
}
set value [lindex $argv $argx]
switch -- $option {
-config {
set configFile $value
}
-debug {
set options(debugP) [set debugP [smtp::boolean $value]]
}
-user {
set userName $value
}
default {
cleanup "unknown option $option"
}
}
}
if {[string compare $userName ""]} {
if {[catch { id convert user $userName }]} {
cleanup "userName doesn't exist: $userName"
}
if {([catch { file isdirectory ~$userName } result]) \
|| (!$result)} {
cleanup "userName doesn't have a home directory: $userName"
}
umask 0077
cd ~$userName
}
if {![file exists $configFile]} {
cleanup "configFile file doesn't exist: $configFile"
}
source $configFile
set options(debugP) $debugP
foreach {k v} [array get options] {
if {![string compare $v ""]} {
unset options($k)
}
}
foreach k [list dataDirectory foldersFile foldersDirectory] {
if {![info exists options($k)]} {
cleanup "configFile didn't define $k: $configFile"
}
}
if {![file isdirectory $options(dataDirectory)]} {
file mkdir $options(dataDirectory)
}
# crack the request
set request ""
set eol ""
while {1} {
if {[catch { gets $stdin line } result]} {
cleanup "lost connection"
}
if {$result < 0} {
break
}
set gotP 0
foreach c [split $line ""] {
if {($c == " ") || ($c == "\t") || [ctype print $c]} {
if {!$gotP} {
append request $eol
set gotP 1
}
append request $c
}
}
if {!$gotP} {
break
}
set eol "\n"
}
set request [string tolower $request]
set getP 0
foreach param [split $request "\n"] {
if {[string first "get " $param] == 0} {
set getP 1
if {[catch { lindex [split $param " "] 1 } page]} {
cleanup "server supports only HTTP/1.0" 501
}
}
}
if {!$getP} {
cleanup "server supports only GET" 405
}
if {[string first /news? $page] != 0} {
cleanup "page $page unavailable" 504
}
foreach param [split [string range $page 6 end] &] {
if {[set x [string first = $param]] <= 0} {
cleanup "page $request unavailable" 504
}
set key [string range $param 0 [expr {$x-1}]]
set arg($key) [string range $param [expr {$x+1}] end]
}
set expires [mime::parsedatetime -now proper]
# /news?index=newsgroups OR /news?index=recent
if {![catch { set arg(index) } index]} {
switch -- $index {
newsgroups {
set lastN 0
}
recent {
set lastN -1
}
default {
cleanup "page $request unavailable" 504
}
}
catch { set lastN $arg(lastn) }
if {[catch { open $options(foldersFile) { RDONLY } } fd]} {
cleanup $fd 505
}
set folders ""
set suffix [lindex [set prefix [file split \
$options(foldersDirectory)]] \
end]
set prefix [eval [list file join] [lreplace $prefix end end]]
for {set lineNo 1} {[gets $fd line] >= 0} {incr lineNo} {
if {[string first $suffix $line] != 0} {
continue
}
set file [file join $prefix $line]
if {[catch { file stat $file stat } result]} {
tclLog $result
continue
}
if {![string compare $stat(type) file]} {
lappend folders [list [eval [list file join] \
[lrange [file split $line] \
1 end]] \
$stat(mtime)]
}
}
catch {close $fd }
switch -- $index {
recent {
set folders [lsort -integer -decreasing -index 1 $folders]
}
default {
set folders [lsort -dictionary -increasing -index 0 $folders]
}
}
puts stdout "HTTP/1.0 200
Content-Type: text/html
Pragma: no-cache
Expires: $expires
newsgroups
"
foreach entry $folders {
set folder [lindex $entry 0]
set t [fmtclock [set mtime [lindex $entry 1]] "%m/%d %H:%M"]
puts stdout "| $t | | $folder |
"
}
puts stdout "
"
cleanup
}
# /news?folder="whatever"
if {[catch { set arg(folder) } folder]} {
cleanup "page $request unavailable" 504
}
foreach p [file split $folder] {
if {(![string compare $p ""]) || ([string first . $p] >= 0)} {
cleanup "page $request unavailable" 504
}
}
set file [file join $options(foldersDirectory) $folder]
if {([catch { file type $file } type]) \
|| ([string compare $type file])} {
cleanup "page $request unavailable" 504
}
if {[catch { mbox::initialize -file $file } mbox]} {
cleanup $mbox 505
}
# /news?folder="whatever"&lastN="N"
if {![catch { set arg(lastn) } lastN]} {
array set props [mbox::getproperty $mbox]
if {$lastN < 0} {
set diff [expr {-($lastN*86400)}]
set last 0
for {set msgNo $props(last)} {$msgNo > 0} {incr msgNo -1} {
if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
tclLog $mime
continue
}
if {[catch { lindex [mime::getheader $mime Date] 0 } value]} {
set value ""
}
if {![catch { mime::parsedatetime $value rclock } rclock]} {
if {$rclock < $diff} {
if {$last == 0} {
set last $msgNo
}
set first $msgNo
}
if {$last == 0} {
break
}
}
}
if {$last > 0} {
set last $props(last)
}
} elseif {[set first \
[expr {[set last $props(last)]-($lastN+1)}]] <= 0} {
set first 1
}
puts stdout "HTTP/1.0 200
Content-Type: text/html
Pragma: no-cache
Expires: $expires
$folder"
if {$last == 0} {
puts stdout "Empty.
"
cleanup
}
puts stdout ""
for {set msgNo $last} {$msgNo >= $first} {incr msgNo -1} {
if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
tclLog $mime
continue
}
set date ""
catch {
set value [lindex [mime::getheader $mime Date] 0]
append date [format %02d \
[mime::parsedatetime $value mon]] / \
[format %02d [mime::parsedatetime $value mday]] " " \
[format %02d [mime::parsedatetime $value hour]] : \
[format %02d [mime::parsedatetime $value min]]
}
if {![string compare $date ""]} {
set date "unknown date"
}
set from ""
catch {
set from [mutl::firstaddress [mime::getheader $mime From]]
catch { unset aprops }
array set aprops [lindex [mime::parseaddress $from] 0]
set from "$aprops(friendly)"
}
set subject ""
catch {
set subject [lindex [mime::getheader $mime Subject] 0]
}
puts stdout "| $date | | $from | | $subject |
"
}
puts stdout "