From 0430a5d1f638e3ce74b155872aaa35f797541d17 Mon Sep 17 00:00:00 2001
From: Circling Skies <loop@antartida.xyz>
Date: Thu, 12 Dec 2024 19:06:53 -0300
Subject: [PATCH] Uses SHA256 instead of sxhash from now on.

Notice that if a user doesn't change his password, we'll keep using
sxhash forever, which I think is quite okay.  The problem with sxhash
is not only that it's not cryptographic, but different systems will
produce different hashes.  For instance, Windows will produce one hash
and FreeBSD will produce another.  We're better off with something
more deterministic such as SHA256.
---
 loop.asd  |  2 +-
 loop.lisp | 24 +++++++++++++++++++-----
 loop.nw   | 24 +++++++++++++++++++-----
 3 files changed, 39 insertions(+), 11 deletions(-)

diff --git a/loop.asd b/loop.asd
index 3015c42..5793792 100644
--- a/loop.asd
+++ b/loop.asd
@@ -3,5 +3,5 @@
   :version "0.1"
   :description "An NNTP server for a circle of friends."
   :depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
-               :filesystem-utils)
+               :filesystem-utils :ironclad/digest/sha256)
   :components ((:file "loop")))
diff --git a/loop.lisp b/loop.lisp
index 6ecd0cb..bd26ad9 100644
--- a/loop.lisp
+++ b/loop.lisp
@@ -2,7 +2,7 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (ql:quickload 
    '(:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
-     :filesystem-utils)
+     :filesystem-utils :ironclad/digest/sha256)
    :silent t))
 
 (clsql:enable-sql-reader-syntax)
@@ -1111,11 +1111,20 @@
       (setq *accounts* (read s))))
   *accounts*)
 
+(defun string->array (s)
+  (make-array (length s) 
+              :element-type '(unsigned-byte 8)
+              :initial-contents (map 'vector #'char-code s)))
+
+(defun string->sha256 (s)
+  (let ((d (ironclad:make-digest :sha256)))
+    (ironclad:produce-digest (ironclad:update-digest d (string->array s)))))
+
 (defun new-account! (username invited-by)
   (let* ((u (str:upcase username))
          (p (random-string 6))
          (a (make-account :username u
-                          :pass (sxhash (str:upcase p))
+                          :pass (string->sha256 (str:upcase p))
                           :creation (get-universal-time)))) 
     (if (get-account u)
         (values nil (fmt "account ~a already exists" u))
@@ -1212,14 +1221,19 @@
 
 (defun pass? (username pass)
   (let ((u (get-account username)))
-    (and u
-         (eq (sxhash pass) (account-pass u)))))
+    (and 
+     u
+     (cond ((integerp (account-pass u))
+            (eq (sxhash pass) (account-pass u)))
+           ((arrayp (account-pass u))
+            (equal (string->sha256 pass) (account-pass u)))
+           (t (error "pass? expected to find INTEGERP or ARRAYP but found ~a" (type-of (account-pass u))))))))
 
 (defun change-passwd! (username newpass)
   (let ((u (get-account username)))
     (when (not u)
       (error "I could not find account ~a." username))
-    (setf (account-pass u) (sxhash newpass))
+    (setf (account-pass u) (string->sha256 newpass))
     (write-accounts!)))
 
 (defun notify-group-created (g)
diff --git a/loop.nw b/loop.nw
index 91cba24..6e33050 100644
--- a/loop.nw
+++ b/loop.nw
@@ -981,11 +981,20 @@ same check here.
       (setq *accounts* (read s))))
   *accounts*)
 
+(defun string->array (s)
+  (make-array (length s) 
+              :element-type '(unsigned-byte 8)
+              :initial-contents (map 'vector #'char-code s)))
+
+(defun string->sha256 (s)
+  (let ((d (ironclad:make-digest :sha256)))
+    (ironclad:produce-digest (ironclad:update-digest d (string->array s)))))
+
 (defun new-account! (username invited-by)
   (let* ((u (str:upcase username))
          (p (random-string 6))
          (a (make-account :username u
-                          :pass (sxhash (str:upcase p))
+                          :pass (string->sha256 (str:upcase p))
                           :creation (get-universal-time)))) 
     (if (get-account u)
         (values nil (fmt "account ~a already exists" u))
@@ -1121,14 +1130,19 @@ there is a macro emerging here called [[with-upcase-args]]. %% TODO
 
 (defun pass? (username pass)
   (let ((u (get-account username)))
-    (and u
-         (eq (sxhash pass) (account-pass u)))))
+    (and 
+     u
+     (cond ((integerp (account-pass u))
+            (eq (sxhash pass) (account-pass u)))
+           ((arrayp (account-pass u))
+            (equal (string->sha256 pass) (account-pass u)))
+           (t (error "pass? expected to find INTEGERP or ARRAYP but found ~a" (type-of (account-pass u))))))))
 
 (defun change-passwd! (username newpass)
   (let ((u (get-account username)))
     (when (not u)
       (error "I could not find account ~a." username))
-    (setf (account-pass u) (sxhash newpass))
+    (setf (account-pass u) (string->sha256 newpass))
     (write-accounts!)))
 
 @ %def PASSWD pass? change-passwd!
@@ -2660,7 +2674,7 @@ about.
 
 <<List of packages to be loaded>>=
 :lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
-:filesystem-utils
+:filesystem-utils :ironclad/digest/sha256
 @
 
 <<loop.lisp>>=