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