2 files changed, 79 insertions(+), 24 deletions(-)

M frontends/discord.rkt
M utils.rkt

@@ 130,12 130,12 @@
             proc
             (thunk (change-counter channel -1))))))
 
-    (define/off-thread (do-delete-message message)
+    (define/off-thread (do-delete-message channel-id message-id)
       (with-handlers ([exn:fail:network? identity])
         (http:delete-message
          client
-         (hash-ref message 'channel_id)
-         (hash-ref message 'id))))
+         channel-id
+         message-id)))
 
     (define/off-thread (get-emote-image id)
       (with-handlers ([exn:fail? (const #"")])


@@ 184,11 184,24 @@
       (make-expiring-cache
        current-inexact-monotonic-milliseconds
        (* 10 60 1000))) ;; 10 min as ms
+
+    ;; cache of msgid -> (channelid . msgid) of recent invocations to
+    ;; their responses. Allows the response to be deleted when the invocation is deleted.
+    ;; Note that message ids are globally unique on Discord, but we need to keep the
+    ;; channel id around for the value, because the http api requires it
+    (define recent-messages-cache
+      (make-expiring-cache
+       current-inexact-monotonic-milliseconds
+       (* 5 60 1000))) ;; 5 min as ms
+
     (thread-loop
      (sleep 30)
-     (define purged (length (expiring-cache-purge emote-image-cache)))
-     (when (> purged 0)
-       (log-r16-debug "Purged ~a emote image bytestrings" purged)))
+     (let ([purged (length (expiring-cache-purge emote-image-cache))])
+       (when (> purged 0)
+         (log-r16-debug "Purged ~a emote image bytestrings" purged)))
+     (let ([purged (length (expiring-cache-purge recent-messages-cache))])
+       (when (> purged 0)
+         (log-r16-debug "Purged ~a recent messages" purged))))
 
     (define/public (get-enrich-context)
       (define deleted-box (current-deleted-box))


@@ 216,7 229,10 @@
         ;; This is to prevent tricks from abusing the bot to download unrelated emotes
         ;; from other servers it's not in.
         (and (set-member? (unbox known-emotes) id)
-             (let ([data (expiring-cache-get emote-image-cache id get-emote-image)])
+             (let ([data (expiring-cache-refresh
+                          emote-image-cache
+                          id
+                          get-emote-image)])
                (and (positive? (bytes-length data))
                     data))))
 


@@ 273,7 289,8 @@
 
       (define (delete-caller)
         (when (box-cas! deleted-box #f #t)
-          (do-delete-message message))
+          (do-delete-message (hash-ref message 'channel_id)
+                             (hash-ref message 'id)))
         (void))
 
       (define reply-contents


@@ 313,6 330,8 @@
       (rc:on-event 'raw-guild-create client guild-create)
       (rc:on-event 'raw-guild-delete client guild-delete)
       (rc:on-event 'raw-guild-emojis-update client guild-emojis-update)
+      (rc:on-event 'raw-message-delete client message-delete)
+      (rc:on-event 'raw-message-delete-bulk client message-delete-bulk)
       (rc:start-client client))
 
     (define (extract-emojis data)


@@ 351,6 370,23 @@
                  (extract-emojis payload))
       (recompute-known-emotes))
 
+    (define (message-delete-impl invoking-message-id)
+      (define value (expiring-cache-get recent-messages-cache invoking-message-id))
+      (when value
+        (define response-channel-id (car value))
+        (define response-message-id (cdr value))
+        (do-delete-message response-channel-id response-message-id))
+      (void))
+
+    (define (message-delete _ws-client _client payload)
+      (message-delete-impl (hash-ref payload 'id)))
+
+    (define (message-delete-bulk _ws-client _client payload)
+      ;; XXX: this does all the calls to message-delete-impl serially when they could
+      ;; probably be issued in parallel
+      (for ([id (in-list (hash-ref payload 'ids))])
+        (message-delete-impl id)))
+
     (define (message-received _ws-client _client message)
       (parameterize ([current-frontend this]
                      [current-message message]


@@ 372,10 408,17 @@
                     (log-r16-error (~a "Internal error:\n" error-message))
                     (list (~a ":warning: Internal error:\n" error-message)))])
                 (func func-args)))
-            (create-message-with-contents
-             channel
-             (and (not (unbox (current-deleted-box))) message)
-             contents)))))
+            (define not-deleted (not (unbox (current-deleted-box))))
+            (define response
+              (create-message-with-contents
+               channel
+               (and not-deleted message)
+               contents))
+            (when (and not-deleted response)
+              (define response-id (hash-ref response 'id))
+              (expiring-cache-put recent-messages-cache
+                                  (hash-ref message 'id)
+                                  (cons channel response-id)))))))
 
     (define (create-message-with-contents channel reply-message contents)
       (define char-cap 2000)

@@ 7,6 7,7 @@
          make-expiring-cache
          expiring-cache-purge
          expiring-cache-put
+         expiring-cache-refresh
          expiring-cache-get)
 
 (define-syntax (thread-loop stx)


@@ 44,13 45,12 @@
        (expiring-cache-ttl cache)))
   (call-with-semaphore
    (expiring-cache-entries-lock cache)
-   (lambda ()
+   (λ ()
      (define entries (expiring-cache-entries cache))
      (define keys-to-remove
-       (for/fold ([acc null])
-                 ([(key timestamp-value) (in-hash entries)]
+       (for/list ([(key timestamp-value) (in-hash entries)]
                   #:when (is-stale (car timestamp-value)))
-         (cons key acc)))
+         key))
      (for ([key (in-list keys-to-remove)])
        (hash-remove! entries key))
      keys-to-remove)))


@@ 66,10 66,22 @@
      (define now ((expiring-cache-timestamp-getter cache)))
      (hash-set! entries k (cons now v)))))
 
-;; get the cached entry for k, computing it using `compute` if not present.
-;; if k is already in cache, its expiration timer is refreshed.
-(define/contract (expiring-cache-get cache k
-                                     [compute-value (λ (_) (error "Missing key"))])
+;; get the cached entry for k if it exists, else #f
+(define/contract (expiring-cache-get cache k)
+  (-> expiring-cache? any/c any/c)
+  (call-with-semaphore
+   (expiring-cache-entries-lock cache)
+   (λ ()
+     (define timestamp-and-value
+       (hash-ref (expiring-cache-entries cache) k #f))
+     (and timestamp-and-value
+          (cdr timestamp-and-value)))))
+
+;; get the cached entry for k, computing it using `compute-value` if not present.
+;; in either case, the ttl is extended to the maximum
+(define/contract (expiring-cache-refresh
+                  cache k
+                  [compute-value (λ (_) (error "Missing key"))])
   (-> expiring-cache? any/c (-> any/c any/c) any/c)
   (call-with-semaphore
    (expiring-cache-entries-lock cache)


@@ 108,11 120,11 @@
     ;; but the test is single threaded so whatever.
     (define entries (expiring-cache-entries cache))
 
-    (check-eqv? 1 (expiring-cache-get cache 0 compute-value))
+    (check-eqv? 1 (expiring-cache-refresh cache 0 compute-value))
     (check-eqv? 1 (unbox times-compute-value-called))
 
     (set-box! fake-current-timestamp 1)
-    (check-eqv? 2 (expiring-cache-get cache 1 compute-value))
+    (check-eqv? 2 (expiring-cache-refresh cache 1 compute-value))
     (check-eqv? 2 (unbox times-compute-value-called))
 
     (check-true (hash-has-key? entries 0) "Key 0 should still be cached")


@@ 138,12 150,12 @@
                    ttl))
 
     ;; Fetch key 0 and populate the cache
-    (check-eqv? 1 (expiring-cache-get cache 0 compute-value))
+    (check-eqv? 1 (expiring-cache-refresh cache 0 compute-value))
     (check-eqv? 1 (unbox times-compute-value-called))
 
     ;; Advance one time unit and fetch it again, this should hit in cache, but update the ttl
     (set-box! fake-current-timestamp (add1 (unbox fake-current-timestamp)))
-    (check-eqv? 1 (expiring-cache-get cache 0 compute-value))
+    (check-eqv? 1 (expiring-cache-refresh cache 0 compute-value))
     (check-eqv? 1 (unbox times-compute-value-called) "Should have hit in cache")
 
     ;; Advance to when key *would have* been purged if we hadn't touched it a second time