]> gitweb.factorcode.org Git - factor.git/commitdiff
elevate: moving to extra/
authorJohn Benediktsson <mrjbq7@gmail.com>
Tue, 25 Jan 2022 18:28:41 +0000 (10:28 -0800)
committerJohn Benediktsson <mrjbq7@gmail.com>
Tue, 25 Jan 2022 18:28:41 +0000 (10:28 -0800)
28 files changed:
basis/elevate/authors.txt [deleted file]
basis/elevate/elevate-docs.factor [deleted file]
basis/elevate/elevate-tests.factor [deleted file]
basis/elevate/elevate.factor [deleted file]
basis/elevate/linux/linux.factor [deleted file]
basis/elevate/linux/platforms.txt [deleted file]
basis/elevate/macosx/macosx.factor [deleted file]
basis/elevate/macosx/platforms.txt [deleted file]
basis/elevate/summary.txt [deleted file]
basis/elevate/tags.txt [deleted file]
basis/elevate/unix/platforms.txt [deleted file]
basis/elevate/unix/unix.factor [deleted file]
basis/elevate/windows/platforms.txt [deleted file]
basis/elevate/windows/windows.factor [deleted file]
extra/elevate/authors.txt [new file with mode: 0644]
extra/elevate/elevate-docs.factor [new file with mode: 0644]
extra/elevate/elevate-tests.factor [new file with mode: 0644]
extra/elevate/elevate.factor [new file with mode: 0644]
extra/elevate/linux/linux.factor [new file with mode: 0644]
extra/elevate/linux/platforms.txt [new file with mode: 0644]
extra/elevate/macosx/macosx.factor [new file with mode: 0644]
extra/elevate/macosx/platforms.txt [new file with mode: 0644]
extra/elevate/summary.txt [new file with mode: 0644]
extra/elevate/tags.txt [new file with mode: 0644]
extra/elevate/unix/platforms.txt [new file with mode: 0644]
extra/elevate/unix/unix.factor [new file with mode: 0644]
extra/elevate/windows/platforms.txt [new file with mode: 0644]
extra/elevate/windows/windows.factor [new file with mode: 0644]

diff --git a/basis/elevate/authors.txt b/basis/elevate/authors.txt
deleted file mode 100644 (file)
index 6c5009e..0000000
+++ /dev/null
@@ -1,2 +0,0 @@
-Cat Stevens
-Barney Gale
diff --git a/basis/elevate/elevate-docs.factor b/basis/elevate/elevate-docs.factor
deleted file mode 100644 (file)
index 546541a..0000000
+++ /dev/null
@@ -1,82 +0,0 @@
-USING: arrays elevate elevate.private help.markup help.syntax
-io.launcher kernel sequences strings system words ;
-IN: elevate
-
-<PRIVATE
-: $resolve? ( children -- ) 
-    first2 2dup swap lookup-word dup word? [ 2nip ($link) ] [ drop ":" glue $snippet ] if ; 
-PRIVATE>
-
-ABOUT: "elevate"
-
-ARTICLE: "elevate" "Elevated permissions API"
-    "The " { $vocab-link "elevate" } " vocabulary provides abstractions for running programs with elevated (administrator) privileges (permissions). It allows code to relaunch itself or other programs with administrator privileges after requiring a password."
-    $nl
-     "This vocabulary is inspired by and ported from " { $url "https://github.com/barneygale/elevate" "Barney Gale's elevate.py" } "."
-    $nl
-    { $subsections already-root? elevate elevated lowered }
-    "However, there are many caveats: " { $link "elevate.bugs" } "." ;
-
-ARTICLE: "elevate.bugs" "Elevate bugs and caveats"
-    "There are many inherent platform-specific limitations and workarounds in the " { $vocab-link "elevate" } " elevated privileges API. This article explains and documents them for the curious, future maintainers, or those who run into problems."
-    { $heading "macOS" }
-    "On Apple macOS, an Applescript command is attempted for a graphical method before " { $snippet "sudo" } ". Sometimes, this command appears to execute incorrectly due to the group of the user owning the calling process. On macOS, " { $snippet "sudo" } " suffers the drawback mentioned below for applications which do not have a TTY connected."
-    { $heading "Linux, *BSD and other Unix-likes" }
-    "On Linux, " { $snippet "gksudo" } ", " { $snippet "kdesudo" } ", and " { $snippet "pkexec" } " are all attempted graphical methods before " { $snippet "sudo" } "."
-    { $list
-        { { $snippet "pkexec" } " is the preferred and most secure graphical authentication method on Linux. It is undesirable for Factor applications, because unless a certain rare global registry value is set, " { $snippet "pkexec" } " does not set the " { $snippet "$DISPLAY" } " environment variable for child processes, and thus cannot launch graphical applications despite being a graphical program itself. It is tried after " { $snippet "gksudo" } " and " { $snippet "kdesudo" } " but before " { $snippet "sudo" } "." }
-        { { $snippet "gksudo" } " and " { $snippet "kdesudo" } " are deprecated, but still present on most GTK- and KDE-based systems, respectively. GTK is more widespread than KDE so " { $snippet "gksudo" } " is tried before " { $snippet "kdesudo" } ". These old-fashioned methods ensure that the launched application can be graphical, so they are preferred for Factor." }
-        { { $snippet "sudo" } " is the final and most robust strategy tried on Linux. It is text-based, so it requires the calling process to have an active and accessible terminal (TTY) for user authentication. If the calling Factor application was started from the desktop graphical shell rather than from a TTY, this method will fail." }
-    }
-    "On other Unix-like or POSIX-like operating systems, " { $snippet "sudo" } " is the only consistently popular method of authentication, and it suffers the same drawback on other Unix-likes as on Linux." 
-    { $heading "Windows" }
-    { "On Windows, the FFI word " { $resolve? "windows.shell32" "ShellExecuteW" } " is used with the verb " { $snippet "runas" } " to force the new process to run with User Account Control. Windows provides no " { $snippet "exec" } " equivalent to replace a running process' image, so a new process will always be spawned, optionally killing the original Factor process." }
-;
-
-HELP: elevated
-{ $values { "command" { $or array string } } { "replace?" boolean } { "win-console?" boolean } { "posix-graphical" boolean } }
-{ $description
-    "Spawn a process from the command " { $slot "command" } " with superuser (administrator) privileges. If the calling process does not already have superuser privileges, it will request them by a number of platform-specific methods."
-    $nl
-    "If " { $slot "replace?" } " is " { $link t } ", the calling Factor process will be replaced with the command (but see Notes)."
-    $nl
-    { $link windows } ": if " { $slot "win-console?" } " is " { $link t } ", a new console window will " { $emphasis "always" } " be spawned for the resulting process, regardless of " { $slot "replace?" } "."
-    $nl
-    { $link unix } ": if " { $slot "posix-graphical?" } " is " { $link t } ", a graphical password method will be attempted before " { $snippet "sudo" } "."
-    $nl
-    "If the calling process is already run as superuser, nothing happens. The input command is left on the stack, placed into a " { $link process } " inside an " { $link array } "."
-}
-{ $notes
-    { $list
-        { "On " { $link windows } ", " { $slot "replace?" } " has the effect of ending (with " { $link exit } ") the calling Factor process after spawning the command because Windows provides no way to replace a running process' image, like " { $snippet "exec" } " does in POSIX." }
-        { "On POSIX (" { $link unix } "), " { $slot "replace?" } " does not cause a graceful shutdown of the calling Factor VM or thread. Instead, the " { $emphasis "entire" } " executable program image will be immediately replaced in memory by the new command prefixed by a privilege elevation strategy. For more information, see " { $resolve? "unix.process" "exec-with-path" } " and the Unix " { $snippet "man" } " page for " { $resolve? "unix.process" "execvp" } " (" { $resolve? "unix.process" "exec" } ") in section 3." }
-        { { $link "elevate.bugs" } " details problems and pitfalls of this word." }
-    }
-}
-{ $errors
-    { $link elevated-failed } " when all strategies fail."
-    $nl
-    "When " { $slot "replace?" } " is " { $link t } ":any errors thrown by " { $link run-process } "."
-} ;
-
-HELP: elevate
-{ $values { "win-console?" boolean } { "posix-graphical" boolean } }
-{ $description "Relaunch the current Factor process with superuser privileges. See " { $link elevated } " for an explanation, as the semantics are identical." } ;
-
-HELP: lowered
-{ $description "Give up all superuser rights, returning the calling Factor process to normal userspace." }
-{ $notes
-    { $list 
-        { "On " { $link windows } " this word is a no-op, because there Windows provides no " { $snippet "setuid" } " equivalent to change the access token of a running process. It does not throw an error, so that it may be used in cross-platform code." }  
-        { "If the process is running as \"real superuser\", (not an impersonation), nothing happens." $nl "If the process is running as an unprivileged user, nothing happens." }
-    } 
-}
-{ $errors { $link lowered-failed } " when giving up superuser rights failed." } ;
-
-HELP: already-root? 
-{ $description "Determine whether the current Factor process (on " { $link unix } ") or hardware thread {on " { $link windows } ") has administrator or elevated (root) privileges." } ; 
-HELP: lowered-failed 
-{ $error-description "Thrown by " { $link lowered } " when giving up elevated privileges resulted in an error or failure by the operating system." } ;
-HELP: elevated-failed 
-{ $error-description "Thrown by " { $link elevated } " when all strategies to elevating privileges failed. See " { $link elevated } "." } ;
-
diff --git a/basis/elevate/elevate-tests.factor b/basis/elevate/elevate-tests.factor
deleted file mode 100644 (file)
index e69de29..0000000
diff --git a/basis/elevate/elevate.factor b/basis/elevate/elevate.factor
deleted file mode 100644 (file)
index 439ed14..0000000
+++ /dev/null
@@ -1,36 +0,0 @@
-USING: accessors arrays assocs combinators command-line
-environment formatting fry io.launcher kernel locals math
-namespaces sequences splitting strings system ui vocabs ;
-IN: elevate
-
-<PRIVATE
-ERROR: elevated-failed command { strategies array } ;
-ERROR: lowered-failed ;
-
-GENERIC#: prepend-command 1 ( command word -- word+command )
-M: array prepend-command
-    prefix ;
-
-M: string prepend-command
-    swap " " glue ;
-
-GENERIC: failed-process? ( process -- ? )
-M: f failed-process? not ;
-M: fixnum failed-process? -1 = ;
-M: process failed-process? status>> zero? not ;
-
-PRIVATE>
-HOOK: already-root? os ( -- ? )
-
-HOOK: elevated os ( command replace? win-console? posix-graphical? -- process )
-HOOK: lowered  os ( -- )
-
-: elevate ( win-console? posix-graphical? -- ) [ (command-line) t ] 2dip elevated drop ;
-
-os unix? [ "elevate.unix" require ] when
-
-{
-    { [ os windows? ] [ "elevate.windows" require ] }
-    { [ os linux? ] [ "elevate.linux" require ] }
-    { [ os macosx? ] [ "elevate.macosx" require ] }
-} cond
diff --git a/basis/elevate/linux/linux.factor b/basis/elevate/linux/linux.factor
deleted file mode 100644 (file)
index 3f14efc..0000000
+++ /dev/null
@@ -1,34 +0,0 @@
-USING: accessors arrays elevate elevate.private elevate.unix
-elevate.unix.private environment io.launcher kernel locals
-sequences system ui ;
-IN: elevate.linux
-
-<PRIVATE
-M:: linux elevated ( command replace? win-console? posix-graphical? -- process )
-    already-root? [
-        <process> command >>command 1array ! we are already root: just give a process
-    ] [
-        posix-graphical? ui-running? or "DISPLAY" os-env and [
-            command { "gksudo" "kdesudo" "pkexec" "sudo" } [
-                prepend-command
-            ] with map :> command-list
-
-            command-list [
-                replace? [ posix-replace-process ] [
-                    ! need to fix race condition
-                    <process> swap >>command t >>detached run-process
-                ] if
-            ] map [
-                [ failed-process? ] all? [
-                    command command-list elevated-failed
-                ] [ ] if
-            ] keep
-        ] [
-            command replace? posix-elevated ! sudo only
-        ] if
-    ] if ;
-
-M: linux lowered
-    posix-lowered ;
-
-PRIVATE>
diff --git a/basis/elevate/linux/platforms.txt b/basis/elevate/linux/platforms.txt
deleted file mode 100644 (file)
index a08e1f3..0000000
+++ /dev/null
@@ -1 +0,0 @@
-linux
diff --git a/basis/elevate/macosx/macosx.factor b/basis/elevate/macosx/macosx.factor
deleted file mode 100644 (file)
index d64462f..0000000
+++ /dev/null
@@ -1,28 +0,0 @@
-USING: accessors arrays cocoa.apple-script elevate
-elevate.unix.private formatting io.launcher kernel locals
-sequences system ;
-IN: elevate.macosx
-
-<PRIVATE
-: apple-script-elevated ( command -- )
-    first quote-apple-script
-    "do shell script %s with administrator privileges without altering line endings"
-    sprintf run-apple-script ;
-
-! TODO
-M:: macosx elevated ( command replace? win-console? posix-graphical? -- process )
-    already-root? [
-        <process> command >>command 1array
-    ] [
-        ! graphical through applescript
-        posix-graphical? [
-            command apple-script-elevated
-        ] when
-        posix-elevated  "lol3" throw
-    ] if "lol" throw ;
-
-M: macosx lowered
-    posix-lowered ;
-
-PRIVATE>
-
diff --git a/basis/elevate/macosx/platforms.txt b/basis/elevate/macosx/platforms.txt
deleted file mode 100644 (file)
index 6e806f4..0000000
+++ /dev/null
@@ -1 +0,0 @@
-macosx
diff --git a/basis/elevate/summary.txt b/basis/elevate/summary.txt
deleted file mode 100644 (file)
index 7fc860c..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Cross-platform API for elevated permissions
diff --git a/basis/elevate/tags.txt b/basis/elevate/tags.txt
deleted file mode 100644 (file)
index 6ed5626..0000000
+++ /dev/null
@@ -1,3 +0,0 @@
-os
-bindings
-windows
diff --git a/basis/elevate/unix/platforms.txt b/basis/elevate/unix/platforms.txt
deleted file mode 100644 (file)
index 509143d..0000000
+++ /dev/null
@@ -1 +0,0 @@
-unix
diff --git a/basis/elevate/unix/unix.factor b/basis/elevate/unix/unix.factor
deleted file mode 100644 (file)
index a589831..0000000
+++ /dev/null
@@ -1,31 +0,0 @@
-USING: arrays elevate elevate.private io.launcher kernel locals
-math sequences splitting strings system unix.ffi unix.process prettyprint ;
-IN: elevate.unix
-
-<PRIVATE
-! https://wiki.sei.cmu.edu/confluence/x/p9YxBQ
-! group ID must be lowered before user ID otherwise program may re-gain root!
-: posix-lowered ( -- )
-    getgid setgid failed-process? [ lowered-failed ] [ ] if
-    getuid setuid failed-process? [ lowered-failed ] [ ] if ;
-
-GENERIC: posix-replace-process ( command-list -- code )
-! naive split breaks with spaces inside quotes in shell commands
-M: string posix-replace-process
-    " " split posix-replace-process ;
-M: array posix-replace-process
-    [ first ] [ rest " " prefix ] bi exec-with-path ;
-
-! if either the real or effective user IDs are 0, we are already elevated
-M: unix already-root?
-    getuid geteuid [ zero? ] bi@ or ;
-
-:: posix-elevated ( command replace? -- process )
-    command "sudo" prepend-command
-    replace? [ posix-replace-process ] [ run-process ] if
-    dup failed-process? [ drop command { "sudo" } elevated-failed ] [ ] if ;
-
-M: unix elevated
-    2drop posix-elevated ;
-
-PRIVATE>
diff --git a/basis/elevate/windows/platforms.txt b/basis/elevate/windows/platforms.txt
deleted file mode 100644 (file)
index 8e1a559..0000000
+++ /dev/null
@@ -1 +0,0 @@
-windows
diff --git a/basis/elevate/windows/windows.factor b/basis/elevate/windows/windows.factor
deleted file mode 100644 (file)
index 18034b8..0000000
+++ /dev/null
@@ -1,30 +0,0 @@
-USING: accessors alien alien.c-types elevate io.launcher kernel
-locals math sequences splitting strings system windows.errors
-windows.kernel32 windows.shell32 windows.user32 ;
-IN: elevate.windows
-
-<PRIVATE
-! TODO
-M: windows already-root?
-    ! https://msdn.microsoft.com/en-us/library/windows/desktop/aa379296(v=vs.85).aspx
-    ! https://msdn.microsoft.com/en-us/library/windows/desktop/aa446671%28v=vs.85%29.aspx
-    ! https://msdn.microsoft.com/en-us/library/windows/desktop/ms683182(v=vs.85).aspx
-    f ;
-
-M:: windows elevated ( command replace? win-console? posix-graphical? -- process )
-    already-root? [
-        <process> command >>command
-    ] [
-        ! hwnd lpOperation
-        f "runas"
-        command dup string? [ " " split ] when
-        ! lpFile lpParameters lpDirectory (enum)nShowCmd
-        [ first ] [ rest ] bi " " join f SW_SHOW
-        ! call shell function with questionable return pointer handling (should use WaitForSingleObject but it hangs)
-        ShellExecuteW alien-address :> retval retval 32 <= [ retval n>win32-error-check ] [ ] if
-        replace? [ exit ] [ ] if
-    ] if ;
-
-! no-op (not possible to lower)
-M: windows lowered ;
-PRIVATE>
diff --git a/extra/elevate/authors.txt b/extra/elevate/authors.txt
new file mode 100644 (file)
index 0000000..6c5009e
--- /dev/null
@@ -0,0 +1,2 @@
+Cat Stevens
+Barney Gale
diff --git a/extra/elevate/elevate-docs.factor b/extra/elevate/elevate-docs.factor
new file mode 100644 (file)
index 0000000..546541a
--- /dev/null
@@ -0,0 +1,82 @@
+USING: arrays elevate elevate.private help.markup help.syntax
+io.launcher kernel sequences strings system words ;
+IN: elevate
+
+<PRIVATE
+: $resolve? ( children -- ) 
+    first2 2dup swap lookup-word dup word? [ 2nip ($link) ] [ drop ":" glue $snippet ] if ; 
+PRIVATE>
+
+ABOUT: "elevate"
+
+ARTICLE: "elevate" "Elevated permissions API"
+    "The " { $vocab-link "elevate" } " vocabulary provides abstractions for running programs with elevated (administrator) privileges (permissions). It allows code to relaunch itself or other programs with administrator privileges after requiring a password."
+    $nl
+     "This vocabulary is inspired by and ported from " { $url "https://github.com/barneygale/elevate" "Barney Gale's elevate.py" } "."
+    $nl
+    { $subsections already-root? elevate elevated lowered }
+    "However, there are many caveats: " { $link "elevate.bugs" } "." ;
+
+ARTICLE: "elevate.bugs" "Elevate bugs and caveats"
+    "There are many inherent platform-specific limitations and workarounds in the " { $vocab-link "elevate" } " elevated privileges API. This article explains and documents them for the curious, future maintainers, or those who run into problems."
+    { $heading "macOS" }
+    "On Apple macOS, an Applescript command is attempted for a graphical method before " { $snippet "sudo" } ". Sometimes, this command appears to execute incorrectly due to the group of the user owning the calling process. On macOS, " { $snippet "sudo" } " suffers the drawback mentioned below for applications which do not have a TTY connected."
+    { $heading "Linux, *BSD and other Unix-likes" }
+    "On Linux, " { $snippet "gksudo" } ", " { $snippet "kdesudo" } ", and " { $snippet "pkexec" } " are all attempted graphical methods before " { $snippet "sudo" } "."
+    { $list
+        { { $snippet "pkexec" } " is the preferred and most secure graphical authentication method on Linux. It is undesirable for Factor applications, because unless a certain rare global registry value is set, " { $snippet "pkexec" } " does not set the " { $snippet "$DISPLAY" } " environment variable for child processes, and thus cannot launch graphical applications despite being a graphical program itself. It is tried after " { $snippet "gksudo" } " and " { $snippet "kdesudo" } " but before " { $snippet "sudo" } "." }
+        { { $snippet "gksudo" } " and " { $snippet "kdesudo" } " are deprecated, but still present on most GTK- and KDE-based systems, respectively. GTK is more widespread than KDE so " { $snippet "gksudo" } " is tried before " { $snippet "kdesudo" } ". These old-fashioned methods ensure that the launched application can be graphical, so they are preferred for Factor." }
+        { { $snippet "sudo" } " is the final and most robust strategy tried on Linux. It is text-based, so it requires the calling process to have an active and accessible terminal (TTY) for user authentication. If the calling Factor application was started from the desktop graphical shell rather than from a TTY, this method will fail." }
+    }
+    "On other Unix-like or POSIX-like operating systems, " { $snippet "sudo" } " is the only consistently popular method of authentication, and it suffers the same drawback on other Unix-likes as on Linux." 
+    { $heading "Windows" }
+    { "On Windows, the FFI word " { $resolve? "windows.shell32" "ShellExecuteW" } " is used with the verb " { $snippet "runas" } " to force the new process to run with User Account Control. Windows provides no " { $snippet "exec" } " equivalent to replace a running process' image, so a new process will always be spawned, optionally killing the original Factor process." }
+;
+
+HELP: elevated
+{ $values { "command" { $or array string } } { "replace?" boolean } { "win-console?" boolean } { "posix-graphical" boolean } }
+{ $description
+    "Spawn a process from the command " { $slot "command" } " with superuser (administrator) privileges. If the calling process does not already have superuser privileges, it will request them by a number of platform-specific methods."
+    $nl
+    "If " { $slot "replace?" } " is " { $link t } ", the calling Factor process will be replaced with the command (but see Notes)."
+    $nl
+    { $link windows } ": if " { $slot "win-console?" } " is " { $link t } ", a new console window will " { $emphasis "always" } " be spawned for the resulting process, regardless of " { $slot "replace?" } "."
+    $nl
+    { $link unix } ": if " { $slot "posix-graphical?" } " is " { $link t } ", a graphical password method will be attempted before " { $snippet "sudo" } "."
+    $nl
+    "If the calling process is already run as superuser, nothing happens. The input command is left on the stack, placed into a " { $link process } " inside an " { $link array } "."
+}
+{ $notes
+    { $list
+        { "On " { $link windows } ", " { $slot "replace?" } " has the effect of ending (with " { $link exit } ") the calling Factor process after spawning the command because Windows provides no way to replace a running process' image, like " { $snippet "exec" } " does in POSIX." }
+        { "On POSIX (" { $link unix } "), " { $slot "replace?" } " does not cause a graceful shutdown of the calling Factor VM or thread. Instead, the " { $emphasis "entire" } " executable program image will be immediately replaced in memory by the new command prefixed by a privilege elevation strategy. For more information, see " { $resolve? "unix.process" "exec-with-path" } " and the Unix " { $snippet "man" } " page for " { $resolve? "unix.process" "execvp" } " (" { $resolve? "unix.process" "exec" } ") in section 3." }
+        { { $link "elevate.bugs" } " details problems and pitfalls of this word." }
+    }
+}
+{ $errors
+    { $link elevated-failed } " when all strategies fail."
+    $nl
+    "When " { $slot "replace?" } " is " { $link t } ":any errors thrown by " { $link run-process } "."
+} ;
+
+HELP: elevate
+{ $values { "win-console?" boolean } { "posix-graphical" boolean } }
+{ $description "Relaunch the current Factor process with superuser privileges. See " { $link elevated } " for an explanation, as the semantics are identical." } ;
+
+HELP: lowered
+{ $description "Give up all superuser rights, returning the calling Factor process to normal userspace." }
+{ $notes
+    { $list 
+        { "On " { $link windows } " this word is a no-op, because there Windows provides no " { $snippet "setuid" } " equivalent to change the access token of a running process. It does not throw an error, so that it may be used in cross-platform code." }  
+        { "If the process is running as \"real superuser\", (not an impersonation), nothing happens." $nl "If the process is running as an unprivileged user, nothing happens." }
+    } 
+}
+{ $errors { $link lowered-failed } " when giving up superuser rights failed." } ;
+
+HELP: already-root? 
+{ $description "Determine whether the current Factor process (on " { $link unix } ") or hardware thread {on " { $link windows } ") has administrator or elevated (root) privileges." } ; 
+HELP: lowered-failed 
+{ $error-description "Thrown by " { $link lowered } " when giving up elevated privileges resulted in an error or failure by the operating system." } ;
+HELP: elevated-failed 
+{ $error-description "Thrown by " { $link elevated } " when all strategies to elevating privileges failed. See " { $link elevated } "." } ;
+
diff --git a/extra/elevate/elevate-tests.factor b/extra/elevate/elevate-tests.factor
new file mode 100644 (file)
index 0000000..e69de29
diff --git a/extra/elevate/elevate.factor b/extra/elevate/elevate.factor
new file mode 100644 (file)
index 0000000..439ed14
--- /dev/null
@@ -0,0 +1,36 @@
+USING: accessors arrays assocs combinators command-line
+environment formatting fry io.launcher kernel locals math
+namespaces sequences splitting strings system ui vocabs ;
+IN: elevate
+
+<PRIVATE
+ERROR: elevated-failed command { strategies array } ;
+ERROR: lowered-failed ;
+
+GENERIC#: prepend-command 1 ( command word -- word+command )
+M: array prepend-command
+    prefix ;
+
+M: string prepend-command
+    swap " " glue ;
+
+GENERIC: failed-process? ( process -- ? )
+M: f failed-process? not ;
+M: fixnum failed-process? -1 = ;
+M: process failed-process? status>> zero? not ;
+
+PRIVATE>
+HOOK: already-root? os ( -- ? )
+
+HOOK: elevated os ( command replace? win-console? posix-graphical? -- process )
+HOOK: lowered  os ( -- )
+
+: elevate ( win-console? posix-graphical? -- ) [ (command-line) t ] 2dip elevated drop ;
+
+os unix? [ "elevate.unix" require ] when
+
+{
+    { [ os windows? ] [ "elevate.windows" require ] }
+    { [ os linux? ] [ "elevate.linux" require ] }
+    { [ os macosx? ] [ "elevate.macosx" require ] }
+} cond
diff --git a/extra/elevate/linux/linux.factor b/extra/elevate/linux/linux.factor
new file mode 100644 (file)
index 0000000..3f14efc
--- /dev/null
@@ -0,0 +1,34 @@
+USING: accessors arrays elevate elevate.private elevate.unix
+elevate.unix.private environment io.launcher kernel locals
+sequences system ui ;
+IN: elevate.linux
+
+<PRIVATE
+M:: linux elevated ( command replace? win-console? posix-graphical? -- process )
+    already-root? [
+        <process> command >>command 1array ! we are already root: just give a process
+    ] [
+        posix-graphical? ui-running? or "DISPLAY" os-env and [
+            command { "gksudo" "kdesudo" "pkexec" "sudo" } [
+                prepend-command
+            ] with map :> command-list
+
+            command-list [
+                replace? [ posix-replace-process ] [
+                    ! need to fix race condition
+                    <process> swap >>command t >>detached run-process
+                ] if
+            ] map [
+                [ failed-process? ] all? [
+                    command command-list elevated-failed
+                ] [ ] if
+            ] keep
+        ] [
+            command replace? posix-elevated ! sudo only
+        ] if
+    ] if ;
+
+M: linux lowered
+    posix-lowered ;
+
+PRIVATE>
diff --git a/extra/elevate/linux/platforms.txt b/extra/elevate/linux/platforms.txt
new file mode 100644 (file)
index 0000000..a08e1f3
--- /dev/null
@@ -0,0 +1 @@
+linux
diff --git a/extra/elevate/macosx/macosx.factor b/extra/elevate/macosx/macosx.factor
new file mode 100644 (file)
index 0000000..d64462f
--- /dev/null
@@ -0,0 +1,28 @@
+USING: accessors arrays cocoa.apple-script elevate
+elevate.unix.private formatting io.launcher kernel locals
+sequences system ;
+IN: elevate.macosx
+
+<PRIVATE
+: apple-script-elevated ( command -- )
+    first quote-apple-script
+    "do shell script %s with administrator privileges without altering line endings"
+    sprintf run-apple-script ;
+
+! TODO
+M:: macosx elevated ( command replace? win-console? posix-graphical? -- process )
+    already-root? [
+        <process> command >>command 1array
+    ] [
+        ! graphical through applescript
+        posix-graphical? [
+            command apple-script-elevated
+        ] when
+        posix-elevated  "lol3" throw
+    ] if "lol" throw ;
+
+M: macosx lowered
+    posix-lowered ;
+
+PRIVATE>
+
diff --git a/extra/elevate/macosx/platforms.txt b/extra/elevate/macosx/platforms.txt
new file mode 100644 (file)
index 0000000..6e806f4
--- /dev/null
@@ -0,0 +1 @@
+macosx
diff --git a/extra/elevate/summary.txt b/extra/elevate/summary.txt
new file mode 100644 (file)
index 0000000..7fc860c
--- /dev/null
@@ -0,0 +1 @@
+Cross-platform API for elevated permissions
diff --git a/extra/elevate/tags.txt b/extra/elevate/tags.txt
new file mode 100644 (file)
index 0000000..6ed5626
--- /dev/null
@@ -0,0 +1,3 @@
+os
+bindings
+windows
diff --git a/extra/elevate/unix/platforms.txt b/extra/elevate/unix/platforms.txt
new file mode 100644 (file)
index 0000000..509143d
--- /dev/null
@@ -0,0 +1 @@
+unix
diff --git a/extra/elevate/unix/unix.factor b/extra/elevate/unix/unix.factor
new file mode 100644 (file)
index 0000000..a589831
--- /dev/null
@@ -0,0 +1,31 @@
+USING: arrays elevate elevate.private io.launcher kernel locals
+math sequences splitting strings system unix.ffi unix.process prettyprint ;
+IN: elevate.unix
+
+<PRIVATE
+! https://wiki.sei.cmu.edu/confluence/x/p9YxBQ
+! group ID must be lowered before user ID otherwise program may re-gain root!
+: posix-lowered ( -- )
+    getgid setgid failed-process? [ lowered-failed ] [ ] if
+    getuid setuid failed-process? [ lowered-failed ] [ ] if ;
+
+GENERIC: posix-replace-process ( command-list -- code )
+! naive split breaks with spaces inside quotes in shell commands
+M: string posix-replace-process
+    " " split posix-replace-process ;
+M: array posix-replace-process
+    [ first ] [ rest " " prefix ] bi exec-with-path ;
+
+! if either the real or effective user IDs are 0, we are already elevated
+M: unix already-root?
+    getuid geteuid [ zero? ] bi@ or ;
+
+:: posix-elevated ( command replace? -- process )
+    command "sudo" prepend-command
+    replace? [ posix-replace-process ] [ run-process ] if
+    dup failed-process? [ drop command { "sudo" } elevated-failed ] [ ] if ;
+
+M: unix elevated
+    2drop posix-elevated ;
+
+PRIVATE>
diff --git a/extra/elevate/windows/platforms.txt b/extra/elevate/windows/platforms.txt
new file mode 100644 (file)
index 0000000..8e1a559
--- /dev/null
@@ -0,0 +1 @@
+windows
diff --git a/extra/elevate/windows/windows.factor b/extra/elevate/windows/windows.factor
new file mode 100644 (file)
index 0000000..18034b8
--- /dev/null
@@ -0,0 +1,30 @@
+USING: accessors alien alien.c-types elevate io.launcher kernel
+locals math sequences splitting strings system windows.errors
+windows.kernel32 windows.shell32 windows.user32 ;
+IN: elevate.windows
+
+<PRIVATE
+! TODO
+M: windows already-root?
+    ! https://msdn.microsoft.com/en-us/library/windows/desktop/aa379296(v=vs.85).aspx
+    ! https://msdn.microsoft.com/en-us/library/windows/desktop/aa446671%28v=vs.85%29.aspx
+    ! https://msdn.microsoft.com/en-us/library/windows/desktop/ms683182(v=vs.85).aspx
+    f ;
+
+M:: windows elevated ( command replace? win-console? posix-graphical? -- process )
+    already-root? [
+        <process> command >>command
+    ] [
+        ! hwnd lpOperation
+        f "runas"
+        command dup string? [ " " split ] when
+        ! lpFile lpParameters lpDirectory (enum)nShowCmd
+        [ first ] [ rest ] bi " " join f SW_SHOW
+        ! call shell function with questionable return pointer handling (should use WaitForSingleObject but it hangs)
+        ShellExecuteW alien-address :> retval retval 32 <= [ retval n>win32-error-check ] [ ] if
+        replace? [ exit ] [ ] if
+    ] if ;
+
+! no-op (not possible to lower)
+M: windows lowered ;
+PRIVATE>