From d1269bbc33f074d2c1d58da9f7736801468eceab Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonyg@leastfixedpoint.com>
Date: Wed, 12 Jun 2019 00:23:39 +0100
Subject: [PATCH] Improved error signalling

---
 imperative/distributed/client.rkt        |  9 +++++++--
 imperative/distributed/federation.rkt    | 13 +++++++------
 imperative/distributed/server.rkt        | 12 ++++++------
 imperative/distributed/wire-protocol.rkt |  2 +-
 4 files changed, 21 insertions(+), 15 deletions(-)

diff --git a/imperative/distributed/client.rkt b/imperative/distributed/client.rkt
index 23cf308..11c1b6f 100644
--- a/imperative/distributed/client.rkt
+++ b/imperative/distributed/client.rkt
@@ -72,8 +72,13 @@
   (on (message (server-packet address (Ping)))
       (w (Pong)))
 
-  (on (message (server-packet address (Err $detail)))
-      (log-syndicate/distributed-error "Error from ~a: ~v" address detail)
+  (on (message (server-packet address (Err $detail $context)))
+      (log-syndicate/distributed-error "Error from ~a: ~v~a"
+                                       address
+                                       detail
+                                       (if context
+                                           (format " ~v" context)
+                                           ""))
       (stop-current-facet))
 
   (on (message (server-packet address (Turn $items)))
diff --git a/imperative/distributed/federation.rkt b/imperative/distributed/federation.rkt
index cb74a3e..a03da7a 100644
--- a/imperative/distributed/federation.rkt
+++ b/imperative/distributed/federation.rkt
@@ -313,8 +313,9 @@
                     [link-matches (hash)] ;; (Hash LocalID (Set (Listof Assertion)))
                     )
 
-             (define (err! detail)
-               (send! (server-proposal management-scope (message-server->poa linkid (Err detail))))
+             (define (err! detail [context #f])
+               (send! (server-proposal management-scope (message-server->poa linkid
+                                                                             (Err detail context))))
                (reset-turn! turn)
                (stop-current-facet))
 
@@ -362,7 +363,7 @@
                          (log-syndicate/federation-error
                           "Duplicate subscription ~a, ID ~a, from link ~a."
                           spec subid linkid)
-                         (err! 'duplicate-subscription)]
+                         (err! 'duplicate-endpoint item)]
                         [else
                          (link-subs (hash-set (link-subs) subid localid))
                          (when (not known?) (specs (hash-set (specs) spec localid)))
@@ -404,7 +405,7 @@
                         [#f (log-syndicate/federation-error
                              "Mention of nonexistent subscription ID ~v from link ~v."
                              subid linkid)
-                            (err! 'nonexistent-subscription)]
+                            (err! 'nonexistent-endpoint item)]
                         [localid
                          (link-subs (hash-remove (link-subs) subid))
                          (unsubscribe! localid linkid)])]
@@ -416,7 +417,7 @@
                       (define matches (hash-ref (link-matches) localid set))
                       (cond
                         [(set-member? matches captures)
-                         (err! 'duplicate-capture)]
+                         (err! 'duplicate-capture item)]
                         [else
                          (link-matches (hash-set (link-matches) localid (set-add matches captures)))
                          (call-with-sub
@@ -439,7 +440,7 @@
                      [(Del localid captures)
                       (define matches (hash-ref (link-matches) localid set))
                       (if (not (set-member? matches captures))
-                          (err! 'nonexistent-capture)
+                          (err! 'nonexistent-capture item)
                           (let ((new-matches (set-remove matches captures)))
                             (link-matches (if (set-empty? new-matches)
                                               (hash-remove (link-matches) localid)
diff --git a/imperative/distributed/server.rkt b/imperative/distributed/server.rkt
index 56e6d59..ff4455c 100644
--- a/imperative/distributed/server.rkt
+++ b/imperative/distributed/server.rkt
@@ -27,7 +27,7 @@
          (on-start
           (match (let-event [(message (message-poa->server id $p))] p)
             [(Connect scope) (react (connected id scope root-facet))]
-            [_ (send! (message-server->poa id (Err 'connection-not-setup)))]))))
+            [_ (send! (message-server->poa id (Err 'connection-not-setup #f)))]))))
 
 (define (connected id scope root-facet)
   (define endpoints (hash))
@@ -36,8 +36,8 @@
 
   (assert (server-active scope))
 
-  (define (send-error! detail)
-    (send! (message-server->poa id (Err detail)))
+  (define (send-error! detail [context #f])
+    (send! (message-server->poa id (Err detail context)))
     (reset-turn! turn)
     (stop-facet root-facet))
 
@@ -48,7 +48,7 @@
            (match item
              [(Assert ep a)
               (if (hash-has-key? endpoints ep)
-                  (send-error! 'duplicate-endpoint)
+                  (send-error! 'duplicate-endpoint item)
                   (react
                    (define ep-facet (current-facet))
                    (set! endpoints (hash-set endpoints ep ep-facet))
@@ -65,7 +65,7 @@
                       #:on-message (! Msg)))))]
              [(Clear ep)
               (match (hash-ref endpoints ep #f)
-                [#f (send-error! 'unknown-endpoint)]
+                [#f (send-error! 'nonexistent-endpoint item)]
                 [ep-facet (stop-facet ep-facet (extend-turn! turn (End ep)))])]
              [(Message body)
               (send! (server-proposal scope body))]))]
@@ -74,4 +74,4 @@
         [(Pong)
          (void)]
         [_
-         (send-error! 'invalid-message)])))
+         (send-error! 'invalid-message p)])))
diff --git a/imperative/distributed/wire-protocol.rkt b/imperative/distributed/wire-protocol.rkt
index 4d32adb..1d8e511 100644
--- a/imperative/distributed/wire-protocol.rkt
+++ b/imperative/distributed/wire-protocol.rkt
@@ -22,7 +22,7 @@
 (message-struct Del (endpoint-name captures))
 (message-struct Msg (endpoint-name captures))
 (message-struct End (endpoint-name))
-(message-struct Err (detail))
+(message-struct Err (detail context))
 
 ;; Transport-related; Bidirectional
 (message-struct Ping ())