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

Add user-file-set!/get and channel-user-file-set!/get

This commit is contained in:
Jaidyn Ann 2023-05-20 07:11:13 -05:00
parent d545c29263
commit 4ad18999a9
2 changed files with 60 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
chatdir.scm
View File

@ -101,17 +101,18 @@
(channel-cleanup! root channel))) (channel-cleanup! root channel)))
;; Create a global user's directory. ;; Create a user's server-wide global-user directory.
;; Quite simple, compared to channel-user-add!
(define (user-add! root username) (define (user-add! root username)
(create-directory (subpath root ".users" username) #t)) (create-directory (subpath root ".users" username) #t))
;; Add a user to a channel, creating their channel's 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 nicknames/profile-pictures
;; can NOT be changed on a per-channel basis. ;; 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 nickname/profile-picture/etc
;; can vary by the channel. ;; can vary by the channel.
@ -122,18 +123,50 @@
[user-path (subpath root channel ".users" "all" username)] [user-path (subpath root channel ".users" "all" username)]
[g-user-path (subpath root ".users" g-name)]) [g-user-path (subpath root ".users" g-name)])
(if (not (or (file-exists? user-path) (directory-exists? user-path))) (if (not (or (file-exists? user-path) (directory-exists? user-path)))
(cond [(and global? global-pairity?) (cond
(user-add! root g-name) ;; global+global-pairity means that we make a symlink between the global-user and
(create-symbolic-link (subpath "../../../.users" g-name) user-path) ;; channel-user; as such the “global” symlink's path is `./`.
(create-symbolic-link "./" ;;g-user-path [(and global? global-pairity?)
(subpath user-path "global"))] (user-add! root g-name)
[global? (create-symbolic-link (subpath "../../../.users" g-name) user-path)
(user-add! root g-name) (create-symbolic-link "./" ;;g-user-path
(create-directory user-path #t) (subpath user-path "global"))]
(create-symbolic-link (subpath "../../../../.users" g-name) ;; Make a channel-user directory and a global-user directory, and link “global”
(subpath user-path "global"))] ;; property.
[#t [global?
(create-directory user-path #t)])))) (user-add! root g-name)
(create-directory user-path #t)
(create-symbolic-link (subpath "../../../../.users" g-name)
(subpath user-path "global"))]
;; This is a channel-only user, don't bother with symlink fanciness.
[#t
(create-directory user-path #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))
;; 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 user-state (that is, removes a symlink from a .users directory ;; Disables a user-state (that is, removes a symlink from a .users directory

13
tests/tests.scm
View File

@ -151,15 +151,20 @@
;; directory is just a link from the global user directory. ;; directory is just a link from the global user directory.
;; /.users/birdo → /living room/.users/birdo ;; /.users/birdo → /living room/.users/birdo
(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")
(check (symbolic-link? (subpath *new-room-all* "birdo")) (check (symbolic-link? (subpath *new-room-all* "birdo"))
=> =>
#t) #t)
(check (user-file-get *dir* "birdo" "nick")
=>
"rose")
;; Check a room user-directory with corresponding global user-directory, ;; Check a room user-directory with corresponding global user-directory,
;; but without the above link/pairity. ;; but without the above link/pairity.
(channel-user-add! *dir* *new-room* "mawa" #t #f) (channel-user-add! *dir* *new-room* "mawa" #t #f)
(print (subpath *users-dir* "mawa")) (channel-user-file-set! *dir* *new-room* "mawa" "nick" "mawarth")
(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"))
@ -167,6 +172,12 @@
) )
=> =>
#t) #t)
(check (user-file-get *dir* "mawa" "nick")
=>
"magma")
(check (channel-user-file-get *dir* *new-room* "mawa" "nick")
=>
"mawarth")