summaryrefslogtreecommitdiff
path: root/src/scm/webid-oidc/server/endpoint/identity-provider.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/scm/webid-oidc/server/endpoint/identity-provider.scm')
-rw-r--r--src/scm/webid-oidc/server/endpoint/identity-provider.scm590
1 files changed, 590 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/server/endpoint/identity-provider.scm b/src/scm/webid-oidc/server/endpoint/identity-provider.scm
new file mode 100644
index 0000000..d259ce9
--- /dev/null
+++ b/src/scm/webid-oidc/server/endpoint/identity-provider.scm
@@ -0,0 +1,590 @@
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 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 <https://www.gnu.org/licenses/>.
+
+(define-module (webid-oidc server endpoint identity-provider)
+ #:use-module (webid-oidc errors)
+ #:use-module (webid-oidc authorization-code)
+ #:use-module (webid-oidc oidc-id-token)
+ #:use-module (webid-oidc access-token)
+ #:use-module (webid-oidc dpop-proof)
+ #:use-module (webid-oidc refresh-token)
+ #:use-module (webid-oidc oidc-configuration)
+ #:use-module (webid-oidc server endpoint)
+ #:use-module (webid-oidc provider-confirmation)
+ #:use-module (webid-oidc client-manifest)
+ #:use-module (webid-oidc jwk)
+ #:use-module ((webid-oidc parameters) #:prefix p:)
+ #:use-module ((webid-oidc config) #:prefix cfg:)
+ #:use-module ((webid-oidc stubs) #:prefix stubs:)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:use-module (web server)
+ #:use-module (web client)
+ #:use-module (ice-9 optargs)
+ #:use-module (ice-9 receive)
+ #:use-module (webid-oidc web-i18n)
+ #:use-module (ice-9 getopt-long)
+ #:use-module (ice-9 suspendable-ports)
+ #:use-module (ice-9 control)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 exceptions)
+ #:use-module (sxml simple)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (oop goops)
+ #:use-module (sxml simple)
+ #:use-module (rnrs bytevectors)
+ #:duplicates (merge-generics)
+ #:declarative? #t
+ #:export
+ (
+ <oidc-discovery>
+ configuration
+
+ <authorization-endpoint>
+ subject
+ encrypted-password
+ key-file
+
+ <token-endpoint>
+ issuer
+ ;; key-file
+
+ <jwks-endpoint>
+ ;; key-file
+
+ <identity-provider>
+ oidc-discovery
+ authorization-endpoint
+ token-endpoint
+ jwks-endpoint
+ default
+ ))
+
+(define* (read-key-file key-file #:key (create? #f))
+ (define returned #f)
+ (if create?
+ (begin
+ (stubs:atomically-update-file
+ key-file
+ (string-append key-file ".lock")
+ (lambda (output-port)
+ (catch #t
+ (lambda ()
+ (call-with-input-file key-file
+ (lambda (port)
+ (set! returned
+ (jwk->key
+ (stubs:json->scm port))))))
+ (lambda error
+ ;; Generate the key and save it
+ (set! returned (generate-key #:n-size 2048))))
+ ;; Either the key already existed, so we save the exact same
+ ;; key, or it did not, so we save a new one.
+ (stubs:scm->json (key->jwk returned) output-port #:pretty #t)
+ #t))
+ returned)
+ ;; Try to read it first:
+ (catch #t
+ (lambda ()
+ (call-with-input-file key-file
+ (lambda (port)
+ (jwk->key (stubs:json->scm port)))))
+ (lambda error
+ (format (current-error-port) (G_ "Warning: generating a new key pair.\n"))
+ (read-key-file key-file #:create? #t)))))
+
+(define-class <oidc-discovery> (<endpoint>)
+ (configuration #:init-keyword #:configuration #:getter configuration))
+
+(define-class <authorization-endpoint> (<endpoint>)
+ (subject #:init-keyword #:subject #:getter subject)
+ (encrypted-password #:init-keyword #:encrypted-password #:getter encrypted-password)
+ (key-file #:init-keyword #:key-file #:getter key-file))
+
+(define-class <token-endpoint> (<endpoint>)
+ (issuer #:init-keyword #:issuer #:getter issuer)
+ (key-file #:init-keyword #:key-file #:getter key-file))
+
+(define-class <jwks-endpoint> (<endpoint>)
+ (key-file #:init-keyword #:key-file #:getter key-file))
+
+(define-class <identity-provider> (<router>)
+ (oidc-discovery #:init-keyword #:oidc-discovery #:getter oidc-discovery)
+ (authorization-endpoint #:init-keyword #:authorization-endpoint #:getter authorization-endpoint)
+ (token-endpoint #:init-keyword #:token-endpoint #:getter token-endpoint)
+ (jwks-endpoint #:init-keyword #:jwks-endpoint #:getter jwks-endpoint))
+
+(define-method (initialize (cfg <oidc-discovery>) initargs)
+ (next-method)
+ (unless (equal? (path cfg) "/.well-known/openid-configuration")
+ (scm-error 'wrong-type-arg "make <oidc-discovery>"
+ (G_ "#:path must be exactly \"/.well-known/openid-configuration\"")
+ '()
+ (list (path cfg))))
+ (let-keywords
+ initargs #t
+ ((configuration #f))
+ (unless (is-a? configuration <oidc-configuration>)
+ (scm-error 'wrong-type-arg "make <oidc-discovery>"
+ (G_ "#:configuration must be an OIDC configuration")
+ '()
+ (list configuration)))))
+
+(define-method (initialize (a <authorization-endpoint>) initargs)
+ (next-method)
+ (let-keywords
+ initargs #t
+ ((subject #f)
+ (encrypted-password #f)
+ (key-file #f))
+ (match subject
+ ((? string? (= string->uri (? uri? subject)))
+ (slot-set! a 'subject subject))
+ ((? uri?) #t)
+ (else
+ (scm-error 'wrong-type-arg "make <authorization-endpoint>"
+ (G_ "#:subject should be an URI")
+ '()
+ (list subject))))
+ (unless (string? encrypted-password)
+ (scm-error 'wrong-type-arg "make <authorization-endpoint>"
+ (G_ "#:encrypted-password should be a string")
+ '()
+ (list encrypted-password)))
+ (unless (string? key-file)
+ (scm-error 'wrong-type-arg "make <authorization-endpoint>"
+ (G_ "#:key-file should be a string")
+ '()
+ (list key-file)))))
+
+(define-method (initialize (t <token-endpoint>) initargs)
+ (next-method)
+ (let-keywords
+ initargs #t
+ ((issuer #f)
+ (key-file #f))
+ (match issuer
+ ((? string? (= string->uri (? uri? issuer)))
+ (slot-set! t 'issuer issuer))
+ ((and (? uri?)
+ (= uri-path "")
+ (= uri-query #f)
+ (= uri-fragment #f))
+ #t)
+ (else
+ (scm-error 'wrong-type-arg "make <token-endpoint>"
+ (G_ "#:subject should be an URI without a path, query or fragment")
+ '()
+ (list issuer))))
+ (unless (string? key-file)
+ (scm-error 'wrong-type-arg "make <token-endpoint>"
+ (G_ "#:key-file should be a string")
+ '()
+ (list key-file)))))
+
+(define-method (initialize (j <jwks-endpoint>) initargs)
+ (next-method)
+ (let-keywords
+ initargs #t
+ ((key-file #f))
+ (unless (string? key-file)
+ (scm-error 'wrong-type-arg "make <jwks-endpoint>"
+ (G_ "#:key-file should be a string")
+ '()
+ (list key-file)))))
+
+(define-method (initialize (idp <identity-provider>) initargs)
+ (next-method)
+ (let-keywords
+ initargs #t
+ ((oidc-discovery #f)
+ (authorization-endpoint #f)
+ (token-endpoint #f)
+ (jwks-endpoint #f)
+ (default #f))
+ (match (routed idp)
+ (((? (cute eq? <> oidc-discovery))
+ (? (cute eq? <> authorization-endpoint))
+ (? (cute eq? <> token-endpoint))
+ (? (cute eq? <> jwks-endpoint))
+ (? (cute eq? <> default)))
+ ;; Recursive initialization done
+ #t)
+ (else
+ ;; Re-initialize with the proper endpoints
+ (initialize idp
+ `(#:routed (,oidc-discovery
+ ,authorization-endpoint
+ ,token-endpoint
+ ,jwks-endpoint
+ ,default)
+ ,@initargs))))))
+
+(define-method (handle (endpoint <oidc-discovery>) request request-body)
+ (let* ((current-sec (time-second (date->time-utc ((p:current-date)))))
+ (exp-sec (+ current-sec 3600))
+ (exp (time-utc->date
+ (make-time time-utc 0 exp-sec))))
+ (receive (response response-body)
+ (serve (configuration endpoint) exp)
+ (values response response-body '()))))
+
+(define (verify-password encrypted-password password)
+ (let ((c (crypt password encrypted-password)))
+ (string=? c encrypted-password)))
+
+(define (split-args str decode-plus-to-space?)
+ (apply append
+ (map
+ (lambda (k=v)
+ (catch #t
+ (lambda ()
+ (match (string-split k=v #\=)
+ (((= (cute uri-decode <> #:decode-plus-to-space? decode-plus-to-space?)
+ (= string->symbol key))
+ (= uri-decode value))
+ `((,key . ,value)))
+ (else '())))
+ (lambda error '())))
+ (catch #t
+ (lambda ()
+ (string-split str #\&))
+ (lambda error
+ '())))))
+
+(define-method (handle (endpoint <authorization-endpoint>) request request-body)
+ (let ((query-args
+ (split-args
+ (uri-query (request-uri request))
+ #f))
+ (form-args
+ (split-args
+ (and (match (request-content-type request)
+ ((or 'application/x-www-form-urlencoded
+ ('application/x-www-form-urlencoded _ ...))
+ #t)
+ (else #f))
+ (if (bytevector? request)
+ (false-if-exception
+ (utf8->string request-body))
+ request-body))
+ #t)))
+ (let ((client-id
+ (match (assq-ref query-args 'client_id)
+ ((? string? (= string->uri (? uri? uri)))
+ uri)
+ (else #f)))
+ (redirect-uri
+ (match (assq-ref query-args 'redirect_uri)
+ ((? string? (= string->uri (? uri? uri)))
+ uri)
+ (else #f)))
+ (password (assq-ref form-args 'password))
+ (state (assq-ref query-args 'state)))
+ (define form
+ (if (uri? client-id)
+ `(div
+ ,(call-with-input-string
+ (format #f (W_ "<h2>Do you wish to authorize <a href=~s>~a</a>?</h2>")
+ (uri->string client-id)
+ (uri->string client-id))
+ xml->sxml)
+ (p ,(W_ "If you wish to do so, please type your password:"))
+ (form (@ (method "post"))
+ (input (@ (type "password")
+ (name "password")
+ (id "password")))
+ (input (@ (type "submit")
+ (value ,(W_ "Allow"))))))
+ '(p)))
+ (unless client-id
+ (raise-exception
+ (make-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ `(p ,(W_ "The client_id query argument is not set."))))))
+ (unless redirect-uri
+ (raise-exception
+ (make-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ `(p ,(W_ "The redirect_uri query argument is not set."))))))
+ (if (eq? (request-method request) 'POST)
+ (begin
+ (unless (and password (verify-password (encrypted-password endpoint) password))
+ (raise-exception
+ (make-exception
+ (make-web-exception 401 (W_ "reason-phrase|Unauthorized"))
+ (make-user-message
+ `(p ,(W_ "The password is incorrect.")))
+ (make-user-message form))))
+ (let ((code (issue <authorization-code>
+ (read-key-file (key-file endpoint))
+ #:webid (subject endpoint)
+ #:client-id client-id))
+ (mf
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>The client, <a href=~s>~a</a>, cannot be queried.</p>")
+ (uri->string client-id)
+ (uri->string client-id))
+ xml->sxml))
+ exn))
+ (lambda ()
+ (make <client-manifest>
+ #:client-id client-id)))))
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>The real client at <a href=~s>~a</a> does not control the advertised redirection URI.</p>"))
+ xml->sxml))
+ exn))
+ (lambda ()
+ (check-redirect-uri mf redirect-uri)))
+ (values
+ (build-response
+ #:code 302
+ #:reason-phrase (W_ "reason-phrase|Found")
+ #:headers `((location
+ . ,(build-uri 'https
+ #:userinfo (uri-userinfo redirect-uri)
+ #:host (uri-host redirect-uri)
+ #:port (uri-port redirect-uri)
+ #:path (uri-path redirect-uri)
+ #:query
+ (if state
+ (format #f "code=~a&state=~a"
+ (uri-encode code)
+ (uri-encode state))
+ (string-append "code="
+ (uri-encode code)))))
+ (content-type application/xhtml+xml)))
+ (call-with-output-string
+ (cute 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")))
+ (head
+ (title ,(W_ "Redirecting...")))
+ (body
+ (p ,(W_ "You are being redirected.")))))
+ <>))
+ '())))
+ (values
+ (build-response #:headers `((content-type application/xhtml+xml)))
+ (call-with-output-string
+ (cute 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")))
+ (head
+ (title ,(W_ "Authorization...")))
+ (body ,form)))
+ <>))
+ '())))))
+
+(define-method (handle (endpoint <token-endpoint>) request request-body)
+ (unless (match (request-content-type request)
+ ((or 'application/x-www-form-urlencoded
+ ('application/x-www-form-urlencoded _ ...))
+ #t)
+ (else #f))
+ (raise-exception
+ (make-exception
+ (make-web-exception 415 (W_ "reason-phrase|Unsupported Media Type"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>Please use <pre>application/x-www-form-urlencoded</pre>.</p>"))
+ xml->sxml)))))
+ (when (bytevector? request-body)
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>Expected an UTF-8 request body.</p>"))
+ xml->sxml))
+ exn)))
+ (lambda ()
+ (set! request-body (utf8->string request-body)))))
+ (unless (eq? (request-method request) 'POST)
+ (raise-exception
+ (make-exception
+ (make-web-exception 405 (W_ "reason-phrase|Method Not Allowed"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>This is a token endpoint, please use <pre>POST</pre>.</p>"))
+ xml->sxml)))))
+ (let ((form-args (split-args request-body #t))
+ (true-uri
+ (let ((server-uri (issuer endpoint)))
+ (build-uri (uri-scheme server-uri)
+ #:userinfo (uri-userinfo server-uri)
+ #:host (uri-host server-uri)
+ #:port (uri-port server-uri)
+ #:path (uri-path (request-uri request))
+ #:query (uri-query (request-uri request))))))
+ (let ((grant-type (assq-ref form-args 'grant_type))
+ (dpop
+ (let ((proof (assq-ref (request-headers request) 'dpop)))
+ (unless proof
+ (raise-exception
+ (make-exception
+ (make-web-exception 401 (W_ "reason-phrase|Unauthorized"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>No DPoP proof has been found in your request.</p>"))
+ xml->sxml)))))
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-exception
+ (make-web-exception 401 (W_ "reason-phrase|Unauthorized"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>The DPoP proof is invalid.</p>"))
+ xml->sxml)))))
+ (lambda ()
+ (decode <dpop-proof> proof
+ #:method (request-method request)
+ #:uri true-uri
+ #:cnf/check
+ (lambda (jkt) #t)))))))
+ (unless grant-type
+ (raise-exception
+ (make-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>The <pre>grant_type</pre> parameter has not been found.</p>"))
+ xml->sxml)))))
+ (receive (webid client-id)
+ (case (string->symbol grant-type)
+ ((authorization_code)
+ (let ((code
+ (let ((str (assq-ref form-args 'code)))
+ (unless str
+ (raise-exception
+ (make-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>Could not find an authorization code.</p>"))
+ xml->sxml)))))
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>The authorization code is invalid.</p>"))
+ xml->sxml))
+ exn)))
+ (lambda ()
+ (decode <authorization-code> str
+ #:issuer-key (read-key-file (key-file endpoint))))))))
+ (values (webid code) (client-id code))))
+ ((refresh_token)
+ (let ((refresh-token (assq-ref form-args 'refresh_token)))
+ (unless refresh-token
+ (raise-exception
+ (make-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Requeset"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>Could not find a refresh token.</p>"))
+ xml->sxml)))))
+ (with-exception-handler
+ (lambda (exn)
+ (raise-exception
+ (make-exception
+ (make-web-exception 403 (W_ "reason-phrase|Forbidden"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>The refresh token is invalid or has been revoked.</p>"))
+ xml->sxml))
+ exn)))
+ (lambda ()
+ (with-refresh-token refresh-token (jwk dpop) values)))))
+ (else
+ (raise-exception
+ (make-exception
+ (make-web-exception 400 (W_ "reason-phrase|Bad Request"))
+ (make-user-message
+ (call-with-input-string
+ (format #f (W_ "<p>Cannot process your grant type, ~a.</p>")
+ (call-with-output-string
+ (cute sxml->xml `(pre ,grant-type) <>)))
+ xml->sxml))))))
+ ;; So, either from an authorization code or a refresh token, I
+ ;; have a webid and client-id.
+ (receive (id-token access-token refresh-token)
+ (let ((key-file (read-key-file (key-file endpoint))))
+ (let ((id-token
+ (issue <id-token> key-file
+ #:webid webid
+ #:iss (issuer endpoint)
+ #:aud client-id))
+ (access-token
+ (issue <access-token> key-file
+ #:webid webid
+ #:iss (issuer endpoint)
+ #:client-key (jwk dpop)
+ #:client-id client-id))
+ (refresh-token
+ ;; Reuse it if already present
+ (if (equal? grant-type "refresh_token")
+ (assq-ref form-args 'refresh_token)
+ (issue-refresh-token
+ webid client-id (jkt (jwk dpop))))))
+ (values id-token access-token refresh-token)))
+ (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 . ,(p:oidc-token-default-validity))
+ (refresh_token . ,refresh-token)))
+ `((user . ,webid)
+ (client-id . ,client-id))))))))
+
+(define-method (handle (endpoint <jwks-endpoint>) request request-body)
+ (let ((jwks (make <jwks> #:keys (list (read-key-file (key-file endpoint))))))
+ (let* ((current-sec (time-second (date->time-utc ((p:current-date)))))
+ (exp-sec (+ current-sec 3600))
+ (exp (time-utc->date
+ (make-time time-utc 0 exp-sec))))
+ (receive (response response-body)
+ (serve jwks exp)
+ (values response response-body '())))))
+
generated by cgit v1.2.3 (git 2.44.0) at 2024-05-18 10:12:08 +0000