diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,22 +1,335 @@ -Copyright XT (c) 2016 +Summary: This library is licensed under Apache-2.0, BSD2, and MIT. -All rights reserved. +Some code in this library is derived from the process library, whose license +is in the "The process Library" section. +----------------------------------------------------------------------------- + +== The 2-Clause BSD License == + +Copyright 2016-2017 XT + Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following condition is met: +modification, are permitted provided that the following conditions are met: - * Neither the name of XT nor the names of other contributors may be used - to endorse or promote products derived from this software without - specific prior written permission. +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------------------- + +== The MIT License == + +Copyright (c) 2016-2017 XT + +Permission is hereby granted, free of charge, to any +person obtaining a copy of this software and associated +documentation files (the "Software"), to deal in the +Software without restriction, including without +limitation the rights to use, copy, modify, merge, +publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software +is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice +shall be included in all copies or substantial portions +of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF +ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED +TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT +SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR +IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. + +----------------------------------------------------------------------------- + +== The Apache License Version 2.0 == + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + +----------------------------------------------------------------------------- + +== The process Library == + +This library (libraries/process) is derived from code from two +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + +The full text of these licenses is reproduced below. Both of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -16,7 +16,7 @@ To put a cherry on top of creaking, fuming, dragging, and littering pointers all over the heap space, `String` had another fantastic nature to serve as a file path data type: Encoding blindness. All functions that return `FilePath` would actually take a series of bytes returned by a syscall and somehow magically "decode" it into a `String` which is surprising because no encoding information was given. Of course there is no magic and it's an abject fail. `FilePath` just wouldn't work. -In June 2015, three bright Haskell programmers came up with an elegant solution called the [Abstract FilePath Proposal] and met an immediate thunderous applause. Inspired by this enthusiasm, they further pursued the career of professional Haskell programming and focused on more interesting things. 16 months later, a programmer under the pseudonym XT got so fed up with the situation and released a package called `rawfilepath` out of pure evil intent. +In June 2015, three bright Haskell programmers came up with an elegant solution called the [Abstract FilePath Proposal] and met an immediate thunderous applause. Inspired by this enthusiasm, they further pursued the career of professional Haskell programming and focused on more interesting things. 16 months later, a programmer under the pseudonym XT got so sick and tired of the situation and released a package called `rawfilepath` that, despite being far from perfect, worked. ## So what is this? @@ -31,6 +31,10 @@ - Minimal dependencies (`bytestring`, `unix`, and `base`) - Lightweight library (under 400 total lines of code) - Available now + +## Documentation + +[API documentation of rawfilepath on Stackage](https://www.stackage.org/package/rawfilepath). ## To do diff --git a/cbits/processFlags.c b/cbits/processFlags.c new file mode 100644 --- /dev/null +++ b/cbits/processFlags.c @@ -0,0 +1,1 @@ +#include "processFlags.h" diff --git a/cbits/processFlags.h b/cbits/processFlags.h new file mode 100644 --- /dev/null +++ b/cbits/processFlags.h @@ -0,0 +1,11 @@ +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Flags used in runProcess.c and for System.Process.Internals + ------------------------------------------------------------------------- */ + +#define RUN_PROCESS_IN_CLOSE_FDS 0x1 +#define RUN_PROCESS_IN_NEW_GROUP 0x2 +#define RUN_PROCESS_DETACHED 0x4 +#define RUN_PROCESS_NEW_SESSION 0x8 +#define RUN_PROCESS_NEW_CONSOLE 0x10 diff --git a/cbits/runProcess.c b/cbits/runProcess.c new file mode 100644 --- /dev/null +++ b/cbits/runProcess.c @@ -0,0 +1,424 @@ +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Support for System.Process + + (c) XT 2016 + + I've extracted this from the process library and modified it to fit the + need for the rawfilepath package. + ------------------------------------------------------------------------- */ + +/* XXX This is a nasty hack; should put everything necessary in this package */ +#include "HsBase.h" +#include "Rts.h" + +#include "execvpe.h" + +#include +#include +#include +#include + +#include "processFlags.h" + + +// If a process was terminated by a signal, the exit status we return +// via the System.Process API is (-signum). This encoding avoids collision with +// normal process termination status codes. See also #7229. +#define TERMSIG_EXITSTATUS(s) (-(WTERMSIG(s))) + +static long max_fd = 0; + +// Rts internal API, not exposed in a public header file: +extern void blockUserSignals(void); +extern void unblockUserSignals(void); + +// See #1593. The convention for the exit code when +// exec() fails seems to be 127 (gleened from C's +// system()), but there's no equivalent convention for +// chdir(), so I'm picking 126 --SimonM. +#define forkChdirFailed 126 +#define forkExecFailed 127 + +// These are arbitrarily chosen -- JP +#define forkSetgidFailed 124 +#define forkSetuidFailed 125 + +__attribute__((__noreturn__)) +static void childFailed(int pipe, int failCode) { + int err; + ssize_t unused __attribute__((unused)); + + err = errno; + unused = write(pipe, &failCode, sizeof(failCode)); + unused = write(pipe, &err, sizeof(err)); + // As a fallback, exit with the failCode + _exit(failCode); +} + +pid_t +runInteractiveProcess (char *const args[], + char *workingDirectory, char **environment, + int fdStdIn, int fdStdOut, int fdStdErr, + int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, + gid_t *childGroup, uid_t *childUser, + int reset_int_quit_handlers, + int flags, + char **failed_doing) +{ + int close_fds = ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0); + int pid; + int fdStdInput[2], fdStdOutput[2], fdStdError[2]; + int forkCommunicationFds[2]; + int r; + int failCode, err; + + // Ordering matters here, see below [Note #431]. + if (fdStdIn == -1) { + r = pipe(fdStdInput); + if (r == -1) { + *failed_doing = "runInteractiveProcess: pipe"; + return -1; + } + } + if (fdStdOut == -1) { + r = pipe(fdStdOutput); + if (r == -1) { + *failed_doing = "runInteractiveProcess: pipe"; + return -1; + } + } + if (fdStdErr == -1) { + r = pipe(fdStdError); + if (r == -1) { + *failed_doing = "runInteractiveProcess: pipe"; + return -1; + } + } + + r = pipe(forkCommunicationFds); + if (r == -1) { + *failed_doing = "runInteractiveProcess: pipe"; + return -1; + } + + // Block signals with Haskell handlers. The danger here is that + // with the threaded RTS, a signal arrives in the child process, + // the RTS writes the signal information into the pipe (which is + // shared between parent and child), and the parent behaves as if + // the signal had been raised. + blockUserSignals(); + + // See #4074. Sometimes fork() gets interrupted by the timer + // signal and keeps restarting indefinitely. + stopTimer(); + + switch(pid = fork()) + { + case -1: + unblockUserSignals(); + startTimer(); + if (fdStdIn == -1) { + close(fdStdInput[0]); + close(fdStdInput[1]); + } + if (fdStdOut == -1) { + close(fdStdOutput[0]); + close(fdStdOutput[1]); + } + if (fdStdErr == -1) { + close(fdStdError[0]); + close(fdStdError[1]); + } + close(forkCommunicationFds[0]); + close(forkCommunicationFds[1]); + *failed_doing = "fork"; + return -1; + + case 0: + // WARNING! We may now be in the child of vfork(), and any + // memory we modify below may also be seen in the parent + // process. + + close(forkCommunicationFds[0]); + fcntl(forkCommunicationFds[1], F_SETFD, FD_CLOEXEC); + + if ((flags & RUN_PROCESS_NEW_SESSION) != 0) { + setsid(); + } + if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { + setpgid(0, 0); + } + + if ( childGroup) { + if ( setgid( *childGroup) != 0) { + // ERROR + childFailed(forkCommunicationFds[1], forkSetgidFailed); + } + } + + if ( childUser) { + if ( setuid( *childUser) != 0) { + // ERROR + childFailed(forkCommunicationFds[1], forkSetuidFailed); + } + } + + unblockUserSignals(); + + if (workingDirectory) { + if (chdir (workingDirectory) < 0) { + childFailed(forkCommunicationFds[1], forkChdirFailed); + } + } + + // [Note #431]: Ordering matters here. If any of the FDs + // 0,1,2 were initially closed, then our pipes may have used + // these FDs. So when we dup2 the pipe FDs down to 0,1,2, we + // must do it in that order, otherwise we could overwrite an + // FD that we need later. + + if (fdStdIn == -1) { + if (fdStdInput[0] != STDIN_FILENO) { + dup2 (fdStdInput[0], STDIN_FILENO); + close(fdStdInput[0]); + } + close(fdStdInput[1]); + } else if (fdStdIn == -2) { + close(STDIN_FILENO); + } else { + dup2(fdStdIn, STDIN_FILENO); + } + + if (fdStdOut == -1) { + if (fdStdOutput[1] != STDOUT_FILENO) { + dup2 (fdStdOutput[1], STDOUT_FILENO); + close(fdStdOutput[1]); + } + close(fdStdOutput[0]); + } else if (fdStdOut == -2) { + close(STDOUT_FILENO); + } else { + dup2(fdStdOut, STDOUT_FILENO); + } + + if (fdStdErr == -1) { + if (fdStdError[1] != STDERR_FILENO) { + dup2 (fdStdError[1], STDERR_FILENO); + close(fdStdError[1]); + } + close(fdStdError[0]); + } else if (fdStdErr == -2) { + close(STDERR_FILENO); + } else { + dup2(fdStdErr, STDERR_FILENO); + } + + if (close_fds) { + int i; + if (max_fd == 0) { +#if HAVE_SYSCONF + max_fd = sysconf(_SC_OPEN_MAX); + if (max_fd == -1) { + max_fd = 256; + } +#else + max_fd = 256; +#endif + } + // XXX Not the pipe + for (i = 3; i < max_fd; i++) { + if (i != forkCommunicationFds[1]) { + close(i); + } + } + } + + /* Reset the SIGINT/SIGQUIT signal handlers in the child, if requested + */ + if (reset_int_quit_handlers) { + struct sigaction dfl; + (void)sigemptyset(&dfl.sa_mask); + dfl.sa_flags = 0; + dfl.sa_handler = SIG_DFL; + (void)sigaction(SIGINT, &dfl, NULL); + (void)sigaction(SIGQUIT, &dfl, NULL); + } + + /* the child */ + if (environment) { + // XXX Check result + execvpe(args[0], args, environment); + } else { + // XXX Check result + execvp(args[0], args); + } + + childFailed(forkCommunicationFds[1], forkExecFailed); + + default: + if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { + setpgid(pid, pid); + } + if (fdStdIn == -1) { + close(fdStdInput[0]); + fcntl(fdStdInput[1], F_SETFD, FD_CLOEXEC); + *pfdStdInput = fdStdInput[1]; + } + if (fdStdOut == -1) { + close(fdStdOutput[1]); + fcntl(fdStdOutput[0], F_SETFD, FD_CLOEXEC); + *pfdStdOutput = fdStdOutput[0]; + } + if (fdStdErr == -1) { + close(fdStdError[1]); + fcntl(fdStdError[0], F_SETFD, FD_CLOEXEC); + *pfdStdError = fdStdError[0]; + } + close(forkCommunicationFds[1]); + fcntl(forkCommunicationFds[0], F_SETFD, FD_CLOEXEC); + + break; + } + + // If the child process had a problem, then it will tell us via the + // forkCommunicationFds pipe. First we try to read what the problem + // was. Note that if none of these conditionals match then we fall + // through and just return pid. + r = read(forkCommunicationFds[0], &failCode, sizeof(failCode)); + if (r == -1) { + *failed_doing = "runInteractiveProcess: read pipe"; + pid = -1; + } + else if (r == sizeof(failCode)) { + // This is the case where we successfully managed to read + // the problem + switch (failCode) { + case forkChdirFailed: + *failed_doing = "runInteractiveProcess: chdir"; + break; + case forkExecFailed: + *failed_doing = "runInteractiveProcess: exec"; + break; + case forkSetgidFailed: + *failed_doing = "runInteractiveProcess: setgid"; + break; + case forkSetuidFailed: + *failed_doing = "runInteractiveProcess: setuid"; + default: + *failed_doing = "runInteractiveProcess: unknown"; + break; + } + // Now we try to get the errno from the child + r = read(forkCommunicationFds[0], &err, sizeof(err)); + if (r == -1) { + *failed_doing = "runInteractiveProcess: read pipe"; + } + else if (r != sizeof(failCode)) { + *failed_doing = "runInteractiveProcess: read pipe bad length"; + } + else { + // If we succeed then we set errno. It'll be saved and + // restored again below. Note that in any other case we'll + // get the errno of whatever else went wrong instead. + errno = err; + } + + // We forked the child, but the child had a problem and stopped so it's + // our responsibility to reap here as nobody else can. + waitpid(pid, NULL, 0); + + pid = -1; + } + else if (r != 0) { + *failed_doing = "runInteractiveProcess: read pipe bad length"; + pid = -1; + } + + if (pid == -1) { + err = errno; + } + + close(forkCommunicationFds[0]); + + unblockUserSignals(); + startTimer(); + + if (pid == -1) { + errno = err; + } + + return pid; +} + +int +terminateProcess (pid_t handle) +{ + return (kill(handle, SIGTERM) == 0); +} + +int +getProcessExitCode (pid_t handle, int *pExitCode) +{ + int wstat, res; + + *pExitCode = 0; + + if ((res = waitpid(handle, &wstat, WNOHANG)) > 0) + { + if (WIFEXITED(wstat)) + { + *pExitCode = WEXITSTATUS(wstat); + return 1; + } + else + if (WIFSIGNALED(wstat)) + { + *pExitCode = TERMSIG_EXITSTATUS(wstat); + return 1; + } + else + { + /* This should never happen */ + } + } + + if (res == 0) return 0; + + if (errno == ECHILD) + { + *pExitCode = 0; + return 1; + } + + return -1; +} + +int waitForProcess (pid_t handle, int *pret) +{ + int wstat; + + if (waitpid(handle, &wstat, 0) < 0) + { + return -1; + } + + if (WIFEXITED(wstat)) { + *pret = WEXITSTATUS(wstat); + return 0; + } + else { + if (WIFSIGNALED(wstat)) + { + *pret = TERMSIG_EXITSTATUS(wstat); + return 0; + } + else + { + /* This should never happen */ + } + } + + return -1; +} diff --git a/rawfilepath.cabal b/rawfilepath.cabal --- a/rawfilepath.cabal +++ b/rawfilepath.cabal @@ -1,12 +1,12 @@ name: rawfilepath -version: 0.1.0.0 +version: 0.1.1 synopsis: Use RawFilePath instead of FilePath description: Please see README.md homepage: https://github.com/xtendo-org/rawfilepath#readme -license: BSD3 +license: Apache-2.0 license-file: LICENSE author: XT -maintainer: xtendo@protonmail.com +maintainer: e@xtendo.org copyright: 2016 XT category: System build-type: Simple @@ -19,20 +19,38 @@ exposed-modules: Data.ByteString.RawFilePath, System.RawFilePath + System.Process.RawFilePath + other-modules: + RawFilePath.Import + System.Process.RawFilePath.Common + System.Process.RawFilePath.Internal + System.Process.RawFilePath.Posix + c-sources: + cbits/runProcess.c + cbits/processFlags.h + cbits/processFlags.c + include-dirs: cbits build-depends: bytestring, unix, base >= 4.7 && < 5 default-language: Haskell2010 default-extensions: + BangPatterns + CPP + LambdaCase OverloadedStrings + RecordWildCards test-suite RawFilePath-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - build-depends: base - , rawfilepath + build-depends: + bytestring, + + base, + rawfilepath ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Data/ByteString/RawFilePath.hs b/src/Data/ByteString/RawFilePath.hs --- a/src/Data/ByteString/RawFilePath.hs +++ b/src/Data/ByteString/RawFilePath.hs @@ -1,17 +1,17 @@ -- | -- Module : Data.ByteString.RawFilePath -- Copyright : (c) XT 2016 --- License : BSD-style +-- License : Apache 2.0 -- -- Maintainer : e@xtendo.org -- Stability : experimental -- Portability : POSIX -- --- A variant of @Data.ByteString@ from the @bytestring@ package that provides --- file I/O functions with 'RawFilePath' instead of 'FilePath'. +-- A drop-in replacement of @Data.ByteString@ from the @bytestring@ package +-- that provides file I/O functions with 'RawFilePath' instead of 'FilePath'. module Data.ByteString.RawFilePath - ( module B + ( module Data.ByteString , RawFilePath , readFile , writeFile @@ -29,19 +29,19 @@ -- extra modules import System.Posix.ByteString -import Data.ByteString as B hiding (readFile, writeFile, appendFile) +import Data.ByteString hiding (readFile, writeFile, appendFile) -- | Read an entire file at the 'RawFilePath' strictly into a 'ByteString'. readFile :: RawFilePath -> IO ByteString -readFile path = withFile path ReadMode B.hGetContents +readFile path = withFile path ReadMode hGetContents -- | Write a 'ByteString' to a file at the 'RawFilePath'. writeFile :: RawFilePath -> ByteString -> IO () -writeFile path content = withFile path WriteMode (`B.hPut` content) +writeFile path content = withFile path WriteMode (`hPut` content) -- | Append a 'ByteString' to a file at the 'RawFilePath'. appendFile :: RawFilePath -> ByteString -> IO () -appendFile path content = withFile path AppendMode (`B.hPut` content) +appendFile path content = withFile path AppendMode (`hPut` content) -- | Acquire a file handle and perform an I/O action. The file will be closed -- on exit or when this I/O action throws an exception. diff --git a/src/RawFilePath/Import.hs b/src/RawFilePath/Import.hs new file mode 100644 --- /dev/null +++ b/src/RawFilePath/Import.hs @@ -0,0 +1,31 @@ +module RawFilePath.Import + ( module Module + , ByteString + , RawFilePath + ) where + +import Control.Concurrent as Module +import Control.Exception as Module +import Control.Monad as Module +import Data.Bits as Module +import Data.Maybe as Module +import Data.Monoid as Module +import Data.Typeable as Module +import Data.Word as Module +import Foreign as Module hiding (void) +import Foreign.C as Module +import GHC.IO.Device as Module hiding (close, getEcho, setEcho) +import GHC.IO.Encoding as Module +import GHC.IO.Exception as Module +import GHC.IO.Handle.FD as Module +import GHC.IO.Handle.Internals as Module +import GHC.IO.Handle.Types as Module +import GHC.IO.IOMode as Module +import System.Exit as Module +import System.IO as Module +import System.IO.Error as Module +import System.IO.Unsafe as Module + +import Data.ByteString (ByteString) +import System.Posix.Types as Module +import System.Posix.ByteString (RawFilePath) diff --git a/src/System/Process/RawFilePath.hs b/src/System/Process/RawFilePath.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/RawFilePath.hs @@ -0,0 +1,168 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Process.RawFilePath +-- Copyright : (C) XT et al. 2017 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : e@xtendo.org +-- Stability : experimental +-- Portability : POSIX +-- +-- Welcome to @System.Process.RawFilePath@, a small part of the Haskell +-- community's effort to purge 'String' for the Greater Good. +-- +-- With this module, you can create (and interact with) sub-processes without +-- the encoding problem of 'String'. The command and its arguments, all +-- 'ByteString's, never get converted from/to 'String' internally on its way +-- to the actual syscall. It also avoids the time/space waste of 'String'. +-- +-- The interface, unlike the original @process@ package, uses types to prevent +-- unnecessary runtime errors when obtaining 'Handle's. This is inspired by +-- the @typed-process@ package which is awesome, although this module is much +-- simpler; it doesn't introduce any new requirement of language extension or +-- library package (for the sake of portability). +-- +-- 'Handle' (accessible with 'processStdin', 'processStdout', and +-- 'processStderr') is what you can use to interact with the sub-process. For +-- example, use 'Data.ByteString.hGetContents' from "Data.ByteString" to read +-- from a 'Handle' as a 'ByteString'. +-- +-- == Example +-- +-- @ +-- {-\# language OverloadedStrings \#-} +-- +-- import System.Process.RawFilePath +-- import qualified Data.ByteString as B +-- +-- main :: IO () +-- main = do +-- p <- 'startProcess' $ 'proc' "echo" ["hello"] +-- \`setStdout\` 'CreatePipe' +-- result <- B.hGetContents ('processStdout' p) +-- _ <- 'waitForProcess' p +-- +-- print (result == "hello\\n") +-- @ +-- +----------------------------------------------------------------------------- + + +module System.Process.RawFilePath + ( + -- ** Configuring process + -- $configuring + ProcessConf + , proc + + -- *** Configuring process standard streams + , StreamType + , CreatePipe(..) + , Inherit(..) + , NoStream(..) + , UseHandle(..) + , setStdin + , setStdout + , setStderr + + -- ** Running process + , Process + , startProcess + + -- ** Obtaining process streams + -- $obtaining + , processStdin + , processStdout + , processStderr + + -- ** Process completion + , stopProcess + , terminateProcess + , waitForProcess + + ) where + +-- base modules + +import RawFilePath.Import hiding (ClosedHandle) + +-- local modules + +import System.Process.RawFilePath.Common +import System.Process.RawFilePath.Internal +import System.Process.RawFilePath.Posix + +-- | Start a new sub-process with the given configuration. +startProcess + :: (StreamType stdin, StreamType stdout, StreamType stderr) + => ProcessConf stdin stdout stderr + -> IO (Process stdin stdout stderr) +startProcess = createProcessInternal + +-- | Stop a sub-process. For now it simply calls 'terminateProcess' and then +-- 'waitForProcess'. +stopProcess :: Process stdin stdout stderr -> IO ExitCode +stopProcess p = do + terminateProcess p + waitForProcess p + +-- | Wait (block) for a sub-process to exit and obtain its exit code. +waitForProcess + :: Process stdin stdout stderr + -> IO ExitCode +waitForProcess ph = lockWaitpid $ do + p_ <- modifyProcessHandle ph $ \ p_ -> return (p_,p_) + case p_ of + ClosedHandle e -> return e + OpenHandle h -> do + e <- alloca $ \ pret -> do + -- don't hold the MVar while we call c_waitForProcess... + throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) + modifyProcessHandle ph $ \ p_' -> + case p_' of + ClosedHandle e -> return (p_', e) + OpenExtHandle{} -> return (p_', ExitFailure (-1)) + OpenHandle ph' -> do + closePHANDLE ph' + code <- peek pret + let e = if code == 0 + then ExitSuccess + else ExitFailure (fromIntegral code) + return (ClosedHandle e, e) + when delegatingCtlc $ + endDelegateControlC e + return e + OpenExtHandle _ _job _iocp -> + return $ ExitFailure (-1) + where + -- If more than one thread calls `waitpid` at a time, `waitpid` will + -- return the exit code to one of them and (-1) to the rest of them, + -- causing an exception to be thrown. + -- Cf. https://github.com/haskell/process/issues/46, and + -- https://github.com/haskell/process/pull/58 for further discussion + lockWaitpid m = withMVar (waitpidLock ph) $ \ () -> m + delegatingCtlc = mbDelegateCtlc ph + +-- | Terminate a sub-process by sending SIGTERM to it. +terminateProcess :: Process stdin stdout stderr -> IO () +terminateProcess p = withProcessHandle p $ \ case + ClosedHandle _ -> return () + OpenExtHandle{} -> error + "terminateProcess with OpenExtHandle should not happen on POSIX." + OpenHandle h -> do + throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h + return () + -- does not close the handle, we might want to try terminating it + -- again, or get its exit code. + + +-- $configuring +-- +-- Configuration of how a new sub-process will be launched. +-- +-- $obtaining +-- +-- As the type signature suggests, these functions only work on processes +-- whose stream in configured to 'CreatePipe'. This is the type-safe way of +-- obtaining 'Handle's instead of returning 'Maybe' 'Handle's like the +-- @process@ package does. diff --git a/src/System/Process/RawFilePath/Common.hs b/src/System/Process/RawFilePath/Common.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/RawFilePath/Common.hs @@ -0,0 +1,243 @@ +module System.Process.RawFilePath.Common + ( Process(..) + , ProcessConf(..) + , proc + , processStdin + , processStdout + , processStderr + , StreamType + , mbFd + , willCreateHandle + , CreatePipe(..) + , Inherit(..) + , NoStream(..) + , UseHandle(..) + , setStdin + , setStdout + , setStderr + + , PHANDLE + , ProcessHandle__(..) + , modifyProcessHandle + , withProcessHandle + , fdStdin + , fdStdout + , fdStderr + , mbPipe + ) where + +import RawFilePath.Import + +-- extra modules + +import System.Posix.Internals (FD) +import qualified GHC.IO.FD as FD + +-- Original declarations + +-- | The process configuration that is needed for creating new processes. Use +-- 'proc' to make one. +data ProcessConf stdin stdout stderr = ProcessConf + { cmdargs :: [ByteString] + -- ^ Executable & arguments, or shell command + , cwd :: Maybe RawFilePath + -- ^ Optional path to the working directory for the new process + , env :: Maybe [(ByteString, ByteString)] + -- ^ Optional environment (otherwise inherit from the current process) + , cfgStdin :: stdin + -- ^ How to determine stdin + , cfgStdout :: stdout + -- ^ How to determine stdout + , cfgStderr :: stderr + -- ^ How to determine stderr + , closeFds :: Bool + -- ^ Close all file descriptors except stdin, stdout and stderr in the new + -- process + , createGroup :: Bool + -- ^ Create a new process group + , delegateCtlc :: Bool + -- ^ Delegate control-C handling. Use this for interactive console + -- processes to let them handle control-C themselves (see below for + -- details). + , createNewConsole :: Bool + -- ^ Use the windows CREATE_NEW_CONSOLE flag when creating the process; + -- does nothing on other platforms. + -- + -- Default: @False@ + , newSession :: Bool + -- ^ Use posix setsid to start the new process in a new session; does nothing on other platforms. + , childGroup :: Maybe GroupID + -- ^ Use posix setgid to set child process's group id. + -- + -- Default: @Nothing@ + , childUser :: Maybe UserID + -- ^ Use posix setuid to set child process's user id. + -- + -- Default: @Nothing@ + } + +-- | Create a process configuration with the default settings. +proc + :: RawFilePath -- ^ Command to run + -> [ByteString] -- ^ Arguments to the command + -> ProcessConf Inherit Inherit Inherit +proc cmd args = ProcessConf + { cmdargs = cmd : args + , cwd = Nothing + , env = Nothing + , cfgStdin = Inherit + , cfgStdout = Inherit + , cfgStderr = Inherit + , closeFds = False + , createGroup = False + , delegateCtlc = False + , createNewConsole = False + , newSession = False + , childGroup = Nothing + , childUser = Nothing + } + +-- | Control how the standard input of the process will be initialized. +setStdin + :: (StreamType newStdin) + => ProcessConf oldStdin stdout stderr + -> newStdin + -> ProcessConf newStdin stdout stderr +setStdin p newStdin = p { cfgStdin = newStdin } +infixl 4 `setStdin` + +-- | Control how the standard output of the process will be initialized. +setStdout + :: (StreamType newStdout) + => ProcessConf stdin oldStdout stderr + -> newStdout + -> ProcessConf stdin newStdout stderr +setStdout p newStdout = p { cfgStdout = newStdout } +infixl 4 `setStdout` + +-- | Control how the standard error of the process will be initialized. +setStderr + :: (StreamType newStderr) + => ProcessConf stdin stdout oldStderr + -> newStderr + -> ProcessConf stdin stdout newStderr +setStderr p newStderr = p { cfgStderr = newStderr } +infixl 4 `setStderr` + +-- | The process type. The three type variables denote how its standard +-- streams were initialized. +data Process stdin stdout stderr = Process + { procStdin :: Maybe Handle + , procStdout :: Maybe Handle + , procStderr :: Maybe Handle + , phandle :: !(MVar ProcessHandle__) + , mbDelegateCtlc :: !Bool + , waitpidLock :: !(MVar ()) + } + +-- | Take a process and return its standard input handle. +processStdin :: Process CreatePipe stdout stderr -> Handle +processStdin Process{..} = fromMaybe err procStdin + where + err = error "This can't happen: stdin is CreatePipe but missing" + +-- | Take a process and return its standard output handle. +processStdout :: Process stdin CreatePipe stderr -> Handle +processStdout Process{..} = fromMaybe err procStdout + where + err = error "This can't happen: stdout is CreatePipe but missing" + +-- | Take a process and return its standard error handle. +processStderr :: Process stdin stdout CreatePipe -> Handle +processStderr Process{..} = fromMaybe err procStderr + where + err = error "This can't happen: stderr is CreatePipe but missing" + +-- | Create a new pipe for the stream. You get a new 'Handle'. +data CreatePipe = CreatePipe deriving Show +-- | Inherit the parent (current) process handle. The child will share the +-- stream. For example, if the child writes anything to stdout, it will all go +-- to the parent's stdout. +data Inherit = Inherit deriving Show +-- | No stream handle will be passed. Use when you don't want to communicate +-- with a stream. For example, to run something silently. +data NoStream = NoStream deriving Show +-- | Use the supplied 'Handle'. +data UseHandle = UseHandle Handle deriving Show + +-- | The class of types that determine the standard stream of a sub-process. +-- You can decide how to initialize the standard streams (stdin, stdout, and +-- stderr) of a sub-process with the instances of this class. +class StreamType c where + mbFd :: FD -> c -> IO FD + willCreateHandle :: c -> Bool +#if __GLASGOW_HASKELL__ >= 780 + mbFd = undefined + willCreateHandle = undefined + {-# MINIMAL #-} +#endif +instance StreamType CreatePipe where + mbFd _ _ = return (-1) + willCreateHandle _ = True +instance StreamType Inherit where + mbFd std _ = return std + willCreateHandle _ = False +instance StreamType NoStream where + mbFd _ _ = return (-2) + willCreateHandle _ = False +instance StreamType UseHandle where + mbFd _std (UseHandle hdl) = + withHandle "" hdl $ \Handle__{haDevice=dev,..} -> case cast dev of + Just fd -> do + -- clear the O_NONBLOCK flag on this FD, if it is set, since + -- we're exposing it externally (see #3316 of 'process') + fd' <- FD.setNonBlockingMode fd False + return (Handle__{haDevice=fd',..}, FD.fdFD fd') + Nothing -> ioError $ mkIOError illegalOperationErrorType + "createProcess" (Just hdl) Nothing + `ioeSetErrorString` "handle is not a file descriptor" + willCreateHandle _ = False + +-- Declarations from the process package (modified) + +type PHANDLE = CPid + +data ProcessHandle__ = OpenHandle PHANDLE + | OpenExtHandle PHANDLE PHANDLE PHANDLE + | ClosedHandle ExitCode + +modifyProcessHandle + :: Process stdin stdout stderr + -> (ProcessHandle__ -> IO (ProcessHandle__, a)) + -> IO a +modifyProcessHandle p = modifyMVar (phandle p) + +withProcessHandle + :: Process stdin stdout stderr -> (ProcessHandle__ -> IO a) -> IO a +withProcessHandle p = withMVar (phandle p) + +fdStdin, fdStdout, fdStderr :: FD +fdStdin = 0 +fdStdout = 1 +fdStderr = 2 + +mbPipe :: StreamType c => c -> Ptr FD -> IOMode -> IO (Maybe Handle) +mbPipe streamConf pfd mode = if willCreateHandle streamConf + then fmap Just (pfdToHandle pfd mode) + else return Nothing + +pfdToHandle :: Ptr FD -> IOMode -> IO Handle +pfdToHandle pfd mode = do + fd <- peek pfd + let filepath = "fd:" ++ show fd + (fD,fd_type) <- FD.mkFD (fromIntegral fd) mode + (Just (Stream,0,0)) -- avoid calling fstat() + False {-is_socket-} + False {-non-blocking-} + fD' <- FD.setNonBlockingMode fD True -- see #3316 +#if __GLASGOW_HASKELL__ >= 704 + enc <- getLocaleEncoding +#else + let enc = localeEncoding +#endif + mkHandleFromFD fD' fd_type filepath mode False {-is_socket-} (Just enc) diff --git a/src/System/Process/RawFilePath/Internal.hs b/src/System/Process/RawFilePath/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/RawFilePath/Internal.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE InterruptibleFFI #-} + +module System.Process.RawFilePath.Internal + ( c_terminateProcess + , c_getProcessExitCode + , c_waitForProcess + ) where + +import Foreign +import Foreign.C + +import System.Posix.Types (CPid (..)) + +import System.Process.RawFilePath.Common + +foreign import ccall unsafe "terminateProcess" + c_terminateProcess + :: PHANDLE + -> IO CInt + +foreign import ccall unsafe "getProcessExitCode" + c_getProcessExitCode + :: PHANDLE + -> Ptr CInt + -> IO CInt + +foreign import ccall interruptible "waitForProcess" -- NB. safe - can block + c_waitForProcess + :: PHANDLE + -> Ptr CInt + -> IO CInt diff --git a/src/System/Process/RawFilePath/Posix.hs b/src/System/Process/RawFilePath/Posix.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/RawFilePath/Posix.hs @@ -0,0 +1,223 @@ +module System.Process.RawFilePath.Posix + ( createProcessInternal + , withCEnvironment + , closePHANDLE + , startDelegateControlC + , endDelegateControlC + , stopDelegateControlC + , c_execvpe + , pPrPr_disableITimers + , createPipe + , createPipeInternalFd + ) where + +import RawFilePath.Import + +-- extra modules + +import Data.ByteString.Internal (ByteString(..), memcpy) +import System.Posix.ByteString.FilePath (withFilePath) +import System.Posix.Internals hiding (withFilePath) +import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe ) +import System.Posix.Signals +import qualified System.Posix.Signals as Sig +import qualified System.Posix.IO as Posix + +-- local modules + +import System.Process.RawFilePath.Common + +#include "processFlags.h" + +closePHANDLE :: PHANDLE -> IO () +closePHANDLE _ = return () + +-- ---------------------------------------------------------------------------- +-- Utils + +withManyByteString :: [ByteString] -> (Ptr CString -> IO a) -> IO a +withManyByteString bs action = + allocaBytes wholeLength $ \ buf -> + allocaBytes ptrLength $ \ cs -> do + copyByteStrings bs buf cs + action (castPtr cs) + where + ptrLength = (length bs + 1) * sizeOf (undefined :: Ptr CString) + wholeLength = sum (map (\ (PS _ _ l) -> l + 1) bs) + +copyByteStrings :: [ByteString] -> Ptr Word8 -> Ptr (Ptr Word8) -> IO () +copyByteStrings [] _ cs = poke cs nullPtr +copyByteStrings (PS fp o l : xs) buf cs = withForeignPtr fp $ \ p -> do + memcpy buf (p `plusPtr` o) (fromIntegral l) + pokeByteOff buf l (0 :: Word8) + poke cs (buf :: Ptr Word8) + copyByteStrings xs (buf `plusPtr` (l + 1)) + (cs `plusPtr` sizeOf (undefined :: Ptr CString)) + +withCEnvironment :: [(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a +withCEnvironment envir act = + let env' = map (\(name, val) -> name <> "=" <> val) envir + in withManyByteString env' act + +-- ----------------------------------------------------------------------------- +-- POSIX runProcess with signal handling in the child + +createProcessInternal + :: (StreamType stdin, StreamType stdout, StreamType stderr) + => ProcessConf stdin stdout stderr + -> IO (Process stdin stdout stderr) +createProcessInternal ProcessConf{..} + = alloca $ \ pfdStdInput -> + alloca $ \ pfdStdOutput -> + alloca $ \ pfdStdError -> + alloca $ \ pFailedDoing -> + maybeWith withCEnvironment env $ \pEnv -> + maybeWith withFilePath cwd $ \pWorkDir -> + maybeWith with childGroup $ \pChildGroup -> + maybeWith with childUser $ \pChildUser -> + withManyByteString cmdargs $ \pargs -> do + + fdin <- mbFd fdStdin cfgStdin + fdout <- mbFd fdStdout cfgStdout + fderr <- mbFd fdStderr cfgStderr + + when delegateCtlc startDelegateControlC + + -- runInteractiveProcess() blocks signals around the fork(). + -- Since blocking/unblocking of signals is a global state + -- operation, we better ensure mutual exclusion of calls to + -- runInteractiveProcess(). + procHandle <- withMVar runInteractiveProcessLock $ \_ -> + c_runInteractiveProcess pargs pWorkDir pEnv + fdin fdout fderr + pfdStdInput pfdStdOutput pfdStdError + pChildGroup pChildUser + (if delegateCtlc then 1 else 0) + ((if closeFds then RUN_PROCESS_IN_CLOSE_FDS else 0) + .|.(if createGroup then RUN_PROCESS_IN_NEW_GROUP else 0) + .|.(if createNewConsole then RUN_PROCESS_NEW_CONSOLE else 0) + .|.(if newSession then RUN_PROCESS_NEW_SESSION else 0)) + pFailedDoing + + when (procHandle == -1) $ do + cFailedDoing <- peek pFailedDoing + failedDoing <- peekCString cFailedDoing + when delegateCtlc stopDelegateControlC + -- TODO(XT): avoid String + throwErrno (show (head cmdargs) ++ ": " ++ failedDoing) + + hIn <- mbPipe cfgStdin pfdStdInput WriteMode + hOut <- mbPipe cfgStdout pfdStdOutput ReadMode + hErr <- mbPipe cfgStderr pfdStdError ReadMode + + mvarProcHandle <- newMVar (OpenHandle procHandle) + lock <- newMVar () + return (Process hIn hOut hErr mvarProcHandle delegateCtlc lock) + +{-# NOINLINE runInteractiveProcessLock #-} +runInteractiveProcessLock :: MVar () +runInteractiveProcessLock = unsafePerformIO $ newMVar () + +-- ---------------------------------------------------------------------------- +-- Delegated control-C handling on Unix + +-- See ticket https://ghc.haskell.org/trac/ghc/ticket/2301 +-- and http://www.cons.org/cracauer/sigint.html +-- +-- While running an interactive console process like ghci or a shell, we want +-- to let that process handle Ctl-C keyboard interrupts how it sees fit. +-- So that means we need to ignore the SIGINT/SIGQUIT Unix signals while we're +-- running such programs. And then if/when they do terminate, we need to check +-- if they terminated due to SIGINT/SIGQUIT and if so then we behave as if we +-- got the Ctl-C then, by throwing the UserInterrupt exception. +-- +-- If we run multiple programs like this concurrently then we have to be +-- careful to avoid messing up the signal handlers. We keep a count and only +-- restore when the last one has finished. + +{-# NOINLINE runInteractiveProcessDelegateCtlc #-} +runInteractiveProcessDelegateCtlc :: MVar (Maybe (Int, Sig.Handler, Sig.Handler)) +runInteractiveProcessDelegateCtlc = unsafePerformIO $ newMVar Nothing + +startDelegateControlC :: IO () +startDelegateControlC = + modifyMVar_ runInteractiveProcessDelegateCtlc $ \ case + Nothing -> do + -- We're going to ignore ^C in the parent while there are any + -- processes using ^C delegation. + -- + -- If another thread runs another process without using + -- delegation while we're doing this then it will inherit the + -- ignore ^C status. + old_int <- installHandler sigINT Ignore Nothing + old_quit <- installHandler sigQUIT Ignore Nothing + return (Just (1, old_int, old_quit)) + + Just (count, old_int, old_quit) -> do + -- If we're already doing it, just increment the count + let !count' = count + 1 + return (Just (count', old_int, old_quit)) + +stopDelegateControlC :: IO () +stopDelegateControlC = + modifyMVar_ runInteractiveProcessDelegateCtlc $ \ case + Just (1, old_int, old_quit) -> do + -- Last process, so restore the old signal handlers + _ <- installHandler sigINT old_int Nothing + _ <- installHandler sigQUIT old_quit Nothing + return Nothing + + Just (count, old_int, old_quit) -> do + -- Not the last, just decrement the count + let !count' = count - 1 + return (Just (count', old_int, old_quit)) + + Nothing -> return Nothing -- should be impossible + +endDelegateControlC :: ExitCode -> IO () +endDelegateControlC exitCode = do + stopDelegateControlC + + -- And if the process did die due to SIGINT or SIGQUIT then + -- we throw our equivalent exception here (synchronously). + -- + -- An alternative design would be to throw to the main thread, as the + -- normal signal handler does. But since we can be sync here, we do so. + -- It allows the code locally to catch it and do something. + case exitCode of + ExitFailure n | isSigIntQuit n -> throwIO UserInterrupt + _ -> return () + where + isSigIntQuit n = sig == sigINT || sig == sigQUIT + where + sig = fromIntegral (-n) + +foreign import ccall unsafe "runInteractiveProcess" + c_runInteractiveProcess + :: Ptr CString + -> CString + -> Ptr CString + -> FD + -> FD + -> FD + -> Ptr FD + -> Ptr FD + -> Ptr FD + -> Ptr CGid + -> Ptr CUid + -> CInt -- reset child's SIGINT & SIGQUIT handlers + -> CInt -- flags + -> Ptr CString + -> IO PHANDLE + +createPipe :: IO (Handle, Handle) +createPipe = do + (readfd, writefd) <- Posix.createPipe + readh <- Posix.fdToHandle readfd + writeh <- Posix.fdToHandle writefd + return (readh, writeh) + +createPipeInternalFd :: IO (FD, FD) +createPipeInternalFd = do + (Fd readfd, Fd writefd) <- Posix.createPipe + return (readfd, writefd) diff --git a/src/System/RawFilePath.hs b/src/System/RawFilePath.hs --- a/src/System/RawFilePath.hs +++ b/src/System/RawFilePath.hs @@ -3,7 +3,7 @@ -- | -- Module : System.RawFilePath -- Copyright : (c) XT 2016 --- License : BSD-style +-- License : Apache 2.0 -- -- Maintainer : e@xtendo.org -- Stability : experimental diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,12 @@ +{-# language OverloadedStrings #-} + +import System.Process.RawFilePath +import qualified Data.ByteString as B + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = do + p <- startProcess $ proc "echo" ["hello"] `setStdout` CreatePipe + result <- B.hGetContents (processStdout p) + _ <- waitForProcess p + + print (result == "hello\n")