picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

adm.l (2976B)

      1 # 30may13abu
      2 # (c) Software Lab. Alexander Burger
      3 
      4 # *Salt *Login *Users *Perms
      5 
      6 # crypt(3) algorithm, e.g. (setq *Salt (16 . "$6$@1$"))
      7 (de passwd (Str Salt)
      8    (if *Salt
      9       `(if (== 64 64)
     10          '(native "libcrypt.so" "crypt" 'S Str (or Salt (salt)))
     11          '(ext:Crypt Str (or Salt (salt))) )
     12       Str ) )
     13 
     14 (de salt ()
     15    (text (cdr *Salt) (randpw (car *Salt))) )
     16 
     17 (de randpw (Len)
     18    (make
     19       (in "/dev/urandom"
     20          (do Len
     21             (link
     22                (get
     23                   '`(mapcar char
     24                      (conc
     25                         (range 46 57)
     26                         (range 65 90)
     27                         (range 97 122) ) )
     28                   (inc (& 63 (rd 1))) ) ) ) ) ) )
     29 
     30 (de auth (Nm Pw)
     31    (with (db 'nm '+User Nm)
     32       (and
     33          (: pw 0)
     34          (= @ (passwd Pw @))
     35          This ) ) )
     36 
     37 ### Login ###
     38 (de login (Nm Pw)
     39    (ifn (setq *Login (auth Nm Pw))
     40       (msg *Pid " ? " Nm)
     41       (msg *Pid " * " (stamp) " " Nm)
     42       (tell 'hi *Pid Nm *Adr)
     43       (push1 '*Bye '(logout))
     44       (push1 '*Fork '(del '(logout) '*Bye))
     45       (timeout (setq *Timeout `(* 3600 1000))) )
     46    *Login )
     47 
     48 (de logout ()
     49    (when *Login
     50       (rollback)
     51       (off *Login)
     52       (tell 'hi *Pid)
     53       (msg *Pid " / " (stamp))
     54       (timeout (setq *Timeout `(* 300 1000))) ) )
     55 
     56 (de hi (Pid Nm Adr)
     57    (if (and (= Nm (get *Login 'nm)) (= Adr *Adr))
     58       (bye)
     59       (hi2 Pid Nm)
     60       (tell 'hi2 *Pid (get *Login 'nm)) ) )
     61 
     62 (de hi2 (Pid Nm)
     63    (if2 Nm (lup *Users Pid)
     64       (con @ Nm)
     65       (idx '*Users (cons Pid Nm) T)
     66       (idx '*Users @ NIL) ) )
     67 
     68 
     69 ### Role ###
     70 (class +Role +Entity)
     71 
     72 (rel nm (+Need +Key +String))          # Role name
     73 (rel perm (+List +Symbol))             # Permission list
     74 (rel usr (+List +Joint) role (+User))  # Associated users
     75 
     76 
     77 ### User ###
     78 (class +User +Entity)
     79 
     80 (rel nm (+Need +Key +String))          # User name
     81 (rel pw (+Swap +String))               # Password
     82 (rel role (+Joint) usr (+Role))        # User role
     83 
     84 
     85 ### Permission management ###
     86 (de permission Lst
     87    (while Lst
     88       (queue '*Perms (car Lst))
     89       (def (pop 'Lst) (pop 'Lst)) ) )
     90 
     91 (de may Args
     92    (mmeq Args (get *Login 'role 'perm)) )
     93 
     94 (de must Args
     95    (unless
     96       (if (cdr Args)
     97          (mmeq @ (get *Login 'role 'perm))
     98          *Login )
     99       (msg *Pid " No permission: " (car Args))
    100       (forbidden) ) )
    101 
    102 ### GUI ###
    103 (de loginForm "Opt"
    104    (form NIL
    105       (htPrin "Opt")
    106       (<grid> 2
    107          ,"Name" (gui 'nm '(+Focus +Able +TextField) '(not *Login) 20)
    108          ,"Password" (gui 'pw '(+Able +PwField) '(not *Login) 20) )
    109       (--)
    110       (gui '(+Button) '(if *Login ,"logout" ,"login")
    111          '(cond
    112             (*Login (logout))
    113             ((login (val> (: home nm)) (val> (: home pw)))
    114                (clr> (: home pw)) )
    115             (T (error ,"Permission denied")) ) )
    116       (when *Login
    117          (<nbsp> 4)
    118          (<span> "bold green"
    119             (<big> (ht:Prin "'" (; *Login nm) ,"' logged in")) ) ) ) )
    120 
    121 # vi:et:ts=3:sw=3