;; disfluid, 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 parameters) #:prefix p:)
  #:use-module (webid-oidc jti)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (web server)
  #:use-module (webid-oidc cache)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (webid-oidc web-i18n)
  #:use-module (ice-9 getopt-long)
  #:use-module (ice-9 suspendable-ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module (sxml simple)
  #:use-module (sxml match)
  #:use-module (srfi srfi-19)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:duplicates (merge-generics)
  #:declarative? #t
  #:export
  (

   make-identity-provider

   ))

(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* (make-identity-provider
          issuer
          key-file
          subject
          encrypted-password
          jwks-uri
          authorization-endpoint-uri
          token-endpoint-uri)
  (let ((key
         (catch #t
           (lambda ()
             (call-with-input-file key-file
               (lambda (port)
                 (jwk->key
                  (stubs:json->scm port)))))
           (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 (key->jwk k) port #:pretty #t)))
               k)))))
    (let ((authorization-endpoint
           (make-authorization-endpoint subject encrypted-password key))
          (token-endpoint
           (make-token-endpoint token-endpoint-uri issuer key))
          (openid-configuration
           (make <oidc-configuration>
             #:jwks-uri jwks-uri
             #:authorization-endpoint authorization-endpoint-uri
             #:token-endpoint 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 ((p:current-date))))
          (parameterize ((web-locale request))
            (cond ((same-uri? uri openid-configuration-uri)
                   (let* ((current-sec (time-second (date->time-utc current-time)))
                          (exp-sec (+ current-sec 3600))
                          (exp (time-utc->date
                                (make-time time-utc 0 exp-sec))))
                     (serve openid-configuration exp)))
                  ((same-uri? uri jwks-uri)
                   (let* ((current-sec (time-second (date->time-utc current-time)))
                          (exp-sec (+ current-sec 3600))
                          (exp (time-utc->date
                                (make-time time-utc 0 exp-sec))))
                     (serve (make <jwks> #:keys (list key)) exp)))
                  ((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 (W_ "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 ,(W_ "xml-lang|en")))
                                       (body
                                        ,(sxml-match
                                          (xml->sxml
                                           (W_ (format #f "<h1>Resource not found</h1>")))
                                          ((*TOP* ,title) title))
                                        ,(sxml-match
                                          (xml->sxml
                                           (W_ (format #f "<p>This OpenID Connect identity provider does not know the resource you are requesting.</p>")))
                                          ((*TOP* ,p) p)))))))))))))))))