first commit

readme.txt

@@ -0,0 +1 @@
+to do: write readme.

source.rkt

@@ -0,0 +1,149 @@
+#lang racket
+
+(require net/url)
+(require json)
+(require db)
+
+(define polls-per-day 4) ; configurable, set to any positive integer
+(define midnight-seconds (* 4 3600)) ; UTC-4, adjust accordingly
+(define channel-id "CHANNEL ID") ;replace this with the channel id, as a string
+(define bot-token "BOT TOKEN") ; replace this with the bot token, as a string
+
+(when (or (eq? channel-id "CHANNEL ID") (eq? bot-token "BOT TOKEN"))
+  (display "Please set the channel-id and bot-token variables.")
+  (newline)
+  (exit))
+
+(define dbc (sqlite3-connect #:database "database.db" #:mode 'create))
+
+(unless (table-exists? dbc "entries")
+  (unless (file-exists? "entries.txt")
+    (display "Please put the entries into a file named entries.txt, separated by newlines.")
+    (newline)
+    (exit))
+  (start-transaction dbc)
+  (query-exec dbc "create table entries (name text unique not null, round int not null)")
+  (query-exec dbc "create table open_polls (round int not null, msg_id text not null)")
+  (query-exec dbc "create table closed_polls (round int not null, entry_1 text not null, entry_2 text not null, voters_1 text not null, voters_2 text not null)")
+  (for ((entry (string-split (port->string (open-input-file "entries.txt") #:close? #t) "\n")))
+    (query-exec dbc "insert into entries (name, round) values (?, 1)" entry))
+  (commit-transaction dbc))
+
+(define (api-get endpoint)
+  (string->jsexpr
+    (port->string
+      (get-pure-port
+        (string->url (string-append "https://discord.com/api/v10" endpoint))
+        (list (string-append "Authorization: Bot " bot-token)))
+      #:close? #t)))
+
+(define (api-post endpoint content)
+  (string->jsexpr
+    (port->string
+      (post-pure-port
+        (string->url (string-append "https://discord.com/api/v10" endpoint))
+        (string->bytes/utf-8 (jsexpr->string content))
+        (list
+          (string-append "Authorization: Bot " bot-token)
+          "Content-Type: application/json"))
+      #:close? #t)))
+
+(define (get-completed-poll-answers msg-id (sleep-time 1))
+  (let ((resp (api-get (string-append "/channels/" channel-id "/messages/" msg-id))))
+    (if (hash-ref (hash-ref (hash-ref resp 'poll) 'results) 'is_finalized)
+      (hash-ref (hash-ref resp 'poll) 'answers)
+      (begin
+        (sleep sleep-time)
+        (get-completed-poll-answers msg-id (* sleep-time 2))))))
+
+(define (get-users msg-id answer-id (so-far '()) (last-user #f))
+  (let* ((base-endpoint
+           (string-append
+             "/channels/" channel-id "/polls/" msg-id "/answers/" (number->string answer-id) "?limit=100"))
+         (resp (api-get (if last-user (string-append base-endpoint "&after=" last-user) base-endpoint)))
+         (users (hash-ref resp 'users))
+         (user-ids (map (lambda (s) (hash-ref s 'id)) users)))
+    (if (empty? user-ids)
+      so-far
+      (get-users msg-id answer-id (append user-ids so-far) (last user-ids)))))
+
+(define (process-completed-poll round msg-id)
+  (api-post (string-append "/channels/" channel-id "/polls/" msg-id "/expire") (make-hash))
+  (let* ((answers (get-completed-poll-answers msg-id))
+         (e1id (hash-ref (car answers) 'answer_id))
+         (e2id (hash-ref (cadr answers) 'answer_id))
+         (e1t (hash-ref (hash-ref (car answers) 'poll_media) 'text))
+         (e2t (hash-ref (hash-ref (cadr answers) 'poll_media) 'text))
+         (e1u (get-users msg-id e1id))
+         (e2u (get-users msg-id e2id))
+         (e1w (>= (length e1u) (length e2u)))
+         (e2w (>= (length e2u) (length e1u))))
+    (start-transaction dbc)
+    (query-exec dbc
+      "insert into closed_polls (round, entry_1, entry_2, voters_1, voters_2) values (?, ?, ?, ?, ?)"
+      round e1t e2t (string-join e1u ",") (string-join e2u ","))
+    (query-exec dbc "delete from open_polls where msg_id = ?" msg-id)
+    (query-exec dbc "update entries set round = ? where name = ?" (if e1w (+ round 1) 0) e1t)
+    (query-exec dbc "update entries set round = ? where name = ?" (if e2w (+ round 1) 0) e2t)
+    (commit-transaction dbc)))
+
+(define (create-poll e1 e2 round poll-number)
+  (let ((resp (api-post
+                (string-append "/channels/" channel-id "/messages")
+                (hash
+                  'poll (hash
+                    'question (hash 'text (string-append "Today's Poll #" (number->string poll-number)))
+                    'answers (list (hash 'poll_media (hash 'text e1)) (hash 'poll_media (hash 'text e2)))
+                    'duration 23)))))
+    (query-exec dbc "insert into open_polls (round, msg_id) values (?, ?)" round (hash-ref resp 'id))))
+
+(define (send-message msg)
+  (api-post
+    (string-append "/channels/" channel-id "/messages")
+    (hash 'content msg)))
+
+(define (sleep-until-next)
+  (sleep 2)
+  (sleep (modulo (- midnight-seconds (current-seconds)) 86400)))
+
+(sleep-until-next)
+(for ((row (query-rows dbc "select * from open_polls")))
+  (process-completed-poll (vector-ref row 0) (vector-ref row 1)))
+
+(define on-round (apply min (query-list dbc "select distinct round from entries where round > 0")))
+(define this-round (shuffle (query-list dbc "select name from entries where round = ?" on-round)))
+
+(define (main-loop)
+  (define last-remaining #f)
+  (when (= 1 (length this-round))
+    (set! last-remaining (car this-round))
+    (query-exec dbc "update entries set round = ? where name = ?" (+ 1 on-round) (car this-round))
+    (set! this-round '()))
+  (when (= 0 (length this-round))
+    (set! on-round (+ 1 on-round))
+    (set! this-round (shuffle (query-list dbc "select name from entries where round = ?" on-round)))
+    (when (= 1 (length this-round))
+      (send-message (string-append "# WINNER WINNER\n## " (string-upcase (car this-round))))
+      (exit))
+    (send-message
+      (string-append
+        "# ROUND " (number->string on-round)
+        (if last-remaining
+          (string-append
+            "\nThe only entry remaining in the previous round was \""
+            last-remaining "\", so it advanced. ")
+          "\n")
+        (number->string (length this-round)) " entries remain:\n* "
+        (string-join this-round "\n* "))))
+  (if (file-exists? "SKIP-TODAY")
+    (send-message "There is no poll today :)")
+    (for ((i (range polls-per-day)))
+      (when (> (length this-round) 1)
+        (create-poll (car this-round) (cadr this-round) on-round (+ 1 i))
+        (set! this-round (cddr this-round)))))
+  (sleep-until-next)
+  (for ((row (query-rows dbc "select * from open_polls")))
+    (process-completed-poll (vector-ref row 0) (vector-ref row 1)))
+  (main-loop))
+
+(main-loop)