;;;; 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)))