;; 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 <https://www.gnu.org/licenses/>.

(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
                 jti-list
                 #:key
                 (current-time current-time)
                 (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
                                          #: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))
            (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: <http://xmlns.com/foaf/0.1/> .
@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .

<#~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."))))))))))))))))