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 {\<} 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