Repair the inotify daemon-skeleton, create example client

Now this library should be mostly-usable for writing a client!

chatdir-inotify.scm

@@ -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 "/")))]
-                 [join-callback (alist-ref 'join-channel callbacks-alist)])
+				  [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
+			 [channel-inpath (subpath root-dir channel ".in")]
-              (string-append (inotify:wd->path
-                              (inotify:event-wd event))
-                             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)])
+      (let* ([channel (inotify:event-name event)])
-        (print "Attempting to join channel " dirname "…")
+        (print "Attempting to join channel " channel "…")
         (if join-callback
-            (apply join-callback (list path))))])))
+            (apply join-callback (list channel))))])))
-
-
-(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 ".")))
 
 
 ;; 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. 🎶

chatdir.scm

@@ -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)

inotify.scm

@@ -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. 🎶
+

tests/inotify.scm

@@ -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*)