rawfilepath 0.1.0.0 → 0.1.1
raw patch · 14 files changed
+1509/−32 lines, 14 filesdep ~basedep ~bytestring
Dependency ranges changed: base, bytestring
Files
- LICENSE +329/−16
- README.md +5/−1
- cbits/processFlags.c +1/−0
- cbits/processFlags.h +11/−0
- cbits/runProcess.c +424/−0
- rawfilepath.cabal +23/−5
- src/Data/ByteString/RawFilePath.hs +8/−8
- src/RawFilePath/Import.hs +31/−0
- src/System/Process/RawFilePath.hs +168/−0
- src/System/Process/RawFilePath/Common.hs +243/−0
- src/System/Process/RawFilePath/Internal.hs +31/−0
- src/System/Process/RawFilePath/Posix.hs +223/−0
- src/System/RawFilePath.hs +1/−1
- test/Spec.hs +11/−1
LICENSE view
@@ -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 <https://e.xtendo.org/>+ 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 <https://e.xtendo.org/>++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.++-----------------------------------------------------------------------------
README.md view
@@ -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
+ cbits/processFlags.c view
@@ -0,0 +1,1 @@+#include "processFlags.h"
+ cbits/processFlags.h view
@@ -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
+ cbits/runProcess.c view
@@ -0,0 +1,424 @@+/* ----------------------------------------------------------------------------+ (c) The University of Glasgow 2004++ Support for System.Process++ (c) XT <https://e.xtendo.org/> 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 <unistd.h>+#include <sys/types.h>+#include <fcntl.h>+#include <signal.h>++#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;+}
rawfilepath.cabal view
@@ -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
src/Data/ByteString/RawFilePath.hs view
@@ -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.
+ src/RawFilePath/Import.hs view
@@ -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)
+ src/System/Process/RawFilePath.hs view
@@ -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.
+ src/System/Process/RawFilePath/Common.hs view
@@ -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)
+ src/System/Process/RawFilePath/Internal.hs view
@@ -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
+ src/System/Process/RawFilePath/Posix.hs view
@@ -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)
src/System/RawFilePath.hs view
@@ -3,7 +3,7 @@ -- | -- Module : System.RawFilePath -- Copyright : (c) XT 2016--- License : BSD-style+-- License : Apache 2.0 -- -- Maintainer : e@xtendo.org -- Stability : experimental
test/Spec.hs view
@@ -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")