) initargs)
(next-method)
(let-keywords
initargs #t
((client-id #f)
(redirect-uris #f))
(let do-initialize ((client-id client-id)
(redirect-uris redirect-uris))
(when (list? redirect-uris)
(set! redirect-uris
(map
(match-lambda
((or (? string? (= string->uri (? uri? value)))
value)
value))
redirect-uris)))
(cond
((string? client-id)
(do-initialize (string->uri client-id) redirect-uris))
((equal? client-id public-client-uri)
(slot-set! client 'client-id client-id)
(slot-set! client 'redirect-uris '()))
((not redirect-uris)
(receive (response response-body) ((p:anonymous-http-request) client-id)
(with-exception-handler
(lambda (error)
(raise-exception
(make-exception
(make-cannot-fetch-client-manifest)
(make-exception-with-message
(if (exception-with-message? error)
(format #f (G_ "cannot fetch a client manifest: ~a")
(exception-message error))
(format #f (G_ "cannot fetch a client manifest"))))
error)))
(lambda ()
(when (bytevector? response-body)
(set! response-body (utf8->string response-body)))
(unless (eqv? (response-code response) 200)
(raise-exception
(make-exception
(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)))))))
(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)))
(unless (string? 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."))))))
(set! redirect-uris
(let fix-redirect-uris ((redirect-uris redirect-uris))
(match redirect-uris
((? vector? (= vector->list redirect-uris))
redirect-uris)
((? list? redirect-uris)
(map fix-redirect-uris redirect-uris))
((? string? (= string->uri (? uri? uri)))
uri)
(anything anything))))
(set! new-client-id
(match new-client-id
((? string? (= string->uri (? uri? uri)))
uri)
(anything anything)))
(unless redirect-uris
(raise-exception
(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."))))))
(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."))))))
(unless (equal? client-id new-client-id)
(raise-exception
(make-exception
(make-inconsistent-client-manifest)
(make-exception-with-message
(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."))))))
(do-initialize new-client-id redirect-uris)))))))
(else
(unless (uri? client-id)
(scm-error 'wrong-type-arg "make"
(G_ "#:client-id should be an URI")
'()
(list client-id)))
(unless (let check-redirect-uris ((redirect-uris redirect-uris))
(match redirect-uris
(() #t)
(((? uri?) redirect-uris ...)
(check-redirect-uris redirect-uris))))
(scm-error 'wrong-type-arg "make"
(G_ "#:redirect-uris should be a list of URIs")
'()
(list redirect-uri)))
(slot-set! client 'client-id client-id)
(slot-set! client 'redirect-uris redirect-uris))))))
(define (check-redirect mf uris redir)
(match uris
(()
(let ((final-message
(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_ "The application wants to get your
authorization through ~s, which is not
approved.
"))
((*TOP* ,element) element))))
(raise-exception
(make-exception
(make-unauthorized-redirect-uri)
(make-exception-with-message final-message)
(make-message-for-the-user final-user-message)))))
(((? (cute equal? <> redir) redir) _ ...)
#t)
((_ uris ...)
(check-redirect mf uris redir))))
(define-method (check-redirect-uri (mf ) redir)
(unless (uri? redir)
(set! redir (string->uri redir)))
(or (equal? (client-id mf) public-client-uri)
(check-redirect mf (redirect-uris mf) redir)))
(define-method (->json-data (mf ))
(let ((other
(catch 'goops-error
(lambda ()
(next-method))
(lambda _
'()))))
`((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld")
(client_id . ,(uri->string (client-id mf)))
(redirect_uris . ,(list->vector (map uri->string (redirect-uris mf))))
,@other)))
(define-method (serve (mf ) expiration-date)
(when (equal? (client-id mf) public-client-uri)
(let ((final-message
(format #f (G_ "cannot serve the public manifest"))))
(raise-exception
(make-exception
(make-cannot-serve-public-manifest)
(make-exception-with-message final-message)))))
(let ((json-object (stubs:scm->json-string
(->json-data mf))))
(let ((etag (stubs:hash 'SHA-256 json-object)))
(values (build-response #:headers `((content-type application/ld+json)
(etag . (,etag . #t))
,@(if expiration-date
`((expires . ,expiration-date))
`((cache-control public must-revalidate)))))
json-object))))