345 lines
12 KiB
Executable File
Raw Permalink Blame History

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

(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))
(cdr lst)))
(define (scar lst)
"Safe CAR, see scdr."
(if (not (pair? 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."
((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
(car (vector-ref (gethost host) 4))
(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 anna :Anna\r\n"))
(define (join-channels stream)
(for-each (lambda (chn)
(format stream "JOIN ~a\r\n" chn))
(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)
((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."
((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)."
((> 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)
((null? lst) #f)
((eq? (car lst) elem) #t)
(else (member? elem (cdr lst)))))
(define (loop lst)
((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")))
((= 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 ""
(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 "://")
(string-append "https://" link))
(out (read-line port)))
(close-pipe port)
(define (greets category name)
(if (not (assoc name category))
(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)
(+ (cdr (car category))
(all-greets (cdr category)))))
(define (empty-list->string s)
(if (null? 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)
(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)
(define (diceware file)
(fold-right (lambda (x y) (string-append x " " y))
(n-func-results 6 (lambda () (diceware-one-word (if (equal? file "eff")
(define (qotd stream channel)
(let ((s (make-connection "" 1717)))
(define (send-quote)
(let ((line (read-line s)))
(unless (eof-object? line)
(send-message stream channel line)
(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)))
((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"))
((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/ - "
" vs \\o - "
((string-contains (empty-list->string (concat-messages data 3 (length data))) "\\o/")
((string-contains (empty-list->string (concat-messages data 3 (length data))) "\\o")
(inc-left-greets (get-username (car data)))
((string-contains (empty-list->string (concat-messages data 3 (length data))) "o/")
(inc-right-greets (get-username (car data)))
((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)
(main-loop stream)))
(let* ((io (make-connection "" 6667)))
(send-nick io)
(send-user io)
(join-channels io)
(main-loop io))