diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-22 13:11:21 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-22 18:08:47 +0200 |
commit | 555e59deba33284067298ce6130c379c75e3d2a3 (patch) | |
tree | c15c823913e917bc474f1cf163caf65a117ee9c3 /src | |
parent | 0d74f8c1ca9c1e9bf9a04b85f598ba7a175d1d86 (diff) |
Use anonymous-http-request from (webid-oidc parameters) everywhere
Diffstat (limited to 'src')
34 files changed, 483 insertions, 561 deletions
diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm index 0960069..d40e0da 100644 --- a/src/scm/webid-oidc/access-token.scm +++ b/src/scm/webid-oidc/access-token.scm @@ -22,7 +22,6 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (ice-9 optargs) #:use-module (ice-9 match) #:use-module (srfi srfi-19) diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm index 4f171a2..e859d47 100644 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ b/src/scm/webid-oidc/authorization-endpoint.scm @@ -22,7 +22,6 @@ #:use-module (webid-oidc client-manifest) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web request) #:use-module (web response) #:use-module (rnrs bytevectors) @@ -43,9 +42,7 @@ (let ((c (crypt password encrypted-password))) (string=? c encrypted-password))) -(define* (make-authorization-endpoint subject encrypted-password jwk validity - #:key - (http-get http-get)) +(define (make-authorization-endpoint subject encrypted-password jwk) (define (parse-arg x decode-plus-to-space?) (map (lambda (x) (uri-decode x @@ -110,8 +107,7 @@ jwk #:webid subject #:client-id client-id)) - (mf (get-client-manifest client-id - #:http-get http-get))) + (mf (get-client-manifest client-id))) (client-manifest-check-redirect-uri mf redirect-uri) (let ((query (if state @@ -135,4 +131,3 @@ (verify-password encrypted-password password))) client-id uri))))))) - diff --git a/src/scm/webid-oidc/cache.scm b/src/scm/webid-oidc/cache.scm index c9d7b26..4bd3e09 100644 --- a/src/scm/webid-oidc/cache.scm +++ b/src/scm/webid-oidc/cache.scm @@ -18,13 +18,13 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (webid-oidc web-i18n) - #:use-module (web client) #:use-module (web request) #:use-module (web response) #:use-module (web uri) #:use-module (ice-9 ftw) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) + #:use-module (ice-9 match) #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) #:declarative? #t @@ -36,7 +36,7 @@ varies? valid? revalidate - with-cache + use-cache )) ;; The cache follows the recommendations of @@ -216,8 +216,7 @@ (define* (revalidate uri response body #:key - (headers '()) - (http-get http-get)) + (headers '())) (define (keep-header? h) (case (car h) ((if-none-match if-unmodified-since) #f) @@ -225,10 +224,10 @@ (let ((etag (response-etag response))) (if etag (receive (new-response new-response-body) - (http-get uri - #:headers - (acons 'if-none-match (list etag) - (filter keep-header? headers))) + ((p:anonymous-http-request) uri + #:headers + `((if-none-match . (,etag)) + ,@(filter keep-header? headers))) (if (eqv? (response-code new-response) 304) (values (build-response @@ -245,30 +244,49 @@ (response-headers response)))) body) (values new-response new-response-body))) - (http-get uri #:headers headers)))) + ((p:anonymous-http-request) uri #:headers headers)))) -(define* (with-cache #:key (http-get http-get)) +(define (with-cache http-get) (lambda* (uri #:key (headers '())) - (when (string? uri) - (set! uri (string->uri uri))) - (let ((request (build-request uri #:headers headers))) - (receive (stored-request stored-response body) (read uri) - (if stored-response - (let ((valid (valid? stored-response)) - (invariant (not (varies? request stored-request stored-response)))) - (unless invariant - (format (current-error-port) - (G_ "Cache entry for ~a varies.\n") - (uri->string uri))) - (if (and valid invariant) - (values stored-response body) - (receive (final-response final-body) - (revalidate uri stored-response body - #:headers headers - #:http-get http-get) - (add request final-response final-body) - (values final-response final-body)))) - (receive (final-response final-body) - (http-get uri #:headers headers) - (add request final-response final-body) - (values final-response final-body))))))) + (parameterize ((p:anonymous-http-request http-get)) + (when (string? uri) + (set! uri (string->uri uri))) + (let ((request (build-request uri #:headers headers))) + (receive (stored-request stored-response body) (read uri) + (if stored-response + (let ((valid (valid? stored-response)) + (invariant (not (varies? request stored-request stored-response)))) + (unless invariant + (format (current-error-port) + (G_ "Cache entry for ~a varies.\n") + (uri->string uri))) + (if (and valid invariant) + (values stored-response body) + (receive (final-response final-body) + (revalidate uri stored-response body + #:headers headers) + (add request final-response final-body) + (values final-response final-body)))) + (receive (final-response final-body) + (http-get uri #:headers headers) + (add request final-response final-body) + (values final-response final-body)))))))) + +(define (use-cache f) + (let ((http-request (p:anonymous-http-request))) + (let ((http-get-with-cache (with-cache http-request))) + (parameterize + ((p:anonymous-http-request + (lambda* (uri . all-args) + (let try-using-cache ((args all-args) + (headers #f)) + (match args + (() + (http-get-with-cache uri #:headers (or headers '()))) + ((#:method 'GET args ...) + (try-using-cache args headers)) + ((#:headers new-headers args ...) + (try-using-cache args (or headers new-headers))) + (else + (apply http-request uri all-args))))))) + (f))))) diff --git a/src/scm/webid-oidc/catalog.scm b/src/scm/webid-oidc/catalog.scm index dd24ffb..c85510a 100644 --- a/src/scm/webid-oidc/catalog.scm +++ b/src/scm/webid-oidc/catalog.scm @@ -16,10 +16,9 @@ (define-module (webid-oidc catalog) #:use-module (webid-oidc errors) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (ice-9 match) - #:use-module (web client) #:use-module (rnrs bytevectors) #:use-module (sxml simple) #:use-module (sxml match) @@ -27,7 +26,7 @@ #:use-module (ice-9 receive) #:use-module (webid-oidc web-i18n) #:declarative? #t - #:export (resolve-uri)) + #:export (resolve-uri use-catalog)) (define useful-namespaces '((ct . "urn:oasis:names:tc:entity:xmlns:xml:catalog") @@ -231,10 +230,10 @@ match-length next-catalogs-rev))))) -(define* (get-catalog uri #:key (http-get http-get)) +(define (get-catalog uri) (case (uri-scheme uri) ((http https) - (receive (response response-body) (http-get uri) + (receive (response response-body) ((p:anonymous-http-request) uri) (when (bytevector? response-body) (set! response-body (utf8->string response-body))) (xml->sxml response-body #:namespaces useful-namespaces))) @@ -246,7 +245,7 @@ (error (format #f (G_ "Unsupported delegate catalog URI scheme: ~s\n") (uri-scheme uri)))))) -(define* (resolve-uri uri #:key (http-get http-get)) +(define (resolve-uri uri) (when (string? uri) (set! uri (string->uri uri))) (let do-examine ((uris @@ -259,10 +258,17 @@ (match uris (() uri) ((catalog-uri uris ...) - (let ((catalog (get-catalog catalog-uri - #:http-get http-get))) + (let ((catalog (get-catalog catalog-uri))) (receive (candidate match-length next-uris) (resolve-uri-in-catalog uri catalog-uri catalog uris) (if (null? next-uris) candidate (do-examine next-uris)))))))) + +(define (use-catalog f) + (let ((http-request (p:anonymous-http-request))) + (parameterize ((p:anonymous-http-request + (lambda* (uri . all-args) + (parameterize ((p:anonymous-http-request http-request)) + (apply http-request (resolve-uri uri) all-args))))) + (f)))) diff --git a/src/scm/webid-oidc/client-manifest.scm b/src/scm/webid-oidc/client-manifest.scm index 847fc54..7ea4931 100644 --- a/src/scm/webid-oidc/client-manifest.scm +++ b/src/scm/webid-oidc/client-manifest.scm @@ -19,8 +19,8 @@ #:use-module (webid-oidc fetch) #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-19) @@ -230,9 +230,7 @@ approved.</p>")) (expires . ,expiration-date))) json-object))) -(define* (get-client-manifest id - #:key - (http-get http-get)) +(define* (get-client-manifest id) (unless (uri? id) (set! id (string->uri id))) (with-exception-handler @@ -255,7 +253,7 @@ approved.</p>")) "http://www.w3.org/ns/solid/terms#PublicOidcClient")) public-oidc-client (receive (response response-body) - (http-get id) + ((p:anonymous-http-request) id) (when (bytevector? response-body) (set! response-body (utf8->string response-body))) (let ((mf (the-client-manifest (stubs:json-string->scm response-body)))) diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index 2c16fb1..7eb8fe3 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -27,7 +27,6 @@ #:use-module ((webid-oidc client accounts) #:prefix account:) #:use-module ((webid-oidc client client) #:prefix client:) #:use-module (web uri) - #:use-module (web client) #:use-module (web request) #:use-module (web response) #:use-module (web server) @@ -54,7 +53,6 @@ (client:client . client) (account:authorization-process . authorization-process) (account:authorization-state . authorization-state) - (account:anonymous-http-request . anonymous-http-request) (client:->sexp . ->sexp) ) @@ -106,25 +104,9 @@ ((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 default-http-request)) +(define* (initial-login client issuer) (setup-headers!) - (parameterize ((account:anonymous-http-request default-http-request) - (client:client client)) + (parameterize ((client:client client)) (make <account:account> #:issuer issuer))) @@ -147,7 +129,7 @@ (authorization . (dpop . ,access-token)) ,@headers))) (receive (response body) - (apply (account:anonymous-http-request) uri + (apply (p:anonymous-http-request) uri #:headers all-headers non-header-args) (let ((code (response-code response))) diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index 7e14000..31d105d 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -37,14 +37,9 @@ #:use-module ((webid-oidc client client) #:prefix client:) #:use-module (web uri) #:use-module (web response) - #:use-module (web client) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t - #:re-export - ( - (p:anonymous-http-request . anonymous-http-request) - ) #:export ( <account> @@ -132,13 +127,6 @@ (define authorization-state (make-parameter #f)) -(define (http-request->http-get http-request) - (lambda* (uri . all-args) - (apply http-request uri #:method 'GET all-args))) - -(define (http-get-implementation) - (http-request->http-get (p:anonymous-http-request))) - (define-class <account> () (subject #:init-keyword #:subject #:getter subject) (issuer #:init-keyword #:issuer #:getter issuer) @@ -371,8 +359,7 @@ decoding-error)))) (lambda () (set! id-token - (decode <id:id-token> id-token - #:http-request (p:anonymous-http-request))))) + (decode <id:id-token> id-token)))) ;; 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/client/application.scm b/src/scm/webid-oidc/client/application.scm index 5839195..d448976 100644 --- a/src/scm/webid-oidc/client/application.scm +++ b/src/scm/webid-oidc/client/application.scm @@ -39,7 +39,6 @@ #:use-module (webid-oidc web-i18n) #:use-module (web uri) #:use-module (web response) - #:use-module (web client) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t @@ -155,21 +154,6 @@ ((hd tl ...) (apply-finished-jobs (hd state) tl))))))) -(define http-request-with-cache - (let ((default-http-get-with-cache (cache:with-cache))) - (lambda* (uri . all-args) - (let try-get-with-cache ((args all-args) - (args-for-get '())) - (match args - (() - (apply default-http-get-with-cache uri (reverse args-for-get))) - ((#:headers arg other-args ...) - (try-get-with-cache other-args `(,arg #:headers ,@args-for-get))) - ((#:method 'GET other-args ...) - (try-get-with-cache other-args args-for-get)) - (else - (apply http-request uri all-args))))))) - (define-method (add-job (state <application-state>) (description <string>) f) (let ((job (make <job> #:description description))) (call-with-new-thread @@ -197,25 +181,26 @@ (slot-set! ret 'authorization-prompts `((,uri . ,continue) ,@(authorization-prompts previous-state))) - ret)))))) - (account:anonymous-http-request http-request-with-cache)) - (with-exception-handler - (lambda (exn) - (let ((msg (if (exception-with-message? exn) - (exception-message exn) - (format #f "~s" exn)))) - (abort-to-prompt - tag - (lambda (_) - ;; We won’t continue, but we will show the error message - (lambda (previous-state) - (let ((ret (shallow-clone previous-state))) - (slot-set! ret 'error-messages - `(,msg ,@(error-messages previous-state))) - ret)))))) - (lambda () - (let ((updater (f))) - (atomic-box-set! (result-box job) updater)))))) + ret))))))) + (cache:use-cache + (lambda () + (with-exception-handler + (lambda (exn) + (let ((msg (if (exception-with-message? exn) + (exception-message exn) + (format #f "~s" exn)))) + (abort-to-prompt + tag + (lambda (_) + ;; We won’t continue, but we will show the error message + (lambda (previous-state) + (let ((ret (shallow-clone previous-state))) + (slot-set! ret 'error-messages + `(,msg ,@(error-messages previous-state))) + ret)))))) + (lambda () + (let ((updater (f))) + (atomic-box-set! (result-box job) updater)))))))) (lambda (continuation get-updater) (atomic-box-set! (result-box job) (get-updater continuation))))))) (let ((ret (shallow-clone state))) diff --git a/src/scm/webid-oidc/client/client.scm b/src/scm/webid-oidc/client/client.scm index 01f8da1..3d02630 100644 --- a/src/scm/webid-oidc/client/client.scm +++ b/src/scm/webid-oidc/client/client.scm @@ -26,7 +26,6 @@ #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module ((webid-oidc client accounts) #:prefix client:) #:use-module (web uri) - #:use-module (web client) #:use-module (web request) #:use-module (web response) #:use-module (web server) diff --git a/src/scm/webid-oidc/client/gui.scm b/src/scm/webid-oidc/client/gui.scm index c0d0767..97e9d0e 100644 --- a/src/scm/webid-oidc/client/gui.scm +++ b/src/scm/webid-oidc/client/gui.scm @@ -36,7 +36,6 @@ #:use-module ((webid-oidc client client) #:prefix client:) #:use-module (web uri) #:use-module (web response) - #:use-module (web client) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm index 318ebb8..c492436 100644 --- a/src/scm/webid-oidc/dpop-proof.scm +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -136,7 +136,7 @@ (ath #:init-keyword #:ath #:accessor ath)) (define-method (default-validity (proof <dpop-proof>)) - 30) + (p:dpop-proof-validity)) (define-method (has-explicit-exp? (proof <dpop-proof>)) #f) @@ -158,6 +158,12 @@ error))) (lambda () (next-method) + ;; Override the validity + (slot-set! token 'exp + (let ((iat (time-second (date->time-utc (iat token))))) + (time-utc->date + (make-time time-utc 0 + (+ iat (p:dpop-proof-validity)))))) (let-keywords initargs #t ((typ "dpop+jwt") diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 4e24659..aabb6ea 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -22,7 +22,6 @@ #:use-module (srfi srfi-19) #:use-module (web uri) #:use-module (web response) - #:use-module (web client) #:declarative? #t #:export ( diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm index 67d959f..fb12431 100644 --- a/src/scm/webid-oidc/example-app.scm +++ b/src/scm/webid-oidc/example-app.scm @@ -23,7 +23,6 @@ #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (web uri) - #:use-module (web client) #:use-module (web request) #:use-module (web response) #:use-module (web server) @@ -301,23 +300,11 @@ (uri->string uri)) (format (current-error-port) (G_ "Then, paste the authorization code you get:\n")) (read-line (current-input-port) 'trim))) - (client:authorization-state #f) - (client:anonymous-http-request - (let ((default-http-get-with-cache (cache:with-cache))) - (lambda* (uri . all-args) - (let try-get-with-cache ((args all-args) - (args-for-get '())) - (match args - (() - (apply default-http-get-with-cache uri (reverse args-for-get))) - ((#:headers arg other-args ...) - (try-get-with-cache other-args `(,arg #:headers ,@args-for-get))) - ((#:method 'GET other-args ...) - (try-get-with-cache other-args args-for-get)) - (else - (apply http-request uri all-args)))))))) - (let menu ((state (make <undoable-app-state>))) - (format #t (G_ "Account: ~a + (client:authorization-state #f)) + (cache:use-cache + (lambda () + (let menu ((state (make <undoable-app-state>))) + (format #t (G_ "Account: ~a URI: ~a Method: ~a Headers: ~a @@ -333,138 +320,138 @@ Available commands: - ~a: perform the request. ") - (let ((acct (app-state-account (current-state state)))) - (if acct - (account-summary acct) - (G_ "Account:|unset"))) - (let ((uri (app-state-uri (current-state state)))) - (if uri - (uri->string uri) - (G_ "URI:|unset"))) - (let ((method (app-state-method (current-state state)))) - (if method - (symbol->string method) - (G_ "Method:|unset"))) - (let ((headers (app-state-headers (current-state state)))) - (if (null? headers) - (G_ "Headers:|none") - (string-join - (map (match-lambda ((header . _) (symbol->string header))) - headers) - (G_ "list separator|, ")))) - add-account-command - choose-account-command - set-uri-command - set-method-command - view-headers-command - clear-headers-command - add-header-command - ok-command) - (when (can-undo? state) - (format #t (G_ "You can undo your last command with \"~a\".\n") undo-command)) - (when (can-redo? state) - (format #t (G_ "You can re-apply your last undone command with \"~a\".\n") redo-command)) - (let ((command (readline (G_ "Readline prompt|Command: ")))) - (if (eof-object? command) - (exit 0) - (with-exception-handler - (lambda (exn) - (if (exception-with-message? exn) - (begin - (format #t (G_ "An error happened: ~a.\n") - (exception-message exn)) - (menu state)) - (raise-exception exn))) - (lambda () - (cond - ((equal? command add-account-command) - (let ((identity-provider - (with-sigint-handler - (lambda () - (menu state)) - (lambda () - (readline (G_ "Please enter your identity provider: ")))))) - (menu (add-account state (make <account:account> #:issuer identity-provider))))) - ((equal? command choose-account-command) - (let ((accounts (enumerate-accounts state))) - (if (null? accounts) - (begin - (format #t (G_ "You don’t have other accounts available. Please add one with \"add-account\".\n")) - (menu state)) - (begin - (let enumerate-accounts ((accounts accounts)) - (match accounts - (((i . account) rest ...) - (format #t (G_ "- ~a: ~a\n") i (account-summary account)) - (enumerate-accounts rest)) - (() #t))) - (with-sigint-handler - (lambda () + (let ((acct (app-state-account (current-state state)))) + (if acct + (account-summary acct) + (G_ "Account:|unset"))) + (let ((uri (app-state-uri (current-state state)))) + (if uri + (uri->string uri) + (G_ "URI:|unset"))) + (let ((method (app-state-method (current-state state)))) + (if method + (symbol->string method) + (G_ "Method:|unset"))) + (let ((headers (app-state-headers (current-state state)))) + (if (null? headers) + (G_ "Headers:|none") + (string-join + (map (match-lambda ((header . _) (symbol->string header))) + headers) + (G_ "list separator|, ")))) + add-account-command + choose-account-command + set-uri-command + set-method-command + view-headers-command + clear-headers-command + add-header-command + ok-command) + (when (can-undo? state) + (format #t (G_ "You can undo your last command with \"~a\".\n") undo-command)) + (when (can-redo? state) + (format #t (G_ "You can re-apply your last undone command with \"~a\".\n") redo-command)) + (let ((command (readline (G_ "Readline prompt|Command: ")))) + (if (eof-object? command) + (exit 0) + (with-exception-handler + (lambda (exn) + (if (exception-with-message? exn) + (begin + (format #t (G_ "An error happened: ~a.\n") + (exception-message exn)) + (menu state)) + (raise-exception exn))) + (lambda () + (cond + ((equal? command add-account-command) + (let ((identity-provider + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (readline (G_ "Please enter your identity provider: ")))))) + (menu (add-account state (make <account:account> #:issuer identity-provider))))) + ((equal? command choose-account-command) + (let ((accounts (enumerate-accounts state))) + (if (null? accounts) + (begin + (format #t (G_ "You don’t have other accounts available. Please add one with \"add-account\".\n")) (menu state)) - (lambda () - (let ((choice (string->number - (readline (format #f (G_ "[1-~a] ") - (length accounts)))))) - (menu (choose-account state choice))))))))) - ((equal? command set-uri-command) - (with-sigint-handler - (lambda () - (menu state)) - (lambda () - (menu (set-uri state (readline (G_ "Visit this URI: "))))))) - ((equal? command set-method-command) - (with-sigint-handler - (lambda () - (menu state)) - (lambda () - (let ((method (readline (G_ "Use this HTTP method [GET]: ")))) - (when (equal? method "") - (set! method "GET")) - (menu (set-method state method)))))) - ((equal? command view-headers-command) - (write-headers (app-state-headers (current-state state)) - (current-output-port)) - (newline) - (menu state)) - ((equal? command clear-headers-command) - (menu (clear-headers state))) - ((equal? command add-header-command) - (with-sigint-handler - (lambda () + (begin + (let enumerate-accounts ((accounts accounts)) + (match accounts + (((i . account) rest ...) + (format #t (G_ "- ~a: ~a\n") i (account-summary account)) + (enumerate-accounts rest)) + (() #t))) + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (let ((choice (string->number + (readline (format #f (G_ "[1-~a] ") + (length accounts)))))) + (menu (choose-account state choice))))))))) + ((equal? command set-uri-command) + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (menu (set-uri state (readline (G_ "Visit this URI: "))))))) + ((equal? command set-method-command) + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (let ((method (readline (G_ "Use this HTTP method [GET]: ")))) + (when (equal? method "") + (set! method "GET")) + (menu (set-method state method)))))) + ((equal? command view-headers-command) + (write-headers (app-state-headers (current-state state)) + (current-output-port)) + (newline) (menu state)) - (lambda () - (let ((header (string-downcase (readline (G_ "Which header? "))))) - (let ((value - (readline - (format #f (G_ "Which header value for ~a? ") - header)))) - (menu (add-header state header value))))))) - ((equal? command ok-command) - (receive (account uri) - (let ((state (current-state state))) - (values - (app-state-account state) - (app-state-uri state))) - (if (and account uri) - (receive (account response body) - (client:request (app-state-account (current-state state)) - (app-state-uri (current-state state)) - #:method (app-state-method (current-state state)) - #:headers (app-state-headers (current-state state))) - (let ((ready-to-write-body - (write-response response (current-output-port)))) - (unless (response-must-not-include-body? ready-to-write-body) - (write-response-body ready-to-write-body - (if (string? body) - (string->utf8 body) - body))) - (newline))) - (format #t (G_ "Please define an account and the URI.\n"))) - (menu state))) - ((equal? command undo-command) - (menu (undo state))) - ((equal? command redo-command) - (menu (redo state))) - (else - (format #t (G_ "I don’t know that command.\n")) - (menu state)))))))))) + ((equal? command clear-headers-command) + (menu (clear-headers state))) + ((equal? command add-header-command) + (with-sigint-handler + (lambda () + (menu state)) + (lambda () + (let ((header (string-downcase (readline (G_ "Which header? "))))) + (let ((value + (readline + (format #f (G_ "Which header value for ~a? ") + header)))) + (menu (add-header state header value))))))) + ((equal? command ok-command) + (receive (account uri) + (let ((state (current-state state))) + (values + (app-state-account state) + (app-state-uri state))) + (if (and account uri) + (receive (account response body) + (client:request (app-state-account (current-state state)) + (app-state-uri (current-state state)) + #:method (app-state-method (current-state state)) + #:headers (app-state-headers (current-state state))) + (let ((ready-to-write-body + (write-response response (current-output-port)))) + (unless (response-must-not-include-body? ready-to-write-body) + (write-response-body ready-to-write-body + (if (string? body) + (string->utf8 body) + body))) + (newline))) + (format #t (G_ "Please define an account and the URI.\n"))) + (menu state))) + ((equal? command undo-command) + (menu (undo state))) + ((equal? command redo-command) + (menu (redo state))) + (else + (format #t (G_ "I don’t know that command.\n")) + (menu state)))))))))))) diff --git a/src/scm/webid-oidc/fetch.scm b/src/scm/webid-oidc/fetch.scm index aed4512..e18cc60 100644 --- a/src/scm/webid-oidc/fetch.scm +++ b/src/scm/webid-oidc/fetch.scm @@ -16,12 +16,12 @@ (define-module (webid-oidc fetch) #:use-module (webid-oidc web-i18n) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:use-module (rnrs bytevectors) - #:use-module (web client) #:use-module (web request) #:use-module (web response) #:use-module (web uri) @@ -49,7 +49,7 @@ cannot-fetch-linked-data? (uri cannot-fetch-linked-data-uri)) -(define* (fetch uri #:key (http-get http-get)) +(define (fetch uri) (unless (uri? uri) (set! uri (string->uri uri))) (with-exception-handler @@ -68,8 +68,8 @@ error)))) (lambda () (receive (response response-body) - (http-get uri - #:headers `((accept (text/turtle application/n-quads application/ld+json)))) + ((p:anonymous-http-request) uri + #:headers `((accept (text/turtle application/n-quads application/ld+json)))) (with-exception-handler (lambda (error) (let ((final-message diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index 46de33c..de56228 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -27,7 +27,6 @@ #:use-module (web request) #:use-module (web response) #:use-module (web uri) - #:use-module (web client) #:use-module (web server) #:use-module (webid-oidc cache) #:use-module (ice-9 optargs) @@ -62,9 +61,7 @@ encrypted-password jwks-uri authorization-endpoint-uri - token-endpoint-uri - #:key - (http-get http-get)) + token-endpoint-uri) (let ((key (catch #t (lambda () @@ -82,10 +79,9 @@ (stubs:scm->json (key->jwk k) port #:pretty #t))) k))))) (let ((authorization-endpoint - (make-authorization-endpoint subject encrypted-password key 120 - #:http-get http-get)) + (make-authorization-endpoint subject encrypted-password key)) (token-endpoint - (make-token-endpoint token-endpoint-uri issuer key 3600)) + (make-token-endpoint token-endpoint-uri issuer key)) (openid-configuration (make <oidc-configuration> #:jwks-uri jwks-uri diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm index f1078aa..9dae649 100644 --- a/src/scm/webid-oidc/jwk.scm +++ b/src/scm/webid-oidc/jwk.scm @@ -16,6 +16,7 @@ (define-module (webid-oidc jwk) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (webid-oidc errors) #:use-module (webid-oidc web-i18n) #:use-module (ice-9 receive) @@ -25,7 +26,6 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-19) #:use-module (web response) - #:use-module (web client) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:use-module (sxml match) @@ -495,8 +495,8 @@ . ,(list->vector (map key->jwk (keys jwks)))))))) -(define* (get-jwks uri #:key (http-request http-request)) - (receive (response response-body) (http-request uri) +(define (get-jwks uri) + (receive (response response-body) ((p:anonymous-http-request) uri) (with-exception-handler (lambda (error) (raise-exception diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm index bfb941f..e0eba54 100644 --- a/src/scm/webid-oidc/jws.scm +++ b/src/scm/webid-oidc/jws.scm @@ -225,7 +225,7 @@ (define-method (default-validity (token <oidc-token>)) (let ((next (next-method)) - (mine 3600)) + (mine (p:oidc-token-default-validity))) (if (and next (< next mine)) next mine))) @@ -264,7 +264,7 @@ (define-method (default-validity (token <single-use-token>)) (let ((next (next-method)) - (mine 120)) + (mine (p:authorization-code-default-validity))) (if (and next (< next mine)) next mine))) @@ -470,43 +470,37 @@ #:neutral (list '()))) (define-method (lookup-keys (token <oidc-token>) args) - (let-keywords - args #f - ((http-request (p:anonymous-http-request))) - (let ((iss (iss token))) - (let ((cfg - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "I cannot query the identity provider configuration: ~a") - (exception-message error)) - (format #f (G_ "I cannot query the identity provider configuration"))))) - (raise-exception - (make-exception - (make-cannot-query-identity-provider iss) - (make-exception-with-message final-message) - error)))) - (lambda () - (make <oidc-configuration> - #:server iss - #:http-request http-request))))) - (with-exception-handler - (lambda (error) - (raise-exception - (make-exception - (make-cannot-query-identity-provider iss) - (make-exception-with-message - (if (exception-with-message? error) - (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a") - (exception-message error)) - (format #f (G_ "I cannot query the JWKS URI of the identity provider"))))))) - (lambda () - (append - (keys (next-method)) - (keys - (parameterize ((p:anonymous-http-request http-request)) - (jwks cfg)))))))))) + (let ((iss (iss token))) + (let ((cfg + (with-exception-handler + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "I cannot query the identity provider configuration: ~a") + (exception-message error)) + (format #f (G_ "I cannot query the identity provider configuration"))))) + (raise-exception + (make-exception + (make-cannot-query-identity-provider iss) + (make-exception-with-message final-message) + error)))) + (lambda () + (make <oidc-configuration> + #:server iss))))) + (with-exception-handler + (lambda (error) + (raise-exception + (make-exception + (make-cannot-query-identity-provider iss) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a") + (exception-message error)) + (format #f (G_ "I cannot query the JWKS URI of the identity provider"))))))) + (lambda () + (append + (keys (next-method)) + (keys (jwks cfg)))))))) (define verify (make <generic-with-default> diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm index 0a776d1..d0d1e20 100644 --- a/src/scm/webid-oidc/oidc-configuration.scm +++ b/src/scm/webid-oidc/oidc-configuration.scm @@ -21,7 +21,6 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-19) @@ -67,8 +66,7 @@ (token-endpoint #f) (solid-oidc-supported "https://solidproject.org/TR/solid-oidc") (json-data #f) - (server #f) - (http-request (p:anonymous-http-request))) + (server #f)) (let do-initialize ((jwks-uri jwks-uri) (authorization-endpoint authorization-endpoint) (token-endpoint token-endpoint) @@ -150,7 +148,7 @@ #:host (uri-host server) #:port (uri-port server) #:path "/.well-known/openid-configuration"))) - (receive (response response-body) (http-request discovery-uri) + (receive (response response-body) ((p:anonymous-http-request) discovery-uri) (with-exception-handler (lambda (error) (raise-exception @@ -184,7 +182,7 @@ (make-exception (make-invalid-oidc-configuratin) (make-exception-with-message - (G_ "when making an OIDC configuration, either its required #:jwks-uri, #:authorization-endpoint and #:token-endpoint fields or #:server (and optionally #:http-request) or #:json-data should be passed"))))))))) + (G_ "when making an OIDC configuration, either its required #:jwks-uri, #:authorization-endpoint and #:token-endpoint fields or #:server or #:json-data should be passed"))))))))) (define-method (->json-data (cfg <oidc-configuration>)) `((jwks_uri . ,(uri->string (jwks-uri cfg))) @@ -198,4 +196,4 @@ (stubs:scm->json-string (->json-data cfg)))) (define-method (jwks (cfg <oidc-configuration>)) - (get-jwks (jwks-uri cfg) #:http-request (p:anonymous-http-request))) + (get-jwks (jwks-uri cfg))) diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm index a33351b..19e22d7 100644 --- a/src/scm/webid-oidc/oidc-id-token.scm +++ b/src/scm/webid-oidc/oidc-id-token.scm @@ -23,7 +23,6 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (ice-9 optargs) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) diff --git a/src/scm/webid-oidc/parameters.scm b/src/scm/webid-oidc/parameters.scm index 7d10798..df879ef 100644 --- a/src/scm/webid-oidc/parameters.scm +++ b/src/scm/webid-oidc/parameters.scm @@ -17,7 +17,16 @@ (define-module (webid-oidc parameters) #:use-module (srfi srfi-19) #:use-module (web client) - #:export (data-home cache-home current-date anonymous-http-request) + #:export + ( + data-home + cache-home + current-date + authorization-code-default-validity + oidc-token-default-validity + dpop-proof-validity + anonymous-http-request + ) #:declarative? #t) (define data-home @@ -52,3 +61,12 @@ (define anonymous-http-request (make-parameter http-request)) + +(define authorization-code-default-validity + (make-parameter 120)) + +(define oidc-token-default-validity + (make-parameter 3600)) + +(define dpop-proof-validity + (make-parameter 30)) diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index 760734e..00c929a 100644 --- a/src/scm/webid-oidc/program.scm +++ b/src/scm/webid-oidc/program.scm @@ -43,48 +43,52 @@ #:use-module (web uri) #:use-module (web request) #:use-module (web response) - #:use-module (web client) #:use-module (webid-oidc cache) #:use-module (web server)) (define logging-mutex (make-mutex)) -(define* (http-get-with-log uri #:key (headers '())) - (define date (date->string (time-utc->date (current-time)))) - (define uri-string (if (uri? uri) (uri->string uri) uri)) - (with-mutex logging-mutex - (when (getenv "XML_CATALOG_FILES") - (format (current-error-port) (G_ "~a: Warning: XML_CATALOG_FILES is set to ~s.\n") - date - (getenv "XML_CATALOG_FILES"))) - (format (current-error-port) (G_ "~a: GET ~a ~s...\n") - date uri-string headers)) - (set! uri (resolve-uri uri - #:http-get - (lambda* (uri . args) - (with-mutex logging-mutex - (format (current-error-port) - (G_ "~a: Warning: loading XML catalog from the web, ~s.\n") - date - (uri->string uri))) - (apply http-get uri args)))) - (receive (response response-body) - (in-another-thread - (http-get uri #:headers headers)) - (with-mutex logging-mutex - (format (current-error-port) (G_ "~a: GET ~a ~s: ~s ~a bytes\n") - date uri-string headers response - (cond - ((bytevector? response-body) - (bytevector-length response-body)) - ((string? response-body) - (string-length response-body)) - (else 0)))) - (values response response-body))) +(define (use-logging-request f) + (let ((backend (p:anonymous-http-request))) + (parameterize + ((p:anonymous-http-request + (lambda* (uri . all-args) + (define date (date->string (time-utc->date (current-time)))) + (define uri-string (if (uri? uri) (uri->string uri) uri)) + (let-keywords + all-args #t + ((headers '()) + (method 'GET)) + (with-mutex logging-mutex + (when (getenv "XML_CATALOG_FILES") + (format (current-error-port) (G_ "~a: Warning: XML_CATALOG_FILES is set to ~s.\n") + date + (getenv "XML_CATALOG_FILES"))) + (format (current-error-port) (G_ "~a: ~s ~a ~s...\n") + date method uri-string headers)) + (receive (response response-body) + (in-another-thread + (apply backend uri all-args)) + (with-mutex logging-mutex + (format (current-error-port) (G_ "~a: ~s ~a ~s: ~s ~a bytes\n") + date method uri-string headers response + (cond + ((bytevector? response-body) + (bytevector-length response-body)) + ((string? response-body) + (string-length response-body)) + (else 0)))) + (values response response-body)))))) + (f)))) -(define cache-http-get - (with-cache - #:http-get http-get-with-log)) +(define (setup-http-request f) + (use-cache + (lambda () + (use-catalog + (lambda () + (use-logging-request + (lambda () + (f)))))))) (define (request-ip-address request) ;; The IP address of the remote end @@ -216,7 +220,7 @@ (serve-one-client* handler implementation server state) (lp)))) -(define-public (main) +(define (inner-main) (setvbuf (current-output-port) 'none) (setvbuf (current-error-port) 'none) (setlocale LC_ALL "") @@ -724,7 +728,6 @@ Rreleased ~a\n") complete-corresponding-source (make-reverse-proxy #:server-uri server-name - #:http-get cache-http-get #:endpoint backend-uri #:auth-header header)) 'http @@ -762,8 +765,7 @@ Rreleased ~a\n") (let ((handler (make-identity-provider server-name key-file subject encrypted-password jwks-uri - authorization-endpoint-uri token-endpoint-uri - #:http-get cache-http-get))) + authorization-endpoint-uri token-endpoint-uri))) (run-server* (handler-with-log (option-ref options log-file-sym #f) @@ -844,14 +846,11 @@ Rreleased ~a\n") (let ((value (assq-ref (request-headers request) header))) (and value (string->uri value))))) (make-authenticator - #:server-uri server-name - #:http-get cache-http-get)) - #:http-get cache-http-get)) + #:server-uri server-name)))) (identity-provider-handler (make-identity-provider server-name key-file subject encrypted-password jwks-uri - authorization-endpoint-uri token-endpoint-uri - #:http-get cache-http-get))) + authorization-endpoint-uri token-endpoint-uri))) (create-root server-name subject) (run-server* (handler-with-log @@ -872,3 +871,6 @@ Rreleased ~a\n") (format (current-error-port) (G_ "Unknown command ~s\n") command) (exit 1)))))))))) + +(define-public (main) + (setup-http-request inner-main)) diff --git a/src/scm/webid-oidc/provider-confirmation.scm b/src/scm/webid-oidc/provider-confirmation.scm index c0d7ea8..e46663e 100644 --- a/src/scm/webid-oidc/provider-confirmation.scm +++ b/src/scm/webid-oidc/provider-confirmation.scm @@ -17,8 +17,8 @@ (define-module (webid-oidc provider-confirmation) #:use-module (webid-oidc errors) #:use-module (webid-oidc fetch) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-19) @@ -81,9 +81,7 @@ (expires . ,expiration-date))) resource))) -(define* (get-provider-confirmations subject - #:key - (http-get http-get)) +(define (get-provider-confirmations subject) (unless (equal? (uri-scheme subject) 'https) (set! subject (build-uri 'https #:userinfo (uri-userinfo subject) @@ -92,19 +90,16 @@ #:path (uri-path subject) #:query (uri-query subject) #:fragment (uri-fragment subject)))) - (let ((graph (fetch subject #:http-get http-get))) + (let ((graph (fetch subject))) (cons (build-uri 'https #:userinfo (uri-userinfo subject) #:host (uri-host subject) #:port (uri-port subject)) (find-confirmations (uri->string subject) graph)))) -(define* (confirm-provider subject issuer - #:key (http-get http-get)) +(define (confirm-provider subject issuer) (unless (string=? (uri-host subject) (uri-host issuer)) - (let search ((providers (get-provider-confirmations - subject - #:http-get http-get))) + (let search ((providers (get-provider-confirmations subject))) (match providers (() (let ((final-message diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index bae9db9..50e5b64 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -36,7 +36,6 @@ #:use-module (web response) #:use-module (web uri) #:use-module (web server) - #:use-module (web client) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (webid-oidc web-i18n) @@ -54,9 +53,7 @@ make-resource-server )) -(define* (make-authenticator #:key - (server-uri #f) - (http-get http-get)) +(define* (make-authenticator #:key (server-uri #f)) (unless (and server-uri (uri? server-uri)) (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))) (lambda (request request-body) @@ -106,18 +103,7 @@ (('dpop . (? string? string-value)) string-value))) (access-token - (decode <access-token> lit-access-token - #:http-request - (lambda* (uri . args) - (let without-method ((remaining-args args) - (kept-args '())) - (match remaining-args - (() (apply http-get uri (reverse kept-args))) - ((#:method 'GET remaining-args ...) - (without-method remaining-args kept-args)) - (((? keyword? key) value remaining-args ...) - (without-method remaining-args - `(,value ,key ,@kept-args)))))))) + (decode <access-token> lit-access-token)) (cnf/jkt (cnf/jkt access-token)) (dpop-proof (decode <dpop-proof> dpop @@ -127,7 +113,7 @@ #:access-token lit-access-token))) (let ((subject (webid access-token)) (issuer (iss access-token))) - (confirm-provider subject issuer #:http-get http-get) + (confirm-provider subject issuer) subject))) #:unwind? #t))))))) @@ -196,16 +182,14 @@ #:key (server-uri #f) (owner #f) - (authenticator #f) - (http-get http-get)) + (authenticator #f)) (unless owner (fail (G_ "The owner is not defined."))) (declare-link-header!) (unless authenticator (set! authenticator (make-authenticator - #:server-uri server-uri - #:http-get http-get))) + #:server-uri server-uri))) (lambda (request request-body) (parameterize ((p:current-date ((p:current-date))) ;; Fix the date (web-locale request)) @@ -217,8 +201,7 @@ ((GET HEAD OPTIONS) (receive (headers content) (ldp:read server-uri owner user - (uri-path (request-uri request)) - #:http-get http-get) + (uri-path (request-uri request))) (let ((true-content-type (car (assq-ref headers 'content-type))) (other-headers @@ -255,8 +238,7 @@ (request-if-match request) (request-if-none-match request) content-type - content - #:http-get http-get) + content) . #f)))) "" user))) @@ -278,16 +260,14 @@ types (assq-ref (request-headers request) 'slug) content-type - content - #:http-get http-get)))) + content)))) "" user)))) ((DELETE) (ldp:delete server-uri owner user (uri-path (request-uri request)) (request-if-match request) - (request-if-none-match request) - #:http-get http-get) + (request-if-none-match request)) (return (build-response) "" diff --git a/src/scm/webid-oidc/reverse-proxy.scm b/src/scm/webid-oidc/reverse-proxy.scm index 30e6d48..ee4878e 100644 --- a/src/scm/webid-oidc/reverse-proxy.scm +++ b/src/scm/webid-oidc/reverse-proxy.scm @@ -28,9 +28,9 @@ #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) #:use-module (web uri) + #:use-module (web client) ;; required to pass the request along #:use-module (web request) #:use-module (web response) - #:use-module (web client) #:use-module (webid-oidc cache) #:use-module (webid-oidc web-i18n) #:use-module (web server) @@ -43,7 +43,6 @@ (define* (make-reverse-proxy #:key (server-uri #f) - (http-get http-get) (endpoint #f) (auth-header 'XXX-Agent)) (set! auth-header @@ -54,8 +53,7 @@ (symbol->string auth-header)))) (define authenticate (make-authenticator - #:server-uri server-uri - #:http-get http-get)) + #:server-uri server-uri)) (unless (and endpoint (uri? endpoint)) (fail (G_ "#:endpoint argument is not present or not an URI."))) (lambda (request request-body) diff --git a/src/scm/webid-oidc/serve.scm b/src/scm/webid-oidc/serve.scm index 66a156c..76c58fc 100644 --- a/src/scm/webid-oidc/serve.scm +++ b/src/scm/webid-oidc/serve.scm @@ -18,11 +18,11 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc fetch) #:use-module (webid-oidc web-i18n) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (ice-9 exceptions) #:use-module (rnrs bytevectors) - #:use-module (web client) #:use-module (web request) #:use-module (web response) #:use-module (web uri) @@ -57,17 +57,18 @@ (define (convert client-accepts server-name path content-type content) (let ((data-as-rdf (false-if-exception - (fetch - (build-uri (uri-scheme server-name) - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path) - #:http-get - (lambda args - (values (build-response - #:headers `((content-type ,content-type))) - content)))))) + (parameterize + ((p:anonymous-http-request + (lambda _ + (values (build-response + #:headers `((content-type ,content-type))) + content)))) + (fetch + (build-uri (uri-scheme server-name) + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path)))))) (if client-accepts ;; Content negociation is asked (let try-satisfy ((accepts client-accepts)) diff --git a/src/scm/webid-oidc/server/create.scm b/src/scm/webid-oidc/server/create.scm index dc9651e..0558ff3 100644 --- a/src/scm/webid-oidc/server/create.scm +++ b/src/scm/webid-oidc/server/create.scm @@ -27,8 +27,8 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web response) #:use-module (rdf rdf) #:use-module (turtle tordf) @@ -88,13 +88,14 @@ (make-exception (make-unsupported-media-type content-type) (make-exception-with-message final-message)))))) - (let ((graph (fetch - doc-uri - #:http-get - (lambda (uri . args) - (values - (build-response #:headers `((content-type ,content-type))) - content))))) + (let ((graph + (parameterize + ((p:anonymous-http-request + (lambda* (uri . args) + (values + (build-response #:headers `((content-type ,content-type))) + content)))) + (fetch doc-uri)))) (with-index graph (lambda (rdf-match) @@ -117,10 +118,8 @@ (or (equal? next "http://www.w3.org/ns/ldp#BasicContainer") (types-indicate-container? (cdr types)))))) -(define* (create server-name owner user container types slug content-type content - #:key - (http-get http-get)) - (check-acl-can-append server-name container owner user #:http-get http-get) +(define* (create server-name owner user container types slug content-type content) + (check-acl-can-append server-name container owner user) (unless (and slug (not (equal? slug ""))) (set! slug (stubs:random 12))) (when (string-contains slug "/") @@ -171,8 +170,7 @@ (lambda error (create server-name owner user container types (string-append slug "-" (stubs:random 12)) - content-type content - #:http-get http-get)))))))) + content-type content)))))))) (define (create-root server-name owner) (define (fix-angle-aux accu chars) diff --git a/src/scm/webid-oidc/server/delete.scm b/src/scm/webid-oidc/server/delete.scm index 4e4ce66..02344ad 100644 --- a/src/scm/webid-oidc/server/delete.scm +++ b/src/scm/webid-oidc/server/delete.scm @@ -26,8 +26,8 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web response) #:use-module (rdf rdf) #:use-module (turtle tordf) @@ -51,9 +51,7 @@ )) -(define* (delete server-name owner user path if-match if-none-match - #:key - (http-get http-get)) +(define* (delete server-name owner user path if-match if-none-match) (check-acl-can-write server-name path owner user) (with-session (lambda (load-content-type load-contained load-static-content diff --git a/src/scm/webid-oidc/server/precondition.scm b/src/scm/webid-oidc/server/precondition.scm index 03ee967..7e3a4bb 100644 --- a/src/scm/webid-oidc/server/precondition.scm +++ b/src/scm/webid-oidc/server/precondition.scm @@ -25,8 +25,8 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web response) #:use-module (rdf rdf) #:use-module (turtle tordf) diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm index cc74898..0cd49fd 100644 --- a/src/scm/webid-oidc/server/read.scm +++ b/src/scm/webid-oidc/server/read.scm @@ -26,8 +26,8 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web response) #:use-module (rdf rdf) #:use-module (turtle tordf) @@ -63,14 +63,12 @@ (base-path auxiliary-resource-absent-base-path) (path-type auxiliary-resource-absent-path-type)) -(define* (read server-name owner user path - #:key - (http-get http-get)) +(define* (read server-name owner user path) (declare-link-header!) (with-session (lambda (load-content-type load-contained load-static-content do-create do-delete) - (check-acl-can-read server-name path owner user #:http-get http-get) + (check-acl-can-read server-name path owner user) (receive (base-path path-type) (base-path path) (let ((container? (container-path? path)) @@ -183,19 +181,20 @@ ;; Content (if container? (let ((static-graph - (fetch - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path) - #:http-get - (lambda (uri . args) - (values - (build-response - #:headers `((content-type ,(load-content-type relevant-etag)))) - (load-static-content relevant-etag)))))) + (parameterize + ((p:anonymous-http-request + (lambda (uri . args) + (values + (build-response + #:headers `((content-type ,(load-content-type relevant-etag)))) + (load-static-content relevant-etag))))) + (fetch + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path))))) (let ((final-graph (reverse (append diff --git a/src/scm/webid-oidc/server/resource/wac.scm b/src/scm/webid-oidc/server/resource/wac.scm index e3ed089..d3f4adf 100644 --- a/src/scm/webid-oidc/server/resource/wac.scm +++ b/src/scm/webid-oidc/server/resource/wac.scm @@ -23,9 +23,9 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (webid-oidc web-i18n) #:use-module (web uri) - #:use-module (web client) #:use-module (rdf rdf) #:use-module (turtle tordf) #:use-module (rnrs bytevectors) @@ -82,7 +82,7 @@ (owner forbidden-owner) (expected-mode forbidden-expected-mode)) -(define (group-member? http-get group-uri agent) +(define (group-member? group-uri agent) (when (string? group-uri) (set! group-uri (string->uri group-uri))) (when (string? agent) @@ -111,7 +111,7 @@ #:continuable? #t)) #f) (lambda () - (let ((data (fetch group-doc-uri #:http-get http-get))) + (let ((data (fetch group-doc-uri))) (with-index data (lambda (rdf-match) @@ -137,7 +137,7 @@ #:path (string-append path ".acl")))))) f)) -(define (check-authorization path check-default? server-name final-path http-get user rdf-match id) +(define (check-authorization path check-default? server-name final-path user rdf-match id) ;; The authorization should give accessTo path, ;; or to a prefix of final-path; and it should ;; be for agent user, or a group that contains @@ -211,7 +211,7 @@ (and user (not (null? (filter (lambda (group) - (group-member? http-get group user)) + (group-member? group user)) groups)))))))) (or (and access-to-ok @@ -227,23 +227,21 @@ #f)))) '()))) -(define (check-authorizations path check-default? server-name final-path http-get user rdf-match +(define (check-authorizations path check-default? server-name final-path user rdf-match allowed-modes authorizations) (if (null? authorizations) (reverse allowed-modes) (let ((new-modes - (check-authorization path check-default? server-name final-path http-get user rdf-match + (check-authorization path check-default? server-name final-path user rdf-match (car authorizations)))) (check-authorizations - path check-default? server-name final-path http-get user rdf-match + path check-default? server-name final-path user rdf-match (append (reverse new-modes) allowed-modes) (cdr authorizations))))) (define acl-aux (string->uri "http://www.w3.org/ns/auth/acl#accessControl")) -(define* (wac-get-modes server-name final-path user - #:key - (http-get http-get)) +(define (wac-get-modes server-name final-path user) (with-session (lambda (content-type contained static-content create delete) (define (wac-check-recursive path check-default?) @@ -263,7 +261,7 @@ server-name path (content-type acl-etag) (static-content acl-etag) (lambda (rdf-match) (check-authorizations - path check-default? server-name final-path http-get user rdf-match + path check-default? server-name final-path user rdf-match '() (map rdf-triple-subject (rdf-match #f @@ -300,7 +298,7 @@ (? uri? (= uri->string b))) (string< a b))))))))) -(define (check-mode server-name path owner user http-get expected-mode) +(define (check-mode server-name path owner user expected-mode) (unless (equal? owner user) (receive (base-path type) (base-path path) @@ -313,7 +311,7 @@ ;; for Control over the base resource. (set! path base-path) (set! expected-mode (string->uri "http://www.w3.org/ns/auth/acl#Control")))) - (let ((modes (wac-get-modes server-name path user #:http-get http-get))) + (let ((modes (wac-get-modes server-name path user))) (define (check-modes modes) (if (null? modes) (let ((final-message @@ -337,26 +335,18 @@ (check-modes (cdr modes))))) (check-modes modes)))) -(define* (check-acl-can-read server-name path owner user - #:key - (http-get http-get)) - (check-mode server-name path owner user http-get +(define (check-acl-can-read server-name path owner user) + (check-mode server-name path owner user (string->uri "http://www.w3.org/ns/auth/acl#Read"))) -(define* (check-acl-can-write server-name path owner user - #:key - (http-get http-get)) - (check-mode server-name path owner user http-get +(define (check-acl-can-write server-name path owner user) + (check-mode server-name path owner user (string->uri "http://www.w3.org/ns/auth/acl#Write"))) -(define* (check-acl-can-append server-name path owner user - #:key - (http-get http-get)) - (check-mode server-name path owner user http-get +(define (check-acl-can-append server-name path owner user) + (check-mode server-name path owner user (string->uri "http://www.w3.org/ns/auth/acl#Append"))) -(define* (check-acl-can-control server-name path owner user - #:key - (http-get http-get)) - (check-mode server-name path owner user http-get +(define (check-acl-can-control server-name path owner user) + (check-mode server-name path owner user (string->uri "http://www.w3.org/ns/auth/acl#Control"))) diff --git a/src/scm/webid-oidc/server/update.scm b/src/scm/webid-oidc/server/update.scm index 589de44..d568d06 100644 --- a/src/scm/webid-oidc/server/update.scm +++ b/src/scm/webid-oidc/server/update.scm @@ -27,8 +27,8 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) - #:use-module (web client) #:use-module (web response) #:use-module (rdf rdf) #:use-module (turtle tordf) @@ -60,13 +60,14 @@ (raise-exception (make-exception (make-unsupported-media-type content-type))))) - (let ((graph (fetch - doc-uri - #:http-get - (lambda (uri . args) - (values - (build-response #:headers `((content-type ,content-type))) - content))))) + (let ((graph + (parameterize + ((p:anonymous-http-request + (lambda (uri . args) + (values + (build-response #:headers `((content-type ,content-type))) + content)))) + (fetch doc-uri)))) (with-index graph (lambda (rdf-match) @@ -90,9 +91,7 @@ (rdf->turtle final-graph)))))))))) (define* (update server-name owner user path if-match if-none-match - content-type content - #:key - (http-get http-get)) + content-type content) (define updated-etag #f) (with-session (lambda (load-content-type load-contained load-static-content diff --git a/src/scm/webid-oidc/simulation.scm b/src/scm/webid-oidc/simulation.scm index 30f7b43..0accdc4 100644 --- a/src/scm/webid-oidc/simulation.scm +++ b/src/scm/webid-oidc/simulation.scm @@ -153,17 +153,11 @@ (crypt "password" "xxx") (with-path server-uri "/keys") (with-path server-uri "/authorize") - (with-path server-uri "/token") - #:http-get - (lambda* (uri . args) - (apply request simulation uri #:method 'GET args)))) + (with-path server-uri "/token"))) (server (make-resource-server #:server-uri server-uri - #:owner owner - #:http-get - (lambda* (uri . args) - (apply request simulation uri #:method 'GET args))))) + #:owner owner))) (define (handle request body) (let ((path (uri-path (request-uri request)))) (if (member path diff --git a/src/scm/webid-oidc/testing.scm b/src/scm/webid-oidc/testing.scm index 06d0127..c26ab5e 100644 --- a/src/scm/webid-oidc/testing.scm +++ b/src/scm/webid-oidc/testing.scm @@ -28,7 +28,13 @@ (define-public (with-test-environment test-name f) (parameterize ((data-home (format #f "tests/~a.home/disfluid" test-name)) - (cache-home (format #f "tests/~a.cache/disfluid" test-name))) + (cache-home (format #f "tests/~a.cache/disfluid" test-name)) + (anonymous-http-request + (lambda _ + (error "cannot request the world-wide web from within a test"))) + (current-date + (lambda () + (error "cannot use the current date from within a test")))) (call-with-output-file* (format #f "~a/seed" (cache-home)) (lambda (port) diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm index 292df4d..a10c843 100644 --- a/src/scm/webid-oidc/token-endpoint.scm +++ b/src/scm/webid-oidc/token-endpoint.scm @@ -26,7 +26,6 @@ #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) - #:use-module (web client) #:use-module (web request) #:use-module (web response) #:use-module (web uri) @@ -179,7 +178,7 @@ port))))))) thunk)))) -(define (make-token-endpoint token-endpoint-uri iss issuer-key validity) +(define (make-token-endpoint token-endpoint-uri iss issuer-key) (lambda (request request-body) (when (bytevector? request-body) (set! request-body (utf8->string request-body))) @@ -295,35 +294,33 @@ (make-unsupported-grant-type grant-type) (make-exception-with-message final-message) (make-message-for-the-user final-user-message)))))) - (let* ((iat (time-second (date->time-utc current-time))) - (exp (+ iat validity))) - (let ((id-token - (issue <id-token> - issuer-key - #:webid webid - #:iss iss - #:aud client-id)) - (access-token - (issue <access-token> - issuer-key - #:webid webid - #:iss iss - #:client-key (jwk dpop) - #:client-id client-id)) - (refresh-token - (if (equal? grant-type "refresh_token") - (assoc-ref form-args "refresh_token") - (refresh:issue-refresh-token webid client-id - (jkt (jwk dpop)))))) - (values - (build-response #:headers '((content-type application/json) - (cache-control (no-cache no-store))) - #:port #f) - (stubs:scm->json-string - `((id_token . ,id-token) - (access_token . ,access-token) - (token_type . "DPoP") - (expires_in . ,validity) - (refresh_token . ,refresh-token))) - client-id - #f))))))))))) + (let ((id-token + (issue <id-token> + issuer-key + #:webid webid + #:iss iss + #:aud client-id)) + (access-token + (issue <access-token> + issuer-key + #:webid webid + #:iss iss + #:client-key (jwk dpop) + #:client-id client-id)) + (refresh-token + (if (equal? grant-type "refresh_token") + (assoc-ref form-args "refresh_token") + (refresh:issue-refresh-token webid client-id + (jkt (jwk dpop)))))) + (values + (build-response #:headers '((content-type application/json) + (cache-control (no-cache no-store))) + #:port #f) + (stubs:scm->json-string + `((id_token . ,id-token) + (access_token . ,access-token) + (token_type . "DPoP") + (expires_in . ,(p:oidc-token-default-validity)) + (refresh_token . ,refresh-token))) + client-id + #f)))))))))) |