scsh-0.6/scsh/user-group.scm

120 lines
3.1 KiB
Scheme
Raw Normal View History

;;; User info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record user-info
name uid gid home-dir shell
;; Make user-info records print like #{user-info shivers}.
((disclose ui)
(list "user-info" (user-info:name ui))))
(import-os-error-syscall
%uid->user-info
(uid user-info-record)
"user_info_uid")
(import-os-error-syscall
%name->user-info
(name user-info-record)
"user_info_name")
(define (uid->user-info uid)
(let ((empty-user-info (make-user-info #f uid #f #f #f)))
(if (%uid->user-info uid empty-user-info)
empty-user-info
(error "Cannot get user's information" uid->user-info uid))))
(define (name->user-info name)
(let ((empty-user-info (make-user-info name #f #f #f #f)))
(if (%name->user-info name empty-user-info)
empty-user-info
(error "Cannot get user's information" name->user-info name))))
(define (user-info uid/name)
((cond ((string? uid/name) name->user-info)
((integer? uid/name) uid->user-info)
(else (error "user-info arg must be string or integer" uid/name)))
uid/name))
;;; Derived functions
(define (->uid uid/name)
(user-info:uid (user-info uid/name)))
(define (->username uid/name)
(user-info:name (user-info uid/name)))
(define (%homedir uid/name)
(user-info:home-dir (user-info uid/name)))
(define home-directory "")
(define (init-home-directory home)
(set! home-directory home))
(define (home-dir . maybe-user)
(if (pair? maybe-user)
(let ((user (car maybe-user)))
(ensure-file-name-is-nondirectory
(or (%homedir user)
(error "Cannot get user's home directory"
user))))
home-directory))
;;; (home-file [user] fname)
(define (home-file arg1 . maybe-arg2)
(receive (dir fname)
(if (pair? maybe-arg2)
(values (home-dir arg1) (car maybe-arg2))
(values home-directory arg1))
(string-append (file-name-as-directory dir) fname)))
;;; Group info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record group-info
name gid members
;; Make group-info records print like #{group-info wheel}.
((disclose gi) (list "group-info" (group-info:name gi))))
(import-os-error-syscall
%gid->group-info
(gid group-info-record)
"group_info_gid")
(import-os-error-syscall
%name->group-info
(name group-info-record)
"group_info_name")
(define (gid->group-info gid)
(let ((empty-group-info (make-group-info #f gid #f)))
(if (%gid->group-info gid empty-group-info)
empty-group-info
(error "Cannot get group's information for gid" gid))))
(define (name->group-info name)
(let ((empty-group-info (make-group-info name #f #f)))
(if (%name->group-info name empty-group-info)
empty-group-info
(error "Cannot get group's information for name" name))))
(define (group-info gid/name)
((cond ((string? gid/name) name->group-info)
((integer? gid/name) gid->group-info)
(else (error "group-info arg must be string or integer" gid/name)))
gid/name))
;;; Derived functions
(define (->gid name)
(group-info:gid (group-info name)))
(define (->groupname gid)
(group-info:name (group-info gid)))