diff options
Diffstat (limited to 'src/scm')
-rw-r--r-- | src/scm/webid-oidc/Makefile.am | 6 | ||||
-rw-r--r-- | src/scm/webid-oidc/cache.scm | 2 | ||||
-rw-r--r-- | src/scm/webid-oidc/client.scm | 488 | ||||
-rw-r--r-- | src/scm/webid-oidc/errors.scm | 68 |
4 files changed, 559 insertions, 5 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 8f5f105..1f9cb5d 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -22,7 +22,8 @@ dist_webidoidcmod_DATA += \ %reldir%/provider-confirmation.scm \ %reldir%/resource-server.scm \ %reldir%/hello-world.scm \ - %reldir%/reverse-proxy.scm + %reldir%/reverse-proxy.scm \ + %reldir%/client.scm webidoidcgo_DATA += \ %reldir%/errors.go \ @@ -48,6 +49,7 @@ webidoidcgo_DATA += \ %reldir%/provider-confirmation.go \ %reldir%/resource-server.go \ %reldir%/hello-world.go \ - %reldir%/reverse-proxy.go + %reldir%/reverse-proxy.go \ + %reldir%/client.go EXTRA_DIST += %reldir%/ChangeLog diff --git a/src/scm/webid-oidc/cache.scm b/src/scm/webid-oidc/cache.scm index 9d9da0f..9435c10 100644 --- a/src/scm/webid-oidc/cache.scm +++ b/src/scm/webid-oidc/cache.scm @@ -35,7 +35,7 @@ (define (default-cache-dir) (let ((xdg-cache-home (or (getenv "XDG_CACHE_HOME") - (format #f "~a/.cache")))) + (format #f "~a/.cache" (getenv "HOME"))))) (format #f "~a/webid-oidc" xdg-cache-home))) (define (web-cache-dir dir) diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm new file mode 100644 index 0000000..ef0d116 --- /dev/null +++ b/src/scm/webid-oidc/client.scm @@ -0,0 +1,488 @@ +(define-module (webid-oidc client) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc provider-confirmation) + #:use-module (webid-oidc oidc-configuration) + #:use-module (webid-oidc oidc-id-token) + #:use-module (webid-oidc dpop-proof) + #:use-module (webid-oidc jwk) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:use-module (web server) + #:use-module (web http) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-19) + #:use-module (rnrs bytevectors)) + +(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 the-current-time current-time) + +(define*-public (token host client-key + #:key + (authorization-code #f) + (refresh-token #f) + (http-get http-get) + (http-post http-post) + (current-time #f)) + (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))) + (unless current-time + (set! current-time the-current-time)) + (when (thunk? current-time) + (set! current-time (current-time))) + (when (integer? current-time) + (set! current-time (make-time time-utc 0 current-time))) + (when (time? current-time) + (set! current-time (time-utc->date current-time))) + (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 + #:iat current-time))) + (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 (default-dir) + (let ((xdg-data-home + (or + (getenv "XDG_DATA_HOME") + (format #f "~a/.local/share" + (getenv "HOME"))))) + (format #f "~a/webid-oidc" xdg-data-home))) + +(define*-public (list-profiles #:key (dir default-dir)) + (when (thunk? dir) + (set! dir (dir))) + (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 dir "/profiles") + read)) + (lambda error + (format (current-error-port) "Could not read profiles: ~s\n" error) + '())))) + +(define* (add-profile webid issuer refresh-token key + #:key (dir default-dir)) + (when (thunk? dir) + (set! dir (dir))) + (let ((other-profiles (list-profiles #:dir dir))) + (stubs:atomically-update-file + (string-append dir "/profiles") + (string-append dir "/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) + (dir default-dir) + (http-get http-get) + (http-post http-post) + (current-time #f)) + (when (thunk? dir) + (set! dir (dir))) + (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 + #:current-time current-time))) + (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 + #:dir dir)) + (values (cdr id-token) access-token key))))))))) + +(define*-public (login webid issuer refresh-token key + #:key + (dir default-dir) + (http-get http-get) + (http-post http-post) + (current-time #f)) + (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 + #:current-time current-time))) + (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 + #:dir dir)) + (values (cdr id-token) access-token key))))) + +(define*-public (refresh id-token + key + #:key + (dir default-dir) + (http-get http-get) + (http-post http-post) + (current-time #f)) + (when (thunk? dir) + (set! dir (dir))) + (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 #:dir dir))) + (letrec ((find-refresh-token + (lambda (profiles) + (when (null? profiles) + (raise-profile-not-found (id-token-webid id-token) + (id-token-iss id-token) + dir)) + (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 + #:dir dir + #:http-get http-get + #:http-post http-post + #:current-time current-time)))) + +(define* (renew-if-expired id-token access-token key + date + #:key + (dir default-dir) + (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) + (refresh id-token key + #:dir dir + #:http-get http-get + #:http-post http-post + #:current-time date) + (values id-token access-token key)))) + +(define*-public (make-client id-token access-token key + #:key + (dir default-dir) + (http-get http-get) + (http-post http-post) + (http-request http-request) + (current-time the-current-time)) + ;; 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 current-time 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 + #:iat current-time))) + (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 + #:dir dir + #: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 current-time #f)))) + (values response response-body)))))) + (define (parse-args uri method headers other-args-rev rest) + (if (null? rest) + (let ((the-current-time current-time)) + (when (thunk? the-current-time) + (set! the-current-time (the-current-time))) + (when (integer? the-current-time) + (set! the-current-time (make-time time-utc 0 the-current-time))) + (when (time? the-current-time) + (set! the-current-time (time-utc->date the-current-time))) + (handler uri method headers (reverse other-args-rev) the-current-time #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))) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 4a62abb..52f5db8 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -455,9 +455,10 @@ &external-error '(issuer cause))) -(define-public (raise-cannot-fetch-issuer-configuration issuer cause) +(define*-public (raise-cannot-fetch-issuer-configuration issuer cause #:key (recoverable? #f)) (raise-exception - ((record-constructor &cannot-fetch-issuer-configuration) issuer cause))) + ((record-constructor &cannot-fetch-issuer-configuration) issuer cause) + #:continuable? recoverable?)) (define-public &cannot-fetch-jwks (make-exception-type @@ -828,6 +829,47 @@ (raise-exception ((record-constructor &unconfirmed-provider) subject provider))) +(define-public &neither-identity-provider-nor-webid + (make-exception-type + '&neither-identity-provider-nor-webid + &external-error + '(uri why-not-identity-provider why-not-webid))) + +(define-public (raise-neither-identity-provider-nor-webid uri why-not-identity-provider why-not-webid) + (raise-exception + ((record-constructor &neither-identity-provider-nor-webid) + uri why-not-identity-provider why-not-webid))) + +(define-public &token-request-failed + (make-exception-type + '&token-request-failed + &external-error + '(cause))) + +(define-public (raise-token-request-failed cause) + (raise-exception + ((record-constructor &token-request-failed) cause))) + +(define-public &profile-not-found + (make-exception-type + '&profile-not-found + &external-error + '(webid iss dir))) + +(define-public (raise-profile-not-found webid iss dir) + (raise-exception + ((record-constructor &profile-not-found) webid iss dir))) + +(define-public &no-provider-candidates + (make-exception-type + '&no-provider-candidates + &external-error + '(webid causes))) + +(define-public (raise-no-provider-candidates webid causes) + (raise-exception + ((record-constructor &no-provider-candidates) webid causes))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -1151,6 +1193,28 @@ ((&unconfirmed-provider) (format #f (G_ "~s does not admit ~s as an identity provider") (get 'subject) (get 'provider))) + ((&neither-identity-provider-nor-webid) + (format #f (G_ "~a is neither an identity provider (because ~a) nor a webid (because ~a)") + (uri->string (get 'uri)) + (recurse (get 'why-not-identity-provider)) + (recurse (get 'why-not-webid)))) + ((&token-request-failed) + (format #f (G_ "the token request failed (because ~a)") + (recurse (get 'cause)))) + ((&profile-not-found) + (format #f (G_ "you don’t have a refresh token for identity ~a certified by ~a in ~s") + (uri->string (get 'webid)) + (uri->string (get 'iss)) + (get 'dir))) + ((&no-provider-candidates) + (format #f (G_ "all identity provider candidates for ~a failed: ~a") + (uri->string (get 'webid)) + (string-join + (map (lambda (cause) + (format #f (G_ "~s failed (because ~a)") + (uri->string (car cause)) (recurse (cdr cause)))) + (get 'causes)) + (G_ ", ")))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) |