1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
|
# 26mar10abu
# (c) Software Lab. Alexander Burger
# *Login *Users *Perms
### Login ###
(de login (Nm Pw)
(ifn (setq *Login (db 'nm '+User Nm 'pw Pw))
(msg *Pid " ? " Nm)
(msg *Pid " * " (stamp) " " Nm)
(tell 'hi *Pid Nm *Adr)
(push1 '*Bye '(logout))
(push1 '*Fork '(del '(logout) '*Bye))
(timeout (setq *Timeout `(* 3600 1000))) )
*Login )
(de logout ()
(when *Login
(rollback)
(off *Login)
(tell 'hi *Pid)
(msg *Pid " / " (stamp))
(timeout (setq *Timeout `(* 300 1000))) ) )
(de hi (Pid Nm Adr)
(if (and (= Nm (get *Login 'nm)) (= Adr *Adr))
(bye)
(hi2 Pid Nm)
(tell 'hi2 *Pid (get *Login 'nm)) ) )
(de hi2 (Pid Nm)
(if2 Nm (lup *Users Pid)
(con @ Nm)
(idx '*Users (cons Pid Nm) T)
(idx '*Users @ NIL) ) )
### Role ###
(class +Role +Entity)
(rel nm (+Need +Key +String)) # Role name
(rel perm (+List +Symbol)) # Permission list
(rel usr (+List +Joint) role (+User)) # Associated users
### User ###
(class +User +Entity)
(rel nm (+Need +Key +String)) # User name
(rel pw (+String)) # Password
(rel role (+Joint) usr (+Role)) # User role
### Permission management ###
(de permission Lst
(while Lst
(queue '*Perms (car Lst))
(def (pop 'Lst) (pop 'Lst)) ) )
(de may Args
(mmeq Args (get *Login 'role 'perm)) )
(de must Args
(unless
(if (cdr Args)
(mmeq @ (get *Login 'role 'perm))
*Login )
(msg *Pid " No permission: " (car Args))
(forbidden) ) )
# vi:et:ts=3:sw=3
|