diff options
| author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-01 14:51:28 +0200 |
|---|---|---|
| committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-01 18:08:56 +0200 |
| commit | bae1843f1a1d644fb3bd4f8c40b1dbb900aa3325 (patch) | |
| tree | 00f590033af904a6a493e41bdebe9b3ddd73043b | |
| parent | d8c2ca930673da858d63f2dea9526c259a2dd936 (diff) | |
Use guile parameters
With parameters, the API does not need to care about the directory
where to load files and how to get the time.
46 files changed, 1468 insertions, 1557 deletions
diff --git a/doc/disfluid.texi b/doc/disfluid.texi index d2558b4..d18c8e9 100644 --- a/doc/disfluid.texi +++ b/doc/disfluid.texi @@ -323,8 +323,9 @@ implementation of @code{http-get} from @emph{(web client)}. Return Encode @var{token} and sign it with the issuer’s @var{key}. @end deffn -@deffn function issue-id-token @var{issuer-key} @var{#alg} @var{#webid} @var{#iss} @var{#sub} @var{#aud} @var{#exp} @var{#iat} -Create an ID token, and encode it with @var{issuer-key}. +@deffn function issue-id-token @var{issuer-key} @var{#:alg} @var{#:webid} @var{#:iss} @var{#:sub} @var{#:aud} @var{#:validity} +Create an ID token that is valid for @var{#:validity} seconds, and +encode it with @var{issuer-key}. @end deffn @node The access token @@ -372,11 +373,12 @@ decoded token otherwise. Encode @var{token} and sign it with the issuer’s @var{key}. @end deffn -@deffn function issue-access-token @var{issuer-key} @var{#alg} @var{#webid} @var{#iss} @var{#exp} @var{#iat} @var{[#client-key} @var{|} @var{#cnf/jkt]} @var{#client-id} -Create an access token, and encode it with @var{issuer-key}. You can -either set the @code{#:cnf/jkt} keyword argument with the fingerprint -of the client key, or set @code{#:client-key} directly, in which case -the fingerprint will be computed for you. +@deffn function issue-access-token @var{issuer-key} @var{#alg} @var{#webid} @var{#iss} @var{#:validity} @var{[#client-key} @var{|} @var{#cnf/jkt]} @var{#client-id} +Create an access token for @var{#:validity} seconds, and encode it +with @var{issuer-key}. You can either set the @code{#:cnf/jkt} keyword +argument with the fingerprint of the client key, or set +@code{#:client-key} directly, in which case the fingerprint will be +computed for you. @end deffn @node The DPoP proof @@ -401,12 +403,9 @@ the proof is not checked by this function. Get the corresponding field of the proof. @end deffn -@deffn function dpop-proof-decode @var{current-time} @var{jti-list} @var{method} @var{uri} @var{str} @var{cnf/check} @var{[#:access-token]} +@deffn function dpop-proof-decode @var{method} @var{uri} @var{str} @var{cnf/check} @var{[#:access-token]} Check and decode a DPoP proof encoded as @var{str}. -The @var{current-time} is passed as a date, time or number (of -seconds). - In order to prevent replay attacks, each proof has a unique random string that is remembered in @var{jti-list} until its expiration date is reached. See the @code{make-jti-list} function. @@ -424,9 +423,26 @@ uses except requesting an access token or a refresh token), it must be bound to an @var{access-token}. @end deffn -@deffn function make-jti-list -This function in @emph{(webid-oidc jti-list)} creates an in-memory, -async-safe, thread-safe cache for the proof IDs. +The DPoP proof algorithm is sensitive to the current time, because the +proofs have a limited time validity. By default, the time is the +system time when the proof is decoded. + +@deffn parameter current-date +This parameter overrides the current time. + +It is a thunk returning a date, so you need to put two parenthesis to +get the time. However, you can set it to a date, a time, a number of +seconds, or a thunk returning any of these. + +@example + (use-module ((webid-oidc parameters) #:prefix p:)) + ;; This is the current date: + ((p:current-date)) + ;; You can override it with a thunk, or a fixed date: + (parameterize ((p:current-date 0)) + ;; Jan 1st 1970 + ((p:current-date))) +@end example @end deffn @deffn function dpop-proof-encode @var{proof} @var{key} @@ -435,13 +451,16 @@ Encode the proof and sign it with @var{key}. To generate valid proofs, field of the proof. @end deffn -@deffn function issue-dpop-proof @var{client-key} @var{#alg} @var{#htm} @var{#htu} @var{#iat} {[#:@var{access-token}=#f]} +@deffn function issue-dpop-proof @var{client-key} @var{#alg} @var{#htm} @var{#htu} {[#:@var{access-token}=#f]} Create a proof, sign it and encode it with @var{client-key}. @var{client-key} should contain both the private and public key, because the public part is written in the proof and the private part is used to sign it. For most uses, the DPoP proof should be encoded for a specific access token. Only token requests should omit the @samp{access-token} field. + +The @samp{iat} field of the DPoP proof is read from the +@var{current-date} parameter. @end deffn @node Generic JWTs @@ -492,25 +511,28 @@ line will indicate which items are dropped. The @emph{(webid-oidc cache)} module exports two functions to deal with the cache. -@deffn function clean-cache @var{[#percents]} @var{[#dir]} -Drop @var{percents}% of the cache right now, in @var{dir} (defaults to -some place within @emph{XDG_CACHE_HOME}). +@deffn function clean-cache @var{[#percents]} +Drop @var{percents}% of the cache right now. @end deffn -@deffn function with-cache @var{[#current-time]} @var{[#http-get]} @var{[#dir]} +@deffn function with-cache @var{[#http-get]} Return a function acting as @emph{http-get} from @emph{(web client)} (takes an URI as the first parameter, and an optional @var{#:headers} set, and returns 2 values, the response and its body). -The cache will be read and written in @var{dir} (defaults to some -place within @emph{XDG_CACHE_HOME}), and the @var{current-time} number -of seconds, SRFI-19 time or date, or time-returning thunk will be used -to check for the validity of responses. +The cache will be read and written in the @samp{web-cache} +subdirectory of the cache home. To check the time window validity, the +@var{current-date} parameter is used. The back-end function, @var{http-get}, defaults to that of @emph{(web client)}. @end deffn +@deffn parameter cache-home +This parameters sets the cache directory. By default, it is +@emph{XDG_CACHE_HOME}. +@end deffn + @node Content negociation @chapter Content negociation There are a number of different available syntaxes for RDF, some being @@ -682,7 +704,7 @@ copy for both. The @emph{content} API is contained in the @code{(webid-oidc server resource content)} module. -@deffn function with-session @var{f} [@var{#:dir}] +@deffn function with-session @var{f} Call @var{f} with 5 arguments: @itemize @item @@ -711,8 +733,13 @@ The first 3 functions as well as the last one are called with an etag, and the function to create a content is called with the content-type, list of contained paths, and (static) content. -By default, the contents are stored within @var{XDG_DATA_HOME}, but it -can be overriden by @var{#:dir}. +The contents are searched in the @emph{server/content} subdirectory of +@var{data-home}. +@end deffn + +@deffn parameter data-home +Defines the directory where to store persistent data. Defaults to +@emph{XDG_DATA_HOME}. @end deffn The @emph{path} API is defined in diff --git a/po/disfluid.pot b/po/disfluid.pot index 01c4198..41a72c0 100644 --- a/po/disfluid.pot +++ b/po/disfluid.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: disfluid SNAPSHOT\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-07-30 21:12+0200\n" +"POT-Creation-Date: 2021-08-01 15:25+0000\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" "Language-Team: LANGUAGE <LL@li.org>\n" @@ -822,7 +822,7 @@ msgstr "" msgid "Unhandled exception type ~a." msgstr "" -#: src/scm/webid-oidc/identity-provider.scm:70 +#: src/scm/webid-oidc/identity-provider.scm:68 msgid "Warning: generating a new key pair." msgstr "" @@ -958,26 +958,26 @@ msgid "" "permissions." msgstr "" -#: src/scm/webid-oidc/resource-server.scm:92 +#: src/scm/webid-oidc/resource-server.scm:85 #, scheme-format msgid "~a: authentication failure: ~a\n" msgstr "" -#: src/scm/webid-oidc/resource-server.scm:275 +#: src/scm/webid-oidc/resource-server.scm:267 #, scheme-format msgid "Warning: ~a\n" msgstr "" #: src/scm/webid-oidc/hello-world.scm:48 src/scm/webid-oidc/example-app.scm:116 -#: src/scm/webid-oidc/program.scm:218 +#: src/scm/webid-oidc/program.scm:233 msgid "command-line|version" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:50 src/scm/webid-oidc/program.scm:222 +#: src/scm/webid-oidc/hello-world.scm:50 src/scm/webid-oidc/program.scm:237 msgid "command-line|complete-corresponding-source" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:52 src/scm/webid-oidc/program.scm:224 +#: src/scm/webid-oidc/hello-world.scm:52 src/scm/webid-oidc/program.scm:239 msgid "command-line|help" msgstr "" @@ -985,11 +985,11 @@ msgstr "" msgid "command-line|port" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:56 src/scm/webid-oidc/program.scm:256 +#: src/scm/webid-oidc/hello-world.scm:56 src/scm/webid-oidc/program.scm:271 msgid "command-line|log-file" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:58 src/scm/webid-oidc/program.scm:258 +#: src/scm/webid-oidc/hello-world.scm:58 src/scm/webid-oidc/program.scm:273 msgid "command-line|error-file" msgstr "" @@ -1028,7 +1028,7 @@ msgstr "" msgid "~a version ~a\n" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:112 src/scm/webid-oidc/program.scm:617 +#: src/scm/webid-oidc/hello-world.scm:112 src/scm/webid-oidc/program.scm:632 msgid "" "You are legally required to link to the complete corresponding source code.\n" msgstr "" @@ -1147,114 +1147,114 @@ msgstr "" msgid "There was an error: ~a\n" msgstr "" -#: src/scm/webid-oidc/program.scm:112 +#: src/scm/webid-oidc/program.scm:125 #, scheme-format msgid "~a: ~a: Internal server error: ~a\n" msgstr "" -#: src/scm/webid-oidc/program.scm:126 +#: src/scm/webid-oidc/program.scm:140 #, scheme-format msgid "" "The client locale ~s can’t be approximated by system locale ~s (because ~a), " "using C.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:150 +#: src/scm/webid-oidc/program.scm:164 #, scheme-format msgid "~a: ~s ~a ~s ~a\n" msgstr "" -#: src/scm/webid-oidc/program.scm:152 +#: src/scm/webid-oidc/program.scm:166 #, scheme-format msgid "~a: ~a (~a)" msgstr "" -#: src/scm/webid-oidc/program.scm:156 +#: src/scm/webid-oidc/program.scm:170 #, scheme-format msgid "~a: ~a" msgstr "" -#: src/scm/webid-oidc/program.scm:166 +#: src/scm/webid-oidc/program.scm:180 #, scheme-format msgid "(there was an error: ~a)" msgstr "" -#: src/scm/webid-oidc/program.scm:220 +#: src/scm/webid-oidc/program.scm:235 msgid "command-line|describe-project" msgstr "" -#: src/scm/webid-oidc/program.scm:226 +#: src/scm/webid-oidc/program.scm:241 msgid "command-line|server|port" msgstr "" -#: src/scm/webid-oidc/program.scm:228 +#: src/scm/webid-oidc/program.scm:243 msgid "command-line|server|server-name" msgstr "" -#: src/scm/webid-oidc/program.scm:230 +#: src/scm/webid-oidc/program.scm:245 msgid "command-line|server|reverse-proxy|backend-uri" msgstr "" -#: src/scm/webid-oidc/program.scm:232 +#: src/scm/webid-oidc/program.scm:247 msgid "command-line|server|reverse-proxy|header" msgstr "" -#: src/scm/webid-oidc/program.scm:234 +#: src/scm/webid-oidc/program.scm:249 msgid "command-line|server|issuer|key-file" msgstr "" -#: src/scm/webid-oidc/program.scm:236 +#: src/scm/webid-oidc/program.scm:251 msgid "command-line|server|issuer|subject" msgstr "" -#: src/scm/webid-oidc/program.scm:238 +#: src/scm/webid-oidc/program.scm:253 msgid "command-line|server|issuer|encrypted-password" msgstr "" -#: src/scm/webid-oidc/program.scm:240 +#: src/scm/webid-oidc/program.scm:255 msgid "command-line|server|issuer|encrypted-password-from-file" msgstr "" -#: src/scm/webid-oidc/program.scm:242 +#: src/scm/webid-oidc/program.scm:257 msgid "command-line|server|issuer|jwks-uri" msgstr "" -#: src/scm/webid-oidc/program.scm:244 +#: src/scm/webid-oidc/program.scm:259 msgid "command-line|server|issuer|authorization-endpoint-uri" msgstr "" -#: src/scm/webid-oidc/program.scm:246 +#: src/scm/webid-oidc/program.scm:261 msgid "command-line|server|issuer|token-endpoint-uri" msgstr "" -#: src/scm/webid-oidc/program.scm:248 +#: src/scm/webid-oidc/program.scm:263 msgid "command-line|server|client-id" msgstr "" -#: src/scm/webid-oidc/program.scm:250 +#: src/scm/webid-oidc/program.scm:265 msgid "command-line|server|redirect-uri" msgstr "" -#: src/scm/webid-oidc/program.scm:252 +#: src/scm/webid-oidc/program.scm:267 msgid "command-line|server|client-name" msgstr "" -#: src/scm/webid-oidc/program.scm:254 +#: src/scm/webid-oidc/program.scm:269 msgid "command-line|server|client-uri" msgstr "" -#: src/scm/webid-oidc/program.scm:288 +#: src/scm/webid-oidc/program.scm:303 #, scheme-format msgid "Usage: ~a COMMAND [OPTIONS]...\n" msgstr "" -#: src/scm/webid-oidc/program.scm:292 +#: src/scm/webid-oidc/program.scm:307 msgid "" "\n" "Run the disfluid COMMAND." msgstr "" -#: src/scm/webid-oidc/program.scm:295 +#: src/scm/webid-oidc/program.scm:310 msgid "" "\n" "This program is covered by the GNU Affero GPL, version 3 or\n" @@ -1264,13 +1264,13 @@ msgid "" "to all responses." msgstr "" -#: src/scm/webid-oidc/program.scm:302 +#: src/scm/webid-oidc/program.scm:317 msgid "" "\n" "Available commands:" msgstr "" -#: src/scm/webid-oidc/program.scm:304 +#: src/scm/webid-oidc/program.scm:319 #, scheme-format msgid "" "\n" @@ -1278,12 +1278,12 @@ msgid "" " run an authenticating reverse proxy." msgstr "" -#: src/scm/webid-oidc/program.scm:307 src/scm/webid-oidc/program.scm:499 -#: src/scm/webid-oidc/program.scm:700 +#: src/scm/webid-oidc/program.scm:322 src/scm/webid-oidc/program.scm:514 +#: src/scm/webid-oidc/program.scm:715 msgid "command-line|command|reverse-proxy" msgstr "" -#: src/scm/webid-oidc/program.scm:308 +#: src/scm/webid-oidc/program.scm:323 #, scheme-format msgid "" "\n" @@ -1291,12 +1291,12 @@ msgid "" " run an identity provider." msgstr "" -#: src/scm/webid-oidc/program.scm:311 src/scm/webid-oidc/program.scm:524 -#: src/scm/webid-oidc/program.scm:722 +#: src/scm/webid-oidc/program.scm:326 src/scm/webid-oidc/program.scm:539 +#: src/scm/webid-oidc/program.scm:737 msgid "command-line|command|identity-provider" msgstr "" -#: src/scm/webid-oidc/program.scm:312 +#: src/scm/webid-oidc/program.scm:327 #, scheme-format msgid "" "\n" @@ -1304,12 +1304,12 @@ msgid "" " serve the pages for a public application." msgstr "" -#: src/scm/webid-oidc/program.scm:315 src/scm/webid-oidc/program.scm:545 -#: src/scm/webid-oidc/program.scm:766 +#: src/scm/webid-oidc/program.scm:330 src/scm/webid-oidc/program.scm:560 +#: src/scm/webid-oidc/program.scm:779 msgid "command-line|command|client-service" msgstr "" -#: src/scm/webid-oidc/program.scm:316 +#: src/scm/webid-oidc/program.scm:331 #, scheme-format msgid "" "\n" @@ -1318,18 +1318,18 @@ msgid "" " facility." msgstr "" -#: src/scm/webid-oidc/program.scm:320 src/scm/webid-oidc/program.scm:571 -#: src/scm/webid-oidc/program.scm:795 +#: src/scm/webid-oidc/program.scm:335 src/scm/webid-oidc/program.scm:586 +#: src/scm/webid-oidc/program.scm:808 msgid "command-line|command|server" msgstr "" -#: src/scm/webid-oidc/program.scm:322 +#: src/scm/webid-oidc/program.scm:337 msgid "" "\n" "General options:" msgstr "" -#: src/scm/webid-oidc/program.scm:324 +#: src/scm/webid-oidc/program.scm:339 #, scheme-format msgid "" "\n" @@ -1338,7 +1338,7 @@ msgid "" " code. For instance, this would be an URI pointing to a tarball." msgstr "" -#: src/scm/webid-oidc/program.scm:329 +#: src/scm/webid-oidc/program.scm:344 #, scheme-format msgid "" "\n" @@ -1346,7 +1346,7 @@ msgid "" " display a short help message and exit." msgstr "" -#: src/scm/webid-oidc/program.scm:333 +#: src/scm/webid-oidc/program.scm:348 #, scheme-format msgid "" "\n" @@ -1354,7 +1354,7 @@ msgid "" " display the version information (~a, released ~a) and exit." msgstr "" -#: src/scm/webid-oidc/program.scm:339 +#: src/scm/webid-oidc/program.scm:354 #, scheme-format msgid "" "\n" @@ -1362,7 +1362,7 @@ msgid "" " describe the project in the DOAP vocabulary and exit." msgstr "" -#: src/scm/webid-oidc/program.scm:343 +#: src/scm/webid-oidc/program.scm:358 #, scheme-format msgid "" "\n" @@ -1370,7 +1370,7 @@ msgid "" " redirect the program standard output to FILE.log." msgstr "" -#: src/scm/webid-oidc/program.scm:347 +#: src/scm/webid-oidc/program.scm:362 #, scheme-format msgid "" "\n" @@ -1378,13 +1378,13 @@ msgid "" " redirect the program errors to FILE.err." msgstr "" -#: src/scm/webid-oidc/program.scm:352 +#: src/scm/webid-oidc/program.scm:367 msgid "" "\n" "General server-side options:" msgstr "" -#: src/scm/webid-oidc/program.scm:354 +#: src/scm/webid-oidc/program.scm:369 #, scheme-format msgid "" "\n" @@ -1392,7 +1392,7 @@ msgid "" " set the server port to bind, 8080 by default." msgstr "" -#: src/scm/webid-oidc/program.scm:358 +#: src/scm/webid-oidc/program.scm:373 #, scheme-format msgid "" "\n" @@ -1400,13 +1400,13 @@ msgid "" " set the public server URI (scheme, userinfo, host, and port)." msgstr "" -#: src/scm/webid-oidc/program.scm:363 +#: src/scm/webid-oidc/program.scm:378 msgid "" "\n" "Options for the resource server:" msgstr "" -#: src/scm/webid-oidc/program.scm:365 +#: src/scm/webid-oidc/program.scm:380 #, scheme-format msgid "" "\n" @@ -1416,7 +1416,7 @@ msgid "" " authentication." msgstr "" -#: src/scm/webid-oidc/program.scm:371 +#: src/scm/webid-oidc/program.scm:386 #, scheme-format msgid "" "\n" @@ -1425,13 +1425,13 @@ msgid "" " reverse-proxy command." msgstr "" -#: src/scm/webid-oidc/program.scm:377 +#: src/scm/webid-oidc/program.scm:392 msgid "" "\n" "Options for the identity provider:" msgstr "" -#: src/scm/webid-oidc/program.scm:379 +#: src/scm/webid-oidc/program.scm:394 #, scheme-format msgid "" "\n" @@ -1440,7 +1440,7 @@ msgid "" " key is generated. The server does not offer an HTTPS service." msgstr "" -#: src/scm/webid-oidc/program.scm:384 +#: src/scm/webid-oidc/program.scm:399 #, scheme-format msgid "" "\n" @@ -1448,7 +1448,7 @@ msgid "" " set the identity of the subject." msgstr "" -#: src/scm/webid-oidc/program.scm:388 +#: src/scm/webid-oidc/program.scm:403 #, scheme-format msgid "" "\n" @@ -1456,7 +1456,7 @@ msgid "" " set the encrypted password to recognize the user." msgstr "" -#: src/scm/webid-oidc/program.scm:392 +#: src/scm/webid-oidc/program.scm:407 #, scheme-format msgid "" "\n" @@ -1464,7 +1464,7 @@ msgid "" " load the user’s encrypted password from ENCRYPTED_PASSWORD_FILE." msgstr "" -#: src/scm/webid-oidc/program.scm:396 +#: src/scm/webid-oidc/program.scm:411 #, scheme-format msgid "" "\n" @@ -1472,7 +1472,7 @@ msgid "" " set the URI to query the key of the server." msgstr "" -#: src/scm/webid-oidc/program.scm:400 +#: src/scm/webid-oidc/program.scm:415 #, scheme-format msgid "" "\n" @@ -1480,7 +1480,7 @@ msgid "" " set the authorization endpoint of the issuer." msgstr "" -#: src/scm/webid-oidc/program.scm:404 +#: src/scm/webid-oidc/program.scm:419 #, scheme-format msgid "" "\n" @@ -1488,13 +1488,13 @@ msgid "" " set the token endpoint of the issuer." msgstr "" -#: src/scm/webid-oidc/program.scm:409 +#: src/scm/webid-oidc/program.scm:424 msgid "" "\n" "Options for the client service:" msgstr "" -#: src/scm/webid-oidc/program.scm:411 +#: src/scm/webid-oidc/program.scm:426 #, scheme-format msgid "" "\n" @@ -1503,7 +1503,7 @@ msgid "" " dereferenced to a semantic resource." msgstr "" -#: src/scm/webid-oidc/program.scm:416 +#: src/scm/webid-oidc/program.scm:431 #, scheme-format msgid "" "\n" @@ -1512,7 +1512,7 @@ msgid "" " page is presented with the code to paste in the application." msgstr "" -#: src/scm/webid-oidc/program.scm:421 +#: src/scm/webid-oidc/program.scm:436 #, scheme-format msgid "" "\n" @@ -1520,7 +1520,7 @@ msgid "" " set the user-visible application name (may be misleading...)." msgstr "" -#: src/scm/webid-oidc/program.scm:425 +#: src/scm/webid-oidc/program.scm:440 #, scheme-format msgid "" "\n" @@ -1529,13 +1529,13 @@ msgid "" " application (again, may be misleading)." msgstr "" -#: src/scm/webid-oidc/program.scm:431 +#: src/scm/webid-oidc/program.scm:446 msgid "" "\n" "Environment variables:" msgstr "" -#: src/scm/webid-oidc/program.scm:433 +#: src/scm/webid-oidc/program.scm:448 msgid "" "\n" " XML_CATALOG_FILES: the server will fetch resources on the web. By\n" @@ -1546,23 +1546,23 @@ msgid "" " content-type." msgstr "" -#: src/scm/webid-oidc/program.scm:441 src/scm/webid-oidc/program.scm:448 -#: src/scm/webid-oidc/program.scm:457 src/scm/webid-oidc/program.scm:465 -#: src/scm/webid-oidc/program.scm:473 +#: src/scm/webid-oidc/program.scm:456 src/scm/webid-oidc/program.scm:463 +#: src/scm/webid-oidc/program.scm:472 src/scm/webid-oidc/program.scm:480 +#: src/scm/webid-oidc/program.scm:488 #, scheme-format msgid "" "the-environment-variable|\n" " It is currently set to ~s." msgstr "" -#: src/scm/webid-oidc/program.scm:444 +#: src/scm/webid-oidc/program.scm:459 msgid "" "\n" " LANG: set the locale of the user interface (for the server commands,\n" " the user is the system administrator)." msgstr "" -#: src/scm/webid-oidc/program.scm:451 +#: src/scm/webid-oidc/program.scm:466 msgid "" "\n" " XDG_DATA_HOME: where the program stores persistent data. The\n" @@ -1571,7 +1571,7 @@ msgid "" " recommended to set it to /var/lib." msgstr "" -#: src/scm/webid-oidc/program.scm:460 +#: src/scm/webid-oidc/program.scm:475 msgid "" "\n" " XDG_CACHE_HOME: where the program stores and updates the seed file,\n" @@ -1579,7 +1579,7 @@ msgid "" " time. The seed file will be initialized from /dev/random." msgstr "" -#: src/scm/webid-oidc/program.scm:468 +#: src/scm/webid-oidc/program.scm:483 msgid "" "\n" " HOME: if XDG_DATA_HOME or XDG_CACHE_HOME is not set, they are\n" @@ -1587,13 +1587,13 @@ msgid "" " not used otherwise." msgstr "" -#: src/scm/webid-oidc/program.scm:477 +#: src/scm/webid-oidc/program.scm:492 msgid "" "\n" "Running a reverse proxy" msgstr "" -#: src/scm/webid-oidc/program.scm:479 +#: src/scm/webid-oidc/program.scm:494 msgid "" "\n" "Suppose that you operate data.provider.com. You want to run an\n" @@ -1606,7 +1606,7 @@ msgid "" "from this reverse proxy." msgstr "" -#: src/scm/webid-oidc/program.scm:489 +#: src/scm/webid-oidc/program.scm:504 #, scheme-format msgid "" "\n" @@ -1620,20 +1620,20 @@ msgid "" " --~a '/var/log/proxy.err'" msgstr "" -#: src/scm/webid-oidc/program.scm:504 +#: src/scm/webid-oidc/program.scm:519 msgid "" "\n" "Running an identity provider" msgstr "" -#: src/scm/webid-oidc/program.scm:506 +#: src/scm/webid-oidc/program.scm:521 msgid "" "\n" "The identity provider running at webid-oidc-demo.planete-kraus.eu is\n" "invoked with the following options:" msgstr "" -#: src/scm/webid-oidc/program.scm:510 +#: src/scm/webid-oidc/program.scm:525 #, scheme-format msgid "" "\n" @@ -1652,20 +1652,20 @@ msgid "" " --~a $PORT" msgstr "" -#: src/scm/webid-oidc/program.scm:530 +#: src/scm/webid-oidc/program.scm:545 msgid "" "\n" "Running the public pages for an application" msgstr "" -#: src/scm/webid-oidc/program.scm:532 +#: src/scm/webid-oidc/program.scm:547 msgid "" "\n" "The example client application pages for\n" "webid-oidc-demo.planete-kraus.eu are served this way:" msgstr "" -#: src/scm/webid-oidc/program.scm:536 +#: src/scm/webid-oidc/program.scm:551 #, scheme-format msgid "" "\n" @@ -1681,13 +1681,13 @@ msgid "" " --~a $PORT" msgstr "" -#: src/scm/webid-oidc/program.scm:550 +#: src/scm/webid-oidc/program.scm:565 msgid "" "\n" "Running a full server" msgstr "" -#: src/scm/webid-oidc/program.scm:553 +#: src/scm/webid-oidc/program.scm:568 msgid "" "\n" "To run the server with identity provider and\n" @@ -1695,7 +1695,7 @@ msgid "" "options for the parts." msgstr "" -#: src/scm/webid-oidc/program.scm:557 +#: src/scm/webid-oidc/program.scm:572 #, scheme-format msgid "" "\n" @@ -1714,14 +1714,14 @@ msgid "" " --~a '...port...'" msgstr "" -#: src/scm/webid-oidc/program.scm:582 +#: src/scm/webid-oidc/program.scm:597 #, scheme-format msgid "" "\n" "If you find a bug, then please send a report to ~a." msgstr "" -#: src/scm/webid-oidc/program.scm:587 +#: src/scm/webid-oidc/program.scm:602 #, scheme-format msgid "" "~a version ~a\n" @@ -1729,108 +1729,108 @@ msgid "" "Rreleased ~a\n" msgstr "" -#: src/scm/webid-oidc/program.scm:624 +#: src/scm/webid-oidc/program.scm:639 #, scheme-format msgid "The --~a argument must be a number, not ~s.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:630 +#: src/scm/webid-oidc/program.scm:645 #, scheme-format msgid "The --~a argument must be an integer, not ~s.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:636 +#: src/scm/webid-oidc/program.scm:651 #, scheme-format msgid "The --~a argument must be positive, ~s is invalid.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:641 +#: src/scm/webid-oidc/program.scm:656 #, scheme-format msgid "The --~a argument must be less than 65536, ~s is invalid.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:669 +#: src/scm/webid-oidc/program.scm:684 msgid "" "You specified two different passwords: one directly, and one from a file. " "Please set only one password.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:693 +#: src/scm/webid-oidc/program.scm:708 #, scheme-format msgid "" "Usage: ~a COMMAND [OPTIONS]...\n" "See --~a (-h).\n" msgstr "" -#: src/scm/webid-oidc/program.scm:703 src/scm/webid-oidc/program.scm:725 -#: src/scm/webid-oidc/program.scm:797 +#: src/scm/webid-oidc/program.scm:718 src/scm/webid-oidc/program.scm:740 +#: src/scm/webid-oidc/program.scm:810 #, scheme-format msgid "You must pass --~a to set the server name.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:707 +#: src/scm/webid-oidc/program.scm:722 #, scheme-format msgid "You must pass --~a to set the backend URI.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:729 src/scm/webid-oidc/program.scm:801 +#: src/scm/webid-oidc/program.scm:744 src/scm/webid-oidc/program.scm:814 #, scheme-format msgid "" "You must pass --~a to set the file where to store the identity provider " "key.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:733 src/scm/webid-oidc/program.scm:805 +#: src/scm/webid-oidc/program.scm:748 src/scm/webid-oidc/program.scm:818 #, scheme-format msgid "You must pass --~a to set the subject of the identity provider.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:737 +#: src/scm/webid-oidc/program.scm:752 #, scheme-format msgid "You must pass --~a or --~a to set the subject’s encrypted password.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:741 src/scm/webid-oidc/program.scm:813 +#: src/scm/webid-oidc/program.scm:756 src/scm/webid-oidc/program.scm:826 #, scheme-format msgid "You must pass --~a to set the JWKS URI.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:745 src/scm/webid-oidc/program.scm:817 +#: src/scm/webid-oidc/program.scm:760 src/scm/webid-oidc/program.scm:830 #, scheme-format msgid "You must pass --~a to set the authorization endpoint URI.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:749 src/scm/webid-oidc/program.scm:821 +#: src/scm/webid-oidc/program.scm:764 src/scm/webid-oidc/program.scm:834 #, scheme-format msgid "You must pass --~a to set the token endpoint URI.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:769 +#: src/scm/webid-oidc/program.scm:782 #, scheme-format msgid "You must pass --~a to set the application web ID.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:773 +#: src/scm/webid-oidc/program.scm:786 #, scheme-format msgid "You must pass --~a to set the redirection URI.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:777 +#: src/scm/webid-oidc/program.scm:790 #, scheme-format msgid "You must pass --~a to set the informative client name.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:781 +#: src/scm/webid-oidc/program.scm:794 #, scheme-format msgid "You must pass --~a to set the informative client URI.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:809 +#: src/scm/webid-oidc/program.scm:822 #, scheme-format msgid "You must pass --~a to set the subject’s encrypted password.\n" msgstr "" -#: src/scm/webid-oidc/program.scm:868 +#: src/scm/webid-oidc/program.scm:877 #, scheme-format msgid "Unknown command ~s\n" msgstr "" @@ -2,7 +2,7 @@ msgid "" msgstr "" "Project-Id-Version: webid-oidc 0.0.0\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-07-30 21:12+0200\n" +"POT-Creation-Date: 2021-08-01 15:25+0000\n" "PO-Revision-Date: 2021-07-30 21:16+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" @@ -859,7 +859,7 @@ msgstr "il y a une erreur" msgid "Unhandled exception type ~a." msgstr "Type d’exception non pris en charge ~a." -#: src/scm/webid-oidc/identity-provider.scm:70 +#: src/scm/webid-oidc/identity-provider.scm:68 msgid "Warning: generating a new key pair." msgstr "Attention : génération d'une nouvelle paire de clé." @@ -1001,26 +1001,26 @@ msgstr "" "<a href=~s>~a</a> peut maintenant s'identifier en votre nom. Vous devez " "toujours ajuster ses permissions." -#: src/scm/webid-oidc/resource-server.scm:92 +#: src/scm/webid-oidc/resource-server.scm:85 #, scheme-format msgid "~a: authentication failure: ~a\n" msgstr "~a : échec d’authentificationn : ~a\n" -#: src/scm/webid-oidc/resource-server.scm:275 +#: src/scm/webid-oidc/resource-server.scm:267 #, scheme-format msgid "Warning: ~a\n" msgstr "Avertissement : ~a\n" #: src/scm/webid-oidc/hello-world.scm:48 src/scm/webid-oidc/example-app.scm:116 -#: src/scm/webid-oidc/program.scm:218 +#: src/scm/webid-oidc/program.scm:233 msgid "command-line|version" msgstr "version" -#: src/scm/webid-oidc/hello-world.scm:50 src/scm/webid-oidc/program.scm:222 +#: src/scm/webid-oidc/hello-world.scm:50 src/scm/webid-oidc/program.scm:237 msgid "command-line|complete-corresponding-source" msgstr "code-source-correspondant-complet" -#: src/scm/webid-oidc/hello-world.scm:52 src/scm/webid-oidc/program.scm:224 +#: src/scm/webid-oidc/hello-world.scm:52 src/scm/webid-oidc/program.scm:239 msgid "command-line|help" msgstr "aide" @@ -1028,11 +1028,11 @@ msgstr "aide" msgid "command-line|port" msgstr "port" -#: src/scm/webid-oidc/hello-world.scm:56 src/scm/webid-oidc/program.scm:256 +#: src/scm/webid-oidc/hello-world.scm:56 src/scm/webid-oidc/program.scm:271 msgid "command-line|log-file" msgstr "fichier-journal" -#: src/scm/webid-oidc/hello-world.scm:58 src/scm/webid-oidc/program.scm:258 +#: src/scm/webid-oidc/hello-world.scm:58 src/scm/webid-oidc/program.scm:273 msgid "command-line|error-file" msgstr "fichier-erreur" @@ -1096,7 +1096,7 @@ msgstr "" msgid "~a version ~a\n" msgstr "~a version ~a\n" -#: src/scm/webid-oidc/hello-world.scm:112 src/scm/webid-oidc/program.scm:617 +#: src/scm/webid-oidc/hello-world.scm:112 src/scm/webid-oidc/program.scm:632 msgid "" "You are legally required to link to the complete corresponding source code.\n" msgstr "" @@ -1258,12 +1258,12 @@ msgstr "" msgid "There was an error: ~a\n" msgstr "Il y a eu une erreur : ~a\n" -#: src/scm/webid-oidc/program.scm:112 +#: src/scm/webid-oidc/program.scm:125 #, scheme-format msgid "~a: ~a: Internal server error: ~a\n" msgstr "~a : ~a : Erreur interne du serveur : ~a\n" -#: src/scm/webid-oidc/program.scm:126 +#: src/scm/webid-oidc/program.scm:140 #, scheme-format msgid "" "The client locale ~s can’t be approximated by system locale ~s (because ~a), " @@ -1272,96 +1272,96 @@ msgstr "" "La locale du client ~s ne peut pas être approchée par la locale système ~s " "(parce que ~a), on utilise C.\n" -#: src/scm/webid-oidc/program.scm:150 +#: src/scm/webid-oidc/program.scm:164 #, scheme-format msgid "~a: ~s ~a ~s ~a\n" msgstr "~a : ~s ~a ~s ~a\n" -#: src/scm/webid-oidc/program.scm:152 +#: src/scm/webid-oidc/program.scm:166 #, scheme-format msgid "~a: ~a (~a)" msgstr "~a : ~a (~a)" -#: src/scm/webid-oidc/program.scm:156 +#: src/scm/webid-oidc/program.scm:170 #, scheme-format msgid "~a: ~a" msgstr "~a : ~a" -#: src/scm/webid-oidc/program.scm:166 +#: src/scm/webid-oidc/program.scm:180 #, scheme-format msgid "(there was an error: ~a)" msgstr "(il y a eu une erreur : ~a)" -#: src/scm/webid-oidc/program.scm:220 +#: src/scm/webid-oidc/program.scm:235 msgid "command-line|describe-project" msgstr "décrire-projet" -#: src/scm/webid-oidc/program.scm:226 +#: src/scm/webid-oidc/program.scm:241 msgid "command-line|server|port" msgstr "port" -#: src/scm/webid-oidc/program.scm:228 +#: src/scm/webid-oidc/program.scm:243 msgid "command-line|server|server-name" msgstr "nom-du-serveur" -#: src/scm/webid-oidc/program.scm:230 +#: src/scm/webid-oidc/program.scm:245 msgid "command-line|server|reverse-proxy|backend-uri" msgstr "uri-arrière-plan" -#: src/scm/webid-oidc/program.scm:232 +#: src/scm/webid-oidc/program.scm:247 msgid "command-line|server|reverse-proxy|header" msgstr "en-tête" -#: src/scm/webid-oidc/program.scm:234 +#: src/scm/webid-oidc/program.scm:249 msgid "command-line|server|issuer|key-file" msgstr "fichier-clé" -#: src/scm/webid-oidc/program.scm:236 +#: src/scm/webid-oidc/program.scm:251 msgid "command-line|server|issuer|subject" msgstr "sujet" -#: src/scm/webid-oidc/program.scm:238 +#: src/scm/webid-oidc/program.scm:253 msgid "command-line|server|issuer|encrypted-password" msgstr "mot-de-passe-chiffré" -#: src/scm/webid-oidc/program.scm:240 +#: src/scm/webid-oidc/program.scm:255 msgid "command-line|server|issuer|encrypted-password-from-file" msgstr "fichier-de-mot-de-passe-chiffré" -#: src/scm/webid-oidc/program.scm:242 +#: src/scm/webid-oidc/program.scm:257 msgid "command-line|server|issuer|jwks-uri" msgstr "uri-jwks" -#: src/scm/webid-oidc/program.scm:244 +#: src/scm/webid-oidc/program.scm:259 msgid "command-line|server|issuer|authorization-endpoint-uri" msgstr "uri-terminal-autorisation" -#: src/scm/webid-oidc/program.scm:246 +#: src/scm/webid-oidc/program.scm:261 msgid "command-line|server|issuer|token-endpoint-uri" msgstr "uri-terminal-jeton" -#: src/scm/webid-oidc/program.scm:248 +#: src/scm/webid-oidc/program.scm:263 msgid "command-line|server|client-id" msgstr "id-client" -#: src/scm/webid-oidc/program.scm:250 +#: src/scm/webid-oidc/program.scm:265 msgid "command-line|server|redirect-uri" msgstr "uri-redirection" -#: src/scm/webid-oidc/program.scm:252 +#: src/scm/webid-oidc/program.scm:267 msgid "command-line|server|client-name" msgstr "nom-client" -#: src/scm/webid-oidc/program.scm:254 +#: src/scm/webid-oidc/program.scm:269 msgid "command-line|server|client-uri" msgstr "uri-client" -#: src/scm/webid-oidc/program.scm:288 +#: src/scm/webid-oidc/program.scm:303 #, scheme-format msgid "Usage: ~a COMMAND [OPTIONS]...\n" msgstr "Utilisation : ~a COMMANDE [OPTIONS]...\n" -#: src/scm/webid-oidc/program.scm:292 +#: src/scm/webid-oidc/program.scm:307 msgid "" "\n" "Run the disfluid COMMAND." @@ -1369,7 +1369,7 @@ msgstr "" "\n" "Exécute la COMMANDE disfluid." -#: src/scm/webid-oidc/program.scm:295 +#: src/scm/webid-oidc/program.scm:310 msgid "" "\n" "This program is covered by the GNU Affero GPL, version 3 or\n" @@ -1385,7 +1385,7 @@ msgstr "" "code source complet correspondant (avec vos modifications) sans\n" "frais. Le serveur ajoute un en-tête « Source: » à toutes les réponses." -#: src/scm/webid-oidc/program.scm:302 +#: src/scm/webid-oidc/program.scm:317 msgid "" "\n" "Available commands:" @@ -1393,7 +1393,7 @@ msgstr "" "\n" "Commandes disponibles :" -#: src/scm/webid-oidc/program.scm:304 +#: src/scm/webid-oidc/program.scm:319 #, scheme-format msgid "" "\n" @@ -1404,12 +1404,12 @@ msgstr "" " ~a :\n" " exécute le proxy inverse authentifiant." -#: src/scm/webid-oidc/program.scm:307 src/scm/webid-oidc/program.scm:499 -#: src/scm/webid-oidc/program.scm:700 +#: src/scm/webid-oidc/program.scm:322 src/scm/webid-oidc/program.scm:514 +#: src/scm/webid-oidc/program.scm:715 msgid "command-line|command|reverse-proxy" msgstr "proxy-inversé" -#: src/scm/webid-oidc/program.scm:308 +#: src/scm/webid-oidc/program.scm:323 #, scheme-format msgid "" "\n" @@ -1420,12 +1420,12 @@ msgstr "" " ~a :\n" " exécute un fournisseur d’identité." -#: src/scm/webid-oidc/program.scm:311 src/scm/webid-oidc/program.scm:524 -#: src/scm/webid-oidc/program.scm:722 +#: src/scm/webid-oidc/program.scm:326 src/scm/webid-oidc/program.scm:539 +#: src/scm/webid-oidc/program.scm:737 msgid "command-line|command|identity-provider" msgstr "fournisseur-identité" -#: src/scm/webid-oidc/program.scm:312 +#: src/scm/webid-oidc/program.scm:327 #, scheme-format msgid "" "\n" @@ -1436,12 +1436,12 @@ msgstr "" " ~a :\n" " sert les pages d’une application publique." -#: src/scm/webid-oidc/program.scm:315 src/scm/webid-oidc/program.scm:545 -#: src/scm/webid-oidc/program.scm:766 +#: src/scm/webid-oidc/program.scm:330 src/scm/webid-oidc/program.scm:560 +#: src/scm/webid-oidc/program.scm:779 msgid "command-line|command|client-service" msgstr "service-client" -#: src/scm/webid-oidc/program.scm:316 +#: src/scm/webid-oidc/program.scm:331 #, scheme-format msgid "" "\n" @@ -1454,12 +1454,12 @@ msgstr "" " exécute un serveur complet, avec un fournisseur d’identité et\n" " une fonction de stockage de ressources." -#: src/scm/webid-oidc/program.scm:320 src/scm/webid-oidc/program.scm:571 -#: src/scm/webid-oidc/program.scm:795 +#: src/scm/webid-oidc/program.scm:335 src/scm/webid-oidc/program.scm:586 +#: src/scm/webid-oidc/program.scm:808 msgid "command-line|command|server" msgstr "serveur" -#: src/scm/webid-oidc/program.scm:322 +#: src/scm/webid-oidc/program.scm:337 msgid "" "\n" "General options:" @@ -1467,7 +1467,7 @@ msgstr "" "\n" "Options générales :" -#: src/scm/webid-oidc/program.scm:324 +#: src/scm/webid-oidc/program.scm:339 #, scheme-format msgid "" "\n" @@ -1481,7 +1481,7 @@ msgstr "" " correspondant. Par exemple, MOYEN serait une URI pointant vers\n" " l’archive de code." -#: src/scm/webid-oidc/program.scm:329 +#: src/scm/webid-oidc/program.scm:344 #, scheme-format msgid "" "\n" @@ -1492,7 +1492,7 @@ msgstr "" " -h, --~a :\n" " affiche un court message d’aide et quitte." -#: src/scm/webid-oidc/program.scm:333 +#: src/scm/webid-oidc/program.scm:348 #, scheme-format msgid "" "\n" @@ -1503,7 +1503,7 @@ msgstr "" " -v, --~a :\n" " affiche le numéro de version (~a, publiée le ~a) et quitte." -#: src/scm/webid-oidc/program.scm:339 +#: src/scm/webid-oidc/program.scm:354 #, scheme-format msgid "" "\n" @@ -1514,7 +1514,7 @@ msgstr "" " --~a :\n" " décrit le projet dans le vocabulaire DOAP et quitte." -#: src/scm/webid-oidc/program.scm:343 +#: src/scm/webid-oidc/program.scm:358 #, scheme-format msgid "" "\n" @@ -1525,7 +1525,7 @@ msgstr "" " -l FICHIER.journal, --~a=FICHIER.journal :\n" " redirige la sortie standard du programme vers FICHIER.journal." -#: src/scm/webid-oidc/program.scm:347 +#: src/scm/webid-oidc/program.scm:362 #, scheme-format msgid "" "\n" @@ -1536,7 +1536,7 @@ msgstr "" " -e FICHIER.erreurs, --~a=FICHIER.erreurs :\n" " redirige les erreurs du programme vers FICHIER.erreurs." -#: src/scm/webid-oidc/program.scm:352 +#: src/scm/webid-oidc/program.scm:367 msgid "" "\n" "General server-side options:" @@ -1544,7 +1544,7 @@ msgstr "" "\n" "Options générales pour un serveur :" -#: src/scm/webid-oidc/program.scm:354 +#: src/scm/webid-oidc/program.scm:369 #, scheme-format msgid "" "\n" @@ -1555,7 +1555,7 @@ msgstr "" " -p PORT, --~a=PORT :\n" " définit le port à lier, 8080 par défaut." -#: src/scm/webid-oidc/program.scm:358 +#: src/scm/webid-oidc/program.scm:373 #, scheme-format msgid "" "\n" @@ -1567,7 +1567,7 @@ msgstr "" " définit l’URI publique du serveur (schéma, identifiant de\n" " l’utilisateur, hôte et port)." -#: src/scm/webid-oidc/program.scm:363 +#: src/scm/webid-oidc/program.scm:378 msgid "" "\n" "Options for the resource server:" @@ -1575,7 +1575,7 @@ msgstr "" "\n" "Options pour le serveur de ressources :" -#: src/scm/webid-oidc/program.scm:365 +#: src/scm/webid-oidc/program.scm:380 #, scheme-format msgid "" "\n" @@ -1590,7 +1590,7 @@ msgstr "" " authentifié, XXX-Agent par défaut. Pour un serveur complet, ceci\n" " désactive l’authentification par Solid-OIDC." -#: src/scm/webid-oidc/program.scm:371 +#: src/scm/webid-oidc/program.scm:386 #, scheme-format msgid "" "\n" @@ -1603,7 +1603,7 @@ msgstr "" " définit l’URI sortante du proxy inversé, seulement pour la\n" " commande proxy-inversé." -#: src/scm/webid-oidc/program.scm:377 +#: src/scm/webid-oidc/program.scm:392 msgid "" "\n" "Options for the identity provider:" @@ -1611,7 +1611,7 @@ msgstr "" "\n" "Options du fournisseur d’identité :" -#: src/scm/webid-oidc/program.scm:379 +#: src/scm/webid-oidc/program.scm:394 #, scheme-format msgid "" "\n" @@ -1625,7 +1625,7 @@ msgstr "" " nouvelle clé sera générée. Le serveur n’offre pas de service\n" " HTTPS." -#: src/scm/webid-oidc/program.scm:384 +#: src/scm/webid-oidc/program.scm:399 #, scheme-format msgid "" "\n" @@ -1636,7 +1636,7 @@ msgstr "" " -s WEBID, --~a=WEBID :\n" " définit l'identité du sujet." -#: src/scm/webid-oidc/program.scm:388 +#: src/scm/webid-oidc/program.scm:403 #, scheme-format msgid "" "\n" @@ -1647,7 +1647,7 @@ msgstr "" " -w MOT_DE_PASSE_CHIFFRÉ, --~a=MOT_DE_PASSE_CHIFFRÉ :\n" " définit le mot de passe chiffré pour reconnaître l’utilisateur." -#: src/scm/webid-oidc/program.scm:392 +#: src/scm/webid-oidc/program.scm:407 #, scheme-format msgid "" "\n" @@ -1660,7 +1660,7 @@ msgstr "" " lit le mot de passe chiffré de l’utilisateur dans " "FICHIER_DE_MOT_DE_PASSE_CHIFFRÉ." -#: src/scm/webid-oidc/program.scm:396 +#: src/scm/webid-oidc/program.scm:411 #, scheme-format msgid "" "\n" @@ -1671,7 +1671,7 @@ msgstr "" " -j URI, --~a=URI :\n" " définit l’URI pour requêter les clés du serveur." -#: src/scm/webid-oidc/program.scm:400 +#: src/scm/webid-oidc/program.scm:415 #, scheme-format msgid "" "\n" @@ -1683,7 +1683,7 @@ msgstr "" " définit l'URI du terminal d'autorisation de l’émetteur\n" " d’identité." -#: src/scm/webid-oidc/program.scm:404 +#: src/scm/webid-oidc/program.scm:419 #, scheme-format msgid "" "\n" @@ -1694,7 +1694,7 @@ msgstr "" " -t URI, --~a=URI :\n" " définit le terminal de jeton de l’émetteur d’identité." -#: src/scm/webid-oidc/program.scm:409 +#: src/scm/webid-oidc/program.scm:424 msgid "" "\n" "Options for the client service:" @@ -1702,7 +1702,7 @@ msgstr "" "\n" "Options pour le service associé à un client :" -#: src/scm/webid-oidc/program.scm:411 +#: src/scm/webid-oidc/program.scm:426 #, scheme-format msgid "" "\n" @@ -1715,7 +1715,7 @@ msgstr "" " définit l’identifiant web de l’application client, qui est\n" " déréférencé pour une ressource sémantique." -#: src/scm/webid-oidc/program.scm:416 +#: src/scm/webid-oidc/program.scm:431 #, scheme-format msgid "" "\n" @@ -1729,7 +1729,7 @@ msgstr "" " d’autorisation. La page de redirection affiche le code à coller\n" " dans l’application." -#: src/scm/webid-oidc/program.scm:421 +#: src/scm/webid-oidc/program.scm:436 #, scheme-format msgid "" "\n" @@ -1741,7 +1741,7 @@ msgstr "" " définit le nom de l’application visible par l’utilisateur (peut\n" " être trompeur…)." -#: src/scm/webid-oidc/program.scm:425 +#: src/scm/webid-oidc/program.scm:440 #, scheme-format msgid "" "\n" @@ -1754,7 +1754,7 @@ msgstr "" " définit l’URI présentant plus d’informations à propos de\n" " l’application (peut aussi être trompeur)." -#: src/scm/webid-oidc/program.scm:431 +#: src/scm/webid-oidc/program.scm:446 msgid "" "\n" "Environment variables:" @@ -1762,7 +1762,7 @@ msgstr "" "\n" "Variables d’environnement :" -#: src/scm/webid-oidc/program.scm:433 +#: src/scm/webid-oidc/program.scm:448 msgid "" "\n" " XML_CATALOG_FILES: the server will fetch resources on the web. By\n" @@ -1781,9 +1781,9 @@ msgstr "" " fichiers depuis le système de fichiers, parce qu’il n’y a pas de\n" " moyen de spécifier le type de contenu." -#: src/scm/webid-oidc/program.scm:441 src/scm/webid-oidc/program.scm:448 -#: src/scm/webid-oidc/program.scm:457 src/scm/webid-oidc/program.scm:465 -#: src/scm/webid-oidc/program.scm:473 +#: src/scm/webid-oidc/program.scm:456 src/scm/webid-oidc/program.scm:463 +#: src/scm/webid-oidc/program.scm:472 src/scm/webid-oidc/program.scm:480 +#: src/scm/webid-oidc/program.scm:488 #, scheme-format msgid "" "the-environment-variable|\n" @@ -1792,7 +1792,7 @@ msgstr "" " \n" " Elle vaut actuellement ~s." -#: src/scm/webid-oidc/program.scm:444 +#: src/scm/webid-oidc/program.scm:459 msgid "" "\n" " LANG: set the locale of the user interface (for the server commands,\n" @@ -1802,7 +1802,7 @@ msgstr "" " LANG : définit la locale de l’interface utilisateur (pour les\n" " commandes serveur, l’utilisateur est l’administrateur système)." -#: src/scm/webid-oidc/program.scm:451 +#: src/scm/webid-oidc/program.scm:466 msgid "" "\n" " XDG_DATA_HOME: where the program stores persistent data. The\n" @@ -1817,7 +1817,7 @@ msgstr "" " ici. Pour un service système, il est recommandé d’utiliser\n" " /var/lib." -#: src/scm/webid-oidc/program.scm:460 +#: src/scm/webid-oidc/program.scm:475 msgid "" "\n" " XDG_CACHE_HOME: where the program stores and updates the seed file,\n" @@ -1830,7 +1830,7 @@ msgstr "" " supprimer ce dossier n’importe quand. Le fichier de graine sera\n" " initialisé à partir de /dev/random." -#: src/scm/webid-oidc/program.scm:468 +#: src/scm/webid-oidc/program.scm:483 msgid "" "\n" " HOME: if XDG_DATA_HOME or XDG_CACHE_HOME is not set, they are\n" @@ -1842,7 +1842,7 @@ msgstr "" " valeur est calculée à partir de la variable d’environnement\n" " HOME. Elle n’est pas utilisée autrement." -#: src/scm/webid-oidc/program.scm:477 +#: src/scm/webid-oidc/program.scm:492 msgid "" "\n" "Running a reverse proxy" @@ -1850,7 +1850,7 @@ msgstr "" "\n" "Exécution d’un proxy inversé" -#: src/scm/webid-oidc/program.scm:479 +#: src/scm/webid-oidc/program.scm:494 msgid "" "\n" "Suppose that you operate data.provider.com. You want to run an\n" @@ -1872,7 +1872,7 @@ msgstr "" "authentifié. https://private.data.provider.com ne doit accepter que\n" "les requêtes depuis ce proxy inversé." -#: src/scm/webid-oidc/program.scm:489 +#: src/scm/webid-oidc/program.scm:504 #, scheme-format msgid "" "\n" @@ -1896,7 +1896,7 @@ msgstr "" " --~a '/var/log/proxy.log' \\\n" " --~a '/var/log/proxy.err'" -#: src/scm/webid-oidc/program.scm:504 +#: src/scm/webid-oidc/program.scm:519 msgid "" "\n" "Running an identity provider" @@ -1904,7 +1904,7 @@ msgstr "" "\n" "Exécution d’un fournisseur d’identité" -#: src/scm/webid-oidc/program.scm:506 +#: src/scm/webid-oidc/program.scm:521 msgid "" "\n" "The identity provider running at webid-oidc-demo.planete-kraus.eu is\n" @@ -1915,7 +1915,7 @@ msgstr "" "webid-oidc-demo.planete-kraus.eu est invoqué avec les options\n" "suivantes :" -#: src/scm/webid-oidc/program.scm:510 +#: src/scm/webid-oidc/program.scm:525 #, scheme-format msgid "" "\n" @@ -1949,7 +1949,7 @@ msgstr "" " --~a 'https://webid-oidc-demo.planete-kraus.eu/token' \\\n" " --~a $PORT" -#: src/scm/webid-oidc/program.scm:530 +#: src/scm/webid-oidc/program.scm:545 msgid "" "\n" "Running the public pages for an application" @@ -1957,7 +1957,7 @@ msgstr "" "\n" "Service des pages publiques pour une application" -#: src/scm/webid-oidc/program.scm:532 +#: src/scm/webid-oidc/program.scm:547 msgid "" "\n" "The example client application pages for\n" @@ -1967,7 +1967,7 @@ msgstr "" "Les pages de l’application client d’exemple pour\n" "webid-oidc-demo.planete-kraus.eu sont servies de cette façon :" -#: src/scm/webid-oidc/program.scm:536 +#: src/scm/webid-oidc/program.scm:551 #, scheme-format msgid "" "\n" @@ -1995,7 +1995,7 @@ msgstr "" "html#Running-a-client' \\\n" " --~a $PORT" -#: src/scm/webid-oidc/program.scm:550 +#: src/scm/webid-oidc/program.scm:565 msgid "" "\n" "Running a full server" @@ -2003,7 +2003,7 @@ msgstr "" "\n" "Exécution d’un serveur complet" -#: src/scm/webid-oidc/program.scm:553 +#: src/scm/webid-oidc/program.scm:568 msgid "" "\n" "To run the server with identity provider and\n" @@ -2015,7 +2015,7 @@ msgstr "" "un serveur de ressources pour un utilisateur particulier, vous devez\n" "combiner les options des parties." -#: src/scm/webid-oidc/program.scm:557 +#: src/scm/webid-oidc/program.scm:572 #, scheme-format msgid "" "\n" @@ -2049,7 +2049,7 @@ msgstr "" " --~a 'https://data.planete-kraus.eu/token' \\\n" " --~a '...port...'" -#: src/scm/webid-oidc/program.scm:582 +#: src/scm/webid-oidc/program.scm:597 #, scheme-format msgid "" "\n" @@ -2058,7 +2058,7 @@ msgstr "" "\n" "Si vous trouvez une erreur, veuillez en envoyer un rapport à ~a." -#: src/scm/webid-oidc/program.scm:587 +#: src/scm/webid-oidc/program.scm:602 #, scheme-format msgid "" "~a version ~a\n" @@ -2069,27 +2069,27 @@ msgstr "" "\n" "Publiée le ~a\n" -#: src/scm/webid-oidc/program.scm:624 +#: src/scm/webid-oidc/program.scm:639 #, scheme-format msgid "The --~a argument must be a number, not ~s.\n" msgstr "L’argument de --~a doit être un nombre, pas ~s.\n" -#: src/scm/webid-oidc/program.scm:630 +#: src/scm/webid-oidc/program.scm:645 #, scheme-format msgid "The --~a argument must be an integer, not ~s.\n" msgstr "L’argument de --~a doit être un entier, pas ~s.\n" -#: src/scm/webid-oidc/program.scm:636 +#: src/scm/webid-oidc/program.scm:651 #, scheme-format msgid "The --~a argument must be positive, ~s is invalid.\n" msgstr "L’argument de --~a doit être positif, ~s est invalide.\n" -#: src/scm/webid-oidc/program.scm:641 +#: src/scm/webid-oidc/program.scm:656 #, scheme-format msgid "The --~a argument must be less than 65536, ~s is invalid.\n" msgstr "L’argument de --~a doit être inférieur à 65536, ~s est invalide.\n" -#: src/scm/webid-oidc/program.scm:669 +#: src/scm/webid-oidc/program.scm:684 msgid "" "You specified two different passwords: one directly, and one from a file. " "Please set only one password.\n" @@ -2097,7 +2097,7 @@ msgstr "" "Vous avez spécifié deux mots de passe différents : l’un directement,\n" "et un autre depuis un fichier. Veuillez n’en spécifier qu’un.\n" -#: src/scm/webid-oidc/program.scm:693 +#: src/scm/webid-oidc/program.scm:708 #, scheme-format msgid "" "Usage: ~a COMMAND [OPTIONS]...\n" @@ -2106,18 +2106,18 @@ msgstr "" "Utilisation : ~a COMMANDE [OPTIONS]...\n" "Voir --~a (-h).\n" -#: src/scm/webid-oidc/program.scm:703 src/scm/webid-oidc/program.scm:725 -#: src/scm/webid-oidc/program.scm:797 +#: src/scm/webid-oidc/program.scm:718 src/scm/webid-oidc/program.scm:740 +#: src/scm/webid-oidc/program.scm:810 #, scheme-format msgid "You must pass --~a to set the server name.\n" msgstr "Vous devez passer --~a pour définir le nom du serveur.\n" -#: src/scm/webid-oidc/program.scm:707 +#: src/scm/webid-oidc/program.scm:722 #, scheme-format msgid "You must pass --~a to set the backend URI.\n" msgstr "Vous devez passer --~a pour définir l'URI du service d’arrière-plan.\n" -#: src/scm/webid-oidc/program.scm:729 src/scm/webid-oidc/program.scm:801 +#: src/scm/webid-oidc/program.scm:744 src/scm/webid-oidc/program.scm:814 #, scheme-format msgid "" "You must pass --~a to set the file where to store the identity provider " @@ -2126,66 +2126,66 @@ msgstr "" "Vous devez passer --~a pour définir le nom du fichier pour sauvegarder\n" "la clé du fournisseur d’identité.\n" -#: src/scm/webid-oidc/program.scm:733 src/scm/webid-oidc/program.scm:805 +#: src/scm/webid-oidc/program.scm:748 src/scm/webid-oidc/program.scm:818 #, scheme-format msgid "You must pass --~a to set the subject of the identity provider.\n" msgstr "" "Vous devez passer --~a pour définir le sujet du fournisseur d’identité.\n" -#: src/scm/webid-oidc/program.scm:737 +#: src/scm/webid-oidc/program.scm:752 #, scheme-format msgid "You must pass --~a or --~a to set the subject’s encrypted password.\n" msgstr "" "Vous devez passer --~a ou --~a pour définir le mot de passe chiffré du " "sujet.\n" -#: src/scm/webid-oidc/program.scm:741 src/scm/webid-oidc/program.scm:813 +#: src/scm/webid-oidc/program.scm:756 src/scm/webid-oidc/program.scm:826 #, scheme-format msgid "You must pass --~a to set the JWKS URI.\n" msgstr "Vous devez passer --~a pour définir l'URI du JWKS.\n" -#: src/scm/webid-oidc/program.scm:745 src/scm/webid-oidc/program.scm:817 +#: src/scm/webid-oidc/program.scm:760 src/scm/webid-oidc/program.scm:830 #, scheme-format msgid "You must pass --~a to set the authorization endpoint URI.\n" msgstr "" "Vous devez passer --~a pour définir l'URI du terminal d'autorisation.\n" -#: src/scm/webid-oidc/program.scm:749 src/scm/webid-oidc/program.scm:821 +#: src/scm/webid-oidc/program.scm:764 src/scm/webid-oidc/program.scm:834 #, scheme-format msgid "You must pass --~a to set the token endpoint URI.\n" msgstr "Vous devez passer --~a pour définir l'URI du terminal de jeton.\n" -#: src/scm/webid-oidc/program.scm:769 +#: src/scm/webid-oidc/program.scm:782 #, scheme-format msgid "You must pass --~a to set the application web ID.\n" msgstr "" "Vous devez passer --~a pour définir l'identifiant web de l’application.\n" -#: src/scm/webid-oidc/program.scm:773 +#: src/scm/webid-oidc/program.scm:786 #, scheme-format msgid "You must pass --~a to set the redirection URI.\n" msgstr "Vous devez passer --~a pour définir l'URI de redirection.\n" -#: src/scm/webid-oidc/program.scm:777 +#: src/scm/webid-oidc/program.scm:790 #, scheme-format msgid "You must pass --~a to set the informative client name.\n" msgstr "" "Vous devez passer --~a pour donner un nom pour l’application à titre " "informatif.\n" -#: src/scm/webid-oidc/program.scm:781 +#: src/scm/webid-oidc/program.scm:794 #, scheme-format msgid "You must pass --~a to set the informative client URI.\n" msgstr "" "Vous devez passer --~a pour définir l'URI du client, à titre informatif.\n" -#: src/scm/webid-oidc/program.scm:809 +#: src/scm/webid-oidc/program.scm:822 #, scheme-format msgid "You must pass --~a to set the subject’s encrypted password.\n" msgstr "" "Vous devez passer --~a pour définir le mot de passe chiffré du sujet.\n" -#: src/scm/webid-oidc/program.scm:868 +#: src/scm/webid-oidc/program.scm:877 #, scheme-format msgid "Unknown command ~s\n" msgstr "Commande inconnue ~s\n" diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index acd9ec9..3e92bd3 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -46,7 +46,8 @@ dist_webidoidcmod_DATA += \ %reldir%/rdf-index.scm \ %reldir%/http-link.scm \ %reldir%/offloading.scm \ - %reldir%/catalog.scm + %reldir%/catalog.scm \ + %reldir%/parameters.scm webidoidcgo_DATA += \ %reldir%/errors.go \ @@ -80,7 +81,8 @@ webidoidcgo_DATA += \ %reldir%/rdf-index.go \ %reldir%/http-link.go \ %reldir%/offloading.go \ - %reldir%/catalog.go + %reldir%/catalog.go \ + %reldir%/parameters.go EXTRA_DIST += %reldir%/ChangeLog diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm index 9c57326..acdc56f 100644 --- a/src/scm/webid-oidc/access-token.scm +++ b/src/scm/webid-oidc/access-token.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-configuration) #: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) @@ -206,8 +207,7 @@ (alg #f) (webid #f) (iss #f) - (iat #f) - (exp #f) + (validity 3600) (client-key #f) (cnf/jkt #f) (client-id #f)) @@ -216,6 +216,7 @@ (access-token-encode (make-access-token `((alg . ,(if (symbol? alg) (symbol->string alg) alg))) - (make-access-token-payload - webid iss iat exp cnf/jkt client-id)) + (let ((iat (time-second (date->time-utc ((p:current-date)))))) + (make-access-token-payload + webid iss iat (+ iat validity) cnf/jkt client-id))) issuer-key)) diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm index 3a0da3b..267d67a 100644 --- a/src/scm/webid-oidc/authorization-code.scm +++ b/src/scm/webid-oidc/authorization-code.scm @@ -19,6 +19,7 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc jws) #:use-module (webid-oidc jti) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (srfi srfi-19)) @@ -129,28 +130,26 @@ (string->uri (assq-ref (the-authorization-code-payload code) 'client_id))) -(define-public (authorization-code-decode current-time jti-list str jwk) - (when (date? current-time) - (set! current-time (date->time-utc current-time))) - (when (time? current-time) - (set! current-time (time-second current-time))) - (with-exception-handler - (lambda (error) - (raise-cannot-decode-authorization-code str error)) - (lambda () - (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk))))) - (let ((exp (time-second (date->time-utc (authorization-code-exp code))))) - (unless (<= current-time exp) - (raise-authorization-code-expired exp current-time)) - (unless (jti-check current-time (authorization-code-jti code) - jti-list - (- exp current-time)) - (with-exception-handler - (lambda (error) - (raise-jti-found (authorization-code-jti code) error)) - (lambda () - (error "the jti-check function returned #f")))) - code))))) +(define-public (authorization-code-decode str jwk) + (parameterize ((p:current-date + (time-second (date->time-utc ((p:current-date)))))) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-authorization-code str error)) + (lambda () + (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk))))) + (let ((exp (time-second (date->time-utc (authorization-code-exp code)))) + (current-time (time-second (date->time-utc ((p:current-date)))))) + (unless (<= current-time exp) + (raise-authorization-code-expired exp current-time)) + (unless (jti-check (authorization-code-jti code) + (- exp current-time)) + (with-exception-handler + (lambda (error) + (raise-jti-found (authorization-code-jti code) error)) + (lambda () + (error "the jti-check function returned #f")))) + code)))))) (define-public (authorization-code-encode authorization-code key) (with-exception-handler diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm index 9ff994c..d5591b7 100644 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ b/src/scm/webid-oidc/authorization-endpoint.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc authorization-code) #: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) @@ -35,8 +36,7 @@ (define*-public (make-authorization-endpoint subject encrypted-password alg jwk validity #:key - (http-get http-get) - (current-time current-time)) + (http-get http-get)) (define (parse-arg x decode-plus-to-space?) (map (lambda (x) (uri-decode x @@ -90,16 +90,9 @@ (lambda (error) (error-application locale error)) (lambda () - (let* ((current-time (if (thunk? current-time) - (current-time) - current-time)) + (let* ((current-time ((p:current-date))) ;; current-date is a thunk parameter (current-sec - (cond ((date? current-time) - (time-second (date->time-utc current-time))) - ((time? current-time) - (time-second current-time)) - ((integer? current-time) - current-time))) + (time-second (date->time-utc current-time))) (exp-sec (+ current-sec validity)) (exp (time-utc->date (make-time time-utc 0 exp-sec))) (code (issue-authorization-code alg jwk exp subject client-id))) diff --git a/src/scm/webid-oidc/cache.scm b/src/scm/webid-oidc/cache.scm index dbf0112..e98f87f 100644 --- a/src/scm/webid-oidc/cache.scm +++ b/src/scm/webid-oidc/cache.scm @@ -16,6 +16,7 @@ (define-module (webid-oidc cache) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web client) #:use-module (web request) #:use-module (web response) @@ -24,7 +25,17 @@ #:use-module (ice-9 receive) #:use-module (ice-9 optargs) #:use-module (srfi srfi-19) - #:use-module (rnrs bytevectors)) + #:use-module (rnrs bytevectors) + #:export + ( + clean-cache + add + read + varies? + valid? + revalidate + with-cache + )) ;; The cache follows the recommendations of ;; https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching @@ -48,36 +59,26 @@ ;; There is a global lock file at the root of the cache, which serves ;; for region locking. Do not remove it! -(define (default-cache-dir) - (let ((xdg-cache-home - (or (getenv "XDG_CACHE_HOME") - (format #f "~a/.cache" (getenv "HOME"))))) - (format #f "~a/disfluid" xdg-cache-home))) +(define (web-cache-dir) + (string-append (p:cache-home) "/web-cache/")) -(define (web-cache-dir dir) - (when (thunk? dir) - (set! dir (dir))) - (string-append dir - "/web-cache/")) - -(define (file-name uri dir) +(define (file-name uri) (when (string? uri) (set! uri (string->uri uri))) - (string-append (web-cache-dir dir) + (string-append (web-cache-dir) (stubs:hash 'SHA-256 (uri->string uri)))) -(define (lock-file-name dir) - (string-append (web-cache-dir dir) ".lock")) +(define (lock-file-name) + (string-append (web-cache-dir) ".lock")) (define (event? percents) (<= (* (random:uniform) 100) percents)) -(define*-public (clean-cache - #:key - (percents 5) - (dir default-cache-dir)) - (define lock-file (lock-file-name dir)) +(define* (clean-cache + #:key + (percents 5)) + (define lock-file (lock-file-name)) (define (survives?) (not (event? percents))) (define (enter? name stat result) @@ -104,14 +105,13 @@ name (strerror errno)) result) (file-system-fold enter? leaf down up skip error 0 - (web-cache-dir dir))) + (web-cache-dir))) (define (maybe-clean-cache pc-happen - pc-cleaned - dir) + pc-cleaned) (when (event? pc-happen) - (clean-cache #:percents pc-cleaned #:dir dir))) + (clean-cache #:percents pc-cleaned))) (define (remove-uncacheable-headers response) (let ((headers (response-headers response))) @@ -129,16 +129,15 @@ #:headers filtered #:port #f)))) -(define*-public (add request response response-body - #:key (dir default-cache-dir)) +(define (add request response response-body) ;; Don’t store it if there’s a cache-control no-store (unless (let ((cc (response-cache-control response '()))) (assq-ref cc 'no-store)) (set! response (remove-uncacheable-headers response)) - (let ((final-file-name (file-name (request-uri request) dir)) - (lock-file (lock-file-name dir))) - (maybe-clean-cache 5 5 dir) + (let ((final-file-name (file-name (request-uri request))) + (lock-file (lock-file-name))) + (maybe-clean-cache 5 5) (stubs:atomically-update-file final-file-name lock-file @@ -152,14 +151,8 @@ (write-response-body file-response response-body)) #t)))))) -(define (the-current-time) - (time-utc->date - (current-time))) - -(define*-public (read uri - #:key - (dir default-cache-dir)) - (let ((final-file-name (file-name uri dir))) +(define (read uri) + (let ((final-file-name (file-name uri))) (catch 'system-error (lambda () (call-with-input-file final-file-name @@ -183,60 +176,46 @@ (or (varies-header? request-a request-b (car headers)) (varies-any-header? request-a request-b (cdr headers))))) -(define-public (varies? request-a request-b response) +(define (varies? request-a request-b response) (let ((vary (response-vary response))) (or (eq? vary '*) (varies-any-header? request-a request-b vary)))) -(define*-public (valid? response - #:key - (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))) - (set! current-time - (date->time-utc current-time)) - (set! current-time - (time-second current-time)) - (let ((cc (response-cache-control response #f)) - (date (response-date response - (time-utc->date - (make-time time-utc 0 current-time)))) - (last-modified (response-last-modified response))) - (set! date (date->time-utc date)) - (set! date (time-second date)) - (when last-modified - (set! last-modified (date->time-utc last-modified)) - (set! last-modified (time-second last-modified))) - (if cc - ;; Use cache-control - (let ((cc-no-cache (assq-ref cc 'no-cache)) - (cc-no-store (assq-ref cc 'no-store)) - (cc-max-age - (or (assq-ref cc 'max-age) - ;; Heuristic freshness - (and last-modified - (/ (- date last-modified) 10))))) - (and (not cc-no-cache) - (not cc-no-store) - cc-max-age - (>= (+ date cc-max-age) current-time))) - ;; Use expires - (let ((exp (response-expires response))) - (when exp - (set! exp (date->time-utc exp)) - (set! exp (time-second exp))) - (and exp - (>= exp current-time)))))) +(define (valid? response) + ;; current-date is a thunk parameter + (let* ((current-date ((p:current-date))) + (current-time (time-second (date->time-utc current-date)))) + (let ((cc (response-cache-control response #f)) + (date (time-second (date->time-utc (response-date response current-date)))) + (last-modified + (let ((as-date (response-last-modified response))) + (and as-date + (time-second (date->time-utc as-date)))))) + (if cc + ;; Use cache-control + (let ((cc-no-cache (assq-ref cc 'no-cache)) + (cc-no-store (assq-ref cc 'no-store)) + (cc-max-age + (or (assq-ref cc 'max-age) + ;; Heuristic freshness + (and last-modified + (/ (- date last-modified) 10))))) + (and (not cc-no-cache) + (not cc-no-store) + cc-max-age + (>= (+ date cc-max-age) current-time))) + ;; Use expires + (let ((exp + (let ((as-date (response-expires response))) + (and as-date + (time-second (date->time-utc as-date)))))) + (and exp + (>= exp current-time))))))) -(define*-public (revalidate uri response body - #:key - (headers '()) - (http-get http-get)) +(define* (revalidate uri response body + #:key + (headers '()) + (http-get http-get)) (define (keep-header? h) (case (car h) ((if-none-match if-unmodified-since) #f) @@ -266,20 +245,14 @@ (values new-response new-response-body))) (http-get uri #:headers headers)))) -(define*-public (with-cache - #:key - (current-time the-current-time) - (http-get http-get) - (dir default-cache-dir)) +(define* (with-cache #:key (http-get http-get)) (lambda* (uri #:key (headers '())) (when (string? uri) (set! uri (string->uri uri))) - (let ((dir (if (thunk? dir) (dir) dir)) - (request (build-request uri #:headers headers))) - (receive (stored-request stored-response body) - (read uri #:dir dir) + (let ((request (build-request uri #:headers headers))) + (receive (stored-request stored-response body) (read uri) (if stored-response - (let ((valid (valid? stored-response #:current-time the-current-time)) + (let ((valid (valid? stored-response)) (invariant (not (varies? request stored-request stored-response)))) (unless invariant (format (current-error-port) "Cache entry for ~a varies.\n" (uri->string uri))) @@ -289,9 +262,9 @@ (revalidate uri stored-response body #:headers headers #:http-get http-get) - (add request final-response final-body #:dir dir) + (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 #:dir dir) + (add request final-response final-body) (values final-response final-body))))))) diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index e8796c0..67928db 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -21,8 +21,8 @@ #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc jwk) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) - #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (web uri) #:use-module (web client) @@ -174,28 +174,17 @@ (raise-no-provider-candidates host-or-webid candidate-errors)) final-candidates)))))) -(define the-current-time current-time) - (define*-public (token host client-key #:key (authorization-code #f) (refresh-token #f) (http-get http-get) - (http-post http-post) - (current-time #f)) + (http-post http-post)) (unless (or authorization-code refresh-token) (scm-error 'wrong-type-arg "token" "You need to either set #:authorization-code or #:refresh-token." '() (list authorization-code))) - (unless current-time - (set! current-time the-current-time)) - (when (thunk? current-time) - (set! current-time (current-time))) - (when (integer? current-time) - (set! current-time (make-time time-utc 0 current-time))) - (when (time? current-time) - (set! current-time (time-utc->date current-time))) (let ((token-endpoint (oidc-configuration-token-endpoint (get-oidc-configuration host #:http-get http-get))) @@ -212,8 +201,7 @@ (else (error "Unknown key type of ~S." client-key))) #:htm 'POST - #:htu token-endpoint - #:iat current-time))) + #:htu token-endpoint))) (receive (response response-body) (http-post token-endpoint #:body @@ -253,17 +241,7 @@ (raise-unexpected-header-value 'content-type (response-content-type response))) (stubs:json-string->scm response-body))))))))) -(define (default-dir) - (let ((xdg-data-home - (or - (getenv "XDG_DATA_HOME") - (format #f "~a/.local/share" - (getenv "HOME"))))) - (format #f "~a/disfluid" xdg-data-home))) - -(define*-public (list-profiles #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define-public (list-profiles) (map (lambda (profile) (list (string->uri (car profile)) ;; webid @@ -272,20 +250,17 @@ (cadddr profile))) ;; key (catch #t (lambda () - (call-with-input-file (string-append dir "/profiles") + (call-with-input-file (string-append (p:data-home) "/profiles") read)) (lambda error (format (current-error-port) "Could not read profiles: ~s\n" error) '())))) -(define* (add-profile webid issuer refresh-token key - #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) - (let ((other-profiles (list-profiles #:dir dir))) +(define (add-profile webid issuer refresh-token key) + (let ((other-profiles (list-profiles))) (stubs:atomically-update-file - (string-append dir "/profiles") - (string-append dir "/profiles.lock") + (string-append (p:data-home) "/profiles") + (string-append (p:data-home) "/profiles.lock") (lambda (port) (write (map (lambda (profile) @@ -304,12 +279,8 @@ #:key (client-id #f) (redirect-uri #f) - (dir default-dir) (http-get http-get) - (http-post http-post) - (current-time #f)) - (when (thunk? dir) - (set! dir (dir))) + (http-post http-post)) (let ((host/webid (get-host/webid))) (let ((authorization-uris (authorize host/webid @@ -324,8 +295,7 @@ (token host/webid key #:authorization-code authz-code #:http-get http-get - #:http-post http-post - #:current-time current-time))) + #:http-post http-post))) (let ((id-token (id-token-decode (assq-ref params 'id_token) #:http-get http-get)) (access-token (assq-ref params 'access_token)) @@ -335,16 +305,13 @@ (add-profile (id-token-webid id-token) (id-token-iss id-token) refresh-token - key - #:dir dir)) + key)) (values (cdr id-token) access-token key))))))))) (define*-public (login webid issuer refresh-token key #:key - (dir default-dir) (http-get http-get) - (http-post http-post) - (current-time #f)) + (http-post http-post)) (when (string? webid) (set! webid (string->uri webid))) (when (string? issuer) @@ -354,8 +321,7 @@ (token iss-host key #:refresh-token refresh-token #:http-get http-get - #:http-post http-post - #:current-time current-time))) + #:http-post http-post))) (let ((id-token (id-token-decode (assq-ref params 'id_token) #:http-get http-get)) (access-token (assq-ref params 'access_token)) @@ -366,30 +332,25 @@ (add-profile (id-token-webid id-token) (id-token-iss id-token) refresh-token - key - #:dir dir)) + key)) (values (cdr id-token) access-token key))))) (define*-public (refresh id-token key #:key - (dir default-dir) (http-get http-get) - (http-post http-post) - (current-time #f)) - (when (thunk? dir) - (set! dir (dir))) + (http-post http-post)) (when (id-token-payload? id-token) ;; For convenience, we’d like a full ID token to use the ID token ;; API. (set! id-token (cons `((alg . "HS256")) id-token))) - (let ((profiles (list-profiles #:dir dir))) + (let ((profiles (list-profiles))) (letrec ((find-refresh-token (lambda (profiles) (when (null? profiles) (raise-profile-not-found (id-token-webid id-token) (id-token-iss id-token) - dir)) + (p:data-home))) (let ((prof (car profiles)) (others (cdr profiles))) (let ((webid (car prof)) @@ -403,15 +364,12 @@ (id-token-iss id-token) (find-refresh-token (profiles)) key - #:dir dir #:http-get http-get - #:http-post http-post - #:current-time current-time)))) + #:http-post http-post)))) (define* (renew-if-expired id-token access-token key date #:key - (dir default-dir) (http-get http-get) (http-post http-post)) ;; Since we’re not supposed to decode the access token, we’re @@ -427,25 +385,22 @@ (set! exp (date->time-utc exp)) (set! exp (time-second exp)) (if (>= date exp) - (refresh id-token key - #:dir dir - #:http-get http-get - #:http-post http-post - #:current-time date) + (parameterize ((p:current-date (lambda () date))) + (refresh id-token key + #:http-get http-get + #:http-post http-post)) (values id-token access-token key)))) (define*-public (make-client id-token access-token key #:key - (dir default-dir) (http-get http-get) (http-post http-post) - (http-request http-request) - (current-time the-current-time)) + (http-request http-request)) ;; HACK: guile does not support other authentication schemes in ;; WWW-Authenticate than Basic, so it will crash when a response ;; containing that header will be issued. (declare-header! "WWW-Authenticate" string->symbol symbol? write) - (define (handler uri method headers other-args current-time retry?) + (define (handler uri method headers other-args retry?) (let ((proof (issue-dpop-proof key #:alg (case (kty key) @@ -455,7 +410,6 @@ (error "Unknown key type of ~S." key))) #:htm method #:htu uri - #:iat current-time #:access-token access-token))) (receive (response response-body) (apply http-request uri @@ -470,7 +424,6 @@ ;; Maybe the access token has expired? (receive (new-id-token new-access-token new-key) (renew-if-expired id-token access-token key server-date - #:dir dir #:http-get http-get #:http-post http-post) (if (equal? access-token new-access-token) @@ -481,18 +434,11 @@ (set! id-token new-id-token) (set! access-token new-access-token) (set! key new-key) - (handler uri method headers other-args current-time #f)))) + (handler uri method headers other-args #f)))) (values response response-body)))))) (define (parse-args uri method headers other-args-rev rest) (if (null? rest) - (let ((the-current-time current-time)) - (when (thunk? the-current-time) - (set! the-current-time (the-current-time))) - (when (integer? the-current-time) - (set! the-current-time (make-time time-utc 0 the-current-time))) - (when (time? the-current-time) - (set! the-current-time (time-utc->date the-current-time))) - (handler uri method headers (reverse other-args-rev) the-current-time #t)) + (handler uri method headers (reverse other-args-rev) #t) (let ((kw (car rest))) (case kw ((#:method) @@ -618,5 +564,3 @@ (title "Not Found")) (body (p "This page does not exist on the server.")))))))))))))) - - diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm index 54b338b..2ccbddc 100644 --- a/src/scm/webid-oidc/dpop-proof.scm +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc jti) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (ice-9 optargs) #:use-module (srfi srfi-19)) @@ -186,51 +187,51 @@ (uri-path b)))) (raise-dpop-uri-mismatch a b))) -(define*-public (dpop-proof-decode current-time jti-list method uri str cnf/check +(define*-public (dpop-proof-decode method uri str cnf/check #:key (access-token #f)) - (when (date? current-time) - (set! current-time (date->time-utc current-time))) - (when (time? current-time) - (set! current-time (time-second current-time))) - (with-exception-handler - (lambda (error) - (raise-cannot-decode-dpop-proof str error)) - (lambda () - (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk)))) - (unless (eq? method (dpop-proof-htm decoded)) - (raise-dpop-method-mismatch (dpop-proof-htm decoded) method)) - (uris-compatible (dpop-proof-htu decoded) - (if (string? uri) - (string->uri uri) - uri)) - (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded))))) - (unless (>= current-time (- iat 5)) - (raise-dpop-signed-in-future iat current-time)) - (unless (<= current-time (+ iat 120)) ;; Valid for 2 min - (raise-dpop-too-old iat current-time))) - (when access-token - (let ((h (stubs:hash 'SHA-256 access-token))) - (unless (equal? (dpop-proof-ath decoded) h) - (raise-exception - (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token))))) - (if (string? cnf/check) - (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded))) - (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f)) - (with-exception-handler - (lambda (error) - (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error)) - (lambda () - (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded))) - ;; deprecated; throw an error instead! - (error "the cnf/check function returned #f"))))) - (unless (jti-check current-time (dpop-proof-jti decoded) jti-list 120) - (with-exception-handler - (lambda (error) - (raise-jti-found (dpop-proof-jti decoded) error)) - (lambda () - (error "the jti-check function returned #f")))) - decoded)))) + (let ((current-time + (time-second (date->time-utc ((p:current-date)))))) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-dpop-proof str error)) + (lambda () + (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk)))) + (unless (eq? method (dpop-proof-htm decoded)) + (raise-dpop-method-mismatch (dpop-proof-htm decoded) method)) + (uris-compatible (dpop-proof-htu decoded) + (if (string? uri) + (string->uri uri) + uri)) + (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded))))) + (unless (>= current-time (- iat 5)) + (raise-dpop-signed-in-future iat current-time)) + (unless (<= current-time (+ iat 120)) ;; Valid for 2 min + (raise-dpop-too-old iat current-time))) + (when access-token + (let ((h (stubs:hash 'SHA-256 access-token))) + (unless (equal? (dpop-proof-ath decoded) h) + (raise-exception + (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token))))) + (if (string? cnf/check) + (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f)) + (with-exception-handler + (lambda (error) + (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error)) + (lambda () + (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + ;; deprecated; throw an error instead! + (error "the cnf/check function returned #f"))))) + (parameterize ((p:current-date current-time)) + ;; jti-check should use the same date. + (unless (jti-check (dpop-proof-jti decoded) 120) + (with-exception-handler + (lambda (error) + (raise-jti-found (dpop-proof-jti decoded) error)) + (lambda () + (error "the jti-check function returned #f")))) + decoded)))))) (define-public (dpop-proof-encode dpop-proof key) (with-exception-handler @@ -245,11 +246,10 @@ (alg #f) (htm #f) (htu #f) - (iat #f) (access-token #f)) (dpop-proof-encode (make-dpop-proof (make-dpop-proof-header alg client-key) - (make-dpop-proof-payload (stubs:random 12) htm htu iat + (make-dpop-proof-payload (stubs:random 12) htm htu ((p:current-date)) (and access-token (stubs:hash 'SHA-256 access-token)))) client-key)) diff --git a/src/scm/webid-oidc/hello-world.scm b/src/scm/webid-oidc/hello-world.scm index 8e68359..d752aae 100644 --- a/src/scm/webid-oidc/hello-world.scm +++ b/src/scm/webid-oidc/hello-world.scm @@ -17,7 +17,6 @@ (define-module (webid-oidc hello-world) #:use-module (webid-oidc resource-server) #:use-module (webid-oidc server log) - #:use-module (webid-oidc jti) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (web request) #:use-module (web response) @@ -112,7 +111,6 @@ Options: (G_ "You are legally required to link to the complete corresponding source code.\n")) (exit 1)) str)) - (jti-list (make-jti-list)) (log-file (option-ref options log-file-sym #f)) (error-file (option-ref options error-file-sym #f))) (unless (and (string->number port-string) diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index 8bd3e5b..e22f1ef 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -57,9 +57,7 @@ jwks-uri authorization-endpoint-uri token-endpoint-uri - jti-list #:key - (current-time current-time) (http-get http-get)) (let ((key (catch #t @@ -80,11 +78,9 @@ 'ES256))) (let ((authorization-endpoint (make-authorization-endpoint subject encrypted-password alg key 120 - #:current-time current-time #:http-get http-get)) (token-endpoint - (make-token-endpoint token-endpoint-uri issuer alg key 3600 jti-list - #:current-time current-time)) + (make-token-endpoint token-endpoint-uri issuer alg key 3600)) (openid-configuration (make-oidc-configuration jwks-uri authorization-endpoint-uri diff --git a/src/scm/webid-oidc/jti.scm b/src/scm/webid-oidc/jti.scm index 4713d7d..cf05bbb 100644 --- a/src/scm/webid-oidc/jti.scm +++ b/src/scm/webid-oidc/jti.scm @@ -15,36 +15,42 @@ ;; along with this program. If not, see <https://www.gnu.org/licenses/>. (define-module (webid-oidc jti) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (ice-9 atomic) #:use-module (ice-9 threads) - #:use-module (srfi srfi-19)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:export (jti-check)) -(define-public (make-jti-list) +(define jti-list (make-atomic-box '())) -(define-public (lookup list jti) - (if (null? list) - #f - (or (string=? (assq-ref (car list) 'jti) jti) - (lookup (cdr list) jti)))) - -(define-public (jti-check current-time jti list valid-time) - (when (date? current-time) - (set! current-time (date->time-utc current-time))) - (when (time? current-time) - (set! current-time (time-second current-time))) - (let* ((old (atomic-box-ref list)) - (new-entry `((exp . ,(+ current-time valid-time)) - (jti . ,jti))) +(define-record-type <jti-item> + (make-jti-item exp jti) + jti-item? + (exp jti-item-exp) + (jti jti-item-jti)) + +(define lookup + (match-lambda* + ((() item) #f) + (((($ <jti-item> exp jti) other ...) item) + (or (string=? jti item) + (lookup other item))))) + +(define (jti-check jti valid-time) + (let* ((current-time + (time-second (date->time-utc ((p:current-date))))) + (old (atomic-box-ref jti-list)) + (new-entry (make-jti-item (+ current-time valid-time) jti)) (new (filter - (lambda (entry) - (let ((exp (assq-ref entry 'exp))) - (>= exp current-time))) + (match-lambda + (($ <jti-item> exp other-jti) + (>= exp current-time))) (cons new-entry old)))) - (let ((present? (lookup old jti))) - (if present? - #f - (let ((discarded (atomic-box-compare-and-swap! list old new))) - (if (eq? discarded old) - #t - (jti-check current-time jti list valid-time))))))) + (and (not (lookup old jti)) + (let ((discarded (atomic-box-compare-and-swap! jti-list old new))) + (if (eq? discarded old) + #t + (jti-check jti valid-time)))))) diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm index 9fe276c..e95efaf 100644 --- a/src/scm/webid-oidc/oidc-id-token.scm +++ b/src/scm/webid-oidc/oidc-id-token.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jws) #:use-module (webid-oidc jti) #: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) @@ -206,12 +207,13 @@ (iss #f) (sub #f) (aud #f) - (exp #f) - (iat #f)) + (validity 3600)) (unless sub (set! sub webid)) (id-token-encode (make-id-token `((alg . ,(symbol->string alg))) - (make-id-token-payload webid iss sub aud (stubs:random 12) exp iat)) + (let ((iat (time-second (date->time-utc ((p:current-date)))))) + (make-id-token-payload webid iss sub aud (stubs:random 12) + (+ iat validity) iat))) issuer-key)) diff --git a/src/scm/webid-oidc/parameters.scm b/src/scm/webid-oidc/parameters.scm new file mode 100644 index 0000000..3b24361 --- /dev/null +++ b/src/scm/webid-oidc/parameters.scm @@ -0,0 +1,34 @@ +(define-module (webid-oidc parameters) + #:use-module (srfi srfi-19) + #:use-module (webid-oidc jti) + #:export (data-home cache-home current-date)) + +(define data-home + (make-parameter + (format #f "~a/disfluid" + (or (getenv "XDG_DATA_HOME") + (format #f "~a/.local/share" + (getenv "HOME")))))) + +(define cache-home + (make-parameter + (format #f "~a/disfluid" + (or (getenv "XDG_CACHE_HOME") + (format #f "~a/.cache" + (getenv "HOME")))))) + +(define current-date + ;; This parameter is a thunk! + (make-parameter + (lambda () + (time-utc->date (current-time))) + (lambda (thunk) + (lambda () + (let ((date (if (thunk? thunk) + (thunk) + thunk))) + (when (integer? date) + (set! date (make-time time-utc 0 date))) + (when (time? date) + (set! date (time-utc->date date))) + date))))) diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index 2eda34c..9d65b70 100644 --- a/src/scm/webid-oidc/program.scm +++ b/src/scm/webid-oidc/program.scm @@ -25,6 +25,7 @@ #:use-module (webid-oidc jti) #:use-module (webid-oidc offloading) #:use-module (webid-oidc catalog) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (ice-9 optargs) @@ -103,81 +104,95 @@ (prepare-log-file log-file)) (when error-file (prepare-error-file error-file)) - (call/ec - (lambda (return) - (with-exception-handler - (lambda (error) - (with-mutex logging-mutex - (format (current-error-port) - (G_ "~a: ~a: Internal server error: ~a\n") - (date->string (time-utc->date (current-time))) - (request-ip-address request) - (error->str error))) - (return - (build-response #:code 500 - #:reason-phrase "Internal Server Error" - #:headers `((source . ,complete-corresponding-source))) - "Sorry, there was an error.")) - (lambda () - (with-exception-handler - (lambda (error) - (with-mutex logging-mutex - (format (current-error-port) - (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n") - ((record-accessor &unknown-client-locale 'web-locale) error) - ((record-accessor &unknown-client-locale 'c-locale) error) - (error->str error)))) - (lambda () - (receive (response response-body user cause) - (call-with-values - (lambda () - (handler request request-body)) - (case-lambda - ((response response-body) - (values response response-body #f #f)) - ((response response-body user) - (values response response-body user #f)) - ((response response-body user cause) - (values response response-body user cause)))) - (let ((logging-port - (let ((response-code (response-code response))) - (if (>= response-code 400) - ;; That’s an error - (current-error-port) - (current-output-port))))) + (parameterize ((p:data-home + (string-append + (or (getenv "XDG_DATA_HOME") + (string-append (getenv "HOME") "/.local/share")) + "/disfluid")) + (p:cache-home + (string-append + (or (getenv "XDG_CACHE_HOME") + (string-append (getenv "HOME") "/.cache")) + "/disfluid")) + ;; Fix the date + (p:current-date ((p:current-date)))) + (call/ec + (lambda (return) + (with-exception-handler + (lambda (error) + (with-mutex logging-mutex + (format (current-error-port) + (G_ "~a: ~a: Internal server error: ~a\n") + (date->string ((p:current-date))) + (request-ip-address request) + (error->str error))) + (return + (build-response #:code 500 + #:reason-phrase "Internal Server Error" + #:headers `((source . ,complete-corresponding-source) + (date . ,((p:current-date))))) + "Sorry, there was an error.")) + (lambda () + (with-exception-handler + (lambda (error) (with-mutex logging-mutex - (format logging-port - (G_ "~a: ~s ~a ~s ~a\n") - (if user - (format #f (G_ "~a: ~a (~a)") - (date->string (time-utc->date (current-time))) - (uri->string user) - (request-ip-address request)) - (format #f (G_ "~a: ~a") - (date->string (time-utc->date (current-time))) - (request-ip-address request))) - (request-method request) - (uri-path (request-uri request)) - (response-code response) - (if cause - (string-append - (response-reason-phrase response) - " " - (format #f (G_ "(there was an error: ~a)") - (error->str cause))) - (response-reason-phrase response))))) - (return - (build-response - #:version (response-version response) - #:code (response-code response) - #:reason-phrase (response-reason-phrase response) - #:headers (cons `(source . ,complete-corresponding-source) - (response-headers response)) - #:port (response-port response) - #:validate-headers? #t) - response-body))) - #:unwind? #t - #:unwind-for-type &unknown-client-locale))))))) + (format (current-error-port) + (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n") + ((record-accessor &unknown-client-locale 'web-locale) error) + ((record-accessor &unknown-client-locale 'c-locale) error) + (error->str error)))) + (lambda () + (receive (response response-body user cause) + (call-with-values + (lambda () + (handler request request-body)) + (case-lambda + ((response response-body) + (values response response-body #f #f)) + ((response response-body user) + (values response response-body user #f)) + ((response response-body user cause) + (values response response-body user cause)))) + (let ((logging-port + (let ((response-code (response-code response))) + (if (>= response-code 400) + ;; That’s an error + (current-error-port) + (current-output-port))))) + (with-mutex logging-mutex + (format logging-port + (G_ "~a: ~s ~a ~s ~a\n") + (if user + (format #f (G_ "~a: ~a (~a)") + (date->string (time-utc->date (current-time))) + (uri->string user) + (request-ip-address request)) + (format #f (G_ "~a: ~a") + (date->string (time-utc->date (current-time))) + (request-ip-address request))) + (request-method request) + (uri-path (request-uri request)) + (response-code response) + (if cause + (string-append + (response-reason-phrase response) + " " + (format #f (G_ "(there was an error: ~a)") + (error->str cause))) + (response-reason-phrase response))))) + (return + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers `((source . ,complete-corresponding-source) + (date . ,((p:current-date))) + ,@(response-headers response)) + #:port (response-port response) + #:validate-headers? #t) + response-body))) + #:unwind? #t + #:unwind-for-type &unknown-client-locale)))))))) (define (serve-one-client* handler implementation server state) ;; Same as serve-one-client, except it is served in a promise. @@ -753,8 +768,6 @@ Rreleased ~a\n") (make-identity-provider server-name key-file subject encrypted-password jwks-uri authorization-endpoint-uri token-endpoint-uri - (make-jti-list) - #:current-time current-time #:http-get cache-http-get))) (run-server* (handler-with-log @@ -821,49 +834,45 @@ Rreleased ~a\n") (format (current-error-port) (G_ "You must pass --~a to set the token endpoint URI.\n") token-endpoint-uri-sym) (exit 1)) - (let ((jti-list (make-jti-list))) - (let ((resource-handler - (make-resource-server - #:server-uri server-name - #:owner subject - #:authenticator - (if header - (begin - (set! header - (string->symbol - (string-downcase - (symbol->string header)))) - (lambda (request request-body) - (let ((value (assq-ref (request-headers request) header))) - (and value (string->uri value))))) - (make-authenticator - jti-list - #:server-uri server-name - #:http-get cache-http-get)) - #:http-get cache-http-get)) - (identity-provider-handler - (make-identity-provider - server-name key-file subject encrypted-password jwks-uri - authorization-endpoint-uri token-endpoint-uri - jti-list - #:current-time current-time - #:http-get cache-http-get))) - (create-root server-name subject) - (run-server* - (handler-with-log - (option-ref options log-file-sym #f) - (option-ref options error-file-sym #f) - complete-corresponding-source - (lambda (request request-body) - (let ((path (uri-path (request-uri request)))) - (if (or (equal? path "/.well-known/openid-configuration") - (equal? path (uri-path jwks-uri)) - (equal? path (uri-path authorization-endpoint-uri)) - (equal? path (uri-path token-endpoint-uri))) - (identity-provider-handler request request-body) - (resource-handler request request-body))))) - 'http - (list #:port port))))) + (let ((resource-handler + (make-resource-server + #:server-uri server-name + #:owner subject + #:authenticator + (if header + (begin + (set! header + (string->symbol + (string-downcase + (symbol->string header)))) + (lambda (request request-body) + (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)) + (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))) + (create-root server-name subject) + (run-server* + (handler-with-log + (option-ref options log-file-sym #f) + (option-ref options error-file-sym #f) + complete-corresponding-source + (lambda (request request-body) + (let ((path (uri-path (request-uri request)))) + (if (or (equal? path "/.well-known/openid-configuration") + (equal? path (uri-path jwks-uri)) + (equal? path (uri-path authorization-endpoint-uri)) + (equal? path (uri-path token-endpoint-uri))) + (identity-provider-handler request request-body) + (resource-handler request request-body))))) + 'http + (list #:port port)))) (else (format (current-error-port) (G_ "Unknown command ~s\n") command) diff --git a/src/scm/webid-oidc/refresh-token.scm b/src/scm/webid-oidc/refresh-token.scm index 34b2f1b..e3fbf7c 100644 --- a/src/scm/webid-oidc/refresh-token.scm +++ b/src/scm/webid-oidc/refresh-token.scm @@ -18,36 +18,33 @@ #:use-module (webid-oidc errors) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc jwk) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (ice-9 optargs) #:use-module (ice-9 threads) - #:use-module (srfi srfi-19)) + #:use-module (srfi srfi-19) + #:export + ( + list-refresh-tokens + update-refresh-token-list + issue-refresh-token + with-refresh-token + remove-refresh-token + )) -(define-public (default-dir) - (let ((xdg-data-home (or - (getenv "XDG_DATA_HOME") - (format #f "~a/.local/share" - (getenv "HOME"))))) - (format #f "~a/disfluid" xdg-data-home))) - -(define*-public (list-refresh-tokens - #:key - (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define (list-refresh-tokens) (catch #t (lambda () - (with-input-from-file (format #f "~a/refresh-tokens.scm" dir) + (with-input-from-file (format #f "~a/refresh-tokens.scm" (p:data-home)) read)) (lambda errors '()))) +;; TODO: use stubs:atomically-update-file and remove that mutex. (define mutex (make-mutex)) -(define* (set-refresh-token-list list - #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define (set-refresh-token-list list) + (define dir (p:data-home)) (define old-file (format #f "~a/refresh-tokens.scm" dir)) (define new-file (format #f "~a/refresh-tokens.scm~" dir)) (stubs:call-with-output-file* @@ -57,12 +54,11 @@ (close-port port))) (rename-file new-file old-file)) -(define*-public (update-refresh-token-list f - #:key (dir default-dir)) +(define (update-refresh-token-list f) (with-mutex mutex - (let ((old (list-refresh-tokens #:dir dir))) + (let ((old (list-refresh-tokens))) (let ((new (f old))) - (set-refresh-token-list new #:dir dir))))) + (set-refresh-token-list new))))) (define (remove sub aud) (lambda (old) @@ -90,20 +86,13 @@ (refresh_token . ,jti)) (remover old))))) -(define*-public (issue-refresh-token sub aud jkt - #:key - (dir default-dir)) +(define (issue-refresh-token sub aud jkt) (define jti (stubs:random 12)) - (update-refresh-token-list (insert sub aud jkt jti) - #:dir dir) + (update-refresh-token-list (insert sub aud jkt jti)) jti) -(define*-public (with-refresh-token refresh-token - key - f - #:key - (dir default-dir)) - (let ((list (list-refresh-tokens #:dir dir))) +(define (with-refresh-token refresh-token key f) + (let ((list (list-refresh-tokens))) (define (check list) (if (null? list) (raise-invalid-refresh-token refresh-token) @@ -121,7 +110,5 @@ (check tl)))))) (check list))) -(define*-public (remove-refresh-token sub aud - #:key - (dir default-dir)) - (update-refresh-token-list (remove sub aud) #:dir dir)) +(define (remove-refresh-token sub aud) + (update-refresh-token-list (remove sub aud))) diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index a6c111e..14d8b81 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -21,12 +21,13 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc serve) - #:use-module (webid-oidc server create) - #:use-module (webid-oidc server read) - #:use-module (webid-oidc server update) - #:use-module (webid-oidc server delete) + #:use-module ((webid-oidc server create) #:prefix ldp:) + #:use-module ((webid-oidc server read) #:prefix ldp:) + #:use-module ((webid-oidc server update) #:prefix ldp:) + #:use-module ((webid-oidc server delete) #:prefix ldp:) #:use-module (webid-oidc server precondition) #:use-module (webid-oidc http-link) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc config) #:prefix cfg:) #:use-module (webid-oidc jti) #:use-module (webid-oidc access-token) @@ -51,8 +52,7 @@ (car (reverse (string-split text #\|))) out))) -(define*-public (make-authenticator jti-list - #:key +(define*-public (make-authenticator #:key (server-uri #f) (current-time current-time) (http-get http-get)) @@ -62,52 +62,45 @@ (let ((headers (request-headers request)) (uri (request-uri request)) (method (request-method request)) - (current-time - (let ((t current-time)) - (when (thunk? t) - (set! t (t))) - (when (integer? t) - (set! t (make-time time-utc 0 t))) - (when (time? t) - (set! t (time-utc->date t))) - t))) - (let ((authz (assoc-ref headers 'authorization)) - (dpop (assoc-ref headers 'dpop)) - (full-uri (build-uri (uri-scheme server-uri) - #:userinfo (uri-userinfo server-uri) - #:host (uri-host server-uri) - #:port (uri-port server-uri) - #:path (string-append - "/" - (encode-and-join-uri-path - (append - (split-and-decode-uri-path (uri-path server-uri)) - (split-and-decode-uri-path - (uri-path uri)))))))) - (and authz dpop - (eq? (car authz) 'dpop) - (with-exception-handler - (lambda (error) - (format (current-error-port) - (G_ "~a: authentication failure: ~a\n") - (date->string current-time) - (error->str error)) - #f) - (lambda () - (let* ((lit-access-token (symbol->string (cadr authz))) - (access-token - (access-token-decode lit-access-token - #:http-get http-get)) - (cnf/jkt (access-token-cnf/jkt access-token)) - (dpop-proof - (dpop-proof-decode - current-time jti-list method full-uri - dpop cnf/jkt #:access-token lit-access-token))) - (let ((subject (access-token-webid access-token)) - (issuer (access-token-iss access-token))) - (confirm-provider subject issuer #:http-get http-get) - subject))) - #:unwind? #t)))))) + (current-time ((p:current-date)))) + (parameterize ((p:current-date current-time)) ;; fix the date + (let ((authz (assoc-ref headers 'authorization)) + (dpop (assoc-ref headers 'dpop)) + (full-uri (build-uri (uri-scheme server-uri) + #:userinfo (uri-userinfo server-uri) + #:host (uri-host server-uri) + #:port (uri-port server-uri) + #:path (string-append + "/" + (encode-and-join-uri-path + (append + (split-and-decode-uri-path (uri-path server-uri)) + (split-and-decode-uri-path + (uri-path uri)))))))) + (and authz dpop + (eq? (car authz) 'dpop) + (with-exception-handler + (lambda (error) + (format (current-error-port) + (G_ "~a: authentication failure: ~a\n") + (date->string current-time) + (error->str error)) + #f) + (lambda () + (let* ((lit-access-token (symbol->string (cadr authz))) + (access-token + (access-token-decode lit-access-token + #:http-get http-get)) + (cnf/jkt (access-token-cnf/jkt access-token)) + (dpop-proof + (dpop-proof-decode + method full-uri + dpop cnf/jkt #:access-token lit-access-token))) + (let ((subject (access-token-webid access-token)) + (issuer (access-token-iss access-token))) + (confirm-provider subject issuer #:http-get http-get) + subject))) + #:unwind? #t))))))) (define (handle-errors f g) (call/ec @@ -175,171 +168,170 @@ (server-uri #f) (owner #f) (authenticator #f) - (current-time current-time) (http-get http-get)) (unless owner (error "The owner is not defined.")) (declare-link-header!) (unless authenticator (set! authenticator - (make-authenticator (make-jti-list) - #:server-uri server-uri - #:current-time current-time - #:http-get http-get))) + (make-authenticator + #:server-uri server-uri + #:http-get http-get))) (lambda (request request-body) - (let ((user (authenticator request request-body))) - (handle-errors - (lambda (return) - (let ((method (request-method request))) - (case method - ((GET HEAD OPTIONS) - (receive (headers content) - (read server-uri owner user - (uri-path (request-uri request)) - #:http-get http-get) - (let ((true-content-type - (car (assq-ref headers 'content-type))) - (other-headers - (filter - (lambda (h) - (not (eq? (car h) 'content-type))) - headers))) - (receive (negociated-content-type - negociated-content) - (convert (request-accept request #f) - server-uri - (uri-path (request-uri request)) - true-content-type - content) - (serve-get - return - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - negociated-content-type - negociated-content - (car (assq-ref headers 'etag)) - (cons `(content-type ,negociated-content-type) - other-headers) - user))))) - ((PUT) - (receive (content-type content) - (nonrdf-or-turtle server-uri request request-body) - (return - (build-response - #:headers - `((etag . (,(update server-uri owner user - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - content-type - content - #:http-get http-get) - . #f)))) - "" - user))) - ((POST) - (receive (content-type content) - (nonrdf-or-turtle server-uri request request-body) - (let ((types - (map car - (filter - (lambda (link) - (equal? (assq-ref link 'rel) "type")) - (request-links request))))) + (parameterize ((p:current-date ((p:current-date)))) ;; Fix the date + (let ((user (authenticator request request-body))) + (handle-errors + (lambda (return) + (let ((method (request-method request))) + (case method + ((GET HEAD OPTIONS) + (receive (headers content) + (ldp:read server-uri owner user + (uri-path (request-uri request)) + #:http-get http-get) + (let ((true-content-type + (car (assq-ref headers 'content-type))) + (other-headers + (filter + (lambda (h) + (not (eq? (car h) 'content-type))) + headers))) + (receive (negociated-content-type + negociated-content) + (convert (request-accept request #f) + server-uri + (uri-path (request-uri request)) + true-content-type + content) + (serve-get + return + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + negociated-content-type + negociated-content + (car (assq-ref headers 'etag)) + (cons `(content-type ,negociated-content-type) + other-headers) + user))))) + ((PUT) + (receive (content-type content) + (nonrdf-or-turtle server-uri request request-body) (return (build-response - #:code 201 #:reason-phrase "Created" #:headers - `((location . ,(create server-uri owner user - (uri-path (request-uri request)) - types - (assq-ref (request-headers request) 'slug) - content-type - content - #:http-get http-get)))) + `((etag . (,(ldp:update server-uri owner user + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + content-type + content + #:http-get http-get) + . #f)))) "" - user)))) - ((DELETE) - (delete server-uri owner user - (uri-path (request-uri request)) - (request-if-match request) - (request-if-none-match request) - #:http-get http-get) - (return - (build-response) - "" - user))))) - (lambda (return error) - (if (cannot-fetch-group? error) - (format (current-error-port) (G_ "Warning: ~a\n") - (error->str error)) - (cond - ((uri-slash-semantics-error? error) - (return - (build-response - #:code 301 - #:reason-phrase "Found" - #:headers - `((location - . ,(build-uri - (uri-scheme server-uri) - #:userinfo (uri-userinfo server-uri) - #:host (uri-host server-uri) - #:port (uri-port server-uri) - #:path (uri-slash-semantics-error-expected-path error))))) - #f - user)) - ((or (path-not-found? error) - (auxiliary-resource-absent? error) - (forbidden? error)) - (if user - ;; That’s a forbidden - (return - (build-response #:code 403 #:reason-phrase "Forbidden") - #f - user) - (return - (build-response #:code 401 #:reason-phrase "Unauthorized" - #:headers `((www-authenticate . ((DPoP))))) - #f - user))) - ((or (cannot-delete-root? error)) - (return - (build-response - #:code 405 - #:reason-phrase "Method Not Allowed") - #f - user)) - ((or (container-not-empty? error) - (incorrect-containment-triples? error) - (path-is-auxiliary? error)) - (return - (build-response - #:code 409 - #:reason-phrase "Conflict") - #f - user)) - ((unsupported-media-type? error) - (return - (build-response - #:code 415 - #:reason-phrase "Unsupported Media Type") - #f - user)) - ((precondition-failed? error) - (return - (build-response - #:code 412 - #:reason-phrase "Precondition Failed") - #f - user)) - ((not-acceptable? error) - (return - (build-response - #:code 406 - #:reason-phrase "Not Acceptable") - #f - user)) - (else - (raise-exception error))))))))) + user))) + ((POST) + (receive (content-type content) + (nonrdf-or-turtle server-uri request request-body) + (let ((types + (map car + (filter + (lambda (link) + (equal? (assq-ref link 'rel) "type")) + (request-links request))))) + (return + (build-response + #:code 201 #:reason-phrase "Created" + #:headers + `((location . ,(ldp:create server-uri owner user + (uri-path (request-uri request)) + types + (assq-ref (request-headers request) 'slug) + content-type + content + #:http-get http-get)))) + "" + 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) + (return + (build-response) + "" + user))))) + (lambda (return error) + (if (cannot-fetch-group? error) + (format (current-error-port) (G_ "Warning: ~a\n") + (error->str error)) + (cond + ((uri-slash-semantics-error? error) + (return + (build-response + #:code 301 + #:reason-phrase "Found" + #:headers + `((location + . ,(build-uri + (uri-scheme server-uri) + #:userinfo (uri-userinfo server-uri) + #:host (uri-host server-uri) + #:port (uri-port server-uri) + #:path (uri-slash-semantics-error-expected-path error))))) + #f + user)) + ((or (path-not-found? error) + (auxiliary-resource-absent? error) + (forbidden? error)) + (if user + ;; That’s a forbidden + (return + (build-response #:code 403 #:reason-phrase "Forbidden") + #f + user) + (return + (build-response #:code 401 #:reason-phrase "Unauthorized" + #:headers `((www-authenticate . ((DPoP))))) + #f + user))) + ((or (cannot-delete-root? error)) + (return + (build-response + #:code 405 + #:reason-phrase "Method Not Allowed") + #f + user)) + ((or (container-not-empty? error) + (incorrect-containment-triples? error) + (path-is-auxiliary? error)) + (return + (build-response + #:code 409 + #:reason-phrase "Conflict") + #f + user)) + ((unsupported-media-type? error) + (return + (build-response + #:code 415 + #:reason-phrase "Unsupported Media Type") + #f + user)) + ((precondition-failed? error) + (return + (build-response + #:code 412 + #:reason-phrase "Precondition Failed") + #f + user)) + ((not-acceptable? error) + (return + (build-response + #:code 406 + #:reason-phrase "Not Acceptable") + #f + user)) + (else + (raise-exception error)))))))))) diff --git a/src/scm/webid-oidc/reverse-proxy.scm b/src/scm/webid-oidc/reverse-proxy.scm index f9caba6..a1b05e3 100644 --- a/src/scm/webid-oidc/reverse-proxy.scm +++ b/src/scm/webid-oidc/reverse-proxy.scm @@ -18,8 +18,8 @@ #:use-module (webid-oidc errors) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc resource-server) - #:use-module (webid-oidc jti) #:use-module ((webid-oidc config) #:prefix cfg:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (ice-9 i18n) @@ -36,9 +36,7 @@ (define*-public (make-reverse-proxy #:key - (jti-list #f) (server-uri #f) - (current-time current-time) (http-get http-get) (endpoint #f) (auth-header 'XXX-Agent)) @@ -50,9 +48,7 @@ (symbol->string auth-header)))) (define authenticate (make-authenticator - (or jti-list (make-jti-list)) #:server-uri server-uri - #:current-time current-time #:http-get http-get)) (unless (and endpoint (uri? endpoint)) (error "#:endpoint argument is not present or not an URI.")) @@ -68,43 +64,46 @@ unconfirmed-issuer) #f) (else - (apply throw key args))))))) - (let ((raw-headers (request-headers request))) - (let ((modified-headers - (append - (if agent - (list (cons auth-header (uri->string agent))) - '()) - (filter - (lambda (h) - (not (eq? (car h) auth-header))) - raw-headers)))) - (let ((modified-request - (build-request - (request-uri request) - #:method (request-method request) - #:headers modified-headers))) - (let ((port (open-socket-for-uri endpoint))) - (let ((request-with-port - (write-request modified-request port))) - (when request-body - (unless (bytevector? request-body) - (set! request-body (string->utf8 request-body))) - (write-request-body request-with-port request-body)) - (force-output (request-port request-with-port)) - (let ((response (read-response port))) - (let ((response-body - (or (response-must-not-include-body? response) - (read-response-body response)))) - (let ((adapted-response - (build-response - #:code (response-code response) - #:reason-phrase (response-reason-phrase response) - #:headers - (append - (if (eqv? (response-code response) 401) - (list (cons 'www-authenticate '((DPoP)))) - '()) - (response-headers response))))) - (close-port port) - (values adapted-response response-body)))))))))))) + (apply throw key args)))))) + (request-time ((p:current-date)))) + (parameterize ((p:current-date request-time)) + ;; The time is now set for the duration of the request + (let ((raw-headers (request-headers request))) + (let ((modified-headers + (append + (if agent + (list (cons auth-header (uri->string agent))) + '()) + (filter + (lambda (h) + (not (eq? (car h) auth-header))) + raw-headers)))) + (let ((modified-request + (build-request + (request-uri request) + #:method (request-method request) + #:headers modified-headers))) + (let ((port (open-socket-for-uri endpoint))) + (let ((request-with-port + (write-request modified-request port))) + (when request-body + (unless (bytevector? request-body) + (set! request-body (string->utf8 request-body))) + (write-request-body request-with-port request-body)) + (force-output (request-port request-with-port)) + (let ((response (read-response port))) + (let ((response-body + (or (response-must-not-include-body? response) + (read-response-body response)))) + (let ((adapted-response + (build-response + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers + (append + (if (eqv? (response-code response) 401) + (list (cons 'www-authenticate '((DPoP)))) + '()) + (response-headers response))))) + (close-port port) + (values adapted-response response-body))))))))))))) diff --git a/src/scm/webid-oidc/server/resource/content.scm b/src/scm/webid-oidc/server/resource/content.scm index 29d8889..57c51dd 100644 --- a/src/scm/webid-oidc/server/resource/content.scm +++ b/src/scm/webid-oidc/server/resource/content.scm @@ -19,6 +19,7 @@ #: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 (rnrs bytevectors) #:use-module (ice-9 exceptions) @@ -36,18 +37,18 @@ )) -(define (default-dir) - (string-append (refresh:default-dir) "/server")) - (define-class <content> () (content-type #:init-keyword #:content-type #:getter content-type) (contained #:init-keyword #:contained #:getter contained) (static-content #:init-keyword #:static-content #:getter static-content)) -(define (load-content session dir etag) +(define (load-content session etag) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) - (call-with-input-file (format #f "~a/content/~a/~a" dir first-char rest) + (call-with-input-file (format #f "~a/server/content/~a/~a" + (p:data-home) + first-char + rest) (lambda (port) (let ((properties (read port))) (set-port-encoding! port "ISO-8859-1") @@ -60,14 +61,14 @@ (hash-set! session etag ret) ret)))))) -(define (new-content session dir content-type contained static-content) +(define (new-content session content-type contained static-content) (when (string? static-content) (set! static-content (string->utf8 static-content))) (let ((etag (stubs:random 12))) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) - (stubs:mkdir-p (format #f "~a/content/~a" dir first-char)) - (let ((port (open (format #f "~a/content/~a/~a" dir first-char rest) + (stubs:mkdir-p (format #f "~a/server/content/~a" (p:data-home) first-char)) + (let ((port (open (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest) (logior O_WRONLY O_CREAT O_EXCL)))) (write `((content-type . ,content-type) (contained . ,contained)) port) @@ -82,18 +83,16 @@ #:static-content static-content)) etag)))) -(define (delete-content dir etag) +(define (delete-content etag) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) - (delete-file (format #f "~a/content/~a/~a" dir first-char rest)))) + (delete-file (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest)))) -(define* (with-session f #:key (dir default-dir)) - (when (thunk? dir) - (set! dir (dir))) +(define (with-session f) (let ((session (make-hash-table))) (define (do-load etag) (or (hash-ref session etag) - (load-content session dir etag))) + (load-content session etag))) (define (get-content-type etag) (content-type (do-load etag))) (define (get-contained etag) @@ -101,7 +100,7 @@ (define (get-static-content etag) (static-content (do-load etag))) (define (do-create content-type contained static-content) - (new-content session dir content-type contained static-content)) + (new-content session content-type contained static-content)) (define (do-delete etag) - (delete-content dir etag)) + (delete-content etag)) (f get-content-type get-contained get-static-content do-create do-delete))) diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm index f1594bc..55c4274 100644 --- a/src/scm/webid-oidc/server/resource/path.scm +++ b/src/scm/webid-oidc/server/resource/path.scm @@ -19,6 +19,7 @@ #: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 (rnrs bytevectors) #:use-module (ice-9 exceptions) @@ -47,17 +48,14 @@ )) -(define (default-dir) - (string-append (refresh:default-dir) "/server")) - (define (hash-path/lock path) (let ((h (stubs:hash 'SHA-256 path)) - (dir (default-dir))) + (dir (p:data-home))) (let ((first-char (substring h 0 1)) (rest (substring h 1))) (values - (format #f "~a/path/~a/~a" dir first-char rest) - (format #f "~a/path/~a/.lock" dir first-char))))) + (format #f "~a/server/path/~a/~a" dir first-char rest) + (format #f "~a/server/path/~a/.lock" dir first-char))))) (define (hash-path path) (receive (h lock) (hash-path/lock path) diff --git a/src/scm/webid-oidc/stubs.scm b/src/scm/webid-oidc/stubs.scm index 0c6f0bc..08d15aa 100644 --- a/src/scm/webid-oidc/stubs.scm +++ b/src/scm/webid-oidc/stubs.scm @@ -17,6 +17,7 @@ (define-module (webid-oidc stubs) #:use-module (webid-oidc config) #:use-module (webid-oidc errors) + #:use-module (webid-oidc parameters) #:use-module (json)) (load-extension @@ -71,11 +72,16 @@ (lambda error (raise-unsupported-alg (cadr error))))) +(define (fix-random-init!) + (setenv "XDG_CACHE_HOME" (cache-home)) + (setenv "DISFLUID_APPLICATION_NAME" ".") + (random-init!)) + (export base64-encode (fix-base64-decode . base64-decode) random - random-init! + (fix-random-init! . random-init!) (fix-generate-key . generate-key) (fix-kty . kty) strip-key diff --git a/src/scm/webid-oidc/testing.scm b/src/scm/webid-oidc/testing.scm index 0aec4b8..aec9504 100644 --- a/src/scm/webid-oidc/testing.scm +++ b/src/scm/webid-oidc/testing.scm @@ -16,31 +16,23 @@ (define-module (webid-oidc testing) #:use-module (webid-oidc stubs) - #:use-module (webid-oidc errors)) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc parameters)) ;; This module is used only when running tests. (define-public (with-test-environment test-name f) - (let ((cache-dir (format #f "tests/~a.cache" test-name)) - (data-dir (format #f "tests/~a.home" test-name))) - (setenv "XDG_CACHE_HOME" cache-dir) - (setenv "XDG_DATA_HOME" data-dir) - (catch #t - (lambda () (mkdir cache-dir)) - (lambda err #t)) - (let ((pkg-cache-dir (format #f "~a/disfluid" cache-dir))) - (catch #t - (lambda () (mkdir pkg-cache-dir)) - (lambda err #t)) - (let ((seed-file-name (format #f "~a/seed" pkg-cache-dir))) - (with-output-to-file seed-file-name - (lambda () - (format #t "This is the initial seed for the random number generator")))))) (with-exception-handler (lambda (error) (format (current-error-port) "The test failed, because ~a.\n" (error->str error)) (raise-exception error)) (lambda () - (random-init!) - (f)))) + (parameterize ((data-home (format #f "tests/~a.home/disfluid" test-name)) + (cache-home (format #f "tests/~a.cache/disfluid" test-name))) + (call-with-output-file* + (format #f "~a/seed" (cache-home)) + (lambda (port) + (format port "This is the initial seed for the random number generator"))) + (random-init!) + (f))))) diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm index 5a05945..7c4d41c 100644 --- a/src/scm/webid-oidc/token-endpoint.scm +++ b/src/scm/webid-oidc/token-endpoint.scm @@ -22,6 +22,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc access-token) + #: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) @@ -76,116 +77,101 @@ thunk #:unwind? #t)))) -(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity jti-list - #:key - (refresh-token-dir refresh:default-dir) - (current-time current-time)) +(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity) (lambda* (request request-body) (try-handle-web-failure (lambda () (when (bytevector? request-body) (set! request-body (utf8->string request-body))) - (let ((current-time - (let ((t current-time)) - (when (thunk? t) - (set! t (t))) - (when (integer? t) - (set! t (make-time time-utc 0 t))) - (when (time? t) - (set! t (time-utc->date t))) - t)) - (form-args - (if (and (request-content-type request) - (eq? (car (request-content-type request)) - 'application/x-www-form-urlencoded)) - (filter - (lambda (x) x) - (map (lambda (kv) - (let ((parsed - (list->vector - (map (lambda (x) - (uri-decode x #:decode-plus-to-space? #t)) - (string-split kv #\=))))) - (if (eq? (vector-length parsed) 2) - `(,(vector-ref parsed 0) . ,(vector-ref parsed 1)) - #f))) - (string-split request-body #\&))) - '())) - (method (request-method request)) - ;; Maybe we’re behind a reverse proxy, so the authority of - ;; (request-uri request) is meaningless. - (uri (build-uri (uri-scheme token-endpoint-uri) - #:userinfo (uri-userinfo token-endpoint-uri) - #:host (uri-host token-endpoint-uri) - #:port (uri-port token-endpoint-uri) - #:path (uri-path (request-uri request)) - #:query (uri-query (request-uri request))))) - (let ((grant-type (assoc-ref form-args "grant_type")) - (dpop (dpop-proof-decode - current-time jti-list method uri - (assq-ref (request-headers request) 'dpop) - (lambda (jkt) #t)))) - (unless (and grant-type (string? grant-type)) - (raise-unsupported-grant-type #f)) - (receive (webid client-id) - (case (string->symbol grant-type) - ((authorization_code) - (let ((code - (let ((str (assoc-ref form-args "code"))) - (unless str - (raise-no-authorization-code)) - (authorization-code-decode - current-time jti-list str jwk)))) - (values (authorization-code-webid code) - (authorization-code-client-id code)))) - ((refresh_token) - (let ((refresh-token (assoc-ref form-args "refresh_token"))) - (unless refresh-token - (raise-no-refresh-token)) - (refresh:with-refresh-token - refresh-token - (dpop-proof-jwk dpop) - values - #:dir refresh-token-dir))) - (else - (raise-unsupported-grant-type grant-type))) - (let* ((iat (time-second (date->time-utc current-time))) - (exp (+ iat validity))) - (let ((id-token - (issue-id-token - jwk - #:alg alg - #:webid (uri->string webid) - #:sub (uri->string webid) - #:iss (uri->string iss) - #:aud (uri->string client-id) - #:exp exp - #:iat iat)) - (access-token - (issue-access-token - jwk - #:alg alg - #:webid (uri->string webid) - #:iss (uri->string iss) - #:exp exp - #:iat iat - #:client-key (dpop-proof-jwk dpop) - #:client-id (uri->string client-id))) - (refresh-token - (if (equal? grant-type "refresh_token") - (assoc-ref form-args "refresh_token") - (refresh:issue-refresh-token webid client-id - (jkt (dpop-proof-jwk dpop)) - #:dir refresh-token-dir)))) - (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)))))))))) + (parameterize ((p:current-date ((p:current-date)))) + (let ((current-time ((p:current-date))) ;; thunk parameter + (form-args + (if (and (request-content-type request) + (eq? (car (request-content-type request)) + 'application/x-www-form-urlencoded)) + (filter + (lambda (x) x) + (map (lambda (kv) + (let ((parsed + (list->vector + (map (lambda (x) + (uri-decode x #:decode-plus-to-space? #t)) + (string-split kv #\=))))) + (if (eq? (vector-length parsed) 2) + `(,(vector-ref parsed 0) . ,(vector-ref parsed 1)) + #f))) + (string-split request-body #\&))) + '())) + (method (request-method request)) + ;; Maybe we’re behind a reverse proxy, so the authority of + ;; (request-uri request) is meaningless. + (uri (build-uri (uri-scheme token-endpoint-uri) + #:userinfo (uri-userinfo token-endpoint-uri) + #:host (uri-host token-endpoint-uri) + #:port (uri-port token-endpoint-uri) + #:path (uri-path (request-uri request)) + #:query (uri-query (request-uri request))))) + (let ((grant-type (assoc-ref form-args "grant_type")) + (dpop (dpop-proof-decode + method uri + (assq-ref (request-headers request) 'dpop) + (lambda (jkt) #t)))) + (unless (and grant-type (string? grant-type)) + (raise-unsupported-grant-type #f)) + (receive (webid client-id) + (case (string->symbol grant-type) + ((authorization_code) + (let ((code + (let ((str (assoc-ref form-args "code"))) + (unless str + (raise-no-authorization-code)) + (authorization-code-decode str jwk)))) + (values (authorization-code-webid code) + (authorization-code-client-id code)))) + ((refresh_token) + (let ((refresh-token (assoc-ref form-args "refresh_token"))) + (unless refresh-token + (raise-no-refresh-token)) + (refresh:with-refresh-token + refresh-token + (dpop-proof-jwk dpop) + values))) + (else + (raise-unsupported-grant-type grant-type))) + (let* ((iat (time-second (date->time-utc current-time))) + (exp (+ iat validity))) + (let ((id-token + (issue-id-token + jwk + #:alg alg + #:webid (uri->string webid) + #:sub (uri->string webid) + #:iss (uri->string iss) + #:aud (uri->string client-id) + #:validity 3600)) + (access-token + (issue-access-token + jwk + #:alg alg + #:webid (uri->string webid) + #:iss (uri->string iss) + #:validity 3600 + #:client-key (dpop-proof-jwk dpop) + #:client-id (uri->string client-id))) + (refresh-token + (if (equal? grant-type "refresh_token") + (assoc-ref form-args "refresh_token") + (refresh:issue-refresh-token webid client-id + (jkt (dpop-proof-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))))))))))) diff --git a/tests/authorization-endpoint-get-form.scm b/tests/authorization-endpoint-get-form.scm index d71d534..7dbf6ba 100644 --- a/tests/authorization-endpoint-get-form.scm +++ b/tests/authorization-endpoint-get-form.scm @@ -17,6 +17,7 @@ (use-modules (webid-oidc authorization-endpoint) (webid-oidc jwk) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (web uri) (web request) (web response) @@ -33,23 +34,20 @@ (define subject (string->uri "https://authorization-endpoint-get-form.scm/profile/card#me")) (define password "p4ssw0rd") (define validity 120) - (define the-time 0) - (define (current-time) - (make-time time-utc 0 the-time)) (define* (http-get uri #:key (headers '())) (exit 2)) (define endpoint (make-authorization-endpoint subject password alg key validity - #:http-get http-get - #:current-time current-time)) + #:http-get http-get)) (receive (response response-body) - (endpoint - (build-request (string->uri - (format #f "https://authorization-endpoint-get-form.scm/authorize?client_id=~a&redirect_uri=~a" - (uri-encode "https://authorization-endpoint-get-form.scm/client/card#app") - (uri-encode "https://authorization-endpoint-get-form.scm/client/redirect")))) - "") + (parameterize ((p:current-date 0)) + (endpoint + (build-request (string->uri + (format #f "https://authorization-endpoint-get-form.scm/authorize?client_id=~a&redirect_uri=~a" + (uri-encode "https://authorization-endpoint-get-form.scm/client/card#app") + (uri-encode "https://authorization-endpoint-get-form.scm/client/redirect")))) + "")) (unless (eq? (response-code response) 200) (exit 3)) (unless (response-content-type response) diff --git a/tests/authorization-endpoint-no-args.scm b/tests/authorization-endpoint-no-args.scm index bd24fa2..66579a2 100644 --- a/tests/authorization-endpoint-no-args.scm +++ b/tests/authorization-endpoint-no-args.scm @@ -17,6 +17,7 @@ (use-modules (webid-oidc authorization-endpoint) (webid-oidc jwk) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (web uri) (web request) (web response) @@ -33,20 +34,17 @@ (define subject (string->uri "https://authorization-endpoint-get-form.scm/profile/card#me")) (define password "p4ssw0rd") (define validity 120) - (define the-time 0) - (define (current-time) - (make-time time-utc 0 the-time)) (define* (http-get uri #:key (headers '())) (exit 2)) (define endpoint (make-authorization-endpoint subject password alg key validity - #:http-get http-get - #:current-time current-time)) + #:http-get http-get)) (receive (response response-body) - (endpoint - (build-request (string->uri - "https://authorization-endpoint-get-form.scm/authorize")) - "") + (parameterize ((p:current-date 0)) + (endpoint + (build-request (string->uri + "https://authorization-endpoint-get-form.scm/authorize")) + "")) (unless (eq? (response-code response) 400) (exit 3))))) diff --git a/tests/authorization-endpoint-submit-form.scm b/tests/authorization-endpoint-submit-form.scm index f379e38..ef84f40 100644 --- a/tests/authorization-endpoint-submit-form.scm +++ b/tests/authorization-endpoint-submit-form.scm @@ -21,6 +21,7 @@ (webid-oidc cache) (webid-oidc jti) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (web uri) (web request) (web response) @@ -40,9 +41,6 @@ (define password "p4ssw0rd") (define encrypted-password (crypt password "$6$this.is.the.salt")) (define validity 120) - (define the-time 0) - (define (current-time) - (make-time time-utc 0 the-time)) (define what-uri-to-expect client) (define served (receive (response response-body) @@ -57,37 +55,36 @@ (exit 2)) (values the-response the-response-body)) (define cached-http-get - (with-cache #:http-get http-get - #:current-time current-time)) - (define jti-list (make-jti-list)) + (with-cache #:http-get http-get)) (define endpoint (make-authorization-endpoint subject encrypted-password alg key validity - #:http-get cached-http-get - #:current-time current-time)) + #:http-get cached-http-get)) (receive (response response-body) ;; The password is fake! - (endpoint - (build-request (string->uri - (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a" - (uri-encode (uri->string client)) - (uri-encode (uri->string redirect)))) - #:headers '((content-type application/x-www-form-urlencoded)) - #:method 'POST - #:port #t) - "password=fake") + (parameterize ((p:current-date 0)) + (endpoint + (build-request (string->uri + (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a" + (uri-encode (uri->string client)) + (uri-encode (uri->string redirect)))) + #:headers '((content-type application/x-www-form-urlencoded)) + #:method 'POST + #:port #t) + "password=fake")) (when (eq? (response-code response) 302) (exit 3))) (receive (response response-body) - (endpoint - (build-request (string->uri - (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a" - (uri-encode (uri->string client)) - (uri-encode (uri->string redirect)))) - #:headers '((content-type application/x-www-form-urlencoded)) - #:method 'POST - #:port #t) - "password=p4ssw0rd") + (parameterize ((p:current-date 0)) + (endpoint + (build-request (string->uri + (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a" + (uri-encode (uri->string client)) + (uri-encode (uri->string redirect)))) + #:headers '((content-type application/x-www-form-urlencoded)) + #:method 'POST + #:port #t) + "password=p4ssw0rd")) (unless (eq? (response-code response) 302) (exit 4)) (let ((loc (response-location response))) @@ -109,10 +106,10 @@ kv))) (unless (assoc-ref args "code") (exit 9)) - (let ((parsed (authorization-code-decode - 60 - jti-list - (car (assoc-ref args "code")) - key))) + (let ((parsed + (parameterize ((p:current-date 60)) + (authorization-code-decode + (car (assoc-ref args "code")) + key)))) (unless parsed (exit 10))))))))) diff --git a/tests/cache-valid.scm b/tests/cache-valid.scm index cf5c0f1..04e7c22 100644 --- a/tests/cache-valid.scm +++ b/tests/cache-valid.scm @@ -16,6 +16,7 @@ (use-modules (webid-oidc cache) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (web uri) (web request) (web response) @@ -44,31 +45,42 @@ (last-modified . ,(time-utc->date (make-time time-utc 0 10))) (date . ,(time-utc->date (make-time time-utc 0 30)))))) ;; response-not-stored: never valid. - (when (valid? response-not-stored #:current-time 0) - (exit 1)) - (when (valid? response-not-stored #:current-time 100) - (exit 2)) + (parameterize ((p:current-date 0)) + (when (valid? response-not-stored) + (exit 1))) + (parameterize ((p:current-date 100)) + (when (valid? response-not-stored) + (exit 2))) ;; response-not-cached: never valid. - (when (valid? response-not-cached #:current-time 0) - (exit 3)) - (when (valid? response-not-cached #:current-time 100) - (exit 4)) + (parameterize ((p:current-date 0)) + (when (valid? response-not-cached) + (exit 3))) + (parameterize ((p:current-date 100)) + (when (valid? response-not-cached) + (exit 4))) ;; response-with-expires: valid at 110, invalid at 130. - (unless (valid? response-with-expires #:current-time 110) - (exit 5)) - (when (valid? response-with-expires #:current-time 130) - (exit 6)) + (parameterize ((p:current-date 110)) + (unless (valid? response-with-expires) + (exit 5))) + (parameterize ((p:current-date 130)) + (when (valid? response-with-expires) + (exit 6))) ;; response-with-overriden-expires: valid at 105, invalid at 115 - (unless (valid? response-with-overriden-expires #:current-time 105) - (exit 7)) - (when (valid? response-with-overriden-expires #:current-time 115) - (exit 8)) + (parameterize ((p:current-date 105)) + (unless (valid? response-with-overriden-expires) + (exit 7))) + (parameterize ((p:current-date 115)) + (when (valid? response-with-overriden-expires) + (exit 8))) ;; response-without-max-age: not valid, cannot get a heuristic - (when (valid? response-without-max-age #:current-time 10) - (exit 9)) + (parameterize ((p:current-date 10)) + (when (valid? response-without-max-age) + (exit 9))) ;; response-with-heuristic-max-age: the heuristic max age is 2, so ;; it is valid at 31 but not at 33. - (unless (valid? response-with-heuristic-max-age #:current-time 31) - (exit 10)) - (when (valid? response-with-heuristic-max-age #:current-time 33) - (exit 11)))) + (parameterize ((p:current-date 31)) + (unless (valid? response-with-heuristic-max-age) + (exit 10))) + (parameterize ((p:current-date 33)) + (when (valid? response-with-heuristic-max-age) + (exit 11))))) diff --git a/tests/client-manifest-fraudulent.scm b/tests/client-manifest-fraudulent.scm index da77c27..b786140 100644 --- a/tests/client-manifest-fraudulent.scm +++ b/tests/client-manifest-fraudulent.scm @@ -30,9 +30,6 @@ (with-test-environment "client-manifest-fraudulent" (lambda () - (define the-current-time 0) - (define (current-time) - (make-time time-utc 0 the-current-time)) (define what-to-respond (build-response #:headers '((content-type text/turtle)))) (define what-to-respond-body @@ -63,7 +60,6 @@ (values what-to-respond what-to-respond-body)) (define cache-http-get (with-cache - #:current-time current-time #:http-get respond)) (with-exception-handler (lambda (error) diff --git a/tests/client-manifest.scm b/tests/client-manifest.scm index fb40901..2812ede 100644 --- a/tests/client-manifest.scm +++ b/tests/client-manifest.scm @@ -52,12 +52,8 @@ (string->uri "https://app.example.com/id#app")) (exit 2)) (values what-to-respond what-to-respond-body)) - (define current-time 0) (define cache-http-get (with-cache - #:current-time - (lambda () - (make-time time-utc 0 current-time)) #:http-get respond)) (define mf (get-client-manifest @@ -85,7 +81,6 @@ (exit 6)) (set! what-to-respond response) (set! what-to-respond-body response-body) - (set! current-time 10) (let ((re-parsed (get-client-manifest (string->uri "https://app.example.com/id#app") #:http-get cache-http-get))) diff --git a/tests/client-token.scm b/tests/client-token.scm index 9c55582..576019a 100644 --- a/tests/client-token.scm +++ b/tests/client-token.scm @@ -18,11 +18,11 @@ (webid-oidc testing) (webid-oidc token-endpoint) (webid-oidc jwk) - (webid-oidc jti) (webid-oidc authorization-code) (webid-oidc oidc-configuration) (webid-oidc jws) (webid-oidc oidc-id-token) + ((webid-oidc parameters) #:prefix p:) (web uri) (web request) (web response) @@ -35,105 +35,103 @@ "client-token" (lambda () (define the-current-time 0) - (define issuer-key (generate-key #:n-size 2048)) - (define issuer-configuration - (make-oidc-configuration - "https://issuer.client-token.scm/keys" - "https://issuer.client-token.scm/authorize" - "https://issuer.client-token.scm/token")) - (define token-endpoint (make-token-endpoint - (string->uri "https://issuer.client-token.scm/token") - (string->uri "https://issuer.client-token.scm") - 'RS256 - issuer-key - 3600 ;; 1 hour - (make-jti-list) - #:current-time (lambda () the-current-time))) - (define client-key (generate-key #:n-size 2048)) - (define authorization-code - (issue-authorization-code 'RS256 issuer-key 120 - (string->uri "https://client-token.scm/profile/card#me") - (string->uri "https://app.client-token.scm/app#id"))) - (define* (http-get uri #:key (headers '())) - (cond - ((equal? uri (string->uri "https://issuer.client-token.scm/.well-known/openid-configuration")) - (serve-oidc-configuration - (time-utc->date (make-time time-utc 0 (+ the-current-time 3600))) - issuer-configuration)) - ((equal? uri (string->uri "https://issuer.client-token.scm/keys")) - (serve-jwks - (time-utc->date (make-time time-utc 0 (+ the-current-time 3600))) - (make-jwks (list issuer-key)))) - (else - (format (current-error-port) "GET request to ~a: error.\n" (uri->string uri)) - (exit 1)))) - (define* (http-post uri #:key (body #f) (headers '())) - (unless (equal? uri (oidc-configuration-token-endpoint issuer-configuration)) - (format (current-error-port) - "Wrong URI for token negociation: ~a (expected ~a).\n" - (uri->string uri) - (uri->string - (oidc-configuration-token-endpoint - issuer-configuration))) - (exit 2)) - (unless (equal? body (format #f "grant_type=authorization_code&code=~a" - authorization-code)) - (format (current-error-port) - "Wrong body: ~s\n" body) - (exit 3)) - (unless (equal? - (assoc-ref headers 'content-type) - '(application/x-www-form-urlencoded)) - (format (current-error-port) - "Wrong content type: ~s\n" (assoc-ref headers 'content-type)) - (exit 4)) - (let ((request - (build-request uri - #:method 'POST - #:headers headers - #:port (open-input-string body))) - (request-body body)) - (receive (response response-body user error) - (token-endpoint request request-body) - (values response response-body)))) - (let ((response - (token "https://issuer.client-token.scm" - client-key - #:authorization-code authorization-code - #:http-get http-get - #:http-post http-post - #:current-time (lambda () the-current-time)))) - (let ((id-token (assq-ref response 'id_token)) - (access-token (assq-ref response 'access_token)) - (token-type (assq-ref response 'token_type)) - (token-expiration (assq-ref response 'expires_in)) - (refresh-token (assq-ref response 'refresh_token))) - (let ((id-token-dec (id-token-decode id-token #:http-get http-get)) - (access-token-dec (jws-decode access-token (lambda (jws) issuer-key)))) - (unless id-token-dec - (format (current-error-port) "Could not decode the ID token from ~s (~s)" - id-token response) - (exit 5)) - (unless access-token-dec - (format (current-error-port) "Could not decode the access token from ~s (~s)" - access-token response) - (exit 6)) - (unless refresh-token - (format (current-error-port) "There does not seem to be a refresh token in ~s" - response) - (exit 6)) - (unless (equal? (id-token-webid id-token-dec) - (string->uri "https://client-token.scm/profile/card#me")) - (exit 7)) - (unless (equal? (id-token-iss id-token-dec) - (string->uri "https://issuer.client-token.scm")) - (exit 8)) - (unless (equal? (id-token-aud id-token-dec) - (string->uri "https://app.client-token.scm/app#id")) - (exit 9)) - ;; It’s not the job of the client to check that the access - ;; token is correct; TODO: add a check with a resource - ;; server. + (parameterize ((p:current-date (lambda () the-current-time))) + (define issuer-key (generate-key #:n-size 2048)) + (define issuer-configuration + (make-oidc-configuration + "https://issuer.client-token.scm/keys" + "https://issuer.client-token.scm/authorize" + "https://issuer.client-token.scm/token")) + (define token-endpoint (make-token-endpoint + (string->uri "https://issuer.client-token.scm/token") + (string->uri "https://issuer.client-token.scm") + 'RS256 + issuer-key + 3600)) + (define client-key (generate-key #:n-size 2048)) + (define authorization-code + (issue-authorization-code 'RS256 issuer-key 120 + (string->uri "https://client-token.scm/profile/card#me") + (string->uri "https://app.client-token.scm/app#id"))) + (define* (http-get uri #:key (headers '())) + (cond + ((equal? uri (string->uri "https://issuer.client-token.scm/.well-known/openid-configuration")) + (serve-oidc-configuration + (time-utc->date (make-time time-utc 0 (+ the-current-time 3600))) + issuer-configuration)) + ((equal? uri (string->uri "https://issuer.client-token.scm/keys")) + (serve-jwks + (time-utc->date (make-time time-utc 0 (+ the-current-time 3600))) + (make-jwks (list issuer-key)))) + (else + (format (current-error-port) "GET request to ~a: error.\n" (uri->string uri)) + (exit 1)))) + (define* (http-post uri #:key (body #f) (headers '())) + (unless (equal? uri (oidc-configuration-token-endpoint issuer-configuration)) + (format (current-error-port) + "Wrong URI for token negociation: ~a (expected ~a).\n" + (uri->string uri) + (uri->string + (oidc-configuration-token-endpoint + issuer-configuration))) + (exit 2)) + (unless (equal? body (format #f "grant_type=authorization_code&code=~a" + authorization-code)) + (format (current-error-port) + "Wrong body: ~s\n" body) + (exit 3)) + (unless (equal? + (assoc-ref headers 'content-type) + '(application/x-www-form-urlencoded)) + (format (current-error-port) + "Wrong content type: ~s\n" (assoc-ref headers 'content-type)) + (exit 4)) + (let ((request + (build-request uri + #:method 'POST + #:headers headers + #:port (open-input-string body))) + (request-body body)) + (receive (response response-body user error) + (token-endpoint request request-body) + (values response response-body)))) + (let ((response + (token "https://issuer.client-token.scm" + client-key + #:authorization-code authorization-code + #:http-get http-get + #:http-post http-post))) + (let ((id-token (assq-ref response 'id_token)) + (access-token (assq-ref response 'access_token)) + (token-type (assq-ref response 'token_type)) + (token-expiration (assq-ref response 'expires_in)) + (refresh-token (assq-ref response 'refresh_token))) + (let ((id-token-dec (id-token-decode id-token #:http-get http-get)) + (access-token-dec (jws-decode access-token (lambda (jws) issuer-key)))) + (unless id-token-dec + (format (current-error-port) "Could not decode the ID token from ~s (~s)" + id-token response) + (exit 5)) + (unless access-token-dec + (format (current-error-port) "Could not decode the access token from ~s (~s)" + access-token response) + (exit 6)) + (unless refresh-token + (format (current-error-port) "There does not seem to be a refresh token in ~s" + response) + (exit 6)) + (unless (equal? (id-token-webid id-token-dec) + (string->uri "https://client-token.scm/profile/card#me")) + (exit 7)) + (unless (equal? (id-token-iss id-token-dec) + (string->uri "https://issuer.client-token.scm")) + (exit 8)) + (unless (equal? (id-token-aud id-token-dec) + (string->uri "https://app.client-token.scm/app#id")) + (exit 9)) + ;; It’s not the job of the client to check that the access + ;; token is correct; TODO: add a check with a resource + ;; server. - ;; TODO: try to negociate a refresh token. - ))))) + ;; TODO: try to negociate a refresh token. + )))))) diff --git a/tests/dpop-proof-iat-in-future.scm b/tests/dpop-proof-iat-in-future.scm index 4f167ca..b5dd3f8 100644 --- a/tests/dpop-proof-iat-in-future.scm +++ b/tests/dpop-proof-iat-in-future.scm @@ -19,6 +19,7 @@ (webid-oidc jwk) (webid-oidc testing) (webid-oidc errors) + ((webid-oidc parameters) #:prefix p:) (web uri) (srfi srfi-19) (web response)) @@ -28,26 +29,24 @@ (lambda () (define jwk (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/res#frag") - #:iat (time-utc->date (make-time time-utc 0 10)))) + (parameterize ((p:current-date 10)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag")))) (with-exception-handler (lambda (error) (unless ((record-predicate &dpop-signed-in-future) ((record-accessor &cannot-decode-dpop-proof 'cause) error)) (raise-exception error))) (lambda () - (dpop-proof-decode (time-utc->date (make-time time-utc 0 0)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf) + (parameterize ((p:current-date 0)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf)) (exit 2)) #:unwind? #t #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-iat-too-late.scm b/tests/dpop-proof-iat-too-late.scm index e1b7a47..0e1f4ed 100644 --- a/tests/dpop-proof-iat-too-late.scm +++ b/tests/dpop-proof-iat-too-late.scm @@ -18,6 +18,7 @@ (webid-oidc jti) (webid-oidc jwk) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (webid-oidc errors) (web uri) (srfi srfi-19) @@ -28,26 +29,24 @@ (lambda () (define jwk (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/res#frag") - #:iat (time-utc->date (make-time time-utc 0 0)))) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag")))) (with-exception-handler (lambda (error) (unless ((record-predicate &dpop-too-old) ((record-accessor &cannot-decode-dpop-proof 'cause) error)) (raise-exception error))) (lambda () - (dpop-proof-decode (time-utc->date (make-time time-utc 0 600)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf) + (parameterize ((p:current-date 600)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf)) (exit 2)) #:unwind? #t #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-invalid-ath.scm b/tests/dpop-proof-invalid-ath.scm index e802ffe..90cd168 100644 --- a/tests/dpop-proof-invalid-ath.scm +++ b/tests/dpop-proof-invalid-ath.scm @@ -16,11 +16,11 @@ (use-modules (webid-oidc dpop-proof) (webid-oidc access-token) - (webid-oidc jti) (webid-oidc jwk) (webid-oidc testing) (webid-oidc errors) ((webid-oidc stubs) #:prefix stubs:) + ((webid-oidc parameters) #:prefix p:) (web uri) (srfi srfi-19) (web response)) @@ -31,25 +31,24 @@ (define jwk (generate-key #:n-size 2048)) (define idp-key (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define access-token - (issue-access-token - idp-key - #:alg 'RS256 - #:webid "https://data.provider/subject" - #:iss "https://identity.provider" - #:iat 10 - #:exp 3610 - #:client-key jwk - #:client-id "https://client")) + (parameterize ((p:current-date 10)) + (issue-access-token + idp-key + #:alg 'RS256 + #:webid "https://data.provider/subject" + #:iss "https://identity.provider" + #:validity 3600 + #:client-key jwk + #:client-id "https://client"))) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/res?query") - #:iat (time-utc->date (make-time time-utc 0 0)) - #:access-token "aaaaaaaaaaaaaaa")) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res?query") + #:access-token "aaaaaaaaaaaaaaa"))) (with-exception-handler (lambda (error) (let ((cause @@ -61,13 +60,12 @@ (equal? (dpop-invalid-access-token-hash-access-token cause) access-token)) (exit 1)))) (lambda () - (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf - #:access-token access-token) + (parameterize ((p:current-date 10)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf + #:access-token access-token)) (exit 2)) #:unwind? #t #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-no-ath.scm b/tests/dpop-proof-no-ath.scm index 67b8a70..35bff75 100644 --- a/tests/dpop-proof-no-ath.scm +++ b/tests/dpop-proof-no-ath.scm @@ -18,6 +18,7 @@ (webid-oidc jti) (webid-oidc jwk) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (webid-oidc errors) (web uri) (srfi srfi-19) @@ -28,14 +29,13 @@ (lambda () (define jwk (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/res?query") - #:iat (time-utc->date (make-time time-utc 0 0)))) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res?query")))) (with-exception-handler (lambda (error) (let ((cause @@ -47,13 +47,12 @@ ;; claim (exit 1)))) (lambda () - (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf - #:access-token "aaa") + (parameterize ((p:current-date 10)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf + #:access-token "aaa")) (exit 2)) #:unwind? #t #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-replay.scm b/tests/dpop-proof-replay.scm index 132a150..b8f4668 100644 --- a/tests/dpop-proof-replay.scm +++ b/tests/dpop-proof-replay.scm @@ -19,6 +19,7 @@ (webid-oidc jwk) (webid-oidc testing) (webid-oidc errors) + ((webid-oidc parameters) #:prefix p:) (web uri) (srfi srfi-19) (web response)) @@ -28,21 +29,19 @@ (lambda () (define jwk (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/res#frag") - #:iat (time-utc->date (make-time time-utc 0 0)))) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag")))) (define (decode) - (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf)) + (parameterize ((p:current-date 10)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf))) (define decoded-once (decode)) (with-exception-handler (lambda (error) diff --git a/tests/dpop-proof-valid-ath.scm b/tests/dpop-proof-valid-ath.scm index 259190f..1e15e17 100644 --- a/tests/dpop-proof-valid-ath.scm +++ b/tests/dpop-proof-valid-ath.scm @@ -16,9 +16,9 @@ (use-modules (webid-oidc dpop-proof) (webid-oidc access-token) - (webid-oidc jti) (webid-oidc jwk) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (web uri) (srfi srfi-19) (web response)) @@ -29,32 +29,30 @@ (define jwk (generate-key #:n-size 2048)) (define idp-key (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define access-token - (issue-access-token - idp-key - #:alg 'RS256 - #:webid "https://data.provider/subject" - #:iss "https://identity.provider" - #:iat 10 - #:exp 3610 - #:client-key jwk - #:client-id "https://client")) + (parameterize ((p:current-date 10)) + (issue-access-token + idp-key + #:alg 'RS256 + #:webid "https://data.provider/subject" + #:iss "https://identity.provider" + #:validity 3600 + #:client-key jwk + #:client-id "https://client"))) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/res#frag") - #:iat (time-utc->date (make-time time-utc 0 0)) - #:access-token access-token)) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag") + #:access-token access-token))) (define decoded - (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf - #:access-token access-token)) + (parameterize ((p:current-date 10)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf + #:access-token access-token))) (unless decoded (exit 1)))) diff --git a/tests/dpop-proof-valid.scm b/tests/dpop-proof-valid.scm index 52da33b..ec6b32a 100644 --- a/tests/dpop-proof-valid.scm +++ b/tests/dpop-proof-valid.scm @@ -18,6 +18,7 @@ (webid-oidc jti) (webid-oidc jwk) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (web uri) (srfi srfi-19) (web response)) @@ -27,20 +28,18 @@ (lambda () (define jwk (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/res#frag") - #:iat (time-utc->date (make-time time-utc 0 0)))) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag")))) (define decoded - (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf)) + (parameterize ((p:current-date 10)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf))) (unless decoded (exit 1)))) diff --git a/tests/dpop-proof-wrong-htm.scm b/tests/dpop-proof-wrong-htm.scm index eaedfe5..1b30161 100644 --- a/tests/dpop-proof-wrong-htm.scm +++ b/tests/dpop-proof-wrong-htm.scm @@ -19,6 +19,7 @@ (webid-oidc jwk) (webid-oidc testing) (webid-oidc errors) + ((webid-oidc parameters) #:prefix p:) (web uri) (srfi srfi-19) (web response)) @@ -28,26 +29,24 @@ (lambda () (define jwk (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'POST - #:htu (string->uri "https://example.com/res#frag") - #:iat (time-utc->date (make-time time-utc 0 0)))) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'POST + #:htu (string->uri "https://example.com/res#frag")))) (with-exception-handler (lambda (error) (unless ((record-predicate &dpop-method-mismatch) ((record-accessor &cannot-decode-dpop-proof 'cause) error)) (raise-exception error))) (lambda () - (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf) + (parameterize ((p:current-date 10)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf)) (exit 2)) #:unwind? #t #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-wrong-htu.scm b/tests/dpop-proof-wrong-htu.scm index c65d1fc..6f3ac0a 100644 --- a/tests/dpop-proof-wrong-htu.scm +++ b/tests/dpop-proof-wrong-htu.scm @@ -19,6 +19,7 @@ (webid-oidc jwk) (webid-oidc testing) (webid-oidc errors) + ((webid-oidc parameters) #:prefix p:) (web uri) (srfi srfi-19) (web response)) @@ -28,26 +29,24 @@ (lambda () (define jwk (generate-key #:n-size 2048)) (define cnf (jkt jwk)) - (define blacklist (make-jti-list)) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/other-res#frag") - #:iat (time-utc->date (make-time time-utc 0 0)))) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/other-res#frag")))) (with-exception-handler (lambda (error) (unless ((record-predicate &dpop-uri-mismatch) ((record-accessor &cannot-decode-dpop-proof 'cause) error)) (raise-exception error))) (lambda () - (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf) + (parameterize ((p:current-date 10)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf)) (exit 2)) #:unwind? #t #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-wrong-key.scm b/tests/dpop-proof-wrong-key.scm index ae6f177..497ae0e 100644 --- a/tests/dpop-proof-wrong-key.scm +++ b/tests/dpop-proof-wrong-key.scm @@ -19,6 +19,7 @@ (webid-oidc jwk) (webid-oidc testing) (webid-oidc errors) + ((webid-oidc parameters) #:prefix p:) (web uri) (srfi srfi-19) (web response)) @@ -28,26 +29,24 @@ (lambda () (define jwk (generate-key #:n-size 2048)) (define cnf (jkt (generate-key #:n-size 2048))) - (define blacklist (make-jti-list)) (define proof - (issue-dpop-proof - jwk - #:alg 'RS256 - #:htm 'GET - #:htu (string->uri "https://example.com/res#frag") - #:iat (time-utc->date (make-time time-utc 0 0)))) + (parameterize ((p:current-date 0)) + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag")))) (with-exception-handler (lambda (error) (unless ((record-predicate &dpop-unconfirmed-key) ((record-accessor &cannot-decode-dpop-proof 'cause) error)) (raise-exception error))) (lambda () - (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) - blacklist - 'GET - (string->uri "https://example.com/res?query") - proof - cnf) + (parameterize ((p:current-date 10)) + (dpop-proof-decode 'GET + (string->uri "https://example.com/res?query") + proof + cnf)) (exit 2)) #:unwind? #t #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/jwks-get.scm b/tests/jwks-get.scm index 66174a2..8e9169e 100644 --- a/tests/jwks-get.scm +++ b/tests/jwks-get.scm @@ -55,12 +55,8 @@ } ") (exit 2))) - (define current-time 0) (define cache-http-get (with-cache - #:current-time - (lambda () - (make-time time-utc 0 current-time)) #:http-get respond)) (define jwks (get-jwks "https://example.com/keys" #:http-get cache-http-get)) diff --git a/tests/oidc-configuration.scm b/tests/oidc-configuration.scm index 7f02941..f7b3bbc 100644 --- a/tests/oidc-configuration.scm +++ b/tests/oidc-configuration.scm @@ -115,12 +115,8 @@ ] }")) (else (exit 2)))) - (define current-time 0) (define cache-http-get (with-cache - #:current-time - (lambda () - (make-time time-utc 0 current-time)) #:http-get respond)) (define cfg (get-oidc-configuration "example.com" diff --git a/tests/resource-server.scm b/tests/resource-server.scm index ef5e0b7..aba4bb0 100644 --- a/tests/resource-server.scm +++ b/tests/resource-server.scm @@ -23,6 +23,7 @@ (webid-oidc dpop-proof) (webid-oidc resource-server) (webid-oidc testing) + ((webid-oidc parameters) #:prefix p:) (web uri) (web request) (srfi srfi-19) @@ -33,7 +34,6 @@ (with-test-environment "resource-server" (lambda () - (define jti (make-jti-list)) (define client-key (generate-key #:n-size 2048)) (define idp-key (generate-key #:n-size 2048)) (define jwks (make-jwks (list idp-key))) @@ -55,26 +55,26 @@ (serve-jwks exp jwks)) (else (exit 1)))) (define access-token - (issue-access-token - idp-key - #:alg 'RS256 - #:webid subject - #:iss "https://identity.provider" - #:iat 10 - #:exp 3610 - #:client-key client-key - #:client-id "https://client")) + (parameterize ((p:current-date 10)) + (issue-access-token + idp-key + #:alg 'RS256 + #:webid subject + #:iss "https://identity.provider" + #:validity 3600 + #:client-key client-key + #:client-id "https://client"))) (define uri (string->uri "https://resource.server/resource")) (define server-uri (string->uri "https://resource.server/")) (define method 'GET) (define dpop-proof - (issue-dpop-proof - client-key - #:alg 'RS256 - #:htm method - #:htu uri - #:iat (time-utc->date (make-time time-utc 0 15)) - #:access-token access-token)) + (parameterize ((p:current-date 15)) + (issue-dpop-proof + client-key + #:alg 'RS256 + #:htm method + #:htu uri + #:access-token access-token))) (define rq (call-with-input-string (format #f "GET /resource HTTP/1.1\r\n\ @@ -90,11 +90,11 @@ DPoP: ~a\r\n\r\n" (define rq-body "") (define authenticator (make-authenticator - jti #:server-uri server-uri - #:current-time (lambda () (make-time time-utc 0 20)) #:http-get http-get)) - (define parsed (authenticator rq rq-body)) + (define parsed + (parameterize ((p:current-date 20)) + (authenticator rq rq-body))) (unless (uri? parsed) (exit 2)) (unless (equal? parsed subject) diff --git a/tests/token-endpoint-issue.scm b/tests/token-endpoint-issue.scm index 6f7d4dc..9438dfe 100644 --- a/tests/token-endpoint-issue.scm +++ b/tests/token-endpoint-issue.scm @@ -22,6 +22,7 @@ (webid-oidc jti) (webid-oidc testing) ((webid-oidc stubs) #:prefix stubs:) + ((webid-oidc parameters) #:prefix p:) (web uri) (web request) (web response) @@ -40,50 +41,27 @@ (define client (string->uri "https://token-endpoint-issue.scm/client/card#app")) (define issuer (string->uri "https://issuer.token-endpoint-issue.scm")) (define validity 3600) - (define jti-list (make-jti-list)) - (define authz (issue-authorization-code - alg key - (time-utc->date (make-time time-utc 0 120)) - subject - client)) - (define the-time 0) - (define (current-time) - (make-time time-utc 0 the-time)) - (define endpoint (make-token-endpoint - (string->uri "https://token-endpoint-issue.scm/token") - issuer alg key validity jti-list - #:current-time current-time)) + (define authz + (issue-authorization-code + alg key + (time-utc->date (make-time time-utc 0 120)) + subject + client)) + (define endpoint + (make-token-endpoint + (string->uri "https://token-endpoint-issue.scm/token") + issuer alg key validity)) (receive (response response-body user error) ;; The code is fake! (let ((dpop - (issue-dpop-proof - client-key - #:alg alg - #:htm 'POST - #:htu (string->uri - "https://token-endpoint-issue.scm/token") - #:iat (time-utc->date (make-time time-utc 0 0))))) - (set! the-time 0) - (endpoint - (build-request (string->uri - "http://localhost:8080/token") - #:headers `((content-type application/x-www-form-urlencoded) - (dpop . ,dpop)) - #:method 'POST - #:port #t) - "grant_type=authorization_code&code=fake")) - (unless (eq? (response-code response) 400) - (exit 3)) - (receive (response response-body user error) - (let ((dpop + (parameterize ((p:current-date 0)) (issue-dpop-proof client-key #:alg alg #:htm 'POST #:htu (string->uri - "https://token-endpoint-issue.scm/token") - #:iat (time-utc->date (make-time time-utc 0 10))))) - (set! the-time 10) + "https://token-endpoint-issue.scm/token"))))) + (parameterize ((p:current-date 0)) (endpoint (build-request (string->uri "http://localhost:8080/token") @@ -91,7 +69,27 @@ (dpop . ,dpop)) #:method 'POST #:port #t) - (string-append "grant_type=authorization_code&code=" authz))) + "grant_type=authorization_code&code=fake"))) + (unless (eq? (response-code response) 400) + (exit 3)) + (receive (response response-body user error) + (let ((dpop + (parameterize ((p:current-date 10)) + (issue-dpop-proof + client-key + #:alg alg + #:htm 'POST + #:htu (string->uri + "https://token-endpoint-issue.scm/token"))))) + (parameterize ((p:current-date 10)) + (endpoint + (build-request (string->uri + "http://localhost:8080/token") + #:headers `((content-type application/x-www-form-urlencoded) + (dpop . ,dpop)) + #:method 'POST + #:port #t) + (string-append "grant_type=authorization_code&code=" authz)))) (unless (eq? (response-code response) 200) (write response) (exit 4)) diff --git a/tests/token-endpoint-refresh.scm b/tests/token-endpoint-refresh.scm index 2b5be1f..f3d9b52 100644 --- a/tests/token-endpoint-refresh.scm +++ b/tests/token-endpoint-refresh.scm @@ -23,6 +23,7 @@ (webid-oidc jti) (webid-oidc testing) ((webid-oidc stubs) #:prefix stubs:) + ((webid-oidc parameters) #:prefix p:) (web uri) (web request) (web response) @@ -41,47 +42,22 @@ (define client (string->uri "https://token-endpoint-issue.scm/client/card#app")) (define issuer (string->uri "https://issuer.token-endpoint-issue.scm")) (define validity 3600) - (define jti-list (make-jti-list)) (define refresh-code (issue-refresh-token subject client (jkt client-key))) - (define the-time 0) - (define (current-time) - (make-time time-utc 0 the-time)) (define endpoint (make-token-endpoint (string->uri "https://token-endpoint-issue.scm/token") - issuer alg key validity jti-list - #:current-time current-time)) + issuer alg key validity)) (receive (response response-body user error) ;; The refresh token is fake! (let ((dpop - (issue-dpop-proof - client-key - #:alg alg - #:htm 'POST - #:htu (string->uri - "https://token-endpoint-issue.scm/token") - #:iat (time-utc->date (make-time time-utc 0 0))))) - (set! the-time 0) - (endpoint - (build-request (string->uri - "http://localhost:8080/token") - #:headers `((content-type application/x-www-form-urlencoded) - (dpop . ,dpop)) - #:method 'POST - #:port #t) - "refresh_token=fake")) - (unless (eq? (response-code response) 400) - (exit 3)) - (receive (response response-body user error) - (let ((dpop + (parameterize ((p:current-date 0)) (issue-dpop-proof client-key #:alg alg #:htm 'POST #:htu (string->uri - "https://token-endpoint-issue.scm/token") - #:iat (time-utc->date (make-time time-utc 0 10))))) - (set! the-time 10) + "https://token-endpoint-issue.scm/token"))))) + (parameterize ((p:current-date 0)) (endpoint (build-request (string->uri "http://localhost:8080/token") @@ -89,7 +65,27 @@ (dpop . ,dpop)) #:method 'POST #:port #t) - (string-append "grant_type=refresh_token&refresh_token=" refresh-code))) + "refresh_token=fake"))) + (unless (eq? (response-code response) 400) + (exit 3)) + (receive (response response-body user error) + (let ((dpop + (parameterize ((p:current-date 10)) + (issue-dpop-proof + client-key + #:alg alg + #:htm 'POST + #:htu (string->uri + "https://token-endpoint-issue.scm/token"))))) + (parameterize ((p:current-date 10)) + (endpoint + (build-request (string->uri + "http://localhost:8080/token") + #:headers `((content-type application/x-www-form-urlencoded) + (dpop . ,dpop)) + #:method 'POST + #:port #t) + (string-append "grant_type=refresh_token&refresh_token=" refresh-code)))) (unless (eq? (response-code response) 200) (exit 4)) (unless (eq? (car (response-content-type response)) 'application/json) |