;; 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 provider-confirmation)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc fetch)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-19)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (rdf rdf)
  #:use-module (turtle tordf))

(define (find-confirmations subject graph)
  (cond ((null? graph) '())
        ((and (string=? (rdf-triple-predicate (car graph))
                        "http://www.w3.org/ns/solid/terms#oidcIssuer")
              (string? (rdf-triple-subject (car graph)))
              (string=? (rdf-triple-subject (car graph)) subject)
              (string? (rdf-triple-object (car graph)))
              (string->uri (rdf-triple-object (car graph)))
              (eq? (uri-scheme (string->uri (rdf-triple-object (car graph))))
                   'https))
         (cons (string->uri (rdf-triple-object (car graph)))
               (find-confirmations subject (cdr graph))))
        (else (find-confirmations subject (cdr graph)))))

(define (serve-confirmations expiration-date subject cnf)
  (let ((resource (format #f "@prefix solid: <http://www.w3.org/ns/solid/terms#> .

<~a> solid:oidcIssuer ~a .
"
                          (uri->string subject)
                          (string-join (map (lambda (uri)
                                              (format #f "<~a>" (uri->string uri)))
                                            cnf)
                                       ", "))))
    (values (build-response #:headers `((content-type text/turtle)
                                        (expires . ,expiration-date)))
            resource)))

(define*-public (get-provider-confirmations subject
                                            #:key
                                            (http-get http-get))
  (unless (equal? (uri-scheme subject) 'https)
    (set! subject (build-uri 'https
                             #:userinfo (uri-userinfo subject)
                             #:host (uri-host subject)
                             #:port (uri-port subject)
                             #:path (uri-path subject)
                             #:query (uri-query subject)
                             #:fragment (uri-fragment subject))))
  (let ((graph (fetch subject #:http-get http-get)))
    (cons (build-uri 'https
                     #:userinfo (uri-userinfo subject)
                     #:host (uri-host subject)
                     #:port (uri-port subject))
          (find-confirmations (uri->string subject) graph))))

(define*-public (confirm-provider subject issuer
                                  #:key (http-get http-get))
  (define (search lst)
    (if (null? lst)
        (raise-unconfirmed-provider subject issuer)
        (or (string=? (car lst) (uri->string issuer))
            (search (cdr lst)))))
  (unless (string=? (uri-host subject) (uri-host issuer))
    (search (get-provider-confirmations
             subject
             #:http-get http-get))))