picolisp

commit 3f5543629dbdf86e996049584e9d7ce79fdbaf91
parent a24a7c2df15a1e47d03cdf0928e06f48e5a998d3
Author: Alexander Burger <abu@software-lab.de>
Date:   Mon, 21 Jan 2013 17:47:34 +0100

Password hashing
Diffstat:
M
CHANGES
 | 
1
+
M
app/user.l
 | 
7
+++++--
M
lib/adm.l
 | 
36
+++++++++++++++++++++++++++++++++---

3 files changed, 39 insertions(+), 5 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
 * DDmmm13 picoLisp-3.1.2
+   Password hashing
    'usec' optional 'flg' argument
    JavaScript 'rd' in "lib/plio.js"
    'bytes' function
diff --git a/app/user.l b/app/user.l
@@ -1,4 +1,4 @@
-# 05jan12abu
+# 21jan13abu
 # (c) Software Lab. Alexander Burger
 
 (must "User Administration" UserAdmin)
@@ -13,7 +13,10 @@
             '(may Password)
             '(pw : home obj)
             '((V) (and V "****"))
-            '((V) (if (= V "****") (: home obj pw) V))
+            '((V)
+               (if (= V "****")
+                  (: home obj pw)
+                  (passwd V (: home obj pw)) ) )
             30 )
          ,"Role"
          (gui '(+Able +E/R +Obj +TextField)
diff --git a/lib/adm.l b/lib/adm.l
@@ -1,11 +1,41 @@
-# 26mar10abu
+# 21jan13abu
 # (c) Software Lab. Alexander Burger
 
-# *Login *Users *Perms
+# *Salt *Login *Users *Perms
+
+# 'crypt' algorithm, e.g. (16 . "$6$@1$")
+(default *Salt (2 . "@1"))
+
+(de salt ()
+   (text (cdr *Salt)
+      (make
+         (in "/dev/urandom"
+            (do (car *Salt)
+               (link
+                  (get
+                     '`(mapcar char
+                        (conc
+                           (range 46 57)
+                           (range 65 90)
+                           (range 97 122) ) )
+                     (& 63 (rd 1)) ) ) ) ) ) ) )
+
+(de passwd (Str Pw)
+   (if (and native *Salt)
+      (native "libcrypt.so" "crypt" 'S Str (or Pw (salt)))
+      Str ) )
+
+(de auth (Nm Pw)
+   (with (db 'nm '+User Nm)
+      (and
+         (or
+            (= (: pw) Pw)
+            (= (: pw) (passwd (: pw) Pw)) )
+         This ) ) )
 
 ### Login ###
 (de login (Nm Pw)
-   (ifn (setq *Login (db 'nm '+User Nm 'pw Pw))
+   (ifn (setq *Login (auth Nm Pw))
       (msg *Pid " ? " Nm)
       (msg *Pid " * " (stamp) " " Nm)
       (tell 'hi *Pid Nm *Adr)