jadedctrl/ chicken-chatdir
Archived
1
0
Disbranĉigi 0
Fontkodo Issues Tirpetoj Activity

Repair the inotify daemon-skeleton, create example client 

Now this library should be mostly-usable for writing a client!
This commit is contained in:
Jaidyn Ann 2023-05-21 15:35:35 -05:00
parent 72f17d26a7
commit 6583b26f52
5 changed files with 263 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

115
chatdir-inotify.scm
View File

@ -15,16 +15,30 @@
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;
(load "chatdir.scm")
(import scheme
(prefix inotify inotify:)
(chicken file) (chicken io) (chicken pathname)
srfi-1
(prefix inotify inotify:))
;; ——————————————————————————————————————————————————
;; Skeleton of a daemon
;; ——————————————————————————————————————————————————
;; The FS-backed input loop, to be run in a seperate thread (so as to not block).
;; This handles channel leaving/joining, and the sending of messages.
;; It should be called after input-loop-init.
;; Call-backs that should be provided in the callbacks-alist are:
;; (join-channel channel) ;; Should call this library's channel-joined function.
;; (leave-channel channel)
;; (send-message channel message-content)
(define (input-loop root-dir callbacks-alist)
(map (lambda (event)
(handle-file-event root-dir callbacks-alist event))
(inotify:next-events!))
(input-loop root-dir callbacks-alist))
;; Initialization for the input loop
(define (input-loop-init root-dir callbacks-alist)
(let ([join-callback (alist-ref 'join-channel callbacks-alist)])
@ -35,19 +49,42 @@
;; Auto-join channels with all pre-existing channel directories
(map (lambda (path)
(let ([channel-dirname (pathname-file (pathname-directory (string-append path "/")))]
(let* ([channel-dirname (pathname-file (pathname-directory (string-append path "/")))]
[in-path (subpath root-dir channel-dirname ".in")]
[join-callback (alist-ref 'join-channel callbacks-alist)])
(print channel-dirname " - " in-path)
(if join-callback
(apply join-callback (list channel-dirname)))
(inotify:add-watch! in-path '(moved-to close-write))
(inotify:add-watch! (create-directory in-path #t)
'(moved-to close-write))
(print "Joined and watching: " in-path)))
(filter directory-exists? (directory-rel irc-dir)))))
(filter directory-exists? (directory-rel root-dir)))))
;; Should be called from the join-channel callback, to
;; communicate that the channel was successfully joined.
(define (channel-joined root-dir channel)
(let* ([in-path (subpath root-dir channel ".in")])
(inotify:add-watch! (create-directory in-path #t)
'(moved-to close-write))
(print "Began watching input " in-path ".")))
;; Handle a single inotify file event, as part of the input loop
(define (handle-file-event root-dir callbacks-alist event)
(if (not (member 'ignored (inotify:event-flags event)))
(let* ([flags (inotify:event-flags event)]
[wd-path (inotify:wd->path (inotify:event-wd event))]
[main-dir? (string=? wd-path root-dir)])
(if main-dir?
(handle-main-dir-event root-dir callbacks-alist event)
(handle-channel-dir-event root-dir callbacks-alist event)))))
;; Handles all inotify-watched file events from the top-level IRC-directory.
;; Mainly, checking for newly-joined or left channels.
(define (handle-main-dir-event callbacks-alist event)
(define (handle-main-dir-event root-dir callbacks-alist event)
(let ([flags (inotify:event-flags event)]
[leave-callback (alist-ref 'leave-channel callbacks-alist)]
[join-callback (alist-ref 'join-channel callbacks-alist)])
@ -58,13 +95,10 @@
(member 'delete flags)
(member 'delete-self flags))
(let* ([channel (inotify:event-name event)]
[channel-inpath
(string-append (inotify:wd->path
(inotify:event-wd event))
channel "/.in")]
[channel-inpath (subpath root-dir channel ".in")]
[channel-wd (path->wd channel-inpath)])
(print "Remove watch for " channel-inpath "…")
(if (and channel-wd (member channel-wd (wd-list)))
(if (and channel-wd (member channel-wd (inotify:wd-list)))
(attempt-remove-watch! channel-wd))
(if leave-callback
(apply leave-callback (list channel))))]
@ -72,20 +106,14 @@
;; If a dir's been created for a channel, maybe-join, then watch input!
[(or (member 'create flags)
(member 'moved-to flags))
(let* ([channel (inotify:event->pathname event)])
(print "Attempting to join channel " dirname "…")
(let* ([channel (inotify:event-name event)])
(print "Attempting to join channel " channel "…")
(if join-callback
(apply join-callback (list path))))])))
(define (channel-joined root-dir channel)
(let* ([in-path (normalize-pathname (string-append root-dir "/" channel "/.in"))])
(inotify:add-watch! in-path '(moved-to close-write))
(print "Began watching input " in-path ".")))
(apply join-callback (list channel))))])))
;; Handles an inotify event that pertains to a channel's .in/ directory
(define (handle-channel-dir-event callbacks-alist event)
(define (handle-channel-dir-event root-dir callbacks-alist event)
(let* ([event-dir (pathname-directory (inotify:event->pathname event))]
[dirname (pathname-file event-dir)]
[channel (pathname-file (pathname-directory event-dir))]
@ -96,36 +124,12 @@
[(and (string=? dirname ".in")
send-message-callback)
(map (lambda (message)
(apply send-message (list channel message)))
(apply send-message-callback (list channel message)))
(with-input-from-file (inotify:event->pathname event)
read-lines))
(delete-file* (inotify:event->pathname event))])))
;; Handle a single inotify file event, as part of the input loop
(define (handle-file-event root-dir callbacks-alist event)
(if (not (member 'ignored (event-flags event)))
(let* ([flags (inotify:event-flags event)]
[wd-path (inotify:wd->path (inotify:event-wd event))]
[main-dir? (string=? wd-path root-dir)])
(if main-dir?
(handle-main-dir-event root-dir callbacks-alist event)
(handle-channel-dir-event root-dir callbacks-alist event)))))
;; The FS-backed input loop, to be run in a seperate thread (so as to not block)
;; This handles channel leaving/joining, and sending messages
;; Call-backs that should be provided:
;; (channel-joined channel)
;; (new-message channel text)
(define (input-loop root-dir callbacks-alist)
(map (lambda (event)
(handle-file-event root-dir callbacks-alist event))
(inotify:next-events!))
(input-loop root-dir callbacks-alist))
;; ——————————————————————————————————————————————————
;; Utility
@ -147,6 +151,23 @@
#t
(inotify:remove-watch! watch)))
;; Wrapper around `directory` that lists a dir's files as a relative path
(define (directory-rel #!optional (path "./"))
(let ([relative-parent (normalize-pathname (string-append path "/"))])
(map (lambda (leaf)
(string-append relative-parent leaf))
(directory path))))
;; Return a file path with the given parameters as elements of the path
;; E.g., "/etc/", "/systemd/user" "mom" => "/etc/systemd/user/mom"
(define (subpath . children)
(normalize-pathname
(reduce-right (lambda (a b)
(string-append a "/" b))
"" children)))
;; Repeat after me:
;; 🎵 Symbolic links cannot have extended attributes, and that is a war-crime. 🎶
;; 🎵 Directories cannot have extended attributes, and that is a war-crime. 🎶

7
chatdir.scm
View File

@ -352,13 +352,6 @@
(string-append a "/" b))
"" children)))
;; Wrapper around `directory` that lists a dir's files as a relative path
(define (directory-rel #!optional (path "./"))
(let ([relative-parent (normalize-pathname (string-append path "/"))])
(map (lambda (leaf)
(string-append relative-parent leaf))
(directory path))))
;; Title says all, I'd hope.
(define (write-string-to-file file value)

173
inotify.scm Normal file
View File

@ -0,0 +1,173 @@
;; Copyright 2023, Jaidyn Levesque <jadedctrl@posteo.at>
;; All rights reserved. Distributed under the terms of the MIT license.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;
(import scheme
(chicken file) (chicken io) (chicken pathname)
srfi-1
(prefix inotify inotify:))
;; ——————————————————————————————————————————————————
;; Skeleton of a daemon
;; ——————————————————————————————————————————————————
;; Initialization for the input loop
(define (input-loop-init root-dir callbacks-alist)
(let ([join-callback (alist-ref 'join-channel callbacks-alist)])
(inotify:init!)
;; Start watching the chatdir (for new channel joins, etc)
(inotify:add-watch!
root-dir '(onlydir moved-to moved-from delete delete-self create))
;; Auto-join channels with all pre-existing channel directories
(map (lambda (path)
(let* ([channel-dirname (pathname-file (pathname-directory (string-append path "/")))]
[in-path (subpath root-dir channel-dirname ".in")]
[join-callback (alist-ref 'join-channel callbacks-alist)])
(print channel-dirname " - " in-path)
(if join-callback
(apply join-callback (list channel-dirname)))
(inotify:add-watch! (create-directory in-path #t)
'(moved-to close-write))
(print "Joined and watching: " in-path)))
(filter directory-exists? (directory-rel root-dir)))))
;; Handles all inotify-watched file events from the top-level IRC-directory.
;; Mainly, checking for newly-joined or left channels.
(define (handle-main-dir-event root-dir callbacks-alist event)
(let ([flags (inotify:event-flags event)]
[leave-callback (alist-ref 'leave-channel callbacks-alist)]
[join-callback (alist-ref 'join-channel callbacks-alist)])
(cond
;; If a channel dir's been moved or removed, stop watching (ofc)
;; … Also quit that room! Heck them!
[(or (member 'moved-from flags)
(member 'delete flags)
(member 'delete-self flags))
(let* ([channel (inotify:event-name event)]
[channel-inpath (subpath root-dir channel ".in")]
[channel-wd (path->wd channel-inpath)])
(print "Remove watch for " channel-inpath "…")
(if (and channel-wd (member channel-wd (inotify:wd-list)))
(attempt-remove-watch! channel-wd))
(if leave-callback
(apply leave-callback (list channel))))]
;; If a dir's been created for a channel, maybe-join, then watch input!
[(or (member 'create flags)
(member 'moved-to flags))
(let* ([channel (inotify:event-name event)])
(print "Attempting to join channel " channel "…")
(if join-callback
(apply join-callback (list channel))))])))
;; Should be called from the join-channel callback, to
;; communicate that the channel was successfully joined.
(define (channel-joined root-dir channel)
(let* ([in-path (subpath root-dir channel ".in")])
(inotify:add-watch! (create-directory in-path #t)
'(moved-to close-write))
(print "Began watching input " in-path ".")))
;; Handles an inotify event that pertains to a channel's .in/ directory
(define (handle-channel-dir-event root-dir callbacks-alist event)
(let* ([event-dir (pathname-directory (inotify:event->pathname event))]
[dirname (pathname-file event-dir)]
[channel (pathname-file (pathname-directory event-dir))]
[send-message-callback (alist-ref 'send-message callbacks-alist)])
(cond
;; If input is given to an `.in` dir… well, send that darn message!
;; What're you wating for?
[(and (string=? dirname ".in")
send-message-callback)
(map (lambda (message)
(apply send-message-callback (list channel message)))
(with-input-from-file (inotify:event->pathname event)
read-lines))
(delete-file* (inotify:event->pathname event))])))
;; Handle a single inotify file event, as part of the input loop
(define (handle-file-event root-dir callbacks-alist event)
(if (not (member 'ignored (inotify:event-flags event)))
(let* ([flags (inotify:event-flags event)]
[wd-path (inotify:wd->path (inotify:event-wd event))]
[main-dir? (string=? wd-path root-dir)])
(if main-dir?
(handle-main-dir-event root-dir callbacks-alist event)
(handle-channel-dir-event root-dir callbacks-alist event)))))
;; The FS-backed input loop, to be run in a seperate thread (so as to not block)
;; This handles channel leaving/joining, and sending messages
;; Call-backs that should be provided:
;; (channel-joined channel)
;; (new-message channel text)
(define (input-loop root-dir callbacks-alist)
(map (lambda (event)
(handle-file-event root-dir callbacks-alist event))
(inotify:next-events!))
(input-loop root-dir callbacks-alist))
;; ——————————————————————————————————————————————————
;; Utility
;; ——————————————————————————————————————————————————
;; Returns an inotify watch-descriptor according the given path
(define (path->wd path)
(car
(filter (lambda (wd)
(string=? (normalize-pathname (inotify:wd->path wd))
(normalize-pathname path)))
(inotify:wd-list))))
;; Attempt to remove an inotify watch; if it's already been removed, no sweat
;; (This happens sometimes when inotify automatically deletes a watch)
(define (attempt-remove-watch! watch)
(handle-exceptions exn
#t
(inotify:remove-watch! watch)))
;; Wrapper around `directory` that lists a dir's files as a relative path
(define (directory-rel #!optional (path "./"))
(let ([relative-parent (normalize-pathname (string-append path "/"))])
(map (lambda (leaf)
(string-append relative-parent leaf))
(directory path))))
;; Return a file path with the given parameters as elements of the path
;; E.g., "/etc/", "/systemd/user" "mom" => "/etc/systemd/user/mom"
(define (subpath . children)
(normalize-pathname
(reduce-right (lambda (a b)
(string-append a "/" b))
"" children)))
;; Repeat after me:
;; 🎵 Symbolic links cannot have extended attributes, and that is a war-crime. 🎶
;; 🎵 Directories cannot have extended attributes, and that is a war-crime. 🎶

0
tests/test-chatdir.scm → tests/chatdir.scm
View File

21
tests/inotify.scm Normal file
View File

@ -0,0 +1,21 @@
(load "../chatdir-inotify.scm")
(define (join-callback channel)
(print "Joined " channel "! ^_^")
(channel-joined "test chatdir" channel))
(define (leave-callback channel)
(print "We've left " channel " </3>"))
(define (send-message-callback channel message)
(print "Sent message to " channel ": " message))
(define *callbacks*
(list (cons 'join-channel join-callback)
(cons 'leave-channel leave-callback)
(cons 'send-message send-message-callback)))
(input-loop-init "test chatdir" *callbacks*)
(input-loop "test chatdir" *callbacks*)