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