2021-04-08 14:15:14 +00:00
|
|
|
#!/usr/bin/guile
|
|
|
|
!#
|
|
|
|
|
|
|
|
(use-modules (ice-9 rdelim)
|
|
|
|
(ice-9 textual-ports)
|
2021-04-09 06:05:47 +00:00
|
|
|
(ice-9 format)
|
|
|
|
(ice-9 control)
|
2021-04-09 06:13:16 +00:00
|
|
|
(ice-9 sandbox)
|
2021-04-11 09:43:24 +00:00
|
|
|
(ice-9 popen)
|
|
|
|
(ice-9 regex)
|
2021-04-09 06:05:47 +00:00
|
|
|
(rnrs exceptions))
|
2021-04-08 14:15:14 +00:00
|
|
|
|
2021-04-08 14:46:41 +00:00
|
|
|
(define +channels+ '("#tildetown" "#bots"))
|
2021-04-08 14:15:14 +00:00
|
|
|
|
|
|
|
(define (scdr lst)
|
2021-04-08 14:57:05 +00:00
|
|
|
"Safe CDR. Returns CDR of lst, if it is a list. Returns lst otherwise."
|
|
|
|
(if (not (pair? lst))
|
2021-04-08 14:15:14 +00:00
|
|
|
lst
|
|
|
|
(cdr lst)))
|
|
|
|
|
2021-04-08 14:57:05 +00:00
|
|
|
(define (scar lst)
|
|
|
|
"Safe CAR, see scdr."
|
|
|
|
(if (not (pair? lst))
|
|
|
|
lst
|
|
|
|
(car lst)))
|
|
|
|
|
2021-04-08 14:15:14 +00:00
|
|
|
(define (slist-ref lst index)
|
2021-04-08 14:57:05 +00:00
|
|
|
"Safe list-ref, see scdr."
|
2021-04-08 14:15:14 +00:00
|
|
|
(if (< (length lst) (+ index 1))
|
|
|
|
'()
|
|
|
|
(list-ref lst index)))
|
|
|
|
|
|
|
|
(define (slist-tail lst index)
|
2021-04-08 14:57:05 +00:00
|
|
|
"Safe list-tail, see scdr."
|
2021-04-08 14:15:14 +00:00
|
|
|
(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 irc 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 (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"))
|
|
|
|
|
2021-04-08 14:46:41 +00:00
|
|
|
(define (join-channels stream)
|
2021-04-08 14:57:05 +00:00
|
|
|
(for-each (lambda (chn)
|
|
|
|
(format stream "JOIN ~a\r\n" chn))
|
|
|
|
+channels+))
|
|
|
|
|
2021-04-08 14:15:14 +00:00
|
|
|
(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))
|
|
|
|
|
2021-04-09 14:04:19 +00:00
|
|
|
(define (input-filter str)
|
2021-04-11 09:43:24 +00:00
|
|
|
"Remove escaped chars to avoid fooling the bot into performing bad actions."
|
|
|
|
(define (remove-escaped-chars lst)
|
2021-04-09 14:04:19 +00:00
|
|
|
(cond
|
|
|
|
((or (null? lst)
|
|
|
|
(null? (cdr lst))) lst)
|
2021-04-11 09:43:24 +00:00
|
|
|
((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))))
|
2021-04-09 14:04:19 +00:00
|
|
|
|
2021-04-09 06:05:47 +00:00
|
|
|
(define (evaluate str)
|
2021-04-11 09:43:24 +00:00
|
|
|
"Evaluate the given string in a sandbox without crashing on errors."
|
2021-04-09 06:05:47 +00:00
|
|
|
(guard (ex
|
|
|
|
(else (begin (display "error encountered!\n")
|
2021-04-09 14:04:19 +00:00
|
|
|
'error))) ;; << this gets printed in chat
|
2021-04-09 06:13:16 +00:00
|
|
|
(eval-in-sandbox (read (open-input-string str)))))
|
2021-04-09 06:05:47 +00:00
|
|
|
|
2021-04-11 09:43:24 +00:00
|
|
|
(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 (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."))))
|
|
|
|
|
2021-04-08 14:15:14 +00:00
|
|
|
(define (main-loop stream)
|
|
|
|
(let* ((inl (read-line stream))
|
2021-04-08 14:57:05 +00:00
|
|
|
(data (string-tokenize inl))
|
2021-04-11 09:43:24 +00:00
|
|
|
(chn (scar (scdr (member "PRIVMSG" data))))
|
|
|
|
(filtered-data (map input-filter data)))
|
2021-04-08 14:15:14 +00:00
|
|
|
;; debug print
|
|
|
|
(format #t "~s~%" data)
|
|
|
|
(cond
|
|
|
|
((equal? (car data) "PING")
|
|
|
|
(pong stream))
|
2021-04-08 14:40:40 +00:00
|
|
|
((or (equal? ":!rollcall" (slist-ref data 3))
|
|
|
|
(equal? ":!anna" (slist-ref data 3)))
|
2021-04-08 14:57:05 +00:00
|
|
|
(send-message stream chn "Hello! I respond to !rollcall, !anna, and !eval <s-expr>."))
|
2021-04-08 14:40:40 +00:00
|
|
|
((equal? ":!eval" (slist-ref data 3))
|
2021-04-11 09:43:24 +00:00
|
|
|
(let ((expr (string-concatenate (intersperse " " (cdr (member ":!eval" filtered-data))))))
|
2021-04-09 06:05:47 +00:00
|
|
|
(send-message stream chn (evaluate expr))))
|
2021-04-11 09:43:24 +00:00
|
|
|
((equal? ":!doc" (slist-ref data 3))
|
|
|
|
(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))))
|
2021-04-08 14:15:14 +00:00
|
|
|
((and (= 7 (length data))
|
|
|
|
(equal? (list-tail data 4) '("ACTION" "shoots" "anna")))
|
2021-04-08 14:57:05 +00:00
|
|
|
(send-action stream chn "dies")
|
2021-04-08 14:15:14 +00:00
|
|
|
(close-port stream)
|
|
|
|
(exit)))
|
|
|
|
(main-loop stream)))
|
|
|
|
|
|
|
|
(let* ((io (make-connection "127.0.0.1" 6667)))
|
|
|
|
(send-nick io)
|
|
|
|
(send-user io)
|
2021-04-08 14:46:41 +00:00
|
|
|
(join-channels io)
|
2021-04-08 14:15:14 +00:00
|
|
|
|
|
|
|
(main-loop io))
|