;; 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 identity-provider)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc authorization-endpoint)
#:use-module (webid-oidc token-endpoint)
#:use-module (webid-oidc oidc-configuration)
#:use-module (webid-oidc jwk)
#:use-module ((webid-oidc config) #:prefix cfg:)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (webid-oidc jti)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (web client)
#:use-module (web server)
#:use-module (webid-oidc cache)
#:use-module (ice-9 optargs)
#:use-module (ice-9 receive)
#:use-module (ice-9 i18n)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 suspendable-ports)
#:use-module (sxml simple)
#:use-module (srfi srfi-19)
#:use-module (rnrs bytevectors))
(define (G_ text)
(let ((out (gettext text)))
(if (string=? out text)
;; No translation, disambiguate
(car (reverse (string-split text #\|)))
out)))
(define* (same-uri? a b #:key (skip-query #f))
(and (equal? (uri-path a) (uri-path b))
(or skip-query (equal? (uri-query a) (uri-query b)))))
(define*-public (make-identity-provider
issuer
key-file
subject
encrypted-password
jwks-uri
authorization-endpoint-uri
token-endpoint-uri
#:key
(http-get http-get))
(let ((key
(catch #t
(lambda ()
(call-with-input-file key-file stubs:json->scm))
(lambda error
(format (current-error-port)
(G_ "Warning: generating a new key pair."))
(let ((k (generate-key #:n-size 2048)))
(stubs:call-with-output-file*
key-file
(lambda (port)
(stubs:scm->json k port #:pretty #t)))
k)))))
(let ((alg
(if (eq? (kty key) 'RSA)
'RS256
'ES256)))
(let ((authorization-endpoint
(make-authorization-endpoint subject encrypted-password alg key 120
#:http-get http-get))
(token-endpoint
(make-token-endpoint token-endpoint-uri issuer alg key 3600))
(openid-configuration
(make-oidc-configuration jwks-uri
authorization-endpoint-uri
token-endpoint-uri))
(openid-configuration-uri
(build-uri 'https
#:host (uri-host issuer)
#:path "/.well-known/openid-configuration")))
(lambda (request request-body)
(let ((uri (request-uri request))
(current-time (current-time)))
(cond ((same-uri? uri openid-configuration-uri)
(let* ((current-sec (time-second current-time))
(exp-sec (+ current-sec 3600))
(exp (time-utc->date
(make-time time-utc 0 exp-sec))))
(serve-oidc-configuration exp openid-configuration)))
((same-uri? uri jwks-uri)
(let* ((current-sec (time-second current-time))
(exp-sec (+ current-sec 3600))
(exp (time-utc->date
(make-time time-utc 0 exp-sec))))
(serve-jwks exp (make-jwks (list key)))))
((same-uri? uri authorization-endpoint-uri #:skip-query #t)
(authorization-endpoint request request-body))
((same-uri? uri token-endpoint-uri)
(token-endpoint request request-body))
((same-uri? uri subject)
(values
(build-response #:headers '((content-type text/turtle))
#:port #f)
(format #f
"@prefix foaf: .
@prefix rdfs: .
<#~a> a foaf:Person ;
rdfs:comment \"It works. Now you should use another service to serve that resource.\" .
"
(uri-fragment subject))))
(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"))
(body
(h1 "Resource not found")
(p "This OpenID Connect identity provider does not know the resource you are requesting."))))))))))))))))