345 lines
12 KiB
Scheme
Executable File
345 lines
12 KiB
Scheme
Executable File
#!/usr/bin/guile
|
||
!#
|
||
|
||
(use-modules (ice-9 rdelim)
|
||
(ice-9 textual-ports)
|
||
(ice-9 format)
|
||
(ice-9 control)
|
||
(ice-9 sandbox)
|
||
(ice-9 popen)
|
||
(ice-9 regex)
|
||
(rnrs exceptions))
|
||
|
||
;; (define +channels+ '("#tildetown" "#lisp" "#bots" "#programming"))
|
||
(define +channels+ '("#bots"))
|
||
|
||
(load "greets.scm")
|
||
|
||
(define (scdr lst)
|
||
"Safe CDR. Returns CDR of lst, if it is a list. Returns lst otherwise."
|
||
(if (not (pair? lst))
|
||
lst
|
||
(cdr lst)))
|
||
|
||
(define (scar lst)
|
||
"Safe CAR, see scdr."
|
||
(if (not (pair? lst))
|
||
lst
|
||
(car lst)))
|
||
|
||
(define (slist-ref lst index)
|
||
"Safe list-ref, see scdr."
|
||
(if (< (length lst) (+ index 1))
|
||
'()
|
||
(list-ref lst index)))
|
||
|
||
(define (slist-tail lst index)
|
||
"Safe list-tail, see scdr."
|
||
(if (< (length lst) (+ index 1))
|
||
'()
|
||
(list-tail lst index)))
|
||
|
||
(define (string-tail str index)
|
||
"List-tail for strings."
|
||
(list->string (list-tail (string->list str) index)))
|
||
|
||
(define (intersperse sep lst)
|
||
"Returns a new list with sep between each element of lst."
|
||
(cond
|
||
((or (null? lst)
|
||
(null? (cdr lst))) lst)
|
||
(else (cons (car lst)
|
||
(cons sep
|
||
(intersperse sep (cdr lst)))))))
|
||
|
||
(define (make-connection host port)
|
||
"Connect to server on host:port, returns a socket for reading and writing."
|
||
(let* ((sock (socket PF_INET SOCK_STREAM 0))
|
||
(con (connect sock
|
||
AF_INET
|
||
(car (vector-ref (gethost host) 4))
|
||
port)))
|
||
sock))
|
||
|
||
(define (get-username str)
|
||
(define (get-username-list lst)
|
||
(cond ((null? lst) '())
|
||
((eq? (car lst) #\!) '())
|
||
(else (cons (car lst)
|
||
(get-username-list (cdr lst))))))
|
||
(list->string (cdr (get-username-list (string->list str)))))
|
||
|
||
(define (pong stream)
|
||
(format stream "PONG :anna\r\n"))
|
||
|
||
(define (send-nick stream)
|
||
(format stream "NICK anna\r\n"))
|
||
|
||
(define (send-user stream)
|
||
(format stream "USER anna 0.0.0.0 anna :Anna\r\n"))
|
||
|
||
(define (join-channels stream)
|
||
(for-each (lambda (chn)
|
||
(format stream "JOIN ~a\r\n" chn))
|
||
+channels+))
|
||
|
||
(define (send-message stream chn msg)
|
||
(format stream "PRIVMSG ~a :~a\r\n" chn msg))
|
||
|
||
(define (send-action stream chn action)
|
||
(format stream "PRIVMSG ~a :\x01ACTION ~a\x01\r\n" chn action))
|
||
|
||
;;; TODO: this can be refactored into a function that takes one char and
|
||
;;; removes it, and composing that into more complex functions.
|
||
(define (input-filter str)
|
||
"Remove escaped chars to avoid fooling the bot into performing bad actions."
|
||
(define (remove-escaped-chars lst)
|
||
(cond
|
||
((or (null? lst)
|
||
(null? (cdr lst))) lst)
|
||
((eq? (car lst) #\\) (remove-escaped-chars (cddr lst)))
|
||
(else (cons (car lst) (remove-escaped-chars (cdr lst))))))
|
||
(list->string (remove-escaped-chars (string->list str))))
|
||
|
||
(define (remove-newlines str)
|
||
(define (remove-newlines-aux lst)
|
||
(cond ((null? lst) '())
|
||
((or (equal? (string (car lst)) "\n")
|
||
(equal? (string (car lst)) "\r"))
|
||
(remove-newlines-aux (cdr lst)))
|
||
(else (cons (car lst) (remove-newlines-aux (cdr lst))))))
|
||
(list->string (remove-newlines-aux (string->list str))))
|
||
|
||
(define (evaluate str)
|
||
"Evaluate the given string in a sandbox without crashing on errors."
|
||
(guard (ex
|
||
(else (begin (display "error encountered!\n")
|
||
'error))) ;; << this gets printed in chat
|
||
(eval-in-sandbox (read (open-input-string str))
|
||
#:bindings all-pure-and-impure-bindings)))
|
||
|
||
(define (find-documentation language search)
|
||
"Find documentation for different programming languages."
|
||
(cond
|
||
((null? language) "Missing langauge specifier.")
|
||
((null? (string-tokenize search)) "Missing search string.")
|
||
((eq? language 'cl) (find-cl-documentation search))
|
||
(else "Unrecognized language! Supported languages are: cl")))
|
||
|
||
(define (read-file f)
|
||
(call-with-input-file f get-string-all))
|
||
|
||
(define (timezone user)
|
||
(let ((path (string-append "/home/" user "/.tz")))
|
||
(if (access? path R_OK)
|
||
(remove-newlines (read-file path))
|
||
(string-append user
|
||
" has not set their timezone. Use `echo '<timezone here>' > ~/.tz' to add your timezone."))))
|
||
|
||
(define (slice start end lst)
|
||
"Return the list between index start and end (start inclusive, end not inclusive)."
|
||
(cond
|
||
((> start end) (error "Start index can't be more than end index."))
|
||
((> end (length lst)) (error "End index too large."))
|
||
((= start end) '())
|
||
(else (cons (list-ref lst start)
|
||
(slice (+ 1 start) end lst)))))
|
||
|
||
(define (escape-string str)
|
||
"Replace all special regex chars with escaped versions."
|
||
(define chars '(#\( #\) #\* #\+ #\?))
|
||
(define (member? elem lst)
|
||
(cond
|
||
((null? lst) #f)
|
||
((eq? (car lst) elem) #t)
|
||
(else (member? elem (cdr lst)))))
|
||
(define (loop lst)
|
||
(cond
|
||
((null? lst) '())
|
||
((member? (car lst) chars) (cons #\\ (cons (car lst) (loop (cdr lst)))))
|
||
(else (cons (car lst) (loop (cdr lst))))))
|
||
(list->string (loop (string->list str))))
|
||
|
||
(define (find-cl-documentation search)
|
||
"Find documentation for Common Lisp."
|
||
(let ((status (system* "grep" (string-append "htm#" search "\"") "cl.htm")))
|
||
(cond
|
||
((= 0 status)
|
||
(let* ((port (open-input-pipe (string-append "grep htm#" search "\\\" cl.htm")))
|
||
(out (string-match "Body.*\"" (read-line port)))
|
||
(sublink (list->string (slice (car (vector-ref out 1))
|
||
(- (cdr (vector-ref out 1)) 1)
|
||
(string->list (vector-ref out 0))))))
|
||
(close-pipe port)
|
||
(string-append "http://www.lispworks.com/documentation/lw70/CLHS/"
|
||
sublink)))
|
||
(else "Symbol not found in documentation."))))
|
||
|
||
(define (shorten-link link)
|
||
(if (null? link)
|
||
"Please provide a link to shorten."
|
||
(let* ((port (open-input-pipe (string-append "curl -F'shorten="
|
||
(if (string-contains link "://")
|
||
link
|
||
(string-append "https://" link))
|
||
"' https://ttm.sh")))
|
||
(out (read-line port)))
|
||
(close-pipe port)
|
||
out)))
|
||
|
||
(define (greets category name)
|
||
(if (not (assoc name category))
|
||
"0"
|
||
(number->string (cdr (assoc name category)))))
|
||
|
||
(define (write-greets)
|
||
(define (greet-values alst)
|
||
(define (actual-values al)
|
||
(cond ((null? al) (format #f "~%"))
|
||
(else (string-append (format #f "~%(cons ~s ~s)" (caar al) (cdar al))
|
||
(actual-values (cdr al))))))
|
||
(format #f "(list ~a)" (actual-values alst)))
|
||
(call-with-output-file "greets.scm" (lambda (stream)
|
||
(format stream
|
||
"(define *left-greets* ~a)~%(define *right-greets* ~a)~%"
|
||
(greet-values *left-greets*)
|
||
(greet-values *right-greets*)))))
|
||
|
||
|
||
;; has to be separate functions since modifying the argument won't change global state
|
||
(define (inc-left-greets name)
|
||
(if (not (assoc name *left-greets*))
|
||
(set! *left-greets* (acons name 1 *left-greets*))
|
||
(set! *left-greets* (assoc-set! *left-greets* name (+ 1 (cdr (assoc name *left-greets*)))))))
|
||
|
||
(define (inc-right-greets name)
|
||
(if (not (assoc name *right-greets*))
|
||
(set! *right-greets* (acons name 1 *right-greets*))
|
||
(assoc-set! *right-greets* name (+ 1 (cdr (assoc name *right-greets*))))))
|
||
|
||
(define (all-greets category)
|
||
(if (null? category)
|
||
0
|
||
(+ (cdr (car category))
|
||
(all-greets (cdr category)))))
|
||
|
||
(define (empty-list->string s)
|
||
(if (null? s)
|
||
""
|
||
s))
|
||
|
||
(define (concat-messages strings index length)
|
||
(if (= index length)
|
||
""
|
||
(string-append (slist-ref strings index)
|
||
(concat-messages strings (+ 1 index) length))))
|
||
|
||
(define (n-func-results n f)
|
||
(if (zero? n)
|
||
'()
|
||
(cons (f) (n-func-results (- n 1) f))))
|
||
|
||
(define (fold-right f base lst)
|
||
(if (null? lst)
|
||
base
|
||
(f (car lst)
|
||
(fold-right f base (cdr lst)))))
|
||
|
||
(define (diceware-one-word file)
|
||
(define (generate-dice n sides)
|
||
(n-func-results n (lambda () (random sides))))
|
||
(let* ((entry (fold-right string-append "" (map number->string
|
||
(map (lambda (x) (+ x 1))
|
||
(generate-dice 5 6)))))
|
||
;; yes, shell scripting in scheme
|
||
(port (open-input-pipe (string-append "grep \"^" entry "\" " file " | awk '{print $2}'")))
|
||
(out (read-line port)))
|
||
(close-pipe port)
|
||
out))
|
||
|
||
(define (diceware file)
|
||
(fold-right (lambda (x y) (string-append x " " y))
|
||
""
|
||
(n-func-results 6 (lambda () (diceware-one-word (if (equal? file "eff")
|
||
"diceware_eff.txt"
|
||
"diceware_words.txt"))))))
|
||
|
||
(define (qotd stream channel)
|
||
(let ((s (make-connection "127.0.0.1" 1717)))
|
||
(define (send-quote)
|
||
(let ((line (read-line s)))
|
||
(unless (eof-object? line)
|
||
(send-message stream channel line)
|
||
(send-quote))))
|
||
(send-quote)
|
||
(close-port s)))
|
||
|
||
(define (main-loop stream)
|
||
(let* ((inl (read-line stream))
|
||
(data (string-tokenize inl))
|
||
(chn (scar (scdr (member "PRIVMSG" data))))
|
||
(filtered-data (map input-filter data)))
|
||
(define (get-greets left-or-right)
|
||
(if (= 4 (length data))
|
||
(number->string (all-greets left-or-right))
|
||
(greets left-or-right (slist-ref data 4))))
|
||
(define (left-greets)
|
||
(get-greets *left-greets*))
|
||
(define (right-greets)
|
||
(get-greets *right-greets*))
|
||
;; debug print
|
||
(format #t "~s~%" data)
|
||
(let ((command (slist-ref data 3)))
|
||
(cond
|
||
((equal? (car data) "PING")
|
||
(pong stream))
|
||
((or (equal? ":!rollcall" command)
|
||
(equal? ":!anna" command))
|
||
(send-message stream chn "Hello! I respond to !anna, !tz <optionally user>, !greets <optionally user>, !dw <optionally \"eff\"> and !eval <s-expr>. My source code is available at https://git.tilde.town/opfez/anna"))
|
||
((equal? ":!eval" command)
|
||
(let ((expr (string-concatenate (intersperse " " (cdr (member ":!eval" filtered-data))))))
|
||
(send-message stream chn (evaluate expr))))
|
||
((equal? ":!doc" command)
|
||
(let ((lang (slist-ref data 4))
|
||
(search (escape-string (string-concatenate (intersperse " " (cddr (member ":!doc" filtered-data)))))))
|
||
(send-message stream chn (find-documentation (string->symbol lang) search))))
|
||
((equal? ":!tz" command)
|
||
(send-message stream chn (if (= 4 (length data))
|
||
(timezone (get-username (car data)))
|
||
(timezone (slist-ref data 4)))))
|
||
((equal? ":!greets" command)
|
||
(send-message stream chn (string-append "o/ - "
|
||
(right-greets)
|
||
" vs \\o - "
|
||
(left-greets))))
|
||
((string-contains (empty-list->string (concat-messages data 3 (length data))) "\\o/")
|
||
#f)
|
||
((string-contains (empty-list->string (concat-messages data 3 (length data))) "\\o")
|
||
|
||
(inc-left-greets (get-username (car data)))
|
||
(write-greets))
|
||
((string-contains (empty-list->string (concat-messages data 3 (length data))) "o/")
|
||
(inc-right-greets (get-username (car data)))
|
||
(write-greets))
|
||
((equal? ":!kirby" command)
|
||
(send-message stream chn "13●0ミ8☆"))
|
||
((equal? ":!dw" command)
|
||
(send-message stream chn (diceware (slist-ref data 4))))
|
||
((equal? ":!qotd" command)
|
||
(qotd stream chn))
|
||
((equal? ":!shorten" command)
|
||
(send-message stream chn (shorten-link (slist-ref data 4))))
|
||
((and (= 7 (length data))
|
||
(equal? (list-tail data 4) '("ACTION" "shoots" "anna")))
|
||
(send-action stream chn "dies")
|
||
(close-port stream)
|
||
(exit))))
|
||
(main-loop stream)))
|
||
|
||
(let* ((io (make-connection "127.0.0.1" 6667)))
|
||
(send-nick io)
|
||
(send-user io)
|
||
(join-channels io)
|
||
|
||
(main-loop io))
|