0c3f4706f0ec954ff05fa4e34fee05b728b4f412 — Vincent Lee 9 months ago f546ac7
discord: If an invocation is deleted within 5 min, r16 also deletes its response
2 files changed, 79 insertions(+), 24 deletions(-)

M frontends/discord.rkt
M utils.rkt
M frontends/discord.rkt => frontends/discord.rkt +55 -12
@@ 130,12 130,12 @@
            (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])
         (hash-ref message 'channel_id)
         (hash-ref message 'id))))

    (define/off-thread (get-emote-image id)
      (with-handlers ([exn:fail? (const #"")])

@@ 184,11 184,24 @@
       (* 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
       (* 5 60 1000))) ;; 5 min as ms

     (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
               (and (positive? (bytes-length 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)))

      (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))

    (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))

    (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)))
             (and (not (unbox (current-deleted-box))) message)
            (define not-deleted (not (unbox (current-deleted-box))))
            (define response
               (and not-deleted message)
            (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)

M utils.rkt => utils.rkt +24 -12
@@ 7,6 7,7 @@

(define-syntax (thread-loop stx)

@@ 44,13 45,12 @@
       (expiring-cache-ttl cache)))
   (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)))
     (for ([key (in-list keys-to-remove)])
       (hash-remove! entries key))

@@ 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)
   (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)
   (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 @@

    ;; 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