+ user-effective-uid and -gid per thread.
+ alignments for euid- and egid-resource + argument to chdir is now optional and defaults to (home-dir)
This commit is contained in:
mainzelm
parent
cf7b089f09
commit
ff0ce8fdfb
|
|
@ -54,7 +54,7 @@
|
|||
;;; broken exception system
|
||||
(else (list err syscall fname)))))
|
||||
(with-resources-aligned
|
||||
(list cwd-resource umask-resource)
|
||||
(list cwd-resource umask-resource euid-resource egid-resource)
|
||||
(lambda ()
|
||||
(makeit fname)))
|
||||
#f))))
|
||||
|
|
@ -116,6 +116,6 @@
|
|||
(y-or-n? (string-append "rename-file:" new-fname
|
||||
" already exists. Delete"))))
|
||||
(with-resources-aligned
|
||||
(list cwd-resource)
|
||||
(list cwd-resource euid-resource egid-resource)
|
||||
(lambda ()
|
||||
(%rename-file old-fname new-fname))))))
|
||||
|
|
|
|||
|
|
@ -374,7 +374,14 @@
|
|||
user-supplementary-gids
|
||||
set-uid
|
||||
set-gid
|
||||
set-effective-gid
|
||||
set-user-effective-uid
|
||||
set-user-effective-gid
|
||||
with-user-effective-uid*
|
||||
with-user-effective-gid*
|
||||
((with-user-effective-uid
|
||||
with-user-effective-gid):syntax)
|
||||
euid-resource
|
||||
egid-resource
|
||||
|
||||
system-name
|
||||
process-times
|
||||
|
|
|
|||
125
scsh/scsh.scm
125
scsh/scsh.scm
|
|
@ -179,11 +179,12 @@
|
|||
(if (not (string=? thread-cwd (cwd-cache)))
|
||||
(change-and-cache-cwd thread-cwd))))
|
||||
|
||||
(define (chdir cwd)
|
||||
(define (chdir . maybe-dir)
|
||||
(let ((dir (:optional maybe-dir (home-dir))))
|
||||
(with-lock cwd-lock
|
||||
(lambda ()
|
||||
(change-and-cache-cwd cwd)
|
||||
(thread-set-cwd! (cwd-cache)))))
|
||||
(change-and-cache-cwd dir)
|
||||
(thread-set-cwd! (cwd-cache))))))
|
||||
|
||||
(define-record-type resource :resource
|
||||
(make-resource align! lock)
|
||||
|
|
@ -212,7 +213,7 @@
|
|||
;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
(define cwd-reinitializer
|
||||
(make-reinitializer (lambda () (warn "calling resumer") (initialize-cwd))))
|
||||
(make-reinitializer (lambda () (initialize-cwd))))
|
||||
|
||||
|
||||
(initialize-cwd)
|
||||
|
|
@ -255,11 +256,6 @@
|
|||
(umask-cache)))))
|
||||
(let-umask changed-umask thunk)))
|
||||
|
||||
;; Align the value of the Unix umask 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 umask lock.
|
||||
|
||||
(define (align-umask!)
|
||||
(let ((thread-umask (umask)))
|
||||
(if (not (= thread-umask (umask-cache)))
|
||||
|
|
@ -273,22 +269,102 @@
|
|||
|
||||
(define umask-resource (make-resource align-umask! umask-lock))
|
||||
|
||||
;; example syscall
|
||||
;; (define (exported-delete-file fname)
|
||||
;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
(define umask-reinitializer
|
||||
(make-reinitializer (lambda () (warn "calling resumer") (initialize-umask))))
|
||||
(make-reinitializer (lambda () (initialize-umask))))
|
||||
|
||||
|
||||
(initialize-umask)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; effective uid and gid per thread
|
||||
|
||||
(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)))))
|
||||
|
||||
(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*)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; ensure S48 is aligned too
|
||||
|
||||
(set-with-fs-context-aligned*!
|
||||
(lambda (thunk)
|
||||
(with-resources-aligned (list cwd-resource umask-resource) thunk)))
|
||||
(with-resources-aligned
|
||||
(list cwd-resource umask-resource euid-resource egid-resource)
|
||||
thunk)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Environment per thread
|
||||
|
|
@ -326,11 +402,6 @@
|
|||
(change-and-cache-env env)))
|
||||
(let-env env thunk))
|
||||
|
||||
;; Align the value of the Unix env 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 env lock.
|
||||
|
||||
(define (align-env!)
|
||||
(let ((res (thread-read-env)))
|
||||
(if (not (env=? res (env-cache)))
|
||||
|
|
@ -344,10 +415,6 @@
|
|||
|
||||
(define environ-resource (make-resource align-env! env-lock))
|
||||
|
||||
;; example syscall
|
||||
;; (define (exported-delete-file fname)
|
||||
;; (with-cwd-aligned (really-delete-file fname)))
|
||||
|
||||
(define env-reinitializer
|
||||
(make-reinitializer install-env))
|
||||
|
||||
|
|
@ -519,6 +586,11 @@
|
|||
(define-simple-syntax (with-total-env env . body)
|
||||
(with-total-env* `env (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 (call/temp-file writer user)
|
||||
(let ((fname #f))
|
||||
|
|
@ -947,7 +1019,8 @@
|
|||
|
||||
(define (exec/env prog env . arglist)
|
||||
(flush-all-ports)
|
||||
(with-resources-aligned (list environ-resource cwd-resource umask-resource)
|
||||
(with-resources-aligned
|
||||
(list environ-resource cwd-resource umask-resource euid-resource egid-resource)
|
||||
(lambda ()
|
||||
(%exec prog (cons prog arglist) env))))
|
||||
|
||||
|
|
@ -964,7 +1037,7 @@
|
|||
(define (exec-path/env prog env . arglist)
|
||||
(flush-all-ports)
|
||||
(with-resources-aligned
|
||||
(list environ-resource cwd-resource umask-resource)
|
||||
(list environ-resource cwd-resource umask-resource euid-resource egid-resource)
|
||||
(lambda ()
|
||||
(let ((prog (stringify prog)))
|
||||
(if (string-index prog #\/)
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
;;; You can't throw an error within a handler
|
||||
;;;
|
||||
|
||||
;;; Move this to somewhere else as soon as Marc published his SRFI
|
||||
;;; Move this to somewhere else as soon as Marc has published his SRFI
|
||||
(define (continuation-capture receiver)
|
||||
((call-with-current-continuation
|
||||
(lambda (cont)
|
||||
|
|
@ -111,22 +111,22 @@
|
|||
|
||||
(import-os-error-syscall user-gid () "scsh_getgid")
|
||||
|
||||
(import-os-error-syscall user-effective-gid () "scsh_getegid")
|
||||
(import-os-error-syscall process-user-effective-gid () "scsh_getegid")
|
||||
|
||||
(import-os-error-syscall set-gid (gid) "scsh_setgid")
|
||||
(import-os-error-syscall process-set-gid (gid) "scsh_setgid")
|
||||
|
||||
(import-os-error-syscall set-effective-gid (gid) "scsh_setegid")
|
||||
(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 user-effective-uid () "scsh_geteuid")
|
||||
(import-os-error-syscall process-user-effective-uid () "scsh_geteuid")
|
||||
|
||||
(import-os-error-syscall set-uid (uid) "scsh_setuid")
|
||||
(import-os-error-syscall process-set-uid (uid) "scsh_setuid")
|
||||
|
||||
(import-os-error-syscall set-effective-uid (uid) "scsh_seteuid")
|
||||
(import-os-error-syscall set-process-user-effective-uid (uid) "scsh_seteuid")
|
||||
|
||||
(import-os-error-syscall %user-login-name () "my_username")
|
||||
|
||||
|
|
@ -184,7 +184,8 @@
|
|||
|
||||
(define (generic-file-op thing fd-op fname-op)
|
||||
(if (string? thing)
|
||||
(with-resources-aligned (list cwd-resource) (lambda () (fname-op thing)))
|
||||
(with-resources-aligned (list cwd-resource euid-resource egid-resource)
|
||||
(lambda () (fname-op thing)))
|
||||
(call/fdes thing fd-op)))
|
||||
|
||||
|
||||
|
|
@ -341,7 +342,8 @@
|
|||
(import-os-error-syscall %delete-file (path) "scsh_unlink")
|
||||
|
||||
(define (delete-file path)
|
||||
(with-resources-aligned (list cwd-resource) (lambda () (%delete-file path))))
|
||||
(with-resources-aligned (list cwd-resource euid-resource egid-resource)
|
||||
(lambda () (%delete-file path))))
|
||||
|
||||
(import-os-error-syscall %sync-file (fd) "scsh_fsync")
|
||||
|
||||
|
|
@ -384,7 +386,7 @@
|
|||
|
||||
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
|
||||
(with-resources-aligned
|
||||
(list cwd-resource umask-resource)
|
||||
(list cwd-resource umask-resource euid-resource egid-resource)
|
||||
(lambda ()
|
||||
(%open path flags (:optional maybe-mode #o666)))))
|
||||
|
||||
|
|
@ -535,7 +537,7 @@
|
|||
|
||||
(define (directory-files . args)
|
||||
(with-resources-aligned
|
||||
(list cwd-resource)
|
||||
(list cwd-resource euid-resource egid-resource)
|
||||
(lambda ()
|
||||
(let-optionals args ((dir ".")
|
||||
(dotfiles? #f))
|
||||
|
|
|
|||
Loading…
Reference in New Issue