;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see
The refresh token you sent is invalid, or it is already bound to another key.
"))) ((*TOP* ,p) p)) ,@(if (message-for-the-user? error) (user-message error) '())))) port))))) ((invalid-authorization-code? error) (return (build-response #:code 400 #:reason-phrase (G_ "reason-phrase|Bad Request") #:headers '((content-type application/xhtml-xml))) (call-with-output-string (lambda (port) (sxml->xml `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") (html (@ (xmlns "http://www.w3.org/1999/xhtml") (xml:lang ,(W_ "xml-lang|en"))) (body ,(sxml-match (xml->sxml (W_ (format #f "The authorization code is forged, or expired.
"))) ((*TOP* ,p) p)) ,@(if (message-for-the-user? error) (user-message error) '())))) port))))) ;; Other bad request (else (return (build-response #:code 400 #:reason-phrase (G_ "reason-phrase|Bad Request") #:headers '((content-type application/xhtml+xml))) (call-with-output-string (lambda (port) (sxml->xml `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") (html (@ (xmlns "http://www.w3.org/1999/xhtml") (xml:lang ,(W_ "xml-lang|en"))) (body ,(sxml-match (xml->sxml (W_ (format #f "The token request failed.
"))) ((*TOP* ,p) p)) ,@(if (message-for-the-user? error) (user-message error) '())))) port))))))) thunk)))) (define (make-token-endpoint token-endpoint-uri iss jwk validity) (lambda (request request-body) (when (bytevector? request-body) (set! request-body (utf8->string request-body))) (try-handle-web-failure (lambda () (parameterize ((p:current-date ((p:current-date))) (web-locale request)) (let ((current-time ((p:current-date))) ;; thunk parameter (form-args (if (and (request-content-type request) (eq? (car (request-content-type request)) 'application/x-www-form-urlencoded)) (filter (lambda (x) x) (map (lambda (kv) (let ((parsed (list->vector (map (lambda (x) (uri-decode x #:decode-plus-to-space? #t)) (string-split kv #\=))))) (if (eq? (vector-length parsed) 2) `(,(vector-ref parsed 0) . ,(vector-ref parsed 1)) #f))) (string-split request-body #\&))) '())) (method (request-method request)) ;; Maybe we’re behind a reverse proxy, so the authority of ;; (request-uri request) is meaningless. (uri (build-uri (uri-scheme token-endpoint-uri) #:userinfo (uri-userinfo token-endpoint-uri) #:host (uri-host token-endpoint-uri) #:port (uri-port token-endpoint-uri) #:path (uri-path (request-uri request)) #:query (uri-query (request-uri request))))) (let ((grant-type (assoc-ref form-args "grant_type")) (dpop (dpop-proof-decode method uri (assq-ref (request-headers request) 'dpop) (lambda (jkt) #t)))) (unless (and grant-type (string? grant-type)) (let ((final-message (format #f (G_ "missing grant type"))) (final-user-message (sxml-match (xml->sxml (format #f (W_ "You did not specify a grant_type for this request.
"))) ((*TOP* ,p) p)))) (raise-exception (make-exception (make-unsupported-grant-type #f) (make-exception-with-message final-message) (make-message-for-the-user final-user-message))))) (receive (webid client-id) (case (string->symbol grant-type) ((authorization_code) (let ((code (let ((str (assoc-ref form-args "code"))) (unless str (let ((final-message (format #f (G_ "missing authorization code"))) (final-user-message (sxml-match (xml->sxml (format #f (W_ "You want to grant an authorization code, but you did not set one.
"))) ((*TOP* ,p) p)))) (raise-exception (make-exception (make-no-authorization-code) (make-exception-with-message final-message) (make-message-for-the-user final-user-message))))) (authorization-code-decode str jwk)))) (values (authorization-code-webid code) (authorization-code-client-id code)))) ((refresh_token) (let ((refresh-token (assoc-ref form-args "refresh_token"))) (unless refresh-token (let ((final-message (format #f (G_ "missing refresh token"))) (final-user-message (sxml-match (xml->sxml (format #f (W_ "You want to grant a refresh token, but you did not set one.
"))) ((*TOP* ,p) p)))) (raise-exception (make-exception (make-no-refresh-token) (make-exception-with-message final-message) (make-message-for-the-user final-user-message))))) (refresh:with-refresh-token refresh-token (dpop-proof-jwk dpop) values))) (else (let ((final-message (format #f (G_ "unsupported grant type: ~s") grant-type)) (final-user-message (sxml-match (xml->sxml (format #f (W_ "You want to use
~sas a grant type, but this is not supported.") grant-type)) ((*TOP* ,p) p)))) (raise-exception (make-exception (make-unsupported-grant-type grant-type) (make-exception-with-message final-message) (make-message-for-the-user final-user-message)))))) (let* ((iat (time-second (date->time-utc current-time))) (exp (+ iat validity))) (let ((id-token (issue-id-token jwk #:webid webid #:sub (uri->string webid) #:iss iss #:aud client-id #:validity 3600)) (access-token (issue-access-token jwk #:webid webid #:iss iss #:validity 3600 #:client-key (dpop-proof-jwk dpop) #:client-id client-id)) (refresh-token (if (equal? grant-type "refresh_token") (assoc-ref form-args "refresh_token") (refresh:issue-refresh-token webid client-id (jkt (dpop-proof-jwk dpop)))))) (values (build-response #:headers '((content-type application/json) (cache-control (no-cache no-store))) #:port #f) (stubs:scm->json-string `((id_token . ,id-token) (access_token . ,access-token) (token_type . "DPoP") (expires_in . ,validity) (refresh_token . ,refresh-token))) client-id #f)))))))))))