Kyle Isom
0c441f5c4f
- clients/README.md: canonical API surface and error type reference - clients/testdata/: shared JSON response fixtures - clients/go/: mciasgoclient package; net/http + TLS 1.2+; sync.RWMutex token state; DisallowUnknownFields on all decoders; 25 tests pass - clients/rust/: async mcias-client crate; reqwest+rustls (no OpenSSL); thiserror MciasError enum; Arc<RwLock> token state; 22+1 tests pass; cargo clippy -D warnings clean - clients/lisp/: ASDF mcias-client; dexador HTTP, yason JSON; mcias-error condition hierarchy; Hunchentoot mock-dispatcher; 37 fiveam checks pass on SBCL 2.6.1; yason boolean normalisation in validate-token - clients/python/: mcias_client package (Python 3.11+); httpx sync; py.typed; dataclasses; 32 pytest tests; mypy --strict + ruff clean - test/mock/mockserver.go: in-memory mock server for Go client tests - ARCHITECTURE.md §19: updated per-language notes to match implementation - PROGRESS.md: Phase 9 marked complete - .gitignore: exclude clients/rust/target/, python .venv, .pytest_cache, .fasl files Security: token never logged or exposed in error messages in any library; TLS enforced in all four languages; token stored under lock/mutex/RwLock
410 lines
16 KiB
Common Lisp
410 lines
16 KiB
Common Lisp
;;;; tests/mock-server.lisp -- Hunchentoot-based mock MCIAS server
|
|
|
|
(in-package #:mcias-client-tests)
|
|
|
|
;;;; -----------------------------------------------------------------------
|
|
;;;; Global state
|
|
;;;; -----------------------------------------------------------------------
|
|
|
|
(defvar *mock-server* nil "The running Hunchentoot acceptor.")
|
|
(defvar *mock-accounts* nil "Hash table: id -> account plist.")
|
|
(defvar *mock-by-name* nil "Hash table: username -> id.")
|
|
(defvar *mock-tokens* nil "Hash table: token-string -> account-id.")
|
|
(defvar *mock-revoked* nil "Hash table: token-string -> t (revoked tokens).")
|
|
(defvar *mock-pgcreds* nil "Hash table: account-id -> pgcreds plist.")
|
|
|
|
(defun reset-mock-state! ()
|
|
"Reset all mock server state to empty."
|
|
(setf *mock-accounts* (make-hash-table :test 'equal)
|
|
*mock-by-name* (make-hash-table :test 'equal)
|
|
*mock-tokens* (make-hash-table :test 'equal)
|
|
*mock-revoked* (make-hash-table :test 'equal)
|
|
*mock-pgcreds* (make-hash-table :test 'equal)))
|
|
|
|
;; Initialise state immediately so the vars are never NIL.
|
|
(reset-mock-state!)
|
|
|
|
;;;; -----------------------------------------------------------------------
|
|
;;;; Mock data helpers
|
|
;;;; -----------------------------------------------------------------------
|
|
|
|
(let ((id-counter 0))
|
|
(defun %next-id ()
|
|
(incf id-counter)
|
|
(format nil "acct-~4,'0D" id-counter)))
|
|
|
|
(defun add-mock-account (username password account-type &rest roles)
|
|
"Add a mock account and return its ID string."
|
|
(let ((id (format nil "acct-~A" (gensym ""))))
|
|
(setf (gethash id *mock-accounts*)
|
|
(list :id id
|
|
:username username
|
|
:password password
|
|
:account-type account-type
|
|
:status "active"
|
|
:roles (or roles '())
|
|
:totp-enabled nil
|
|
:created-at "2024-01-01T00:00:00Z"
|
|
:updated-at "2024-01-01T00:00:00Z"))
|
|
(setf (gethash username *mock-by-name*) id)
|
|
id))
|
|
|
|
(defun %issue-mock-token (account-id)
|
|
"Create and store a mock token for ACCOUNT-ID. Returns the token string."
|
|
(let ((token (format nil "mock-token-~A-~A" account-id (gensym ""))))
|
|
(setf (gethash token *mock-tokens*) account-id)
|
|
token))
|
|
|
|
;;;; -----------------------------------------------------------------------
|
|
;;;; Response helpers (used inside Hunchentoot handlers)
|
|
;;;; -----------------------------------------------------------------------
|
|
|
|
(defun %yason-encode (obj)
|
|
"Encode OBJ to a JSON string."
|
|
(with-output-to-string (s)
|
|
(yason:encode obj s)))
|
|
|
|
(defun %send-json (status body-string)
|
|
"Set the HTTP status code and content-type, then return BODY-STRING."
|
|
(setf (hunchentoot:return-code*) status
|
|
(hunchentoot:content-type*) "application/json")
|
|
body-string)
|
|
|
|
(defun %send-ok (ht)
|
|
"Send a 200 response with HT (hash-table) encoded as JSON."
|
|
(%send-json 200 (%yason-encode ht)))
|
|
|
|
(defun %send-no-content ()
|
|
"Send a 204 No Content response."
|
|
(setf (hunchentoot:return-code*) 204
|
|
(hunchentoot:content-type*) "application/json")
|
|
"")
|
|
|
|
(defun %send-error (code message)
|
|
"Send an error response with CODE and MESSAGE."
|
|
(let ((ht (make-hash-table :test 'equal)))
|
|
(setf (gethash "error" ht) message)
|
|
(%send-json code (%yason-encode ht))))
|
|
|
|
(defun %read-json-body ()
|
|
"Read and parse the raw POST body as JSON. Returns NIL on failure."
|
|
(let ((raw (hunchentoot:raw-post-data :force-binary t)))
|
|
(when raw
|
|
(ignore-errors
|
|
(yason:parse (babel:octets-to-string raw :encoding :utf-8))))))
|
|
|
|
(defun %bearer-token ()
|
|
"Extract the Bearer token from the Authorization header, or NIL."
|
|
(let ((auth (hunchentoot:header-in* :authorization)))
|
|
(when (and auth (> (length auth) 7)
|
|
(string-equal (subseq auth 0 7) "Bearer "))
|
|
(subseq auth 7))))
|
|
|
|
(defun %authenticated-account ()
|
|
"Return the account plist for the current Bearer token, or NIL."
|
|
(let ((token (%bearer-token)))
|
|
(when token
|
|
(unless (gethash token *mock-revoked*)
|
|
(let ((account-id (gethash token *mock-tokens*)))
|
|
(when account-id
|
|
(gethash account-id *mock-accounts*)))))))
|
|
|
|
(defun %require-admin ()
|
|
"Return the authenticated account if it has the 'admin' role.
|
|
Sends 401 or 403 and returns NIL otherwise."
|
|
(let ((acct (%authenticated-account)))
|
|
(cond
|
|
((null acct)
|
|
(%send-error 401 "unauthorized")
|
|
nil)
|
|
((not (member "admin" (getf acct :roles) :test #'string=))
|
|
(%send-error 403 "forbidden")
|
|
nil)
|
|
(t acct))))
|
|
|
|
(defun %account->hash (acct)
|
|
"Convert internal account plist ACCT to a yason-encodable hash-table."
|
|
(let ((ht (make-hash-table :test 'equal)))
|
|
(setf (gethash "id" ht) (getf acct :id)
|
|
(gethash "username" ht) (getf acct :username)
|
|
(gethash "account_type" ht) (getf acct :account-type)
|
|
(gethash "status" ht) (getf acct :status)
|
|
(gethash "created_at" ht) (getf acct :created-at)
|
|
(gethash "updated_at" ht) (getf acct :updated-at)
|
|
;; yason: nil -> JSON false, t -> JSON true
|
|
(gethash "totp_enabled" ht) (if (getf acct :totp-enabled) t nil))
|
|
ht))
|
|
|
|
;;;; -----------------------------------------------------------------------
|
|
;;;; Dispatcher
|
|
;;;; -----------------------------------------------------------------------
|
|
|
|
(defclass mock-dispatcher (hunchentoot:acceptor) ()
|
|
(:documentation "Custom Hunchentoot acceptor that dispatches mock MCIAS routes."))
|
|
|
|
(defun %path= (path expected)
|
|
"Check if PATH equals EXPECTED (case-insensitive)."
|
|
(string-equal path expected))
|
|
|
|
(defun %path-prefix-p (path prefix)
|
|
"Check if PATH starts with PREFIX."
|
|
(and (>= (length path) (length prefix))
|
|
(string-equal (subseq path 0 (length prefix)) prefix)))
|
|
|
|
(defun %path-segment (path n)
|
|
"Return the Nth segment of PATH (0-indexed), split by /."
|
|
(let ((parts (remove "" (cl-ppcre:split "/" path) :test #'string=)))
|
|
(when (< n (length parts))
|
|
(nth n parts))))
|
|
|
|
(defmethod hunchentoot:handle-request ((acceptor mock-dispatcher) request)
|
|
"Dispatch requests to mock MCIAS handlers."
|
|
(let ((method (hunchentoot:request-method request))
|
|
(path (hunchentoot:script-name request)))
|
|
(cond
|
|
;; GET /v1/health
|
|
((and (eq method :get) (%path= path "/v1/health"))
|
|
(let ((ht (make-hash-table :test 'equal)))
|
|
(setf (gethash "status" ht) "ok")
|
|
(%send-ok ht)))
|
|
|
|
;; GET /v1/keys/public
|
|
((and (eq method :get) (%path= path "/v1/keys/public"))
|
|
(let ((ht (make-hash-table :test 'equal)))
|
|
(setf (gethash "kty" ht) "OKP"
|
|
(gethash "crv" ht) "Ed25519"
|
|
(gethash "x" ht) "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=")
|
|
(%send-ok ht)))
|
|
|
|
;; POST /v1/auth/login
|
|
((and (eq method :post) (%path= path "/v1/auth/login"))
|
|
(let* ((body (%read-json-body))
|
|
(uname (and body (gethash "username" body)))
|
|
(pass (and body (gethash "password" body)))
|
|
(acct-id (and uname (gethash uname *mock-by-name*)))
|
|
(acct (and acct-id (gethash acct-id *mock-accounts*))))
|
|
(if (and acct (string= pass (getf acct :password)))
|
|
(let* ((token (format nil "mock-token-~A" (gensym "")))
|
|
(ht (make-hash-table :test 'equal)))
|
|
(setf (gethash token *mock-tokens*) acct-id)
|
|
(setf (gethash "token" ht) token
|
|
(gethash "expires_at" ht) "2099-01-01T00:00:00Z")
|
|
(%send-ok ht))
|
|
(%send-error 401 "invalid credentials"))))
|
|
|
|
;; POST /v1/auth/logout
|
|
((and (eq method :post) (%path= path "/v1/auth/logout"))
|
|
(let ((token (%bearer-token)))
|
|
(when token
|
|
(remhash token *mock-tokens*)
|
|
(setf (gethash token *mock-revoked*) t)))
|
|
(%send-no-content))
|
|
|
|
;; POST /v1/auth/renew
|
|
((and (eq method :post) (%path= path "/v1/auth/renew"))
|
|
(let ((acct (%authenticated-account)))
|
|
(if acct
|
|
(let* ((old-token (%bearer-token))
|
|
(acct-id (getf acct :id))
|
|
(new-token (format nil "mock-token-~A" (gensym "")))
|
|
(ht (make-hash-table :test 'equal)))
|
|
;; Revoke old token
|
|
(when old-token
|
|
(remhash old-token *mock-tokens*)
|
|
(setf (gethash old-token *mock-revoked*) t))
|
|
(setf (gethash new-token *mock-tokens*) acct-id)
|
|
(setf (gethash "token" ht) new-token
|
|
(gethash "expires_at" ht) "2099-01-01T00:00:00Z")
|
|
(%send-ok ht))
|
|
(%send-error 401 "unauthorized"))))
|
|
|
|
;; POST /v1/token/validate
|
|
((and (eq method :post) (%path= path "/v1/token/validate"))
|
|
(let* ((body (%read-json-body))
|
|
(tok-str (and body (gethash "token" body)))
|
|
(ht (make-hash-table :test 'equal)))
|
|
(cond
|
|
;; Token is present, not revoked, and known
|
|
((and tok-str
|
|
(not (gethash tok-str *mock-revoked*))
|
|
(gethash tok-str *mock-tokens*))
|
|
(let* ((acct-id (gethash tok-str *mock-tokens*))
|
|
(acct (gethash acct-id *mock-accounts*)))
|
|
;; valid = t -> yason encodes as JSON true
|
|
(setf (gethash "valid" ht) t
|
|
(gethash "sub" ht) acct-id
|
|
(gethash "roles" ht) (getf acct :roles)
|
|
(gethash "expires_at" ht) "2099-01-01T00:00:00Z")))
|
|
(t
|
|
;; valid = nil -> yason encodes as JSON false
|
|
(setf (gethash "valid" ht) nil)))
|
|
(%send-ok ht)))
|
|
|
|
;; GET /v1/accounts
|
|
((and (eq method :get) (%path= path "/v1/accounts"))
|
|
(when (%require-admin)
|
|
(let ((accts '()))
|
|
(maphash (lambda (k v)
|
|
(declare (ignore k))
|
|
(push (%account->hash v) accts))
|
|
*mock-accounts*)
|
|
(%send-json 200 (%yason-encode accts)))))
|
|
|
|
;; POST /v1/accounts
|
|
((and (eq method :post) (%path= path "/v1/accounts"))
|
|
(when (%require-admin)
|
|
(let* ((body (%read-json-body))
|
|
(uname (and body (gethash "username" body)))
|
|
(atype (and body (gethash "account_type" body)))
|
|
(pass (and body (gethash "password" body))))
|
|
(if (gethash uname *mock-by-name*)
|
|
(%send-error 409 "username already exists")
|
|
(let ((id (add-mock-account uname (or pass "nopass") (or atype "user"))))
|
|
(%send-json 201 (%yason-encode (%account->hash (gethash id *mock-accounts*)))))))))
|
|
|
|
;; DELETE /v1/token/:jti
|
|
((and (eq method :delete) (%path-prefix-p path "/v1/token/"))
|
|
(let ((jti (subseq path (length "/v1/token/"))))
|
|
(remhash jti *mock-tokens*)
|
|
(setf (gethash jti *mock-revoked*) t))
|
|
(%send-no-content))
|
|
|
|
;; GET /v1/accounts/:id
|
|
((and (eq method :get)
|
|
(%path-prefix-p path "/v1/accounts/")
|
|
;; Make sure it's not /v1/accounts/:id/roles or /pgcreds
|
|
(not (cl-ppcre:scan "/" (subseq path (length "/v1/accounts/")))))
|
|
(when (%require-admin)
|
|
(let* ((id (subseq path (length "/v1/accounts/")))
|
|
(acct (gethash id *mock-accounts*)))
|
|
(if acct
|
|
(%send-ok (%account->hash acct))
|
|
(%send-error 404 "account not found")))))
|
|
|
|
;; GET /v1/accounts/:id/roles
|
|
((and (eq method :get)
|
|
(cl-ppcre:scan "^/v1/accounts/[^/]+/roles$" path))
|
|
(when (%require-admin)
|
|
(let* ((parts (cl-ppcre:split "/" path))
|
|
(id (nth 3 parts))
|
|
(acct (gethash id *mock-accounts*))
|
|
(ht (make-hash-table :test 'equal)))
|
|
(if acct
|
|
(progn
|
|
(setf (gethash "roles" ht) (getf acct :roles))
|
|
(%send-ok ht))
|
|
(%send-error 404 "account not found")))))
|
|
|
|
;; PUT /v1/accounts/:id/roles
|
|
((and (eq method :put)
|
|
(cl-ppcre:scan "^/v1/accounts/[^/]+/roles$" path))
|
|
(when (%require-admin)
|
|
(let* ((parts (cl-ppcre:split "/" path))
|
|
(id (nth 3 parts))
|
|
(acct (gethash id *mock-accounts*))
|
|
(body (%read-json-body))
|
|
(roles (and body (gethash "roles" body))))
|
|
(if acct
|
|
(progn
|
|
(setf (getf (gethash id *mock-accounts*) :roles) roles)
|
|
(%send-no-content))
|
|
(%send-error 404 "account not found")))))
|
|
|
|
;; PUT /v1/accounts/:id/pgcreds
|
|
((and (eq method :put)
|
|
(cl-ppcre:scan "^/v1/accounts/[^/]+/pgcreds$" path))
|
|
(when (%require-admin)
|
|
(let* ((parts (cl-ppcre:split "/" path))
|
|
(id (nth 3 parts))
|
|
(body (%read-json-body)))
|
|
(if (gethash id *mock-accounts*)
|
|
(progn
|
|
(setf (gethash id *mock-pgcreds*) body)
|
|
(%send-no-content))
|
|
(%send-error 404 "account not found")))))
|
|
|
|
;; GET /v1/accounts/:id/pgcreds
|
|
((and (eq method :get)
|
|
(cl-ppcre:scan "^/v1/accounts/[^/]+/pgcreds$" path))
|
|
(when (%require-admin)
|
|
(let* ((parts (cl-ppcre:split "/" path))
|
|
(id (nth 3 parts))
|
|
(creds (gethash id *mock-pgcreds*)))
|
|
(if creds
|
|
(%send-ok creds)
|
|
(%send-error 404 "no pgcreds for account")))))
|
|
|
|
;; PATCH /v1/accounts/:id
|
|
((and (eq method :patch)
|
|
(%path-prefix-p path "/v1/accounts/")
|
|
(not (cl-ppcre:scan "/" (subseq path (length "/v1/accounts/")))))
|
|
(when (%require-admin)
|
|
(let* ((id (subseq path (length "/v1/accounts/")))
|
|
(acct (gethash id *mock-accounts*))
|
|
(body (%read-json-body)))
|
|
(if acct
|
|
(progn
|
|
(when (and body (gethash "status" body))
|
|
(setf (getf (gethash id *mock-accounts*) :status)
|
|
(gethash "status" body)))
|
|
(%send-ok (%account->hash (gethash id *mock-accounts*))))
|
|
(%send-error 404 "account not found")))))
|
|
|
|
;; DELETE /v1/accounts/:id
|
|
((and (eq method :delete)
|
|
(%path-prefix-p path "/v1/accounts/")
|
|
(not (cl-ppcre:scan "/" (subseq path (length "/v1/accounts/")))))
|
|
(when (%require-admin)
|
|
(let* ((id (subseq path (length "/v1/accounts/")))
|
|
(acct (gethash id *mock-accounts*)))
|
|
(if acct
|
|
(progn
|
|
(remhash id *mock-accounts*)
|
|
(maphash (lambda (k v)
|
|
(when (string= v id)
|
|
(remhash k *mock-by-name*)))
|
|
*mock-by-name*)
|
|
(%send-no-content))
|
|
(%send-error 404 "account not found")))))
|
|
|
|
;; POST /v1/token/issue
|
|
((and (eq method :post) (%path= path "/v1/token/issue"))
|
|
(when (%require-admin)
|
|
(let* ((body (%read-json-body))
|
|
(acct-id (and body (gethash "account_id" body))))
|
|
(if (and acct-id (gethash acct-id *mock-accounts*))
|
|
(let* ((token (%issue-mock-token acct-id))
|
|
(ht (make-hash-table :test 'equal)))
|
|
(setf (gethash "token" ht) token
|
|
(gethash "expires_at" ht) "2099-01-01T00:00:00Z")
|
|
(%send-ok ht))
|
|
(%send-error 404 "account not found")))))
|
|
|
|
;; Catch-all
|
|
(t
|
|
(%send-error 404 (format nil "not found: ~A ~A" method path))))))
|
|
|
|
;;;; -----------------------------------------------------------------------
|
|
;;;; Start/stop
|
|
;;;; -----------------------------------------------------------------------
|
|
|
|
(defun start-mock-server (&key (port 0))
|
|
"Start the mock MCIAS server on PORT (0 = OS-assigned).
|
|
Returns the actual port bound."
|
|
(reset-mock-state!)
|
|
;; Seed an admin account.
|
|
(add-mock-account "admin" "adminpass" "admin" "admin")
|
|
(let ((acceptor (make-instance 'mock-dispatcher
|
|
:port port
|
|
:access-log-destination nil
|
|
:message-log-destination nil)))
|
|
(hunchentoot:start acceptor)
|
|
(setf *mock-server* acceptor)
|
|
(hunchentoot:acceptor-port acceptor)))
|
|
|
|
(defun stop-mock-server ()
|
|
"Stop the running mock server."
|
|
(when *mock-server*
|
|
(hunchentoot:stop *mock-server*)
|
|
(setf *mock-server* nil)))
|