From a2a8474e938e2528e5087cf36978132329941446 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Sat, 24 Aug 2024 19:54:02 +0200
Subject: [PATCH] first basic version of HS256 signing (for JWT creation)

---
 shape/shape.lisp    | 10 +++++-----
 test/test-core.lisp |  3 +++
 util.lisp           | 38 ++++++++++++++++++++++++++++++--------
 3 files changed, 38 insertions(+), 13 deletions(-)

diff --git a/shape/shape.lisp b/shape/shape.lisp
index 690b8db..b41fede 100644
--- a/shape/shape.lisp
+++ b/shape/shape.lisp
@@ -21,12 +21,12 @@
   (setf (slot-value rec 'head) (util:rfill (head-fields rec) head)))
 
 (defmethod print-object ((rec record) stream)
-  (print-unreadable-object (rec stream :type t)
-    (format-fields rec stream 'head 'data)))
+  (print-fields rec stream 'head 'data))
 
-(defun format-fields (item stream &rest fields)
-  (let ((fm (format nil "~{~(~a~): ~~S ~}" fields)))
-    (apply #'format stream fm (mapcar #'(lambda (x) (funcall x item)) fields))))
+(defun print-fields (rec stream &rest fields)
+  (let ((fm (util:make-vars-format fields)))
+    (print-unreadable-object (rec stream :type t)
+      (apply #'format stream fm (mapcar #'(lambda (x) (funcall x rec)) fields)))))
 
 (defun head-value (rec key)
   (elt (head rec) (position key (head-fields rec))))
diff --git a/test/test-core.lisp b/test/test-core.lisp
index bff2672..9263d2c 100644
--- a/test/test-core.lisp
+++ b/test/test-core.lisp
@@ -63,6 +63,9 @@
       (t:show-result))))
 
 (deftest test-util ()
+  (util:lgi (util:create-secret))
+  (let ((now (get-universal-time)))
+    (== (util:from-unix-time (util:to-unix-time now)) now))
   (== (util:rfill '(1 2 3 4 5) '(a b c)) '(a b c nil nil))
   (== (util:rtrim '(1 2 nil 3 nil)) '(1 2 nil 3)) 
   (== (util:to-keyword "hello-kitty") :hello-kitty)
diff --git a/util.lisp b/util.lisp
index 8b41c19..13d2ab1 100644
--- a/util.lisp
+++ b/util.lisp
@@ -4,8 +4,9 @@
   (:use :common-lisp)
   (:local-nicknames (:b64 :qbase64))
   #+sbcl (:import-from :sb-ext #:add-package-local-nickname)
-  (:export #:lg #:lgd #:lgi
-           #:create-secret #:digest
+  (:export #:make-vars-format #:lg #:lgd #:lgi
+           #:from-unix-time #:to-unix-time
+           #:create-secret #:digest #:sign
            #:rfill #:rtrim #:loop-plist #:filter-plist #:plist-pairs #:plist-equal
            #:flatten-str #:to-keyword #:keyword-to-string #:to-integer #:to-string
            #:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string
@@ -14,27 +15,48 @@
 
 (in-package :scopes/util)
 
-;;;; logging shortcuts
+;;;; formatting and logging shortcuts
+
+(defun make-vars-format (vars)
+  (format nil "~{~(~a~): ~~S ~}" vars))
 
 (defmacro lg (level &rest vars)
   (let ((lm (find-symbol (string level) :log))
-        (fm (format nil "~{~(~a~): ~~S ~}" vars)))
+        (fm (make-vars-format vars)))
     `(,lm ,fm ,@vars)))
 
 (defmacro lgd (&rest vars) `(lg :debug ,@vars))
 (defmacro lgi (&rest vars) `(lg :info ,@vars))
 
+;;;; date and time manipulations
+
+(defconstant *unix-time-base* (encode-universal-time 0 0 0 1 1 1970 0))
+
+(defun from-unix-time (time)
+  (when time (+ time *unix-time-base*)))
+
+(defun to-unix-time (time)
+  (when time (- time *unix-time-base*)))
+
 ;;;; secrets, digests, and other crypto stuff
 
-(defun create-secret ()
-  (b64:encode-bytes (ironclad:random-data 16)))
+(defun create-secret (&key (bytes 16) (scheme :original))
+  (b64:encode-bytes (ironclad:random-data bytes) :scheme scheme))
 
-(defun digest (pw &key (scheme :original) (alg :sha256))
+(defun digest (tx &key (scheme :original) (alg :sha256))
   (b64:encode-bytes
     (ironclad:digest-sequence alg 
-      (flexi-streams:string-to-octets pw :external-format :utf8))
+      (flexi-streams:string-to-octets tx :external-format :utf8))
     :scheme scheme))
 
+(defun sign (tx key)
+  (let* ((binp (flexi-streams:string-to-octets tx :external-format :utf8))
+         (bkey (make-array 16 :element-type '(unsigned-byte 8)
+                          :initial-contents (b64:decode-string key)))
+         (mac (ironclad:make-mac :hmac bkey :sha256)))
+    (ironclad:update-mac mac binp)
+    (b64:encode-bytes (ironclad:hmac-digest mac) :scheme :uri)))
+
 ;;;; lists and loops
 
 (defun rfill (ll ls)