| 1 | module "/pliant/language/unsafe.pli" | |
| 2 | module "/pliant/language/stream.pli" | |
| 3 | module "/pliant/fullpliant/user.pli" | |
| 4 | ||
| 5 | module "/pliant/language/context.pli" | |
| 6 | module "/pliant/fullpliant/this_computer.pli" | |
| 7 | module "/pliant/util/remote/client.pli" | |
| 8 | module "/pliant/admin/md5.pli" | |
| 9 | ||
| 10 | type LoginSlice | |
| 11 | field DateTime from to | |
| 12 | field Str ip comment | |
| 13 | ||
| 14 | gvar (Dictionary Str LoginSlice) slice | |
| 15 | gvar Sem slice_sem | |
| 16 | gvar DateTime purged_on := datetime | |
| 17 | ||
| 18 | ||
| 19 | function write_down u | |
| 20 | arg_rw Data:User2 u | |
| 21 | (var Stream s) open "data:/pliant/login/"+keyof:u append+mkdir+safe | |
| 22 | s writeline (string u:from)+" "+(string u:to)+" "+u:ip+" "+u:comment | |
| 23 | s close | |
| 24 | ||
| 25 | function login_record user ip comment -> accepted | |
| 26 | arg Str user ip comment ; arg CBool accepted | |
| 27 | accepted := true | |
| 28 | plugin login | |
| 29 | var DateTime now := datetime | |
| 30 | # first try with read only lock, even if we might update the data | |
| 31 | slice_sem rd_request | |
| 32 | var Pointer:LoginSlice s :> slice first user | |
| 33 | if exists:s and s:ip=ip and s:comment=comment | |
| 34 | if now:seconds-s:to:seconds<60 | |
| 35 | # less than one minute, do nothing | |
| 36 | slice_sem rd_release | |
| 37 | return | |
| 38 | if now:seconds-s:to:seconds<3600 and s:to:date=now:date | |
| 39 | # more than one minute, just update the 'to' field | |
| 40 | s to := now | |
| 41 | var Data:User2 u :> user_database2:data:user user | |
| 42 | u to := now | |
| 43 | slice_sem rd_release | |
| 44 | return | |
| 45 | slice_sem rd_release | |
| 46 | # start a new slice | |
| 47 | var Data:User2 u :> user_database2:data:user user | |
| 48 | if not exists:u | |
| 49 | user_database2:data:user create user | |
| 50 | u :> user_database2:data:user user | |
| 51 | slice_sem request | |
| 52 | var Pointer:LoginSlice s :> slice first user | |
| 53 | if exists:s | |
| 54 | if s:ip=ip and s:comment=comment and now:seconds-s:to:seconds<60 | |
| 55 | # another thread got in between semaphore rd_release and request | |
| 56 | slice_sem release | |
| 57 | return | |
| 58 | write_down u | |
| 59 | else | |
| 60 | slice insert user (var LoginSlice empty_slice) | |
| 61 | s :> slice first user | |
| 62 | s from := now | |
| 63 | s to := now | |
| 64 | s ip := ip | |
| 65 | s comment := comment | |
| 66 | u from := now | |
| 67 | u to := now | |
| 68 | u ip := ip | |
| 69 | u comment := comment | |
| 70 | if now:seconds-purged_on:seconds>3600 | |
| 71 | var Pointer:LoginSlice s :> slice first | |
| 72 | while exists:s | |
| 73 | if now:seconds-s:to:seconds<3600 | |
| 74 | s :> slice next s | |
| 75 | else | |
| 76 | write_down (user_database2:data:user (slice key s)) | |
| 77 | var Data:User2 u :> user_database2:data:user (slice key s) | |
| 78 | u from := undefined | |
| 79 | s :> slice remove s | |
| 80 | purged_on := datetime | |
| 81 | slice_sem release | |
| 82 | ||
| 83 | ||
| 84 | function startup | |
| 85 | each u user_database2:data:user | |
| 86 | if u:from=defined | |
| 87 | write_down u | |
| 88 | u from := undefined | |
| 89 | startup | |
| 90 | ||
| 91 | ||
| 92 | function is_administrator user -> admin | |
| 93 | arg Str user ; arg CBool admin | |
| 94 | var Data:User u :> user_database:data:user user | |
| 95 | each r u:right | |
| 96 | if r:right="administrator" | |
| 97 | return true | |
| 98 | each t u:template | |
| 99 | each r user_database:data:user:t:right | |
| 100 | if r:right="administrator" | |
| 101 | return true | |
| 102 | admin := false | |
| 103 | ||
| 104 | function is_password_server host -> pp | |
| 105 | arg Str host ; arg CBool pp | |
| 106 | each server this_computer:env:"pliant":"password" | |
| 107 | if (keyof:server parse "server" any) | |
| 108 | if server=host | |
| 109 | return true | |
| 110 | pp := false | |
| 111 | ||
| 112 | function user_update user first_name name email abstract password_md5 public_key language options style_options server -> status | |
| 113 | arg Str user first_name name email abstract password_md5 public_key language options style_options server ; arg Status status | |
| 114 | remote server | |
| 115 | control c is_password_server:c | |
| 116 | control c not is_administrator:user | |
| 117 | share status | |
| 118 | user_database:data:user create user | |
| 119 | user_database2:data:user create user | |
| 120 | user_secret_database:data:user create user | |
| 121 | var Data:User u :> user_database:data:user user | |
| 122 | u first_name := first_name | |
| 123 | u name := name | |
| 124 | u email := email | |
| 125 | u abstract := abstract | |
| 126 | user_secret_database:data:user:user password_md5 := password_md5 | |
| 127 | u public_key := public_key | |
| 128 | u language := language | |
| 129 | u options := options | |
| 130 | u style_options := style_options | |
| 131 | local_streaming s | |
| 132 | each r user_database:data:user:user:right | |
| 133 | s writeline "right "+(string keyof:r)+" "+(string r:auth)+" "+(string r:ip)+" "+(string r:server)+" "+(string r:right) | |
| 134 | each t user_database:data:user:user:template | |
| 135 | s writeline "template "+(string keyof:t)+" "+string:t | |
| 136 | remote_streaming s | |
| 137 | var Data:User u :> user_database:data:user user | |
| 138 | var (Dictionary Str Void) lines templates | |
| 139 | while not s:atend | |
| 140 | var Str l := s readline | |
| 141 | if (l parse "right" (var Str id) (var Str auth) (var Str ip) (var Str server) (var Str right)) | |
| 142 | if right<>"administrator" | |
| 143 | u:right create id | |
| 144 | var Data:UserRight r :> u:right id | |
| 145 | r auth := auth+"3" 0 ; r ip := ip ; r server := server ; r right := right | |
| 146 | lines insert id void | |
| 147 | eif (l parse "template" (var Str id) (var Str template)) | |
| 148 | if not is_administrator:template | |
| 149 | u:template create id | |
| 150 | u:template id := template | |
| 151 | templates insert id void | |
| 152 | each r u:right | |
| 153 | if not exists:(lines first keyof:r) | |
| 154 | u:right delete keyof:r | |
| 155 | each t u:template | |
| 156 | if not exists:(templates first keyof:t) | |
| 157 | u:template delete keyof:t | |
| 158 | success | |
| 159 | status := success | |
| 160 | failure | |
| 161 | status := failure | |
| 162 | ||
| 163 | function user_change_password user password_md5 server -> status | |
| 164 | arg Str user password_md5 server ; arg Status status | |
| 165 | remote server | |
| 166 | control c is_password_server:c | |
| 167 | control c not is_administrator:user | |
| 168 | share status | |
| 169 | user_secret_database:data:user:user password_md5 := password_md5 | |
| 170 | success | |
| 171 | status := success | |
| 172 | failure | |
| 173 | status := failure | |
| 174 | ||
| 175 | function user_delete user server -> status | |
| 176 | arg Str user server ; arg Status status | |
| 177 | remote server | |
| 178 | control c is_password_server:c | |
| 179 | control c not is_administrator:user | |
| 180 | share status | |
| 181 | user_database:data:user delete user | |
| 182 | user_database2:data:user delete user | |
| 183 | user_secret_database:data:user delete user | |
| 184 | success | |
| 185 | status := success | |
| 186 | failure | |
| 187 | status := failure | |
| 188 | ||
| 189 | ||
| 190 | function user_update user -> status | |
| 191 | arg Str user ; arg ExtendedStatus status | |
| 192 | status := success | |
| 193 | each c this_computer:env:"pliant":"password" | |
| 194 | if (keyof:c parse "client" any) and c<>computer_fullname | |
| 195 | var Data:User u :> user_database:data:user user | |
| 196 | if (user_update user u:first_name u:name u:email u:abstract user_secret_database:data:user:user:password_md5 u:public_key u:language u:options u:style_options c)=failure | |
| 197 | status := failure "Failed to forward changes to server "+c | |
| 198 | ||
| 199 | ||
| 200 | export login_record | |
| 201 | export user_update user_change_password user_delete | |