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

436
chatdir.scm
View File

@ -22,29 +22,23 @@
(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))))
;; Lists all currently-joined channels.
(define (channels root)
(directory root))
;; Returns an inotify watch-descriptor according the given path ;; Creates a channel's file hierarchy; safe to run, even if the channel
(define (path->wd path) ;; has already been created.
(car (define (channel-add! root channel)
(filter (lambda (wd) (let* ([path (subpath root channel)])
(string=? (normalize-pathname (inotify:wd->path wd)) (create-directory (subpath path ".in") #t)
(normalize-pathname path))) (create-directory (subpath path ".users" "online") #t)
(inotify:wd-list)))) (create-directory (subpath path ".users" "offline") #t)
(create-directory (subpath path ".users" "all") #t)
(channel-cleanup! root channel)))
;; 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. ;; Tidies up a channel directory: Removes `online` and `offline` user links.
@ -62,32 +56,97 @@
(directory users-dir)))) (directory users-dir))))
;; Creates a channel's file hierarchy; safe to run, even if the channel ;; Sets a channel's metadata value; that is, sets the contents of the file
;; has already been created. ;; /$channel/.meta/$key to $value.
(define (channel-add! root channel) (define (channel-metadata-set! root channel key value #!optional (xattr-alist '()))
(let* ([path (subpath root channel)]) (directory-file-set! (subpath root channel ".meta")
(create-directory (subpath path ".in") #t) key value
(create-directory (subpath path ".users" "online") #t) xattr-alist))
(create-directory (subpath path ".users" "offline") #t)
(create-directory (subpath path ".users" "all") #t)
(channel-cleanup! root channel)))
;; Return a specific bit of metadata of a channel, as a string
(define (channel-metadata-get root channel key)
(directory-file-get (subpath root channel ".meta") key))
;; Return a cons-list of a channel's metadata, with the file-content followed by
;; an alist of the extended attributes
(define (channel-metadata-get* root channel key)
(directory-file-get* (subpath root channel ".meta") key))
;; Return a list of all metadata key (files in /$channel/.meta/).
(define (channel-metadata root channel)
(directory (subpath root channel ".meta")))
;; ——————————————————————————————————————————————————
;; User management
;; ——————————————————————————————————————————————————
;; Create a user's server-wide global-user directory. ;; Create a user's server-wide global-user directory.
;; Quite simple, compared to channel-user-add! ;; Quite simple, compared to channel-user-add!
(define (user-add! root username) (define (user-add! root username)
(create-directory (subpath root ".users" username "local") #t)) (create-directory (subpath root ".users" username "local") #t))
;; 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))
;; 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"))))
;; 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. ;; Add a user to a channel, creating their channel-user directory.
;; There are three types of channel users: ;; There are three types of channel users:
;; * Channel-only: We have no meaningful way of ever linking this user to a server-wide identity. ;; * Channel-only: We have no meaningful way of ever linking this user to a
;; server-wide identity.
;; (global? #f) (global-pairity #f) ;; (global? #f) (global-pairity #f)
;; * Serverwide-1: The user has a server-wide identity, and data like nicknames/profile-pictures ;; * Serverwide-1: The user has a server-wide identity, and data like
;; can NOT be changed on a per-channel basis. channel-user is link to global-user. ;; nicknames/profile-pictures can NOT be changed on a per-channel
;; basis. channel-user is link to global-user.
;; (global #t) (global-pairity #t) ;; (global #t) (global-pairity #t)
;; * Serverwide-2: The user has a server-wide identity, but their nickname/profile-picture/etc ;; * Serverwide-2: The user has a server-wide identity, but their
;; can vary by the channel. ;; nickname/profile-picture/etc can vary by the channel.
;; (global #t) (global-pairity #f) ;; (global #t) (global-pairity #f)
(define (channel-user-add! root channel username (define (channel-user-add! root channel username
#!optional (global? #t) (global-pairity? #t) (global-name #f)) #!optional (global? #t) (global-pairity? #t) (global-name #f))
@ -111,25 +170,6 @@
(create-directory user-path #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 a file in the channel-user's directory to given value.
;; Sets /$channel/.users/all/$user/$key to $value. ;; Sets /$channel/.users/all/$user/$key to $value.
(define (channel-user-file-set! root channel username key value #!optional (xattr-alist '())) (define (channel-user-file-set! root channel username key value #!optional (xattr-alist '()))
@ -171,149 +211,10 @@
(channel-user-enable-state! root channel username enabled-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
;; /$channel/.meta/$key to $value.
(define (channel-metadata-set! root channel key value #!optional (xattr-alist '()))
(directory-file-set! (subpath root channel ".meta")
key value
xattr-alist))
;; Return a specific bit of metadata of a channel, as a string
(define (channel-metadata-get root channel key)
(directory-file-get (subpath root channel ".meta") key))
;; Return a cons-list of a channel's metadata, with the file-content followed by
;; an alist of the extended attributes
(define (channel-metadata-get* root channel key)
(directory-file-get* (subpath root channel ".meta") key))
;; Return a list of all metadata key (files in /$channel/.meta/).
(define (channel-metadata root channel)
(directory (subpath root channel ".meta")))
;; Lists all currently-joined channels.
(define (channels root)
(directory root))
;; 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)))
;; 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)))
;; Finds an appropriate (non-colliding, non-in-use) name for a message file,
;; based on its date.
(define (message-file-leaf root channel date)
(directory-unique-file (subpath root channel)
(date->string date "[~m-~d] ~H:~M:~S")))
;; ——————————————————————————————————————————————————
;; 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
@ -327,7 +228,7 @@
(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)))
@ -376,6 +277,18 @@
(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)])
@ -477,6 +390,135 @@
(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))))