diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-09 23:25:58 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-13 20:30:18 +0200 |
commit | 6a83b79c4de5986ad61a552c2612b7cce0105cda (patch) | |
tree | 8704d7b7bf2af24fab416a45ca8567148a558d05 /src | |
parent | 9b6c36923f3ac4a2bd8f2a70ca679bc7374aef56 (diff) |
Client: use http-request instead of http-get and http-post
Diffstat (limited to 'src')
-rw-r--r-- | src/scm/webid-oidc/client.scm | 47 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/accounts.scm | 51 | ||||
-rw-r--r-- | src/scm/webid-oidc/program.scm | 1 |
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) |