Reorganize source file, spaces > tabs
This commit is contained in:
parent
f4b47d3756
commit
2ef1c47b83
436
chatdir.scm
436
chatdir.scm
|
|
@ -22,29 +22,23 @@
|
|||
(prefix xattr xattr:))
|
||||
|
||||
|
||||
;; 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))))
|
||||
;; ——————————————————————————————————————————————————
|
||||
;; Channel management
|
||||
;; ——————————————————————————————————————————————————
|
||||
|
||||
;; Lists all currently-joined channels.
|
||||
(define (channels root)
|
||||
(directory root))
|
||||
|
||||
;; 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)))
|
||||
;; Creates a channel's file hierarchy; safe to run, even if the channel
|
||||
;; has already been created.
|
||||
(define (channel-add! root channel)
|
||||
(let* ([path (subpath root channel)])
|
||||
(create-directory (subpath path ".in") #t)
|
||||
(create-directory (subpath path ".users" "online") #t)
|
||||
(create-directory (subpath path ".users" "offline") #t)
|
||||
(create-directory (subpath path ".users" "all") #t)
|
||||
(channel-cleanup! root channel)))
|
||||
|
||||
|
||||
;; Tidies up a channel directory: Removes `online` and `offline` user links.
|
||||
|
|
@ -62,32 +56,97 @@
|
|||
(directory users-dir))))
|
||||
|
||||
|
||||
;; Creates a channel's file hierarchy; safe to run, even if the channel
|
||||
;; has already been created.
|
||||
(define (channel-add! root channel)
|
||||
(let* ([path (subpath root channel)])
|
||||
(create-directory (subpath path ".in") #t)
|
||||
(create-directory (subpath path ".users" "online") #t)
|
||||
(create-directory (subpath path ".users" "offline") #t)
|
||||
(create-directory (subpath path ".users" "all") #t)
|
||||
(channel-cleanup! root channel)))
|
||||
;; 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")))
|
||||
|
||||
|
||||
|
||||
;; ——————————————————————————————————————————————————
|
||||
;; 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))
|
||||
|
||||
|
||||
;; 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.
|
||||
;; 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)
|
||||
;; * 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.
|
||||
;; * 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.
|
||||
;; * 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))
|
||||
|
|
@ -111,25 +170,6 @@
|
|||
(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 '()))
|
||||
|
|
@ -171,149 +211,10 @@
|
|||
(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.
|
||||
(define (channel-message-add! root channel contents
|
||||
|
|
@ -327,7 +228,7 @@
|
|||
(append attrs-sans-sender `((user.chat.sender . ,sender)))
|
||||
attrs-sans-sender)])
|
||||
(directory-file-set! (subpath root channel)
|
||||
(message-file-leaf root channel date)
|
||||
(channel-message-file-leaf root channel date)
|
||||
contents attrs)))
|
||||
|
||||
|
||||
|
|
@ -376,6 +277,18 @@
|
|||
(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
|
||||
(define (input-loop-init root-dir callbacks-alist)
|
||||
(let ([join-callback (alist-ref 'join-channel callbacks-alist)])
|
||||
|
|
@ -477,6 +390,135 @@
|
|||
(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:
|
||||
;; 🎵 Symbolic links 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))))
|
||||
|
||||
|
|
|
|||
Reference in New Issue