~williewillus/public-inbox

This thread contains a patchset. You're looking at the original emails, but you may wish to use the patch review UI. Review patch
2 2

[PATCH r16] Eliminate flatten trick context into db and guild id

Details
Message ID
<20210301025924.1700183-1-vincent@vincent-lee.net>
DKIM signature
pass
Download raw message
Patch: +97 -114
---
Here's how things flowed before the previous commit:
* r16 module: db:get-trick-context
* db module: calls the contextualizer, which was defined in r16 module
* r16: contextualizer extracts guild id
* db: gets value back from contextualizer, construct trick ctx and return it
* r16: gets trick ctx back, calls db with the actual call it wanted to do
* db: does it

There's many hidden back and forth calls over the module boundary which in my mind points
to major complection of the db and main modules.

Instead, the main module always computes the context id of the message
(either the guild id, or the channel id if the former is absent, which should support
DM channels).

In the db module, contexts are removed and the db + context id is just passed directly
and once into the calls that need it.

I hope this is convincingly simpler for ok's/lgtm's.
Please patch onto your local tree and kick the tires a bit.

 r16.rkt      |  74 ++++++++++++++--------------
 trick-db.rkt | 137 ++++++++++++++++++++++-----------------------------
 2 files changed, 97 insertions(+), 114 deletions(-)

diff --git a/r16.rkt b/r16.rkt
index 39e8be4..74490c8 100755
--- a/r16.rkt
+++ b/r16.rkt
@@ -23,7 +23,8 @@
  (and (rc:message-author message)
       (rc:user-bot (rc:message-author message))))

(define (make-db filename) (db:make-trickdb rc:message-guild-id filename))
(define (context-id message)
  (or (rc:message-guild-id message) (rc:message-channel-id message)))

(define message-author-id (compose1 rc:user-id rc:message-author))

@@ -60,14 +61,12 @@
      (values (substring str 0 index) (string-trim (substring str index)))
      (values str #f))))

(define-syntax-rule (check-trick-prereqs db message text context-out name-out body-out body)
  (let ([context-out (db:get-trick-context db message)])
    (if context-out
      (let-values ([(name-out body-out) (split-once text)])
        (if (non-empty-string? name-out)
(define-syntax-rule (check-trick-prereqs message text context-out name-out body-out body)
  (let ([context-out (context-id message)])
    (let-values ([(name-out body-out) (split-once text)])
      (if (non-empty-string? name-out)
          body
          (~a "Missing the name for the trick!")))
      (~a "Cannot run tricks for this type of message!"))))
          (~a "Missing the name for the trick!")))))

(define deleter-thread
  (thread
@@ -103,55 +102,57 @@
         (if parent (trick-invocations parent) 0)))

(define (run-snippet client db message code)
  (let ([code (strip-backticks code)]
        [text (rc:message-content message)])
  (let ([code (strip-backticks code)])
    (with-typing-indicator client message
      (thunk (ev:run code (evaluation-ctx client message (db:get-trick-context db message) "" #f))))))
      (thunk (ev:run code (evaluation-ctx client message db (context-id message) "" #f))))))

(define (register-trick client db message text)
  (check-trick-prereqs
    db message text
    context name body
    message text
    context-id name body
    (cond
      [(not body) (~a "Trick " name " needs a body!")]
      [(db:add-trick! context name (thunk (make-trick body message #f)))
      [(db:add-trick! db context-id name (thunk (make-trick body message #f)))
       (~a "Successfully registered trick " name "!")]
      [else (~a "Trick " name " already exists!")])))

(define (call-trick client db message text)
  (check-trick-prereqs
    db message text
    context name body
    (let ([trick (db:get-trick context name)])
    message text
    context-id name body
    (let ([trick (db:get-trick db context-id name)])
      (if trick
        (begin
          (db:update-trick! context name (lambda (t) (set-trick-invocations! t (add1 (trick-invocations t))) t) (const #t))
          (db:update-trick! db context-id name
                            (lambda (t) (set-trick-invocations! t (add1 (trick-invocations t))) t)
                            (const #t))
          (with-typing-indicator client message
            (thunk (ev:run
              (trick-body trick)
              (evaluation-ctx
                client
                message
                context
                db
                context-id
                (or body "")
                #f)))))
        (~a "Trick " name " doesn't exist!")))))

(define (update-trick client db message text)
  (check-trick-prereqs
    db message text
    context name body
    message text
    context-id name body
    (cond
      [(not body) (~a "Trick " name " needs a body!")]
      [(db:update-trick! context name (curry make-trick body message) (curry can-modify? message))
      [(db:update-trick! db context-id name (curry make-trick body message) (curry can-modify? message))
       (~a "Successfully updated trick " name "!")]
      [else (~a "Trick " name " doesn't exist, or you can't modify it!")])))

(define (delete-trick client db message text)
  (check-trick-prereqs
    db message text
    context name body
    (if (db:remove-trick! context name (curry can-modify? message))
    message text
    context-id name _
    (if (db:remove-trick! db context-id name (curry can-modify? message))
      (~a "Successfully removed trick " name "!")
      (~a "Trick " name " doesn't exist, or you can't remove it!"))))

@@ -174,7 +175,7 @@
      (> (trick-invocations l) (trick-invocations r)))))

(define (popular-tricks client db message text)
  (let ([tricks (sort (db:all-tricks (db:get-trick-context db message)) cmp-tricks)])
  (let ([tricks (sort (db:all-tricks db (context-id message)) cmp-tricks)])
    (if (empty? tricks)
      (~a "There aren't any tricks registered in your guild! Use `" prefix "register` to create one.")
      (apply ~a "**Most popular tricks in your guild:**"
@@ -189,9 +190,9 @@

(define (show-trick client db message text)
  (check-trick-prereqs
    db message text
    context name _
    (let ([trick (db:get-trick context name)])
    message text
    context-id name _
    (let ([trick (db:get-trick db context-id name)])
      (if trick
        (~a
          "Trick **"
@@ -245,9 +246,9 @@
(define/contract (make-attachment data name type)
  (-> bytes? (or/c string? bytes?) (or/c symbol? string? bytes?) http:attachment?)
  (http:attachment data (~a type) name))
(define/contract ((call-subtrick client trick-ctx message parent-ctx) name arguments)
  (-> rc:client? db:trick-context? rc:message? any/c (-> (or/c symbol? string?) any/c any))
  (let ([trick (db:get-trick trick-ctx (~a name))])
(define/contract ((call-subtrick client db context-id message parent-ctx) name arguments)
  (-> rc:client? db:trickdb? string? rc:message? any/c (-> (or/c symbol? string?) any/c any))
  (let ([trick (db:get-trick db context-id (~a name))])
    (if trick
      (match-let
        ([(list stdout vals ... stderr)
@@ -257,7 +258,8 @@
                    (evaluation-ctx
                      client
                      message
                      trick-ctx
                      db
                      context-id
                      (if arguments (~a arguments) "")
                      parent-ctx)))
            list)])
@@ -307,7 +309,7 @@
          ; If empty byte string returned, return #f
          (and data (positive? (bytes-length data)) data)))))))

(define (evaluation-ctx client message trick-ctx args parent-ctx)
(define (evaluation-ctx client message db context-id args parent-ctx)
  (let* ([placeholder (make-placeholder #f)]
         [ctx
          `((message-contents . ,(rc:message-content message))
@@ -325,7 +327,7 @@
            (emote-image      . ,(emote-image client))
            (delete-caller    . ,(thunk (thread-send deleter-thread (cons client message))))
            (make-attachment  . ,make-attachment)
            (call-trick       . ,(call-subtrick client trick-ctx message placeholder))
            (call-trick       . ,(call-subtrick client db context-id message placeholder))
            (parent-context   . ,parent-ctx))])
    (placeholder-set! placeholder (make-hash ctx))
    (cons (make-reader-graph ctx) '(threading))))
@@ -403,7 +405,7 @@
  (let* ([client (rc:make-client token
                                 #:auto-shard #t
                                 #:intents (list rc:intent-guilds rc:intent-guild-messages))]
         [db     (make-db "tricks.rktd")])
         [db     (db:make-trickdb "tricks.rktd")])
    (thread
      (thunk
        (let loop ()
diff --git a/trick-db.rkt b/trick-db.rkt
index 5402989..e3326a7 100644
--- a/trick-db.rkt
+++ b/trick-db.rkt
@@ -1,121 +1,102 @@
#lang racket

(require
  (only-in racket-cord message?)
  racket/contract
  racket/hash
  racket/serialize)

(define saveable-trick? serializable?)

; A context id specifies the environment tricks belong to. Most commonly, it is a
; guild id or DM channel id
(define context-id? string?)
(define trick-key? string?)
; A contextualizer is a function mapping a message to a context key (e.g. guild ID)
(define contextualizer? (-> message? any))
; A permission check is a way to ensure a trick can be modified or removed.
(define permission-check? (or/c (-> saveable-trick? boolean?) #f))

(provide
 trickdb?
  (contract-out
    (saveable-trick? (-> any/c boolean?))
    (trick-context? (-> any/c boolean?))
    (make-trickdb (-> contextualizer? path-string? trickdb?))
    (get-trick-context (-> trickdb? message? (or/c trick-context? #f)))
    (list-tricks (-> trick-context? (listof trick-key?)))
    (all-tricks (-> trick-context? (listof (cons/c trick-key? saveable-trick?))))
    (get-trick (-> trick-context? trick-key? (or/c saveable-trick? #f)))
    (add-trick! (-> trick-context? trick-key? (-> saveable-trick?) boolean?))
    (update-trick! (-> trick-context? trick-key? (-> saveable-trick? saveable-trick?) permission-check? boolean?))
    (remove-trick! (-> trick-context? trick-key? permission-check? boolean?))
    (make-trickdb (-> path-string? trickdb?))
    (list-tricks (-> trickdb? context-id? (listof trick-key?)))
    (all-tricks (-> trickdb? context-id? (listof (cons/c trick-key? saveable-trick?))))
    (get-trick (-> trickdb? context-id? trick-key? (or/c saveable-trick? #f)))
    (add-trick! (-> trickdb? context-id? trick-key? (-> saveable-trick?) boolean?))
    (update-trick! (-> trickdb? context-id? trick-key? (-> saveable-trick? saveable-trick?) permission-check? boolean?))
    (remove-trick! (-> trickdb? context-id? trick-key? permission-check? boolean?))
    (commit-db! (-> trickdb? boolean?))))

; data: guild -> trick-context
(struct trickdb (data filename contextualizer (dirty #:mutable) lock))

; data: trick-key -> trick
(struct trick-context (data db))
; data: context-id -> (trick-key -> trick)
(struct trickdb (data filename (dirty #:mutable) lock))

(define (serialize-db db)
  (serialize
    (hash-map
      (trickdb-data db)
      ; Extract just the data portion of a context
      (lambda (k v) (cons k (trick-context-data v))))))

(define (deserialize-db db data)
  (make-hash
    (map
      (lambda (e) (cons (car e) (trick-context (cdr e) db)))
      (deserialize data))))

(define (try-read-db db filename default)
  (serialize (hash->list trickdb-data db)))

(define (try-read-db filename default)
  (with-handlers ([exn:fail? (lambda (e) (displayln e (current-error-port)) (default))])
    (deserialize-db db (read (open-input-file filename)))))

(define (make-trickdb contextualizer filename)
  ; Due to the contexts having backreferences for locking, we instantiate the db first and then read in the ctxs
  (let ((db (trickdb
              (make-hash)
              filename
              contextualizer
              #f
              (make-semaphore 1))))
    (hash-union! (trickdb-data db) (try-read-db db filename make-hash))
    db))
    (make-hash (deserialize (read (open-input-file filename))))))

(define (make-trickdb filename)
  (let ([data (try-read-db filename make-hash)])
    (trickdb
     data
     filename
     #f
     (make-semaphore 1))))

(define-syntax-rule (with-db-lock db . body)
  (call-with-semaphore (trickdb-lock db) (thunk . body)))

(define (mark-dirty ctx) (set-trickdb-dirty! (trick-context-db ctx) #t))

(define (get-trick-context db message)
  (let ((id ((trickdb-contextualizer db) message)))
    (and id
      (with-db-lock db
        (hash-ref!
          (trickdb-data db)
          id
          (thunk
            (trick-context (make-hash) db)))))))

(define (list-tricks context)
  (with-db-lock (trick-context-db context)
    (hash-keys (trick-context-data context))))

(define (all-tricks context)
  (with-db-lock (trick-context-db context)
    (hash->list (trick-context-data context))))

(define (get-trick context name)
  (with-db-lock (trick-context-db context)
    (hash-ref (trick-context-data context) name #f)))

(define (add-trick! context name thunk)
  (with-db-lock (trick-context-db context)
    (let* ((table  (trick-context-data context))
(define (mark-dirty db) (set-trickdb-dirty! db #t))

; Note: db lock must be held
(define (get-submap db context-id)
  (and context-id
       (hash-ref!
        (trickdb-data db)
        context-id
        (thunk (make-hash)))))

(define (list-tricks db context-id)
  (with-db-lock db
    (hash-keys (get-submap db context-id))))

(define (all-tricks db context-id)
  (with-db-lock db
    (hash->list (get-submap db context-id))))

(define (get-trick db context-id name)
  (with-db-lock db
    (hash-ref (get-submap db context-id) name #f)))

(define (add-trick! db context-id name thunk)
  (with-db-lock db
    (let* ((table  (get-submap db context-id))
           (create (not (hash-has-key? table name))))
      (when create
        (log-info (~a "Trick created: " name))
        (mark-dirty context)
        (mark-dirty db)
        (hash-set! table name (thunk)))
      create)))

(define (update-trick! context name thunk perm-check)
  (with-db-lock (trick-context-db context)
    (let* ((table  (trick-context-data context))
(define (update-trick! db context-id name thunk perm-check)
  (with-db-lock db
    (let* ((table  (get-submap db context-id))
           (modify (and (hash-has-key? table name) (perm-check (hash-ref table name)))))
      (when modify
        (log-info (~a "Trick updated: " name))
        (mark-dirty context)
        (mark-dirty db)
        (hash-set! table name (thunk (hash-ref table name))))
      modify)))

(define (remove-trick! context name perm-check)
  (with-db-lock (trick-context-db context)
    (let* ((table  (trick-context-data context))
(define (remove-trick! db context-id name perm-check)
  (with-db-lock db
    (let* ((table  (get-submap db context-id))
           (remove (and (hash-has-key? table name) (perm-check (hash-ref table name)))))
      (when remove
        (log-info (~a "Trick deleted: " name))
        (mark-dirty context)
        (mark-dirty db)
        (hash-remove! table name))
      remove)))

-- 
2.30.1

[r16/patches/linux_buildtest.yml] build success

builds.sr.ht
Details
Message ID
<C9LOGXM8FI8R.3F93BQS14DXLS@cirno2>
In-Reply-To
<20210301025924.1700183-1-vincent@vincent-lee.net> (view parent)
DKIM signature
missing
Download raw message
r16/patches/linux_buildtest.yml: SUCCESS in 1m32s

[Eliminate flatten trick context into db and guild id][0] from [Vincent Lee][1]

[0]: https://lists.sr.ht/~williewillus/public-inbox/patches/20710
[1]: mailto:vincent@vincent-lee.net

✓ #444127 SUCCESS r16/patches/linux_buildtest.yml https://builds.sr.ht/~williewillus/job/444127
Details
Message ID
<58276f6f-a36e-226c-afcb-7b47213d550d@gmail.com>
In-Reply-To
<20210301025924.1700183-1-vincent@vincent-lee.net> (view parent)
DKIM signature
pass
Download raw message
probably should have done this to start with, tbh :wacko:
yeah, haven't tested but from reading it lgtm
Reply to thread Export thread (mbox)