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

Reorganize source file, spaces > tabs

This commit is contained in:
Jaidyn Ann 2023-05-21 11:56:36 -05:00
parent f4b47d3756
commit 2ef1c47b83
2 changed files with 470 additions and 428 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

726
chatdir.scm
View File

@ -15,251 +15,53 @@
;; ;;
(import scheme (import scheme
(chicken file) (chicken file posix) (chicken pathname) (chicken io) (chicken file) (chicken file posix) (chicken pathname) (chicken io)
(chicken random) (chicken string) (chicken random) (chicken string)
srfi-1 srfi-13 srfi-19 srfi-1 srfi-13 srfi-19
(prefix inotify inotify:) (prefix inotify inotify:)
(prefix xattr xattr:)) (prefix xattr xattr:))
;; Wrapper around `directory` that lists a dir's files as a relative path ;; ——————————————————————————————————————————————————
(define (directory-rel #!optional (path "./")) ;; Channel management
(let ([relative-parent (normalize-pathname (string-append path "/"))]) ;; ——————————————————————————————————————————————————
(map (lambda (leaf)
(string-append relative-parent leaf))
(directory path))))
;; 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)))
;; Tidies up a channel directory: Removes `online` and `offline` user links.
(define (channel-cleanup! root channel)
(let ([users-dir (subpath root channel ".users")])
(map
(lambda (state-dir)
(if (not (substring-index state-dir "/all"))
(map
(lambda (link)
(let ([link-path (subpath users-dir state-dir link)])
(if (symbolic-link? link-path)
(delete-file link-path))))
(directory (subpath users-dir state-dir)))))
(directory users-dir))))
;; Lists all currently-joined channels.
(define (channels root)
(directory root))
;; Creates a channel's file hierarchy; safe to run, even if the channel ;; Creates a channel's file hierarchy; safe to run, even if the channel
;; has already been created. ;; has already been created.
(define (channel-add! root channel) (define (channel-add! root channel)
(let* ([path (subpath root channel)]) (let* ([path (subpath root channel)])
(create-directory (subpath path ".in") #t) (create-directory (subpath path ".in") #t)
(create-directory (subpath path ".users" "online") #t) (create-directory (subpath path ".users" "online") #t)
(create-directory (subpath path ".users" "offline") #t) (create-directory (subpath path ".users" "offline") #t)
(create-directory (subpath path ".users" "all") #t) (create-directory (subpath path ".users" "all") #t)
(channel-cleanup! root channel))) (channel-cleanup! root channel)))
;; Create a user's server-wide global-user directory. ;; Tidies up a channel directory: Removes `online` and `offline` user links.
;; Quite simple, compared to channel-user-add! (define (channel-cleanup! root channel)
(define (user-add! root username) (let ([users-dir (subpath root channel ".users")])
(create-directory (subpath root ".users" username "local") #t)) (map
(lambda (state-dir)
(if (not (substring-index state-dir "/all"))
;; Add a user to a channel, creating their channel-user directory. (map
;; There are three types of channel users: (lambda (link)
;; * Channel-only: We have no meaningful way of ever linking this user to a server-wide identity. (let ([link-path (subpath users-dir state-dir link)])
;; (global? #f) (global-pairity #f) (if (symbolic-link? link-path)
;; * Serverwide-1: The user has a server-wide identity, and data like nicknames/profile-pictures (delete-file link-path))))
;; can NOT be changed on a per-channel basis. channel-user is link to global-user. (directory (subpath users-dir state-dir)))))
;; (global #t) (global-pairity #t) (directory users-dir))))
;; * Serverwide-2: The user has a server-wide identity, but their nickname/profile-picture/etc
;; can vary by the channel.
;; (global #t) (global-pairity #f)
(define (channel-user-add! root channel username
#!optional (global? #t) (global-pairity? #t) (global-name #f))
(let* ([g-name (if global-name global-name username)]
[user-path (subpath root channel ".users" "all" username)]
[g-user-path (subpath root ".users" g-name)])
(cond [(or (file-exists? user-path) (directory-exists? user-path))
#f]
;; If global, we gotta do some symlink dancing.
[global?
(user-add! root g-name)
(if global-pairity?
(create-symbolic-link (subpath "../../../.users" g-name) user-path)
(create-directory user-path #t))
(create-symbolic-link (subpath "../../../../.users" g-name)
(subpath user-path "global"))
(create-symbolic-link (subpath "../../../" channel ".users" "all" username)
(subpath g-user-path "local" channel))]
;; This is a channel-only user, don't bother with symlink fanciness.
[#t
(create-directory user-path #t)])))
;; Return a list of all users of a channel of given state.
;; (Lists files in /$channel/.users/$state/).
(define (channel-users root channel #!optional (state "online"))
(directory (subpath root channel ".users" state)))
;; Sets a file in the user's directory to given value.
;; Sets /.users/$user/$key to $value.
(define (user-file-set! root username key value #!optional (xattr-alist '()))
(directory-file-set! (subpath root ".users" username)
key value xattr-alist))
;; Returns the contents of a file in the user's global directory,
;; /.users/$user/$key.
(define (user-file-get root username key)
(directory-file-get (subpath root ".users" username) key))
;; Sets a file in the channel-user's directory to given value.
;; Sets /$channel/.users/all/$user/$key to $value.
(define (channel-user-file-set! root channel username key value #!optional (xattr-alist '()))
(directory-file-set! (subpath root channel ".users" "all" username)
key value xattr-alist))
;; Returns the contents of a file in the user's channel directory,
;; /$channel/.users/all/$user/$key.
(define (channel-user-file-get root channel username key)
(directory-file-get (subpath root channel ".users" "all" username) key))
;; Disables a channel-user's online/offline/etc state.
;; That is, removes a symlink from a /$channel/.users/* directory.
(define (channel-user-disable-state! root channel username state)
(let ([state-link (subpath root channel ".users" state username)])
(if (or (file-exists? state-link)
(symbolic-link? state-link))
(delete-file state-link))))
;; Enables a channel-user's state (online/offline/etc).
;; That is, makes a symlink to a /$channel/.users/* directory.
(define (channel-user-enable-state! root channel username state)
(let* ([state-path
(create-directory (subpath root channel ".users" state) #t)]
[user-path (subpath ".." "all" username)]
[state-link (subpath state-path username)])
(if (not (or (file-exists? state-link)
(symbolic-link? state-link)))
(create-symbolic-link user-path
state-link))))
;; Ensures the enabled-state is enabled, and it's opposite (disabled-state) is not
(define (channel-user-toggle-states! root channel username enabled-state disabled-state)
(channel-user-disable-state! root channel username disabled-state)
(channel-user-enable-state! root channel username enabled-state))
;; Enables a user's state (online/offline/etc), for all channels they are in.
(define (user-enable-state! root username state)
(map
(lambda (channel)
(channel-user-enable-state! root channel username state))
(directory (subpath root ".users" username "local"))))
;; Disables a user's state (online/offline/etc), for all channels they are in.
(define (user-disable-state! root username state)
(map
(lambda (channel)
(channel-user-disable-state! root channel username state))
(directory (subpath root ".users" username "local"))))
;; Ensures the enabled-state is enabled, and it's opposite (disabled-state) is not,
;; for all channels the given user is in.
(define (user-toggle-states! root username enabled-state disabled-state)
(map
(lambda (channel)
(channel-user-toggle-states! root channel username
enabled-state disabled-state))
(directory (subpath root ".users" username "local"))))
(define (write-string-to-file file value)
(call-with-output-file file
(lambda (out-port)
(write-string value #f out-port))))
(define (write-port-to-file path in-port)
(call-with-output-file path
(lambda (out-port)
(copy-port in-port out-port read-byte write-byte))))
(define (write-byte-list-to-file path byte-list)
(call-with-output-file path
(lambda (out-port)
(map (lambda (byte)
(write-char byte out-port))
byte-list))))
(define (read-file-to-string file)
(call-with-input-file file
(lambda (in-port)
(read-string #f in-port))))
(define (directory-file-set! directory key value #!optional (xattr-alist '()))
(let ([path (subpath directory key)])
;; Write the contents (value)
(cond [(string? value)
(write-string-to-file path value)]
[(input-port? value)
(write-port-to-file path value)]
[(list? value)
(write-byte-list-to-file path value)])
;; Write the xattrs (if applicable)
(map (lambda (xattr-cons)
(xattr:set-xattr path (symbol->string (car xattr-cons))
(cdr xattr-cons)))
xattr-alist)))
(define (directory-file-get directory key)
(read-file-to-string (subpath directory key)))
;; Get the contents of the given file as a string, including the
(define (directory-file-get* directory key)
(let ([path (subpath directory key)])
(cons (directory-file-get directory key)
(map (lambda (xattr)
(cons (string->symbol xattr)
(xattr:get-xattr path xattr)))
(xattr:list-xattrs path)))))
;; Sets a channel's metadata value; that is, sets the contents of the file ;; Sets a channel's metadata value; that is, sets the contents of the file
;; /$channel/.meta/$key to $value. ;; /$channel/.meta/$key to $value.
(define (channel-metadata-set! root channel key value #!optional (xattr-alist '())) (define (channel-metadata-set! root channel key value #!optional (xattr-alist '()))
(directory-file-set! (subpath root channel ".meta") (directory-file-set! (subpath root channel ".meta")
key value key value
xattr-alist)) xattr-alist))
;; Return a specific bit of metadata of a channel, as a string ;; Return a specific bit of metadata of a channel, as a string
@ -278,57 +80,156 @@
(directory (subpath root channel ".meta"))) (directory (subpath root channel ".meta")))
;; Lists all currently-joined channels.
(define (channels root) ;; ——————————————————————————————————————————————————
(directory root)) ;; User management
;; ——————————————————————————————————————————————————
;; Create a user's server-wide global-user directory.
;; Quite simple, compared to channel-user-add!
(define (user-add! root username)
(create-directory (subpath root ".users" username "local") #t))
;; Return a file path with the given parameters as elements of the path ;; Sets a file in the user's directory to given value.
;; E.g., "/etc/", "/systemd/user" "mom" => "/etc/systemd/user/mom" ;; Sets /.users/$user/$key to $value.
(define (subpath . children) (define (user-file-set! root username key value #!optional (xattr-alist '()))
(normalize-pathname (directory-file-set! (subpath root ".users" username)
(reduce-right (lambda (a b) key value xattr-alist))
(string-append a "/" b))
"" children)))
;; Given a directory and a filename, return a unique filename by appending ;; Returns the contents of a file in the user's global directory,
;; a number to the end of the name, as necessary. ;; /.users/$user/$key.
(define (directory-unique-file directory name #!optional (suffix "")) (define (user-file-get root username key)
(let* ([leaf (directory-file-get (subpath root ".users" username) key))
(string-append name suffix)]
[path
(subpath directory leaf)])
(if (file-exists? path)
(directory-unique-file
directory
leaf
(number->string (+ (or (string->number suffix) 0)
.1)))
leaf)))
;; Finds an appropriate (non-colliding, non-in-use) name for a message file, ;; Enables a user's state (online/offline/etc), for all channels they are in.
;; based on its date. (define (user-enable-state! root username state)
(define (message-file-leaf root channel date) (map
(directory-unique-file (subpath root channel) (lambda (channel)
(date->string date "[~m-~d] ~H:~M:~S"))) (channel-user-enable-state! root channel username state))
(directory (subpath root ".users" username "local"))))
;; Disables a user's state (online/offline/etc), for all channels they are in.
(define (user-disable-state! root username state)
(map
(lambda (channel)
(channel-user-disable-state! root channel username state))
(directory (subpath root ".users" username "local"))))
;; Ensures the enabled-state is enabled, and it's opposite (disabled-state) is not,
;; for all channels the given user is in.
(define (user-toggle-states! root username enabled-state disabled-state)
(map
(lambda (channel)
(channel-user-toggle-states! root channel username
enabled-state disabled-state))
(directory (subpath root ".users" username "local"))))
;; Return a list of all users of a channel of given state.
;; (Lists files in /$channel/.users/$state/).
(define (channel-users root channel #!optional (state "online"))
(directory (subpath root channel ".users" state)))
;; Add a user to a channel, creating their channel-user directory.
;; There are three types of channel users:
;; * Channel-only: We have no meaningful way of ever linking this user to a
;; server-wide identity.
;; (global? #f) (global-pairity #f)
;; * Serverwide-1: The user has a server-wide identity, and data like
;; nicknames/profile-pictures can NOT be changed on a per-channel
;; basis. channel-user is link to global-user.
;; (global #t) (global-pairity #t)
;; * Serverwide-2: The user has a server-wide identity, but their
;; nickname/profile-picture/etc can vary by the channel.
;; (global #t) (global-pairity #f)
(define (channel-user-add! root channel username
#!optional (global? #t) (global-pairity? #t) (global-name #f))
(let* ([g-name (if global-name global-name username)]
[user-path (subpath root channel ".users" "all" username)]
[g-user-path (subpath root ".users" g-name)])
(cond [(or (file-exists? user-path) (directory-exists? user-path))
#f]
;; If global, we gotta do some symlink dancing.
[global?
(user-add! root g-name)
(if global-pairity?
(create-symbolic-link (subpath "../../../.users" g-name) user-path)
(create-directory user-path #t))
(create-symbolic-link (subpath "../../../../.users" g-name)
(subpath user-path "global"))
(create-symbolic-link (subpath "../../../" channel ".users" "all" username)
(subpath g-user-path "local" channel))]
;; This is a channel-only user, don't bother with symlink fanciness.
[#t
(create-directory user-path #t)])))
;; Sets a file in the channel-user's directory to given value.
;; Sets /$channel/.users/all/$user/$key to $value.
(define (channel-user-file-set! root channel username key value #!optional (xattr-alist '()))
(directory-file-set! (subpath root channel ".users" "all" username)
key value xattr-alist))
;; Returns the contents of a file in the user's channel directory,
;; /$channel/.users/all/$user/$key.
(define (channel-user-file-get root channel username key)
(directory-file-get (subpath root channel ".users" "all" username) key))
;; Disables a channel-user's online/offline/etc state.
;; That is, removes a symlink from a /$channel/.users/* directory.
(define (channel-user-disable-state! root channel username state)
(let ([state-link (subpath root channel ".users" state username)])
(if (or (file-exists? state-link)
(symbolic-link? state-link))
(delete-file state-link))))
;; Enables a channel-user's state (online/offline/etc).
;; That is, makes a symlink to a /$channel/.users/* directory.
(define (channel-user-enable-state! root channel username state)
(let* ([state-path
(create-directory (subpath root channel ".users" state) #t)]
[user-path (subpath ".." "all" username)]
[state-link (subpath state-path username)])
(if (not (or (file-exists? state-link)
(symbolic-link? state-link)))
(create-symbolic-link user-path
state-link))))
;; Ensures the enabled-state is enabled, and it's opposite (disabled-state) is not
(define (channel-user-toggle-states! root channel username enabled-state disabled-state)
(channel-user-disable-state! root channel username disabled-state)
(channel-user-enable-state! root channel username enabled-state))
;; ——————————————————————————————————————————————————
;; Message management
;; ——————————————————————————————————————————————————
;; Create a message file for the given channel, contents, sender, etc. ;; Create a message file for the given channel, contents, sender, etc.
(define (channel-message-add! root channel contents (define (channel-message-add! root channel contents
#!optional (sender #f) (date (current-date)) #!optional (sender #f) (date (current-date))
(additional-xattrs '())) (additional-xattrs '()))
(let* ([attrs-sans-sender (append (let* ([attrs-sans-sender (append
`((user.chat.date . ,(date->string date "~1T~2")) `((user.chat.date . ,(date->string date "~1T~2"))
(user.chat.channel . ,channel)) (user.chat.channel . ,channel))
additional-xattrs)] additional-xattrs)]
[attrs (if sender [attrs (if sender
(append attrs-sans-sender `((user.chat.sender . ,sender))) (append attrs-sans-sender `((user.chat.sender . ,sender)))
attrs-sans-sender)]) attrs-sans-sender)])
(directory-file-set! (subpath root channel) (directory-file-set! (subpath root channel)
(message-file-leaf root channel date) (channel-message-file-leaf root channel date)
contents attrs))) contents attrs)))
;; List all messages of the given channel. ;; List all messages of the given channel.
@ -340,9 +241,9 @@
(define (channel-messages-by-xattr root channel xattr value) (define (channel-messages-by-xattr root channel xattr value)
(filter (filter
(lambda (message-leaf) (lambda (message-leaf)
(string=? (xattr:get-xattr (subpath root channel message-leaf) (string=? (xattr:get-xattr (subpath root channel message-leaf)
xattr) xattr)
value)) value))
(channel-messages root channel))) (channel-messages root channel)))
@ -354,114 +255,126 @@
;; List all messages sent at exactly the given date. ;; List all messages sent at exactly the given date.
(define (channel-messages-by-date root channel date) (define (channel-messages-by-date root channel date)
(channel-messages-by-xattr root channel "user.chat.date" (channel-messages-by-xattr root channel "user.chat.date"
(date->string date "~1T~2"))) (date->string date "~1T~2")))
;; List all messages sent around the given date, ±deviation seconds. ;; List all messages sent around the given date, ±deviation seconds.
(define (channel-messages-by-date* root channel date deviation) (define (channel-messages-by-date* root channel date deviation)
(channel-messages-by-date-range root channel (channel-messages-by-date-range root channel
(seconds->date (- (date->seconds date) deviation)) (seconds->date (- (date->seconds date) deviation))
(seconds->date (+ (date->seconds date) deviation)))) (seconds->date (+ (date->seconds date) deviation))))
;; List all messages sent within the given date range. ;; List all messages sent within the given date range.
(define (channel-messages-by-date-range root channel min-date max-date) (define (channel-messages-by-date-range root channel min-date max-date)
(filter (filter
(lambda (message-leaf) (lambda (message-leaf)
(let* ([message-path (subpath root channel message-leaf)] (let* ([message-path (subpath root channel message-leaf)]
[message-date (string->date (xattr:get-xattr message-path "user.chat.date") [message-date (string->date (xattr:get-xattr message-path "user.chat.date")
"~Y-~m-~dT~H:~M:~S~z")]) "~Y-~m-~dT~H:~M:~S~z")])
(and (date<=? min-date message-date) (and (date<=? min-date message-date)
(date<=? message-date max-date)))) (date<=? message-date max-date))))
(channel-messages root channel))) (channel-messages root channel)))
;; Finds an appropriate (non-colliding, non-in-use) name for a message file,
;; based on its date.
(define (channel-message-file-leaf root channel date)
(directory-unique-file (subpath root channel)
(date->string date "[~m-~d] ~H:~M:~S")))
;; ——————————————————————————————————————————————————
;; Skeleton of a daemon
;; ——————————————————————————————————————————————————
;; Initialization for the input loop ;; Initialization for the input loop
(define (input-loop-init root-dir callbacks-alist) (define (input-loop-init root-dir callbacks-alist)
(let ([join-callback (alist-ref 'join-channel callbacks-alist)]) (let ([join-callback (alist-ref 'join-channel callbacks-alist)])
(inotify:init!) (inotify:init!)
;; Start watching the chatdir (for new channel joins, etc) ;; Start watching the chatdir (for new channel joins, etc)
(inotify:add-watch! (inotify:add-watch!
root-dir '(onlydir moved-to moved-from delete delete-self create)) root-dir '(onlydir moved-to moved-from delete delete-self create))
;; Auto-join channels with all pre-existing channel directories ;; Auto-join channels with all pre-existing channel directories
(map (lambda (path) (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)]) [join-callback (alist-ref 'join-channel callbacks-alist)])
(if join-callback (if join-callback
(apply join-callback (list channel-dirname))) (apply join-callback (list channel-dirname)))
(inotify:add-watch! in-path '(moved-to close-write)) (inotify:add-watch! in-path '(moved-to close-write))
(print "Joined and watching: " in-path))) (print "Joined and watching: " in-path)))
(filter directory-exists? (directory-rel irc-dir))))) (filter directory-exists? (directory-rel irc-dir)))))
;; Handles all inotify-watched file events from the top-level IRC-directory. ;; Handles all inotify-watched file events from the top-level IRC-directory.
;; Mainly, checking for newly-joined or left channels. ;; Mainly, checking for newly-joined or left channels.
(define (handle-main-dir-event callbacks-alist event) (define (handle-main-dir-event callbacks-alist event)
(let ([flags (inotify:event-flags event)] (let ([flags (inotify:event-flags event)]
[leave-callback (alist-ref 'leave-channel callbacks-alist)] [leave-callback (alist-ref 'leave-channel callbacks-alist)]
[join-callback (alist-ref 'join-channel callbacks-alist)]) [join-callback (alist-ref 'join-channel callbacks-alist)])
(cond (cond
;; If a channel dir's been moved or removed, stop watching (ofc) ;; If a channel dir's been moved or removed, stop watching (ofc)
;; … Also quit that room! Heck them! ;; … Also quit that room! Heck them!
[(or (member 'moved-from flags) [(or (member 'moved-from flags)
(member 'delete flags) (member 'delete flags)
(member 'delete-self flags)) (member 'delete-self flags))
(let* ([channel (inotify:event-name event)] (let* ([channel (inotify:event-name event)]
[channel-inpath [channel-inpath
(string-append (inotify:wd->path (string-append (inotify:wd->path
(inotify:event-wd event)) (inotify:event-wd event))
channel "/.in")] channel "/.in")]
[channel-wd (path->wd channel-inpath)]) [channel-wd (path->wd channel-inpath)])
(print "Remove watch for " channel-inpath "…") (print "Remove watch for " channel-inpath "…")
(if (and channel-wd (member channel-wd (wd-list))) (if (and channel-wd (member channel-wd (wd-list)))
(attempt-remove-watch! channel-wd)) (attempt-remove-watch! channel-wd))
(if leave-callback (if leave-callback
(apply leave-callback (list channel))))] (apply leave-callback (list channel))))]
;; If a dir's been created for a channel, maybe-join, then watch input! ;; If a dir's been created for a channel, maybe-join, then watch input!
[(or (member 'create flags) [(or (member 'create flags)
(member 'moved-to flags)) (member 'moved-to flags))
(let* ([channel (inotify:event->pathname event)]) (let* ([channel (inotify:event->pathname event)])
(print "Attempting to join channel " dirname "…") (print "Attempting to join channel " dirname "…")
(if join-callback (if join-callback
(apply join-callback (list path))))]))) (apply join-callback (list path))))])))
(define (channel-joined root-dir channel) (define (channel-joined root-dir channel)
(let* ([in-path (normalize-pathname (string-append root-dir "/" channel "/.in"))]) (let* ([in-path (normalize-pathname (string-append root-dir "/" channel "/.in"))])
(inotify:add-watch! in-path '(moved-to close-write)) (inotify:add-watch! in-path '(moved-to close-write))
(print "Began watching input " in-path "."))) (print "Began watching input " in-path ".")))
;; Handles an inotify event that pertains to a channel's .in/ directory ;; 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 callbacks-alist event)
(let* ([event-dir (pathname-directory (inotify:event->pathname event))] (let* ([event-dir (pathname-directory (inotify:event->pathname event))]
[dirname (pathname-file event-dir)] [dirname (pathname-file event-dir)]
[channel (pathname-file (pathname-directory event-dir))] [channel (pathname-file (pathname-directory event-dir))]
[send-message-callback (alist-ref 'send-message callbacks-alist)]) [send-message-callback (alist-ref 'send-message callbacks-alist)])
(cond (cond
;; If input is given to an `.in` dir… well, send that darn message! ;; If input is given to an `.in` dir… well, send that darn message!
;; What're you wating for? ;; What're you wating for?
[(and (string=? dirname ".in") [(and (string=? dirname ".in")
send-message-callback) send-message-callback)
(map (lambda (message) (map (lambda (message)
(apply send-message (list channel message))) (apply send-message (list channel message)))
(with-input-from-file (inotify:event->pathname event) (with-input-from-file (inotify:event->pathname event)
read-lines)) read-lines))
(delete-file* (inotify:event->pathname event))]))) (delete-file* (inotify:event->pathname event))])))
;; Handle a single inotify file event, as part of the input loop ;; Handle a single inotify file event, as part of the input loop
(define (handle-file-event root-dir callbacks-alist event) (define (handle-file-event root-dir callbacks-alist event)
(if (not (member 'ignored (event-flags event))) (if (not (member 'ignored (event-flags event)))
(let* ([flags (inotify:event-flags event)] (let* ([flags (inotify:event-flags event)]
[wd-path (inotify:wd->path (inotify:event-wd event))] [wd-path (inotify:wd->path (inotify:event-wd event))]
[main-dir? (string=? wd-path root-dir)]) [main-dir? (string=? wd-path root-dir)])
(if main-dir? (if main-dir?
(handle-main-dir-event root-dir callbacks-alist event) (handle-main-dir-event root-dir callbacks-alist event)
(handle-channel-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) ;; The FS-backed input loop, to be run in a seperate thread (so as to not block)
@ -471,12 +384,141 @@
;; (new-message channel text) ;; (new-message channel text)
(define (input-loop root-dir callbacks-alist) (define (input-loop root-dir callbacks-alist)
(map (lambda (event) (map (lambda (event)
(handle-file-event root-dir callbacks-alist event)) (handle-file-event root-dir callbacks-alist event))
(inotify:next-events!)) (inotify:next-events!))
(input-loop root-dir callbacks-alist)) (input-loop root-dir callbacks-alist))
;; ——————————————————————————————————————————————————
;; inotify 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)))
;; Repeat after me: ;; Repeat after me:
;; 🎵 Symbolic links cannot have extended attributes, and that is a war-crime. 🎶 ;; 🎵 Symbolic links cannot have extended attributes, and that is a war-crime. 🎶
;; 🎵 Directories cannot have extended attributes, and that is a war-crime. 🎶 ;; 🎵 Directories cannot have extended attributes, and that is a war-crime. 🎶
;; ——————————————————————————————————————————————————
;; Directory as key/value store
;; ——————————————————————————————————————————————————
;; Set the contents of a directory's file `key` to `value`, setting any
;; extended attributes passed as xattr-alist.
(define (directory-file-set! directory key value #!optional (xattr-alist '()))
(let ([path (subpath directory key)])
;; Write the contents (value)
(cond [(string? value)
(write-string-to-file path value)]
[(input-port? value)
(write-port-to-file path value)]
[(list? value)
(write-byte-list-to-file path value)])
;; Write the xattrs (if applicable)
(map (lambda (xattr-cons)
(xattr:set-xattr path (symbol->string (car xattr-cons))
(cdr xattr-cons)))
xattr-alist)))
;; Get the contents of the given file as astring.
(define (directory-file-get directory key)
(read-file-to-string (subpath directory key)))
;; Get the contents of the given file as a string, including the all
;; extended attributes as an alist.
;; (contents (xattr . value) (xattr .value) …)
(define (directory-file-get* directory key)
(let ([path (subpath directory key)])
(cons (directory-file-get directory key)
(map (lambda (xattr)
(cons (string->symbol xattr)
(xattr:get-xattr path xattr)))
(xattr:list-xattrs path)))))
;; Given a directory and a filename, return a unique filename by appending
;; a number to the end of the name, as necessary.
(define (directory-unique-file directory name #!optional (suffix ""))
(let* ([leaf
(string-append name suffix)]
[path
(subpath directory leaf)])
(if (file-exists? path)
(directory-unique-file
directory
leaf
(number->string (+ (or (string->number suffix) 0)
.1)))
leaf)))
;; ——————————————————————————————————————————————————
;; Misc. utility
;; ——————————————————————————————————————————————————
;; 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)))
;; 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)
(call-with-output-file file
(lambda (out-port)
(write-string value #f out-port))))
;; Again, self-evident. Right?
(define (write-port-to-file path in-port)
(call-with-output-file path
(lambda (out-port)
(copy-port in-port out-port read-byte write-byte))))
;; Still obvious, no?
(define (write-byte-list-to-file path byte-list)
(call-with-output-file path
(lambda (out-port)
(map (lambda (byte)
(write-char byte out-port))
byte-list))))
;; And we're still on the same page, I'd hope?
(define (read-file-to-string file)
(call-with-input-file file
(lambda (in-port)
(read-string #f in-port))))

172
tests/tests.scm
View File

@ -8,7 +8,7 @@
;; Appends six random chars ;; Appends six random chars
(define (randomize-string str) (define (randomize-string str)
(string-append str " " (string-append str " "
(random-bytes "ABC123" 6))) (random-bytes "ABC123" 6)))
@ -24,8 +24,8 @@
;; General-pupose functions ;; General-pupose functions
;; —————————————————————————————————————————————————— ;; ——————————————————————————————————————————————————
(check (subpath "/etc" "systemd/" "user" "momma") (check (subpath "/etc" "systemd/" "user" "momma")
=> =>
"/etc/systemd/user/momma") "/etc/systemd/user/momma")
@ -37,29 +37,29 @@
(define *room-meta-path* "test chatdir/dining room/.meta") (define *room-meta-path* "test chatdir/dining room/.meta")
(define *room-topic* "Here we can discuss everything relating to food.\nCooking, dining, etc!\nThe only limit is your palette!\n") (define *room-topic* "Here we can discuss everything relating to food.\nCooking, dining, etc!\nThe only limit is your palette!\n")
(define *room-topic-xattrs* (list (cons 'user.chat.user "admin-tan") (define *room-topic-xattrs* (list (cons 'user.chat.user "admin-tan")
(cons 'user.chat.date (number->string (pseudo-random-integer 9999))))) (cons 'user.chat.date (number->string (pseudo-random-integer 9999)))))
(directory-file-set! *room-meta-path* "topic" *room-topic* *room-topic-xattrs*) (directory-file-set! *room-meta-path* "topic" *room-topic* *room-topic-xattrs*)
(check (directory-file-get *room-meta-path* "topic") (check (directory-file-get *room-meta-path* "topic")
=> =>
*room-topic*) *room-topic*)
(check (directory-file-get* *room-meta-path* "topic") (check (directory-file-get* *room-meta-path* "topic")
=> =>
(cons *room-topic* *room-topic-xattrs*)) (cons *room-topic* *room-topic-xattrs*))
(define *room-topic-2* (randomize-string *room-topic*)) (define *room-topic-2* (randomize-string *room-topic*))
(define *room-topic-xattrs-2* (alist-update 'user.chat.user "admin-mom" *room-topic-xattrs*)) (define *room-topic-xattrs-2* (alist-update 'user.chat.user "admin-mom" *room-topic-xattrs*))
(channel-metadata-set! *dir* *room* "topic" (channel-metadata-set! *dir* *room* "topic"
*room-topic-2* *room-topic-2*
*room-topic-xattrs-2*) *room-topic-xattrs-2*)
(check (channel-metadata-get *dir* *room* "topic") (check (channel-metadata-get *dir* *room* "topic")
=> =>
*room-topic-2*) *room-topic-2*)
(check (channel-metadata-get* *dir* *room* "topic") (check (channel-metadata-get* *dir* *room* "topic")
=> =>
(cons *room-topic-2* *room-topic-xattrs-2*)) (cons *room-topic-2* *room-topic-xattrs-2*))
@ -93,49 +93,49 @@
(check (directory-file-get* (subpath *dir* *room*) *msg-name*) (check (directory-file-get* (subpath *dir* *room*) *msg-name*)
=> =>
(list *msg-text* (list *msg-text*
(cons 'user.chat.date (date->string *msg-date* "~1T~2")) (cons 'user.chat.date (date->string *msg-date* "~1T~2"))
*msg-xattr* *msg-xattr*
(cons 'user.chat.sender *msg-sender*) (cons 'user.chat.sender *msg-sender*)
(cons 'user.chat.channel *room*))) (cons 'user.chat.channel *room*)))
(check (directory-file-get* (subpath *dir* *room*) *msg-name-2*) (check (directory-file-get* (subpath *dir* *room*) *msg-name-2*)
=> =>
(list *msg-text-2* (list *msg-text-2*
(cons 'user.chat.date (date->string *msg-date-2* "~1T~2")) (cons 'user.chat.date (date->string *msg-date-2* "~1T~2"))
(cons 'user.chat.sender *msg-sender-2*) (cons 'user.chat.sender *msg-sender-2*)
(cons 'user.chat.channel *room*))) (cons 'user.chat.channel *room*)))
(check (list (find (lambda (a) (string=? *msg-name* a)) (check (list (find (lambda (a) (string=? *msg-name* a))
(channel-messages *dir* *room*)) (channel-messages *dir* *room*))
(find (lambda (a) (string=? *msg-name-2* a)) (find (lambda (a) (string=? *msg-name-2* a))
(channel-messages *dir* *room*))) (channel-messages *dir* *room*)))
=> =>
(list *msg-name* *msg-name-2*)) (list *msg-name* *msg-name-2*))
(check (list (<= 2 (length (channel-messages-by-sender *dir* *room* "maya"))) (check (list (<= 2 (length (channel-messages-by-sender *dir* *room* "maya")))
(find (lambda (a) (string=? *msg-name-3* a)) (find (lambda (a) (string=? *msg-name-3* a))
(channel-messages-by-sender *dir* *room* "maya"))) (channel-messages-by-sender *dir* *room* "maya")))
=> =>
(list #t *msg-name-3*)) (list #t *msg-name-3*))
(check (find (lambda (a) (string=? *msg-name-3* a)) (check (find (lambda (a) (string=? *msg-name-3* a))
(channel-messages-by-date *dir* *room* *msg-date-3*)) (channel-messages-by-date *dir* *room* *msg-date-3*))
=> =>
*msg-name-3*) *msg-name-3*)
(check (let ([messages (check (let ([messages
(channel-messages-by-date-range *dir* *room* *msg-date-3* *msg-date-4*)]) (channel-messages-by-date-range *dir* *room* *msg-date-3* *msg-date-4*)])
(list (find (lambda (a) (string=? *msg-name-3* a)) messages) (list (find (lambda (a) (string=? *msg-name-3* a)) messages)
(find (lambda (a) (string=? *msg-name-4* a)) messages))) (find (lambda (a) (string=? *msg-name-4* a)) messages)))
=> =>
(list *msg-name-3* *msg-name-4*)) (list *msg-name-3* *msg-name-4*))
@ -147,26 +147,26 @@
(define *new-room-users* (subpath *new-room-path* ".users")) (define *new-room-users* (subpath *new-room-path* ".users"))
(define *new-room-all* (subpath *new-room-users* "all")) (define *new-room-all* (subpath *new-room-users* "all"))
(if (directory-exists? *new-room-path*) (if (directory-exists? *new-room-path*)
(delete-directory (subpath *dir* *new-room*) #t)) (delete-directory (subpath *dir* *new-room*) #t))
(channel-add! *dir* *new-room*) (channel-add! *dir* *new-room*)
(check (and (directory-exists? *new-room-path*) (check (and (directory-exists? *new-room-path*)
(directory-exists? *new-room-all*)) (directory-exists? *new-room-all*))
=> =>
*new-room-all*) *new-room-all*)
(define *new-room-online* (subpath *new-room-path* ".users" "online")) (define *new-room-online* (subpath *new-room-path* ".users" "online"))
(create-symbolic-link "./" (subpath *new-room-online* "birdo")) (create-symbolic-link "./" (subpath *new-room-online* "birdo"))
(create-symbolic-link "./" (subpath *new-room-online* "mondo")) (create-symbolic-link "./" (subpath *new-room-online* "mondo"))
(check (sort (directory *new-room-online*) string<) (check (sort (directory *new-room-online*) string<)
=> =>
'("birdo" "mondo")) '("birdo" "mondo"))
(channel-cleanup! *dir* *new-room*) (channel-cleanup! *dir* *new-room*)
(check (directory *new-room-online*) (check (directory *new-room-online*)
=> =>
'()) '())
@ -175,24 +175,24 @@
;; —————————————————————————————————————————————————— ;; ——————————————————————————————————————————————————
(define *users-dir* (subpath *dir* ".users")) (define *users-dir* (subpath *dir* ".users"))
(if (directory-exists? *users-dir*) (if (directory-exists? *users-dir*)
(delete-directory *users-dir* #t)) (delete-directory *users-dir* #t))
(if (directory-exists? *new-room-users*) (if (directory-exists? *new-room-users*)
(delete-directory *new-room-users* #t)) (delete-directory *new-room-users* #t))
;; Create a global user-directory. ;; Create a global user-directory.
(user-add! *dir* "birdo") (user-add! *dir* "birdo")
(check (string? (directory-exists? (subpath *dir* ".users" "birdo"))) (check (string? (directory-exists? (subpath *dir* ".users" "birdo")))
=> =>
#t) #t)
;; Check a room-only account; it has no global directory. ;; Check a room-only account; it has no global directory.
(channel-user-add! *dir* *new-room* "mondo" #f #f) (channel-user-add! *dir* *new-room* "mondo" #f #f)
(check (and (not (directory-exists? (subpath *users-dir* "mondo"))) (check (and (not (directory-exists? (subpath *users-dir* "mondo")))
(not (symbolic-link? (subpath *new-room-all* "mondo"))) (not (symbolic-link? (subpath *new-room-all* "mondo")))
(string? (directory-exists? (subpath *new-room-all* "mondo")))) (string? (directory-exists? (subpath *new-room-all* "mondo"))))
=> =>
#t) #t)
;; Check a room user-directory, that matches up one-to-one with a ;; Check a room user-directory, that matches up one-to-one with a
@ -202,17 +202,17 @@
(channel-user-add! *dir* *new-room* "birdo" #t #t) (channel-user-add! *dir* *new-room* "birdo" #t #t)
(channel-user-file-set! *dir* *new-room* "birdo" "nick" "rose") (channel-user-file-set! *dir* *new-room* "birdo" "nick" "rose")
(check (read-symbolic-link (subpath *new-room-all* "birdo")) (check (read-symbolic-link (subpath *new-room-all* "birdo"))
=> =>
"../../../.users/birdo") "../../../.users/birdo")
(check (read-symbolic-link (subpath *new-room-all* "birdo" "global")) (check (read-symbolic-link (subpath *new-room-all* "birdo" "global"))
=> =>
"../../../../.users/birdo") "../../../../.users/birdo")
(check (read-symbolic-link (subpath *users-dir* "birdo" "local" *new-room*)) (check (read-symbolic-link (subpath *users-dir* "birdo" "local" *new-room*))
=> =>
(subpath "../../../" *new-room* ".users" "all" "birdo")) (subpath "../../../" *new-room* ".users" "all" "birdo"))
(check (user-file-get *dir* "birdo" "nick") (check (user-file-get *dir* "birdo" "nick")
=> =>
"rose") "rose")
;; Check a room user-directory with corresponding global user-directory, ;; Check a room user-directory with corresponding global user-directory,
@ -222,42 +222,42 @@
(channel-user-file-set! *dir* *new-room* "mawa" "nick" "mawarth") (channel-user-file-set! *dir* *new-room* "mawa" "nick" "mawarth")
(user-file-set! *dir* "mawa" "nick" "magma") (user-file-set! *dir* "mawa" "nick" "magma")
(check (and (not (symbolic-link? (subpath *new-room-all* "mawa"))) (check (and (not (symbolic-link? (subpath *new-room-all* "mawa")))
(symbolic-link? (subpath *new-room-all* "mawa" "global")) (symbolic-link? (subpath *new-room-all* "mawa" "global"))
(directory-exists? (subpath *new-room-all* "mawa")) (directory-exists? (subpath *new-room-all* "mawa"))
(string? (directory-exists? (subpath *users-dir* "mawa"))) (string? (directory-exists? (subpath *users-dir* "mawa")))
) )
=> =>
#t) #t)
(check (user-file-get *dir* "mawa" "nick") (check (user-file-get *dir* "mawa" "nick")
=> =>
"magma") "magma")
(check (channel-user-file-get *dir* *new-room* "mawa" "nick") (check (channel-user-file-get *dir* *new-room* "mawa" "nick")
=> =>
"mawarth") "mawarth")
;; Make sure user-states (online/offline) work! ;; Make sure user-states (online/offline) work!
(channel-user-enable-state! *dir* *new-room* "mawa" "online") (channel-user-enable-state! *dir* *new-room* "mawa" "online")
(check (read-symbolic-link (subpath *new-room-users* "online" "mawa")) (check (read-symbolic-link (subpath *new-room-users* "online" "mawa"))
=> =>
"../all/mawa") "../all/mawa")
(channel-user-toggle-states! *dir* *new-room* "mawa" "offline" "online") (channel-user-toggle-states! *dir* *new-room* "mawa" "offline" "online")
(check (list (symbolic-link? (subpath *new-room-users* "online" "mawa")) (check (list (symbolic-link? (subpath *new-room-users* "online" "mawa"))
(read-symbolic-link (subpath *new-room-users* "offline" "mawa"))) (read-symbolic-link (subpath *new-room-users* "offline" "mawa")))
=> =>
'(#f "../all/mawa")) '(#f "../all/mawa"))
(channel-user-disable-state! *dir* *new-room* "mawa" "offline") (channel-user-disable-state! *dir* *new-room* "mawa" "offline")
(check (symbolic-link? (subpath *new-room-users* "offline" "mawa")) (check (symbolic-link? (subpath *new-room-users* "offline" "mawa"))
=> =>
#f) #f)
(user-enable-state! *dir* "mawa" "online") (user-enable-state! *dir* "mawa" "online")
(check (list (symbolic-link? (subpath *new-room-users* "online" "mawa")) (check (list (symbolic-link? (subpath *new-room-users* "online" "mawa"))
(symbolic-link? (subpath *dir* *room* ".users" "online" "mawa"))) (symbolic-link? (subpath *dir* *room* ".users" "online" "mawa")))
=> =>
'(#t #t)) '(#t #t))
;; —————————————————————————————————————————————————— ;; ——————————————————————————————————————————————————