Coverage report: /home/ellis/comp/core/lib/cry/jwt.lisp

KindCoveredAll%
expression111251 44.2
branch624 25.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; jwt.lisp --- JSON Web Tokens
2
 
3
 ;; This implementation is based on CLJWT: https://github.com/gschjetne/cljwt/blob/master/src/cljwt.lisp
4
 
5
 ;;; Commentary:
6
 
7
 ;; ref: https://en.wikipedia.org/wiki/JSON_Web_Token
8
 
9
 ;; rfc:7519
10
 
11
 ;; TODO 2024-06-30: ref: https://datatracker.ietf.org/doc/html/rfc7517
12
 
13
 ;; https://40ants.com/lisp-project-of-the-day/2020/05/0080-jose.html
14
 
15
 ;; https://medium.facilelogin.com/jwt-jws-and-jwe-for-not-so-dummies-b63310d201a3
16
 
17
 ;;; Code:
18
 (in-package :cry/jwt)
19
 
20
 ;;; Conditions
21
 (define-condition unsecured-token (error) ())
22
 
23
 (define-condition invalid-hmac (error) ())
24
 
25
 (define-condition unsupported-algorithm (error)
26
   ((algorithm :initarg :algorithm :reader algorithm))
27
   (:report (lambda (condition stream)
28
              (format stream "Algorithm \"~A\" not supported"
29
                      (algorithm condition)))))
30
 
31
 (define-condition invalid-time (error)
32
   ((delta :initarg :delta :reader time-delta))
33
   (:report (lambda (condition stream)
34
              (format stream "Token ~A. ~D seconds off."
35
                      (typecase condition
36
                        (expired "has expired")
37
                        (not-yet-valid "is not yet valid"))
38
                      (time-delta condition)))))
39
 
40
 (define-condition expired (invalid-time) ())
41
 
42
 (define-condition not-yet-valid (invalid-time) ())
43
 
44
 (defmacro bind-hash-tables (bindings &body body)
45
   `(let ,(loop for binding in bindings collect
46
               (list (car binding)
47
                     `(etypecase ,(cadr binding)
48
                        (hash-table ,(cadr binding))
49
                        (list (plist-hash-table ,(cadr binding)
50
                                                :test #'equal)))))
51
      ,@body))
52
 
53
 (defmacro add-claims (hash &rest claims)
54
   `(progn ,@(loop for (key value) on claims by #'cddr collect
55
                  `(when ,value
56
                     (setf (gethash ,key ,hash) ,value)))))
57
 
58
 (defun to-unix-time (time)
59
   "Convert universal time to New Jersey time"
60
   (when time (- time (encode-universal-time 0 0 0 1 1 1970 0))))
61
 
62
 (defun from-unix-time (time)
63
   "Convert New Jersey time to universal time"
64
   (when time (+ time (encode-universal-time 0 0 0 1 1 1970 0))))
65
 
66
 (defun base64-encode (input)
67
   "Takes a string or octets, returns an unpadded URI-encoded Base64 string."
68
   (etypecase input
69
     (string (base64-encode (sb-ext:string-to-octets input :external-format :utf-8)))
70
     ((simple-array (unsigned-byte 8))
71
      (with-output-to-string (out)
72
        (with-input-from-string (in (dat/base64:octet-vector-to-base64-string input :uri t))
73
          (loop for character = (read-char in nil)
74
                while character do
75
                  ;; CL-BASE64 always uses padding, which must be removed.
76
                  (unless (eq character #\.)
77
                    (write-char character out))))))))
78
 
79
 (defun base64-decode (base-64-string)
80
   "Takes a base64-uri string and return an array of octets"
81
   (dat/base64:base64-string-to-octet-vector
82
    ;; Re-pad the string, or CL-BASE64 will get confused
83
    (concatenate 'string
84
                 base-64-string
85
                 (make-array (rem (length base-64-string) 4)
86
                             :element-type 'character
87
                             :initial-element #\.))
88
    :uri t))
89
 
90
 (defun issue (claims &key algorithm secret issuer subject audience
91
                        expiration not-before issued-at id more-header)
92
   "Encodes and returns a JSON Web Token. Times are in universal-time,
93
 number of seconds from 1900-01-01 00:00:00"
94
   (bind-hash-tables ((claimset claims)
95
                      (header more-header))
96
     ;; Add registered claims to the claims hash table
97
     (add-claims claimset
98
                 "iss" issuer
99
                 "sub" subject
100
                 "aud" audience
101
                 "exp" (to-unix-time expiration)
102
                 "nbf" (to-unix-time not-before)
103
                 "iat" (to-unix-time issued-at)
104
                 "jti" id)
105
     ;; Add type and algorithm to the header hash table
106
     (add-claims header
107
                 "typ" "JWT"
108
                 "alg" (ecase algorithm
109
                         (:none "none")
110
                         (:hs256 "HS256")))
111
     ;; Prepare JSON
112
     (let ((header-string (base64-encode
113
                           (with-output-to-string (s)
114
                             (dat/json:json-encode header s))))
115
           (claims-string (base64-encode
116
                           (with-output-to-string (s)
117
                             (dat/json:json-encode claimset s)))))
118
       ;; Assemble and, if applicable, sign the JWT
119
       (format nil "~A.~A.~@[~A~]"
120
               header-string
121
               claims-string
122
               (when (eq algorithm :hs256)
123
                 (HS256-digest header-string
124
                               claims-string
125
                               secret))))))
126
 
127
 (defun hs256-digest (header-string claims-string secret)
128
   "Takes header and claims in Base64, secret as a string or octets,
129
 returns the digest, in Base64"
130
   (base64-encode
131
    (ironclad:hmac-digest
132
     (ironclad:update-hmac
133
      (ironclad:make-hmac (etypecase secret
134
                   ((simple-array (unsigned-byte 8))
135
                    secret)
136
                   (string
137
                    (sb-ext:string-to-octets secret
138
                                      :external-format :utf-8)))
139
                 'ironclad:SHA256)
140
      (concatenate '(vector (unsigned-byte 8))
141
                   (sb-ext:string-to-octets
142
                    header-string)
143
                   #(46) ; ASCII period (.)
144
                   (sb-ext:string-to-octets
145
                    claims-string))))))
146
 
147
 (defun compare-hs256-digest (header-string claims-string
148
                              secret reported-digest)
149
   "Takes header and claims in Base64, secret as a string or octets, and a digest in Base64 to compare with. Signals an error if there is a mismatch."
150
   (let ((computed-digest
151
          (hs256-digest header-string
152
                        claims-string
153
                        secret)))
154
     (unless (equalp computed-digest
155
                    reported-digest)
156
       (cerror "Continue anyway" 'invalid-hmac
157
              :reported-digest reported-digest
158
              :computed-digest computed-digest))))
159
 
160
 (defun jwt-decode (jwt-string &key secret fail-if-unsecured)
161
   "Decodes and verifies a JSON Web Token. Returns two hash tables,
162
 token claims and token header"
163
   (destructuring-bind (header-string claims-string digest-string)
164
       (split-sequence #\. jwt-string)
165
     (let* ((header-hash (dat/json:json-decode
166
                          (sb-ext:octets-to-string
167
                           (base64-decode
168
                            header-string)
169
                           :external-format :utf-8)))
170
            (claims-hash (json-decode
171
                          (sb-ext:octets-to-string
172
                           (base64-decode
173
                            claims-string)
174
                           :external-format :utf-8)))
175
            (algorithm (dat/json:json-getf header-hash "alg")))
176
       ;; Verify HMAC
177
       (cond ((equal algorithm "HS256") 
178
              (compare-HS256-digest header-string
179
                                    claims-string
180
                                    secret
181
                                    digest-string))
182
             ((and (or (null algorithm) (equal algorithm "none")) fail-if-unsecured)
183
              (cerror "Continue anyway" 'unsecured-token))
184
             (t (cerror "Continue anyway" 'unsupported-algorithm
185
                        :algorithm algorithm)))
186
       ;; Verify timestamps
187
       (let ((expires (from-unix-time (json-getf claims-hash "exp")))
188
             (not-before (from-unix-time (json-getf claims-hash "nbf")))
189
             (current-time (get-universal-time)))
190
         (when (and expires (> current-time expires))
191
           (cerror "Continue anyway" 'expired :delta (- current-time expires)))
192
         (when (and not-before (< current-time not-before))
193
           (cerror "Continue anyway" 'not-yet-valid :delta (- current-time not-before))))
194
       ;; Return json objects
195
       (values claims-hash header-hash))))