1# -*- tcl -*- 2# pop3d_dbox.tcl -- 3# 4# Implementation of a simple mailbox database for the pop3 server 5# Each mailbox is a a directory in a base directory, with each mail 6# a file in that directory. The mail file contains both headers and 7# body of the mail. 8# 9# Copyright (c) 2002 by Andreas Kupries 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13# 14# RCS: @(#) $Id: pop3d_dbox.tcl,v 1.12 2005/09/28 04:51:23 andreas_kupries Exp $ 15 16package require mime ; # tcllib | mime token is result of "get". 17package require log ; # tcllib | Logging package 18 19namespace eval ::pop3d::dbox { 20 # Data storage in the pop3d::dbox module 21 # ------------------------------------- 22 # One array per object containing the db contents. Keyed by user name. 23 # And the information about the last file data was read from. 24 25 # counter is used to give a unique name for unnamed databases 26 variable counter 0 27 28 # commands is the list of subcommands recognized by the server 29 variable commands [list \ 30 "add" \ 31 "base" \ 32 "dele" \ 33 "destroy" \ 34 "exists" \ 35 "get" \ 36 "list" \ 37 "lock" \ 38 "locked" \ 39 "move" \ 40 "remove" \ 41 "size" \ 42 "stat" \ 43 "unlock" \ 44 ] 45 46 variable version ; set version 1.0.2 47} 48 49 50# ::pop3d::dbox::new -- 51# 52# Create a new mailbox database with a given name; 53# if no name is given, use 54# p3dboxX, where X is a number. 55# 56# Arguments: 57# name name of the mailbox database; if null, generate one. 58# 59# Results: 60# name name of the mailbox database created 61 62proc ::pop3d::dbox::new {{name ""}} { 63 variable counter 64 65 if { [llength [info level 0]] == 1 } { 66 incr counter 67 set name "p3dbox${counter}" 68 } 69 70 if { ![string equal [info commands ::$name] ""] } { 71 return -code error \ 72 "command \"$name\" already exists,\ 73 unable to create mailbox database" 74 } 75 76 # Set up the namespace 77 namespace eval ::pop3d::dbox::dbox::$name { 78 variable dir "" 79 variable state ; array set state {} 80 variable locked ; array set locked {} 81 variable transfer ; array set transfer {} 82 } 83 84 # Create the command to manipulate the mailbox database 85 interp alias {} ::$name {} ::pop3d::dbox::DboxProc $name 86 87 return $name 88} 89 90########################## 91# Private functions follow 92 93# ::pop3d::dbox::DboxProc -- 94# 95# Command that processes all mailbox database object commands. 96# 97# Arguments: 98# name name of the mailbox database object to manipulate. 99# args command name and args for the command 100# 101# Results: 102# Varies based on command to perform 103 104proc ::pop3d::dbox::DboxProc {name {cmd ""} args} { 105 106 # Do minimal args checks here 107 if { [llength [info level 0]] == 2 } { 108 return -code error \ 109 "wrong # args: should be \"$name option ?arg arg ...?\"" 110 } 111 112 # Split the args into command and args components 113 if { [llength [info commands ::pop3d::dbox::_$cmd]] == 0 } { 114 variable commands 115 set optlist [join $commands ", "] 116 set optlist [linsert $optlist "end-1" "or"] 117 return -code error "bad option \"$cmd\": must be $optlist" 118 } 119 eval [list ::pop3d::dbox::_$cmd $name] $args 120} 121 122 123proc ::pop3d::dbox::_base {name base} { 124 # @c Constructor. Does some more checks on the given base directory. 125 126 # sanity checks 127 if {$base == {}} { 128 return -code error "directory not specified" 129 } 130 if {! [file exists $base]} { 131 return -code error "base: \"$base\" does not exist" 132 } 133 if {! [file isdirectory $base]} { 134 return -code error "base: \"$base\" not a directory" 135 } 136 if {! [file readable $base]} { 137 return -code error "base: \"$base\" not readable" 138 } 139 if {! [file writable $base]} { 140 return -code error "base: \"$base\" not writable" 141 } 142 143 upvar ::pop3d::dbox::dbox::${name}::dir dir 144 set dir $base 145 return 146} 147 148 149# ::pop3d::dbox::_destroy -- 150# 151# Destroy a mail database, including its associated command and 152# data storage. 153# 154# Arguments: 155# name Name of the database to destroy. 156# 157# Results: 158# None. 159 160proc ::pop3d::dbox::_destroy {name} { 161 namespace delete ::pop3d::dbox::dbox::$name 162 interp alias {} ::$name {} 163 return 164} 165 166proc ::pop3d::dbox::_add {name mbox} { 167 # @c Create a mailbox with handle <a mbox>. The handle is used as the 168 # @c name of the directory to contain the mails too. 169 # 170 # @a mbox: Reference to the mailbox to be operated on. 171 172 set dir [CheckDir $name] 173 set mboxpath [file join $dir $mbox] 174 175 if {[file exists $mboxpath]} { 176 return -code error "cannot add \"$mbox\", mailbox already in existence" 177 } 178 179 file mkdir $mboxpath 180 return 181} 182 183 184proc ::pop3d::dbox::_remove {name mbox} { 185 # @c Remove mailbox with handle <a mbox>. This will destroy all mails 186 # @c contained in it too. 187 # 188 # @a mbox: Reference to the mailbox to be operated on. 189 190 set dir [CheckDir $name] 191 set mboxpath [file join $dir $mbox] 192 193 if {![file exists $mboxpath]} { 194 return -code error "cannot remove \"$mbox\", mailbox does not exist" 195 } 196 197 if {[_locked $name $mbox]} { 198 return -code error "cannot remove \"$mbox\", mailbox is locked" 199 } 200 201 file delete -force $mboxpath 202 return 203} 204 205 206proc ::pop3d::dbox::_move {name old new} { 207 # @c Change the handle of mailbox <a old> to <a new>. 208 # 209 # @a old: Reference to the mailbox to be operated on. 210 # @a new: New reference to the mailbox 211 212 set dir [CheckDir $name] 213 set oldpath [file join $dir $old] 214 set newpath [file join $dir $new] 215 216 if {![file exists $oldpath]} { 217 return -code error "cannot move \"$old\", mailbox does not exist" 218 } 219 if {[file exists $newpath]} { 220 return -code error \ 221 "cannot move \"$old\", destination \"$new\" already exists" 222 } 223 224 file rename -force $oldpath $newpath 225 return 226} 227 228 229proc ::pop3d::dbox::_list {name} { 230 # @c Lists known mailboxes in object. 231 # @r List of mailbox names. 232 233 set dir [CheckDir $name] 234 set here [pwd] 235 cd $dir 236 set files [glob -nocomplain *] 237 cd $here 238 239 set res [list] 240 foreach f $files { 241 set mboxpath [file join $dir $f] 242 if {! [file isdirectory $mboxpath]} {continue} 243 if {! [file readable $mboxpath]} {continue} 244 if {! [file writable $mboxpath]} {continue} 245 lappend res $f 246 } 247 return $res 248} 249 250 251proc ::pop3d::dbox::_exists {name mbox} { 252 # @c Determines existence of mailbox <a mbox>. 253 # @a mbox: Reference to the mailbox to check for. 254 # @r 1 if the mailbox exists, 0 else. 255 256 set dir [CheckDir $name] 257 set mbox [file join $dir $mbox] 258 return [file exists $mbox] 259} 260 261 262proc ::pop3d::dbox::_locked {name mbox} { 263 # @c Checks wether the specified mailbox is locked or not. 264 # @a mbox: Reference to the mailbox to check. 265 # @r 1 if the mailbox is locked, 0 else. 266 267 set dir [CheckDir $name] 268 set mbox [file join $dir $mbox] 269 270 upvar ::pop3d::dbox::dbox::${name}::locked locked 271 272 return [::info exists locked($mbox)] 273} 274 275 276# -- interface to the pop server (storage callback) -- 277 278proc ::pop3d::dbox::_lock {name mbox} { 279 # @c Locks the given mailbox, additionally stores a list of the 280 # @c available files in the manager state. All files (= messages) 281 # @c added to the mailbox after this operation will be ignored 282 # @c during the session. 283 # 284 # @a mbox: Reference to the mailbox to be locked. 285 # @r 1 if mailbox was locked sucessfully, 0 else. 286 287 # locked already ? 288 if {[_locked $name $mbox]} { 289 return 0 290 } 291 292 set dir [Check $name $mbox] 293 294 # Compute a list of message files residing in the mailbox directory 295 296 upvar ::pop3d::dbox::dbox::${name}::state state 297 upvar ::pop3d::dbox::dbox::${name}::locked locked 298 299 set state($dir) [lsort [glob -nocomplain [file join $dir *]]] 300 set locked($dir) 1 301 return 1 302} 303 304 305proc ::pop3d::dbox::_unlock {name mbox} { 306 # @c A locked mailbox is unlocked, thereby made available 307 # @c to other sessions. 308 # 309 # @a mbox: Reference to the mailbox to be locked. 310 311 # not locked ? 312 if {![_locked $name $mbox]} {return} 313 set dir [Check $name $mbox] 314 315 upvar ::pop3d::dbox::dbox::${name}::state state 316 upvar ::pop3d::dbox::dbox::${name}::locked locked 317 318 unset state($dir) 319 unset locked($dir) 320 return 321} 322 323 324proc ::pop3d::dbox::_stat {name mbox} { 325 # @c Determines the number of messages picked up by <m lock>. 326 # @c Will fail if the mailbox was not locked. 327 # 328 # @a mbox: Reference to the mailbox queried. 329 # @r The number of messages in the mailbox 330 331 set dir [Check $name $mbox] 332 333 if {![_locked $name $mbox]} { 334 return -code error "mailbox \"$mbox\" is not locked" 335 } 336 337 upvar ::pop3d::dbox::dbox::${name}::state state 338 339 return [llength $state($dir)] 340} 341 342 343proc ::pop3d::dbox::_size {name mbox {msgId {}}} { 344 # @c Determines the size of the specified message, in bytes. 345 # 346 # @a mbox: Reference to the mailbox to be operated on. 347 # @a msgId: Numerical index of the message to look at. 348 # @r size of the message in bytes. 349 350 log::log debug "$name size $mbox ($msgId)" 351 352 set dir [Check $name $mbox] 353 354 log::log debug "$name mbox dir = $dir" 355 356 upvar ::pop3d::dbox::dbox::${name}::state state 357 358 if {$msgId == {}} { 359 log::log debug "$name size /full" 360 361 # Full size of the maildrop requested. 362 if {![info exists state($dir)]} { 363 # No stat before size, assume that there are no messages 364 # in the maildrop, which implies that the maildrop is 365 # empty, i.e. of size 0. 366 return 0 367 } 368 369 set n 0 370 set k [llength $state($dir)] 371 for {set id 0} {$id < $k} {incr id} { 372 incr n [file size [lindex $state($dir) $id]] 373 } 374 return $n 375 } 376 377 if { 378 ($msgId < 1) || 379 (![info exists state($dir)]) || 380 ([llength $state($dir)] < $msgId) 381 } { 382 return -code error "id \"$msgId\" out of range" 383 } 384 incr msgId -1 385 386 ## log::log debug "$name msg mails = $state($dir)" 387 log::log debug "$name msg file = [lindex $state($dir) $msgId]" 388 389 return [file size [lindex $state($dir) $msgId]] 390} 391 392 393proc ::pop3d::dbox::_dele {name mbox msgList} { 394 # @c Deletes the specified messages from the mailbox. This should 395 # @c be followed by a <m unlock> as the state is not updated 396 # @c accordingly. 397 # 398 # @a mbox: Reference to the mailbox to be operated on. 399 # @a msgList: List of message ids. 400 401 set dir [Check $name $mbox] 402 if {[llength $msgList] == 0} { 403 return -code error "nothing to delete" 404 } 405 406 # @d The code assumes that the id's in the list were already 407 # @d checked against the maximal number of messages. 408 409 upvar ::pop3d::dbox::dbox::${name}::state state 410 411 foreach msgId $msgList { 412 if { 413 ($msgId < 1) || 414 (![info exists state($dir)]) || 415 ([llength $state($dir)] < $msgId) 416 } { 417 return -code error "id \"$msgId\" out of range" 418 } 419 } 420 foreach msgId $msgList { 421 file delete [lindex $state($dir) [incr msgId -1]] 422 } 423 424 # the mailbox state is unusable now. 425 return 426} 427 428proc ::pop3d::dbox::_get {name mbox msgId} { 429 set dir [Check $name $mbox] 430 431 upvar ::pop3d::dbox::dbox::${name}::state state 432 433 if { 434 ($msgId < 1) || 435 (![info exists state($dir)]) || 436 ([llength $state($dir)] < $msgId) 437 } { 438 return -code error "id \"$msgId\" out of range" 439 } 440 incr msgId -1 441 442 set mailfile [lindex $state($dir) $msgId] 443 444 set token [::mime::initialize -file $mailfile] 445 return $token 446} 447 448########################### 449########################### 450# Internal helper commands. 451 452proc ::pop3d::dbox::Check {name mbox} { 453 # @c Internal procedure. Used to map a mailbox handle 454 # @c to the directory containing the messages. 455 # @a mbox: Reference to the mailbox to be operated on. 456 # @r Path of directory holding the message files of the 457 # @r specified mailbox. 458 459 set dir [CheckDir $name] 460 set mboxpath [file join $dir $mbox] 461 462 if {! [file exists $mboxpath]} { 463 return -code error "\"$mbox\" does not exist" 464 } 465 if {! [file isdirectory $mboxpath]} { 466 return -code error "\"$mbox\" is not a directory" 467 } 468 if {! [file readable $mboxpath]} { 469 return -code error "\"$mbox\" is not readable" 470 } 471 if {! [file writable $mboxpath]} { 472 return -code error "\"$mbox\" is not writable" 473 } 474 return $mboxpath 475} 476 477proc ::pop3d::dbox::CheckDir {name} { 478 upvar ::pop3d::dbox::dbox::${name}::dir dir 479 480 if {$dir == {}} { 481 return -code error "base directory not specified" 482 } 483 return $dir 484} 485 486########################## 487# Module initialization 488 489package provide pop3d::dbox $::pop3d::dbox::version 490