322 lines
8.9 KiB
Scheme
322 lines
8.9 KiB
Scheme
;;; UMASK
|
|
|
|
(import-os-error-syscall set-process-umask (mask) "scsh_umask")
|
|
|
|
(define (process-umask)
|
|
(let ((m (set-process-umask 0)))
|
|
(set-process-umask m)
|
|
m))
|
|
;;; Working directory
|
|
|
|
(import-os-error-syscall %chdir (directory) "scsh_chdir")
|
|
|
|
;;; These calls change/reveal the process working directory
|
|
;;;
|
|
|
|
(define (process-chdir . maybe-dir)
|
|
(let ((dir (:optional maybe-dir (home-dir))))
|
|
(%chdir dir)))
|
|
|
|
;; TODO: we get an error if cwd does not exist on startup
|
|
(import-os-error-syscall process-cwd () "scheme_cwd")
|
|
|
|
;;; GID
|
|
|
|
(import-os-error-syscall user-gid () "scsh_getgid")
|
|
|
|
(import-os-error-syscall process-user-effective-gid () "scsh_getegid")
|
|
|
|
(import-os-error-syscall process-set-gid (gid) "scsh_setgid")
|
|
|
|
(import-os-error-syscall set-process-user-effective-gid (gid) "scsh_setegid")
|
|
|
|
(import-os-error-syscall user-supplementary-gids () "get_groups")
|
|
|
|
;;; UID
|
|
(import-os-error-syscall user-uid () "scsh_getuid")
|
|
|
|
(import-os-error-syscall process-user-effective-uid () "scsh_geteuid")
|
|
|
|
(import-os-error-syscall process-set-uid (uid) "scsh_setuid")
|
|
|
|
(import-os-error-syscall set-process-user-effective-uid (uid) "scsh_seteuid")
|
|
|
|
(import-os-error-syscall %user-login-name () "my_username")
|
|
|
|
(define (user-login-name)
|
|
(or (%user-login-name)
|
|
(error "Cannot get your name")))
|
|
|
|
|
|
;;; PID
|
|
|
|
(import-os-error-syscall pid () "scsh_getpid")
|
|
(import-os-error-syscall parent-pid () "scsh_getppid")
|
|
;;; Process groups and session ids
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(import-os-error-syscall process-group () "scsh_getpgrp")
|
|
|
|
(import-os-error-syscall %set-process-group (pid groupid) "scsh_setpgid")
|
|
|
|
(define (set-process-group arg1 . maybe-arg2)
|
|
(receive (pid pgrp) (if (null? maybe-arg2)
|
|
(values (pid) arg1)
|
|
(values arg1 (car maybe-arg2)))
|
|
(%set-process-group pid pgrp)))
|
|
|
|
|
|
(import-os-error-syscall become-session-leader () "scsh_setsid")
|
|
|
|
;;; Miscellaneous process state
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; PROCESS TIMES
|
|
|
|
;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
|
|
|
|
|
|
(import-os-error-syscall process-times/list () "process_times")
|
|
|
|
(define (process-times)
|
|
(apply values (process-times/list)))
|
|
|
|
(import-os-error-syscall cpu-ticks/sec () "cpu_clock_ticks_per_sec")
|
|
|
|
;;; Resources
|
|
|
|
;; Align the value of the Unix cwd with scsh's value.
|
|
;; Since another thread could disalign, this call and
|
|
;; any ensuring syscall that relies upon it should
|
|
;; be "glued together" with the cwd lock.
|
|
|
|
(define cwd-lock (make-lock))
|
|
|
|
(define (align-cwd!)
|
|
(let ((thread-cwd (cwd)))
|
|
(if (not (string=? thread-cwd (cwd-cache)))
|
|
(change-and-cache-cwd thread-cwd))))
|
|
|
|
(define cwd-resource (make-resource align-cwd! cwd-lock))
|
|
|
|
;; example syscall
|
|
;; (define (exported-delete-file fname)
|
|
;; (with-cwd-aligned (really-delete-file fname)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; effective uid and gid per thread
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; working directory per thread
|
|
|
|
(define *cwd-cache* 'uninitialized)
|
|
|
|
(define (initialize-cwd)
|
|
(set! *cwd-cache* (process-cwd))
|
|
(set! $cwd ;;; TODO The old thread-fluid will remain
|
|
(make-preserved-thread-fluid
|
|
(cwd-cache))))
|
|
; (set! cwd-lock (make-lock)))
|
|
|
|
(define (cwd-cache)
|
|
*cwd-cache*)
|
|
|
|
;; Actually do the syscall and update the cache
|
|
;; assumes the cwd lock obtained
|
|
(define (change-and-cache-cwd new-cwd)
|
|
(if (not (file-name-absolute? new-cwd))
|
|
(process-chdir (string-append (cwd) "/" new-cwd))
|
|
(process-chdir new-cwd))
|
|
(set! *cwd-cache* (process-cwd)))
|
|
|
|
;; The thread-specific cwd: A thread fluid
|
|
|
|
(define $cwd 'empty-cwd-value)
|
|
|
|
(define (cwd) (thread-fluid $cwd))
|
|
(define (thread-set-cwd! cwd) (set-thread-fluid! $cwd cwd))
|
|
(define (let-cwd cwd thunk)
|
|
(let-thread-fluid $cwd cwd thunk))
|
|
|
|
(define (with-cwd* new-cwd thunk)
|
|
(let ((changed-cwd
|
|
(with-lock cwd-lock
|
|
(lambda ()
|
|
(change-and-cache-cwd new-cwd)
|
|
(cwd-cache)))))
|
|
(let-cwd changed-cwd thunk)))
|
|
|
|
(define (chdir . maybe-dir)
|
|
(let ((dir (:optional maybe-dir (home-dir))))
|
|
(with-lock cwd-lock
|
|
(lambda ()
|
|
(change-and-cache-cwd dir)
|
|
(thread-set-cwd! (cwd-cache))))))
|
|
|
|
(define cwd-reinitializer
|
|
(make-reinitializer (lambda () (initialize-cwd))))
|
|
|
|
(initialize-cwd)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; umask per thread
|
|
(define *umask-cache* 'uninitialized)
|
|
(define umask-lock (make-lock))
|
|
|
|
(define (initialize-umask)
|
|
(set! *umask-cache* (process-umask))
|
|
(set! $umask ;;; TODO The old thread-fluid will remain
|
|
(make-preserved-thread-fluid
|
|
(umask-cache))))
|
|
; (set! umask-lock (make-lock)))
|
|
|
|
(define (umask-cache)
|
|
*umask-cache*)
|
|
|
|
;; Actually do the syscall and update the cache
|
|
;; assumes the resource lock obtained
|
|
(define (change-and-cache-umask new-umask)
|
|
(set-process-umask new-umask)
|
|
(set! *umask-cache* (process-umask)))
|
|
|
|
;; The thread-specific umask: A thread fluid
|
|
|
|
(define $umask 'empty-umask-value)
|
|
|
|
(define (umask) (thread-fluid $umask))
|
|
(define (thread-set-umask! new-umask) (set-thread-fluid! $umask new-umask))
|
|
(define (let-umask new-umask thunk)
|
|
(let-thread-fluid $umask new-umask thunk))
|
|
|
|
(define (with-umask* new-umask thunk)
|
|
(let ((changed-umask
|
|
(with-lock umask-lock
|
|
(lambda ()
|
|
(change-and-cache-umask new-umask)
|
|
(umask-cache)))))
|
|
(let-umask changed-umask thunk)))
|
|
|
|
(define (align-umask!)
|
|
(let ((thread-umask (umask)))
|
|
(if (not (= thread-umask (umask-cache)))
|
|
(change-and-cache-umask thread-umask))))
|
|
|
|
(define (set-umask new-umask)
|
|
(with-lock umask-lock
|
|
(lambda ()
|
|
(change-and-cache-umask new-umask)
|
|
(thread-set-umask! (umask-cache)))))
|
|
|
|
(define umask-resource (make-resource align-umask! umask-lock))
|
|
|
|
(define umask-reinitializer
|
|
(make-reinitializer (lambda () (initialize-umask))))
|
|
|
|
|
|
(initialize-umask)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ensure S48 is aligned too
|
|
|
|
(set-with-fs-context-aligned*!
|
|
(lambda (thunk)
|
|
(with-resources-aligned
|
|
(list cwd-resource umask-resource euid-resource egid-resource)
|
|
thunk)))
|
|
|
|
;; Sugar:
|
|
|
|
(define-simple-syntax (with-cwd dir . body)
|
|
(with-cwd* dir (lambda () . body)))
|
|
|
|
(define-simple-syntax (with-umask mask . body)
|
|
(with-umask* mask (lambda () . body)))
|
|
|
|
(define-simple-syntax (with-user-effective-uid uid . body)
|
|
(with-user-effective-uid* uid (lambda () . body)))
|
|
|
|
(define-simple-syntax (with-user-effective-gid gid . body)
|
|
(with-user-effective-gid* gid (lambda () . body)))
|
|
|
|
(define-syntax make-Xid-resource
|
|
(syntax-rules ()
|
|
((make-Xid-resource
|
|
process-user-effective-Xid set-process-user-effective-Xid
|
|
process-set-Xid set-Xid
|
|
align-eXid! eXid-resource
|
|
user-effective-Xid set-user-effective-Xid with-user-effective-Xid*)
|
|
(begin
|
|
(define *eXid-cache* 'uninitialized)
|
|
(define eXid-lock (make-lock))
|
|
|
|
(define (initialize-eXid)
|
|
(set! *eXid-cache* (process-user-effective-Xid))
|
|
(set! $eXid
|
|
(make-preserved-thread-fluid
|
|
(eXid-cache))))
|
|
|
|
(define (eXid-cache)
|
|
*eXid-cache*)
|
|
|
|
;; Actually do the syscall and update the cache
|
|
;; assumes the resource lock obtained
|
|
(define (change-and-cache-eXid new-eXid)
|
|
(set-process-user-effective-Xid new-eXid)
|
|
(set! *eXid-cache* (process-user-effective-Xid)))
|
|
|
|
;; The thread-specific eXid: A thread fluid
|
|
|
|
(define $eXid 'empty-eXid-value)
|
|
|
|
(define (user-effective-Xid) (thread-fluid $eXid))
|
|
(define (thread-set-eXid! new-eXid) (set-thread-fluid! $eXid new-eXid))
|
|
(define (let-eXid new-eXid thunk)
|
|
(let-thread-fluid $eXid new-eXid thunk))
|
|
|
|
;; set-Xid will affect the effective X id
|
|
(define (set-Xid Xid)
|
|
(with-lock eXid-lock
|
|
(lambda ()
|
|
(process-set-Xid Xid)
|
|
(set! *eXid-cache* (process-user-effective-Xid))
|
|
(thread-set-eXid! *eXid-cache*))))
|
|
|
|
(define (with-user-effective-Xid* new-eXid thunk)
|
|
(let ((changed-eXid
|
|
(with-lock eXid-lock
|
|
(lambda ()
|
|
(change-and-cache-eXid new-eXid)
|
|
(eXid-cache)))))
|
|
(let-eXid changed-eXid thunk)))
|
|
|
|
(define (align-eXid!)
|
|
(let ((thread-eXid (user-effective-Xid)))
|
|
(if (not (= thread-eXid (eXid-cache)))
|
|
(change-and-cache-eXid thread-eXid))))
|
|
|
|
(define (set-user-effective-Xid new-eXid)
|
|
(with-lock eXid-lock
|
|
(lambda ()
|
|
(change-and-cache-eXid new-eXid)
|
|
(thread-set-eXid! (eXid-cache)))))
|
|
|
|
(define eXid-resource (make-resource align-eXid! eXid-lock))
|
|
|
|
(define eXid-reinitializer
|
|
(make-reinitializer (lambda () (initialize-eXid))))
|
|
|
|
(initialize-eXid)
|
|
))))
|
|
|
|
(make-Xid-resource
|
|
process-user-effective-uid set-process-user-effective-uid
|
|
process-set-uid set-uid
|
|
align-euid! euid-resource
|
|
user-effective-uid set-user-effective-uid with-user-effective-uid*)
|
|
|
|
(make-Xid-resource
|
|
process-user-effective-gid set-process-user-effective-gid
|
|
process-set-gid set-gid
|
|
align-egid! egid-resource
|
|
user-effective-gid set-user-effective-gid with-user-effective-gid*)
|