;; Copyright (c) 2024, SWGY, Inc. <ron@sw.gy>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or (at
;; your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software Foundation, Inc.,
;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
;;
(in-package :swtx)
(defparameter *challenge-lifetime* (* 5 60)
"Specify the default challenge lifetime, in seconds")
(defparameter *max-allowed-challenges* 5
"Allow no more than this many live challenges at once.")
(defparameter *jwt-app-id* nil)
(defparameter *jwt-api-id* nil)
(defparameter *jwt-signing-secret* nil)
(defvar *role-any* "any")
(defvar *role-admin* "admin")
(defvar *admin-auth-minutes* 15)
(defvar *role-attendee* "attendee")
(defvar *attendee-auth-minutes* 30)
(defvar *role-host* "host")
(defvar *host-auth-minutes* (* 8 60))
(defvar *role-rep* "rep")
(defvar *rep-auth-minutes* (* 8 60))
(defvar *role-vendor* "vendor")
(defvar *vendor-auth-minutes* 30)
(defun base64url-encode (data)
(let* ((encoded (cl-base64:usb8-array-to-base64-string
(ironclad:ascii-string-to-byte-array data)))
(url-safe (string-replace "+" "-" (string-replace "/" "_" encoded))))
(string-right-trim "=" url-safe)))
(defun base64-pad-string (base-64-string)
(concatenate 'string
base-64-string
(case (rem (length base-64-string) 4)
(0 "") (1 "...")
(2 "..") (3 "."))))
(defun base64url-decode (base-64-string)
"Given a base64 encoded string, return the unencoded string."
(cl-base64:base64-string-to-string (base64-pad-string base-64-string) :uri t))
(defun hmac-sha256 (key data)
(let* ((mac (ironclad:make-mac :hmac key :sha256)))
(ironclad:update-mac mac data)
(ironclad:produce-mac mac)))
(defun compute-jwt-signature (secret-key &key message)
(let* ((key (ironclad:ascii-string-to-byte-array secret-key))
(data-to-sign (ironclad:ascii-string-to-byte-array message))
(mac-digest (hmac-sha256 key data-to-sign))
(encoded-signature
(cl-base64:usb8-array-to-base64-string mac-digest :uri t)))
; Drop the final '.' from the end for JWT purposes.
(subseq encoded-signature 0 (1- (length encoded-signature)))))
(defun validate-jwt-signature (secret-key &key message)
(let ((components (cl-ppcre:split "\\." message)))
(unless (= 3 (length components))
(error "Malformed JWT; expected 3 components separated by '.'"))
(destructuring-bind (header payload signature) components
(let* ((signing-input (concatenate 'string header "." payload))
(decoded-signature (cl-base64:base64-string-to-usb8-array
(base64-pad-string signature) :uri t))
(key (ironclad:ascii-string-to-byte-array secret-key))
(mac (ironclad:make-mac :hmac key :sha256)))
;; Compute the HMAC of the signing input
(ironclad:update-mac mac (ironclad:ascii-string-to-byte-array signing-input))
(let ((computed-signature (ironclad:produce-mac mac)))
;; Compare computed HMAC with the decoded signature
(ironclad:constant-time-equal computed-signature decoded-signature))))))
(defun jwt-encode (payload secret)
"Given a hashtable as a payload and a signing secret, return the
equivalent jwt object."
(let* ((header "{\"alg\":\"HS256\",\"typ\":\"JWT\"}")
(encoded-header (base64url-encode header))
(encoded-payload (base64url-encode
(st-json:write-json-to-string payload)))
(message (format nil "~A.~A" encoded-header encoded-payload))
(signature (compute-jwt-signature secret :message message)))
(format T "Signature is ~%~A~%" signature)
(format nil "~A.~A" message signature)))
(defun jwt-decode (token secret)
"Given an encoded JWT, validate the signature using the provided signing
secret, then return the parsed st-json:JSO for the payload."
(let* ((pieces (cl-ppcre:split "\\." token))
(json-payload (base64url-decode (second pieces))))
; First validate the signature
(when (validate-jwt-signature secret :message token)
(let ((payload (st-json:read-json-from-string json-payload)))
(cond
((and (> (get-universal-time) (st-json:getjso "iat" payload))
; Next validate the current time is before the expiration time
(< (get-universal-time) (st-json:getjso "exp" payload))
; For our API
(equal *jwt-api-id* (st-json:getjso "iss" payload))
; And for this app
(equal *jwt-app-id* (st-json:getjso "aud" payload)))
payload)
(t nil))))))
(defun generate-jwt (email role &key (vendor-id nil) (person-id nil) (minutes 15))
"Generate a JWT token for the provided email and role, optionally specifying
the vendor-id. The JWT will be good for the number of minutes specified"
(let* ((expiration-time (+ (get-universal-time) (* 60 minutes)))
(issued-at-time (get-universal-time))
(payload (make-hash-table)))
(setf (gethash "sub" payload) email)
(setf (gethash "exp" payload) expiration-time)
(setf (gethash "iss" payload) *jwt-api-id*)
(setf (gethash "iat" payload) issued-at-time)
(setf (gethash "aud" payload) *jwt-app-id*)
(setf (gethash "role" payload) role)
(setf (gethash "vendor-id" payload) vendor-id)
(setf (gethash "person-id" payload) person-id)
(when (and (string= role *role-vendor*) (null vendor-id))
(error "Vendor ID is required for vendor role"))
(when (and (string= role *role-rep*) (null vendor-id))
(error "Vendor ID is required for rep role"))
(when (and (string= role *role-rep*) (null person-id))
(error "Person ID is required for rep role"))
(when (and (string= role *role-attendee*) (null person-id))
(error "Person ID is required for attendee role"))
(jwt-encode payload *jwt-signing-secret*)))
(defun path-allows-challenge-p (path)
"Returns nil if the path is now allowed for a challenge."
(ppcre:scan
(format nil "/(auth|validate|recover-accounts\\?email=.{~A,~A})$"
*min-email-length*
*max-email-length*)
path))
(defun create-new-challenge (path &key people-db auth-db)
"Create a new challenge instance for the indicated path. If more than
the max allowed challenges are valid and outstanding, return nil.
Challenges are only allowed for auth and validate endpoints."
(let* ((id (generate-id))
(valid-until (+ (get-universal-time) *challenge-lifetime*))
(response-code (generate-response-code))
(email (get-email-from-path people-db path))
(current-challenge-count (get-challenge-count-for-email auth-db email)))
(when (and (valid-recipient-p email)
(path-allows-challenge-p path)
(< current-challenge-count *max-allowed-challenges*))
(make-challenge id valid-until response-code path email))))
(defun resolves-challenge-p (challenge response-code)
"Given a challenge and a response code, return T if the
challenge is valid and the response code matches. False otherwise."
(when (> (parse-integer (valid-until challenge)) (get-universal-time))
(equal response-code (response-code challenge))))
(defun generate-response-code ()
"Generate a response code suitable for association with a challenge."
(if *disable-random-codes* 0 (ironclad:strong-random 1000000)))
(defun get-email-from-path (people-db path)
"Given a people-db reference and a path (see below), return the email address
that should receive the challenge email.
path - The path comprises an HTTP verb, a space, and a url to the API
resource being interacted with. See the challenge class documentation
for complete details.
For paths matching '/api/attendees/:attendee-id', return that attendee's
email.
For paths matching '/api/vendors/:vendor-id', return that vendor's primary
contact email.
For paths matching '/api/vendors/:vendor-id/reps/:rep-id', return that
vendor rep's email address.
For paths matching '/api/hosts/:host-id', return that event host's email.
"
(let* ((verb-matcher "\\w{3,7}")
(id-pattern *id-shape-regex*)
(suffix "(auth|validate)$")
(recovery-matcher
(format nil "^GET /api/recover-accounts\\?email=.{~A,~A}"
*min-email-length*
*max-email-length*))
(attendee-matcher (format nil "^~A /api/attendees/(~A)/~A"
verb-matcher id-pattern suffix))
(vendor-matcher (format nil "^~A /api/vendors/(~A)/~A"
verb-matcher id-pattern suffix))
(rep-matcher (format nil "^~A /api/vendors/(~A)/reps/(~A)/~A"
verb-matcher id-pattern id-pattern suffix))
(host-matcher (format nil "^~A /api/hosts/(~A)/~A"
verb-matcher id-pattern suffix)))
(cond
((ppcre:scan recovery-matcher path)
; pull the email address from the part after the '?'
(second (ppcre:split "email=" path)))
(t
(dolist (c `(("a." . ,attendee-matcher)
("v." . ,vendor-matcher)
("v.~A.vr." . ,rep-matcher)
("h." . ,host-matcher)))
(multiple-value-bind (_s groups) (ppcre:scan-to-strings (cdr c) path)
(when _s
(cond
((string-equal "v.~A.vr." (car c))
(return (get-from-db people-db
(format nil "v.~A.vr.~A.email"
(aref groups 0) (aref groups 1)))))
(t
(return (get-from-db people-db
(format nil "~A~A.email"
(car c) (aref groups 0)))))))))))))
(defun email-challenge (challenge)
"Email the associated email address for this challenge."
(with-accessors ((email email)
(code response-code)) challenge
(send-auth-email email code)))
(defmacro with-oneshot-auth (auth-db (email-var) &body body)
"The provided body will only be executed if the provided request-params
specify an ST-Challenge-ID and associated ST-Challenge-Response that are
properly resolve a challenge for this particular URL and verb.
Otherwise, a 401-bad auth will be returned.
When adding this type of auth to a new endpoint, be sure to update
the path-allows-challenge-p function in auth.lisp"
(let ((request-headers-sym (gensym "request-headers"))
(challenge-id-sym (gensym "challenge-id"))
(challenge-sym (gensym "challenge"))
(challenge-response-sym (gensym "challenge-reponse"))
(request-path-sym (gensym "request-path"))
(request-method-sym (gensym "request-method")))
`(let* ((,request-headers-sym
(lack.request:request-headers ningle:*request*))
(,challenge-id-sym
(header-val "st-challenge-id"
,request-headers-sym *max-id-length*))
(,challenge-response-sym
(header-val "st-challenge-response"
,request-headers-sym *max-response-code-length*))
(,request-path-sym (lack.request:request-path-info ningle:*request*))
(,request-method-sym (lack.request:request-method ningle:*request*)))
(let ((,challenge-sym (load-challenge ,auth-db ,challenge-id-sym)))
(if (and ,challenge-sym
(resolves-challenge-p ,challenge-sym ,challenge-response-sym)
(equal
; Chop off query params
(first (ppcre:split "\\?" (path ,challenge-sym)))
(format nil "~A ~A" ,request-method-sym ,request-path-sym)))
; Good auth, the challenge is now consumed.
(progn
(delete-challenge ,auth-db ,challenge-id-sym)
; TODO: Update to optionally provide the email address that was
; used.
(let ((,email-var (email ,challenge-sym)))
,@body))
`(401 () ("Bad Auth")))))))
(defmacro with-persistent-auth ((roles request-params) &body body)
"Require a valid JWT with a role in the specified list.
If the roles include vendor, the vendor ID must be present and must match.
If the roles include attendee, the person ID must be present and must match.
If the roles include rep, the vendor and person IDs must both be present and
must both match."
(let ((request-headers-sym (gensym "request-headers"))
(vendor-id-sym (gensym "vendor-id"))
(rep-id-sym (gensym "rep-id"))
(attendee-id-sym (gensym "attendee-id"))
(authorization-sym (gensym "authorization"))
(jwt-payload-sym (gensym "payload"))
(role-sym (gensym "role")))
`(let* ((,request-headers-sym
(lack.request:request-headers ningle:*request*))
(,vendor-id-sym
(param-val :vendor-id ,request-params *max-id-length*))
(,rep-id-sym
(param-val :rep-id ,request-params *max-id-length*))
(,attendee-id-sym
(param-val :attendee-id ,request-params *max-id-length*))
(,authorization-sym (header-val "authorization"
,request-headers-sym
*max-auth-header-length*)))
; Pull the "Authorization" header
(when ,authorization-sym
(let* ((,jwt-payload-sym (jwt-decode
(second
; Trim 'bearer ' or 'Bearer ' off the start
; if present.
(cl-ppcre:split "[Bb]earer " ,authorization-sym))
*jwt-signing-secret*))
(,role-sym (if ,jwt-payload-sym
(st-json:getjso "role" ,jwt-payload-sym)
nil)))
; Check for jwt role within set of specified roles
(format T "Loaded role from ~A.~%" ,jwt-payload-sym)
(if ,jwt-payload-sym
(cond
((member *role-any* ,roles :test #'equal)
(progn ,@body))
; Role Vendor
((and (member ,role-sym ,roles :test #'equal)
(equal *role-vendor* ,role-sym)
(equal (st-json:getjso "vendor-id" ,jwt-payload-sym)
,vendor-id-sym))
(format T "Passed vendor auth case~%")
(progn ,@body))
; Role Rep
((and (member ,role-sym ,roles :test #'equal)
(equal *role-rep* ,role-sym)
(equal (st-json:getjso "vendor-id" ,jwt-payload-sym)
,vendor-id-sym)
(equal (st-json:getjso "person-id" ,jwt-payload-sym)
,rep-id-sym))
(format T "Passed rep auth case~%")
(progn ,@body))
; Role Attendee
((and (member ,role-sym ,roles :test #'equal)
(equal *role-attendee* ,role-sym)
(equal (st-json:getjso "person-id" ,jwt-payload-sym)
,attendee-id-sym))
(format T "Passed attendee auth case~%")
(progn ,@body))
; Role Host
((and (member ,role-sym ,roles :test #'equal)
(equal *role-host* ,role-sym))
(format T "Passed host auth case~%")
(progn ,@body))
; Role Admin
((and (member ,role-sym ,roles :test #'equal)
(equal *role-admin* ,role-sym))
(format T "Passed admin auth case~%")
(progn ,@body))
(t
(format T "Auth failed the role checking portion~%")
(format T "Role: ~A, Roles: ~{~A~^,~}~%"
,role-sym ,roles)
`(401 () ("Bad Auth")))) ; cond 't'
`(401 () ("Bad Auth")) ; jwt-payload is nil
))))))