steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

finish up elevate implementation for now

elevate-erg
Cat Stevens 2018-05-18 19:02:43 -04:00 committed by Doug Coleman
parent 9f74361b7a
commit fafdef3138
2 changed files with 71 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/elevate/elevate-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.syntax help.markup ;
USING: arrays help.markup help.syntax strings ;
IN: elevate
ABOUT: elevate

91
basis/elevate/elevate.factor
View File

@ -1,8 +1,33 @@
USING: arrays command-line fry io.launcher kernel math namespaces
sequences system unix.ffi ;
USING: accessors arrays assocs command-line environment
formatting fry io.launcher kernel ui locals math namespaces
sequences splitting strings system unix.ffi unix.process ;
IN: elevate
: apple-script-elevate ( command -- ) 2drop ;
<PRIVATE
ERROR: elevated-failed path ;
ERROR: lowered-failed ;
CONSTANT: apple-script-charmap H{
{ "\n" "\\n" }
{ "\r" "\\r" }
{ "\t" "\\t" }
{ "\"" "\\\"" }
{ "\\" "\\\\" }
}
: quote-apple-script ( str -- str' )
[ 1string [ apple-script-charmap at ] [ ] bi or ] { } map-as
"" join "\"" dup surround ;
: run-apple-script ( str -- ) drop ;
: apple-script-elevated ( command -- )
quote-apple-script
"do shell script %s with administrator privileges without altering line endings"
sprintf run-apple-script ;
: posix-replace-process ( command-list -- code )
[ first ] [ rest ] bi exec-with-path ;
GENERIC: glue-command ( prefix command -- glued )
@ -12,31 +37,55 @@ M: array glue-command
M: string glue-command
" " glue ;
ERROR: elevated-failed path ;
GENERIC: failed-process? ( process -- ? )
M: f failed-process? not ;
M: fixnum failed-process? -1 = ;
M: process failed-process? status>> zero? not ;
HOOK: elevated os ( command win-console? posix-graphical? -- process )
PRIVATE>
HOOK: elevated os ( command replace? win-console? posix-graphical? -- process )
! TODO
M: windows elevated
2drop run-process ;
3drop run-process ;
M: macosx elevated
nip [ ! graphical (through applescript)
apple-script-elevate
! TODO
M:: macosx elevated ( command replace? win-console? posix-graphical? -- process )
posix-graphical? [ ! graphical (through applescript)
command apple-script-elevated
] when
command replace? win-console? posix-graphical?
linux os [ elevated ] with-variable ;
M:: linux elevated ( command replace? win-console? posix-graphical? -- process )
getuid zero? [
<process> command >>command ! we are already root: just give a process
] [
f f linux os [ elevated ] with-variable
! graphical handled
posix-graphical? ui-running? or "DISPLAY" os-env and
{ "gksudo" "kdesudo" "sudo" } { "sudo" } ?
command '[ _ glue-command ] map [
replace? [
" " split posix-replace-process
] [ run-process ] if
] map
! if they all failed, then it failed, but if one passed, that's normal (success)
[ [ failed-process? ] all? [ command elevated-failed ] [ ] if ] keep
] if ;
M: linux elevated
nip getuid zero? [
drop ! we are already root: do nothing
] [
{ "gksudo" "kdesudo" "sudo" } { "sudo" } ? ! graphical handled
swap '[ _ glue-command ] map
[ " " split [ first utf8 string>alien ] [ rest ] execvp ] map
[ -1 = ] all? elevated-failed
] if ;
: elevate ( win-console? posix-graphical? -- ) [ (command-line) t ] 2dip elevated drop ;
: elevate ( option? -- ) (command-line) elevated ;
HOOK: lowered os ( -- )
HOOK: lowered os ( relaunch? -- )
! https://wiki.sei.cmu.edu/confluence/display/c/POS36-C.+Observe+correct+revocation+order+while+relinquishing+privileges
! group ID must be lowered before user ID otherwise program may re-gain root!
M: linux lowered
getgid setgid failed-process? [ lowered-failed ] [ ] if
getuid setuid failed-process? [ lowered-failed ] [ ] if ;
M: macosx lowered
linux os [ lowered ] with-variable ;
M: windows lowered ;