basis-library/mlton/process.sml

   1 (* Copyright (C) 2009 Matthew Fluet.
   2  * Copyright (C) 2002-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 structure MLtonProcess =
  10    struct
  11       structure Prim = PrimitiveFFI.MLton.Process
  12       structure MLton = Primitive.MLton
  13       local
  14          open Posix
  15       in
  16          structure FileSys = FileSys
  17          structure IO = IO
  18          structure ProcEnv = ProcEnv
  19          structure Process = Process
  20          structure FileDesc = PrePosix.FileDesc
  21          structure PId = PrePosix.PId
  22          structure Signal = PrePosix.Signal
  23       end
  24       structure Mask = MLtonSignal.Mask
  25       structure SysCall = PosixError.SysCall
  26
  27       type pid = PId.t
  28
  29       exception MisuseOfForget
  30       exception DoublyRedirected
  31
  32       type input = unit
  33       type output = unit
  34
  35       type none = unit
  36       type chain = unit
  37       type any = unit
  38
  39       val useWindowsProcess = MLton.Platform.OS.useWindowsProcess
  40
  41       val readWrite =
  42         let
  43            open FileSys.S
  44         in
  45            flags [irusr, iwusr, irgrp, iwgrp, iroth, iwoth]
  46         end
  47
  48       structure Child =
  49          struct
  50             datatype 'use childt =
  51                FileDesc of FileSys.file_desc
  52              | Stream of 'use * ('use -> unit)
  53              | Term
  54             type ('use, 'dir) t = 'use childt ref
  55
  56             (* This is _not_ the identity; by rebuilding it we get type
  57              * ('a, 'b) t -> ('c, 'd) t
  58              *)
  59             fun remember x =
  60                case !x of
  61                   FileDesc f =>
  62                      (x := Stream ((), fn () => ())
  63                       ; ref (FileDesc f))
  64                 | Stream _ => raise MisuseOfForget (* remember twice = bad *)
  65                 | Term => ref Term
  66
  67             local
  68                fun convert (new, close) p =
  69                   case !p of
  70                      FileDesc fd =>
  71                         let
  72                            val str = new (fd, "<process>")
  73                            val () = p := Stream (str, close)
  74                         in
  75                            str
  76                         end
  77                    | Stream (str, _) => str
  78                    | Term => raise MisuseOfForget
  79             in
  80                val binIn = convert (BinIO.newIn, BinIO.closeIn)
  81                val binOut = convert (BinIO.newOut, BinIO.closeOut)
  82                val textIn = convert (TextIO.newIn, TextIO.closeIn)
  83                val textOut = convert (TextIO.newOut, TextIO.closeOut)
  84             end
  85
  86             fun fd p =
  87                case !p of
  88                   FileDesc fd => fd
  89                 | _ => raise MisuseOfForget
  90
  91             fun close ch =
  92                case ch of
  93                   FileDesc fd => IO.close fd
  94                 | Stream (str, close) => close str
  95                 | Term => ()
  96
  97             val close =
  98                fn (stdin, stdout, stderr) =>
  99                (close stdin; close stdout; close stderr)
 100          end
 101
 102       structure Param =
 103          struct
 104             datatype ('use, 'dir) t =
 105                File of string
 106              | FileDesc of FileSys.file_desc
 107              | Pipe
 108              | Self
 109
 110             (* This is _not_ the identity; by rebuilding it we get type
 111              * ('a, 'b) t -> ('c, 'd) t
 112              *)
 113             val forget = fn
 114                File x => File x
 115              | FileDesc f => FileDesc f
 116              | Pipe => Pipe
 117              | Self => Self
 118
 119             val pipe = Pipe
 120             local
 121                val null = if useWindowsProcess then "nul" else "/dev/null"
 122             in
 123                val null = File null
 124             end
 125             val self = Self
 126             fun file f = File f
 127             fun fd f = FileDesc f
 128
 129             fun child c =
 130                FileDesc
 131                (case !c of
 132                    Child.FileDesc f => (c := Child.Stream ((), fn () => ()); f)
 133                  | Child.Stream _ => raise DoublyRedirected
 134                  | Child.Term  => raise MisuseOfForget)
 135
 136             fun setCloseExec fd =
 137                if useWindowsProcess
 138                   then ()
 139                else IO.setfd (fd, IO.FD.flags [IO.FD.cloexec])
 140
 141             local
 142                fun openOut std p =
 143                   case p of
 144                      File s => (FileSys.creat (s, readWrite), Child.Term)
 145                    | FileDesc f => (f, Child.Term)
 146                    | Pipe =>
 147                         let
 148                            val {infd, outfd} = IO.pipe ()
 149                            val () = setCloseExec infd
 150                         in
 151                            (outfd, Child.FileDesc infd)
 152                         end
 153                    | Self => (std, Child.Term)
 154             in
 155                fun openStdout p = openOut FileSys.stdout p
 156                fun openStderr p = openOut FileSys.stderr p
 157             end
 158
 159             fun openStdin p =
 160                case p of
 161                   File s =>
 162                      (FileSys.openf (s, FileSys.O_RDONLY, FileSys.O.flags []),
 163                       Child.Term)
 164                 | FileDesc f => (f, Child.Term)
 165                 | Pipe =>
 166                      let
 167                         val {infd, outfd} = IO.pipe ()
 168                         val () = setCloseExec outfd
 169                      in
 170                         (infd, Child.FileDesc outfd)
 171                      end
 172                 | Self => (FileSys.stdin, Child.Term)
 173
 174             fun close p fd =
 175                case p of
 176                   File _ => IO.close fd
 177                 | FileDesc _ => IO.close fd
 178                 | Pipe => IO.close fd
 179                 | _ => ()
 180         end
 181
 182       datatype ('stdin, 'stdout, 'stderr) t =
 183          T of {pid: Process.pid, (* if useWindowsProcess,
 184                                   * then this is a Windows process handle
 185                                   * and can't be passed to
 186                                   * Posix.Process.* functions.
 187                                   *)
 188                status: Posix.Process.exit_status option ref,
 189                stderr: ('stderr, input) Child.t,
 190                stdin:  ('stdin, output) Child.t,
 191                stdout: ('stdout, input) Child.t}
 192
 193       local
 194          fun make f (T r) = f r
 195       in
 196          val getStderr = fn z => make #stderr z
 197          val getStdin = fn z => make #stdin z
 198          val getStdout = fn z => make #stdout z
 199       end
 200
 201       fun ('a, 'b) protect (f: 'a -> 'b, x: 'a): 'b =
 202          let
 203             val () = Mask.block Mask.all
 204          in
 205             DynamicWind.wind (fn () => f x, fn () => Mask.unblock Mask.all)
 206          end
 207
 208       local
 209          fun reap reapFn (T {pid, status, stderr, stdin, stdout, ...}) =
 210             case !status of
 211                NONE =>
 212                   let
 213                      val _ = Child.close (!stdin, !stdout, !stderr)
 214                      val st = reapFn pid
 215                   in
 216                      status := SOME st
 217                      ; st
 218                   end
 219              | SOME st => st
 220       in
 221          fun reapForFork p =
 222             reap (fn pid =>
 223                   let
 224                      (* protect is probably too much; typically, one
 225                       * would only mask SIGINT, SIGQUIT and SIGHUP.
 226                       *)
 227                      val (_, st) =
 228                         protect (Process.waitpid, (Process.W_CHILD pid, []))
 229                   in
 230                      st
 231                   end)
 232                   p
 233          fun reapForCreate p =
 234             reap (fn pid =>
 235                   let
 236                      val pid' = PId.toRep pid
 237                      val status' = ref (C_Status.fromInt 0)
 238                      val () =
 239                         SysCall.simple
 240                         (fn () =>
 241                          PrimitiveFFI.Windows.Process.getexitcode
 242                          (pid', status'))
 243                   in
 244                      Process.fromStatus' (!status')
 245                   end)
 246                  p
 247       end
 248       val reap = fn p =>
 249          (if useWindowsProcess then reapForCreate else reapForFork) p
 250
 251       local
 252          fun kill killFn (p as T {pid, status, ...}, signal) =
 253             case !status of
 254                NONE =>
 255                   let
 256                      val () = killFn (pid, signal)
 257                   in
 258                      ignore (reap p)
 259                   end
 260              | SOME _ => ()
 261       in
 262          fun killForFork p =
 263             kill (fn (pid, signal) =>
 264                   Process.kill (Process.K_PROC pid, signal))
 265                  p
 266          fun killForCreate p =
 267             kill (fn (pid, signal) =>
 268                   SysCall.simple
 269                   (fn () =>
 270                    PrimitiveFFI.Windows.Process.terminate
 271                    (PId.toRep pid, Signal.toRep signal)))
 272                  p
 273       end
 274       val kill = fn (p, signal) =>
 275          (if useWindowsProcess then killForCreate else killForFork) (p, signal)
 276
 277       fun launchWithFork (path, args, env, stdin, stdout, stderr) =
 278          case protect (Process.fork, ()) of
 279             NONE => (* child *)
 280                let
 281                   fun dup2 (old, new) =
 282                      if old = new
 283                         then ()
 284                      else (IO.dup2 {old = old, new = new}; IO.close old)
 285                   val args = path :: args
 286                   val execTh =
 287                      case env of
 288                         NONE =>
 289                            (fn () => Process.exec (path, args))
 290                       | SOME env =>
 291                            (fn () => Process.exece (path, args, env))
 292                in
 293                   dup2 (stdin, FileSys.stdin)
 294                   ; dup2 (stdout, FileSys.stdout)
 295                   ; dup2 (stderr, FileSys.stderr)
 296                   ; ignore (execTh ())
 297                   ; Process.exit 0w127 (* just in case *)
 298                end
 299           | SOME pid => pid (* parent *)
 300
 301       fun strContains seps s =
 302         CharVector.exists (Char.contains seps) s
 303       (* In MinGW, a string must be escaped if it contains " \t" or is "".
 304        * Escaping means adds "s on the front and end. Any quotes inside
 305        * must be escaped with \. Any \s already in the string must be
 306        * doubled ONLY when they precede a " or the end of string.
 307        *)
 308       fun mingwEscape (l, 0) = l
 309         | mingwEscape (l, i) = mingwEscape (#"\\"::l, i-1)
 310       fun mingwFold (#"\\", (l, escapeCount)) = (#"\\"::l, escapeCount+1)
 311         | mingwFold (#"\"", (l, escapeCount)) =
 312             (#"\"" :: mingwEscape (#"\\"::l, escapeCount), 0)
 313         | mingwFold (x, (l, _)) = (x :: l, 0)
 314       val mingwQuote = mingwEscape o CharVector.foldl mingwFold ([#"\""], 0)
 315       fun mingwEscape y =
 316          if not (strContains " \t\"" y) andalso y<>"" then y else
 317          String.implode (List.rev (#"\"" :: mingwQuote y))
 318
 319       fun cygwinEscape y =
 320          if not (strContains " \t\"\r\n\f'" y) andalso y<>"" then y else
 321          concat ["\"",
 322                  String.translate
 323                  (fn #"\"" => "\\\"" | #"\\" => "\\\\" | x => String.str x) y,
 324                  "\""]
 325
 326       val cmdEscapeCreate =
 327          if MLton.Platform.OS.host = MLton.Platform.OS.MinGW
 328          then mingwEscape else cygwinEscape
 329
 330       val cmdEscapeSpawn =
 331          if MLton.Platform.OS.host = MLton.Platform.OS.MinGW
 332          then mingwEscape else (fn s => s)
 333
 334       fun launchWithCreate (path, args, env, stdin, stdout, stderr) =
 335          let
 336             val path' =
 337                NullString.nullTerm
 338                (let
 339                    open MLton.Platform.OS
 340                 in
 341                    case host of
 342                       Cygwin => Cygwin.toFullWindowsPath path
 343                     | MinGW => path
 344                     | _ => raise Fail "MLton.Process.launchWithCreate: path'"
 345                 end)
 346             val args' =
 347                NullString.nullTerm
 348                (String.concatWith " " (List.map cmdEscapeCreate (path :: args)))
 349             val env' =
 350                Option.map
 351                (fn env =>
 352                 NullString.nullTerm
 353                 ((String.concatWith "\000" env) ^ "\000"))
 354                env
 355             val stdin' = FileDesc.toRep stdin
 356             val stdout' = FileDesc.toRep stdout
 357             val stderr' = FileDesc.toRep stderr
 358             val createTh =
 359                case env' of
 360                   NONE =>
 361                      (fn () =>
 362                       PrimitiveFFI.Windows.Process.createNull
 363                       (path', args', stdin', stdout', stderr'))
 364                 | SOME env' =>
 365                      (fn () =>
 366                       PrimitiveFFI.Windows.Process.create
 367                       (path', args', env', stdin', stdout', stderr'))
 368             val pid' =
 369                SysCall.simpleResult'
 370                ({errVal = C_PId.castFromFixedInt ~1}, fn () =>
 371                 createTh ())
 372             val pid = PId.fromRep pid'
 373          in
 374             pid
 375          end
 376
 377       val launch =
 378          fn z =>
 379          (if useWindowsProcess then launchWithCreate else launchWithFork) z
 380
 381       fun create {args, env, path, stderr, stdin, stdout} =
 382          if not (FileSys.access (path, [FileSys.A_EXEC]))
 383             then PosixError.raiseSys PosixError.noent
 384          else
 385             let
 386                val () = TextIO.flushOut TextIO.stdOut
 387                val (fstdin, cstdin) = Param.openStdin stdin
 388                val (fstdout, cstdout) = Param.openStdout stdout
 389                val (fstderr, cstderr) = Param.openStderr stderr
 390                val closeStdio =
 391                   fn () => (Param.close stdin fstdin
 392                             ; Param.close stdout fstdout
 393                             ; Param.close stderr fstderr)
 394                val pid =
 395                   launch (path, args, env, fstdin, fstdout, fstderr)
 396                   handle ex => (closeStdio ()
 397                                 ; Child.close (cstdin, cstdout, cstderr)
 398                                 ; raise ex)
 399                val () = closeStdio ()
 400             in
 401                T {pid = pid,
 402                   status = ref NONE,
 403                   stderr = ref cstderr,
 404                   stdin = ref cstdin,
 405                   stdout = ref cstdout}
 406             end
 407
 408       fun spawne {path, args, env} =
 409          if useWindowsProcess
 410             then
 411                let
 412                   val args = List.map cmdEscapeSpawn args
 413                   val path = NullString.nullTerm path
 414                   val args = CUtil.C_StringArray.fromList args
 415                   val env = CUtil.C_StringArray.fromList env
 416                in
 417                   (PId.fromRep o SysCall.simpleResult')
 418                   ({errVal = C_PId.castFromFixedInt ~1}, fn () =>
 419                    Prim.spawne (path, args, env))
 420                end
 421          else
 422             case Posix.Process.fork () of
 423                NONE => (Posix.Process.exece (path, args, env) handle _ => ()
 424                         ; Posix.Process.exit 0w127)
 425              | SOME pid => pid
 426
 427       fun spawn {args, path}=
 428          spawne {args = args,
 429                  env = ProcEnv.environ (),
 430                  path = path}
 431
 432       fun spawnp {args, file} =
 433          if useWindowsProcess
 434             then
 435                let
 436                   val file = NullString.nullTerm file
 437                   val args = List.map cmdEscapeSpawn args
 438                   val args = CUtil.C_StringArray.fromList args
 439                in
 440                   (PId.fromRep o SysCall.simpleResult')
 441                   ({errVal = C_PId.castFromFixedInt ~1}, fn () =>
 442                    Prim.spawnp (file, args))
 443                end
 444          else
 445             case Posix.Process.fork () of
 446                NONE => (Posix.Process.execp (file, args) handle _ => ()
 447                         ; Posix.Process.exit 0w127)
 448              | SOME pid => pid
 449
 450       open Exit
 451    end