Initial commit
This commit is contained in:
commit
b5918e6f77
|
|
@ -0,0 +1,2 @@
|
||||||
|
*.rkt~
|
||||||
|
.config.uwubot
|
||||||
|
|
@ -0,0 +1,205 @@
|
||||||
|
#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))
|
||||||
Loading…
Reference in New Issue