uwubot/uwubot.rkt

#lang racket

(require racket/async-channel)
(require struct-update)
(require json)
(require net/url)
(require net/uri-codec)
(require net/rfc6455)
(require web-server/http/request-structs)
(require uuid)
(require html-parsing)

;; Bot configuration
(struct app-config [instance token char-limit] #:transparent)
(define-struct-updaters app-config)

;; This is dumb but I'm not good enough with the Racket
(define (config-from-file filename)
  (define (parse-config config)
    (match config
      [(cons #:instance (cons x r))
       (app-config-instance-set (parse-config r) x)]
      [(cons #:token (cons x r))
       (app-config-token-set (parse-config r) x)]
      [(cons #:char-limit (cons x r))
       (app-config-char-limit-set (parse-config r) x)]
      [_ (app-config '() '() 500)]))
  (parse-config (with-input-from-file filename read)))

;; Represents the current masto config
(define current-config (make-parameter '()))

;; Utils
(define (make-api-url path #:ws? [ws? #f] #:query [query '()])
  (url (if ws? "wss" "https")
                 #f (app-config-instance (current-config))
                 #f #t
                 `(,(path/param "api" '())
                   ,(path/param "v1" '())
                   ,@(map (lambda (x) (path/param x '())) path))
                 query #f))

(define (make-header k v)
  (string-append k ": " v))

(define (get-authorization)
  (string-append "Bearer " (app-config-token (current-config)))) 

;; Creates a toot
(define (make-toot status #:cw [cw #f] #:reply-to [reply-to #f]
                   #:sensitive [sensitive #f] #:language [lang #f]
                   #:visibility [visibility #f])
  (for/fold ([out '()])
            ([name '(status in_reply_to_id sensitive spoiler_text language visibility)]
             [value (list status reply-to sensitive cw lang visibility)])
    (cond [(false? value) out]
          [else (cons (cons name value) out)])))

;; Sends a toot
(define (send-toot toot)
  (define idem-key (uuid-string))
  (define-values (status headers rsp)
    (http-sendrecv/url (make-api-url '("statuses"))
                       #:method "POST"
                       #:headers (list
                                  (make-header "Idempotency-Key" idem-key)
                                  (make-header "Authorization" (get-authorization))
                                  (make-header "Content-Type" "application/x-www-form-urlencoded"))
                       #:data (alist->form-urlencoded toot)))
  (string->jsexpr (port->string rsp)))

(define (verify-creds)
  (define-values (status headers rsp)
    (http-sendrecv/url (make-api-url '("accounts" "verify_credentials"))
                       #:headers (list (make-header "Authorization" (get-authorization)))))
  (string->jsexpr (port->string rsp)))

(define (fetch-toot toot-id)
  (define-values (status headers rsp)
    (http-sendrecv/url (make-api-url (list "statuses" toot-id))
                       #:headers (list (make-header "Authorization" (get-authorization)))))
  (string->jsexpr (port->string rsp)))

;; Stream incoming toots
(define (stream-user chan)
  (define query (list (cons 'access_token (app-config-token (current-config)))
                      (cons 'stream "user")))
  (define ws (ws-connect (make-api-url '("streaming") #:ws? #t #:query query)))
  (define (stream-forever chan)
    (let ([msg (ws-recv ws)])
      (cond [(equal? msg eof) (void)]
            [else
             (define msg-data (string->jsexpr msg))
             (async-channel-put chan (list (hash-ref msg-data 'event)
                                           (hash-ref msg-data 'payload)))
             (stream-forever chan)])))
  (stream-forever chan)
  (ws-close! ws))

(define (bot-run)
  (define my-username (hash-ref (verify-creds) 'acct))
  (define (handle-mention status)
    (define status-error (hash-ref status 'error #f))
    (cond
      [(string? status-error) (void)]
      [else
       (define status-reply-to-id (hash-ref status 'in_reply_to_id))
       (define status-account (hash-ref status 'account))
       (define status-username (hash-ref status-account 'acct))
       (cond
         [(string? status-reply-to-id)
          (define parent (fetch-toot status-reply-to-id))
          (define parent-error (hash-ref parent 'error #f))
          (if (string? parent-error)
              (void)
              (do-uwu-reply parent (string-append "@" status-username)))]
         [else (do-uwu-reply status #f)])]))
  (define (do-uwu-reply status orig-username)
    ;(displayln status)
    (define status-text (hash-ref status 'content))
    (define status-id (hash-ref status 'id))
    (define status-sensitive (hash-ref status 'sensitive))
    (define status-cw (hash-ref status 'spoiler_text))
    (define status-lang (hash-ref status 'language))
    (define status-vis (hash-ref status 'visibility))
    (define status-account (hash-ref status 'account))
    (define status-username (string-append "@" (hash-ref status-account 'acct)))
    (define status-bio (hash-ref status-account 'note))
    (define cleaned-text
      (maybe-prepend status-username
                     (maybe-prepend orig-username
                                    (string-trim
                                     (string-replace (xexp-strip-tags (html->xexp status-text))
                                                     (string-append "@" my-username) "")))))
    ;; priv => unlisted basically
    (define mapped-vis (match status-vis
                         ["public" "public"]
                         ["direct" "direct"]
                         [_ "unlisted"]))
    (cond [(string-contains? status-bio "nobot") (void)]
          [else
           (define new-content (string-chunk (uwu cleaned-text)
                                (app-config-char-limit (current-config))))
           (for/fold ([reply-to status-id])
                     ([toot new-content])
             (hash-ref (send-toot (make-toot toot #:cw status-cw
                                   #:reply-to reply-to
                                   #:sensitive status-sensitive
                                   #:language status-lang
                                   #:visibility mapped-vis))
                       'id))]))
             
  (define (handle-notification payload)
    (match (hash-ref payload 'type)
      ["mention" (handle-mention (hash-ref payload 'status))]
      [_ (void)]))
  (define (do-stream chan)
    (define next (async-channel-get chan))
    (match next
      [(list "notification" payload)
       (handle-notification (string->jsexpr payload))]
      [_ (void)])
    (do-stream chan))
  (define chan (make-async-channel))
  (define recv-thread (thread (lambda () (stream-user chan))))
  (do-stream chan))

(define (uwu text)
  (define replacements (list (list #px"[rl]" "w")
                             (list #px"[RL]" "W")
                             (list #px"([nNmM])o" "\\1yo")
                             (list #px"([nNmM])O" "\\1YO")))
  (define (uwu-word text)
    (if (and (not (zero? (string-length text))) (char=? #\@ (string-ref text 0)))
        text
        (for/fold ([t text])
                  ([r replacements])
          (regexp-replace* (first r) t (second r)))))
  (string-append (string-join (map uwu-word (string-split text))) " uwu"))

(define (string-chunk str n)
  (cond [(<= (string-length str) n) (list str)]
        [else (cons (substring str 0 n) (string-chunk (substring str n) n))]))

(define (xexp-strip-tags x)
  (define (xexp-content x)
    (cond
      [(string? x) x]
      [(and (list? x) (equal? (first x) '@)) ""]
      [(and (list? x) (not (equal? (first x) '@))) (map xexp-content (rest x))]
      [else ""]))
  (string-join (flatten (xexp-content x)) ""))

(define (maybe-prepend pre text)
    (cond
      [(not (string? pre)) text]
      [(string-contains? text pre) text]
      [(string-append pre " " text)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;

(define bot-config (config-from-file ".config.uwubot"))
(parameterize ([current-config bot-config])
  (displayln "Running uwubot")
  (bot-run))