1#! /bin/sh
2# -*- tcl -*- \
3exec tclsh "$0" ${1+"$@"}
4
5# impersonal.tcl - export impersonal mail via the web
6#
7# (c) 1999 Marshall T. Rose
8# Hold harmless the author, and any lawful use is allowed.
9#
10
11package require Tcl 8.3
12global options
13
14
15# begin of routines that may be redefined in configFile
16
17proc tclLog {message} {
18    global options
19
20    if {([info exists options(debugP)]) && ($options(debugP) > 0)} {
21        puts stderr $message
22    }
23
24    if {([string first "DEBUG " $message] == 0) \
25            || ([catch { set fd [open $options(logFile) \
26                                      { WRONLY CREAT APPEND }] }])} {
27        return
28    }
29
30    regsub -all "\n" $message " " message
31
32    catch { puts -nonewline $fd \
33                 [format "%s %-8.8s %06d %s\n" \
34                         [clock format [clock seconds] -format "%m/%d %T"] \
35                         personal [expr {[pid]%65535}] $message] }
36
37    catch { close $fd }
38}
39
40# end of routines that may be redefined in configFile
41
42
43proc firstext {mime} {
44    array set props [mime::getproperty $mime]
45
46    if {[info exists props(parts)]} {
47        foreach part $props(parts) {
48            if {[string compare [firstext $part] ""]} {
49                return $part
50            }
51        }
52    } else {
53        switch -- $props(content) {
54            text/plain
55                -
56            text/html {
57                return $mime
58            }
59        }
60    }
61}
62
63proc sanitize {text} {
64    regsub -all "&" $text {\&} text
65    regsub -all "<" $text {\&lt;}  text
66
67    return $text
68}
69
70proc cleanup {{message ""} {code 500}} {
71    global errorCode errorInfo
72
73    set ecode $errorCode
74    set einfo $errorInfo
75
76    if {[string compare $message ""]} {
77        tclLog $message
78
79        catch {
80            puts stdout "HTTP/1.0 $code Server Error
81Content-Type: text/html
82Status: 500 Server Error
83
84<html><head><title>Service Problem</title></head>
85<body><h1>Service Problem</h1>
86<b>Reason:</b> [sanitize $message]"
87
88            if {$code == 505} {
89                puts stdout "<br>
90<b>Stack:</b>
91<pre>[sanitize $einfo]</pre>
92<hr></hr>"
93            }
94
95            puts stdout "</body></html>"
96        }
97    }
98
99    flush stdout
100
101    exit 0
102}
103
104
105
106if {[catch {
107
108    set program impersonal
109
110    package require mbox 1.0
111    package require mutl 1.0
112    package require smtp 1.1
113    package require Tclx 8.0
114
115
116# move stdin, close stdin/stderr
117
118    dup [set null [open /dev/null { RDWR }]] stderr
119    set stdin [dup stdin]
120    dup $null stdin
121    close $null
122
123    fconfigure $stdin -translation crlf
124    fconfigure stdout -translation crlf
125
126
127# parse arguments and initialize environment
128
129    set program [file tail [file rootname $argv0]]
130
131    set configFile .${program}-config.tcl
132
133    set debugP 0
134
135    set userName ""
136
137    for {set argx 0} {$argx < $argc} {incr argx} {
138        set option [lindex $argv $argx]
139        if {[incr argx] >= $argc} {
140            cleanup "missing argument to $option"
141        }
142        set value [lindex $argv $argx]
143
144        switch -- $option {
145            -config {
146                set configFile $value
147            }
148
149            -debug {
150                set options(debugP) [set debugP [smtp::boolean $value]]
151            }
152
153            -user {
154                set userName $value
155            }
156
157            default {
158                cleanup "unknown option $option"
159            }
160        }
161    }
162
163    if {[string compare $userName ""]} {
164        if {[catch { id convert user $userName }]} {
165            cleanup "userName doesn't exist: $userName"
166        }
167        if {([catch { file isdirectory ~$userName } result]) \
168                || (!$result)} {
169            cleanup "userName doesn't have a home directory: $userName"
170        }
171
172        umask 0077
173        cd ~$userName
174    }
175
176    if {![file exists $configFile]} {
177        cleanup "configFile file doesn't exist: $configFile"
178    }
179    source $configFile
180
181    set options(debugP) $debugP
182
183    foreach {k v} [array get options] {
184        if {![string compare $v ""]} {
185            unset options($k)
186        }
187    }
188
189    foreach k [list dataDirectory foldersFile foldersDirectory] {
190        if {![info exists options($k)]} {
191            cleanup "configFile didn't define $k: $configFile"
192        }
193    }
194
195    if {![file isdirectory $options(dataDirectory)]} {
196        file mkdir $options(dataDirectory)
197    }
198
199
200# crack the request
201
202    set request ""
203    set eol ""
204    while {1} {
205        if {[catch { gets $stdin line } result]} {
206            cleanup "lost connection"
207        }
208        if {$result < 0} {
209            break
210        }
211
212        set gotP 0
213        foreach c [split $line ""] {
214            if {($c == " ") || ($c == "\t") || [ctype print $c]} {
215                if {!$gotP} {
216                    append request $eol
217                    set gotP 1
218                }
219                append request $c
220            }
221        }
222        if {!$gotP} {
223            break
224        }
225
226        set eol "\n"
227    }
228    set request [string tolower $request]
229
230    set getP 0
231    foreach param [split $request "\n"] {
232        if {[string first "get " $param] == 0} {
233            set getP 1
234            if {[catch { lindex [split $param " "] 1 } page]} {
235                cleanup "server supports only HTTP/1.0" 501
236            }
237        }
238    }
239    if {!$getP} {
240        cleanup "server supports only GET" 405
241    }
242
243    if {[string first /news? $page] != 0} {
244        cleanup "page $page unavailable" 504
245    }
246    foreach param [split [string range $page 6 end] &] {
247        if {[set x [string first = $param]] <= 0} {
248            cleanup "page $request unavailable" 504
249        }
250        set key [string range $param 0 [expr {$x-1}]]
251        set arg($key) [string range $param [expr {$x+1}] end]
252    }
253
254    set expires [mime::parsedatetime -now proper]
255
256
257# /news?index=newsgroups OR /news?index=recent
258
259    if {![catch { set arg(index) } index]} {
260        switch -- $index {
261            newsgroups {
262                set lastN 0
263            }
264
265            recent {
266                set lastN -1
267            }
268
269            default {
270                cleanup "page $request unavailable" 504
271            }
272        }
273        catch { set lastN $arg(lastn) }
274
275        if {[catch { open $options(foldersFile) { RDONLY } } fd]} {
276            cleanup $fd 505
277        }
278
279        set folders ""
280        set suffix [lindex [set prefix [file split \
281                                             $options(foldersDirectory)]] \
282                           end]
283        set prefix [eval [list file join] [lreplace $prefix end end]]
284
285        for {set lineNo 1} {[gets $fd line] >= 0} {incr lineNo} {
286            if {[string first $suffix $line] != 0} {
287                continue
288            }
289            set file [file join $prefix $line]
290
291            if {[catch { file stat $file stat } result]} {
292                tclLog $result
293
294                continue
295            }
296            if {![string compare $stat(type) file]} {
297                lappend folders [list [eval [list file join] \
298                                            [lrange [file split $line] \
299                                                    1 end]] \
300                                      $stat(mtime)]
301            }
302        }
303
304        catch {close $fd }
305
306        switch -- $index {
307            recent {
308                set folders [lsort -integer    -decreasing -index 1 $folders]
309            }
310
311            default {
312                set folders [lsort -dictionary -increasing -index 0 $folders]
313            }
314        }
315
316        puts stdout "HTTP/1.0 200
317Content-Type: text/html
318Pragma: no-cache
319Expires: $expires
320
321<html><head><title>newsgroups</title></head><body>
322<table cellborder=0 cellpadding=0 cellspacing=0>"
323
324        foreach entry $folders {
325            set folder [lindex $entry 0]
326            set t [fmtclock [set mtime [lindex $entry 1]] "%m/%d %H:%M"]
327
328            puts stdout "<tr><td><a href=\"news?folder=$folder&lastN=$lastN&mtime=$mtime\">$t</a></td><td width=5></td><td><b>$folder</b></td></tr>"
329        }
330
331        puts stdout "</table>
332</body></html>"
333
334        cleanup
335    }
336
337
338# /news?folder="whatever"
339
340    if {[catch { set arg(folder) } folder]} {
341        cleanup "page $request unavailable" 504
342    }
343
344    foreach p [file split $folder] {
345        if {(![string compare $p ""]) || ([string first . $p] >= 0)} {
346            cleanup "page $request unavailable" 504
347        }
348    }
349
350    set file [file join $options(foldersDirectory) $folder]
351    if {([catch { file type $file } type]) \
352            || ([string compare $type file])} {
353        cleanup "page $request unavailable" 504
354    }
355    if {[catch { mbox::initialize -file $file } mbox]} {
356        cleanup $mbox 505
357    }
358
359
360# /news?folder="whatever"&lastN="N"
361
362    if {![catch { set arg(lastn) } lastN]} {
363        array set props [mbox::getproperty $mbox]
364
365        if {$lastN < 0} {
366            set diff [expr {-($lastN*86400)}]
367
368            set last 0
369            for {set msgNo $props(last)} {$msgNo > 0} {incr msgNo -1} {
370                if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
371                    tclLog $mime
372
373                    continue
374                }
375
376                if {[catch { lindex [mime::getheader $mime Date] 0 } value]} {
377                    set value ""
378                }
379                if {![catch { mime::parsedatetime $value rclock } rclock]} {
380                    if {$rclock < $diff} {
381                        if {$last == 0} {
382                            set last $msgNo
383                        }
384                        set first $msgNo
385                    }
386                    if {$last == 0} {
387                        break
388                    }
389                }
390            }
391            if {$last > 0} {
392                set last $props(last)
393            }
394        } elseif {[set first \
395		[expr {[set last $props(last)]-($lastN+1)}]] <= 0} {
396            set first 1
397        }
398
399        puts stdout "HTTP/1.0 200
400Content-Type: text/html
401Pragma: no-cache
402Expires: $expires
403
404<html><head><title>$folder</title></head><body>"
405
406        if {$last == 0} {
407            puts stdout "<b>Empty.</b>
408</body></html>"
409
410            cleanup
411        }
412
413        puts stdout "<table cellborder=0 cellpadding=0 cellspacing=0>"
414        for {set msgNo $last} {$msgNo >= $first} {incr msgNo -1} {
415            if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
416                tclLog $mime
417
418                continue
419            }
420
421            set date ""
422            catch {
423                set value [lindex [mime::getheader $mime Date] 0]
424                append date [format %02d \
425                                    [mime::parsedatetime $value mon]]   /  \
426                       [format %02d [mime::parsedatetime $value mday]] " " \
427                       [format %02d [mime::parsedatetime $value hour]]  :  \
428                       [format %02d [mime::parsedatetime $value min]]
429            }
430            if {![string compare $date ""]} {
431                set date "unknown date"
432            }
433
434            set from ""
435            catch {
436                set from [mutl::firstaddress [mime::getheader $mime From]]
437
438                catch { unset aprops }
439
440                array set aprops [lindex [mime::parseaddress $from] 0]
441                set from "<a href='mailto:$aprops(local)@$aprops(domain)'>$aprops(friendly)</a>"
442            }
443
444            set subject ""
445            catch {
446                set subject [lindex [mime::getheader $mime Subject] 0]
447            }
448
449            puts stdout "<tr><td><a href=\"news?folder=$folder&msgNo=$msgNo\">$date</a></td><td width=5></td><td><b>$from</b></td><td width=5></td><td>$subject</td></tr>"
450        }
451        puts stdout "</table>
452</body></html>"
453
454        cleanup
455    }
456
457
458# /news?folder="whatever"&msgNo="N"
459
460    if {![catch { set arg(msgno) } msgNo]} {
461        if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
462            cleanup $mime 505
463        }
464
465        if {![string compare [set part [firstext $mime]] ""]} {
466            set part $mime
467        }
468        switch -- [set content [mime::getproperty $part content]] {
469            text/plain {
470                regsub -all "\n\n" [mime::getbody $part] "<p>" body
471
472                set result "<html><head><title>$folder $msgNo</title></head>
473<body>$body</body></html>"
474
475            }
476
477            text/html {
478                set result [mime::getbody $part]
479            }
480
481            default {
482                set result "<html><head><title>$folder $msgNo</title></head>
483<body>
484Message is $content.
485</body></html>"
486            }
487        }
488
489        puts stdout "HTTP/1.0 200
490Content-Type: text/html
491
492$result"
493
494        cleanup
495    }
496
497
498    cleanup "page $request unavailable" 504
499
500
501} result]} {
502    global errorCode errorInfo
503
504    set ecode $errorCode
505    set einfo $errorInfo
506
507    if {(![catch { info body tclLog } result2]) \
508            && ([string compare [string trim $result2] \
509                        {catch {puts stderr $string}}])} {
510        catch { tclLog $result }
511    }
512
513    if {![string first "POSIX EPIPE" $ecode]} {
514        exit 0
515    }
516
517    catch {
518        smtp::sendmessage \
519            [mime::initialize \
520                 -canonical text/plain \
521                 -param  {charset us-ascii} \
522                 -string "$result\n\nerrorCode: $ecode\n\n$einfo"] \
523            -originator "" \
524            -header [list From    [id user]@[info hostname]]       \
525            -header [list To      operator@[info hostname]]        \
526            -header [list Subject "[info hostname] fatal $program"]
527    }
528
529    cleanup $result
530}
531
532
533exit 75
534