diff --git a/autolith.asd b/autolith.asd index fd4478f5..b12afe11 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,7 @@ (:file "recovery-tests") (:file "lisp-worker-tests") (:file "self-tool-tests") - (:file "device-authentication-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..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 credentials come from Autolith's own device 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 d6731f2d..1441820a 100644 --- a/docs/guide.org +++ b/docs/guide.org @@ -433,10 +433,15 @@ 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= 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. 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/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/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..a798b1ae --- /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 real + &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 t)) +(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..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) @@ -90,6 +127,24 @@ "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 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) &key stream open-browser-p) "Run the device login protocol for a subscription provider." @@ -241,6 +296,7 @@ This follows the filtered fork-history behavior in Codex (declare (ignore provider)) (device-authentication-client-create)) + (-> provider-family-create (keyword configuration &key (:reasoning-summaries-p boolean)) model-provider) diff --git a/src/provider/device-authentication.lisp b/src/provider/device-authentication.lisp index d25f4886..51303ebd 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) @@ -15,7 +10,7 @@ -;;;; -- Device Authentication State -- +;;;; -- ChatGPT Device Authentication State -- (defclass device-authorization-code () ((authorization-code @@ -30,9 +25,7 @@ :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 -- +;;;; -- ChatGPT Device Authentication Methods -- (defclass openai-device-authentication-client (device-authentication-client) () @@ -103,7 +96,7 @@ (credential-source-save primary-source credentials)) t)))) -;;;; -- Public Construction and Presentation -- +;;;; -- ChatGPT Device Authentication Construction and Presentation -- (-> device-authentication-client-create (&key @@ -126,7 +119,7 @@ (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." + "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)) @@ -158,16 +151,7 @@ (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))) +;;;; -- Private ChatGPT Device Flow -- (-> device-authentication--poll-for-code (device-authentication-client device-authorization) @@ -194,7 +178,7 @@ :headers (list (cons "Content-Type" "application/json") (cons "Accept" "application/json") (cons "User-Agent" - (device-authentication--user-agent))) + (authentication-user-agent))) :content content :stage ':poll) (declare (ignore response-headers)) @@ -311,5 +295,5 @@ ;;;; -- 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/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 809960db..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) @@ -623,7 +628,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..560df05f --- /dev/null +++ b/tests/chatgpt-authentication-tests.lisp @@ -0,0 +1,311 @@ +(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 + 201/2 + :clock-function (lambda () 1/2) + :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 ((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) + (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) + (device-setting nil) + (browser-login-count 0) + (device-login-count 0) + (browser-message nil) + (device-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 (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 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-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 index cd7b90c9..dfe9c31a 100644 --- a/tests/device-authentication-tests.lisp +++ b/tests/device-authentication-tests.lisp @@ -1,21 +1,7 @@ (in-package #:autolith) -;;;; -- Device Authentication Test Support -- +;;;; -- ChatGPT 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 () @@ -47,41 +33,9 @@ (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 -- +;;;; -- ChatGPT Device Authentication Tests -- (-> device-authentication-test--complete-flow () null) (defun device-authentication-test--complete-flow () @@ -576,13 +530,6 @@ "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 () 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 c5d0f736..83d35021 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)