Negociate a token (client)

1 files changed, 488 insertions, 0 deletions

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)))