Switch to a more sensible error reporting system

1 files changed, 62 insertions, 22 deletions

diff --git a/src/scm/webid-oidc/provider-confirmation.scm b/src/scm/webid-oidc/provider-confirmation.scm
index 1baf2f3..aa9e085 100644
--- a/src/scm/webid-oidc/provider-confirmation.scm
+++ b/src/scm/webid-oidc/provider-confirmation.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -22,24 +22,50 @@
   #:use-module (web response)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 optargs)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (webid-oidc web-i18n)
   #:use-module (rdf rdf)
-  #:use-module (turtle tordf))
+  #:use-module (turtle tordf)
+  #:declarative? #t
+  #:export
+  (
+
+   &unconfirmed-provider
+   make-unconfirmed-provider
+   unconfirmed-provider?
+
+   get-provider-confirmations
+   confirm-provider
+   ))
+
+(define-exception-type
+  &unconfirmed-provider
+  &external-error
+  make-unconfirmed-provider
+  unconfirmed-provider?)
 
 (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)))))
+  (let search-graph ((graph graph)
+                     (confirmations '()))
+    (match graph
+      (() (reverse confirmations))
+      ((hd graph ...)
+       (match `(,(rdf-triple-subject hd)
+                ,(rdf-triple-predicate hd)
+                ,(rdf-triple-object hd))
+         (((? (cute equal? subject <>) _)
+           "http://www.w3.org/ns/solid/terms#oidcIssuer"
+           (? string?
+              (= string->uri
+                 (and (? uri? provider)
+                      (= uri-scheme 'https)))))
+          (search-graph graph `(,provider ,@confirmations)))
+         (else
+          (search-graph graph confirmations)))))))
 
 (define (serve-confirmations expiration-date subject cnf)
   (let ((resource (format #f "@prefix solid: <http://www.w3.org/ns/solid/terms#> .
@@ -55,9 +81,9 @@
                                         (expires . ,expiration-date)))
             resource)))
 
-(define*-public (get-provider-confirmations subject
-                                            #:key
-                                            (http-get http-get))
+(define* (get-provider-confirmations subject
+                                     #:key
+                                     (http-get http-get))
   (unless (equal? (uri-scheme subject) 'https)
     (set! subject (build-uri 'https
                              #:userinfo (uri-userinfo subject)
@@ -73,14 +99,28 @@
                      #:port (uri-port subject))
           (find-confirmations (uri->string subject) graph))))
 
-(define*-public (confirm-provider subject issuer
-                                  #:key (http-get http-get))
+(define* (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))))
+    (let search ((providers (get-provider-confirmations
+                             subject
+                             #:http-get http-get)))
+      (match providers
+        (()
+         (let ((final-message
+                (format #f ("~s has not set ~s as an identity provider")
+                        (uri->string subject)
+                        (uri->string issuer))))
+           (raise-exception
+            (make-exception
+             (make-unconfirmed-provider)
+             (make-exception-with-message final-message)))))
+        (((? (cute equal? <> issuer) _) . _)
+         #t)
+        ((_ providers ...)
+         (search providers))))))