Implement Phase 9: client libraries (Go, Rust, Lisp, Python)
- 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:
201
clients/lisp/tests/client-tests.lisp
Normal file
201
clients/lisp/tests/client-tests.lisp
Normal 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
409
clients/lisp/tests/mock-server.lisp
Normal 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
8
clients/lisp/tests/package.lisp
Normal 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))
|
||||
Reference in New Issue
Block a user