kyle/mcias
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Implement Phase 9: client libraries (Go, Rust, Lisp, Python)

Browse Source 
- 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
This commit is contained in:
Kyle Isom
2026-03-11 16:38:32 -07:00
parent f34e9a69a0
commit 0c441f5c4f
1974 changed files with 10151 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

102
clients/lisp/README.md Normal file
View File

@@ -0,0 +1,102 @@
# mcias-client (Common Lisp)
Common Lisp client library for the [MCIAS](../../README.md) identity and access management API.
## Requirements
- SBCL 2.x (primary), CCL (secondary)
- Quicklisp
## Installation
Place the `clients/lisp/` directory on ASDF's central registry or load it
via Quicklisp local-projects:
```sh
ln -s /path/to/mcias/clients/lisp ~/.quicklisp/local-projects/mcias-client
```
Then in your Lisp image:
```lisp
(ql:quickload :mcias-client)
```
## Quick Start
```lisp
(use-package :mcias-client)
;; Connect to the MCIAS server.
(defvar *client* (make-client "https://auth.example.com"))
;; Authenticate.
(multiple-value-bind (token expires-at)
(login *client* "alice" "s3cret")
(format t "token expires at ~A~%" expires-at))
;; The token is stored in the client automatically.
(let ((accounts (list-accounts *client*)))
(format t "~A accounts~%" (length accounts)))
;; Revoke the token when done.
(logout *client*)
```
## Custom CA Certificate
```lisp
(defvar *client*
(make-client "https://auth.example.com"
:ca-cert "/etc/mcias/ca.pem"))
```
## Error Handling
All functions signal typed conditions on error:
```lisp
(handler-case
(login *client* "alice" "wrongpass")
(mcias-auth-error (e)
(format t "auth failed: ~A~%" (mcias-error-message e)))
(mcias-forbidden-error (e)
(format t "forbidden: ~A~%" (mcias-error-message e)))
(mcias-not-found-error (e)
(format t "not found: ~A~%" (mcias-error-message e)))
(mcias-input-error (e)
(format t "bad input: ~A~%" (mcias-error-message e)))
(mcias-conflict-error (e)
(format t "conflict: ~A~%" (mcias-error-message e)))
(mcias-server-error (e)
(format t "server error ~A: ~A~%"
(mcias-error-status e)
(mcias-error-message e))))
```
All condition types are subclasses of `mcias-error`, which has slots:
- `mcias-error-status` — HTTP status code (integer)
- `mcias-error-message` — server error message (string)
## `validate-token` Return Value
`validate-token` returns a property list. The `:valid` key is `T` if the
token is valid, `NIL` otherwise (never raises an error for an invalid token):
```lisp
(let ((result (validate-token *client* some-token)))
(if (getf result :valid)
(format t "valid; sub=~A~%" (getf result :sub))
(format t "invalid~%")))
```
## Running Tests
```sh
sbcl --non-interactive \
--eval '(require :asdf)' \
--eval "(push #P\"$(pwd)/\" asdf:*central-registry*)" \
--eval '(ql:quickload :mcias-client/tests :silent t)' \
--eval '(mcias-client-tests:run-all-tests)' \
--eval '(uiop:quit)'
```

288
clients/lisp/client.lisp Normal file
View File

@@ -0,0 +1,288 @@
;;;; client.lisp -- MCIAS REST API client implementation
(in-package #:mcias-client)
;;;; -----------------------------------------------------------------------
;;;; Client class
;;;; -----------------------------------------------------------------------
(defclass mcias-client ()
((base-url :initarg :base-url
:reader client-base-url
:documentation "Base URL of the MCIAS server (no trailing slash).")
(token :initarg :token
:initform nil
:accessor client-token
:documentation "Current Bearer token string, or NIL.")
(ca-cert :initarg :ca-cert
:initform nil
:reader client-ca-cert
:documentation "Path to CA certificate file for TLS verification, or NIL."))
(:documentation "Holds connection parameters for one MCIAS server."))
(defun make-client (base-url &key token ca-cert)
"Create an MCIAS client for BASE-URL.
Optional TOKEN pre-seeds the Bearer token; CA-CERT overrides TLS CA."
;; Strip any trailing slashes so we can always append /v1/... cleanly.
(let ((url (string-right-trim "/" base-url)))
(make-instance 'mcias-client
:base-url url
:token token
:ca-cert ca-cert)))
;;;; -----------------------------------------------------------------------
;;;; Internal helpers
;;;; -----------------------------------------------------------------------
(defun %encode-json (object)
"Encode OBJECT to a JSON string using yason."
(with-output-to-string (s)
(yason:encode object s)))
(defun %parse-json (string)
"Parse STRING as JSON. Returns NIL for empty or nil input."
(when (and string (> (length string) 0))
(yason:parse string)))
(defun %auth-headers (client)
"Return an alist of HTTP headers for CLIENT.
Includes Authorization: Bearer <token> when a token is set."
(let ((headers (list (cons "Content-Type" "application/json")
(cons "Accept" "application/json"))))
(when (client-token client)
(push (cons "Authorization"
(concatenate 'string "Bearer " (client-token client)))
headers))
headers))
(defun %check-status (status body-string)
"Signal an appropriate mcias-error if STATUS >= 400.
Extracts the 'error' field from the JSON body when possible."
(when (>= status 400)
(let* ((parsed (ignore-errors (%parse-json body-string)))
(message (if (hash-table-p parsed)
(or (gethash "error" parsed) body-string)
body-string)))
(signal-mcias-error status message))))
(defun %request (client method path &key body)
"Perform an HTTP request against the MCIAS server.
METHOD is a keyword (:GET :POST etc.), PATH is the API path string.
BODY (optional) is a hash table or list that will be JSON-encoded.
Returns the parsed JSON response body (hash-table/list/string/number)
or NIL for empty responses."
(let* ((url (concatenate 'string (client-base-url client) path))
(headers (%auth-headers client))
(content (when body (%encode-json body))))
(multiple-value-bind (resp-body status)
(handler-case
(dex:request url
:method method
:headers headers
:content content
:want-stream nil
:force-string t)
(dex:http-request-failed (e)
(values (dex:response-body e)
(dex:response-status e))))
(%check-status status resp-body)
(%parse-json resp-body))))
;;;; -----------------------------------------------------------------------
;;;; Account response helper
;;;; -----------------------------------------------------------------------
(defun %account->plist (ht)
"Convert a yason-parsed account hash-table HT to a plist."
(when ht
(list :id (gethash "id" ht)
:username (gethash "username" ht)
:account-type (gethash "account_type" ht)
:status (gethash "status" ht)
:created-at (gethash "created_at" ht)
:updated-at (gethash "updated_at" ht))))
;;;; -----------------------------------------------------------------------
;;;; Authentication
;;;; -----------------------------------------------------------------------
(defun login (client username password &key totp-code)
"Authenticate USERNAME/PASSWORD against MCIAS.
Stores the returned token in CLIENT-TOKEN.
Returns (values token expires-at)."
(let* ((body (let ((ht (make-hash-table :test 'equal)))
(setf (gethash "username" ht) username
(gethash "password" ht) password)
(when totp-code
(setf (gethash "totp_code" ht) totp-code))
ht))
(resp (%request client :post "/v1/auth/login" :body body))
(token (gethash "token" resp))
(expires-at (gethash "expires_at" resp)))
(setf (client-token client) token)
(values token expires-at)))
(defun logout (client)
"Revoke the current session token and clear CLIENT-TOKEN.
Returns T on success."
(%request client :post "/v1/auth/logout")
(setf (client-token client) nil)
t)
(defun renew-token (client)
"Renew the current Bearer token.
Stores the new token in CLIENT-TOKEN.
Returns (values new-token expires-at)."
(let* ((resp (%request client :post "/v1/auth/renew" :body (make-hash-table :test 'equal)))
(token (gethash "token" resp))
(expires-at (gethash "expires_at" resp)))
(setf (client-token client) token)
(values token expires-at)))
(defun validate-token (client token-string)
"Validate TOKEN-STRING with the MCIAS server.
Returns a plist with :valid :sub :roles :expires-at.
:valid is T for a valid token, NIL for invalid (not an error condition)."
(let* ((body (let ((ht (make-hash-table :test 'equal)))
(setf (gethash "token" ht) token-string)
ht))
(resp (%request client :post "/v1/token/validate" :body body))
;; yason parses JSON true -> T, JSON false -> :FALSE
(raw-valid (gethash "valid" resp))
(valid (if (eq raw-valid t) t nil)))
(list :valid valid
:sub (gethash "sub" resp)
:roles (gethash "roles" resp)
:expires-at (gethash "expires_at" resp))))
;;;; -----------------------------------------------------------------------
;;;; Server information
;;;; -----------------------------------------------------------------------
(defun health (client)
"Check server health. Returns T on success, signals on failure."
(%request client :get "/v1/health")
t)
(defun get-public-key (client)
"Fetch the server's public key (JWK).
Returns a plist with :kty :crv :x."
(let ((resp (%request client :get "/v1/keys/public")))
(list :kty (gethash "kty" resp)
:crv (gethash "crv" resp)
:x (gethash "x" resp))))
;;;; -----------------------------------------------------------------------
;;;; Account management (admin)
;;;; -----------------------------------------------------------------------
(defun create-account (client username account-type &key password)
"Create a new account. Requires admin token.
Returns an account plist."
(let ((body (let ((ht (make-hash-table :test 'equal)))
(setf (gethash "username" ht) username
(gethash "account_type" ht) account-type)
(when password
(setf (gethash "password" ht) password))
ht)))
(%account->plist (%request client :post "/v1/accounts" :body body))))
(defun list-accounts (client)
"List all accounts. Requires admin token.
Returns a list of account plists."
(let ((resp (%request client :get "/v1/accounts")))
;; Response is a JSON array
(mapcar #'%account->plist resp)))
(defun get-account (client id)
"Get account by ID. Requires admin token.
Returns an account plist."
(%account->plist (%request client :get (format nil "/v1/accounts/~A" id))))
(defun update-account (client id &key status)
"Update account fields. Requires admin token.
Returns updated account plist."
(let ((body (let ((ht (make-hash-table :test 'equal)))
(when status
(setf (gethash "status" ht) status))
ht)))
(%account->plist (%request client :patch
(format nil "/v1/accounts/~A" id)
:body body))))
(defun delete-account (client id)
"Delete account by ID. Requires admin token.
Returns T on success."
(%request client :delete (format nil "/v1/accounts/~A" id))
t)
;;;; -----------------------------------------------------------------------
;;;; Role management (admin)
;;;; -----------------------------------------------------------------------
(defun get-roles (client account-id)
"Get roles for ACCOUNT-ID. Requires admin token.
Returns a list of role strings."
(let ((resp (%request client :get (format nil "/v1/accounts/~A/roles" account-id))))
(gethash "roles" resp)))
(defun set-roles (client account-id roles)
"Set roles for ACCOUNT-ID to ROLES (list of strings). Requires admin token.
Returns T on success."
(let ((body (let ((ht (make-hash-table :test 'equal)))
(setf (gethash "roles" ht) roles)
ht)))
(%request client :put
(format nil "/v1/accounts/~A/roles" account-id)
:body body)
t))
;;;; -----------------------------------------------------------------------
;;;; Token management (admin)
;;;; -----------------------------------------------------------------------
(defun issue-service-token (client account-id)
"Issue a service token for ACCOUNT-ID. Requires admin token.
Returns (values token expires-at)."
(let* ((body (let ((ht (make-hash-table :test 'equal)))
(setf (gethash "account_id" ht) account-id)
ht))
(resp (%request client :post "/v1/token/issue" :body body))
(token (gethash "token" resp))
(expires-at (gethash "expires_at" resp)))
(values token expires-at)))
(defun revoke-token (client jti)
"Revoke token by JTI. Requires admin token.
Returns T on success."
(%request client :delete (format nil "/v1/token/~A" jti))
t)
;;;; -----------------------------------------------------------------------
;;;; PG credentials (admin)
;;;; -----------------------------------------------------------------------
(defun get-pg-creds (client account-id)
"Get PostgreSQL credentials for ACCOUNT-ID. Requires admin token.
Returns a plist with :host :port :database :username :password."
(let ((resp (%request client :get (format nil "/v1/accounts/~A/pgcreds" account-id))))
(list :host (gethash "host" resp)
:port (gethash "port" resp)
:database (gethash "database" resp)
:username (gethash "username" resp)
:password (gethash "password" resp))))
(defun set-pg-creds (client account-id host port database username password)
"Set PostgreSQL credentials for ACCOUNT-ID. Requires admin token.
Returns T on success."
(let ((body (let ((ht (make-hash-table :test 'equal)))
(setf (gethash "host" ht) host
(gethash "port" ht) port
(gethash "database" ht) database
(gethash "username" ht) username
(gethash "password" ht) password)
ht)))
(%request client :put
(format nil "/v1/accounts/~A/pgcreds" account-id)
:body body)
t))

37
clients/lisp/conditions.lisp Normal file
View File

@@ -0,0 +1,37 @@
;;;; conditions.lisp -- MCIAS error condition hierarchy
(in-package #:mcias-client)
(define-condition mcias-error (error)
((status :initarg :status :reader mcias-error-status
:documentation "HTTP status code (integer).")
(message :initarg :message :reader mcias-error-message
:documentation "Server error message string."))
(:report (lambda (c s)
(format s "MCIAS error ~A: ~A"
(mcias-error-status c)
(mcias-error-message c))))
(:documentation "Base condition for all MCIAS API errors."))
(define-condition mcias-auth-error (mcias-error) ()
(:documentation "401 Unauthorized -- token missing, invalid, or expired."))
(define-condition mcias-forbidden-error (mcias-error) ()
(:documentation "403 Forbidden -- insufficient role."))
(define-condition mcias-not-found-error (mcias-error) ()
(:documentation "404 Not Found -- resource does not exist."))
(define-condition mcias-input-error (mcias-error) ()
(:documentation "400 Bad Request -- malformed request."))
(define-condition mcias-conflict-error (mcias-error) ()
(:documentation "409 Conflict -- e.g. duplicate username."))
(define-condition mcias-server-error (mcias-error) ()
(:documentation "5xx -- unexpected server error."))
(defun signal-mcias-error (status message)
"Signal the appropriate MCIAS condition for STATUS (integer) and MESSAGE (string)."
(case status
(401 (error 'mcias-auth-error :status status :message message))
(403 (error 'mcias-forbidden-error :status status :message message))
(404 (error 'mcias-not-found-error :status status :message message))
(400 (error 'mcias-input-error :status status :message message))
(409 (error 'mcias-conflict-error :status status :message message))
(t (error 'mcias-server-error :status status :message message))))

25
clients/lisp/mcias-client.asd Normal file
View File

@@ -0,0 +1,25 @@
(defsystem "mcias-client"
:version "0.1.0"
:author "Kyle Isom"
:description "Common Lisp client for the MCIAS identity and access management API"
:license "MIT"
:depends-on ("dexador"
"yason"
"cl-ppcre"
"alexandria")
:components ((:file "package")
(:file "conditions" :depends-on ("package"))
(:file "client" :depends-on ("package" "conditions")))
:in-order-to ((test-op (test-op "mcias-client/tests"))))
(defsystem "mcias-client/tests"
:version "0.1.0"
:description "Tests for mcias-client"
:depends-on ("mcias-client"
"fiveam"
"hunchentoot"
"babel")
:components ((:file "tests/package")
(:file "tests/mock-server" :depends-on ("tests/package"))
(:file "tests/client-tests" :depends-on ("tests/package" "tests/mock-server")))
:perform (test-op (op c)
(uiop:symbol-call :mcias-client-tests :run-all-tests)))

49
clients/lisp/package.lisp Normal file
View File

@@ -0,0 +1,49 @@
;;;; package.lisp -- package definition for mcias-client
(defpackage #:mcias-client
(:use #:cl)
(:export
;; Client construction
#:make-client
#:client-base-url
#:client-token
;; Conditions
#:mcias-error
#:mcias-auth-error
#:mcias-forbidden-error
#:mcias-not-found-error
#:mcias-input-error
#:mcias-conflict-error
#:mcias-server-error
#:mcias-error-status
#:mcias-error-message
;; Authentication
#:login
#:logout
#:renew-token
#:validate-token
;; Server information
#:health
#:get-public-key
;; Account management (admin)
#:create-account
#:list-accounts
#:get-account
#:update-account
#:delete-account
;; Role management (admin)
#:get-roles
#:set-roles
;; Token management (admin)
#:issue-service-token
#:revoke-token
;; PG credentials (admin)
#:get-pg-creds
#:set-pg-creds))

201
clients/lisp/tests/client-tests.lisp Normal file
View File

@@ -0,0 +1,201 @@
;;;; tests/client-tests.lisp -- fiveam test suite for mcias-client
(in-package #:mcias-client-tests)
;;;; -----------------------------------------------------------------------
;;;; Test suite
;;;; -----------------------------------------------------------------------
(fiveam:def-suite mcias-client-suite
:description "Tests for the mcias-client library")
(fiveam:in-suite mcias-client-suite)
;;;; -----------------------------------------------------------------------
;;;; Helper macro
;;;; -----------------------------------------------------------------------
(defmacro with-mock-server ((client-var &key admin-token) &body body)
"Spin up a fresh mock server, bind CLIENT-VAR, run BODY, then stop."
(let ((port-var (gensym "PORT"))
(server-url (gensym "URL")))
`(let* ((,port-var (start-mock-server))
(,server-url (format nil "http://localhost:~A" ,port-var))
(,client-var (make-client ,server-url :token ,admin-token)))
(unwind-protect
(progn ,@body)
(stop-mock-server)))))
;;;; -----------------------------------------------------------------------
;;;; Condition hierarchy tests
;;;; -----------------------------------------------------------------------
(fiveam:test condition-hierarchy
"Verify the condition type hierarchy."
(fiveam:is (subtypep 'mcias-auth-error 'mcias-error))
(fiveam:is (subtypep 'mcias-forbidden-error 'mcias-error))
(fiveam:is (subtypep 'mcias-not-found-error 'mcias-error))
(fiveam:is (subtypep 'mcias-input-error 'mcias-error))
(fiveam:is (subtypep 'mcias-conflict-error 'mcias-error))
(fiveam:is (subtypep 'mcias-server-error 'mcias-error)))
;;;; -----------------------------------------------------------------------
;;;; make-client tests
;;;; -----------------------------------------------------------------------
(fiveam:test make-client-basic
"make-client stores base-url and token."
(let ((c (make-client "http://localhost:9000" :token "tok123")))
(fiveam:is (string= "http://localhost:9000" (client-base-url c)))
(fiveam:is (string= "tok123" (client-token c)))))
(fiveam:test make-client-strips-trailing-slash
"make-client trims trailing slashes from the URL."
(let ((c (make-client "http://localhost:9000///")))
(fiveam:is (string= "http://localhost:9000" (client-base-url c)))))
(fiveam:test make-client-no-token
"make-client with no :token gives NIL token."
(let ((c (make-client "http://localhost:9000")))
(fiveam:is (null (client-token c)))))
;;;; -----------------------------------------------------------------------
;;;; Server info tests
;;;; -----------------------------------------------------------------------
(fiveam:test health-ok
"health returns T for a live server."
(with-mock-server (c)
(fiveam:is (eq t (health c)))))
(fiveam:test get-public-key
"get-public-key returns a plist with :kty :crv :x."
(with-mock-server (c)
(let ((jwk (get-public-key c)))
(fiveam:is (string= "OKP" (getf jwk :kty)))
(fiveam:is (string= "Ed25519" (getf jwk :crv)))
(fiveam:is (stringp (getf jwk :x))))))
;;;; -----------------------------------------------------------------------
;;;; Authentication tests
;;;; -----------------------------------------------------------------------
(fiveam:test login-success
"Successful login returns a token and stores it in the client."
(with-mock-server (c)
(multiple-value-bind (token expires-at)
(login c "admin" "adminpass")
(fiveam:is (stringp token))
(fiveam:is (stringp expires-at))
(fiveam:is (string= token (client-token c))))))
(fiveam:test login-bad-password
"Wrong password signals mcias-auth-error."
(with-mock-server (c)
(fiveam:signals mcias-auth-error
(login c "admin" "wrongpassword"))))
(fiveam:test login-unknown-user
"Unknown username signals mcias-auth-error."
(with-mock-server (c)
(fiveam:signals mcias-auth-error
(login c "nosuchuser" "whatever"))))
(fiveam:test logout-clears-token
"logout revokes the token server-side and sets client-token to NIL."
(with-mock-server (c)
(login c "admin" "adminpass")
(fiveam:is (stringp (client-token c)))
(fiveam:is (eq t (logout c)))
(fiveam:is (null (client-token c)))))
(fiveam:test renew-token
"renew-token replaces the stored token."
(with-mock-server (c)
(login c "admin" "adminpass")
(let ((old-token (client-token c)))
(multiple-value-bind (new-token expires-at)
(renew-token c)
(fiveam:is (stringp new-token))
(fiveam:is (stringp expires-at))
(fiveam:is (not (string= old-token new-token)))
(fiveam:is (string= new-token (client-token c)))))))
;;;; -----------------------------------------------------------------------
;;;; Token validation tests
;;;; -----------------------------------------------------------------------
(fiveam:test validate-token-valid
"validate-token returns :valid T for a live token."
(with-mock-server (c)
(multiple-value-bind (token _expires)
(login c "admin" "adminpass")
(declare (ignore _expires))
(let ((result (validate-token c token)))
(fiveam:is (eq t (getf result :valid)))
(fiveam:is (stringp (getf result :sub)))))))
(fiveam:test validate-token-after-logout
"validate-token returns :valid NIL for a revoked token (not an error)."
(with-mock-server (c)
(login c "admin" "adminpass")
(let ((token (client-token c)))
(logout c)
(let ((result (validate-token c token)))
(fiveam:is (null (getf result :valid)))))))
(fiveam:test validate-token-garbage
"validate-token returns :valid NIL for a garbage token string."
(with-mock-server (c)
(let ((result (validate-token c "garbage-token-xyz")))
(fiveam:is (null (getf result :valid))))))
;;;; -----------------------------------------------------------------------
;;;; Account management tests
;;;; -----------------------------------------------------------------------
(fiveam:test create-account
"create-account returns a plist with :id :username :status."
(with-mock-server (c)
(login c "admin" "adminpass")
(let ((acct (create-account c "newuser" "user" :password "pass123")))
(fiveam:is (stringp (getf acct :id)))
(fiveam:is (string= "newuser" (getf acct :username)))
(fiveam:is (stringp (getf acct :status))))))
(fiveam:test list-accounts
"list-accounts returns a list with at least the admin account."
(with-mock-server (c)
(login c "admin" "adminpass")
(let ((accounts (list-accounts c)))
(fiveam:is (listp accounts))
(fiveam:is (>= (length accounts) 1)))))
;;;; -----------------------------------------------------------------------
;;;; End-to-end lifecycle test
;;;; -----------------------------------------------------------------------
(fiveam:test e2e-login-validate-logout
"Full lifecycle: login -> validate (valid) -> logout -> validate (invalid)."
(with-mock-server (c)
(multiple-value-bind (token _)
(login c "admin" "adminpass")
(declare (ignore _))
;; Token should be valid right after login
(let ((r1 (validate-token c token)))
(fiveam:is (eq t (getf r1 :valid))))
;; Logout revokes the token
(logout c)
;; Token should now be invalid (not an error)
(let ((r2 (validate-token c token)))
(fiveam:is (null (getf r2 :valid)))))))
;;;; -----------------------------------------------------------------------
;;;; Entry point
;;;; -----------------------------------------------------------------------
(defun run-all-tests ()
"Run all mcias-client tests. Returns T if all pass."
(let ((results (fiveam:run 'mcias-client-suite)))
(fiveam:explain! results)
(fiveam:results-status results)))

409
clients/lisp/tests/mock-server.lisp Normal file
View File

@@ -0,0 +1,409 @@
;;;; 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)))

8
clients/lisp/tests/package.lisp Normal file
View File

@@ -0,0 +1,8 @@
;;;; tests/package.lisp
;;; We do NOT :use #:fiveam to avoid importing fiveam symbols into our
;;; package (which causes SBCL package-lock errors on some versions).
;;; Instead we prefix all fiveam calls with fiveam:.
(defpackage #:mcias-client-tests
(:use #:cl #:mcias-client)
(:export #:run-all-tests))