git.m455.casa

linkbud

clone url: git://git.m455.casa/linkbud

linkbud.scm

1 (import utf8
2 openssl
3 srfi-95
4 srfi-152
5 (chicken pathname)
6 (chicken pretty-print)
7 (chicken io)
8 (chicken file)
9 (chicken string) ;; string-split will be used from here, because it's defined after srfi-152
10 (chicken format)
11 (chicken process)
12 (chicken process-context)
13 (chicken tcp)
14 (chicken time posix))
15
16 (define log-file "log.scm")
17 (define config-file "config.scm")
18
19 (define html-header-path "templates/html/header.html")
20 (define html-post-path "templates/html/post.html")
21 (define html-footer-path "templates/html/footer.html")
22 (define html-file "index.html")
23
24 (define rss-header-path "templates/rss/header.xml")
25 (define rss-item-path "templates/rss/item.xml")
26 (define rss-footer-path "templates/rss/footer.xml")
27 (define rss-file "feed.rss")
28
29 (define config-alist #f)
30 (define html-header-value #f)
31 (define html-post-value #f)
32 (define html-footer-value #f)
33 (define rss-header-value #f)
34 (define rss-item-value #f)
35 (define rss-footer-value #f)
36
37 (define-values (from-server to-server) (values #f #f))
38
39 (define config-contents
40 #<<string-block
41 (
42 ;; this file was generated by linkbud.
43 ;; source: https://git.m455.casa/linkbud
44 (irc-host . "irc.libera.chat")
45 (irc-port . 6667)
46 (irc-ssl . #f) ;; can be #t or #f
47
48 ;; can be #f, (irc-password "mycoolpassword"), or, if it's supported, you can
49 ;; use the following password as a sasl workaround (ergo.chat supports this):
50 ;; (irc-password "username:mycoolpassword")
51 (irc-password . #f)
52
53 ;; irc servers, such as https://ergo.chat/ provide a history playback feature,
54 ;; which can cause bots to pick up old, already-processed messages when
55 ;; connecting. set this to #t if you want to disable history playback.
56 ;; such as ergo.chat.
57 (irc-disable-history? . #f)
58
59 (irc-nickname . "linkbud") ;; this value shows up as the bot's name in chat, and can be registered
60 (irc-username . "linkbud") ;; this value shows up in join and leave messages
61 (irc-realname . "linkbud") ;; this value shows up in... i don't know haha
62
63 ;; add channels in the list below that you want linkbud to listen and respond to
64 ;; for example:
65 ;; (irc-channels ("#basement"
66 ;; "#another-channel"
67 ;; "#some-other-channel"))
68 (irc-channels . ("#linkbud-demo"))
69
70 ;; the following items use this value:
71 ;; - the templates/rss/rss-header.xml
72 ;; - the templates/rss/rss-item.xml
73 (base-url . "https://linkbudz.example.com")
74
75 ;; the directory where the index.html and feed.rss files will be generated for
76 ;; for example:
77 ;; (build-path "/var/www/my-website-directory")
78 (build-path . "build")
79
80 ;; this only shows up in the rss feed itself
81 (rss-feed-title . "linkbudz rss feed")
82 (rss-description-value . "links shared by friends")
83
84 ;; the html <title> and <h1> use this
85 (html-title . "LINKBUDZ")
86
87 ;; message shown after someone submits a post
88 (post-response . "post added to linkbudz!")
89 )
90 string-block
91 )
92
93 (define html-header-contents
94 #<<string-block
95 <!DOCTYPE html>
96 <html>
97 <head>
98 <meta charset="utf-8" />
99 <meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes" />
100 <link rel="icon" href="data:,">
101 <link rel="alternate" type="application/rss+xml" title="{{rss-feed-title}}" href="{{base-url}}/feed.rss"/>
102 <title>{{html-title}}</title>
103 <style>
104 body {
105 font-family: sans-serif;
106 font-size: 18px;
107 margin: 0 auto;
108 max-width: 600px;
109 }
110
111 hr {
112 border: 0;
113 border-bottom: 2px solid black;
114 }
115
116 a {
117 color: blue;
118 text-decoration: none;
119 font-weight: bold;
120 }
121
122 dd {
123 margin: 4px 0;
124 }
125
126 .last-dd {
127 margin-bottom: 30px;
128 }
129
130 .protocol {
131 color: #3a4f3a;
132 background-color: #beffbe;
133 padding: 2px 5px;
134 }
135
136 @media only screen and (max-width: 700px) {
137 body {
138 margin: 10px;
139 }
140 }
141
142 @media (prefers-color-scheme: dark) {
143 body {
144 background-color: #111;
145 color: #eee;
146 }
147 hr {
148 border-bottom: 2px solid #eee;
149 }
150 a {
151 color: #0ff;
152 }
153 .protocol {
154 color: #ff7a7a;
155 background-color: #111;
156 padding: 0;
157 }
158 }
159 </style>
160 <script>
161 function copyId(button_tag) {
162 /* get the text */
163 var elem = button_tag.parentElement.querySelector('span.id').innerHTML;
164
165 /* Copy the text inside the text field */
166 navigator.clipboard.writeText(elem);
167
168 /* change the button text */
169 button_tag.innerHTML = "Copied!";
170 }
171 </script>
172 <noscript>
173 <style>
174 .dont-show-if-javascript-is-disabled {
175 display: none;
176 }
177 </style>
178 </noscript>
179 </head>
180 <body>
181 <h1>{{html-title}}</h1>
182 <p><a href="{{base-url}}/feed.rss">RSS</a></p>
183 <hr aria-hidden="true">
184 <dl>
185 string-block
186 )
187
188 (define html-post-contents
189 #<<string-block
190 <dt>
191 <a href="{{post-url}}">{{post-title}}</a>
192 </dt>
193 <dd>
194 <span class="protocol">{{post-protocol}}</span> posted by
195 <span class="sender">{{post-sender}}</span> on
196 <span class="time">{{post-date-human}}</span>
197 </dd>
198 <dd class="last-dd">
199 <span aria-hidden="true">ID: <span class="id">{{post-guid}}</span></span>
200 <button class="dont-show-if-javascript-is-disabled" onclick="copyId(this)">Copy ID</button>
201 </dd>
202 string-block
203 )
204
205 (define html-footer-contents
206 #<<string-block
207 </dl>
208 </body>
209 </html>
210 string-block
211 )
212
213 (define rss-header-contents
214 #<<string-block
215 <?xml version="1.0" encoding="UTF-8" ?>
216 <rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom">
217 <channel>
218 <title>{{rss-feed-title}}</title>
219 <link>{{base-url}}</link>
220 <description>{{rss-description-value}}</description>
221 <atom:link href="{{base-url}}/feed.rss" rel="self" type="application/rss+xml" />
222 string-block
223 )
224
225 (define rss-item-contents
226 #<<string-block
227 <item>
228 <title><![CDATA[{{item-title}}]]></title>
229 <link><![CDATA[{{item-url}}]]></link>
230 <guid isPermaLink="false">{{item-guid}}</guid>
231 <category domain="{{base-url}}">{{item-protocol}}</category>
232 <pubDate>{{item-date-rss}}</pubDate>
233 <description>
234 <![CDATA[
235 <p><a href="{{item-url}}">{{item-title}}</a></p>
236 <p>[{{item-protocol}}] posted by {{item-sender}} on {{item-date-human}}</p>
237 ]]>
238 </description>
239 </item>
240 string-block
241 )
242
243 (define rss-footer-contents
244 #<<string-block
245 </channel>
246 </rss>
247 string-block
248 )
249
250 (define (ormap f l)
251 (if (null? l)
252 #f
253 (if (f (car l))
254 #t
255 (ormap f (cdr l)))))
256
257 (define (file-write path contents)
258 (with-output-to-file path
259 (lambda () (print contents))))
260
261 (define (file-append path contents)
262 (with-output-to-file path
263 (lambda () (print contents))
264 #:append))
265
266 (define (pretty-print-to-file path contents)
267 (with-output-to-file path
268 (lambda () (pretty-print contents))))
269
270 (define (file-doesnt-exist-and-exit file)
271 (print (format "error: ~a doesn't exist. try running 'linkbud init'" file))
272 (exit))
273
274 (define (load-config!)
275 (if (file-exists? config-file)
276 (set! config-alist (with-input-from-file config-file read))
277 (file-doesnt-exist-and-exit config-file)))
278
279 (define (config-get key)
280 (alist-ref key config-alist))
281
282 ;; use syntax-rules here to delay evaluation of value, otherwise #f is passed to
283 ;; the parameter on startup, because I set the values all to #f by default on
284 ;; startup, which would cause this function to set everything to #f everytime
285 ;; it's called
286 (define-syntax load-template!
287 (syntax-rules ()
288 ((_ value file)
289 (if (file-exists? file)
290 (set! value (with-input-from-file file read-string))
291 (file-doesnt-exist-and-exit file)))))
292
293 (define (load-templates!)
294 (load-template! html-header-value html-header-path)
295 (load-template! html-post-value html-post-path)
296 (load-template! html-footer-value html-footer-path)
297 (load-template! rss-header-value rss-header-path)
298 (load-template! rss-item-value rss-item-path)
299 (load-template! rss-footer-value rss-footer-path))
300
301 (define (pair->mustached-pair pair)
302 (let* ((first (car pair))
303 (key (if (string? first)
304 first
305 (symbol->string first))))
306 `(,(string-append "{{" key "}}") . ,(cdr pair))))
307
308 (define (string-populate str smap)
309 (string-translate*
310 str
311 (map pair->mustached-pair smap)))
312
313 (define (string-populate-with-default-values str)
314 (string-translate*
315 str
316 (map pair->mustached-pair config-alist)))
317
318 (define (shell-command str)
319 (call-with-input-pipe str read-line))
320
321 ;; returns "2022-02-14 21:17:26" because the `date -Rd'<some_date>'` doesn't
322 ;; like it without the hyphens or colons
323 (define (date-current)
324 (time->string (seconds->local-time) "%Y-%m-%d %H:%M:%S"))
325
326 ;; returns "Mon, 14 Feb 2022 21:17:26 -0500"
327 (define (date->rss-date str)
328 (time->string (string->time str "%Y-%m-%d %H:%M")
329 "%a, %d %b %Y %H:%M:%S %z"))
330
331 ;; returns "February 14, 2022"
332 (define (date->human-date str)
333 (time->string (string->time str "%Y-%m-%d %H:%M")
334 "%B %d, %Y"))
335
336 (define (clean-input-for-html str)
337 (if (or (string-contains str "javascript:")
338 (string-contains str "mailto:"))
339 (clean-input-for-html (string-translate* str '(("javascript:" . "")
340 ("mailto:" . "")
341 ("]]>" . ""))))
342 (string-translate* str '(("&" . "&amp;")
343 ("<" . "&lt;")
344 (">" . "&gt;")
345 ("\"" . "&quot;")
346 ("'" . "&#39;")))))
347
348 (define (clean-input-html->rss str)
349 ;; we don't need the other stuff that clean-input-for-html does, such as the
350 ;; javascript and mailto stuff, because the str is passed through
351 ;; clean-input-for-html before getting to this procedure
352 (string-translate* str '(("&amp;" . "&")
353 ("&lt;" . "<")
354 ("&gt;" . ">")
355 ("&quot;" . "\"")
356 ("&#39;" . "'"))))
357
358 (define (fix-url url-str)
359 (let ((split-str (string-split url-str "://")))
360 (if (> (length split-str) 1)
361 url-str
362 (string-append "https://" url-str))))
363
364 (define (get-protocol url-str)
365 (let ((split-str (string-split url-str "://")))
366 (if (> (length split-str) 1)
367 (car split-str)
368 "https")))
369
370 (define (sort-by-date mode log)
371 (let ((sort-list-of-alists (lambda ()
372 (sort log (lambda (x-alist y-alist)
373 (< (alist-ref 'date x-alist)
374 (alist-ref 'date y-alist)))))))
375 (if (eq? mode 'reverse)
376 (reverse (sort-list-of-alists))
377 (sort-list-of-alists))))
378
379 (define (log-file->sexp)
380 (if (file-exists? log-file)
381 (with-input-from-file log-file read)
382 '()))
383
384 (define (id-exists? id-str list-of-post-alists)
385 (if (null? list-of-post-alists)
386 #f
387 (let ((current-alist (car list-of-post-alists)))
388 (if (equal? id-str (alist-ref 'guid current-alist))
389 ;; we return this here, instead of returning #t, so we can use this
390 ;; procedure with an (remove-alist-from-list ... alist) procedure
391 current-alist
392 (id-exists? id-str (cdr list-of-post-alists))))))
393
394 (define (remove-alist-from-list alist list-of-alists)
395 (if (null? list-of-alists)
396 '()
397 (if (equal? alist (car list-of-alists))
398 (remove-alist-from-list alist (cdr list-of-alists))
399 (cons (car list-of-alists)
400 (remove-alist-from-list alist (cdr list-of-alists))))))
401
402 ;; irc util ====================================================================
403 ;; (tcp-read-timeout #f) so (read-line ...) on a TCP connection doesn't timeout after 60 seconds
404 (tcp-read-timeout #f)
405
406 (define (send str)
407 (write-line (string-append str "\r\n") to-server))
408
409 (define-syntax send-format
410 (syntax-rules ()
411 ((_ str v ...)
412 (send (format str v ...)))))
413
414 (define (send-password)
415 (send-format "PASS ~a" (config-get 'irc-password)))
416
417 (define (send-nick)
418 (send-format "NICK ~a" (config-get 'irc-nickname)))
419
420 (define (send-user)
421 (send-format "USER ~a 0.0.0.0 ~a :~a"
422 (config-get 'irc-nickname)
423 (config-get 'irc-username)
424 (config-get 'irc-realname)))
425
426 (define (send-message channel message)
427 (send-format "PRIVMSG ~a :~a" channel message))
428
429 (define (check-for-ping server-data)
430 (when (equal? "PING" (substring server-data 0 4))
431 (send "PONG :lol")))
432
433 (define (disable-history)
434 (send-format "PRIVMSG nickserv :SET autoreplay-lines 0"))
435
436 (define (join-channel channel)
437 (send-format "JOIN ~a" channel))
438
439 (define (join-channels)
440 (for-each join-channel (config-get 'irc-channels)))
441
442 (define (get-sender mode split-server-data)
443 (let* ((sender-data (list-ref split-server-data 0)) ;; => ":nickname!~realname@user/realname" or ":nickname!realname@localhost"
444 (sender-data-split (string-split sender-data ":!~@"))) ;; => ("nickname" "realname" "user/realname")
445 (case mode
446 ('realname (cadr sender-data-split))
447 ('nickname (car sender-data-split))
448 (else "unknown"))))
449
450 (define (get-channel split-server-data)
451 (list-ref split-server-data 2))
452
453 ;; returns a message in the form of '("this" "is" "a" "test")
454 (define (get-message split-server-data)
455 (let ((raw-message-split (list-tail split-server-data 3))) ;; => '(":this" "is" "a" "test")
456 (cons (substring (car raw-message-split) 1) ;; get the first item, and remove the colon
457 (cdr raw-message-split))))
458
459 ;; generation utils =======================================================
460 (define (generate-feed-rss list-of-item-alists)
461 (let ((rss-file-path (make-pathname (config-get 'build-path) rss-file)))
462 ;; create rss header and overwrite file
463 (file-write rss-file-path
464 (string-populate-with-default-values rss-header-value))
465
466 ;; create rss items and append them to file
467 (for-each
468 (lambda (item-alist)
469 (file-append
470 rss-file-path
471 (string-populate (string-populate-with-default-values rss-item-value)
472 `((item-title . ,(clean-input-html->rss (alist-ref 'title item-alist)))
473 (item-url . ,(alist-ref 'url item-alist))
474 (item-guid . ,(alist-ref 'guid item-alist))
475 (item-protocol . ,(alist-ref 'protocol item-alist))
476 (item-sender . ,(alist-ref 'sender item-alist))
477 (item-date-rss . ,(alist-ref 'date-rss item-alist))
478 (item-date-human . ,(alist-ref 'date-human item-alist))))))
479 list-of-item-alists)
480 ;; append rss footer to file
481 (file-append rss-file-path rss-footer-value)))
482
483 ;; generate html utils ==========================================
484 (define (generate-feed-html list-of-post-alists)
485 (let ((html-file-path (make-pathname (config-get 'build-path) html-file)))
486 ;; create html header
487 (file-write html-file-path
488 (string-populate-with-default-values html-header-value))
489
490 ;; append html posts
491 (for-each
492 (lambda (post-alist)
493 (file-append
494 html-file-path
495 (string-populate html-post-value
496 `((post-url . ,(alist-ref 'url post-alist))
497 (post-title . ,(alist-ref 'title post-alist))
498 (post-protocol . ,(alist-ref 'protocol post-alist))
499 (post-sender . ,(alist-ref 'sender post-alist))
500 (post-date-human . ,(alist-ref 'date-human post-alist))
501 (post-guid . ,(alist-ref 'guid post-alist))))))
502 list-of-post-alists)
503 ;; append html footer
504 (file-append html-file-path
505 html-footer-value)))
506
507 ;; commands ===================================================================
508 (define (post-delete channel realname id-str)
509 (let* ((log-file-sexp (log-file->sexp))
510 (post-to-remove (id-exists? id-str log-file-sexp)))
511 (if post-to-remove
512 (let* ((posts-list (remove-alist-from-list post-to-remove log-file-sexp))
513 (posts-list-reversed (sort-by-date 'reverse posts-list)))
514 (pretty-print-to-file log-file posts-list)
515 (generate-feed-html posts-list-reversed)
516 (generate-feed-rss posts-list-reversed)
517 (send-message channel "post deleted!"))
518 (send-message channel "oh no, that ID doesn't exist!"))))
519
520 ;; message split comes in the form of: "im-a-url im a title"
521 (define (post-add channel realname message-split)
522 (if (>= (length message-split) 2) ;; at least '(a b) or more
523 (let* ((log-file-contents (log-file->sexp))
524 (date (date-current)) ;; => "2022-02-14 21:17:26"
525 (date-numbers-only (string-translate date "- :")) ;; => "20220214211726" (punctuation-less format for sorting by number)
526 (url (fix-url (clean-input-for-html (car message-split))))
527 (contents-after-url (string-intersperse (cdr message-split)))
528 (post-alist `(((date . ,(string->number date-numbers-only))
529 (date-rss . ,(date->rss-date date)) ;; => "Mon, 14 Feb 2022 21:17:26 -0500" (this can't convert the punctuation-less format to the RSS format unfortunately, so we use the punctuation format)
530 (date-human . ,(date->human-date date)) ;; => "February 14, 2022"
531 (sender . ,realname)
532 (url . ,url)
533 (title . ,(clean-input-for-html contents-after-url))
534 (guid . ,(string-append realname date-numbers-only)) ;; => "nick20220214211726"
535 (protocol . ,(get-protocol url))))) ;; => whatever comes before the first "://". defaults to "http" if no protocol is provided
536 (posts-list (sort-by-date 'normal (append log-file-contents post-alist)))
537 (posts-list-reversed (sort-by-date 'reverse posts-list)))
538 ;; write to log file
539 (pretty-print-to-file log-file posts-list)
540 ;; generate html and rss
541 (generate-feed-html posts-list-reversed)
542 (generate-feed-rss posts-list-reversed)
543 ;; i don't use the URL here because it pings me on irc lol
544 (send-message channel (config-get 'post-response)))
545 (begin
546 (send-message channel "woops. you need to provide a link and a title, friend :O.")
547 (send-message channel "kind of like this: !post https://example.com your very cool title here"))))
548
549 (define (reload channel)
550 (load-config!)
551 (load-templates!)
552 (send-message channel "config.scm and template files reloaded!"))
553
554 (define (regenerate channel)
555 (let ((posts-list-reversed (sort-by-date 'reverse (log-file->sexp))))
556 (if (null? posts-list-reversed)
557 (begin
558 (send-message channel "woops! it looks like there aren't any posts")
559 (send-message channel "try adding one with !post <link> <title>"))
560 (begin
561 (generate-feed-html posts-list-reversed)
562 (generate-feed-rss posts-list-reversed)
563 (send-message channel "feeds regenerated!")))))
564
565 (define (help channel)
566 (send-message channel "i respond to the following commands:")
567 (send-message channel " !post <link> <title>: submit a link to the feed")
568 (send-message channel " !delete <id of post>: delete a link from the feed")
569 (send-message channel " !regenerate: regenerate the html and rss feeds")
570 (send-message channel " !reload: reload the config.scm and template files")
571 (send-message channel " !linkbud: display this help message"))
572
573 ;; irc loop ===================================================================
574 ;; how split-server-data looks:
575 ;; 0 1 2 3
576 ;; '(":some-nickname!some-realname@localhost" "PRIVMSG" "#tildetown" ":this" "is" "a" "test")
577 ;; or sometimes with a tilde:
578 ;; '(":some-nickname!~some-realname@user/some-realname" "PRIVMSG" "#tildetown" ":this" "is" "a" "test")
579 ;;
580 ;; and note to self, this is how private messages look:
581 ;; :some-nickname!~some-realname@user/some-realname PRIVMSG linkbud :oh this is a test
582 ;; , because i'll need to reference this later
583 (define (check-for-command server-data)
584 (let ((split-server-data (string-split server-data)))
585 (when (equal? (list-ref split-server-data 1) "PRIVMSG")
586 (let* ((nickname (get-sender 'nickname split-server-data))
587 ;; ergo.chat, if names are cloaked, uses "nickname!~u@ ...", so
588 ;; this doesn't really work here, which is why i commented it out
589 ;; for now
590 ; (realname (get-sender 'realname split-server-data))
591 (realname (get-sender 'nickname split-server-data))
592 (chan (get-channel split-server-data))
593 (channel (if (equal? chan (config-get 'irc-nickname))
594 nickname
595 chan))
596 (message-split (get-message split-server-data)))
597 (when (not (null? message-split))
598 (case (string->symbol (car message-split))
599 ((!post !link) (post-add channel realname (cdr message-split)))
600 ('!delete (post-delete channel realname (cadr message-split)))
601 ('!regenerate (regenerate channel))
602 ('!reload (reload channel))
603 ('!linkbud (help channel))
604 (else 'do-nothing)))))))
605
606 (define (start-irc-connection)
607 (when (config-get 'irc-password)
608 (send-password))
609 (send-nick)
610 (send-user)
611 (when (config-get 'irc-disable-history?) (disable-history))
612 (join-channels)
613 (sleep 1))
614
615 (define (listen-to-irc-server)
616 (let ((server-data (read-line from-server)))
617 (print server-data)
618 (check-for-ping server-data)
619 (check-for-command server-data)
620 (sleep 1))
621 (listen-to-irc-server))
622
623 (define (create-init-file file contents)
624 (if (file-exists? file)
625 (print (format "~a already exists. skipping file creation" file))
626 (let ((directory (pathname-directory file)))
627 ;; #t creates parent directories if they exist
628 (when directory (create-directory directory #t))
629 (file-write file contents)
630 (print (format "created ~a" file)))))
631
632 (define (init)
633 (when (not (file-exists? config-file))
634 (file-write config-file config-contents))
635
636 ;; load config file contents into runtime because the build path needs
637 ;; to be retrieved from the generated config file
638 (load-config!)
639
640 (create-init-file html-header-path html-header-contents)
641 (create-init-file html-post-path html-post-contents)
642 (create-init-file html-footer-path html-footer-contents)
643 (create-init-file rss-header-path rss-header-contents)
644 (create-init-file rss-item-path rss-item-contents)
645 (create-init-file rss-footer-path rss-footer-contents)
646
647 (create-directory (config-get 'build-path)))
648
649 (define (run)
650 (if (file-exists? config-file)
651 (begin (load-config!)
652 (load-templates!)
653 (set!-values (from-server to-server)
654 (let ((irc-host (config-get 'irc-host))
655 (irc-port (config-get 'irc-port)))
656 (if (config-get 'irc-ssl)
657 (ssl-connect* #:hostname irc-host
658 #:port irc-port)
659 (tcp-connect irc-host irc-port))))
660 (start-irc-connection)
661 (listen-to-irc-server))
662 (print "linkbud hasn't been initialized yet. Try running ./linkbud init.")))
663
664 (define help-message
665 #<<string-block
666 help - display this help message
667 init - generate default files
668 run - connect linkbud to an irc server and listen for commands
669 string-block
670 )
671
672 (define (main args)
673 (if (null? args)
674 (print help-message)
675 (case (string->symbol (car args))
676 ((--help -help help -h)
677 (print help-message))
678 ('init (init))
679 ('run (run))
680 (else (print help-message)))))
681
682 (main (command-line-arguments))