;; webid-oidc, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(define-module (webid-oidc client)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc provider-confirmation)
#:use-module (webid-oidc oidc-configuration)
#:use-module (webid-oidc oidc-id-token)
#:use-module (webid-oidc dpop-proof)
#:use-module (webid-oidc jwk)
#: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)
#:use-module (web request)
#:use-module (web response)
#:use-module (web server)
#:use-module (web http)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-19)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 i18n)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 suspendable-ports)
#:use-module (sxml simple))
(define*-public (authorize host-or-webid
#:key
(client-id #f)
(redirect-uri #f)
(state #f)
(http-get http-get))
(define cannot-be-webid #f)
(define candidate-errors '())
;; host-or-webid can be: the host (as a string), an URI (as a string
;; or an URI). 3 differents things.
(when (string? host-or-webid)
;; If it’s a string, it can be either a host name or a URI.
(set! host-or-webid
(catch #t
(lambda ()
(let ((urified (string->uri host-or-webid)))
(if urified
urified
(error "It’s not a string representing an URI."))))
(lambda error
(build-uri 'https #:host host-or-webid)))))
;; client-id and redirect-uri are required, state must be a string.
(when (string? client-id)
(set! client-id (string->uri client-id)))
(when (string? redirect-uri)
(set! redirect-uri (string->uri redirect-uri)))
(let ((host-candidates
(with-exception-handler
(lambda (why-not-webid)
;; try as an identity provider
(set! cannot-be-webid why-not-webid)
(build-uri 'https
#:userinfo (uri-userinfo host-or-webid)
#:host (uri-host host-or-webid)
#:port (uri-port host-or-webid)))
(lambda ()
(get-provider-confirmations host-or-webid #:http-get http-get))
#:unwind? #t)))
(let ((configurations
(if cannot-be-webid
(with-exception-handler
(lambda (why-not-identity-provider)
(raise-neither-identity-provider-nor-webid
host-or-webid
why-not-identity-provider
cannot-be-webid))
(lambda ()
(cons (uri->string host-candidates)
(get-oidc-configuration (uri-host host-candidates)
#:userinfo (uri-userinfo host-candidates)
#:port (uri-port host-candidates)
#:http-get http-get))))
(filter
(lambda (cfg) cfg)
(map
(lambda (host)
(with-exception-handler
(lambda (cause)
(set! candidate-errors (acons host cause candidate-errors))
#f)
(lambda ()
(cons (uri->string host)
(get-oidc-configuration (uri-host host)
#:userinfo (uri-userinfo host)
#:port (uri-port host)
#:http-get http-get)))
#:unwind? #t))
host-candidates)))))
(let ((authorization-endpoints
(if cannot-be-webid
(with-exception-handler
(lambda (why-not-identity-provider)
(raise-neither-identity-provider-nor-webid
host-or-webid
why-not-identity-provider
cannot-be-webid))
(lambda ()
(let ((host (car configurations))
(cfg (cdr configurations)))
(cons host (oidc-configuration-authorization-endpoint cfg)))))
(map
(lambda (host/cfg)
(let ((host (car host/cfg))
(cfg (cdr host/cfg)))
(with-exception-handler
(lambda (cause)
(set! candidate-errors (acons (string->uri host) cause
candidate-errors)))
(lambda ()
(cons host
(oidc-configuration-authorization-endpoint cfg)))
#:unwind? #t)))
configurations))))
(if cannot-be-webid
(let ((host (car authorization-endpoints))
(authz (cdr authorization-endpoints)))
(list
(cons
host
(build-uri (uri-scheme authz)
#:userinfo (uri-userinfo authz)
#:host (uri-host authz)
#:port (uri-port authz)
#:path (uri-path authz)
#:query (format #f "client_id=~a&redirect_uri=~a~a"
(uri-encode (uri->string client-id))
(uri-encode (uri->string redirect-uri))
(if state
(format #f "&state=~a"
(uri-encode state))
""))))))
(let ((final-candidates
(map
(lambda (host/authorization-endpoint)
(let ((host (car host/authorization-endpoint))
(authorization-endpoint (cdr host/authorization-endpoint)))
(cons
host
(build-uri (uri-scheme authorization-endpoint)
#:userinfo (uri-userinfo authorization-endpoint)
#:host (uri-host authorization-endpoint)
#:port (uri-port authorization-endpoint)
#:path (uri-path authorization-endpoint)
#:query (format #f "client_id=~a&redirect_uri=~a~a"
(uri-encode (uri->string client-id))
(uri-encode (uri->string redirect-uri))
(if state
(format #f "&state=~a"
(uri-encode state))
""))))))
authorization-endpoints)))
(when (null? final-candidates)
(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))
(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)))
(grant-type
(if authorization-code
"authorization_code"
"refresh_token")))
(let ((dpop-proof
(issue-dpop-proof
client-key
#:alg (case (kty client-key)
((EC) 'ES256)
((RSA) 'RS256)
(else
(error "Unknown key type of ~S." client-key)))
#:htm 'POST
#:htu token-endpoint
#:iat current-time)))
(receive (response response-body)
(http-post token-endpoint
#:body
(string-join
(map
(lambda (arg)
(string-append (uri-encode (car arg))
"="
(uri-encode (cdr arg))))
`(("grant_type" . ,grant-type)
,@(if authorization-code
`(("code" . ,authorization-code))
'())
,@(if refresh-token
`(("refresh_token" . ,refresh-token))
'())))
"&")
#:headers
`((content-type application/x-www-form-urlencoded)
(dpop . ,dpop-proof)))
(with-exception-handler
(lambda (error)
(raise-token-request-failed error))
(lambda ()
(when (bytevector? response-body)
(set! response-body (utf8->string response-body)))
(with-exception-handler
(lambda (error)
(raise-unexpected-response response error))
(lambda ()
(unless (eqv? (response-code response) 200)
(raise-request-failed-unexpectedly
(response-code response)
(response-reason-phrase response)))
(unless (and (response-content-type response)
(eq? (car (response-content-type response 'application/json))))
(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/webid-oidc" xdg-data-home)))
(define*-public (list-profiles #:key (dir default-dir))
(when (thunk? dir)
(set! dir (dir)))
(map (lambda (profile)
(list
(string->uri (car profile)) ;; webid
(string->uri (cadr profile)) ;; issuer
(caddr profile) ;; refresh token
(cadddr profile))) ;; key
(catch #t
(lambda ()
(call-with-input-file (string-append dir "/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)))
(stubs:atomically-update-file
(string-append dir "/profiles")
(string-append dir "/profiles.lock")
(lambda (port)
(write
(map (lambda (profile)
(list
(uri->string (car profile)) ;; webid
(uri->string (cadr profile)) ;; issuer
(caddr profile) ;; refresh token
key)) ;; key
(cons `(,webid
,issuer
,refresh-token)
other-profiles))
port)))))
(define*-public (setup get-host/webid choose-provider browse-authorization-uri
#: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)))
(let ((host/webid (get-host/webid)))
(let ((authorization-uris
(authorize host/webid
#:client-id client-id
#:redirect-uri redirect-uri
#:http-get http-get))
(key (generate-key #:n-size 2048)))
(let ((provider (choose-provider (map car authorization-uris))))
(let ((authz-uri (assq-ref authorization-uris provider)))
(let ((authz-code (browse-authorization-uri authz-uri)))
(let ((params
(token host/webid key
#:authorization-code authz-code
#:http-get http-get
#:http-post http-post
#:current-time current-time)))
(let ((id-token (id-token-decode (assq-ref params 'id_token)
#:http-get http-get))
(access-token (assq-ref params 'access_token))
(refresh-token (assq-ref params 'refresh_token)))
(when refresh-token
;; Save it to disk
(add-profile (id-token-webid id-token)
(id-token-iss id-token)
refresh-token
key
#:dir dir))
(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))
(when (string? webid)
(set! webid (string->uri webid)))
(when (string? issuer)
(set! issuer (string->uri issuer)))
(let ((iss-host (uri-host issuer)))
(let ((params
(token iss-host key
#:refresh-token refresh-token
#:http-get http-get
#:http-post http-post
#:current-time current-time)))
(let ((id-token (id-token-decode (assq-ref params 'id_token)
#:http-get http-get))
(access-token (assq-ref params 'access_token))
(new-refresh-token (assq-ref params 'refresh-token)))
(when (and new-refresh-token
(not (equal? refresh-token new-refresh-token)))
;; The refresh token has been updated
(add-profile (id-token-webid id-token)
(id-token-iss id-token)
refresh-token
key
#:dir dir))
(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)))
(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)))
(letrec ((find-refresh-token
(lambda (profiles)
(when (null? profiles)
(raise-profile-not-found (id-token-webid id-token)
(id-token-iss id-token)
dir))
(let ((prof (car profiles))
(others (cdr profiles)))
(let ((webid (car prof))
(issuer (cadr prof))
(refresh (caddr prof)))
(if (and (equal? webid (id-token-webid id-token))
(equal? issuer (id-token-iss id-token)))
refresh
(find-refresh-token others)))))))
(login (id-token-webid id-token)
(id-token-iss id-token)
(find-refresh-token (profiles))
key
#:dir dir
#:http-get http-get
#:http-post http-post
#:current-time current-time))))
(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
;; judging from the ID token to know if it has expired.
(when (date? date)
(set! date (date->time-utc date)))
(when (time? date)
(set! date (time-second date)))
(when (id-token-payload? id-token)
;; See the refresh function
(set! id-token (cons `((alg . "HS256")) id-token)))
(let ((exp (id-token-exp id-token)))
(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)
(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))
;; 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?)
(let ((proof (issue-dpop-proof
key
#:alg (case (kty key)
((EC) 'ES256)
((RSA) 'RS256)
(else
(error "Unknown key type of ~S." key)))
#:htm method
#:htu uri
#:iat current-time)))
(receive (response response-body)
(apply http-request uri
#:method method
#:headers (append `((dpop . ,proof)
(Authorization . ,(string-append "DPoP " access-token)))
headers)
other-args)
(let ((server-date (response-date response))
(code (response-code response)))
(if (and retry? (eqv? code 401))
;; 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)
;; No, it’s just that way.
(values response response-body)
;; Ah, we have a new access token
(begin
(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))))
(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))
(let ((kw (car rest)))
(case kw
((#:method)
(if (null? (cdr rest))
(parse-args uri method headers (cons kw other-args-rev) '())
(parse-args uri (cadr rest) headers other-args-rev (cddr rest))))
((#:headers)
(if (null? (cdr rest))
(parse-args uri method headers (cons kw other-args-rev) '())
(parse-args uri method (append headers (cadr rest)) other-args-rev (cddr rest))))
(else
(parse-args uri method headers (cons kw other-args-rev) '()))))))
(define (parse-http-request-args uri args)
(parse-args uri 'GET '() '() args))
(lambda (uri . args)
(parse-http-request-args uri args)))
(define*-public (serve-application id redirect-uri
#:key
(client-name "Example application")
(client-uri "https://webid-oidc-demo.planete-kraus.eu"))
(when (string? id)
(set! id (string->uri id)))
(when (string? redirect-uri)
(set! redirect-uri (string->uri redirect-uri)))
(when (string? client-uri)
(set! client-uri (string->uri client-uri)))
(let* ((manifest
(format #f
"@prefix solid: .
<~a> solid:oidcRegistration \"\"\"{
\"client_id\" : \"~a\",
\"redirect_uris\" : [\"~a\"],
\"client_name\" : \"~a\",
\"client_uri\" : \"~a\",
\"grant_types\" : [\"refresh_token\", \"authorization_code\"],
\"response_types\" : [\"code\"]
}\"\"\" .
"
(uri->string id)
(uri->string id)
(uri->string redirect-uri)
client-name
(uri->string id)))
(manifest-etag (stubs:hash 'SHA-256 manifest)))
(lambda (request request-body)
(let ((uri (request-uri request)))
(cond
((equal? (uri-path uri) (uri-path id))
(let ((if-none-match (request-if-none-match request)))
(if (and (list? if-none-match)
(member manifest-etag
(map car (request-if-none-match request))))
(values
(build-response
#:code 304
#:reason-phrase "Not Modified"
#:headers `((content-type text/turtle)
(etag . (,manifest-etag . #t))))
#f)
(values
(build-response
#:headers `((content-type text/turtle)
(etag . (,manifest-etag . #t))
(cache-control public must-revalidate)))
manifest))))
((equal? (uri-path uri) (uri-path redirect-uri))
(let ((query-args
(map
(lambda (key=value)
(let ((splits
(map uri-decode (string-split key=value #\=))))
(if (or (null? splits) (null? (cdr splits)))
splits
(cons (string->symbol (car splits)) (cdr splits)))))
(string-split (uri-query uri) #\&))))
(let ((code (assq-ref query-args 'code)))
(if code
(values
(build-response
#:headers `((content-type application/xhtml+xml)))
(with-output-to-string
(lambda ()
(sxml->xml
`(*TOP*
(*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
(html (@ (xmlns "http://www.w3.org/1999/xhtml")
(xml:lang "en"))
(head
(title "Authorization"))
(body
(p "You have been authorized. Please paste the following code in the application:")
(p (strong ,code)))))))))
(values
(build-response
#:code 400
#:reason-phrase "Invalid Request"
#:headers `((content-type application/xhtml+xml)))
(with-output-to-string
(lambda ()
(sxml->xml
`(*TOP*
(*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
(html (@ (xmlns "http://www.w3.org/1999/xhtml")
(xml:lang "en"))
(head
(title "Error"))
(body
(p "Your identity provider did not authorize you. :("))))))))))))
(else
(values
(build-response
#:code 404
#:reason-phrase "Not Found"
#:headers `((content-type application/xhtml+xml)))
(with-output-to-string
(lambda ()
(sxml->xml
`(*TOP*
(*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
(html (@ (xmlns "http://www.w3.org/1999/xhtml")
(xml:lang "en"))
(head
(title "Not Found"))
(body
(p "This page does not exist on the server."))))))))))))))