From f912762f2d081d385526196d08feabf3891a4dbc Mon Sep 17 00:00:00 2001 From: Eric Fode Date: Sun, 30 Aug 2026 11:43:54 -0700 Subject: [PATCH 1/4] Use browser OAuth for ChatGPT authentication --- autolith.asd | 4 +- docs/architecture.org | 2 +- docs/guide.org | 10 +- src/configuration/settings.lisp | 30 + src/provider/authentication.lisp | 53 ++ src/provider/chatgpt/authentication.lisp | 531 ++++++++++++++++ src/provider/client.lisp | 14 +- src/provider/device-authentication.lisp | 304 +-------- src/provider/gemini/authentication.lisp | 37 +- src/provider/nous/authentication.lisp | 2 +- tests/authentication-tests.lisp | 2 +- tests/chatgpt-authentication-tests.lisp | 272 ++++++++ tests/device-authentication-test-support.lisp | 55 ++ tests/device-authentication-tests.lisp | 596 ------------------ tests/tests.lisp | 2 +- 15 files changed, 968 insertions(+), 946 deletions(-) create mode 100644 src/provider/chatgpt/authentication.lisp create mode 100644 tests/chatgpt-authentication-tests.lisp create mode 100644 tests/device-authentication-test-support.lisp delete mode 100644 tests/device-authentication-tests.lisp diff --git a/autolith.asd b/autolith.asd index fd4478f5..064463c2 100644 --- a/autolith.asd +++ b/autolith.asd @@ -62,6 +62,7 @@ (:file "configuration/preferences") (:file "configuration/permissions") (:file "provider/authentication") + (:file "provider/chatgpt/authentication") (:file "provider/gemini/authentication") (:file "provider/grok/authentication") (:file "provider/api-key") @@ -201,6 +202,7 @@ :components ((:module "tests" :serial t :components ((:file "test-support") + (:file "device-authentication-test-support") (:file "stream-tests") (:file "memory-tests") (:file "papercut-tests") @@ -223,6 +225,7 @@ (:file "conversation-replay-tests") (:file "plan-tests") (:file "authentication-tests") + (:file "chatgpt-authentication-tests") (:file "gemini-authentication-tests") (:file "grok-authentication-tests") (:file "nous-authentication-tests") @@ -249,7 +252,6 @@ (:file "recovery-tests") (:file "lisp-worker-tests") (:file "self-tool-tests") - (:file "device-authentication-tests") (:file "nous-device-authentication-tests") (:file "agent-tests") (:file "inference-tests") diff --git a/docs/architecture.org b/docs/architecture.org index e872a442..d79c7308 100644 --- a/docs/architecture.org +++ b/docs/architecture.org @@ -113,7 +113,7 @@ provider request --> semantic events --> agent --> validated tool calls - Configuration records credential *locations* only - A provider request sees tokens only in its dynamic scope - The optional Codex file is a one-time access-token import -- Renewable credentials come from Autolith's own device flow +- Renewable ChatGPT credentials come from Autolith's browser OAuth flow * Workspace and workers diff --git a/docs/guide.org b/docs/guide.org index d6731f2d..2a825fe5 100644 --- a/docs/guide.org +++ b/docs/guide.org @@ -433,10 +433,12 @@ available. =(models)= triggers discovery. You can also pass non-secret =:headers= and static =:models= for descriptions, windows, efforts, or providers that have no model-list endpoint. -Built-in ChatGPT, Grok, and Nous Research subscriptions authenticate through a -browser device flow. Gemini uses Google installed-application OAuth with a local -loopback callback. Anthropic, Fireworks, OpenCode, OpenRouter, Mistral, and -user-registered OpenAI-compatible providers use API keys. +Built-in ChatGPT subscriptions use browser OAuth with PKCE and a local callback +on =localhost:1455= or =localhost:1457=. The authorization URL is always printed +for manual browser use. Grok and Nous Research use browser device flows. Gemini +uses Google installed-application OAuth with a local loopback callback. +Anthropic, Fireworks, OpenCode, OpenRouter, Mistral, and user-registered +OpenAI-compatible providers use API keys. ChatGPT Codex Fast mode sends =service_tier=priority= when the active Codex model advertises Fast support and uses 2x plan usage. The built-in GPT-5.6 models diff --git a/src/configuration/settings.lisp b/src/configuration/settings.lisp index 9291b47f..d4ba6650 100644 --- a/src/configuration/settings.lisp +++ b/src/configuration/settings.lisp @@ -15,6 +15,12 @@ "https://chatgpt.com/backend-api/codex/responses" "The current ChatGPT Codex Responses endpoint.") +;; ChatGPT browser OAuth behavior inspected at +;; https://github.com/openai/codex commit +;; 94cbbddafc1776d5e377bca1b05932c697e82238. +(defparameter *openai-oauth-issuer* "https://auth.openai.com" + "The OpenAI issuer serving ChatGPT browser OAuth.") + (defparameter *openai-oauth-token-endpoint* "https://auth.openai.com/oauth/token" "The OpenAI OAuth token endpoint.") @@ -22,6 +28,30 @@ (defparameter *openai-oauth-client-id* "app_EMoamEEZ73f0CkXaXp7hrann" "The public OAuth client identifier used by Codex-compatible clients.") +(defparameter *openai-oauth-scopes* + '("openid" + "profile" + "email" + "offline_access" + "api.connectors.read" + "api.connectors.invoke") + "The scopes requested by ChatGPT browser OAuth.") + +(defparameter *openai-oauth-originator* "autolith" + "The honest client originator sent during ChatGPT browser OAuth.") + +(defparameter *chatgpt-oauth-callback-ports* '(1455 1457) + "The localhost callback ports allowed by the ChatGPT OAuth client.") + +(defparameter *chatgpt-oauth-callback-timeout* 900 + "The maximum seconds to wait for the ChatGPT browser callback.") + +(defparameter *chatgpt-oauth-request-timeout* 5 + "The maximum seconds allowed to read one local callback request line.") + +(defparameter *chatgpt-oauth-request-line-limit* 8192 + "The maximum characters accepted in one local callback request line.") + ;; Gemini CLI OAuth behavior inspected at google-gemini/gemini-cli commit ;; 0bd1d439751478771c45d3d0895a6a9760554bf4. The installed application uses ;; PKCE as a public client. Autolith deliberately does not embed its client diff --git a/src/provider/authentication.lisp b/src/provider/authentication.lisp index ecb5dd55..4b7266fa 100644 --- a/src/provider/authentication.lisp +++ b/src/provider/authentication.lisp @@ -81,6 +81,59 @@ its protocol-level close operation." (json-object-p (aref organizations 0))) (json-get (aref organizations 0) "id"))))))) + +;;;; -- OAuth Wire Helpers -- + +(-> authentication-user-agent () string) +(defun authentication-user-agent () + "Return the honest Autolith user agent sent to authentication services." + (format nil "autolith/~A (~A ~A; ~A)" + *autolith-version* + (software-type) + (software-version) + (machine-type))) + +(-> oauth--base64url ((simple-array (unsigned-byte 8) (*))) string) +(defun oauth--base64url (octets) + "Return OCTETS as unpadded RFC 4648 Base64url text." + (string-right-trim + '(#\=) + (substitute #\_ + #\/ + (substitute #\- + #\+ + (usb8-array-to-base64-string octets))))) + +(-> oauth--create-pkce (&key (:verifier-octets integer)) (values string string)) +(defun oauth--create-pkce (&key (verifier-octets 32)) + "Return a fresh PKCE verifier and S256 challenge from VERIFIER-OCTETS." + (unless (plusp verifier-octets) + (error 'authentication-error + :message "The OAuth PKCE verifier size must be positive.")) + (let* ((verifier (oauth--base64url (random-data verifier-octets))) + (octets (map '(simple-array (unsigned-byte 8) (*)) #'char-code verifier)) + (challenge + (oauth--base64url + (ironclad:digest-sequence ':sha256 octets)))) + (values verifier challenge))) + +(-> oauth--query-parameters (string) list) +(defun oauth--query-parameters (target) + "Decode TARGET's query string into an association list." + (let ((question (position #\? target))) + (when question + (loop with query = (subseq target (1+ question)) + with start = 0 + for end = (position #\& query :start start) + for field = (subseq query start end) + for equals = (position #\= field) + collect (cons (url-decode (subseq field 0 equals)) + (url-decode (if equals + (subseq field (1+ equals)) + ""))) + while end + do (setf start (1+ end)))))) + ;;;; -- Credential Sources -- (defclass credential-source (cl-rfc8628:credential-source) diff --git a/src/provider/chatgpt/authentication.lisp b/src/provider/chatgpt/authentication.lisp new file mode 100644 index 00000000..6777e820 --- /dev/null +++ b/src/provider/chatgpt/authentication.lisp @@ -0,0 +1,531 @@ +(in-package #:autolith) + +;;;; -- ChatGPT Browser OAuth Conditions -- + +(define-condition chatgpt-oauth-error (authentication-error) + ((stage + :initarg :stage + :reader chatgpt-oauth-error-stage + :type keyword + :documentation "The browser OAuth stage that failed.") + (status + :initarg :status + :initform nil + :reader chatgpt-oauth-error-status + :type (option integer) + :documentation "The HTTP status returned by OpenAI, if known.") + (code + :initarg :code + :initform nil + :reader chatgpt-oauth-error-code + :type (option string) + :documentation "A bounded non-secret OAuth error code, if supplied.") + (response + :initarg :response + :initform nil + :reader chatgpt-oauth-error-response + :type (option string) + :documentation "A bounded redacted OAuth error description, if supplied.")) + (:documentation "A failure in ChatGPT browser OAuth.")) + +(define-condition chatgpt-oauth-state-mismatch (chatgpt-oauth-error) + () + (:documentation + "A local ChatGPT OAuth callback whose state does not match the active login.")) + + +;;;; -- PKCE and Authorization URL -- + +(-> chatgpt-oauth-create-pkce () (values string string)) +(defun chatgpt-oauth-create-pkce () + "Return a fresh 512-bit PKCE verifier and its S256 challenge." + (oauth--create-pkce :verifier-octets 64)) + +(-> chatgpt-oauth--state () string) +(defun chatgpt-oauth--state () + "Return a fresh 256-bit OAuth state value." + (oauth--base64url (random-data 32))) + +(-> chatgpt-oauth-authorization-url + (&key + (:redirect-uri string) + (:state string) + (:code-challenge string) + (:issuer string) + (:client-id string) + (:originator string)) + string) +(defun chatgpt-oauth-authorization-url + (&key + redirect-uri + state + code-challenge + (issuer *openai-oauth-issuer*) + (client-id *openai-oauth-client-id*) + (originator *openai-oauth-originator*)) + "Build the OpenAI authorization URL for one ChatGPT browser login." + (format nil "~A/oauth/authorize?~A" + (string-right-trim '(#\/) issuer) + (url-encode-params + (list + (cons "response_type" "code") + (cons "client_id" client-id) + (cons "redirect_uri" redirect-uri) + (cons "scope" (format nil "~{~A~^ ~}" *openai-oauth-scopes*)) + (cons "code_challenge" code-challenge) + (cons "code_challenge_method" "S256") + (cons "id_token_add_organizations" "true") + (cons "codex_cli_simplified_flow" "true") + (cons "state" state) + (cons "originator" originator))))) + +(-> chatgpt-oauth--redacted-value (t list) (option string)) +(defun chatgpt-oauth--redacted-value (value secrets) + "Return bounded VALUE after exact secret redaction, or NIL." + (when (stringp value) + (let ((bounded (bounded-string value :limit 256))) + (redact-exact-string-values + bounded secrets + (safe-redaction-marker "[OAUTH VALUE REDACTED]" secrets))))) + +(-> chatgpt-oauth--fail + (&key + (:stage keyword) + (:message string) + (:status (option integer)) + (:code (option string)) + (:response (option string))) + nil) +(defun chatgpt-oauth--fail (&key stage message status code response) + "Signal a structured ChatGPT OAuth failure containing only safe metadata." + (error 'chatgpt-oauth-error + :message message + :stage stage + :status status + :code code + :response response)) + + +;;;; -- Loopback Callback -- + +(-> chatgpt-oauth--open-listener (integer) (option sb-bsd-sockets:inet-socket)) +(defun chatgpt-oauth--open-listener (port) + "Open one IPv4 loopback listener on PORT, or return NIL when unavailable." + (let ((listener nil)) + (handler-case + (progn + (setf listener (make-instance 'sb-bsd-sockets:inet-socket + :type ':stream + :protocol ':tcp)) + (sb-bsd-sockets:socket-bind + listener + (sb-bsd-sockets:make-inet-address "127.0.0.1") + port) + (sb-bsd-sockets:socket-listen listener 4) + listener) + (error () + (when listener + (ignore-errors (sb-bsd-sockets:socket-close listener))) + nil)))) + +(-> chatgpt-oauth-loopback-open () (values sb-bsd-sockets:inet-socket string)) +(defun chatgpt-oauth-loopback-open () + "Open the first available allowlisted ChatGPT callback port." + (dolist (port *chatgpt-oauth-callback-ports*) + (let ((listener (chatgpt-oauth--open-listener port))) + (when listener + (return-from chatgpt-oauth-loopback-open + (values listener + (format nil "http://localhost:~D/auth/callback" port)))))) + (chatgpt-oauth--fail + :stage ':callback-listen + :message + (format nil + "Could not start the ChatGPT OAuth callback server on localhost port~P ~{~D~^ or ~}." + (length *chatgpt-oauth-callback-ports*) + *chatgpt-oauth-callback-ports*))) + +(-> chatgpt-oauth--write-callback-response (stream string string) null) +(defun chatgpt-oauth--write-callback-response (stream status body) + "Write one minimal browser response with STATUS and ASCII BODY." + (format stream + "HTTP/1.1 ~A~C~CContent-Type: text/plain; charset=utf-8~C~CContent-Length: ~D~C~CConnection: close~C~C~C~C~A" + status + #\Return #\Linefeed #\Return #\Linefeed + (length body) + #\Return #\Linefeed #\Return #\Linefeed + #\Return #\Linefeed + body) + (finish-output stream) + nil) + +(-> chatgpt-oauth--request-target (string) (option string)) +(defun chatgpt-oauth--request-target (request-line) + "Return the request target from one HTTP GET request line." + (when (uiop:string-prefix-p "GET " request-line) + (let* ((first-space (position #\Space request-line)) + (second-space (and first-space + (position #\Space request-line + :start (1+ first-space))))) + (and second-space + (subseq request-line (1+ first-space) second-space))))) + +(-> chatgpt-oauth--callback-target-p ((option string)) boolean) +(defun chatgpt-oauth--callback-target-p (target) + "Return true when TARGET addresses the ChatGPT OAuth callback path." + (and target + (let ((question (position #\? target))) + (string= (subseq target 0 question) "/auth/callback")))) + +(-> chatgpt-oauth--state-matches-p (t string) boolean) +(defun chatgpt-oauth--state-matches-p (actual expected) + "Return true when ACTUAL is EXPECTED or its supported onboarding variant." + (and (stringp actual) + (or (string= actual expected) + (string= actual + (format nil "~A.onboarding_entrypoint=life_sciences" + expected))))) + +(-> chatgpt-oauth--callback-code (string string) string) +(defun chatgpt-oauth--callback-code (target expected-state) + "Validate one callback TARGET and return its authorization code." + (let* ((parameters (oauth--query-parameters target)) + (state (rest (assoc "state" parameters :test #'string=))) + (code (rest (assoc "code" parameters :test #'string=))) + (raw-error (rest (assoc "error" parameters :test #'string=))) + (raw-description + (rest (assoc "error_description" parameters :test #'string=))) + (secrets (list expected-state code)) + (safe-error (chatgpt-oauth--redacted-value raw-error secrets)) + (safe-description + (chatgpt-oauth--redacted-value raw-description secrets))) + (unless (chatgpt-oauth--state-matches-p state expected-state) + (error 'chatgpt-oauth-state-mismatch + :message "The ChatGPT OAuth callback state did not match." + :stage ':callback + :status nil + :code nil + :response nil)) + (when raw-error + (chatgpt-oauth--fail + :stage ':authorization + :message (format nil "OpenAI rejected ChatGPT authorization~@[ (~A)~]." + safe-error) + :code safe-error + :response safe-description)) + (unless (non-empty-string-p code) + (chatgpt-oauth--fail + :stage ':callback + :message "The ChatGPT OAuth callback omitted its authorization code.")) + code)) + + +(-> chatgpt-oauth--callback-code-or-continue (string string) (option string)) +(defun chatgpt-oauth--callback-code-or-continue (target expected-state) + "Return a callback code, or NIL when an unrelated local callback should be ignored." + (handler-case + (chatgpt-oauth--callback-code target expected-state) + (chatgpt-oauth-state-mismatch () + nil))) + +(-> chatgpt-oauth--read-request-line + (stream integer integer + &key (:clock-function function) (:wait-function function) + (:request-timeout integer) (:line-limit integer)) + (option string)) +(defun chatgpt-oauth--read-request-line + (stream file-descriptor deadline + &key + (clock-function #'device-authentication-monotonic-seconds) + (wait-function #'sb-sys:wait-until-fd-usable) + (request-timeout *chatgpt-oauth-request-timeout*) + (line-limit *chatgpt-oauth-request-line-limit*)) + "Read one bounded callback request line without exceeding the local deadline." + (let* ((started-at (funcall clock-function)) + (connection-deadline + (min deadline (+ started-at request-timeout))) + (characters + (make-array 128 + :element-type 'character + :adjustable t + :fill-pointer 0))) + (loop + (when (>= (length characters) line-limit) + (return nil)) + (let ((remaining (- connection-deadline (funcall clock-function)))) + (unless (and (plusp remaining) + (or (listen stream) + (funcall wait-function + file-descriptor ':input remaining))) + (return nil))) + (let ((character (read-char stream nil nil))) + (cond + ((null character) + (return nil)) + ((char= character #\Linefeed) + (return + (string-right-trim '(#\Return) + (coerce characters 'string)))) + (t + (vector-push-extend character characters))))))) + +(-> chatgpt-oauth-await-loopback + (sb-bsd-sockets:inet-socket string &key (:timeout integer)) + string) +(defun chatgpt-oauth-await-loopback + (listener expected-state &key (timeout *chatgpt-oauth-callback-timeout*)) + "Wait at most TIMEOUT seconds for a valid ChatGPT browser callback." + (let ((deadline (+ (device-authentication-monotonic-seconds) timeout))) + (loop + (let ((remaining (- deadline (device-authentication-monotonic-seconds)))) + (unless (and (plusp remaining) + (sb-sys:wait-until-fd-usable + (sb-bsd-sockets:socket-file-descriptor listener) + ':input + remaining)) + (chatgpt-oauth--fail + :stage ':callback-wait + :message "ChatGPT authentication timed out waiting for the browser callback.")) + (let ((socket nil) + (stream nil)) + (unwind-protect + (progn + (setf socket (sb-bsd-sockets:socket-accept listener) + stream (sb-bsd-sockets:socket-make-stream + socket + :input t + :output t + :element-type 'character + :external-format ':utf-8 + :buffering ':none)) + (let* ((request-line + (chatgpt-oauth--read-request-line + stream + (sb-bsd-sockets:socket-file-descriptor socket) + deadline)) + (target + (and request-line + (chatgpt-oauth--request-target request-line)))) + (cond + ((null request-line) + nil) + ((not (chatgpt-oauth--callback-target-p target)) + (chatgpt-oauth--write-callback-response + stream "404 Not Found" "Not Found")) + (t + (handler-case + (let ((code + (chatgpt-oauth--callback-code-or-continue + target expected-state))) + (if code + (progn + (chatgpt-oauth--write-callback-response + stream + "200 OK" + "ChatGPT authorization was received. Return to Autolith.") + (return code)) + (chatgpt-oauth--write-callback-response + stream + "400 Bad Request" + "ChatGPT authorization did not match this login."))) + (chatgpt-oauth-error (condition) + (chatgpt-oauth--write-callback-response + stream + "400 Bad Request" + "ChatGPT authorization failed. Return to Autolith.") + (error condition))))))) + (when stream + (ignore-errors (close stream))) + (when (and socket (null stream)) + (ignore-errors (sb-bsd-sockets:socket-close socket))))))))) + + +;;;; -- Token Exchange -- + +(-> chatgpt-oauth--request + (&key (:url string) (:content string)) + (values string integer list)) +(defun chatgpt-oauth--request (&key url content) + "POST one form-encoded request to OpenAI's OAuth token endpoint." + (handler-case + (multiple-value-bind (body status headers uri stream) + (dexador:post + url + :headers + (list (cons "Content-Type" "application/x-www-form-urlencoded") + (cons "Accept" "application/json") + (cons "User-Agent" (authentication-user-agent)) + (cons "originator" *openai-oauth-originator*)) + :content content + :force-string t + :connect-timeout 30 + :read-timeout 60) + (declare (ignore uri stream)) + (values body status headers)) + (http-request-failed (condition) + (values (or (response-body condition) "") + (response-status condition) + (response-headers condition))))) + +(-> chatgpt-oauth--error-description (t) (option string)) +(defun chatgpt-oauth--error-description (document) + "Return the provider error description carried by DOCUMENT, if any." + (when (json-object-p document) + (or (json-get document "error_description") + (let ((error (json-get document "error"))) + (and (json-object-p error) + (or (json-get error "message") + (json-get error "description"))))))) + +(-> chatgpt-oauth--token-document (function string list keyword) json-object) +(defun chatgpt-oauth--token-document + (request-function endpoint parameters stage) + "POST PARAMETERS and validate the JSON token response for STAGE." + (let* ((content (url-encode-params parameters)) + (secrets (remove-if-not #'non-empty-string-p + (mapcar #'rest parameters)))) + (multiple-value-bind (body status headers) + (funcall request-function :url endpoint :content content) + (declare (ignore headers)) + (unless (and (integerp status) (<= 200 status 299)) + (let* ((document (handler-case (json-decode body) (error () nil))) + (raw-code (oauth-error-code body)) + (raw-description + (chatgpt-oauth--error-description document)) + (code (chatgpt-oauth--redacted-value raw-code secrets)) + (description + (chatgpt-oauth--redacted-value raw-description secrets))) + (chatgpt-oauth--fail + :stage stage + :message (format nil "ChatGPT OAuth token request failed~@[ (~A)~]." + code) + :status (and (integerp status) status) + :code code + :response description))) + (handler-case + (let ((document (json-decode body))) + (unless (json-object-p document) + (error "not an object")) + document) + (error () + (chatgpt-oauth--fail + :stage stage + :message "The ChatGPT OAuth token response contained invalid JSON." + :status status)))))) + +(-> chatgpt-oauth--credentials-from-document + (chatgpt-credential-manager json-object) + oauth-credentials) +(defun chatgpt-oauth--credentials-from-document (manager document) + "Validate DOCUMENT and return persisted ChatGPT OAuth credentials." + (let* ((id-token (json-get document "id_token")) + (access-token (json-get document "access_token")) + (refresh-token (json-get document "refresh_token")) + (account-id + (or (and (non-empty-string-p id-token) (jwt-account-id id-token)) + (and (non-empty-string-p access-token) + (jwt-account-id access-token))))) + (unless (and (non-empty-string-p id-token) + (non-empty-string-p access-token) + (non-empty-string-p refresh-token) + (non-empty-string-p account-id)) + (chatgpt-oauth--fail + :stage ':token-response + :message "The ChatGPT OAuth token response omitted required fields.")) + (make-instance 'oauth-credentials + :access-token access-token + :refresh-token refresh-token + :id-token id-token + :account-id account-id + :expires-at (or (jwt-expiration access-token) + (jwt-expiration id-token)) + :source-path + (credential-source-pathname + (credential-manager-primary-source manager))))) + +(-> chatgpt-oauth-exchange-code + (chatgpt-credential-manager string string string + &key (:request-function function) (:client-id string) + (:token-endpoint string)) + oauth-credentials) +(defun chatgpt-oauth-exchange-code + (manager code verifier redirect-uri + &key + (request-function #'chatgpt-oauth--request) + (client-id *openai-oauth-client-id*) + (token-endpoint *openai-oauth-token-endpoint*)) + "Exchange one authorization CODE using VERIFIER and persist no state." + (chatgpt-oauth--credentials-from-document + manager + (chatgpt-oauth--token-document + request-function + token-endpoint + (list (cons "grant_type" "authorization_code") + (cons "code" code) + (cons "redirect_uri" redirect-uri) + (cons "client_id" client-id) + (cons "code_verifier" verifier)) + ':exchange))) + + +;;;; -- Public Login Flow -- + +(-> chatgpt-oauth-login + (chatgpt-credential-manager + &key (:stream stream) (:open-browser-p boolean) + (:browser-function function) (:callback-function function) + (:request-function function) (:timeout integer)) + oauth-credentials) +(defun chatgpt-oauth-login + (manager + &key + (stream *standard-output*) + (open-browser-p t) + (browser-function #'device-authentication-open-browser) + (callback-function #'chatgpt-oauth-await-loopback) + (request-function #'chatgpt-oauth--request) + (timeout *chatgpt-oauth-callback-timeout*)) + "Authenticate ChatGPT through browser OAuth and save renewable credentials." + (unless (plusp timeout) + (chatgpt-oauth--fail + :stage ':configuration + :message "The ChatGPT OAuth callback timeout must be positive.")) + (call-with-secret-use + (lambda () + (multiple-value-bind (listener redirect-uri) + (chatgpt-oauth-loopback-open) + (unwind-protect + (multiple-value-bind (verifier challenge) + (chatgpt-oauth-create-pkce) + (let* ((state (chatgpt-oauth--state)) + (authorization-url + (chatgpt-oauth-authorization-url + :redirect-uri redirect-uri + :state state + :code-challenge challenge))) + (format stream + "~&Sign in with ChatGPT in your browser:~% ~A~%~%Starting local callback server on ~A.~%Waiting up to ~D seconds for the browser callback.~%" + authorization-url + redirect-uri + timeout) + (finish-output stream) + (when open-browser-p + (unless (handler-case + (funcall browser-function authorization-url) + (error () nil)) + (format stream + "Could not open a browser. Open the URL above manually.~%") + (finish-output stream))) + (let* ((code + (funcall callback-function + listener state :timeout timeout)) + (credentials + (chatgpt-oauth-exchange-code + manager code verifier redirect-uri + :request-function request-function))) + (credential-manager-accept-account + manager credentials :allow-change t) + (credential-source-save + (credential-manager-primary-source manager) + credentials)))) + (ignore-errors (sb-bsd-sockets:socket-close listener))))))) \ No newline at end of file diff --git a/src/provider/client.lisp b/src/provider/client.lisp index f957944a..d63f120d 100644 --- a/src/provider/client.lisp +++ b/src/provider/client.lisp @@ -90,6 +90,15 @@ "The ~A provider does not expose an authentication operation." (provider-account-label provider)))) +(defmethod provider-authenticate + ((provider codex-subscription-provider) &key stream open-browser-p) + "Run browser OAuth for the ChatGPT subscription provider." + (chatgpt-oauth-login + (provider-credential-manager provider) + :stream (or stream *standard-output*) + :open-browser-p open-browser-p) + "ChatGPT authentication was saved by Autolith.") + (defmethod provider-authenticate ((provider subscription-provider) &key stream open-browser-p) "Run the device login protocol for a subscription provider." @@ -235,11 +244,6 @@ This follows the filtered fork-history behavior in Codex (:documentation "Return a fresh device authentication client for PROVIDER's account service.")) -(defmethod provider-device-authentication-client - ((provider codex-subscription-provider)) - "Return the ChatGPT device authentication client." - (declare (ignore provider)) - (device-authentication-client-create)) (-> provider-family-create (keyword configuration &key (:reasoning-summaries-p boolean)) diff --git a/src/provider/device-authentication.lisp b/src/provider/device-authentication.lisp index d25f4886..151d3939 100644 --- a/src/provider/device-authentication.lisp +++ b/src/provider/device-authentication.lisp @@ -1,11 +1,6 @@ (in-package #:autolith) -;;;; -- Device Authentication Defaults -- - -(defparameter *openai-oauth-issuer* "https://auth.openai.com" - "The issuer for Autolith-owned ChatGPT device authentication.") - -;;;; -- Device Authentication Conditions -- +;;;; -- RFC 8628 Conditions -- (define-condition device-authentication-error (cl-rfc8628:device-authentication-error authentication-error) @@ -14,302 +9,7 @@ "A device authentication failure joined to Autolith's condition hierarchy.")) - -;;;; -- Device Authentication State -- - -(defclass device-authorization-code () - ((authorization-code - :initarg :authorization-code - :reader device-authorization-code-value - :type non-empty-string - :documentation "The short-lived OAuth authorization code.") - (code-verifier - :initarg :code-verifier - :reader device-authorization-code-verifier - :type non-empty-string - :documentation "The PKCE verifier returned by the device service.")) - (:documentation "The short-lived result of an approved device authorization.")) - -;;;; -- Device Authentication Protocol -- - -;;;; -- Device Authentication Methods -- - -(defclass openai-device-authentication-client (device-authentication-client) - () - (:documentation - "The proprietary OpenAI device authorization client behind ChatGPT logins.")) - -(defmethod device-authentication-request-code - ((client openai-device-authentication-client)) - "Request a fresh user code from CLIENT's configured OpenAI issuer." - (call-with-secret-use - (lambda () - (let* ((document - (device-authentication-json-request - :client client - :url (device-authentication-issuer-url - client - "/api/accounts/deviceauth/usercode") - :content-type "application/json" - :content (json-encode - (json-object - "client_id" - (device-authentication-client-id client))) - :stage ':request-code)) - (device-authorization-id - (json-get document "device_auth_id")) - (user-code - (or (json-get document "user_code") - (json-get document "usercode"))) - (poll-interval - (device-authentication-poll-interval - (json-get document "interval")))) - (unless (and (non-empty-string-p device-authorization-id) - (non-empty-string-p user-code)) - (device-authentication-fail - :stage ':request-code - :message "The device authorization response omitted required fields.")) - (make-instance 'device-authorization - :verification-url - (device-authentication-issuer-url client "/codex/device") - :user-code user-code - :device-authorization-id device-authorization-id - :poll-interval poll-interval))))) - -(defmethod device-authentication-complete - ((client openai-device-authentication-client) - (authorization device-authorization) - (manager credential-manager)) - "Poll AUTHORIZATION, exchange its code, and securely publish the result." - (call-with-secret-use - (lambda () - (let* ((authorization-code - (funcall - (device-authentication-client-poll-function client) - client - authorization)) - (primary-source (credential-manager-primary-source manager))) - (unless (typep authorization-code 'device-authorization-code) - (device-authentication-fail - :stage ':poll - :message "The device authorization poll returned an invalid result.")) - (let ((credentials - (device-authentication--exchange-code - :client client - :authorization-code authorization-code - :source-path (credential-source-pathname primary-source)))) - (credential-manager-accept-account - manager credentials :allow-change t) - (credential-source-save primary-source credentials)) - t)))) - -;;;; -- Public Construction and Presentation -- - -(-> device-authentication-client-create - (&key - (:issuer string) - (:client-id string) - (:request-function (option function)) - (:poll-function (option function)) - (:sleep-function function) - (:clock-function function) - (:browser-function function) - (:poll-timeout integer)) - device-authentication-client) -(defun device-authentication-client-create - (&key - (issuer *openai-oauth-issuer*) - (client-id *openai-oauth-client-id*) - request-function - poll-function - (sleep-function #'sleep) - (clock-function #'device-authentication-monotonic-seconds) - (browser-function #'device-authentication-open-browser) - (poll-timeout *device-authentication-timeout*)) - "Create a device client, optionally replacing every external effect." - (unless (and (non-empty-string-p issuer) - (non-empty-string-p client-id) - (plusp poll-timeout)) - (device-authentication-fail - :stage ':configuration - :message "Device authentication configuration is invalid.")) - (make-instance 'openai-device-authentication-client - :issuer (string-right-trim '(#\/) issuer) - :client-id client-id - :request-function - (or request-function #'device-authentication-request) - :poll-function - (or poll-function #'device-authentication--poll-for-code) - :sleep-function sleep-function - :clock-function clock-function - :browser-function browser-function - :poll-timeout poll-timeout)) - -(defmethod device-authentication-display-code - ((client openai-device-authentication-client) - (authorization device-authorization) - (stream stream)) - "Display the ChatGPT verification URL and one-time code." - (declare (ignore client)) - (format stream - "~&Sign in with ChatGPT:~% Open: ~A~% Code: ~A~%~%The code expires in 15 minutes. Continue only if you started this login in Autolith.~%" - (device-authorization-verification-url authorization) - (device-authorization-user-code authorization)) - (finish-output stream) - nil) - -;;;; -- Private Device Flow -- - -(-> device-authentication--user-agent () string) -(defun device-authentication--user-agent () - "Return the honest Autolith user agent sent to device endpoints." - (format nil "autolith/~A (~A ~A; ~A)" - *autolith-version* - (software-type) - (software-version) - (machine-type))) - -(-> device-authentication--poll-for-code - (device-authentication-client device-authorization) - device-authorization-code) -(defun device-authentication--poll-for-code (client authorization) - "Poll CLIENT until AUTHORIZATION succeeds, fails, or reaches its deadline." - (let* ((clock (device-authentication-client-clock-function client)) - (started-at (funcall clock)) - (deadline (+ started-at - (device-authentication-client-poll-timeout client))) - (url (device-authentication-issuer-url - client - "/api/accounts/deviceauth/token")) - (content - (json-encode - (json-object - "device_auth_id" (device-authorization-id authorization) - "user_code" (device-authorization-user-code authorization))))) - (loop - (multiple-value-bind (body status response-headers) - (device-authentication-invoke-request - :client client - :url url - :headers (list (cons "Content-Type" "application/json") - (cons "Accept" "application/json") - (cons "User-Agent" - (device-authentication--user-agent))) - :content content - :stage ':poll) - (declare (ignore response-headers)) - (cond - ((device-authentication-success-status-p status) - (let* ((document - (handler-case - (json-decode body) - (error () - (device-authentication-fail - :stage ':poll - :message "The approved device response contained invalid JSON.")))) - (authorization-code - (and (json-object-p document) - (json-get document "authorization_code"))) - (code-verifier - (and (json-object-p document) - (json-get document "code_verifier")))) - (unless (and (non-empty-string-p authorization-code) - (non-empty-string-p code-verifier)) - (device-authentication-fail - :stage ':poll - :message "The approved device response omitted required fields.")) - (return - (make-instance 'device-authorization-code - :authorization-code authorization-code - :code-verifier code-verifier)))) - ((member status '(403 404)) - (let ((now (funcall clock))) - (when (>= now deadline) - (device-authentication-fail - :stage ':poll - :message "Device authentication timed out after 15 minutes.")) - (funcall (device-authentication-client-sleep-function client) - (min (device-authorization-poll-interval authorization) - (max 0 (- deadline now)))))) - (t - (let ((code - (device-authentication-error-code-of-body - body - (list - (device-authorization-id authorization) - (device-authorization-user-code authorization) - content)))) - (device-authentication-fail - :stage ':poll - :message (format nil "Device authorization was not completed~@[ (~A)~]." - code) - :status status - :code code)))))))) - -(-> device-authentication--exchange-code - (&key - (:client device-authentication-client) - (:authorization-code device-authorization-code) - (:source-path pathname)) - oauth-credentials) -(defun device-authentication--exchange-code - (&key client authorization-code source-path) - "Exchange AUTHORIZATION-CODE and return credentials attributed to SOURCE-PATH." - (let* ((redirect-url - (device-authentication-issuer-url client "/deviceauth/callback")) - (content - (url-encode-params - (list - (cons "grant_type" "authorization_code") - (cons "code" - (device-authorization-code-value authorization-code)) - (cons "redirect_uri" redirect-url) - (cons "client_id" (device-authentication-client-id client)) - (cons "code_verifier" - (device-authorization-code-verifier authorization-code))))) - (document - (device-authentication-json-request - :client client - :url (device-authentication-issuer-url client "/oauth/token") - :content-type "application/x-www-form-urlencoded" - :content content - :stage ':exchange - :secret-values - (list - (device-authorization-code-value authorization-code) - (device-authorization-code-verifier authorization-code) - content))) - (id-token (json-get document "id_token")) - (access-token (json-get document "access_token")) - (refresh-token (json-get document "refresh_token")) - (account-id - (or (and (stringp id-token) - (device-authentication--jwt-account-id id-token)) - (and (stringp access-token) - (device-authentication--jwt-account-id access-token))))) - (unless (and (non-empty-string-p id-token) - (non-empty-string-p access-token) - (non-empty-string-p refresh-token) - (non-empty-string-p account-id)) - (device-authentication-fail - :stage ':credentials - :message "The OAuth exchange omitted required credential fields.")) - (make-instance 'oauth-credentials - :access-token access-token - :refresh-token refresh-token - :id-token id-token - :account-id account-id - :expires-at (or (jwt-expiration access-token) - (jwt-expiration id-token)) - :source-path source-path))) - -(-> device-authentication--jwt-account-id (string) (option string)) -(defun device-authentication--jwt-account-id (token) - "Return the account identifier carried by TOKEN's unverified JWT payload." - (jwt-account-id token)) - - ;;;; -- cl-rfc8628 Host Wiring -- -(setf cl-rfc8628:*user-agent-function* #'device-authentication--user-agent +(setf cl-rfc8628:*user-agent-function* #'authentication-user-agent cl-rfc8628:*device-authentication-error-class* 'device-authentication-error) diff --git a/src/provider/gemini/authentication.lisp b/src/provider/gemini/authentication.lisp index 02d65d02..8290365e 100644 --- a/src/provider/gemini/authentication.lisp +++ b/src/provider/gemini/authentication.lisp @@ -66,16 +66,6 @@ ;;;; -- PKCE and Request Data -- -(-> gemini-oauth--base64url ((simple-array (unsigned-byte 8) (*))) string) -(defun gemini-oauth--base64url (octets) - "Return OCTETS as unpadded RFC 4648 Base64url text." - (string-right-trim - '(#\=) - (substitute #\_ - #\/ - (substitute #\- - #\+ - (usb8-array-to-base64-string octets))))) (-> gemini-oauth--random-hex (integer) string) (defun gemini-oauth--random-hex (octet-count) @@ -86,13 +76,8 @@ (-> gemini-oauth-create-pkce () (values string string)) (defun gemini-oauth-create-pkce () - "Return a fresh PKCE verifier and its S256 challenge." - (let* ((verifier (gemini-oauth--base64url (random-data 32))) - (octets (map '(simple-array (unsigned-byte 8) (*)) #'char-code verifier)) - (challenge - (gemini-oauth--base64url - (ironclad:digest-sequence ':sha256 octets)))) - (values verifier challenge))) + "Return a fresh 256-bit PKCE verifier and its S256 challenge." + (oauth--create-pkce :verifier-octets 32)) (-> gemini-oauth-authorization-url (&key @@ -124,22 +109,6 @@ (cons "code_challenge_method" "S256") (cons "state" state))))) -(-> gemini-oauth--query-parameters (string) list) -(defun gemini-oauth--query-parameters (target) - "Decode TARGET's query string into an association list." - (let ((question (position #\? target))) - (when question - (loop with query = (subseq target (1+ question)) - with start = 0 - for end = (position #\& query :start start) - for field = (subseq query start end) - for equals = (position #\= field) - collect (cons (url-decode (subseq field 0 equals)) - (url-decode (if equals - (subseq field (1+ equals)) - ""))) - while end - do (setf start (1+ end)))))) (-> gemini-oauth--redacted-value (t list) (option string)) (defun gemini-oauth--redacted-value (value secrets) @@ -245,7 +214,7 @@ (1+ first-space) second-space))) (parameters (and target - (gemini-oauth--query-parameters target))) + (oauth--query-parameters target))) (state (cdr (assoc "state" parameters :test #'string=))) (code (cdr (assoc "code" parameters :test #'string=))) (oauth-error (cdr (assoc "error" parameters :test #'string=)))) diff --git a/src/provider/nous/authentication.lisp b/src/provider/nous/authentication.lisp index 8a4c994b..f45ef145 100644 --- a/src/provider/nous/authentication.lisp +++ b/src/provider/nous/authentication.lisp @@ -316,7 +316,7 @@ (cons "x-nous-refresh-token" effective-refresh-token) (cons "Content-Type" "application/x-www-form-urlencoded") (cons "Accept" "application/json") - (cons "User-Agent" (device-authentication--user-agent))) + (cons "User-Agent" (authentication-user-agent))) :content (url-encode-params (list diff --git a/tests/authentication-tests.lisp b/tests/authentication-tests.lisp index 809960db..14bf4987 100644 --- a/tests/authentication-tests.lisp +++ b/tests/authentication-tests.lisp @@ -623,7 +623,7 @@ nil) (token-refresh-failed () t)) - "non-renewable bootstrap credentials require Autolith's device flow") + "non-renewable bootstrap credentials require Autolith's browser login") (let* ((primary-source (credential-manager-primary-source manager)) (renewable (make-instance 'oauth-credentials diff --git a/tests/chatgpt-authentication-tests.lisp b/tests/chatgpt-authentication-tests.lisp new file mode 100644 index 00000000..3f7e47cb --- /dev/null +++ b/tests/chatgpt-authentication-tests.lisp @@ -0,0 +1,272 @@ +(in-package #:autolith) + +;;;; -- ChatGPT OAuth Test Support -- + +(defvar *chatgpt-test-saved-credentials* nil + "Credentials observed by the ChatGPT recording source.") + +(defclass chatgpt-test-credential-source (autolith-credential-source) + () + (:documentation "A ChatGPT credential source that records test writes.")) + +(defmethod credential-source-save + ((source chatgpt-test-credential-source) (credentials oauth-credentials)) + "Record CREDENTIALS without writing SOURCE." + (declare (ignore source)) + (setf *chatgpt-test-saved-credentials* credentials)) + +(-> chatgpt-test--manager () chatgpt-credential-manager) +(defun chatgpt-test--manager () + "Return an isolated recording ChatGPT credential manager." + (make-instance 'chatgpt-credential-manager + :primary-source + (make-instance 'chatgpt-test-credential-source + :pathname #P"/tmp/chatgpt-auth.sexp"))) + +(-> chatgpt-test--parameter (string string) (option string)) +(defun chatgpt-test--parameter (target name) + "Return NAME from TARGET's decoded query parameters." + (rest (assoc name (oauth--query-parameters target) :test #'string=))) + + +;;;; -- ChatGPT OAuth Tests -- + +(-> run-chatgpt-authentication-tests () null) +(defun run-chatgpt-authentication-tests () + "Test PKCE, authorization, callback validation, exchange, and command routing." + (multiple-value-bind (verifier challenge) + (chatgpt-oauth-create-pkce) + (test-assert (= (length verifier) 86) + "ChatGPT PKCE emits the current 512-bit verifier") + (test-assert (= (length challenge) 43) + "ChatGPT PKCE emits an S256 challenge") + (test-assert (and (not (find #\= verifier)) + (not (find #\= challenge))) + "ChatGPT PKCE values are unpadded Base64url")) + (let* ((redirect-uri "http://localhost:1455/auth/callback") + (url + (chatgpt-oauth-authorization-url + :redirect-uri redirect-uri + :state "state-test" + :code-challenge "challenge-test" + :issuer "https://issuer.test/" + :client-id "client-test" + :originator "autolith-test"))) + (test-assert (string= (subseq url 0 (position #\? url)) + "https://issuer.test/oauth/authorize") + "ChatGPT authorization uses the configured issuer") + (dolist (case + `(("response_type" . "code") + ("client_id" . "client-test") + ("redirect_uri" . ,redirect-uri) + ("scope" . "openid profile email offline_access api.connectors.read api.connectors.invoke") + ("code_challenge" . "challenge-test") + ("code_challenge_method" . "S256") + ("id_token_add_organizations" . "true") + ("codex_cli_simplified_flow" . "true") + ("state" . "state-test") + ("originator" . "autolith-test"))) + (test-assert + (string= (chatgpt-test--parameter url (first case)) (rest case)) + (format nil "ChatGPT authorization includes ~A" (first case))))) + (test-assert + (string= + (chatgpt-oauth--callback-code + "/auth/callback?code=code-test&state=state-test" + "state-test") + "code-test") + "ChatGPT callback validation returns the authorization code") + (test-assert + (string= + (chatgpt-oauth--callback-code + "/auth/callback?code=code-test&state=state-test.onboarding_entrypoint%3Dlife_sciences" + "state-test") + "code-test") + "ChatGPT callback validation accepts the supported onboarding state suffix") + (let ((condition nil) + (state "state-secret") + (code "code-secret")) + (handler-case + (chatgpt-oauth--callback-code + (format nil "/auth/callback?code=~A&state=wrong" code) + state) + (chatgpt-oauth-error (caught) + (setf condition caught))) + (test-assert + (and condition + (eq (chatgpt-oauth-error-stage condition) ':callback) + (not (test-object-contains-string-p condition state)) + (not (test-object-contains-string-p condition code))) + "ChatGPT callback failures reject mismatched state without retaining secrets") + (test-assert (typep condition 'chatgpt-oauth-state-mismatch) + "ChatGPT state mismatches use their dedicated condition")) + (test-assert + (null + (chatgpt-oauth--callback-code-or-continue + "/auth/callback?code=ignored&state=wrong" + "state-test")) + "ChatGPT listener handling ignores unrelated local callbacks") + (let ((wait-count 0)) + (test-assert + (null + (chatgpt-oauth--read-request-line + (make-string-input-stream "") + -1 + 100 + :clock-function (lambda () 0) + :wait-function + (lambda (file-descriptor direction timeout) + (declare (ignore file-descriptor direction timeout)) + (incf wait-count) + nil))) + "ChatGPT callback request reading stops when its local read wait expires") + (test-assert (= wait-count 1) + "ChatGPT callback request reading performs one bounded wait")) + (let* ((manager (chatgpt-test--manager)) + (id-token (test-account-jwt "account-test")) + (request-url nil) + (request-content nil) + (credentials + (chatgpt-oauth-exchange-code + manager + "code-secret" + "verifier-secret" + "http://localhost:1455/auth/callback" + :client-id "client-test" + :token-endpoint "https://issuer.test/oauth/token" + :request-function + (lambda (&key url content) + (setf request-url url + request-content content) + (values + (json-encode + (json-object "id_token" id-token + "access_token" "access-test" + "refresh_token" "refresh-test")) + 200 + nil))))) + (test-assert (string= request-url "https://issuer.test/oauth/token") + "ChatGPT exchange uses the configured token endpoint") + (dolist (case + '(("grant_type" . "authorization_code") + ("code" . "code-secret") + ("redirect_uri" . "http://localhost:1455/auth/callback") + ("client_id" . "client-test") + ("code_verifier" . "verifier-secret"))) + (test-assert + (string= (chatgpt-test--parameter + (format nil "?~A" request-content) + (first case)) + (rest case)) + (format nil "ChatGPT exchange includes ~A" (first case)))) + (test-assert + (and (string= (oauth-credentials-access-token credentials) "access-test") + (string= (oauth-credentials-refresh-token credentials) "refresh-test") + (string= (oauth-credentials-account-id credentials) "account-test")) + "ChatGPT exchange returns renewable account credentials")) + (let ((condition nil) + (secret "verifier-do-not-leak")) + (handler-case + (chatgpt-oauth--token-document + (lambda (&key url content) + (declare (ignore url content)) + (values + (json-encode + (json-object + "error" + (json-object "code" "invalid_grant" + "message" (format nil "bad ~A" secret)))) + 400 + nil)) + "https://issuer.test/oauth/token" + (list (cons "code_verifier" secret)) + ':exchange) + (chatgpt-oauth-error (caught) + (setf condition caught))) + (test-assert + (and condition + (eq (chatgpt-oauth-error-stage condition) ':exchange) + (= (chatgpt-oauth-error-status condition) 400) + (string= (chatgpt-oauth-error-code condition) "invalid_grant") + (not (test-object-contains-string-p condition secret))) + "ChatGPT token failures use typed redacted diagnostics")) + (let* ((manager (chatgpt-test--manager)) + (id-token (test-account-jwt "account-login")) + (*chatgpt-test-saved-credentials* nil) + (output (make-string-output-stream)) + (browser-url nil) + (secret-guard-observed-p nil)) + (test-call-with-function-replacements + (list + (list 'chatgpt-oauth-loopback-open + (lambda () + (values ':listener "http://localhost:1455/auth/callback"))) + (list 'chatgpt-oauth-create-pkce + (lambda () (values "verifier-test" "challenge-test"))) + (list 'chatgpt-oauth--state + (lambda () "state-test"))) + (lambda () + (chatgpt-oauth-login + manager + :stream output + :browser-function (lambda (url) (setf browser-url url) nil) + :callback-function + (lambda (listener state &key timeout) + (test-assert (eq listener ':listener) + "ChatGPT login waits on its loopback listener") + (test-assert (and (string= state "state-test") (= timeout 900)) + "ChatGPT login passes state and timeout to the callback") + (setf secret-guard-observed-p (secret-use-active-p)) + "code-test") + :request-function + (lambda (&key url content) + (declare (ignore url content)) + (values + (json-encode + (json-object "id_token" id-token + "access_token" "access-login" + "refresh_token" "refresh-login")) + 200 + nil))))) + (let ((text (get-output-stream-string output))) + (test-assert (and browser-url + (search "http%3A%2F%2Flocalhost%3A1455%2Fauth%2Fcallback" + browser-url) + (search "Could not open a browser" text)) + "ChatGPT login exposes the browser URL and manual fallback")) + (test-assert secret-guard-observed-p + "ChatGPT login keeps transient OAuth data in secret scope") + (test-assert + (and *chatgpt-test-saved-credentials* + (string= (oauth-credentials-access-token + *chatgpt-test-saved-credentials*) + "access-login")) + "ChatGPT login publishes credentials through the credential manager")) + (let* ((provider + (provider-authentication-provider (test-configuration) "chatgpt")) + (output (make-string-output-stream)) + (browser-setting nil) + (browser-login-count 0) + (message nil)) + (test-call-with-function-replacements + (list + (list 'chatgpt-oauth-login + (lambda (manager &key stream open-browser-p) + (declare (ignore manager stream)) + (incf browser-login-count) + (setf browser-setting open-browser-p) + nil)) + (list 'device-authentication-login + (lambda (&rest arguments) + (declare (ignore arguments)) + (error "The ChatGPT auth command must not use device authentication.")))) + (lambda () + (setf message + (provider-authenticate + provider :stream output :open-browser-p nil)))) + (test-assert (and (= browser-login-count 1) + (null browser-setting) + (string= message + "ChatGPT authentication was saved by Autolith.")) + "The ChatGPT auth command routes through browser OAuth")) + nil) \ No newline at end of file diff --git a/tests/device-authentication-test-support.lisp b/tests/device-authentication-test-support.lisp new file mode 100644 index 00000000..1e5a3da6 --- /dev/null +++ b/tests/device-authentication-test-support.lisp @@ -0,0 +1,55 @@ +(in-package #:autolith) + +;;;; -- Device Authentication Test Support -- + +(defvar *device-authentication-test-saved-credentials* nil + "The credentials observed by the recording test store.") + +(defclass recording-autolith-credential-source (autolith-credential-source) + () + (:documentation "An Autolith credential source that records rather than writes test data.")) + +(defmethod credential-source-save + ((source recording-autolith-credential-source) + (credentials oauth-credentials)) + "Record CREDENTIALS without touching SOURCE's pathname." + (declare (ignore source)) + (setf *device-authentication-test-saved-credentials* credentials) + credentials) + +(-> device-authentication-test--url-suffix-p (string string) boolean) +(defun device-authentication-test--url-suffix-p (url suffix) + "Return true when URL ends with SUFFIX." + (and (>= (length url) (length suffix)) + (if (string= url suffix :start1 (- (length url) (length suffix))) + t + nil))) + +(-> device-authentication-test--request (list string) (option list)) +(defun device-authentication-test--request (requests suffix) + "Return the first recorded request whose URL ends in SUFFIX." + (find-if + (lambda (request) + (let ((url (getf request :url))) + (device-authentication-test--url-suffix-p url suffix))) + requests)) + +(-> device-authentication-test--signals + (function keyword &key (:status (option integer)) (:code (option string))) + null) +(defun device-authentication-test--signals + (function stage &key status code) + "Assert that FUNCTION signals a safe device error for STAGE." + (let ((signaled-p nil)) + (handler-case + (funcall function) + (device-authentication-error (condition) + (setf signaled-p t) + (test-assert (eq (device-authentication-error-stage condition) stage) + "the device error reports the failed stage") + (test-assert (eql (device-authentication-error-status condition) status) + "the device error reports only the expected status") + (test-assert (equal (device-authentication-error-code condition) code) + "the device error reports only the expected OAuth code"))) + (test-assert signaled-p "the device operation signals its expected condition") + nil)) diff --git a/tests/device-authentication-tests.lisp b/tests/device-authentication-tests.lisp deleted file mode 100644 index cd7b90c9..00000000 --- a/tests/device-authentication-tests.lisp +++ /dev/null @@ -1,596 +0,0 @@ -(in-package #:autolith) - -;;;; -- Device Authentication Test Support -- - -(defvar *device-authentication-test-saved-credentials* nil - "The credentials observed by the recording test store.") - -(defclass recording-autolith-credential-source (autolith-credential-source) - () - (:documentation "A Autolith credential source that records rather than writes test data.")) - -(defmethod credential-source-save - ((source recording-autolith-credential-source) - (credentials oauth-credentials)) - "Record CREDENTIALS without touching SOURCE's pathname." - (declare (ignore source)) - (setf *device-authentication-test-saved-credentials* credentials) - credentials) - -(-> device-authentication-test--manager () credential-manager) -(defun device-authentication-test--manager () - "Return a credential manager whose writable source records test credentials." - (make-instance - 'credential-manager - :primary-source - (make-instance 'recording-autolith-credential-source - :pathname #P"/tmp/autolith-device-authentication/auth.sexp") - :bootstrap-source - (make-instance 'codex-bootstrap-credential-source - :pathname #P"/tmp/autolith-device-authentication/codex-auth.json"))) - -(-> device-authentication-test--base64url (string) string) -(defun device-authentication-test--base64url (source) - "Return SOURCE encoded as unpadded RFC 4648 Base64url text." - (string-right-trim - '(#\=) - (substitute #\_ - #\/ - (substitute #\- - #\+ - (cl-base64:string-to-base64-string source))))) - -(-> device-authentication-test--jwt (json-object) string) -(defun device-authentication-test--jwt (payload) - "Return an unsigned test JWT containing PAYLOAD." - (format nil "~A.~A.signature" - (device-authentication-test--base64url "{\"alg\":\"none\"}") - (device-authentication-test--base64url (json-encode payload)))) - -(-> device-authentication-test--request - (list string) - list) -(defun device-authentication-test--request (requests suffix) - "Return the first recorded request whose URL ends in SUFFIX." - (find-if (lambda (request) - (let ((url (getf request :url))) - (and (>= (length url) (length suffix)) - (string= url - suffix - :start1 (- (length url) (length suffix)))))) - requests)) - -(-> device-authentication-test--signals - (function keyword &key (:status (option integer)) (:code (option string))) - null) -(defun device-authentication-test--signals - (function stage &key status code) - "Assert that FUNCTION signals a safe device error for STAGE." - (let ((signaled-p nil)) - (handler-case - (funcall function) - (device-authentication-error (condition) - (setf signaled-p t) - (test-assert (eq (device-authentication-error-stage condition) stage) - "the device error reports the failed stage") - (test-assert (eql (device-authentication-error-status condition) status) - "the device error reports only the expected status") - (test-assert (equal (device-authentication-error-code condition) code) - "the device error reports only the expected OAuth code"))) - (test-assert signaled-p "the device operation signals its expected condition") - nil)) - - -;;;; -- Device Authentication Tests -- - -(-> device-authentication-test--complete-flow () null) -(defun device-authentication-test--complete-flow () - "Exercise request, pending poll, exchange, display, and secure publication." - (let* ((account-id "account-test-123") - (id-token - (device-authentication-test--jwt - (json-object - "https://api.openai.com/auth" - (json-object "chatgpt_account_id" account-id)))) - (requests nil) - (poll-count 0) - (clock 0) - (sleeps nil) - (opened-url nil) - (*device-authentication-test-saved-credentials* nil)) - (flet ((request (&key method url headers content) - (push (list :method method - :url url - :headers headers - :content content) - requests) - (cond - ((device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/usercode") - (values - (json-encode - (json-object - "device_auth_id" "device-test-123" - "user_code" "TEST-CODE" - "interval" "2")) - 200 - nil)) - ((device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/token") - (incf poll-count) - (if (= poll-count 1) - (values "{}" 404 nil) - (values - (json-encode - (json-object - "authorization_code" "authorization-test-123" - "code_challenge" "challenge-test-123" - "code_verifier" "verifier-test-123")) - 200 - nil))) - ((device-authentication-test--url-suffix-p url "/oauth/token") - (values - (json-encode - (json-object - "id_token" id-token - "access_token" "access-test-123" - "refresh_token" "refresh-test-123")) - 200 - nil)) - (t - (error "Unexpected test URL.")))) - - (pause (seconds) - (push seconds sleeps) - (incf clock seconds)) - - (now () - clock) - - (open-browser (url) - (setf opened-url url) - t)) - (let* ((client - (device-authentication-client-create - :issuer "https://issuer.test/" - :request-function #'request - :sleep-function #'pause - :clock-function #'now - :browser-function #'open-browser)) - (manager (device-authentication-test--manager)) - (output - (with-output-to-string (stream) - (test-assert - (device-authentication-login client manager :stream stream) - "the complete device flow succeeds"))) - (ordered-requests (nreverse requests)) - (code-request - (device-authentication-test--request - ordered-requests - "/api/accounts/deviceauth/usercode")) - (exchange-request - (device-authentication-test--request - ordered-requests - "/oauth/token")) - (saved *device-authentication-test-saved-credentials*)) - (test-assert (= poll-count 2) - "pending authorization is polled until approved") - (test-assert (equal sleeps '(2)) - "the server polling interval is honored") - (test-assert - (string= opened-url "https://issuer.test/codex/device") - "the configured browser receives the verification URL") - (test-assert (search "https://issuer.test/codex/device" output) - "the verification URL is always displayed") - (test-assert (search "TEST-CODE" output) - "the one-time user code is always displayed") - (dolist (secret (list id-token - "access-test-123" - "refresh-test-123" - "authorization-test-123" - "verifier-test-123")) - (test-assert (null (search secret output)) - "credential material is never displayed")) - (test-assert - (string= - (json-get (json-decode (getf code-request :content)) "client_id") - *openai-oauth-client-id*) - "the current public OAuth client identifier is sent") - (test-assert - (string-equal - (rest (assoc "Content-Type" - (getf exchange-request :headers) - :test #'string-equal)) - "application/x-www-form-urlencoded") - "the code exchange uses form encoding") - (test-assert - (and (search "grant_type=authorization_code" - (getf exchange-request :content)) - (search "code=authorization-test-123" - (getf exchange-request :content)) - (search "code_verifier=verifier-test-123" - (getf exchange-request :content)) - (search "redirect_uri=https%3A%2F%2Fissuer.test%2Fdeviceauth%2Fcallback" - (getf exchange-request :content))) - "the code exchange contains the exact device grant fields") - (test-assert (typep saved 'oauth-credentials) - "credentials are published through Autolith's store protocol") - (test-assert - (string= (oauth-credentials-account-id saved) account-id) - "the nested ChatGPT account identifier is extracted") - (test-assert - (string= (oauth-credentials-access-token saved) "access-test-123") - "the exchanged access token reaches only the credential store") - (test-assert - (equal (oauth-credentials-source-path saved) - #P"/tmp/autolith-device-authentication/auth.sexp") - "saved credentials are attributed to Autolith's private store"))) - nil)) - -(-> device-authentication-test--injected-poll () null) -(defun device-authentication-test--injected-poll () - "Verify high-level authentication accepts an injected polling effect." - (let* ((account-id "account-from-access") - (access-token - (device-authentication-test--jwt - (json-object "chatgpt_account_id" account-id))) - (poll-calls 0) - (secret-guard-observed-p nil) - (*device-authentication-test-saved-credentials* nil)) - (flet ((request (&key method url headers content) - (declare (ignore method headers content)) - (cond - ((device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/usercode") - (values - (json-encode - (json-object - "device_auth_id" "device-injected" - "user_code" "INJECTED-CODE" - "interval" "7")) - 200 - nil)) - ((device-authentication-test--url-suffix-p url "/oauth/token") - (values - (json-encode - (json-object - "id_token" - (device-authentication-test--jwt (json-object)) - "access_token" access-token - "refresh_token" "refresh-injected")) - 200 - nil)) - (t - (error "The injected poll should avoid the poll endpoint.")))) - - (poll (client authorization) - (declare (ignore client)) - (incf poll-calls) - (setf secret-guard-observed-p (secret-use-active-p)) - (test-assert - (string= (device-authorization-user-code authorization) - "INJECTED-CODE") - "the injected poll receives the requested authorization") - (make-instance 'device-authorization-code - :authorization-code "authorization-injected" - :code-verifier "verifier-injected")) - - (unexpected-sleep (seconds) - (declare (ignore seconds)) - (error "The injected poll must not sleep."))) - (let ((client - (device-authentication-client-create - :issuer "https://issuer.test" - :request-function #'request - :poll-function #'poll - :sleep-function #'unexpected-sleep))) - (with-output-to-string (stream) - (device-authentication-login - client - (device-authentication-test--manager) - :stream stream - :open-browser-p nil)) - (test-assert (= poll-calls 1) - "the injected polling function is called exactly once") - (test-assert - secret-guard-observed-p - "device authorization holds the process-wide transient-secret guard") - (test-assert - (string= (oauth-credentials-account-id - *device-authentication-test-saved-credentials*) - account-id) - "account extraction falls back from the ID token to the access token"))) - nil)) - -(-> device-authentication-test--timeout () null) -(defun device-authentication-test--timeout () - "Verify pending responses stop at the configured polling deadline." - (let ((clock 0) - (poll-count 0) - (request-guard-observed-p nil) - (*device-authentication-test-saved-credentials* nil)) - (flet ((request (&key method url headers content) - (declare (ignore method headers content)) - (if (device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/usercode") - (progn - (setf request-guard-observed-p - (secret-use-active-p)) - (values - (json-encode - (json-object - "device_auth_id" "device-timeout" - "user_code" "TIMEOUT-CODE" - "interval" "5")) - 200 - nil)) - (progn - (incf poll-count) - (values "{}" 403 nil)))) - - (pause (seconds) - (incf clock seconds)) - - (now () - clock)) - (let* ((client - (device-authentication-client-create - :issuer "https://issuer.test" - :request-function #'request - :sleep-function #'pause - :clock-function #'now - :poll-timeout 10)) - (authorization (device-authentication-request-code client))) - (test-assert - request-guard-observed-p - "direct device-code requests hold the transient-secret guard") - (device-authentication-test--signals - (lambda () - (device-authentication-complete - client - authorization - (device-authentication-test--manager))) - ':poll) - (test-assert (= poll-count 3) - "pending authorization stops at its deadline") - (test-assert (null *device-authentication-test-saved-credentials*) - "timed-out authentication publishes no credentials"))) - nil)) - -(-> device-authentication-test--error-echo-containment () null) -(defun device-authentication-test--error-echo-containment () - "Verify device-flow failures cannot echo transient request credentials." - (let ((device-id "device-secret-echo") - (user-code "USER-SECRET-ECHO") - (*device-authentication-test-saved-credentials* nil)) - (flet ((request (&key method url headers content) - (declare (ignore method headers content)) - (if - (device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/usercode") - (values - (json-encode - (json-object - "device_auth_id" device-id - "user_code" user-code - "interval" "1")) - 200 - nil) - (values - (json-encode - (json-object - "error" - (format nil "~A/~A" device-id user-code))) - 400 - nil)))) - (let* ((client - (device-authentication-client-create - :issuer "https://issuer.test" - :request-function #'request)) - (authorization (device-authentication-request-code client)) - (condition - (handler-case - (progn - (device-authentication-complete - client - authorization - (device-authentication-test--manager)) - nil) - (device-authentication-error (failure) - failure)))) - (test-assert - (and - condition - (not (test-object-contains-string-p condition device-id)) - (not (test-object-contains-string-p condition user-code)) - (test-object-contains-string-p - condition - *device-authentication-redaction-marker*)) - "poll failures redact echoed device identifiers and user codes")))) - (let ((authorization-code "authorization-secret-echo") - (code-verifier "verifier-secret-echo") - (*device-authentication-test-saved-credentials* nil)) - (flet ((request (&key method url headers content) - (declare (ignore method headers content)) - (cond - ((device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/usercode") - (values - (json-encode - (json-object - "device_auth_id" "device-exchange-echo" - "user_code" "EXCHANGE-ECHO" - "interval" "1")) - 200 - nil)) - ((device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/token") - (values - (json-encode - (json-object - "authorization_code" authorization-code - "code_verifier" code-verifier)) - 200 - nil)) - (t - (values - (json-encode - (json-object - "error" - (format - nil - "~A/~A" - authorization-code - code-verifier))) - 400 - nil))))) - (let* ((client - (device-authentication-client-create - :issuer "https://issuer.test" - :request-function #'request)) - (authorization (device-authentication-request-code client)) - (condition - (handler-case - (progn - (device-authentication-complete - client - authorization - (device-authentication-test--manager)) - nil) - (device-authentication-error (failure) - failure)))) - (test-assert - (and - condition - (not - (test-object-contains-string-p - condition authorization-code)) - (not (test-object-contains-string-p condition code-verifier)) - (test-object-contains-string-p - condition - *device-authentication-redaction-marker*)) - "exchange failures redact echoed authorization and PKCE values")))) - nil) - -(-> device-authentication-test--declined () null) -(defun device-authentication-test--declined () - "Verify a declined authorization exposes only its safe OAuth code." - (let ((*device-authentication-test-saved-credentials* nil)) - (flet ((request (&key method url headers content) - (declare (ignore method headers content)) - (if (device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/usercode") - (values - (json-encode - (json-object - "device_auth_id" "device-declined" - "user_code" "DECLINED-CODE" - "interval" "1")) - 200 - nil) - (values - (json-encode - (json-object - "error" "authorization_declined" - "error_description" "A sensitive provider explanation")) - 401 - nil)))) - (let* ((client - (device-authentication-client-create - :issuer "https://issuer.test" - :request-function #'request)) - (authorization (device-authentication-request-code client))) - (device-authentication-test--signals - (lambda () - (device-authentication-complete - client - authorization - (device-authentication-test--manager))) - ':poll - :status 401 - :code "authorization_declined") - (test-assert (null *device-authentication-test-saved-credentials*) - "declined authentication publishes no credentials"))) - nil)) - -(-> device-authentication-test--missing-account () null) -(defun device-authentication-test--missing-account () - "Verify token exchange without an account identifier is never published." - (let ((*device-authentication-test-saved-credentials* nil)) - (flet ((request (&key method url headers content) - (declare (ignore method headers content)) - (cond - ((device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/usercode") - (values - (json-encode - (json-object - "device_auth_id" "device-no-account" - "user_code" "NO-ACCOUNT-CODE" - "interval" "1")) - 200 - nil)) - ((device-authentication-test--url-suffix-p - url - "/api/accounts/deviceauth/token") - (values - (json-encode - (json-object - "authorization_code" "authorization-no-account" - "code_verifier" "verifier-no-account")) - 200 - nil)) - (t - (values - (json-encode - (json-object - "id_token" - (device-authentication-test--jwt (json-object)) - "access_token" - (device-authentication-test--jwt (json-object)) - "refresh_token" "refresh-no-account")) - 200 - nil))))) - (let* ((client - (device-authentication-client-create - :issuer "https://issuer.test" - :request-function #'request)) - (authorization (device-authentication-request-code client))) - (device-authentication-test--signals - (lambda () - (device-authentication-complete - client - authorization - (device-authentication-test--manager))) - ':credentials) - (test-assert (null *device-authentication-test-saved-credentials*) - "an incomplete token exchange is never published"))) - nil)) - -(-> device-authentication-test--url-suffix-p (string string) boolean) -(defun device-authentication-test--url-suffix-p (url suffix) - "Return true when URL ends with SUFFIX." - (and (>= (length url) (length suffix)) - (if (string= url suffix :start1 (- (length url) (length suffix))) - t - nil))) - -(-> run-device-authentication-tests () boolean) -(defun run-device-authentication-tests () - "Run the offline ChatGPT device authentication tests." - (device-authentication-test--complete-flow) - (device-authentication-test--injected-poll) - (device-authentication-test--timeout) - (device-authentication-test--error-echo-containment) - (device-authentication-test--declined) - (device-authentication-test--missing-account) - t) diff --git a/tests/tests.lisp b/tests/tests.lisp index c5d0f736..c8d3d631 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -280,6 +280,7 @@ (test-workspace-plan) (test-authentication-store) (test-authentication-bootstrap-and-refresh) + (run-chatgpt-authentication-tests) (run-gemini-authentication-tests) (test-grok-authentication) (run-nous-authentication-tests) @@ -348,7 +349,6 @@ (test-image-commit-replay-probe) (test-crash-capsule-correlation) (run-recovery-tests) - (run-device-authentication-tests) (run-nous-device-authentication-tests) (run-agent-tests) (test-task-agent-native-reader) From f6991686a0762a62238218bbb7a7ad245770d453 Mon Sep 17 00:00:00 2001 From: Eric Fode Date: Sun, 30 Aug 2026 12:04:26 -0700 Subject: [PATCH 2/4] Accept fractional OAuth callback deadlines --- src/provider/chatgpt/authentication.lisp | 2 +- tests/chatgpt-authentication-tests.lisp | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/provider/chatgpt/authentication.lisp b/src/provider/chatgpt/authentication.lisp index 6777e820..b422732a 100644 --- a/src/provider/chatgpt/authentication.lisp +++ b/src/provider/chatgpt/authentication.lisp @@ -229,7 +229,7 @@ nil))) (-> chatgpt-oauth--read-request-line - (stream integer integer + (stream integer real &key (:clock-function function) (:wait-function function) (:request-timeout integer) (:line-limit integer)) (option string)) diff --git a/tests/chatgpt-authentication-tests.lisp b/tests/chatgpt-authentication-tests.lisp index 3f7e47cb..14b3d7a7 100644 --- a/tests/chatgpt-authentication-tests.lisp +++ b/tests/chatgpt-authentication-tests.lisp @@ -112,8 +112,8 @@ (chatgpt-oauth--read-request-line (make-string-input-stream "") -1 - 100 - :clock-function (lambda () 0) + 201/2 + :clock-function (lambda () 1/2) :wait-function (lambda (file-descriptor direction timeout) (declare (ignore file-descriptor direction timeout)) From 9f395cf8cd05a63930727c269f04d0d299c48760 Mon Sep 17 00:00:00 2001 From: Eric Fode Date: Sun, 30 Aug 2026 12:11:49 -0700 Subject: [PATCH 3/4] Accept Dexador OAuth response headers --- src/provider/chatgpt/authentication.lisp | 2 +- tests/chatgpt-authentication-tests.lisp | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/src/provider/chatgpt/authentication.lisp b/src/provider/chatgpt/authentication.lisp index b422732a..a798b1ae 100644 --- a/src/provider/chatgpt/authentication.lisp +++ b/src/provider/chatgpt/authentication.lisp @@ -344,7 +344,7 @@ (-> chatgpt-oauth--request (&key (:url string) (:content string)) - (values string integer list)) + (values string integer t)) (defun chatgpt-oauth--request (&key url content) "POST one form-encoded request to OpenAI's OAuth token endpoint." (handler-case diff --git a/tests/chatgpt-authentication-tests.lisp b/tests/chatgpt-authentication-tests.lisp index 14b3d7a7..96026764 100644 --- a/tests/chatgpt-authentication-tests.lisp +++ b/tests/chatgpt-authentication-tests.lisp @@ -122,6 +122,24 @@ "ChatGPT callback request reading stops when its local read wait expires") (test-assert (= wait-count 1) "ChatGPT callback request reading performs one bounded wait")) + (let ((headers (make-hash-table :test #'equal))) + (multiple-value-bind (body status returned-headers) + (test-call-with-function-replacements + (list + (list + 'dexador:post + (lambda (&rest arguments) + (declare (ignore arguments)) + (values "{}" 200 headers nil nil)))) + (lambda () + (chatgpt-oauth--request + :url "https://issuer.test/oauth/token" + :content "grant_type=authorization_code"))) + (test-assert + (and (string= body "{}") + (= status 200) + (eq returned-headers headers)) + "ChatGPT token transport accepts Dexador hash-table response headers"))) (let* ((manager (chatgpt-test--manager)) (id-token (test-account-jwt "account-test")) (request-url nil) From be67371eed666d29a90ed5d45c2398b607e95d87 Mon Sep 17 00:00:00 2001 From: Eric Fode Date: Sun, 30 Aug 2026 13:24:02 -0700 Subject: [PATCH 4/4] Restore ChatGPT device authentication --- autolith.asd | 1 + docs/architecture.org | 2 +- docs/guide.org | 9 +- src/application/commands.lisp | 25 +- src/provider/client.lisp | 62 ++- src/provider/device-authentication.lisp | 284 ++++++++++ src/startup/main.lisp | 37 +- tests/application-command-tests.lisp | 87 +++- tests/authentication-tests.lisp | 31 +- tests/chatgpt-authentication-tests.lisp | 45 +- tests/device-authentication-tests.lisp | 543 ++++++++++++++++++++ tests/openai-compatible-provider-tests.lisp | 47 +- tests/tests.lisp | 1 + 13 files changed, 1068 insertions(+), 106 deletions(-) create mode 100644 tests/device-authentication-tests.lisp diff --git a/autolith.asd b/autolith.asd index 064463c2..b12afe11 100644 --- a/autolith.asd +++ b/autolith.asd @@ -252,6 +252,7 @@ (:file "recovery-tests") (:file "lisp-worker-tests") (:file "self-tool-tests") + (:file "device-authentication-tests") (:file "nous-device-authentication-tests") (:file "agent-tests") (:file "inference-tests") diff --git a/docs/architecture.org b/docs/architecture.org index d79c7308..68ca9460 100644 --- a/docs/architecture.org +++ b/docs/architecture.org @@ -113,7 +113,7 @@ provider request --> semantic events --> agent --> validated tool calls - Configuration records credential *locations* only - A provider request sees tokens only in its dynamic scope - The optional Codex file is a one-time access-token import -- Renewable ChatGPT credentials come from Autolith's browser OAuth flow +- Renewable ChatGPT credentials come from browser OAuth or the optional device-code flow * Workspace and workers diff --git a/docs/guide.org b/docs/guide.org index 2a825fe5..1441820a 100644 --- a/docs/guide.org +++ b/docs/guide.org @@ -434,9 +434,12 @@ available. =(models)= triggers discovery. You can also pass non-secret providers that have no model-list endpoint. Built-in ChatGPT subscriptions use browser OAuth with PKCE and a local callback -on =localhost:1455= or =localhost:1457=. The authorization URL is always printed -for manual browser use. Grok and Nous Research use browser device flows. Gemini -uses Google installed-application OAuth with a local loopback callback. +on =localhost:1455= or =localhost:1457= by default. Use +=/auth chatgpt device=, =(auth "chatgpt" "device")=, or +=autolith auth chatgpt device= to select the device-code flow instead. The +browser authorization URL is always printed for manual use. Grok and Nous +Research use browser device flows. Gemini uses Google installed-application +OAuth with a local loopback callback. Anthropic, Fireworks, OpenCode, OpenRouter, Mistral, and user-registered OpenAI-compatible providers use API keys. diff --git a/src/application/commands.lisp b/src/application/commands.lisp index a3f6507b..ec4290c6 100644 --- a/src/application/commands.lisp +++ b/src/application/commands.lisp @@ -1710,9 +1710,11 @@ are forwarded to TERMINAL-UI-SELECT." (terminal-authentication-streams (terminal-ui-terminal (application-ui application)))) -(-> application-authenticate (application string) null) -(defun application-authenticate (application provider-name) - "Authenticate APPLICATION's explicitly named provider." +(-> application-authenticate + (application string &optional (or null string symbol)) + null) +(defun application-authenticate (application provider-name &optional method) + "Authenticate APPLICATION's explicitly named provider using optional METHOD." (let* ((ui (application-ui application)) (provider (application--authentication-provider application provider-name)) (message nil)) @@ -1732,10 +1734,11 @@ are forwarded to TERMINAL-UI-SELECT." (*api-key-input-file-descriptor* input-file-descriptor) (*api-key-output-styled-p* (terminal-styled-p (terminal-ui-terminal ui)))) - (setf message - (provider-authenticate provider - :stream output - :open-browser-p t))) + (setf message + (provider-authenticate-with-method + provider method + :stream output + :open-browser-p t))) (if stop-ui-p (terminal-ui-start ui) (application--authentication-ui-resume ui)))) @@ -2065,20 +2068,20 @@ are forwarded to TERMINAL-UI-SELECT." (define-application-command application--builtin-authentication-command (:name "/auth" - :argument "[PROVIDER]" + :argument "[PROVIDER] [METHOD]" :description "pick and authenticate a registered provider" - :tip "starts direct authentication for an explicitly selected provider." + :tip "uses browser auth by default; ChatGPT also accepts device." :busy-behavior :hold :terminal-behavior :exclusive :callable t) - (application &optional (provider-name nil provider-name-supplied-p)) + (application &optional (provider-name nil provider-name-supplied-p) method) (let ((provider-name (if provider-name-supplied-p provider-name (and *application-command-interactive-p* (application--pick-authentication-provider application))))) (when provider-name - (application-authenticate application provider-name))) + (application-authenticate application provider-name method))) ':continue) (define-application-command application--builtin-model-command diff --git a/src/provider/client.lisp b/src/provider/client.lisp index d63f120d..cfb28755 100644 --- a/src/provider/client.lisp +++ b/src/provider/client.lisp @@ -45,6 +45,43 @@ (:documentation "Authenticate PROVIDER and return a safe user-visible completion message.")) +(defparameter *chatgpt-authentication-method* ':browser + "The dynamically selected ChatGPT authentication method.") + +(-> provider--authentication-method + (model-provider (or null string symbol)) + keyword) +(defun provider--authentication-method (provider method) + "Validate and normalize METHOD for PROVIDER authentication." + (when (and method + (not (typep provider 'codex-subscription-provider))) + (error 'authentication-error + :message + "Only the ChatGPT provider accepts an authentication method.")) + (let ((name (and method (string-downcase (string method))))) + (cond + ((or (null name) (string= name "browser")) + ':browser) + ((member name '("device" "device-code") :test #'string=) + ':device-code) + (t + (error 'authentication-error + :message + "ChatGPT authentication method must be browser or device."))))) + +(-> provider-authenticate-with-method + (model-provider (or null string symbol) + &key (:stream stream) (:open-browser-p boolean)) + string) +(defun provider-authenticate-with-method + (provider method &key stream open-browser-p) + "Authenticate PROVIDER using its selected METHOD." + (let ((*chatgpt-authentication-method* + (provider--authentication-method provider method))) + (provider-authenticate provider + :stream stream + :open-browser-p open-browser-p))) + (-> provider--authentication-completion-message (model-provider string) string) @@ -92,11 +129,20 @@ (defmethod provider-authenticate ((provider codex-subscription-provider) &key stream open-browser-p) - "Run browser OAuth for the ChatGPT subscription provider." - (chatgpt-oauth-login - (provider-credential-manager provider) - :stream (or stream *standard-output*) - :open-browser-p open-browser-p) + "Run the selected OAuth flow for the ChatGPT subscription provider." + (let ((stream (or stream *standard-output*))) + (ecase *chatgpt-authentication-method* + (:browser + (chatgpt-oauth-login + (provider-credential-manager provider) + :stream stream + :open-browser-p open-browser-p)) + (:device-code + (device-authentication-login + (provider-device-authentication-client provider) + (provider-credential-manager provider) + :stream stream + :open-browser-p open-browser-p)))) "ChatGPT authentication was saved by Autolith.") (defmethod provider-authenticate ((provider subscription-provider) @@ -244,6 +290,12 @@ This follows the filtered fork-history behavior in Codex (:documentation "Return a fresh device authentication client for PROVIDER's account service.")) +(defmethod provider-device-authentication-client + ((provider codex-subscription-provider)) + "Return the ChatGPT device authentication client." + (declare (ignore provider)) + (device-authentication-client-create)) + (-> provider-family-create (keyword configuration &key (:reasoning-summaries-p boolean)) diff --git a/src/provider/device-authentication.lisp b/src/provider/device-authentication.lisp index 151d3939..51303ebd 100644 --- a/src/provider/device-authentication.lisp +++ b/src/provider/device-authentication.lisp @@ -9,6 +9,290 @@ "A device authentication failure joined to Autolith's condition hierarchy.")) + +;;;; -- ChatGPT Device Authentication State -- + +(defclass device-authorization-code () + ((authorization-code + :initarg :authorization-code + :reader device-authorization-code-value + :type non-empty-string + :documentation "The short-lived OAuth authorization code.") + (code-verifier + :initarg :code-verifier + :reader device-authorization-code-verifier + :type non-empty-string + :documentation "The PKCE verifier returned by the device service.")) + (:documentation "The short-lived result of an approved device authorization.")) + +;;;; -- ChatGPT Device Authentication Methods -- + +(defclass openai-device-authentication-client (device-authentication-client) + () + (:documentation + "The proprietary OpenAI device authorization client behind ChatGPT logins.")) + +(defmethod device-authentication-request-code + ((client openai-device-authentication-client)) + "Request a fresh user code from CLIENT's configured OpenAI issuer." + (call-with-secret-use + (lambda () + (let* ((document + (device-authentication-json-request + :client client + :url (device-authentication-issuer-url + client + "/api/accounts/deviceauth/usercode") + :content-type "application/json" + :content (json-encode + (json-object + "client_id" + (device-authentication-client-id client))) + :stage ':request-code)) + (device-authorization-id + (json-get document "device_auth_id")) + (user-code + (or (json-get document "user_code") + (json-get document "usercode"))) + (poll-interval + (device-authentication-poll-interval + (json-get document "interval")))) + (unless (and (non-empty-string-p device-authorization-id) + (non-empty-string-p user-code)) + (device-authentication-fail + :stage ':request-code + :message "The device authorization response omitted required fields.")) + (make-instance 'device-authorization + :verification-url + (device-authentication-issuer-url client "/codex/device") + :user-code user-code + :device-authorization-id device-authorization-id + :poll-interval poll-interval))))) + +(defmethod device-authentication-complete + ((client openai-device-authentication-client) + (authorization device-authorization) + (manager credential-manager)) + "Poll AUTHORIZATION, exchange its code, and securely publish the result." + (call-with-secret-use + (lambda () + (let* ((authorization-code + (funcall + (device-authentication-client-poll-function client) + client + authorization)) + (primary-source (credential-manager-primary-source manager))) + (unless (typep authorization-code 'device-authorization-code) + (device-authentication-fail + :stage ':poll + :message "The device authorization poll returned an invalid result.")) + (let ((credentials + (device-authentication--exchange-code + :client client + :authorization-code authorization-code + :source-path (credential-source-pathname primary-source)))) + (credential-manager-accept-account + manager credentials :allow-change t) + (credential-source-save primary-source credentials)) + t)))) + +;;;; -- ChatGPT Device Authentication Construction and Presentation -- + +(-> device-authentication-client-create + (&key + (:issuer string) + (:client-id string) + (:request-function (option function)) + (:poll-function (option function)) + (:sleep-function function) + (:clock-function function) + (:browser-function function) + (:poll-timeout integer)) + device-authentication-client) +(defun device-authentication-client-create + (&key + (issuer *openai-oauth-issuer*) + (client-id *openai-oauth-client-id*) + request-function + poll-function + (sleep-function #'sleep) + (clock-function #'device-authentication-monotonic-seconds) + (browser-function #'device-authentication-open-browser) + (poll-timeout *device-authentication-timeout*)) + "Create a ChatGPT device client, optionally replacing every external effect." + (unless (and (non-empty-string-p issuer) + (non-empty-string-p client-id) + (plusp poll-timeout)) + (device-authentication-fail + :stage ':configuration + :message "Device authentication configuration is invalid.")) + (make-instance 'openai-device-authentication-client + :issuer (string-right-trim '(#\/) issuer) + :client-id client-id + :request-function + (or request-function #'device-authentication-request) + :poll-function + (or poll-function #'device-authentication--poll-for-code) + :sleep-function sleep-function + :clock-function clock-function + :browser-function browser-function + :poll-timeout poll-timeout)) + +(defmethod device-authentication-display-code + ((client openai-device-authentication-client) + (authorization device-authorization) + (stream stream)) + "Display the ChatGPT verification URL and one-time code." + (declare (ignore client)) + (format stream + "~&Sign in with ChatGPT:~% Open: ~A~% Code: ~A~%~%The code expires in 15 minutes. Continue only if you started this login in Autolith.~%" + (device-authorization-verification-url authorization) + (device-authorization-user-code authorization)) + (finish-output stream) + nil) + +;;;; -- Private ChatGPT Device Flow -- + +(-> device-authentication--poll-for-code + (device-authentication-client device-authorization) + device-authorization-code) +(defun device-authentication--poll-for-code (client authorization) + "Poll CLIENT until AUTHORIZATION succeeds, fails, or reaches its deadline." + (let* ((clock (device-authentication-client-clock-function client)) + (started-at (funcall clock)) + (deadline (+ started-at + (device-authentication-client-poll-timeout client))) + (url (device-authentication-issuer-url + client + "/api/accounts/deviceauth/token")) + (content + (json-encode + (json-object + "device_auth_id" (device-authorization-id authorization) + "user_code" (device-authorization-user-code authorization))))) + (loop + (multiple-value-bind (body status response-headers) + (device-authentication-invoke-request + :client client + :url url + :headers (list (cons "Content-Type" "application/json") + (cons "Accept" "application/json") + (cons "User-Agent" + (authentication-user-agent))) + :content content + :stage ':poll) + (declare (ignore response-headers)) + (cond + ((device-authentication-success-status-p status) + (let* ((document + (handler-case + (json-decode body) + (error () + (device-authentication-fail + :stage ':poll + :message "The approved device response contained invalid JSON.")))) + (authorization-code + (and (json-object-p document) + (json-get document "authorization_code"))) + (code-verifier + (and (json-object-p document) + (json-get document "code_verifier")))) + (unless (and (non-empty-string-p authorization-code) + (non-empty-string-p code-verifier)) + (device-authentication-fail + :stage ':poll + :message "The approved device response omitted required fields.")) + (return + (make-instance 'device-authorization-code + :authorization-code authorization-code + :code-verifier code-verifier)))) + ((member status '(403 404)) + (let ((now (funcall clock))) + (when (>= now deadline) + (device-authentication-fail + :stage ':poll + :message "Device authentication timed out after 15 minutes.")) + (funcall (device-authentication-client-sleep-function client) + (min (device-authorization-poll-interval authorization) + (max 0 (- deadline now)))))) + (t + (let ((code + (device-authentication-error-code-of-body + body + (list + (device-authorization-id authorization) + (device-authorization-user-code authorization) + content)))) + (device-authentication-fail + :stage ':poll + :message (format nil "Device authorization was not completed~@[ (~A)~]." + code) + :status status + :code code)))))))) + +(-> device-authentication--exchange-code + (&key + (:client device-authentication-client) + (:authorization-code device-authorization-code) + (:source-path pathname)) + oauth-credentials) +(defun device-authentication--exchange-code + (&key client authorization-code source-path) + "Exchange AUTHORIZATION-CODE and return credentials attributed to SOURCE-PATH." + (let* ((redirect-url + (device-authentication-issuer-url client "/deviceauth/callback")) + (content + (url-encode-params + (list + (cons "grant_type" "authorization_code") + (cons "code" + (device-authorization-code-value authorization-code)) + (cons "redirect_uri" redirect-url) + (cons "client_id" (device-authentication-client-id client)) + (cons "code_verifier" + (device-authorization-code-verifier authorization-code))))) + (document + (device-authentication-json-request + :client client + :url (device-authentication-issuer-url client "/oauth/token") + :content-type "application/x-www-form-urlencoded" + :content content + :stage ':exchange + :secret-values + (list + (device-authorization-code-value authorization-code) + (device-authorization-code-verifier authorization-code) + content))) + (id-token (json-get document "id_token")) + (access-token (json-get document "access_token")) + (refresh-token (json-get document "refresh_token")) + (account-id + (or (and (stringp id-token) + (device-authentication--jwt-account-id id-token)) + (and (stringp access-token) + (device-authentication--jwt-account-id access-token))))) + (unless (and (non-empty-string-p id-token) + (non-empty-string-p access-token) + (non-empty-string-p refresh-token) + (non-empty-string-p account-id)) + (device-authentication-fail + :stage ':credentials + :message "The OAuth exchange omitted required credential fields.")) + (make-instance 'oauth-credentials + :access-token access-token + :refresh-token refresh-token + :id-token id-token + :account-id account-id + :expires-at (or (jwt-expiration access-token) + (jwt-expiration id-token)) + :source-path source-path))) + +(-> device-authentication--jwt-account-id (string) (option string)) +(defun device-authentication--jwt-account-id (token) + "Return the account identifier carried by TOKEN's unverified JWT payload." + (jwt-account-id token)) + + ;;;; -- cl-rfc8628 Host Wiring -- (setf cl-rfc8628:*user-agent-function* #'authentication-user-agent diff --git a/src/startup/main.lisp b/src/startup/main.lisp index a7ab7057..2593db34 100644 --- a/src/startup/main.lisp +++ b/src/startup/main.lisp @@ -560,8 +560,10 @@ dependencies." (list 'main--locate-user-tree-system)))) nil) -(-> main-authenticate (configuration (option string)) null) -(defun main-authenticate (configuration selection) +(-> main-authenticate + (configuration (option string) &optional (option string)) + null) +(defun main-authenticate (configuration selection &optional method) "Authenticate a registered provider before the conversation UI starts." (configuration-ensure-directories configuration) (let ((provider (main--authentication-provider configuration selection)) @@ -569,9 +571,10 @@ dependencies." (*api-key-output-styled-p* (main--authentication-output-styled-p *standard-output*))) (format t "~&~A~%" - (provider-authenticate provider - :stream *standard-output* - :open-browser-p t))) + (provider-authenticate-with-method + provider method + :stream *standard-output* + :open-browser-p t))) nil) (-> main--image-pathnames (list) list) @@ -624,11 +627,12 @@ dependencies." &key (:resume-requested-p boolean) (:resume-id (option string)) (:authenticate-p boolean) - (:authentication-selection (option string))) + (:authentication-selection (option string)) + (:authentication-method (option string))) null) (defun main--start-session (command &key resume-requested-p resume-id authenticate-p - authentication-selection) + authentication-selection authentication-method) "Start one interactive Autolith session from COMMAND's parsed options." (main--register-local-source-trees) (let* ((immutable-p (not (null (getopt* command ':immutable)))) @@ -677,7 +681,8 @@ dependencies." (user-init-load configuration) (main-authenticate (preferences-apply-model-selection (provider-bootstrap-configuration configuration)) - authentication-selection)) + authentication-selection + authentication-method)) (when handoff-record (localgroup-handoff-begin-startup handoff-record) (application--clear-recovery-environment)) @@ -909,14 +914,18 @@ path." (make-command :name "auth" :description "authenticate a provider, then start a session" - :usage "[PROVIDER]" + :usage "[PROVIDER] [METHOD]" :handler (lambda (command) - (main--start-session - command - :authenticate-p t - :authentication-selection - (main--single-selection command "provider name"))))) + (let ((arguments (command-arguments command))) + (when (> (length arguments) 2) + (error 'configuration-error + :message "Auth accepts a provider and optional method.")) + (main--start-session + command + :authenticate-p t + :authentication-selection (first arguments) + :authentication-method (second arguments)))))) (-> main--top-level-command () clingon:command) (defun main--top-level-command () diff --git a/tests/application-command-tests.lisp b/tests/application-command-tests.lisp index e30e03e9..5eec1821 100644 --- a/tests/application-command-tests.lisp +++ b/tests/application-command-tests.lisp @@ -587,23 +587,24 @@ (null (application-operation-call application name)) (format nil "(~A) accepts its omitted optional argument" name))))) (uiop:delete-directory-tree root :validate t :if-does-not-exist ':ignore))) - (dolist (input '("/auth grok typo" - "/mcp refresh typo" - "/permissions auto garbage")) - (test-assert - (= (length (application-command--tokens input)) 3) - (format nil "~A tokenizes every supplied slash argument" input)) - (let* ((invocation (application-command-invocation-parse input)) - (command (application-command-invocation-command invocation))) + (dolist (case '(("/auth grok device typo" 4) + ("/mcp refresh typo" 3) + ("/permissions auto garbage" 3))) + (destructuring-bind (input token-count) case (test-assert - (handler-case - (progn - (application-command-execute command nil invocation) - nil) - (configuration-error () - t)) - (format nil "~A reports excess slash arguments during guarded dispatch" - input)))) + (= (length (application-command--tokens input)) token-count) + (format nil "~A tokenizes every supplied slash argument" input)) + (let* ((invocation (application-command-invocation-parse input)) + (command (application-command-invocation-command invocation))) + (test-assert + (handler-case + (progn + (application-command-execute command nil invocation) + nil) + (configuration-error () + t)) + (format nil "~A reports excess slash arguments during guarded dispatch" + input))))) (test-assert (handler-case (progn @@ -893,7 +894,8 @@ "Test /auth and (auth) share selection, explicit naming, and direct output." (let ((application (make-instance 'application)) (picked-p nil) - (authenticated-provider nil)) + (authenticated-provider nil) + (authenticated-method nil)) (test-call-with-function-replacements (list (list @@ -904,9 +906,10 @@ "grok")) (list 'application-authenticate - (lambda (candidate provider-name) + (lambda (candidate provider-name &optional method) (declare (ignore candidate)) - (setf authenticated-provider provider-name) + (setf authenticated-provider provider-name + authenticated-method method) nil))) (lambda () (let ((*application-command-interactive-p* t)) @@ -918,15 +921,28 @@ (and picked-p (string= authenticated-provider "grok")) "argument-free auth picks and authenticates one provider") (setf picked-p nil - authenticated-provider nil) + authenticated-provider nil + authenticated-method nil) (test-assert (eq (application--builtin-authentication-command application "anthropic") ':continue) "named auth completes through the canonical command") (test-assert (and (not picked-p) - (string= authenticated-provider "anthropic")) - "named auth bypasses selection and preserves the provider name"))))) + (string= authenticated-provider "anthropic") + (null authenticated-method)) + "named auth bypasses selection and preserves the provider name") + (setf authenticated-provider nil + authenticated-method nil) + (test-assert + (eq (application--builtin-authentication-command + application "chatgpt" "device") + ':continue) + "auth accepts an explicit ChatGPT authentication method") + (test-assert + (and (string= authenticated-provider "chatgpt") + (string= authenticated-method "device")) + "auth passes the explicit authentication method through unchanged"))))) (let* ((configuration (test-configuration)) (root (test-configuration-root configuration)) (conversation (conversation-create configuration @@ -942,7 +958,8 @@ :conversation conversation :ui (terminal-ui-create :terminal terminal))) (picked-p nil) - (authenticated-provider nil)) + (authenticated-provider nil) + (authenticated-method nil)) (unwind-protect (test-call-with-function-replacements (list @@ -954,9 +971,10 @@ "grok")) (list 'application-authenticate - (lambda (candidate provider-name) + (lambda (candidate provider-name &optional method) (declare (ignore candidate)) - (setf authenticated-provider provider-name) + (setf authenticated-provider provider-name + authenticated-method method) nil))) (lambda () (test-assert @@ -966,7 +984,8 @@ (and picked-p (string= authenticated-provider "grok")) "callable auth with no provider opens provider selection") (setf picked-p nil - authenticated-provider nil) + authenticated-provider nil + authenticated-method nil) (test-assert (eq (application-run-lisp-input application "(auth \"anthropic\")") @@ -974,8 +993,20 @@ "callable auth with a provider completes through local Lisp") (test-assert (and (not picked-p) - (string= authenticated-provider "anthropic")) - "callable auth with a provider bypasses selection"))) + (string= authenticated-provider "anthropic") + (null authenticated-method)) + "callable auth with a provider bypasses selection") + (setf authenticated-provider nil + authenticated-method nil) + (test-assert + (eq (application-run-lisp-input + application "(auth \"chatgpt\" \"device\")") + ':continue) + "callable auth accepts an explicit authentication method") + (test-assert + (and (string= authenticated-provider "chatgpt") + (string= authenticated-method "device")) + "callable auth passes its authentication method through"))) (uiop:delete-directory-tree root :validate t :if-does-not-exist ':ignore))) diff --git a/tests/authentication-tests.lisp b/tests/authentication-tests.lisp index 14bf4987..604d1f7e 100644 --- a/tests/authentication-tests.lisp +++ b/tests/authentication-tests.lisp @@ -461,24 +461,26 @@ (root (test-configuration-root configuration)) (observed-descriptor nil) (observed-styled-p ':unset) + (observed-method nil) (provider-function (lambda (candidate selection) (declare (ignore candidate selection)) ':test-provider)) (authenticator - (lambda (provider &key stream open-browser-p) - (declare (ignore stream)) - (test-assert (and (eq provider ':test-provider) - open-browser-p) - "command-line auth invokes the selected provider") - (setf observed-descriptor *api-key-input-file-descriptor* - observed-styled-p *api-key-output-styled-p*) - "Provider authentication was saved."))) + (lambda (provider method &key stream open-browser-p) + (declare (ignore stream)) + (test-assert (and (eq provider ':test-provider) + open-browser-p) + "command-line auth invokes the selected provider") + (setf observed-descriptor *api-key-input-file-descriptor* + observed-styled-p *api-key-output-styled-p* + observed-method method) + "Provider authentication was saved."))) (unwind-protect (progn (test-call-with-function-replacements (list (list 'main--authentication-provider provider-function) - (list 'provider-authenticate authenticator)) + (list 'provider-authenticate-with-method authenticator)) (lambda () (let ((*standard-output* (make-string-output-stream))) (main-authenticate configuration "example")))) @@ -486,6 +488,8 @@ (and (= observed-descriptor 0) (null observed-styled-p)) "noninteractive command-line auth supplies stdin without terminal styling") + (test-assert (null observed-method) + "command-line auth defaults its method selection") (setf observed-styled-p ':unset) (test-call-with-function-replacements (list (list 'main--authentication-provider provider-function) @@ -493,12 +497,13 @@ (lambda (stream) (declare (ignore stream)) t)) - (list 'provider-authenticate authenticator)) + (list 'provider-authenticate-with-method authenticator)) (lambda () (let ((*standard-output* (make-string-output-stream))) - (main-authenticate configuration "example")))) - (test-assert (eq observed-styled-p t) - "interactive command-line auth enables semantic styling")) + (main-authenticate configuration "example" "device")))) + (test-assert (and (eq observed-styled-p t) + (string= observed-method "device")) + "command-line auth passes styling and method selection")) (uiop:delete-directory-tree root :validate t :if-does-not-exist ':ignore))) nil) diff --git a/tests/chatgpt-authentication-tests.lisp b/tests/chatgpt-authentication-tests.lisp index 96026764..560df05f 100644 --- a/tests/chatgpt-authentication-tests.lisp +++ b/tests/chatgpt-authentication-tests.lisp @@ -264,8 +264,11 @@ (provider-authentication-provider (test-configuration) "chatgpt")) (output (make-string-output-stream)) (browser-setting nil) + (device-setting nil) (browser-login-count 0) - (message nil)) + (device-login-count 0) + (browser-message nil) + (device-message nil)) (test-call-with-function-replacements (list (list 'chatgpt-oauth-login @@ -275,16 +278,34 @@ (setf browser-setting open-browser-p) nil)) (list 'device-authentication-login - (lambda (&rest arguments) - (declare (ignore arguments)) - (error "The ChatGPT auth command must not use device authentication.")))) + (lambda (client manager &key stream open-browser-p) + (declare (ignore client manager stream)) + (incf device-login-count) + (setf device-setting open-browser-p) + t))) (lambda () - (setf message - (provider-authenticate - provider :stream output :open-browser-p nil)))) - (test-assert (and (= browser-login-count 1) - (null browser-setting) - (string= message - "ChatGPT authentication was saved by Autolith.")) - "The ChatGPT auth command routes through browser OAuth")) + (setf browser-message + (provider-authenticate-with-method + provider nil :stream output :open-browser-p nil) + device-message + (provider-authenticate-with-method + provider "device" :stream output :open-browser-p nil)))) + (test-assert + (and (= browser-login-count 1) + (= device-login-count 1) + (null browser-setting) + (null device-setting) + (string= browser-message + "ChatGPT authentication was saved by Autolith.") + (string= device-message browser-message)) + "The ChatGPT auth command offers browser and device OAuth") + (test-assert + (handler-case + (progn + (provider-authenticate-with-method + provider "invalid" :stream output :open-browser-p nil) + nil) + (authentication-error () + t)) + "The ChatGPT auth command rejects unknown authentication methods")) nil) \ No newline at end of file diff --git a/tests/device-authentication-tests.lisp b/tests/device-authentication-tests.lisp new file mode 100644 index 00000000..dfe9c31a --- /dev/null +++ b/tests/device-authentication-tests.lisp @@ -0,0 +1,543 @@ +(in-package #:autolith) + +;;;; -- ChatGPT Device Authentication Test Support -- + + +(-> device-authentication-test--manager () credential-manager) +(defun device-authentication-test--manager () + "Return a credential manager whose writable source records test credentials." + (make-instance + 'credential-manager + :primary-source + (make-instance 'recording-autolith-credential-source + :pathname #P"/tmp/autolith-device-authentication/auth.sexp") + :bootstrap-source + (make-instance 'codex-bootstrap-credential-source + :pathname #P"/tmp/autolith-device-authentication/codex-auth.json"))) + +(-> device-authentication-test--base64url (string) string) +(defun device-authentication-test--base64url (source) + "Return SOURCE encoded as unpadded RFC 4648 Base64url text." + (string-right-trim + '(#\=) + (substitute #\_ + #\/ + (substitute #\- + #\+ + (cl-base64:string-to-base64-string source))))) + +(-> device-authentication-test--jwt (json-object) string) +(defun device-authentication-test--jwt (payload) + "Return an unsigned test JWT containing PAYLOAD." + (format nil "~A.~A.signature" + (device-authentication-test--base64url "{\"alg\":\"none\"}") + (device-authentication-test--base64url (json-encode payload)))) + + + +;;;; -- ChatGPT Device Authentication Tests -- + +(-> device-authentication-test--complete-flow () null) +(defun device-authentication-test--complete-flow () + "Exercise request, pending poll, exchange, display, and secure publication." + (let* ((account-id "account-test-123") + (id-token + (device-authentication-test--jwt + (json-object + "https://api.openai.com/auth" + (json-object "chatgpt_account_id" account-id)))) + (requests nil) + (poll-count 0) + (clock 0) + (sleeps nil) + (opened-url nil) + (*device-authentication-test-saved-credentials* nil)) + (flet ((request (&key method url headers content) + (push (list :method method + :url url + :headers headers + :content content) + requests) + (cond + ((device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/usercode") + (values + (json-encode + (json-object + "device_auth_id" "device-test-123" + "user_code" "TEST-CODE" + "interval" "2")) + 200 + nil)) + ((device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/token") + (incf poll-count) + (if (= poll-count 1) + (values "{}" 404 nil) + (values + (json-encode + (json-object + "authorization_code" "authorization-test-123" + "code_challenge" "challenge-test-123" + "code_verifier" "verifier-test-123")) + 200 + nil))) + ((device-authentication-test--url-suffix-p url "/oauth/token") + (values + (json-encode + (json-object + "id_token" id-token + "access_token" "access-test-123" + "refresh_token" "refresh-test-123")) + 200 + nil)) + (t + (error "Unexpected test URL.")))) + + (pause (seconds) + (push seconds sleeps) + (incf clock seconds)) + + (now () + clock) + + (open-browser (url) + (setf opened-url url) + t)) + (let* ((client + (device-authentication-client-create + :issuer "https://issuer.test/" + :request-function #'request + :sleep-function #'pause + :clock-function #'now + :browser-function #'open-browser)) + (manager (device-authentication-test--manager)) + (output + (with-output-to-string (stream) + (test-assert + (device-authentication-login client manager :stream stream) + "the complete device flow succeeds"))) + (ordered-requests (nreverse requests)) + (code-request + (device-authentication-test--request + ordered-requests + "/api/accounts/deviceauth/usercode")) + (exchange-request + (device-authentication-test--request + ordered-requests + "/oauth/token")) + (saved *device-authentication-test-saved-credentials*)) + (test-assert (= poll-count 2) + "pending authorization is polled until approved") + (test-assert (equal sleeps '(2)) + "the server polling interval is honored") + (test-assert + (string= opened-url "https://issuer.test/codex/device") + "the configured browser receives the verification URL") + (test-assert (search "https://issuer.test/codex/device" output) + "the verification URL is always displayed") + (test-assert (search "TEST-CODE" output) + "the one-time user code is always displayed") + (dolist (secret (list id-token + "access-test-123" + "refresh-test-123" + "authorization-test-123" + "verifier-test-123")) + (test-assert (null (search secret output)) + "credential material is never displayed")) + (test-assert + (string= + (json-get (json-decode (getf code-request :content)) "client_id") + *openai-oauth-client-id*) + "the current public OAuth client identifier is sent") + (test-assert + (string-equal + (rest (assoc "Content-Type" + (getf exchange-request :headers) + :test #'string-equal)) + "application/x-www-form-urlencoded") + "the code exchange uses form encoding") + (test-assert + (and (search "grant_type=authorization_code" + (getf exchange-request :content)) + (search "code=authorization-test-123" + (getf exchange-request :content)) + (search "code_verifier=verifier-test-123" + (getf exchange-request :content)) + (search "redirect_uri=https%3A%2F%2Fissuer.test%2Fdeviceauth%2Fcallback" + (getf exchange-request :content))) + "the code exchange contains the exact device grant fields") + (test-assert (typep saved 'oauth-credentials) + "credentials are published through Autolith's store protocol") + (test-assert + (string= (oauth-credentials-account-id saved) account-id) + "the nested ChatGPT account identifier is extracted") + (test-assert + (string= (oauth-credentials-access-token saved) "access-test-123") + "the exchanged access token reaches only the credential store") + (test-assert + (equal (oauth-credentials-source-path saved) + #P"/tmp/autolith-device-authentication/auth.sexp") + "saved credentials are attributed to Autolith's private store"))) + nil)) + +(-> device-authentication-test--injected-poll () null) +(defun device-authentication-test--injected-poll () + "Verify high-level authentication accepts an injected polling effect." + (let* ((account-id "account-from-access") + (access-token + (device-authentication-test--jwt + (json-object "chatgpt_account_id" account-id))) + (poll-calls 0) + (secret-guard-observed-p nil) + (*device-authentication-test-saved-credentials* nil)) + (flet ((request (&key method url headers content) + (declare (ignore method headers content)) + (cond + ((device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/usercode") + (values + (json-encode + (json-object + "device_auth_id" "device-injected" + "user_code" "INJECTED-CODE" + "interval" "7")) + 200 + nil)) + ((device-authentication-test--url-suffix-p url "/oauth/token") + (values + (json-encode + (json-object + "id_token" + (device-authentication-test--jwt (json-object)) + "access_token" access-token + "refresh_token" "refresh-injected")) + 200 + nil)) + (t + (error "The injected poll should avoid the poll endpoint.")))) + + (poll (client authorization) + (declare (ignore client)) + (incf poll-calls) + (setf secret-guard-observed-p (secret-use-active-p)) + (test-assert + (string= (device-authorization-user-code authorization) + "INJECTED-CODE") + "the injected poll receives the requested authorization") + (make-instance 'device-authorization-code + :authorization-code "authorization-injected" + :code-verifier "verifier-injected")) + + (unexpected-sleep (seconds) + (declare (ignore seconds)) + (error "The injected poll must not sleep."))) + (let ((client + (device-authentication-client-create + :issuer "https://issuer.test" + :request-function #'request + :poll-function #'poll + :sleep-function #'unexpected-sleep))) + (with-output-to-string (stream) + (device-authentication-login + client + (device-authentication-test--manager) + :stream stream + :open-browser-p nil)) + (test-assert (= poll-calls 1) + "the injected polling function is called exactly once") + (test-assert + secret-guard-observed-p + "device authorization holds the process-wide transient-secret guard") + (test-assert + (string= (oauth-credentials-account-id + *device-authentication-test-saved-credentials*) + account-id) + "account extraction falls back from the ID token to the access token"))) + nil)) + +(-> device-authentication-test--timeout () null) +(defun device-authentication-test--timeout () + "Verify pending responses stop at the configured polling deadline." + (let ((clock 0) + (poll-count 0) + (request-guard-observed-p nil) + (*device-authentication-test-saved-credentials* nil)) + (flet ((request (&key method url headers content) + (declare (ignore method headers content)) + (if (device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/usercode") + (progn + (setf request-guard-observed-p + (secret-use-active-p)) + (values + (json-encode + (json-object + "device_auth_id" "device-timeout" + "user_code" "TIMEOUT-CODE" + "interval" "5")) + 200 + nil)) + (progn + (incf poll-count) + (values "{}" 403 nil)))) + + (pause (seconds) + (incf clock seconds)) + + (now () + clock)) + (let* ((client + (device-authentication-client-create + :issuer "https://issuer.test" + :request-function #'request + :sleep-function #'pause + :clock-function #'now + :poll-timeout 10)) + (authorization (device-authentication-request-code client))) + (test-assert + request-guard-observed-p + "direct device-code requests hold the transient-secret guard") + (device-authentication-test--signals + (lambda () + (device-authentication-complete + client + authorization + (device-authentication-test--manager))) + ':poll) + (test-assert (= poll-count 3) + "pending authorization stops at its deadline") + (test-assert (null *device-authentication-test-saved-credentials*) + "timed-out authentication publishes no credentials"))) + nil)) + +(-> device-authentication-test--error-echo-containment () null) +(defun device-authentication-test--error-echo-containment () + "Verify device-flow failures cannot echo transient request credentials." + (let ((device-id "device-secret-echo") + (user-code "USER-SECRET-ECHO") + (*device-authentication-test-saved-credentials* nil)) + (flet ((request (&key method url headers content) + (declare (ignore method headers content)) + (if + (device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/usercode") + (values + (json-encode + (json-object + "device_auth_id" device-id + "user_code" user-code + "interval" "1")) + 200 + nil) + (values + (json-encode + (json-object + "error" + (format nil "~A/~A" device-id user-code))) + 400 + nil)))) + (let* ((client + (device-authentication-client-create + :issuer "https://issuer.test" + :request-function #'request)) + (authorization (device-authentication-request-code client)) + (condition + (handler-case + (progn + (device-authentication-complete + client + authorization + (device-authentication-test--manager)) + nil) + (device-authentication-error (failure) + failure)))) + (test-assert + (and + condition + (not (test-object-contains-string-p condition device-id)) + (not (test-object-contains-string-p condition user-code)) + (test-object-contains-string-p + condition + *device-authentication-redaction-marker*)) + "poll failures redact echoed device identifiers and user codes")))) + (let ((authorization-code "authorization-secret-echo") + (code-verifier "verifier-secret-echo") + (*device-authentication-test-saved-credentials* nil)) + (flet ((request (&key method url headers content) + (declare (ignore method headers content)) + (cond + ((device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/usercode") + (values + (json-encode + (json-object + "device_auth_id" "device-exchange-echo" + "user_code" "EXCHANGE-ECHO" + "interval" "1")) + 200 + nil)) + ((device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/token") + (values + (json-encode + (json-object + "authorization_code" authorization-code + "code_verifier" code-verifier)) + 200 + nil)) + (t + (values + (json-encode + (json-object + "error" + (format + nil + "~A/~A" + authorization-code + code-verifier))) + 400 + nil))))) + (let* ((client + (device-authentication-client-create + :issuer "https://issuer.test" + :request-function #'request)) + (authorization (device-authentication-request-code client)) + (condition + (handler-case + (progn + (device-authentication-complete + client + authorization + (device-authentication-test--manager)) + nil) + (device-authentication-error (failure) + failure)))) + (test-assert + (and + condition + (not + (test-object-contains-string-p + condition authorization-code)) + (not (test-object-contains-string-p condition code-verifier)) + (test-object-contains-string-p + condition + *device-authentication-redaction-marker*)) + "exchange failures redact echoed authorization and PKCE values")))) + nil) + +(-> device-authentication-test--declined () null) +(defun device-authentication-test--declined () + "Verify a declined authorization exposes only its safe OAuth code." + (let ((*device-authentication-test-saved-credentials* nil)) + (flet ((request (&key method url headers content) + (declare (ignore method headers content)) + (if (device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/usercode") + (values + (json-encode + (json-object + "device_auth_id" "device-declined" + "user_code" "DECLINED-CODE" + "interval" "1")) + 200 + nil) + (values + (json-encode + (json-object + "error" "authorization_declined" + "error_description" "A sensitive provider explanation")) + 401 + nil)))) + (let* ((client + (device-authentication-client-create + :issuer "https://issuer.test" + :request-function #'request)) + (authorization (device-authentication-request-code client))) + (device-authentication-test--signals + (lambda () + (device-authentication-complete + client + authorization + (device-authentication-test--manager))) + ':poll + :status 401 + :code "authorization_declined") + (test-assert (null *device-authentication-test-saved-credentials*) + "declined authentication publishes no credentials"))) + nil)) + +(-> device-authentication-test--missing-account () null) +(defun device-authentication-test--missing-account () + "Verify token exchange without an account identifier is never published." + (let ((*device-authentication-test-saved-credentials* nil)) + (flet ((request (&key method url headers content) + (declare (ignore method headers content)) + (cond + ((device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/usercode") + (values + (json-encode + (json-object + "device_auth_id" "device-no-account" + "user_code" "NO-ACCOUNT-CODE" + "interval" "1")) + 200 + nil)) + ((device-authentication-test--url-suffix-p + url + "/api/accounts/deviceauth/token") + (values + (json-encode + (json-object + "authorization_code" "authorization-no-account" + "code_verifier" "verifier-no-account")) + 200 + nil)) + (t + (values + (json-encode + (json-object + "id_token" + (device-authentication-test--jwt (json-object)) + "access_token" + (device-authentication-test--jwt (json-object)) + "refresh_token" "refresh-no-account")) + 200 + nil))))) + (let* ((client + (device-authentication-client-create + :issuer "https://issuer.test" + :request-function #'request)) + (authorization (device-authentication-request-code client))) + (device-authentication-test--signals + (lambda () + (device-authentication-complete + client + authorization + (device-authentication-test--manager))) + ':credentials) + (test-assert (null *device-authentication-test-saved-credentials*) + "an incomplete token exchange is never published"))) + nil)) + + +(-> run-device-authentication-tests () boolean) +(defun run-device-authentication-tests () + "Run the offline ChatGPT device authentication tests." + (device-authentication-test--complete-flow) + (device-authentication-test--injected-poll) + (device-authentication-test--timeout) + (device-authentication-test--error-echo-containment) + (device-authentication-test--declined) + (device-authentication-test--missing-account) + t) diff --git a/tests/openai-compatible-provider-tests.lisp b/tests/openai-compatible-provider-tests.lisp index 01c4873c..0823717f 100644 --- a/tests/openai-compatible-provider-tests.lisp +++ b/tests/openai-compatible-provider-tests.lisp @@ -240,8 +240,7 @@ (make-instance 'preference-state :model model :reasoning-effort "minimal")) - (let ((authenticated-configuration nil) - (authenticated-selection :unset) + (let ((authentication-calls nil) (live-application (make-instance 'application)) (reconnect-called-p nil)) (test-call-with-function-replacements @@ -273,9 +272,9 @@ :reasoning-efforts ("minimal")))) nil)) (list 'main-authenticate - (lambda (configuration selection) - (setf authenticated-configuration configuration - authenticated-selection selection) + (lambda (configuration selection &optional method) + (push (list configuration selection method) + authentication-calls) nil)) (list 'application-reconnect (lambda (application &rest arguments) @@ -288,22 +287,32 @@ (lambda (application &rest arguments) (declare (ignore application arguments)) nil))) - (lambda () - (let ((*active-application* live-application)) - (let ((*active-application* nil)) - (main-dispatch '("auth")))))) + (lambda () + (let ((*active-application* live-application)) + (let ((*active-application* nil)) + (main-dispatch '("auth"))) + (let ((*active-application* nil)) + (main-dispatch '("auth" "chatgpt" "device")))))) (test-assert (not reconnect-called-p) - "bare auth does not reconnect the active application") - (test-assert - (and authenticated-configuration - (null authenticated-selection) - (string= (configuration-model authenticated-configuration) - model) - (string= (configuration-reasoning-effort - authenticated-configuration) - "minimal")) - "bare auth selects the persisted registered provider"))) + "auth commands do not reconnect the active application") + (let ((calls (nreverse authentication-calls))) + (test-assert (= (length calls) 2) + "auth commands authenticate exactly once each") + (destructuring-bind (bare explicit) calls + (test-assert + (and (typep (first bare) 'configuration) + (null (second bare)) + (null (third bare)) + (string= (configuration-model (first bare)) model) + (string= (configuration-reasoning-effort (first bare)) + "minimal")) + "bare auth selects the persisted registered provider") + (test-assert + (and (typep (first explicit) 'configuration) + (string= (second explicit) "chatgpt") + (string= (third explicit) "device")) + "command-line auth passes its explicit provider and method"))))) (if old-environment-model (sb-posix:setenv "AUTOLITH_MODEL" old-environment-model 1) (sb-posix:unsetenv "AUTOLITH_MODEL")) diff --git a/tests/tests.lisp b/tests/tests.lisp index c8d3d631..83d35021 100644 --- a/tests/tests.lisp +++ b/tests/tests.lisp @@ -349,6 +349,7 @@ (test-image-commit-replay-probe) (test-crash-capsule-correlation) (run-recovery-tests) + (run-device-authentication-tests) (run-nous-device-authentication-tests) (run-agent-tests) (test-task-agent-native-reader)