diff options
Diffstat (limited to 'src/scm/webid-oidc/client-manifest.scm')
-rw-r--r-- | src/scm/webid-oidc/client-manifest.scm | 47 |
1 files changed, 30 insertions, 17 deletions
diff --git a/src/scm/webid-oidc/client-manifest.scm b/src/scm/webid-oidc/client-manifest.scm index 1d855c1..2d1f428 100644 --- a/src/scm/webid-oidc/client-manifest.scm +++ b/src/scm/webid-oidc/client-manifest.scm @@ -16,6 +16,7 @@ (define-module (webid-oidc client-manifest) #:use-module (webid-oidc errors) + #:use-module (webid-oidc server endpoint) #:use-module (webid-oidc fetch) #:use-module (webid-oidc web-i18n) #:use-module (webid-oidc serializable) @@ -153,9 +154,11 @@ (make-exception-with-message (format #f (G_ "the server responded with code ~a") (response-code response))) - (make-message-for-the-user - `(p ,(format #f (W_ "The server hosting your application responded with code ~a.") - (response-code response))))))) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The server hosting your application responded with code ~a.<p>") + (response-code response)) + xml->sxml))))) (let ((json-data (stubs:json-string->scm response-body))) (let ((new-client-id (assq-ref json-data 'client_id)) (redirect-uris (assq-ref json-data 'redirect_uris))) @@ -164,8 +167,10 @@ (make-exception (make-exception-with-message (G_ "the client manifest does not have a client_id field")) - (make-message-for-the-user - `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the client_id field.")))))) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the client_id field.<p>")) + xml->sxml))))) (set! redirect-uris (let fix-redirect-uris ((redirect-uris redirect-uris)) (match redirect-uris @@ -186,15 +191,19 @@ (make-exception (make-exception-with-message (G_ "the client manifest does not have a redirect_uris field")) - (make-message-for-the-user - `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the redirect_uris field.")))))) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the redirect_uris field.<p>")) + xml->sxml))))) (unless new-client-id (raise-exception (make-exception (make-exception-with-message (G_ "the client manifest does not have a client_id field")) - (make-message-for-the-user - `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the client_id field.")))))) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The server hosting your application does not behave correctly, because it lacks the client_id field.<p>")) + xml->sxml))))) (unless (equal? client-id new-client-id) (raise-exception (make-exception @@ -203,8 +212,10 @@ (format #f (G_ "the client manifest under ~s has a client_id of ~s") (uri->string client-id) (uri->string new-client-id))) - (make-message-for-the-user - `(p ,(W_ "The application you want to use does not control the domain name it appears to represent.")))))) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The application you want to use does not control the domain name it appears to represent.</p>")) + xml->sxml))))) (do-initialize new-client-id redirect-uris))))))) (else (unless (uri? client-id) @@ -231,16 +242,18 @@ (format #f (G_ "the client manifest does not allow ~s as a redirection uri") (uri->string redir))) (final-user-message - (sxml-match - (xml->sxml (W_ "<p>The application wants to get your -authorization through <strong>~s</strong>, which is not -approved.</p>")) - ((*TOP* ,element) element)))) + (call-with-input-string + (format #f (W_ "<p>The application wants to get your +authorization through <strong>~a</strong>, which is not +approved.</p>") + (call-with-output-string + (cute sxml->xml `(*TOP* ,(uri->string redir)) <>))) + xml->sxml))) (raise-exception (make-exception (make-unauthorized-redirect-uri) (make-exception-with-message final-message) - (make-message-for-the-user final-user-message))))) + (make-user-message final-user-message))))) (((? (cute equal? <> redir) redir) _ ...) #t) ((_ uris ...) |