Client: use http-request instead of http-get and http-post

3 files changed, 54 insertions, 45 deletions

diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 1aad35d..461c4a7 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -25,6 +25,7 @@
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
   #:use-module ((webid-oidc client accounts) #:prefix client:)
+  #:use-module ((webid-oidc cache) #:prefix cache:)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (web request)
@@ -104,33 +105,35 @@
        ((value port)
         (original-writer value port))))))
 
+(define* default-http-get-with-cache
+  (cache:with-cache))
+
+(define* (default-http-request uri . all-args)
+  (let try-get-with-cache ((args all-args))
+    (match args
+      ((#:headers _)
+       (apply default-http-get-with-cache all-args))
+      ((#:headers _ other-args ...)
+       (try-get-with-cache other-args))
+      (else
+       (apply http-request all-args)))))
+
 (define* (initial-login client issuer
                         #:key
-                        (http-request http-request))
+                        (http-request default-http-request))
   (setup-headers!)
   (match client
     (($ <client> client-id client-key redirect-uri)
-     (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))))
-       (client:save-account
-        (client:login #f issuer
-                      #:http-get my-http-get
-                      #:http-post my-http-post
-                      #:client-id client-id
-                      #:client-key client-key
-                      #:redirect-uri redirect-uri))))))
+     (client:save-account
+      (client:login #f issuer
+                    #:http-request http-request
+                    #:client-id client-id
+                    #:client-key client-key
+                    #:redirect-uri redirect-uri)))))
 
 (define* (request client subject issuer
                   #:key
-                  (http-request http-request))
+                  (http-request default-http-request))
   (setup-headers!)
   (match client
     (($ <client> client-id client-key redirect-uri)
@@ -149,16 +152,14 @@
                 ((subject issuer)
                  (client:save-account
                   (client:login subject issuer
-                                #:http-get my-http-get
-                                #:http-post my-http-post
+                                #:http-request http-request
                                 #:client-id client-id
                                 #:client-key client-key
                                 #:redirect-uri redirect-uri)))
                 ((($ <client:account> subject issuer _ _ _ _))
                  (client:save-account
                   (client:login subject issuer
-                                #:http-get my-http-get
-                                #:http-post my-http-post
+                                #:http-request http-request
                                 #:client-id client-id
                                 #:client-key client-key
                                 #:redirect-uri redirect-uri)))))))
diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm
index d7219e3..cd69c59 100644
--- a/src/scm/webid-oidc/client/accounts.scm
+++ b/src/scm/webid-oidc/client/accounts.scm
@@ -310,12 +310,15 @@
     (($ <account> subject issuer id-token access-token _ keypair)
      (make-account subject issuer id-token access-token #f keypair))))
 
+(define (http-request->http-get http-request)
+  (lambda* (uri . all-args)
+    (apply http-request uri #:method 'GET all-args)))
+
 ;; subject is optional. If the user is unknown, ask for an issuer and
 ;; pass #f as subject.
 (define* (login subject issuer
                 #:key
-                (http-get http-get)
-                (http-post http-post)
+                (http-request http-request)
                 (state #f)
                 client-id
                 client-key
@@ -337,7 +340,7 @@
                      (uri-host issuer)
                      #:userinfo (uri-userinfo issuer)
                      #:port (uri-port issuer)
-                     #:http-get http-get)))
+                     #:http-get (http-request->http-get http-request))))
                (values 
                 (cfg:oidc-configuration-authorization-endpoint configuration)
                 (cfg:oidc-configuration-token-endpoint configuration)))
@@ -379,23 +382,24 @@
                    #:htu token-endpoint)))
              ;; Post the token request with the correct grant:
              (receive (response response-body)
-                 (http-post token-endpoint
-                            #:body
-                            (string-join
-                             (map
-                              (match-lambda
-                                ((key . value)
-                                 (string-append (uri-encode key)
-                                                "="
-                                                (uri-encode value))))
-                              `(("grant_type" . ,grant-type)
-                                (,(if available-refresh-token
-                                      "refresh_token"
-                                      "code") . ,grant)))
-                             "&")
-                            #:headers
-                            `((content-type application/x-www-form-urlencoded)
-                              (dpop . ,dpop-proof)))
+                 (http-request token-endpoint
+                               #:method 'POST
+                               #:body
+                               (string-join
+                                (map
+                                 (match-lambda
+                                   ((key . value)
+                                    (string-append (uri-encode key)
+                                                   "="
+                                                   (uri-encode value))))
+                                 `(("grant_type" . ,grant-type)
+                                   (,(if available-refresh-token
+                                         "refresh_token"
+                                         "code") . ,grant)))
+                                "&")
+                               #:headers
+                               `((content-type application/x-www-form-urlencoded)
+                                 (dpop . ,dpop-proof)))
                ;; Check that the token endpoint responded correctly.
                (when (eqv? (response-code response) 403)
                  (when subject
@@ -440,7 +444,7 @@
                             'application/json)
                  (let ((final-message
                         (format #f (G_ "The token response has content-type ~s, not application/json.")
-                            (response-content-type response))))
+                                (response-content-type response))))
                    (raise-exception
                     (make-exception
                      (make-token-request-failed response response-body)
@@ -490,7 +494,10 @@
                              (make-exception-with-message final-message)
                              decoding-error))))
                      (lambda ()
-                       (set! id-token (id:id-token-decode id-token #:http-get http-get))))
+                       (set! id-token
+                             (id:id-token-decode id-token
+                                                 #:http-get
+                                                 (http-request->http-get http-request)))))
                    ;; We are not interested in the ID token
                    ;; signature anymore, because it won’t be
                    ;; transmitted to other parties and we know that
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index 2b80bef..6af3665 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -37,6 +37,7 @@
   #:use-module (ice-9 threads)
   #:use-module (ice-9 futures)
   #:use-module (ice-9 textual-ports)
+  #:use-module (ice-9 exceptions)
   #:use-module (srfi srfi-19)
   #:use-module (rnrs bytevectors)
   #:use-module (web uri)