clone url: git://git.m455.casa/dog
main.scm
| 1 | (import utf8 |
| 2 | openssl |
| 3 | srfi-1 |
| 4 | (chicken file) |
| 5 | (chicken tcp) |
| 6 | (chicken format) |
| 7 | (chicken io) |
| 8 | (chicken string)) |
| 9 | |
| 10 | ;; variables ========================== |
| 11 | (define config-file "config.scm") |
| 12 | |
| 13 | (define config-alist |
| 14 | (if (file-exists? config-file) |
| 15 | (with-input-from-file config-file read) |
| 16 | (print (format "woops! ~a doesn't exist." config-file)))) |
| 17 | |
| 18 | (define-values (from-server to-server) |
| 19 | (let ((irc-host (alist-ref 'irc-host config-alist)) |
| 20 | (irc-port (alist-ref 'irc-port config-alist))) |
| 21 | (if (alist-ref 'irc-ssl config-alist) |
| 22 | (ssl-connect* #:hostname irc-host |
| 23 | #:port irc-port) |
| 24 | (tcp-connect irc-host irc-port)))) |
| 25 | |
| 26 | ;; utils ========================== |
| 27 | (define (keys alist) |
| 28 | (map car alist)) |
| 29 | |
| 30 | (define (is-key? key alist) |
| 31 | (member key (keys alist))) |
| 32 | |
| 33 | (define (list-update! l k v) |
| 34 | (set-car! (list-tail l k) v) |
| 35 | l) |
| 36 | |
| 37 | (define (config-get key) |
| 38 | (alist-ref key config-alist)) |
| 39 | |
| 40 | (define (file->lines file) |
| 41 | (with-input-from-file file read-lines)) |
| 42 | |
| 43 | (define (file->alist file) |
| 44 | (let ((lines (file->lines file))) |
| 45 | (map (lambda (index entry) `(,index . ,entry)) |
| 46 | (iota (length lines)) |
| 47 | lines))) |
| 48 | |
| 49 | (define (file-write file contents) |
| 50 | (with-output-to-file |
| 51 | file |
| 52 | (lambda () (display contents)))) |
| 53 | |
| 54 | (define (file-append file contents) |
| 55 | (with-output-to-file |
| 56 | file |
| 57 | (lambda () (display contents)) |
| 58 | #:append)) |
| 59 | |
| 60 | ;; commands ======================== |
| 61 | (define (help) |
| 62 | (list "========" |
| 63 | "Usage:" |
| 64 | " !help - Show this help message" |
| 65 | " !ls - Show all catalogue items" |
| 66 | " !add <text> - Add text to the catalogue" |
| 67 | " !rm <number> - Remove an item from the catalogue" |
| 68 | " !update <number> <text> - Replace the contents of an item with new text" |
| 69 | "========")) |
| 70 | |
| 71 | (define (ls) |
| 72 | (if (file-exists? (config-get 'list-file)) |
| 73 | (let* ((entries (file->lines (config-get 'list-file))) |
| 74 | (number-of-entries (length entries))) |
| 75 | (if (= number-of-entries 0) |
| 76 | (list "no stuffs :(") |
| 77 | (let ((numbers (map number->string (iota number-of-entries)))) |
| 78 | (map (lambda (x y) (string-append x ". " y)) |
| 79 | numbers |
| 80 | entries)))) |
| 81 | (list "no file ;("))) |
| 82 | |
| 83 | (define (add str) |
| 84 | (file-append (config-get 'list-file) |
| 85 | (string-append str "\n")) |
| 86 | (format "added '~a' to the list!" str)) |
| 87 | |
| 88 | (define (rm message-split) |
| 89 | (let* ((index (string->number (car message-split))) |
| 90 | (list-file (config-get 'list-file)) |
| 91 | (file-alist (file->alist list-file))) |
| 92 | (if (is-key? index file-alist) |
| 93 | (let* ((entries (map cdr file-alist)) |
| 94 | (entry-to-remove (list-ref entries index)) |
| 95 | (entries-with-entry-removed (remove (lambda (s) (equal? s entry-to-remove)) entries))) |
| 96 | (file-write list-file (string-intersperse entries-with-entry-removed "\n")) |
| 97 | (format "removed '~a' from the list!" entry-to-remove)) |
| 98 | "woops, couldn't find that item."))) |
| 99 | |
| 100 | (define (update message-split) |
| 101 | (let* ((index (string->number (car message-split))) |
| 102 | (list-file (config-get 'list-file)) |
| 103 | (file-alist (file->alist list-file))) |
| 104 | (if (and (is-key? index file-alist) |
| 105 | (> (length message-split) 1)) |
| 106 | (let* ((entries (map cdr file-alist)) |
| 107 | (new-text (string-intersperse (cdr message-split)))) |
| 108 | (file-write list-file |
| 109 | (string-intersperse (list-update! entries index new-text) "\n")) |
| 110 | (format "updated list item ~a to '~a'!" index new-text)) |
| 111 | "woops. you gotta provide a valid number and text!"))) |
| 112 | |
| 113 | ;; irc util ==================================================================== |
| 114 | ;; (tcp-read-timeout #f) so (read-line ...) on a TCP connection doesn't timeout after 60 seconds |
| 115 | (tcp-read-timeout #f) |
| 116 | |
| 117 | (define (send str) |
| 118 | (write-line (string-append str "\r\n") to-server)) |
| 119 | |
| 120 | (define-syntax send-format |
| 121 | (syntax-rules () |
| 122 | ((_ str v ...) |
| 123 | (send (format str v ...))))) |
| 124 | |
| 125 | (define (send-password) |
| 126 | (send-format "PASS ~a" (config-get 'irc-password))) |
| 127 | |
| 128 | (define (send-nick) |
| 129 | (send-format "NICK ~a" (config-get 'irc-nickname))) |
| 130 | |
| 131 | (define (send-user) |
| 132 | (send-format "USER ~a 0.0.0.0 ~a :~a" |
| 133 | (config-get 'irc-nickname) |
| 134 | (config-get 'irc-username) |
| 135 | (config-get 'irc-realname))) |
| 136 | |
| 137 | (define (send-message channel message) |
| 138 | (send-format "PRIVMSG ~a :~a" channel message)) |
| 139 | |
| 140 | (define (send-multiline-message channel lines) |
| 141 | (for-each (lambda (line) |
| 142 | (send-message channel line)) |
| 143 | lines)) |
| 144 | |
| 145 | (define (check-for-ping server-data) |
| 146 | (when (equal? "PING" (substring server-data 0 4)) |
| 147 | (send "PONG :lol"))) |
| 148 | |
| 149 | (define (disable-history) |
| 150 | (send-format "PRIVMSG nickserv :SET autoreplay-lines 0")) |
| 151 | |
| 152 | (define (join-channel channel) |
| 153 | (send-format "JOIN ~a" channel)) |
| 154 | |
| 155 | (define (join-channels) |
| 156 | (for-each join-channel (config-get 'irc-channels))) |
| 157 | |
| 158 | (define (get-sender mode split-server-data) |
| 159 | (let* ((sender-data (list-ref split-server-data 0)) ;; => ":nickname!~realname@user/realname" or ":nickname!realname@localhost" |
| 160 | (sender-data-split (string-split sender-data ":!~@"))) ;; => ("nickname" "realname" "user/realname") |
| 161 | (case mode |
| 162 | ('realname (cadr sender-data-split)) |
| 163 | ('nickname (car sender-data-split)) |
| 164 | (else "unknown")))) |
| 165 | |
| 166 | (define (get-channel split-server-data) |
| 167 | (list-ref split-server-data 2)) |
| 168 | |
| 169 | ;; returns a message in the form of '("this" "is" "a" "test") |
| 170 | (define (get-message split-server-data) |
| 171 | (let ((raw-message-split (list-tail split-server-data 3))) ;; => '(":this" "is" "a" "test") |
| 172 | (cons (substring (car raw-message-split) 1) ;; get the first item, and remove the colon |
| 173 | (cdr raw-message-split)))) |
| 174 | |
| 175 | ;; irc loop =================================================================== |
| 176 | ;; how split-server-data looks: |
| 177 | ;; 0 1 2 3 |
| 178 | ;; '(":some-nickname!some-realname@localhost" "PRIVMSG" "#tildetown" ":this" "is" "a" "test") |
| 179 | ;; or sometimes with a tilde: |
| 180 | ;; '(":some-nickname!~some-realname@user/some-realname" "PRIVMSG" "#tildetown" ":this" "is" "a" "test") |
| 181 | ;; |
| 182 | ;; how private messages look: |
| 183 | ;; :some-nickname!~some-realname@user/some-realname PRIVMSG botname :oh this is a test |
| 184 | (define (check-for-command server-data) |
| 185 | (let ((split-server-data (string-split server-data))) |
| 186 | (when (equal? (list-ref split-server-data 1) "PRIVMSG") |
| 187 | (let* ((nickname (get-sender 'nickname split-server-data)) |
| 188 | (realname (get-sender 'realname split-server-data)) |
| 189 | (chan (get-channel split-server-data)) |
| 190 | (channel (let ((chan (get-channel split-server-data))) |
| 191 | (if (equal? chan (config-get 'irc-nickname)) |
| 192 | nickname |
| 193 | chan))) |
| 194 | (message-split (get-message split-server-data))) |
| 195 | (when (not (null? message-split)) |
| 196 | (case (string->symbol (car message-split)) |
| 197 | ('!ls (send-multiline-message channel (ls))) |
| 198 | ('!add (send-message channel (add (string-intersperse (cdr message-split))))) |
| 199 | ('!rm (send-message channel (rm (cdr message-split)))) |
| 200 | ('!update (send-message channel (update (cdr message-split)))) |
| 201 | ('!dog (send-multiline-message channel (help))) |
| 202 | (else 'do-nothing))))))) |
| 203 | |
| 204 | (define (start-irc-connection) |
| 205 | (when (config-get 'irc-password) |
| 206 | (send-password)) |
| 207 | (send-nick) |
| 208 | (send-user) |
| 209 | (when (config-get 'irc-disable-history?) (disable-history)) |
| 210 | (join-channels) |
| 211 | (sleep 1)) |
| 212 | |
| 213 | (define (listen-to-irc-server) |
| 214 | (let ((server-data (read-line from-server))) |
| 215 | (print server-data) |
| 216 | (check-for-ping server-data) |
| 217 | (check-for-command server-data) |
| 218 | (sleep 1)) |
| 219 | (listen-to-irc-server)) |
| 220 | |
| 221 | (define (main) |
| 222 | (start-irc-connection) |
| 223 | (listen-to-irc-server)) |
| 224 | |
| 225 | (main) |