diff options
Diffstat (limited to 'src/scm/webid-oidc/client.scm')
| -rw-r--r-- | src/scm/webid-oidc/client.scm | 110 |
1 files changed, 27 insertions, 83 deletions
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index e8796c0..67928db 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -21,8 +21,8 @@ #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc jwk) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) - #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (web uri) #:use-module (web client) @@ -174,28 +174,17 @@ (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)) + (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))) - (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))) @@ -212,8 +201,7 @@ (else (error "Unknown key type of ~S." client-key))) #:htm 'POST - #:htu token-endpoint - #:iat current-time))) + #:htu token-endpoint))) (receive (response response-body) (http-post token-endpoint #:body @@ -253,17 +241,7 @@ (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/disfluid" xdg-data-home))) - -(define*-public (list-profiles #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define-public (list-profiles) (map (lambda (profile) (list (string->uri (car profile)) ;; webid @@ -272,20 +250,17 @@ (cadddr profile))) ;; key (catch #t (lambda () - (call-with-input-file (string-append dir "/profiles") + (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 - #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) - (let ((other-profiles (list-profiles #:dir dir))) +(define (add-profile webid issuer refresh-token key) + (let ((other-profiles (list-profiles))) (stubs:atomically-update-file - (string-append dir "/profiles") - (string-append dir "/profiles.lock") + (string-append (p:data-home) "/profiles") + (string-append (p:data-home) "/profiles.lock") (lambda (port) (write (map (lambda (profile) @@ -304,12 +279,8 @@ #: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))) + (http-post http-post)) (let ((host/webid (get-host/webid))) (let ((authorization-uris (authorize host/webid @@ -324,8 +295,7 @@ (token host/webid key #:authorization-code authz-code #:http-get http-get - #:http-post http-post - #:current-time current-time))) + #: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)) @@ -335,16 +305,13 @@ (add-profile (id-token-webid id-token) (id-token-iss id-token) refresh-token - key - #:dir dir)) + key)) (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)) + (http-post http-post)) (when (string? webid) (set! webid (string->uri webid))) (when (string? issuer) @@ -354,8 +321,7 @@ (token iss-host key #:refresh-token refresh-token #:http-get http-get - #:http-post http-post - #:current-time current-time))) + #: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)) @@ -366,30 +332,25 @@ (add-profile (id-token-webid id-token) (id-token-iss id-token) refresh-token - key - #:dir dir)) + key)) (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))) + (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 #:dir dir))) + (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) - dir)) + (p:data-home))) (let ((prof (car profiles)) (others (cdr profiles))) (let ((webid (car prof)) @@ -403,15 +364,12 @@ (id-token-iss id-token) (find-refresh-token (profiles)) key - #:dir dir #:http-get http-get - #:http-post http-post - #:current-time current-time)))) + #:http-post http-post)))) (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 @@ -427,25 +385,22 @@ (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) + (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*-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)) + (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 current-time retry?) + (define (handler uri method headers other-args retry?) (let ((proof (issue-dpop-proof key #:alg (case (kty key) @@ -455,7 +410,6 @@ (error "Unknown key type of ~S." key))) #:htm method #:htu uri - #:iat current-time #:access-token access-token))) (receive (response response-body) (apply http-request uri @@ -470,7 +424,6 @@ ;; 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) @@ -481,18 +434,11 @@ (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)))) + (handler uri method headers other-args #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)) + (handler uri method headers (reverse other-args-rev) #t) (let ((kw (car rest))) (case kw ((#:method) @@ -618,5 +564,3 @@ (title "Not Found")) (body (p "This page does not exist on the server.")))))))))))))) - - |