diff options
Diffstat (limited to 'src/scm/webid-oidc/client.scm')
| -rw-r--r-- | src/scm/webid-oidc/client.scm | 551 |
1 files changed, 136 insertions, 415 deletions
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index 67928db..4fdb824 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -24,6 +24,7 @@ #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc config) #:prefix cfg:) + #:use-module ((webid-oidc client accounts) #:prefix client:) #:use-module (web uri) #:use-module (web client) #:use-module (web request) @@ -32,434 +33,154 @@ #:use-module (web http) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (ice-9 i18n) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) - #:use-module (sxml simple)) + #:use-module (ice-9 match) + #:use-module (sxml simple) + #:export + ( + <client> + make-client + client? + client-id + client-key + client-redirect-uri -(define*-public (authorize host-or-webid - #:key - (client-id #f) - (redirect-uri #f) - (state #f) - (http-get http-get)) - (define cannot-be-webid #f) - (define candidate-errors '()) - ;; host-or-webid can be: the host (as a string), an URI (as a string - ;; or an URI). 3 differents things. - (when (string? host-or-webid) - ;; If it’s a string, it can be either a host name or a URI. - (set! host-or-webid - (catch #t - (lambda () - (let ((urified (string->uri host-or-webid))) - (if urified - urified - (error "It’s not a string representing an URI.")))) - (lambda error - (build-uri 'https #:host host-or-webid))))) - ;; client-id and redirect-uri are required, state must be a string. - (when (string? client-id) - (set! client-id (string->uri client-id))) - (when (string? redirect-uri) - (set! redirect-uri (string->uri redirect-uri))) - (let ((host-candidates - (with-exception-handler - (lambda (why-not-webid) - ;; try as an identity provider - (set! cannot-be-webid why-not-webid) - (build-uri 'https - #:userinfo (uri-userinfo host-or-webid) - #:host (uri-host host-or-webid) - #:port (uri-port host-or-webid))) - (lambda () - (get-provider-confirmations host-or-webid #:http-get http-get)) - #:unwind? #t))) - (let ((configurations - (if cannot-be-webid - (with-exception-handler - (lambda (why-not-identity-provider) - (raise-neither-identity-provider-nor-webid - host-or-webid - why-not-identity-provider - cannot-be-webid)) - (lambda () - (cons (uri->string host-candidates) - (get-oidc-configuration (uri-host host-candidates) - #:userinfo (uri-userinfo host-candidates) - #:port (uri-port host-candidates) - #:http-get http-get)))) - (filter - (lambda (cfg) cfg) - (map - (lambda (host) - (with-exception-handler - (lambda (cause) - (set! candidate-errors (acons host cause candidate-errors)) - #f) - (lambda () - (cons (uri->string host) - (get-oidc-configuration (uri-host host) - #:userinfo (uri-userinfo host) - #:port (uri-port host) - #:http-get http-get))) - #:unwind? #t)) - host-candidates))))) - (let ((authorization-endpoints - (if cannot-be-webid - (with-exception-handler - (lambda (why-not-identity-provider) - (raise-neither-identity-provider-nor-webid - host-or-webid - why-not-identity-provider - cannot-be-webid)) - (lambda () - (let ((host (car configurations)) - (cfg (cdr configurations))) - (cons host (oidc-configuration-authorization-endpoint cfg))))) - (map - (lambda (host/cfg) - (let ((host (car host/cfg)) - (cfg (cdr host/cfg))) - (with-exception-handler - (lambda (cause) - (set! candidate-errors (acons (string->uri host) cause - candidate-errors))) - (lambda () - (cons host - (oidc-configuration-authorization-endpoint cfg))) - #:unwind? #t))) - configurations)))) - (if cannot-be-webid - (let ((host (car authorization-endpoints)) - (authz (cdr authorization-endpoints))) - (list - (cons - host - (build-uri (uri-scheme authz) - #:userinfo (uri-userinfo authz) - #:host (uri-host authz) - #:port (uri-port authz) - #:path (uri-path authz) - #:query (format #f "client_id=~a&redirect_uri=~a~a" - (uri-encode (uri->string client-id)) - (uri-encode (uri->string redirect-uri)) - (if state - (format #f "&state=~a" - (uri-encode state)) - "")))))) - (let ((final-candidates - (map - (lambda (host/authorization-endpoint) - (let ((host (car host/authorization-endpoint)) - (authorization-endpoint (cdr host/authorization-endpoint))) - (cons - host - (build-uri (uri-scheme authorization-endpoint) - #:userinfo (uri-userinfo authorization-endpoint) - #:host (uri-host authorization-endpoint) - #:port (uri-port authorization-endpoint) - #:path (uri-path authorization-endpoint) - #:query (format #f "client_id=~a&redirect_uri=~a~a" - (uri-encode (uri->string client-id)) - (uri-encode (uri->string redirect-uri)) - (if state - (format #f "&state=~a" - (uri-encode state)) - "")))))) - authorization-endpoints))) - (when (null? final-candidates) - (raise-no-provider-candidates host-or-webid candidate-errors)) - final-candidates)))))) - -(define*-public (token host client-key - #:key - (authorization-code #f) - (refresh-token #f) - (http-get http-get) - (http-post http-post)) - (unless (or authorization-code refresh-token) - (scm-error 'wrong-type-arg "token" - "You need to either set #:authorization-code or #:refresh-token." - '() - (list authorization-code))) - (let ((token-endpoint - (oidc-configuration-token-endpoint - (get-oidc-configuration host #:http-get http-get))) - (grant-type - (if authorization-code - "authorization_code" - "refresh_token"))) - (let ((dpop-proof - (issue-dpop-proof - client-key - #:alg (case (kty client-key) - ((EC) 'ES256) - ((RSA) 'RS256) - (else - (error "Unknown key type of ~S." client-key))) - #:htm 'POST - #:htu token-endpoint))) - (receive (response response-body) - (http-post token-endpoint - #:body - (string-join - (map - (lambda (arg) - (string-append (uri-encode (car arg)) - "=" - (uri-encode (cdr arg)))) - `(("grant_type" . ,grant-type) - ,@(if authorization-code - `(("code" . ,authorization-code)) - '()) - ,@(if refresh-token - `(("refresh_token" . ,refresh-token)) - '()))) - "&") - #:headers - `((content-type application/x-www-form-urlencoded) - (dpop . ,dpop-proof))) - (with-exception-handler - (lambda (error) - (raise-token-request-failed error)) - (lambda () - (when (bytevector? response-body) - (set! response-body (utf8->string response-body))) - (with-exception-handler - (lambda (error) - (raise-unexpected-response response error)) - (lambda () - (unless (eqv? (response-code response) 200) - (raise-request-failed-unexpectedly - (response-code response) - (response-reason-phrase response))) - (unless (and (response-content-type response) - (eq? (car (response-content-type response 'application/json)))) - (raise-unexpected-header-value 'content-type (response-content-type response))) - (stubs:json-string->scm response-body))))))))) - -(define-public (list-profiles) - (map (lambda (profile) - (list - (string->uri (car profile)) ;; webid - (string->uri (cadr profile)) ;; issuer - (caddr profile) ;; refresh token - (cadddr profile))) ;; key - (catch #t - (lambda () - (call-with-input-file (string-append (p:data-home) "/profiles") - read)) - (lambda error - (format (current-error-port) "Could not read profiles: ~s\n" error) - '())))) - -(define (add-profile webid issuer refresh-token key) - (let ((other-profiles (list-profiles))) - (stubs:atomically-update-file - (string-append (p:data-home) "/profiles") - (string-append (p:data-home) "/profiles.lock") - (lambda (port) - (write - (map (lambda (profile) - (list - (uri->string (car profile)) ;; webid - (uri->string (cadr profile)) ;; issuer - (caddr profile) ;; refresh token - key)) ;; key - (cons `(,webid - ,issuer - ,refresh-token) - other-profiles)) - port))))) - -(define*-public (setup get-host/webid choose-provider browse-authorization-uri - #:key - (client-id #f) - (redirect-uri #f) - (http-get http-get) - (http-post http-post)) - (let ((host/webid (get-host/webid))) - (let ((authorization-uris - (authorize host/webid - #:client-id client-id - #:redirect-uri redirect-uri - #:http-get http-get)) - (key (generate-key #:n-size 2048))) - (let ((provider (choose-provider (map car authorization-uris)))) - (let ((authz-uri (assq-ref authorization-uris provider))) - (let ((authz-code (browse-authorization-uri authz-uri))) - (let ((params - (token host/webid key - #:authorization-code authz-code - #:http-get http-get - #:http-post http-post))) - (let ((id-token (id-token-decode (assq-ref params 'id_token) - #:http-get http-get)) - (access-token (assq-ref params 'access_token)) - (refresh-token (assq-ref params 'refresh_token))) - (when refresh-token - ;; Save it to disk - (add-profile (id-token-webid id-token) - (id-token-iss id-token) - refresh-token - key)) - (values (cdr id-token) access-token key))))))))) - -(define*-public (login webid issuer refresh-token key - #:key - (http-get http-get) - (http-post http-post)) - (when (string? webid) - (set! webid (string->uri webid))) - (when (string? issuer) - (set! issuer (string->uri issuer))) - (let ((iss-host (uri-host issuer))) - (let ((params - (token iss-host key - #:refresh-token refresh-token - #:http-get http-get - #:http-post http-post))) - (let ((id-token (id-token-decode (assq-ref params 'id_token) - #:http-get http-get)) - (access-token (assq-ref params 'access_token)) - (new-refresh-token (assq-ref params 'refresh-token))) - (when (and new-refresh-token - (not (equal? refresh-token new-refresh-token))) - ;; The refresh token has been updated - (add-profile (id-token-webid id-token) - (id-token-iss id-token) - refresh-token - key)) - (values (cdr id-token) access-token key))))) + request -(define*-public (refresh id-token - key - #:key - (http-get http-get) - (http-post http-post)) - (when (id-token-payload? id-token) - ;; For convenience, we’d like a full ID token to use the ID token - ;; API. - (set! id-token (cons `((alg . "HS256")) id-token))) - (let ((profiles (list-profiles))) - (letrec ((find-refresh-token - (lambda (profiles) - (when (null? profiles) - (raise-profile-not-found (id-token-webid id-token) - (id-token-iss id-token) - (p:data-home))) - (let ((prof (car profiles)) - (others (cdr profiles))) - (let ((webid (car prof)) - (issuer (cadr prof)) - (refresh (caddr prof))) - (if (and (equal? webid (id-token-webid id-token)) - (equal? issuer (id-token-iss id-token))) - refresh - (find-refresh-token others))))))) - (login (id-token-webid id-token) - (id-token-iss id-token) - (find-refresh-token (profiles)) - key - #:http-get http-get - #:http-post http-post)))) + serve-application + ) + #:declarative? #t) -(define* (renew-if-expired id-token access-token key - date - #:key - (http-get http-get) - (http-post http-post)) - ;; Since we’re not supposed to decode the access token, we’re - ;; judging from the ID token to know if it has expired. - (when (date? date) - (set! date (date->time-utc date))) - (when (time? date) - (set! date (time-second date))) - (when (id-token-payload? id-token) - ;; See the refresh function - (set! id-token (cons `((alg . "HS256")) id-token))) - (let ((exp (id-token-exp id-token))) - (set! exp (date->time-utc exp)) - (set! exp (time-second exp)) - (if (>= date exp) - (parameterize ((p:current-date (lambda () date))) - (refresh id-token key - #:http-get http-get - #:http-post http-post)) - (values id-token access-token key)))) +(define-record-type <client> + (make-client id key redirect-uri) + client? + (id client-id) + (key client-key) + (redirect-uri client-redirect-uri)) -(define*-public (make-client id-token access-token key - #:key - (http-get http-get) - (http-post http-post) - (http-request http-request)) +;; subject is optional, if you don’t know who the user is. +(define* (request client subject issuer + #:key + (http-request http-request)) ;; HACK: guile does not support other authentication schemes in ;; WWW-Authenticate than Basic, so it will crash when a response ;; containing that header will be issued. - (declare-header! "WWW-Authenticate" string->symbol symbol? write) - (define (handler uri method headers other-args retry?) - (let ((proof (issue-dpop-proof - key - #:alg (case (kty key) - ((EC) 'ES256) - ((RSA) 'RS256) - (else - (error "Unknown key type of ~S." key))) - #:htm method - #:htu uri - #:access-token access-token))) - (receive (response response-body) - (apply http-request uri - #:method method - #:headers (append `((dpop . ,proof) - (Authorization . ,(string-append "DPoP " access-token))) - headers) - other-args) - (let ((server-date (response-date response)) - (code (response-code response))) - (if (and retry? (eqv? code 401)) - ;; Maybe the access token has expired? - (receive (new-id-token new-access-token new-key) - (renew-if-expired id-token access-token key server-date - #:http-get http-get - #:http-post http-post) - (if (equal? access-token new-access-token) - ;; No, it’s just that way. - (values response response-body) - ;; Ah, we have a new access token - (begin - (set! id-token new-id-token) - (set! access-token new-access-token) - (set! key new-key) - (handler uri method headers other-args #f)))) - (values response response-body)))))) - (define (parse-args uri method headers other-args-rev rest) - (if (null? rest) - (handler uri method headers (reverse other-args-rev) #t) - (let ((kw (car rest))) - (case kw - ((#:method) - (if (null? (cdr rest)) - (parse-args uri method headers (cons kw other-args-rev) '()) - (parse-args uri (cadr rest) headers other-args-rev (cddr rest)))) - ((#:headers) - (if (null? (cdr rest)) - (parse-args uri method headers (cons kw other-args-rev) '()) - (parse-args uri method (append headers (cadr rest)) other-args-rev (cddr rest)))) - (else - (parse-args uri method headers (cons kw other-args-rev) '())))))) - (define (parse-http-request-args uri args) - (parse-args uri 'GET '() '() args)) - (lambda (uri . args) - (parse-http-request-args uri args))) + (declare-header! + "WWW-Authenticate" + (cute parse-header 'pragma <>) + (lambda (value) + (and (list? value) + (let check-value ((schemes value)) + (match schemes + (() #t) + (((hd . args) tl ...) + (and (symbol? hd) + (let check-args ((args args)) + (match args + (() #t) + (((key . value) tl ...) + (and (symbol? key) + (string? value) + (check-args tl))))) + (check-value tl))))))) + (cute write-header 'pragma <> <>)) + ;; The same applies for the authorization header. + (let ((original-parser (header-parser 'authorization)) + (original-writer (header-writer 'authorization))) + (declare-header! + "Authorization" + original-parser + (lambda (value) #t) + (match-lambda* + ((('dpop . dpop) port) + (format port "DPoP ~a" dpop)) + ((value port) + (original-writer value port))))) + (match client + (($ <client> client-id client-key redirect-uri) + (let ((do-login + (let ((my-http-get + (lambda* (uri . args) + (apply http-request uri + #:method 'GET + args))) + (my-http-post + (lambda* (uri . args) + (apply http-request uri + #:method 'POST + args)))) + (match-lambda* + ((subject issuer) + (client:save-account + (client:login subject issuer + #:http-get my-http-get + #:http-post my-http-post + #:client-id client-id + #:client-key client-key + #:redirect-uri redirect-uri))) + (($ <account> subject issuer _ _ _ _) + (client:save-account + (client:login subject issuer + #:http-get my-http-get + #:http-post my-http-post + #:client-id client-id + #:client-key client-key + #:redirect-uri redirect-uri))))))) + (let ((current-account (do-login subject issuer))) + (define (handle request request-body) + (receive (response response-body) + (let* ((access-token (client:account-access-token current-account)) + (dpop-proof + (issue-dpop-proof + (client:account-keypair current-account) + #:alg (case (kty client-key) + ((EC) 'ES256) + ((RSA) 'RS256)) + #:htm (request-method request) + #:htu (request-uri request) + #:access-token access-token))) + (let ((headers + `((dpop . ,dpop-proof) + (authorization . (dpop . ,access-token)) + ,@(request-headers request)))) + (http-request + (request-uri request) + #:method (request-method request) + #:headers headers))) + (if (eqv? (response-code response) 401) + ;; Maybe the accesss token expired + (let ((server-date (time-second (date->time-utc (response-date response)))) + (exp (assq-ref (client:account-id-token current-account) 'exp))) + (if (>= server-date exp) + ;; The ID token expired, renew it. + (begin + (set! current-account + (client:save-account + (do-login + (client:save-account + (client:invalidate-access-token current-account))))) + ;; Read it that way: invalidate the current + ;; account access token, then save it so that + ;; noone uses the invalid access token, then + ;; try to log in again, and finally save the + ;; new access token. + (handle request request-body)) + ;; The ID token has not expired, we don’t care. + (values response response-body))) + ;; OK or other error, we don’t care. + (values response response-body)))) + handle))))) -(define*-public (serve-application id redirect-uri - #:key - (client-name "Example application") - (client-uri "https://webid-oidc-demo.planete-kraus.eu")) +(define* (serve-application id redirect-uri + #:key + (client-name "Example application") + (client-uri "https://webid-oidc-demo.planete-kraus.eu")) (when (string? id) (set! id (string->uri id))) (when (string? redirect-uri) |