Switch to a more sensible error reporting system

1 files changed, 63 insertions, 50 deletions

diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index 5ee84db..4b38248 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -25,6 +25,8 @@
   #:use-module ((webid-oidc server read) #:prefix ldp:)
   #:use-module ((webid-oidc server update) #:prefix ldp:)
   #:use-module ((webid-oidc server delete) #:prefix ldp:)
+  #:use-module ((webid-oidc server resource wac) #:prefix wac:)
+  #:use-module ((webid-oidc server resource path) #:prefix ldp:)
   #:use-module (webid-oidc server precondition)
   #:use-module (webid-oidc http-link)
   #:use-module ((webid-oidc parameters) #:prefix p:)
@@ -38,33 +40,33 @@
   #:use-module (web client)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 receive)
-  #:use-module (ice-9 i18n)
+  #:use-module (webid-oidc web-i18n)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 suspendable-ports)
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
   #:use-module (sxml simple)
-  #:use-module (srfi srfi-19))
+  #:use-module (srfi srfi-19)
+  #:declarative? #t
+  #:export
+  (
+   make-authenticator
+   make-resource-server
+   ))
 
-(define (G_ text)
-  (let ((out (gettext text)))
-    (if (string=? out text)
-        ;; No translation, disambiguate
-        (car (reverse (string-split text #\|)))
-        out)))
-
-(define*-public (make-authenticator #:key
-                                    (server-uri #f)
-                                    (current-time current-time)
-                                    (http-get http-get))
+(define* (make-authenticator #:key
+                             (server-uri #f)
+                             (http-get http-get))
   (unless (and server-uri (uri? server-uri))
-    (error "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))
+    (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri).")))
   (lambda (request request-body)
     (let ((headers (request-headers request))
           (uri (request-uri request))
           (method (request-method request))
           (current-time ((p:current-date))))
-      (parameterize ((p:current-date current-time)) ;; fix the date
+      (parameterize ((web-locale request)
+                     (p:current-date current-time)) ;; fix the date
         (let ((authz (assoc-ref headers 'authorization))
               (dpop (assoc-ref headers 'dpop))
               (full-uri (build-uri (uri-scheme server-uri)
@@ -82,10 +84,14 @@
                (eq? (car authz) 'dpop)
                (with-exception-handler
                    (lambda (error)
-                     (format (current-error-port)
-                             (G_ "~a: authentication failure: ~a\n")
-                             (date->string current-time)
-                             (error->str error))
+                     (if (exception-with-message? error)
+                         (format (current-error-port)
+                                 (G_ "~a: authentication failure: ~a\n")
+                                 (date->string current-time)
+                                 (exception-message error))
+                         (format (current-error-port)
+                                 (G_ "~a: authentication failure\n")
+                                 (date->string current-time)))
                      #f)
                  (lambda ()
                    ;; Sometimes the access is the cadr as a symbol,
@@ -151,7 +157,7 @@
             (return
              (build-response
               #:code 412
-              #:reason-phrase "Precondition Failed")
+              #:reason-phrase (W_ "reason-phrase|Precondition Failed"))
              #f
              user))
         (lambda ()
@@ -166,7 +172,7 @@
             (return
              (build-response
               #:code 304
-              #:reason-phrase "Not Modified"
+              #:reason-phrase (W_ "reason-phrase|Not Modified")
               #:headers headers)
              #f
              user))
@@ -175,14 +181,14 @@
             (check-precondition path if-match if-none-match etag))
           (respond-normal)))))
 
-(define*-public (make-resource-server
-                 #:key
-                 (server-uri #f)
-                 (owner #f)
-                 (authenticator #f)
-                 (http-get http-get))
+(define* (make-resource-server
+          #:key
+          (server-uri #f)
+          (owner #f)
+          (authenticator #f)
+          (http-get http-get))
   (unless owner
-    (error "The owner is not defined."))
+    (fail (G_ "The owner is not defined.")))
   (declare-link-header!)
   (unless authenticator
     (set! authenticator
@@ -190,7 +196,8 @@
            #:server-uri server-uri
            #:http-get http-get)))
   (lambda (request request-body)
-    (parameterize ((p:current-date ((p:current-date)))) ;; Fix the date
+    (parameterize ((p:current-date ((p:current-date))) ;; Fix the date
+                   (web-locale request))
       (let ((user (authenticator request request-body)))
         (handle-errors
          (lambda (return)
@@ -253,7 +260,7 @@
                                (request-links request)))))
                     (return
                      (build-response
-                      #:code 201 #:reason-phrase "Created"
+                      #:code 201 #:reason-phrase (W_ "reason-phrase|Created")
                       #:headers
                       `((location . ,(ldp:create server-uri owner user
                                                  (uri-path (request-uri request))
@@ -275,15 +282,21 @@
                  ""
                  user)))))
          (lambda (return error)
-           (if (cannot-fetch-group? error)
-               (format (current-error-port) (G_ "Warning: ~a\n")
-                       (error->str error))
+           (if (wac:cannot-fetch-group? error)
+               (if (exception-with-message? error)
+                   (format (current-error-port)
+                           (G_ "~a: ignoring a group that cannot be fetched: ~a\n")
+                           (date->string ((p:current-date)))
+                           (exception-message error))
+                   (format (current-error-port)
+                           (G_ "~a: ignoring a group that cannot be fetched\n")
+                           (date->string ((p:current-date)))))
                (cond
-                ((uri-slash-semantics-error? error)
+                ((ldp:uri-slash-semantics-error? error)
                  (return
                   (build-response
                    #:code 301
-                   #:reason-phrase "Found"
+                   #:reason-phrase (W_ "reason-phrase|Found")
                    #:headers
                    `((location
                       . ,(build-uri
@@ -294,55 +307,55 @@
                           #:path (uri-slash-semantics-error-expected-path error)))))
                   #f
                   user))
-                ((or (path-not-found? error)
-                     (auxiliary-resource-absent? error)
-                     (forbidden? error))
+                ((or (ldp:path-not-found? error)
+                     (ldp:auxiliary-resource-absent? error)
+                     (wac:forbidden? error))
                  (if user
                      ;; That’s a forbidden
                      (return
-                      (build-response #:code 403 #:reason-phrase "Forbidden")
+                      (build-response #:code 403 #:reason-phrase (W_ "reason-phrase|Forbidden"))
                       #f
                       user)
                      (return
-                      (build-response #:code 401 #:reason-phrase "Unauthorized"
+                      (build-response #:code 401 #:reason-phrase (W_ "reason-phrase|Unauthorized")
                                       #:headers `((www-authenticate . ((DPoP)))))
                       #f
                       user)))
-                ((or (cannot-delete-root? error))
+                ((ldp:cannot-delete-root? error)
                  (return
                   (build-response
                    #:code 405
-                   #:reason-phrase "Method Not Allowed")
+                   #:reason-phrase (W_ "reason-phrase|Method Not Allowed"))
                   #f
                   user))
-                ((or (container-not-empty? error)
-                     (incorrect-containment-triples? error)
-                     (path-is-auxiliary? error))
+                ((or (ldp:container-not-empty? error)
+                     (ldp:incorrect-containment-triples? error)
+                     (ldp:path-is-auxiliary? error))
                  (return
                   (build-response
                    #:code 409
-                   #:reason-phrase "Conflict")
+                   #:reason-phrase (W_ "reason-phrase|Conflict"))
                   #f
                   user))
-                ((unsupported-media-type? error)
+                ((ldp:unsupported-media-type? error)
                  (return
                   (build-response
                    #:code 415
-                   #:reason-phrase "Unsupported Media Type")
+                   #:reason-phrase (W_ "reason-phrase|Unsupported Media Type"))
                   #f
                   user))
                 ((precondition-failed? error)
                  (return
                   (build-response
                    #:code 412
-                   #:reason-phrase "Precondition Failed")
+                   #:reason-phrase (W_ "reason-phrase|Precondition Failed"))
                   #f
                   user))
                 ((not-acceptable? error)
                  (return
                   (build-response
                    #:code 406
-                   #:reason-phrase "Not Acceptable")
+                   #:reason-phrase (W_ "reason-phrase|Not Acceptable"))
                   #f
                   user))
                 (else