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