1# webservice.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
2#
3#
4#
5# -------------------------------------------------------------------------
6# This software is distributed in the hope that it will be useful, but
7# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
8# or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
9# for more details.
10# -------------------------------------------------------------------------
11#
12# @(#)$Id: webservice.tcl,v 1.1 2001/08/03 21:36:42 patthoyts Exp $
13
14package require SOAP
15package require rpcvar
16namespace import -force rpcvar::*
17
18set scriptdir  webservice.scripts
19set admindir   webservice.admin
20set lockfile   [file join $admindir webservice.lock]
21set userfile   [file join $admindir webservice.users]
22set actionfile [file join $admindir webservice.actions]
23set actionmap  [file join $admindir webservice.map]
24
25namespace eval urn:tclsoap:webservices {
26
27    SOAP::export register unregister save read
28
29    proc register {email passwd action} {
30	global usertbl
31	global useract
32	global actiontbl
33
34	auth::map_lock
35	set failed [catch {
36	    auth::map_parse
37	    if {! [info exists usertbl($email)]} {
38		# new user
39		if {[info exists actiontbl($action)]} {
40		    error "registration failed: \
41			    SOAPAction \"$action\" has already been registered" \
42			    {} Client
43		}
44		set usertbl($email) $passwd
45		set actiontbl($action) [auth::safeaction $action]
46		set useract($email) $action
47
48	    } else {
49		# registered user - new action
50		auth::authorise $email $passwd new
51		if {$action == {}} {
52		    error "registration failed: \
53			    SOAPAction \"\" is not permitted." () Client
54		}
55		if {[info exists actiontbl($action)]} {
56		    error "registration failed: \
57			    SOAPAction \"$action\" has already been registered" \
58			    {} Client
59		}
60		set actiontbl($action) [auth::safeaction $action]
61		lappend useract($email) $action
62	    }
63	    auth::map_update
64	} err]
65	auth::map_unlock
66	if {$failed} {
67	    return -code error $err
68	}
69	return [rpcvar boolean true]
70    }
71
72    proc save {email passwd action filedata} {
73	auth::map_lock
74	auth::map_parse
75	auth::map_unlock
76	auth::authorise $email $passwd $action
77	set filename [auth::actionfile $action]
78	set f [open [file join $::scriptdir $filename] w]
79	puts $f $filedata
80	close $f
81	return [rpcvar boolean true]
82    }
83
84    proc read {email passwd action} {
85	auth::map_lock
86	auth::map_parse
87	auth::map_unlock
88	auth::authorise $email $passwd $action
89	set filename [auth::actionfile $action]
90	set f [open [file join $::scriptdir $filename] r]
91	set data [::read $f]
92	close $f
93	return $data
94    }
95
96    proc unregister {email passwd action} {
97	error "not implemented" {} Server
98    }
99
100    namespace eval auth {
101
102	proc authorise {email passwd action} {
103	    global usertbl
104	    global useract
105	    if {! [info exists usertbl($email)]} {
106		error "authorisation failed: \
107			invalid username or password" {} Client
108	    }
109	    if {! [string match $usertbl($email) $passwd]} {
110		error "authorisation failed: \
111			invalid username or password" {} Client
112	    }
113	    if {$action != "new"} {
114		if {[lsearch -exact $useract($email) $action] == -1} {
115		    error "authorisation failed: \
116			    action not registered to your account." {} Client
117		}
118	    }
119	    return
120	}
121
122	proc actionfile {action} {
123	    global actiontbl
124	    if {! [info exists actiontbl($action)]} {
125		error "invalid SOAPAction specified:\
126			\"$action\" is not a registered namespace." {} Client
127	    }
128	    return $actiontbl($action)
129	}
130
131	proc safeaction {action} {
132	    set name {}
133	    set action [string map {: _ / ^} $action]
134	    foreach c [split $action {}] {
135		if {[string is wordchar $c] || [string match {[-_^.]} $c]} {
136		    append name $c
137		}
138	    }
139	    return $name
140	}
141
142	proc map_lock {} {
143	    global lockfile
144	    for {set try 0} {$try < 10} {incr try} {
145		set failed [catch {open $lockfile {WRONLY EXCL CREAT}} lock]
146		if {! $failed} {
147		    puts $lock [pid]
148		    close $lock
149		    return
150		}
151		after 100
152	    }
153	    error "failed to obtain lock: please try again." {} Client
154	}
155
156	proc map_unlock {} {
157	    global lockfile
158	    catch {file delete $lockfile}
159	}
160
161	proc map_parse {} {
162	    map_parse_userfile
163	    map_parse_actionfile
164	}
165
166	proc map_parse_userfile {} {
167	    global userfile
168	    global usertbl
169	    if {! [file exists $userfile]} {
170		set f [open $userfile {RDONLY CREAT}]
171	    } else {
172		set f [open $userfile r]
173	    }
174
175	    while {! [eof $f]} {
176		if {[gets $f line] > 0} {
177		    set line [split $line "\t"]
178		    set usertbl([lindex $line 0]) [lindex $line 1]
179		}
180	    }
181	    close $f
182	}
183
184	proc map_parse_actionfile {} {
185	    global actionfile
186	    global useract
187	    global actiontbl
188	    if {! [file exists $actionfile]} {
189		set f [open $actionfile {RDONLY CREAT}]
190	    } else {
191		set f [open $actionfile r]
192	    }
193
194	    while {! [eof $f]} {
195		if {[gets $f line] > 0} {
196		    set line [split $line "\t"]
197		    set useract([lindex $line 0]) [lindex $line 1]
198		    foreach action [lindex $line 1] {
199			set actiontbl($action) [safeaction $action]
200		    }
201		}
202	    }
203	    close $f
204	}
205
206	proc map_update {} {
207	    global userfile
208	    global actionfile
209	    global actionmap
210	    global usertbl
211	    global useract
212
213	    set f [open $userfile w]
214	    foreach email [array names usertbl] {
215		puts $f "$email\t$usertbl($email)"
216	    }
217	    close $f
218
219	    set f [open $actionfile w]
220	    set g [open $actionmap w]
221	    foreach email [array names useract] {
222		puts $f "$email\t$useract($email)"
223		foreach action $useract($email) {
224		    puts $g "$action\t[safeaction $action]\t$email"
225		}
226	    }
227	    close $g
228	    close $f
229
230	    return
231	}
232    }
233}
234
235#
236# Local variables:
237# mode: tcl
238# End:
239