anna/anna.scm

#!/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"))
;; (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 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 (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)))))

(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 (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 5 (lambda () (diceware-one-word (if (equal? file "eff")
                                                                  "diceware_eff.txt"
                                                                  "diceware_words.txt"))))))

(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)))
    ;; debug print
    (format #t "~s~%" data)
    (cond
     ((equal? (car data) "PING")
      (pong stream))
     ((or (equal? ":!rollcall" (slist-ref data 3))
          (equal? ":!anna" (slist-ref data 3)))
      (send-message stream chn "Hello! I respond to !anna, !tz <optionally user>, !greets, !lgreets <optionally user>, !rgreets <optionally user>, !dw <optionally \"eff\"> and !eval <s-expr>. My source code is available at https://git.tilde.town/opfez/anna"))
     ((equal? ":!eval" (slist-ref data 3))
      (let ((expr (string-concatenate (intersperse " " (cdr (member ":!eval" filtered-data))))))
        (send-message stream chn (evaluate expr))))
     ((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))))
     ((equal? ":!tz" (slist-ref data 3))
      (send-message stream chn (if (= 4 (length data))
                                   (timezone (get-username (car data)))
                                   (timezone (slist-ref data 4)))))
     ((equal? ":!lgreets" (slist-ref data 3))
      (format #t "~s~%" *left-greets*)
      (send-message stream chn (if (= 4 (length data))
                                   (greets *left-greets* (get-username (car data)))
                                   (greets *left-greets* (slist-ref data 4)))))
     ((equal? ":!rgreets" (slist-ref data 3))
      (format #t "~s~%" *right-greets*)
      (send-message stream chn (if (= 4 (length data))
                                   (greets *right-greets* (get-username (car data)))
                                   (greets *right-greets* (slist-ref data 4)))))
     ((equal? ":!greets" (slist-ref data 3))
      (send-message stream chn (string-append "o/ - "
                                              (number->string (all-greets *right-greets*))
                                              " vs \\o - "
                                              (number->string (all-greets *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" (slist-ref data 3))
      (send-message stream chn "13●0ミ8☆"))
     ((equal? ":!dw" (slist-ref data 3))
      (send-message stream chn (diceware (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))