impersonal.tcl
Go to the documentation of this file.00001
00002
00003 exec tclsh "$0" ${1+"$@"}
00004
00005
00006
00007
00008
00009
00010
00011 package require Tcl 8.3
00012 global options
00013
00014
00015
00016
00017 ret tclLog (type message) {
00018 global options
00019
00020 if {([info exists options(debugP)]) && ($options(debugP) > 0)} {
00021 puts stderr $message
00022 }
00023
00024 if {([string first "DEBUG " $message] == 0) \
00025 || ([catch { set fd [open $options(logFile) \
00026 { WRONLY CREAT APPEND }] }])} {
00027 return
00028 }
00029
00030 regsub -all "\n" $message " " message
00031
00032 catch { puts -nonewline $fd \
00033 [format "%s %-8.8s %06d %s\n" \
00034 [clock format [clock seconds] -format "%m/%d %T"] \
00035 personal [expr {[pid]%65535}] $message] }
00036
00037 catch { close $fd }
00038 }
00039
00040
00041
00042
00043 ret firstext (type mime) {
00044 array set props [mime::getproperty $mime]
00045
00046 if {[info exists props(parts)]} {
00047 foreach part $props(parts) {
00048 if {[string compare [firstext $part] ""]} {
00049 return $part
00050 }
00051 }
00052 } else {
00053 switch -- $props(content) {
00054 text/plain
00055 -
00056 text/html {
00057 return $mime
00058 }
00059 }
00060 }
00061 }
00062
00063 ret sanitize (type text) {
00064 regsub -all "&" $text {\&} text
00065 regsub -all "<" $text {\<} text
00066
00067 return $text
00068 }
00069
00070 ret cleanup (optional message ="" , optional code =500) {
00071 global errorCode errorInfo
00072
00073 set ecode $errorCode
00074 set einfo $errorInfo
00075
00076 if {[string compare $message ""]} {
00077 tclLog $message
00078
00079 catch {
00080 puts stdout "HTTP/1.0 $code Server Error
00081 Content-Type: text/html
00082 Status: 500 Server Error
00083
00084 <html><head><title>Service Problem</title></head>
00085 <body><h1>Service Problem</h1>
00086 <b>Reason:</b> [sanitize $message]"
00087
00088 if {$code == 505} {
00089 puts stdout "<br>
00090 <b>Stack:</b>
00091 <pre>[sanitize $einfo]</pre>
00092 <hr></hr>"
00093 }
00094
00095 puts stdout "</body></html>"
00096 }
00097 }
00098
00099 flush stdout
00100
00101 exit 0
00102 }
00103
00104
00105
00106 if {[catch {
00107
00108 program = impersonal
00109
00110 package require mbox 1.0
00111 package require mutl 1.0
00112 package require smtp 1.1
00113 package require Tclx 8.0
00114
00115
00116
00117
00118 dup [ null = [open /dev/null { RDWR }]] stderr
00119 stdin = [dup stdin]
00120 dup $null stdin
00121 close $null
00122
00123 fconfigure $stdin -translation crlf
00124 fconfigure stdout -translation crlf
00125
00126
00127
00128
00129 program = [file tail [file rootname $argv0]]
00130
00131 configFile = .${program}-config.tcl
00132
00133 debugP = 0
00134
00135 userName = ""
00136
00137 for { argx = 0} {$argx < $argc} {incr argx} {
00138 option = [lindex $argv $argx]
00139 if {[incr argx] >= $argc} {
00140 cleanup "missing argument to $option"
00141 }
00142 value = [lindex $argv $argx]
00143
00144 switch -- $option {
00145 -config {
00146 configFile = $value
00147 }
00148
00149 -debug {
00150 options = (debugP) [ debugP = [smtp::boolean $value]]
00151 }
00152
00153 -user {
00154 userName = $value
00155 }
00156
00157 default {
00158 cleanup "unknown option $option"
00159 }
00160 }
00161 }
00162
00163 if {[string compare $userName ""]} {
00164 if {[catch { id convert user $userName }]} {
00165 cleanup "userName doesn't exist: $userName"
00166 }
00167 if {([catch { file isdirectory ~$userName } result]) \
00168 || (!$result)} {
00169 cleanup "userName doesn't have a home directory: $userName"
00170 }
00171
00172 umask 0077
00173 cd ~$userName
00174 }
00175
00176 if {![file exists $configFile]} {
00177 cleanup "configFile file doesn't exist: $configFile"
00178 }
00179 source $configFile
00180
00181 options = (debugP) $debugP
00182
00183 foreach {k v} [array get options] {
00184 if {![string compare $v ""]} {
00185 un options = ($k)
00186 }
00187 }
00188
00189 foreach k [list dataDirectory foldersFile foldersDirectory] {
00190 if {![info exists options($k)]} {
00191 cleanup "configFile didn't define $k: $configFile"
00192 }
00193 }
00194
00195 if {![file isdirectory $options(dataDirectory)]} {
00196 file mkdir $options(dataDirectory)
00197 }
00198
00199
00200
00201
00202 request = ""
00203 eol = ""
00204 while {1} {
00205 if {[catch { gets $stdin line } result]} {
00206 cleanup "lost connection"
00207 }
00208 if {$result < 0} {
00209 break
00210 }
00211
00212 gotP = 0
00213 foreach c [split $line ""] {
00214 if {($c == " ") || ($c == "\t") || [ctype print $c]} {
00215 if {!$gotP} {
00216 append request $eol
00217 gotP = 1
00218 }
00219 append request $c
00220 }
00221 }
00222 if {!$gotP} {
00223 break
00224 }
00225
00226 eol = "\n"
00227 }
00228 request = [string tolower $request]
00229
00230 getP = 0
00231 foreach param [split $request "\n"] {
00232 if {[string first "get " $param] == 0} {
00233 getP = 1
00234 if {[catch { lindex [split $param " "] 1 } page]} {
00235 cleanup "server supports only HTTP/1.0" 501
00236 }
00237 }
00238 }
00239 if {!$getP} {
00240 cleanup "server supports only GET" 405
00241 }
00242
00243 if {[string first /news? $page] != 0} {
00244 cleanup "page $page unavailable" 504
00245 }
00246 foreach param [split [string range $page 6 end] &] {
00247 if {[ x = [string first = $param]] <= 0} {
00248 cleanup "page $request unavailable" 504
00249 }
00250 key = [string range $param 0 [expr {$x-1}]]
00251 arg = ($key) [string range $param [expr {$x+1}] end]
00252 }
00253
00254 expires = [mime::parsedatetime -now proper]
00255
00256
00257
00258
00259 if {![catch { arg = (index) } index]} {
00260 switch -- $index {
00261 newsgroups {
00262 lastN = 0
00263 }
00264
00265 recent {
00266 lastN = -1
00267 }
00268
00269 default {
00270 cleanup "page $request unavailable" 504
00271 }
00272 }
00273 catch { lastN = $arg(lastn) }
00274
00275 if {[catch { open $options(foldersFile) { RDONLY } } fd]} {
00276 cleanup $fd 505
00277 }
00278
00279 folders = ""
00280 suffix = [lindex [ prefix = [file split \
00281 $options(foldersDirectory)]] \
00282 end]
00283 prefix = [eval [list file join] [lreplace $prefix end end]]
00284
00285 for { lineNo = 1} {[gets $fd line] >= 0} {incr lineNo} {
00286 if {[string first $suffix $line] != 0} {
00287 continue
00288 }
00289 file = [file join $prefix $line]
00290
00291 if {[catch { file stat $file stat } result]} {
00292 tclLog $result
00293
00294 continue
00295 }
00296 if {![string compare $stat(type) file]} {
00297 lappend folders [list [eval [list file join] \
00298 [lrange [file split $line] \
00299 1 end]] \
00300 $stat(mtime)]
00301 }
00302 }
00303
00304 catch {close $fd }
00305
00306 switch -- $index {
00307 recent {
00308 folders = [lsort -integer -decreasing -index 1 $folders]
00309 }
00310
00311 default {
00312 folders = [lsort -dictionary -increasing -index 0 $folders]
00313 }
00314 }
00315
00316 puts stdout "HTTP/1.0 200
00317 Content-Type: text/html
00318 Pragma: no-cache
00319 Expires: $expires
00320
00321 <html><head><title>newsgroups</title></head><body>
00322 <table cellborder=0 cellpadding=0 cellspacing=0>"
00323
00324 foreach entry $folders {
00325 folder = [lindex $entry 0]
00326 t = [fmtclock [ mtime = [lindex $entry 1]] "%m/%d %H:%M"]
00327
00328 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>"
00329 }
00330
00331 puts stdout "</table>
00332 </body></html>"
00333
00334 cleanup
00335 }
00336
00337
00338
00339
00340 if {[catch { arg = (folder) } folder]} {
00341 cleanup "page $request unavailable" 504
00342 }
00343
00344 foreach p [file split $folder] {
00345 if {(![string compare $p ""]) || ([string first . $p] >= 0)} {
00346 cleanup "page $request unavailable" 504
00347 }
00348 }
00349
00350 file = [file join $options(foldersDirectory) $folder]
00351 if {([catch { file type $file } type]) \
00352 || ([string compare $type file])} {
00353 cleanup "page $request unavailable" 504
00354 }
00355 if {[catch { mbox::initialize -file $file } mbox]} {
00356 cleanup $mbox 505
00357 }
00358
00359
00360
00361
00362 if {![catch { arg = (lastn) } lastN]} {
00363 array props = [mbox::getproperty $mbox]
00364
00365 if {$lastN < 0} {
00366 diff = [expr {-($lastN*86400)}]
00367
00368 last = 0
00369 for { msgNo = $props(last)} {$msgNo > 0} {incr msgNo -1} {
00370 if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
00371 tclLog $mime
00372
00373 continue
00374 }
00375
00376 if {[catch { lindex [mime::getheader $mime Date] 0 } value]} {
00377 value = ""
00378 }
00379 if {![catch { mime::parsedatetime $value rclock } rclock]} {
00380 if {$rclock < $diff} {
00381 if {$last == 0} {
00382 last = $msgNo
00383 }
00384 first = $msgNo
00385 }
00386 if {$last == 0} {
00387 break
00388 }
00389 }
00390 }
00391 if {$last > 0} {
00392 last = $props(last)
00393 }
00394 } elseif {[ first = \
00395 [expr {[ last = $props(last)]-($lastN+1)}]] <= 0} {
00396 first = 1
00397 }
00398
00399 puts stdout "HTTP/1.0 200
00400 Content-Type: text/html
00401 Pragma: no-cache
00402 Expires: $expires
00403
00404 <html><head><title>$folder</title></head><body>"
00405
00406 if {$last == 0} {
00407 puts stdout "<b>Empty.</b>
00408 </body></html>"
00409
00410 cleanup
00411 }
00412
00413 puts stdout "<table cellborder=0 cellpadding=0 cellspacing=0>"
00414 for { msgNo = $last} {$msgNo >= $first} {incr msgNo -1} {
00415 if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
00416 tclLog $mime
00417
00418 continue
00419 }
00420
00421 date = ""
00422 catch {
00423 value = [lindex [mime::getheader $mime Date] 0]
00424 append date [format %02d \
00425 [mime::parsedatetime $value mon]] / \
00426 [format %02d [mime::parsedatetime $value mday]] " " \
00427 [format %02d [mime::parsedatetime $value hour]] : \
00428 [format %02d [mime::parsedatetime $value min]]
00429 }
00430 if {![string compare $date ""]} {
00431 date = "unknown date"
00432 }
00433
00434 from = ""
00435 catch {
00436 from = [mutl::firstaddress [mime::getheader $mime From]]
00437
00438 catch { un aprops = }
00439
00440 array aprops = [lindex [mime::parseaddress $from] 0]
00441 from = "<a href='mailto:$aprops(local)@$aprops(domain)'>$aprops(friendly)</a>"
00442 }
00443
00444 subject = ""
00445 catch {
00446 subject = [lindex [mime::getheader $mime Subject] 0]
00447 }
00448
00449 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>"
00450 }
00451 puts stdout "</table>
00452 </body></html>"
00453
00454 cleanup
00455 }
00456
00457
00458
00459
00460 if {![catch { arg = (msgno) } msgNo]} {
00461 if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
00462 cleanup $mime 505
00463 }
00464
00465 if {![string compare [ part = [firstext $mime]] ""]} {
00466 part = $mime
00467 }
00468 switch -- [ content = [mime::getproperty $part content]] {
00469 text/plain {
00470 regsub -all "\n\n" [mime::getbody $part] "<p>" body
00471
00472 result = "<html><head><title>$folder $msgNo</title></head>
00473 <body>$body</body></html>"
00474
00475 }
00476
00477 text/html {
00478 result = [mime::getbody $part]
00479 }
00480
00481 default {
00482 result = "<html><head><title>$folder $msgNo</title></head>
00483 <body>
00484 Message is $content.
00485 </body></html>"
00486 }
00487 }
00488
00489 puts stdout "HTTP/1.0 200
00490 Content-Type: text/html
00491
00492 $result"
00493
00494 cleanup
00495 }
00496
00497
00498 cleanup "page $request unavailable" 504
00499
00500
00501 } result]} {
00502 global errorCode errorInfo
00503
00504 ecode = $errorCode
00505 einfo = $errorInfo
00506
00507 if {(![catch { info body tclLog } result2]) \
00508 && ([string compare [string trim $result2] \
00509 {catch {puts stderr $string}}])} {
00510 catch { tclLog $result }
00511 }
00512
00513 if {![string first "POSIX EPIPE" $ecode]} {
00514 exit 0
00515 }
00516
00517 catch {
00518 smtp::sendmessage \
00519 [mime::initialize \
00520 -canonical text/plain \
00521 -param {char us = -ascii} \
00522 -string "$result\n\nerrorCode: $ecode\n\n$einfo"] \
00523 -originator "" \
00524 -header [list From [id user]@[info hostname]] \
00525 -header [list To operator@[info hostname]] \
00526 -header [list Subject "[info hostname] fatal $program"]
00527 }
00528
00529 cleanup $result
00530 }
00531
00532
00533 exit 75
00534
