diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index fa11a60ab9f..e1112f2a2bf 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -8,8 +8,14 @@ If available, link to an existing issue this PR fixes. For example: ## TODO +Feel free to open the PR and ask for help + - [] New (API-)documentation for new features exist (Note: API-docs are enough, additional docs are in `help/markdown`) - [] unit or integration test exists (or short reasoning why it doesn't make sense) + + > Note: Consider using the `CreateProcess` API which can be tested more easily, see https://github.com/fsharp/FAKE/pull/2131/files#diff-4fb4a77e110fbbe8210205dfe022389b for an example (the changes in the `DotNet.Testing.NUnit` module) + +- [] boy scout rule: "leave the code behind in a better state than you found it" (fix warnings, obsolete members or code-style in the places you worked in) - [] (if new module) the module has been linked from the "Modules" menu, edit `help/templates/template.cshtml`, linking to the API-reference is fine. - [] (if new module) the module is in the correct namespace - [] (if new module) the module is added to Fake.sln (`dotnet sln Fake.sln add src/app/Fake.*/Fake.*.fsproj`) diff --git a/src/app/Fake.Core.Context/Context.fs b/src/app/Fake.Core.Context/Context.fs index 38ba8cf0a69..aeae09362ec 100644 --- a/src/app/Fake.Core.Context/Context.fs +++ b/src/app/Fake.Core.Context/Context.fs @@ -36,6 +36,12 @@ type internal RuntimeContextWrapper(t: RuntimeContext) = inherit System.MarshalByRefObject() #endif member x.Type = t + override x.ToString() = + match t with + | Fake f -> sprintf "Wrapper(ScriptFile=%s)" f.ScriptFile + | UnknownObj o -> sprintf "Wrapper(UnknownObj=%O)" o + | Unknown -> sprintf "Wrapper(Unknown)" + #if USE_ASYNC_LOCAL open System.Threading @@ -54,6 +60,7 @@ let private getDataDict() = #endif let private setContext (name:string) (o : obj) : unit = + //printfn "set context '%s' -> %A, threadId '%d'" name o System.Threading.Thread.CurrentThread.ManagedThreadId #if USE_ASYNC_LOCAL let d = getDataDict() d.AddOrUpdate(name, o, fun _ old -> o) |> ignore @@ -62,15 +69,17 @@ let private setContext (name:string) (o : obj) : unit = #endif let private getContext (name:string) : obj = + let result = #if USE_ASYNC_LOCAL - let d = getDataDict() - match d.TryGetValue(name) with - | true, v -> v - | false, _ -> null + let d = getDataDict() + match d.TryGetValue(name) with + | true, v -> v + | false, _ -> null #else - System.Runtime.Remoting.Messaging.CallContext.LogicalGetData(name) + System.Runtime.Remoting.Messaging.CallContext.LogicalGetData(name) #endif - + //printfn "get context '%s' -> '%A', threadId '%d'" name result System.Threading.Thread.CurrentThread.ManagedThreadId + result let private fake_ExecutionType = "fake_context_execution_type" let getExecutionContext () = @@ -81,6 +90,8 @@ let getExecutionContext () = let setExecutionContext (e:RuntimeContext) = setContext fake_ExecutionType (new RuntimeContextWrapper(e)) +let removeExecutionContext () = setContext fake_ExecutionType null + let getFakeExecutionContext (e:RuntimeContext) = match e with | RuntimeContext.UnknownObj _ diff --git a/src/app/Fake.Core.Process/CmdLineParsing.fs b/src/app/Fake.Core.Process/CmdLineParsing.fs index 1a24d5f093f..0118fbe626e 100644 --- a/src/app/Fake.Core.Process/CmdLineParsing.fs +++ b/src/app/Fake.Core.Process/CmdLineParsing.fs @@ -3,7 +3,7 @@ module internal CmdLineParsing = let escapeCommandLineForShell (cmdLine:string) = sprintf "'%s'" (cmdLine.Replace("'", "'\\''")) - let windowsArgvToCommandLine args = + let windowsArgvToCommandLine shorten args = let escapeBackslashes (sb:System.Text.StringBuilder) (s:string) (lastSearchIndex:int) = // Backslashes must be escaped if and only if they precede a double quote. [ lastSearchIndex .. -1 .. 0] @@ -14,25 +14,29 @@ module internal CmdLineParsing = let sb = new System.Text.StringBuilder() for (s:string) in args do - sb.Append('"') |> ignore - // Escape double quotes (") and backslashes (\). - let mutable searchIndex = 0 - - // Put this test first to support zero length strings. - let mutable quoteIndex = 0 - while searchIndex < s.Length && quoteIndex >= 0 do + if shorten && s.Length > 0 && s.IndexOfAny([|' '; '\"'; '\\'; '\t'|]) < 0 then + sb.Append s |> ignore + sb.Append " " |> ignore + else + sb.Append('"') |> ignore + // Escape double quotes (") and backslashes (\). + let mutable searchIndex = 0 + + // Put this test first to support zero length strings. + let mutable quoteIndex = 0 + while searchIndex < s.Length && quoteIndex >= 0 do - quoteIndex <- s.IndexOf('"', searchIndex) - if quoteIndex >= 0 then - sb.Append(s, searchIndex, quoteIndex - searchIndex) |> ignore - escapeBackslashes sb s (quoteIndex - 1) - sb.Append('\\') |> ignore - sb.Append('"') |> ignore - searchIndex <- quoteIndex + 1 - - sb.Append(s, searchIndex, s.Length - searchIndex) |> ignore - escapeBackslashes sb s (s.Length - 1) - sb.Append(@""" ") |> ignore + quoteIndex <- s.IndexOf('"', searchIndex) + if quoteIndex >= 0 then + sb.Append(s, searchIndex, quoteIndex - searchIndex) |> ignore + escapeBackslashes sb s (quoteIndex - 1) + sb.Append('\\') |> ignore + sb.Append('"') |> ignore + searchIndex <- quoteIndex + 1 + + sb.Append(s, searchIndex, s.Length - searchIndex) |> ignore + escapeBackslashes sb s (s.Length - 1) + sb.Append(@""" ") |> ignore sb.ToString(0, System.Math.Max(0, sb.Length - 1)) @@ -100,7 +104,7 @@ module internal CmdLineParsing = results.ToArray() let toProcessStartInfo args = - let cmd = windowsArgvToCommandLine args + let cmd = windowsArgvToCommandLine true args if Environment.isMono && Environment.isLinux then // See https://bugzilla.xamarin.com/show_bug.cgi?id=19296 cmd.Replace("\\$", "\\\\$").Replace("\\`", "\\\\`") @@ -108,15 +112,19 @@ module internal CmdLineParsing = type FilePath = string +/// Helper functions for proper command line parsing module Args = - let toWindowsCommandLine args = CmdLineParsing.windowsArgvToCommandLine args + /// Convert the given argument list to a conforming windows command line string, escapes parameter in quotes if needed (currently always but this might change). + let toWindowsCommandLine args = CmdLineParsing.windowsArgvToCommandLine true args + /// Escape the given argument list according to a unix shell (bash) let toLinuxShellCommandLine args = System.String.Join(" ", args |> Seq.map CmdLineParsing.escapeCommandLineForShell) - + /// Read a windows command line string into its arguments let fromWindowsCommandLine cmd = CmdLineParsing.windowsCommandLineToArgv cmd - + +/// Represents a list of arguments type Arguments = - { Args : string array } + internal { Args : string array } static member Empty = { Args = [||] } /// See https://msdn.microsoft.com/en-us/library/17w5ykft.aspx static member OfWindowsCommandLine cmd = @@ -126,6 +134,15 @@ type Arguments = member x.ToWindowsCommandLine = Args.toWindowsCommandLine x.Args member x.ToLinuxShellCommandLine = Args.toLinuxShellCommandLine x.Args - static member OfArgs args = { Args = args } + /// Create a new arguments object from the given list of arguments + static member OfArgs (args:string seq) = { Args = args |> Seq.toArray } + /// Create a new arguments object from a given startinfo-conforming-escaped command line string. static member OfStartInfo cmd = Arguments.OfWindowsCommandLine cmd - member internal x.ToStartInfo = CmdLineParsing.toProcessStartInfo x.Args + /// Create a new command line string which can be used in a ProcessStartInfo object. + member x.ToStartInfo = CmdLineParsing.toProcessStartInfo x.Args + +module Arguments = + let withPrefix s (a:Arguments) = + Arguments.OfArgs(Seq.append s a.Args) + let append s (a:Arguments) = + Arguments.OfArgs(Seq.append a.Args s) \ No newline at end of file diff --git a/src/app/Fake.Core.Process/CreateProcess.fs b/src/app/Fake.Core.Process/CreateProcess.fs new file mode 100644 index 00000000000..72c3e500272 --- /dev/null +++ b/src/app/Fake.Core.Process/CreateProcess.fs @@ -0,0 +1,496 @@ +namespace Fake.Core + +open System +open System.IO +open System.Diagnostics +open Fake.Core.ProcessHelpers + +/// Hook for events when an CreateProcess is executed. +type internal IProcessHook<'TRes> = + abstract member PrepareState : unit -> IDisposable + abstract member PrepareStreams : IDisposable * StreamSpecs -> StreamSpecs + abstract member ProcessStarted : IDisposable * System.Diagnostics.Process -> unit + abstract member RetrieveResult : IDisposable * System.Threading.Tasks.Task -> Async<'TRes> + +type internal IProcessHookImpl<'TState, 'TRes when 'TState :> IDisposable> = + abstract member PrepareState : unit -> 'TState + abstract member PrepareStreams : 'TState * StreamSpecs -> StreamSpecs + abstract member ProcessStarted : 'TState * System.Diagnostics.Process -> unit + abstract member RetrieveResult : 'TState * System.Threading.Tasks.Task -> Async<'TRes> + +module internal ProcessHook = + let toRawHook (h:IProcessHookImpl<'TState,'TRes>) = + { new IProcessHook<'TRes> with + member x.PrepareState () = + let state = h.PrepareState () + state :> IDisposable + member x.PrepareStreams (state, specs) = + h.PrepareStreams (state :?> 'TState, specs) + member x.ProcessStarted (state, proc) = + h.ProcessStarted (state :?> 'TState, proc) + member x.RetrieveResult (state, exitCode) = + h.RetrieveResult (state :?> 'TState, exitCode) } + + +/// The output of the process. If ordering between stdout and stderr is important you need to use streams. +type ProcessOutput = { Output : string; Error : string } + +type ProcessResult<'a> = { Result : 'a; ExitCode : int } + +/// Generator for results +//type ResultGenerator<'TRes> = +// { GetRawOutput : unit -> ProcessOutput +// GetResult : ProcessOutput -> 'TRes } +/// Handle for creating a process and returning potential results. +type CreateProcess<'TRes> = + internal { + Command : Command + WorkingDirectory : string option + Environment : EnvMap option + Streams : StreamSpecs + Hook : IProcessHook<'TRes> + } + + //member x.OutputRedirected = x.HasRedirect + member x.CommandLine = x.Command.CommandLine + + +/// Module for creating and modifying CreateProcess<'TRes> instances +module CreateProcess = + let internal emptyHook = + { new IProcessHook> with + member __.PrepareState () = null + member __.PrepareStreams (_, specs) = specs + member __.ProcessStarted (_,_) = () + member __.RetrieveResult (_, t) = + async { + let! raw = Async.AwaitTaskWithoutAggregate t + return { ExitCode = raw.RawExitCode; Result = () } + } } + + (*let internal ofProc (x:RawCreateProcess) = + { Command = x.Command + WorkingDirectory = x.WorkingDirectory + Environment = x.Environment + Streams = x.Streams + Hook = + { new IProcessHook with + member __.PrepareStart specs = x.OutputHook.Prepare specs + member __.ProcessStarted (state, p) = x.OutputHook.OnStart(state, p) + member __.RetrieveResult (s, t) = + x.OutputHook.Retrieve(s, t) } }*) + + let fromCommand command = + { Command = command + WorkingDirectory = None + // Problem: Environment not allowed when using ShellCommand + Environment = None + Streams = + { // Problem: Redirection not allowed when using ShellCommand + StandardInput = Inherit + // Problem: Redirection not allowed when using ShellCommand + StandardOutput = Inherit + // Problem: Redirection not allowed when using ShellCommand + StandardError = Inherit } + Hook = emptyHook } + let fromRawWindowsCommandLine command windowsCommandLine = + fromCommand <| RawCommand(command, Arguments.OfWindowsCommandLine windowsCommandLine) + let fromRawCommand command args = + fromCommand <| RawCommand(command, Arguments.OfArgs args) + + let ofStartInfo (p:System.Diagnostics.ProcessStartInfo) = + { Command = if p.UseShellExecute then ShellCommand p.FileName else RawCommand(p.FileName, Arguments.OfStartInfo p.Arguments) + WorkingDirectory = if System.String.IsNullOrWhiteSpace p.WorkingDirectory then None else Some p.WorkingDirectory + Environment = + p.Environment + |> Seq.map (fun kv -> kv.Key, kv.Value) + |> EnvMap.ofSeq + |> Some + Streams = + { StandardInput = if p.RedirectStandardError then CreatePipe StreamRef.Empty else Inherit + StandardOutput = if p.RedirectStandardError then CreatePipe StreamRef.Empty else Inherit + StandardError = if p.RedirectStandardError then CreatePipe StreamRef.Empty else Inherit + } + Hook = emptyHook + } + let internal interceptStreamFallback onInherit target (s:StreamSpecification) = + match s with + | Inherit -> onInherit() + | UseStream (close, stream) -> + let combined = Stream.CombineWrite(stream, target) + UseStream(close, combined) + | CreatePipe pipe -> + CreatePipe (StreamRef.Map (fun s -> Stream.InterceptStream(s, target)) pipe) + let interceptStream target (s:StreamSpecification) = + interceptStreamFallback (fun _ -> failwithf "cannot intercept stream when it is not redirected. Please redirect the stream first!") target s + + let copyRedirectedProcessOutputsToStandardOutputs (c:CreateProcess<_>)= + { c with + Streams = + { c.Streams with + StandardOutput = + let stdOut = System.Console.OpenStandardOutput() + interceptStream stdOut c.Streams.StandardOutput + StandardError = + let stdErr = System.Console.OpenStandardError() + interceptStream stdErr c.Streams.StandardError } } + + let withWorkingDirectory workDir (c:CreateProcess<_>)= + { c with + WorkingDirectory = Some workDir } + let withCommand command (c:CreateProcess<_>)= + { c with + Command = command } + + let replaceFilePath newFilePath (c:CreateProcess<_>)= + { c with + Command = + match c.Command with + | ShellCommand s -> failwith "Expected RawCommand" + | RawCommand (_, c) -> RawCommand(newFilePath, c) } + let mapFilePath f (c:CreateProcess<_>)= + c + |> replaceFilePath (f (match c.Command with ShellCommand s -> failwith "Expected RawCommand" | RawCommand (file, _) -> f file)) + + + let internal withHook h (c:CreateProcess<_>) = + { Command = c.Command + WorkingDirectory = c.WorkingDirectory + Environment = c.Environment + Streams = c.Streams + Hook = h } + let internal withHookImpl h (c:CreateProcess<_>) = + c + |> withHook (h |> ProcessHook.toRawHook) + + let internal simpleHook prepareState prepareStreams onStart onResult = + { new IProcessHookImpl<_, _> with + member __.PrepareState () = + prepareState () + member __.PrepareStreams (state, streams) = + prepareStreams state streams + member __.ProcessStarted (state, p) = + onStart state p + member __.RetrieveResult (state, exitCode) = + onResult state exitCode } + + type internal CombinedState<'a when 'a :> IDisposable > = + { State1 : IDisposable; State2 : 'a } + interface IDisposable with + member x.Dispose() = + if not (isNull x.State1) then + x.State1.Dispose() + x.State2.Dispose() + let internal hookAppendFuncs prepareState prepareStreams onStart onResult (c:IProcessHook<'TRes>) = + { new IProcessHookImpl<_, _> with + member __.PrepareState () = + let state1 = c.PrepareState () + let state2 = prepareState () + { State1 = state1; State2 = state2 } + member __.PrepareStreams (state, streams) = + let newStreams = c.PrepareStreams(state.State1, streams) + let finalStreams = prepareStreams state.State2 newStreams + finalStreams + member __.ProcessStarted (state, p) = + c.ProcessStarted (state.State1, p) + onStart state.State2 p + member __.RetrieveResult (state, exitCode) = + async { + let d = c.RetrieveResult(state.State1, exitCode) + return! onResult d state.State2 exitCode + } } + + let internal appendFuncs prepareState prepareStreams onStart onResult (c:CreateProcess<_>) = + c + |> withHookImpl ( + c.Hook + |> hookAppendFuncs prepareState prepareStreams onStart onResult + ) + + type internal DisposableWrapper<'a> = + { State: 'a; OnDispose : 'a -> unit } + interface IDisposable with + member x.Dispose () = x.OnDispose x.State + + let internal appendFuncsDispose prepareState prepareStreams onStart onResult onDispose (c:CreateProcess<_>) = + c + |> appendFuncs + (fun () -> + let state = prepareState () + { State = state; OnDispose = onDispose }) + (fun state streams -> prepareStreams state.State streams) + (fun state p -> onStart state.State p) + (fun prev state exitCode -> onResult prev state.State exitCode) + let appendSimpleFuncs prepareState onStart onResult onDispose (c:CreateProcess<_>) = + c + |> appendFuncsDispose + prepareState + (fun state streams -> streams) + onStart + onResult + onDispose + + let addOnSetup f (c:CreateProcess<_>) = + c + |> appendSimpleFuncs + (fun _ -> f()) + (fun state p -> ()) + (fun prev state exitCode -> prev) + (fun _ -> ()) + let addOnFinally f (c:CreateProcess<_>) = + c + |> appendSimpleFuncs + (fun _ -> ()) + (fun state p -> ()) + (fun prev state exitCode -> prev) + (fun _ -> f ()) + let addOnStarted f (c:CreateProcess<_>) = + c + |> appendSimpleFuncs + (fun _ -> ()) + (fun state p -> f ()) + (fun prev state exitCode -> prev) + (fun _ -> ()) + + let withEnvironment (env: (string * string) list) (c:CreateProcess<_>)= + { c with + Environment = Some (EnvMap.ofSeq env) } + + let withEnvironmentMap (env: EnvMap) (c:CreateProcess<_>)= + { c with + Environment = Some env } + let getEnvironmentMap (c:CreateProcess<_>)= + match c.Environment with + | Some en -> en + | None -> EnvMap.create() + + let setEnvironmentVariable envKey (envVar:string) (c:CreateProcess<_>) = + { c with + Environment = + getEnvironmentMap c + |> IMap.add envKey envVar + |> Some } + + let withStandardOutput stdOut (c:CreateProcess<_>)= + { c with + Streams = + { c.Streams with + StandardOutput = stdOut } } + let withStandardError stdErr (c:CreateProcess<_>)= + { c with + Streams = + { c.Streams with + StandardError = stdErr } } + let withStandardInput stdIn (c:CreateProcess<_>)= + { c with + Streams = + { c.Streams with + StandardInput = stdIn } } + + let map f c = + c + |> appendSimpleFuncs + (fun _ -> ()) + (fun state p -> ()) + (fun prev state exitCode -> + async { + let! old = prev + return f old + }) + (fun _ -> ()) + + let mapResult f (c:CreateProcess>) = + c + |> map (fun r -> + { ExitCode = r.ExitCode; Result = f r.Result }) + let redirectOutput (c:CreateProcess<_>) = + c + |> appendFuncsDispose + (fun streams -> + let outMem = new MemoryStream() + let errMem = new MemoryStream() + outMem, errMem) + (fun (outMem, errMem) streams -> + { streams with + StandardOutput = + interceptStreamFallback (fun _ -> UseStream (false, outMem)) outMem streams.StandardOutput + StandardError = + interceptStreamFallback (fun _ -> UseStream (false, errMem)) errMem streams.StandardError + }) + (fun (outMem, errMem) p -> ()) + (fun prev (outMem, errMem) exitCode -> + async { + let! prevResult = prev + let! exitCode = exitCode |> Async.AwaitTaskWithoutAggregate + outMem.Position <- 0L + errMem.Position <- 0L + let stdErr = (new StreamReader(errMem)).ReadToEnd() + let stdOut = (new StreamReader(outMem)).ReadToEnd() + let r = { Output = stdOut; Error = stdErr } + return { ExitCode = exitCode.RawExitCode; Result = r } + }) + (fun (outMem, errMem) -> + outMem.Dispose() + errMem.Dispose()) + + let withOutputEvents onStdOut onStdErr (c:CreateProcess<_>) = + let watchStream onF (stream:System.IO.Stream) = + async { + let reader = new System.IO.StreamReader(stream) + let mutable finished = false + while not finished do + let! line = reader.ReadLineAsync() + finished <- isNull line + onF line + } + |> fun a -> Async.StartImmediateAsTask(a) + c + |> appendFuncsDispose + (fun () -> + let closeOut, outMem = InternalStreams.StreamModule.limitedStream() + let closeErr, errMem = InternalStreams.StreamModule.limitedStream() + + let outMemS = InternalStreams.StreamModule.fromInterface outMem + let errMemS = InternalStreams.StreamModule.fromInterface errMem + let tOut = watchStream onStdOut outMemS + let tErr = watchStream onStdErr errMemS + (closeOut, outMem, closeErr, errMem, tOut, tErr)) + (fun (closeOut, outMem, closeErr, errMem, tOut, tErr) streams -> + { streams with + StandardOutput = + outMem + |> InternalStreams.StreamModule.createWriteOnlyPart (fun () -> closeOut() |> Async.RunSynchronously) + |> InternalStreams.StreamModule.fromInterface + |> fun s -> interceptStream s streams.StandardOutput + StandardError = + errMem + |> InternalStreams.StreamModule.createWriteOnlyPart (fun () -> closeErr() |> Async.RunSynchronously) + |> InternalStreams.StreamModule.fromInterface + |> fun s -> interceptStream s streams.StandardError + }) + (fun state p -> ()) + (fun prev (closeOut, outMem, closeErr, errMem, tOut, tErr) exitCode -> + async { + let! prevResult = prev + do! closeOut() + do! closeErr() + do! tOut + do! tErr + return prevResult + }) + (fun (closeOut, outMem, closeErr, errMem, tOut, tErr) -> + + outMem.Dispose() + errMem.Dispose()) + + let addOnExited f (c:CreateProcess<_>) = + c + |> appendSimpleFuncs + (fun _ -> ()) + (fun state p -> ()) + (fun prev state exitCode -> + async { + let! prevResult = prev + let! e = exitCode + let s = f prevResult e.RawExitCode + return s + }) + (fun _ -> ()) + + let ensureExitCodeWithMessage msg (r:CreateProcess<_>) = + r + |> addOnExited (fun data exitCode -> + if exitCode <> 0 then failwith msg + else data) + + + let internal tryGetOutput (data:obj) = + match data with + | :? ProcessResult as output -> + Some output.Result + | :? ProcessOutput as output -> + Some output + | _ -> None + + let ensureExitCode (r:CreateProcess<_>) = + r + |> addOnExited (fun data exitCode -> + if exitCode <> 0 then + let output = tryGetOutput (data :> obj) + let msg = + match output with + | Some output -> + (sprintf "Process exit code '%d' <> 0. Command Line: %s\nStdOut: %s\nStdErr: %s" exitCode r.CommandLine output.Output output.Error) + | None -> + (sprintf "Process exit code '%d' <> 0. Command Line: %s" exitCode r.CommandLine) + failwith msg + else + data + ) + + let warnOnExitCode msg (r:CreateProcess<_>) = + r + |> addOnExited (fun data exitCode -> + if exitCode <> 0 then + let output = tryGetOutput (data :> obj) + let msg = + match output with + | Some output -> + (sprintf "%s. exit code '%d' <> 0. Command Line: %s\nStdOut: %s\nStdErr: %s" msg exitCode r.CommandLine output.Output output.Error) + | None -> + (sprintf "%s. exit code '%d' <> 0. Command Line: %s" msg exitCode r.CommandLine) + //if Env.isVerbose then + eprintfn "%s" msg + else data) + + type internal TimeoutState = + { Stopwatch : System.Diagnostics.Stopwatch + mutable HasExited : bool } + let withTimeout (timeout:System.TimeSpan) (c:CreateProcess<_>) = + c + |> appendSimpleFuncs + (fun _ -> + { Stopwatch = System.Diagnostics.Stopwatch.StartNew() + HasExited = false }) + (fun state proc -> + state.Stopwatch.Restart() + async { + let ms = int64 timeout.TotalMilliseconds + let msMax = int <| Math.Min(ms, int64 Int32.MaxValue) + do! Async.Sleep(msMax) + try + if not state.HasExited && not proc.HasExited then + proc.Kill() + with exn -> + Trace.traceError + <| sprintf "Could not kill process %s %s after timeout: %O" proc.StartInfo.FileName + proc.StartInfo.Arguments exn + } + |> Async.StartImmediate) + (fun prev state exitCode -> + async { + let! e = exitCode |> Async.AwaitTaskWithoutAggregate + state.HasExited <- true + state.Stopwatch.Stop() + let! prevResult = prev + match e.RawExitCode with + | 0 -> + return prevResult + | _ when state.Stopwatch.Elapsed > timeout -> + return failwithf "Process '%s' timed out." c.CommandLine + | _ -> + return prevResult + }) + (fun state -> state.Stopwatch.Stop()) + + type internal ProcessState = + { mutable Process : Process } + let internal getProcess (c:CreateProcess<_>) = + c + |> appendSimpleFuncs + (fun _ -> { Process = null }) + (fun state proc -> + state.Process <- proc) + (fun prev state exitCode -> + async.Return (state.Process, prev, exitCode)) + (fun state -> ()) diff --git a/src/app/Fake.Core.Process/CreateProcessExt.fs b/src/app/Fake.Core.Process/CreateProcessExt.fs new file mode 100644 index 00000000000..70303fff61f --- /dev/null +++ b/src/app/Fake.Core.Process/CreateProcessExt.fs @@ -0,0 +1,14 @@ +namespace Fake.Core + +[] +module CreateProcessExt = + module CreateProcess = + /// Ensures the executable is run with the full framework. On non-windows platforms that means running the tool by invoking 'mono'. + let withFramework (c:CreateProcess<_>) = + match Environment.isWindows, c.Command, Process.monoPath with + | false, RawCommand(file, args), Some monoPath when file.ToLowerInvariant().EndsWith(".exe") -> + { c with + Command = RawCommand(monoPath, Arguments.withPrefix ["--debug"; file] args) } + | false, RawCommand(file, args), _ when file.ToLowerInvariant().EndsWith(".exe") -> + failwithf "trying to start a .NET process on a non-windows platform, but mono could not be found. Try to set the MONO environment variable or add mono to the PATH." + | _ -> c \ No newline at end of file diff --git a/src/app/Fake.Core.Process/Fake.Core.Process.fsproj b/src/app/Fake.Core.Process/Fake.Core.Process.fsproj index d783a2d7a91..72f0fa99142 100644 --- a/src/app/Fake.Core.Process/Fake.Core.Process.fsproj +++ b/src/app/Fake.Core.Process/Fake.Core.Process.fsproj @@ -28,14 +28,18 @@ + - + - + + + + diff --git a/src/app/Fake.Core.Process/InternalStreams.fs b/src/app/Fake.Core.Process/InternalStreams.fs new file mode 100644 index 00000000000..6be482e65f1 --- /dev/null +++ b/src/app/Fake.Core.Process/InternalStreams.fs @@ -0,0 +1,654 @@ +namespace Fake.Core + +open System +open System.IO +open System.Diagnostics +open Fake.Core.ProcessHelpers + +[] +module StreamExtensions = + + type System.IO.Stream with + static member CombineWrite (target1:System.IO.Stream, target2:System.IO.Stream)= + if not target1.CanWrite || not target2.CanWrite then + raise <| System.ArgumentException("Streams need to be writeable to combine them.") + let notsupported () = raise <| System.InvalidOperationException("operation not suppotrted") + { new System.IO.Stream() with + member __.CanRead = false + member __.CanSeek = false + member __.CanTimeout = target1.CanTimeout || target2.CanTimeout + member __.CanWrite = true + member __.Length = target1.Length + member __.Position with get () = target1.Position and set _ = notsupported() + member __.Flush () = target1.Flush(); target2.Flush() + member __.FlushAsync (tok) = + async { + do! target1.FlushAsync(tok) + do! target2.FlushAsync(tok) + } + |> Async.StartImmediateAsTask + :> System.Threading.Tasks.Task + member __.Seek (_, _) = notsupported() + member __.SetLength (_) = notsupported() + member __.Read (_, _, _) = notsupported() + member __.Write (buffer, offset, count)= + target1.Write(buffer, offset, count) + target2.Write(buffer, offset, count) + override __.WriteAsync(buffer, offset, count, tok) = + async { + let! child1 = + target1.WriteAsync(buffer, offset, count, tok) + |> Async.AwaitTask + |> Async.StartChild + let! child2 = + target2.WriteAsync(buffer, offset, count, tok) + |> Async.AwaitTask + |> Async.StartChild + do! child1 + do! child2 + } + |> Async.StartImmediateAsTask + :> System.Threading.Tasks.Task + } + + static member InterceptStream (readStream:System.IO.Stream, track:System.IO.Stream)= + if not readStream.CanRead || not track.CanWrite then + raise <| System.ArgumentException("track Stream need to be writeable and readStream readable to intercept the readStream.") + { new System.IO.Stream() with + member __.CanRead = true + member __.CanSeek = readStream.CanSeek + member __.CanTimeout = readStream.CanTimeout || track.CanTimeout + member __.CanWrite = readStream.CanWrite + member __.Length = readStream.Length + member __.Position with get () = readStream.Position and set v = readStream.Position <- v + member __.Flush () = readStream.Flush(); track.Flush() + member __.FlushAsync (tok) = + async { + do! readStream.FlushAsync(tok) + do! track.FlushAsync(tok) + } + |> Async.StartImmediateAsTask + :> System.Threading.Tasks.Task + member __.Seek (offset, origin) = readStream.Seek(offset, origin) + member __.SetLength (l) = readStream.SetLength(l) + member __.Read (buffer, offset, count) = + let read = readStream.Read(buffer, offset, count) + track.Write(buffer, offset, read) + read + override __.ReadAsync (buffer, offset, count, _) = + async { + let! read = readStream.ReadAsync(buffer, offset, count) + do! track.WriteAsync(buffer, offset, read) + return read + } + |> Async.StartImmediateAsTask + member __.Write (buffer, offset, count)= + readStream.Write(buffer, offset, count) + override __.WriteAsync(buffer, offset, count, tok) = + readStream.WriteAsync(buffer, offset, count, tok) + override __.Dispose(t) = if t then readStream.Dispose() + } + + +module internal InternalStreams = + open System + open System.Threading + open System.Collections + open System.Collections.Generic + module AsyncHelper = + let FromBeginEndCancel beginAction endAction cancelAction = + let asyncResult = ref null + Async.FromBeginEnd( + (fun (callback, state) -> + asyncResult := beginAction(callback, state) + !asyncResult), + (fun res -> + endAction res), + cancelAction = (fun () -> + while !asyncResult = null do Thread.Sleep 20 + cancelAction(!asyncResult))) + open AsyncHelper + + type ConcurrentQueueMessage<'a> = + | Enqueue of 'a * AsyncReplyChannel + | Dequeue of AsyncReplyChannel> + | TryDequeue of AsyncReplyChannel> + + type ConcurrentQueue<'a>() = + let core = + let queue = Queue<'a>() + let waitingQueue = Queue>>() + MailboxProcessor.Start(fun inbox -> + let rec loop () = async { + let! msg = inbox.Receive() + match msg with + | Enqueue (item,reply) -> + try + if waitingQueue.Count > 0 then + let waiting = waitingQueue.Dequeue() + waiting.Reply (Choice1Of2 item) + else + queue.Enqueue item + reply.Reply None + with exn -> + reply.Reply (Some exn) + | Dequeue reply -> + try + if queue.Count > 0 then + let item = queue.Dequeue() + reply.Reply (Choice1Of2 item) + else + waitingQueue.Enqueue reply + with exn -> + reply.Reply (Choice2Of2 exn) + | TryDequeue reply -> + try + let item = + if queue.Count > 0 then + Some <| queue.Dequeue() + else None + reply.Reply (Choice1Of2 item) + with exn -> + reply.Reply (Choice2Of2 exn) + return! loop() } + loop()) + member x.EnqueueAsync(item) = async { + let! item = core.PostAndAsyncReply(fun reply -> Enqueue (item, reply)) + return + match item with + | Some exn -> raise exn + | None -> () } + member x.DequeAsyncTimeout(?timeout) = async { + let! result = + core.PostAndTryAsyncReply( + (fun reply -> Dequeue (reply)), ?timeout = timeout) + return + match result with + | Some r -> + match r with + | Choice1Of2 item -> Some item + | Choice2Of2 exn -> raise exn + | None -> None } + member x.DequeAsync() = async { + let! result = + core.PostAndAsyncReply( + (fun reply -> Dequeue (reply))) + return + match result with + | Choice1Of2 item -> item + | Choice2Of2 exn -> raise exn } + + member x.TryDequeAsync() = async { + let! result = core.PostAndAsyncReply(fun reply -> TryDequeue (reply)) + return + match result with + | Choice1Of2 item -> item + | Choice2Of2 exn -> raise exn } + member x.Enqueue(item) = x.EnqueueAsync item |> Async.RunSynchronously + member x.Deque() = x.DequeAsync () |> Async.RunSynchronously + member x.TryDeque() = x.TryDequeAsync () |> Async.RunSynchronously + exception ReadCanceledException + type MyIAsyncReadResult<'a> (callback:AsyncCallback, state) = + let event = new AutoResetEvent(false) + let mutable completed = false + let mutable canceled = false + let mutable data = None + let syncRoot = obj() + + interface IAsyncResult with + member x.AsyncState with get() = state + member x.IsCompleted with get() = completed + member x.AsyncWaitHandle with get() = event :> WaitHandle + member x.CompletedSynchronously with get() = false + member x.End(resultData:option<'a>) = + lock syncRoot (fun () -> + if canceled then + raise ReadCanceledException + data <- resultData + event.Set() |> ignore + if callback <> null then + callback.Invoke (x:>IAsyncResult) + completed <- true) + member x.Read + with get () = + data + member x.Cancel() = + lock syncRoot (fun () -> + if completed then + failwith "operation already completed!" + canceled <- true) + member x.IsCanceled with get() = canceled + + type IStream<'a> = + inherit IDisposable + abstract member Read : unit -> Async<'a option> + abstract member Write : 'a -> Async + type AsyncStreamHelper<'a> (innerStream:IStream<'a>) = + let queue = ConcurrentQueue>() + let workerCts = new System.Threading.CancellationTokenSource() + let worker = + Async.StartAsTask (async { + let! (cts:CancellationToken) = Async.CancellationToken + while not cts.IsCancellationRequested do + let! data = innerStream.Read() + let finished = ref false + while not !finished do + let! (asyncResult:MyIAsyncReadResult<'a>) = queue.DequeAsync() + if not asyncResult.IsCanceled then + try + asyncResult.End(data) + finished := true + with ReadCanceledException -> () // find next + return () + }, cancellationToken = workerCts.Token) + + + let beginRead(callback, state) = + let result = new MyIAsyncReadResult<'a>(callback, state) + queue.Enqueue result + result :> IAsyncResult + + let endRead(asyncResult:IAsyncResult) = + let readResult = asyncResult :?> MyIAsyncReadResult<'a> + if asyncResult.IsCompleted then + readResult.Read + else + // block for exit + WaitHandle.WaitAll ([|asyncResult.AsyncWaitHandle|]) |> ignore + readResult.Read + + let cancelRead(asyncResult:IAsyncResult) = + let readResult = asyncResult :?> MyIAsyncReadResult<'a> + readResult.Cancel() + + let read () = + AsyncHelper.FromBeginEndCancel beginRead endRead cancelRead + + interface IStream<'a> with + member x.Read() = read() + member x.Write d = innerStream.Write(d) + member x.Dispose () = innerStream.Dispose() + member x.BaseStream with get() = innerStream + static member FromAdvancedRead advancedRead count = + async { + let buffer = Array.zeroCreate count + let! read = advancedRead(buffer, 0, count) + return Array.sub buffer 0 read + } + + module StreamModule = + let createUnsupported() = + { new IStream<'a> with + member x.Dispose () = () + member x.Read () = raise <| System.NotSupportedException "" + member x.Write input = raise <| System.NotSupportedException "" } + + type StreamHelper(istream:IStream) = + inherit Stream() + let mutable cache = [||] + let mutable currentIndex = 0 + let mutable isDisposed = false + let read (dst:byte array) offset count = async { + let! newCache = + if cache.Length - currentIndex > 0 then + async.Return cache + else + async { + currentIndex <- 0 + let! data = istream.Read() + return + match data with + | Some d -> d + | None -> [||] } + cache <- newCache + // Use cache + let realCount = + Math.Min( + cache.Length - currentIndex, + count) + Array.Copy(cache, currentIndex, dst, offset, realCount) + currentIndex <- currentIndex + realCount + return realCount } + let write dst offset count = async { + if count > 0 then + let newDst = + Array.sub dst offset count + return! istream.Write newDst } + let readOne () = async { + let dst = Array.zeroCreate 1 + let! result = read dst 0 1 + return + if result = 0 then + None + else Some (dst.[0]) } + + let writeOne b = istream.Write [|b|] + let beginRead, endRead, cancelRead = + Async.AsBeginEnd(fun (dst, offset, count) -> read dst offset count) + let beginWrite, endWrite, cancelWrite = + Async.AsBeginEnd(fun (src, offset, count) -> write src offset count) + + let checkDisposed() = + if isDisposed then + raise <| ObjectDisposedException("onetimestream") + override x.ReadAsync (dst, offset, count, tok) = + Async.StartAsTask(read dst offset count, cancellationToken = tok) + override x.WriteAsync (dst, offset, count, tok) = + Async.StartAsTask(write dst offset count, cancellationToken = tok) + :> System.Threading.Tasks.Task + override x.Flush () = () + override x.Seek(offset:int64, origin:SeekOrigin) = + raise <| NotSupportedException() + override x.SetLength(value:int64) = + raise <| NotSupportedException() + //override x.BeginRead(dst, offset, count, callback, state) = + // beginRead((dst, offset, count), callback, state) + //override x.EndRead(res) = + // endRead res + member x.CancelRead(res) = + cancelRead(res) + //override x.BeginWrite(src, offset, count, callback, state) = + // beginWrite((src, offset, count), callback, state) + //override x.EndWrite(res) = + // endWrite res + member x.CancelWrite(res) = + cancelWrite(res) + override x.Read(dst, offset, count) = + read dst offset count |> Async.RunSynchronously + override x.Write(src, offset, count) = + write src offset count |> Async.RunSynchronously + override x.ReadByte() = + if isDisposed then -1 + else + match readOne() |> Async.RunSynchronously with + | Some s -> int s + | None -> -1 + override x.WriteByte item = + if not isDisposed then + writeOne item |> Async.RunSynchronously + override x.CanRead + with get() = + checkDisposed() + true + override x.CanSeek + with get() = + checkDisposed() + false + override x.CanWrite + with get() = + checkDisposed() + true + override x.Length + with get() = + raise <| NotSupportedException() + override x.Position + with get() = + raise <| NotSupportedException() + and set value = + raise <| NotSupportedException() + override x.Dispose disposing = + if not isDisposed then + isDisposed <- true + if disposing then + istream.Dispose() + base.Dispose disposing + + let fromInterface istream = new StreamHelper(istream) :> Stream + [] + module StreamExtensions = + type System.IO.Stream with + //member s.MyReadAsync(buffer:byte array,offset,count) = + // match s with + // | :? StreamHelper as helper -> helper.ReadAsync(buffer, offset, count) + // | _ -> + // Async.FromBeginEnd( + // (fun (callback, state) -> s.BeginRead(buffer, offset, count, callback, state)), + // (fun result -> s.EndRead result)) + + //member s.MyWriteAsync(buffer:byte array,offset,count) = + // match s with + // | :? StreamHelper as helper -> helper.WriteAsync(buffer, offset, count) + // | _ -> + // Async.FromBeginEnd( + // (fun (callback, state) -> s.BeginWrite(buffer, offset, count, callback, state)), + // (fun result -> s.EndWrite result)) + member s.AsyncRead c = AsyncStreamHelper<_>.FromAdvancedRead (s.ReadAsync >> Async.AwaitTask) c + member s.AsyncRead (buffer, offset, count) = Async.AwaitTask(s.ReadAsync(buffer, offset, count)) + member s.AsyncWrite (buffer, offset, count) = Async.AwaitTask(s.WriteAsync(buffer, offset, count)) + type IStream<'a> with + member s.ReadWait() = + s.Read() |> Async.RunSynchronously + member s.WriteWait(d) = + s.Write(d) |> Async.RunSynchronously + + open StreamExtensions + let toCancelAbleStream s = new AsyncStreamHelper<_>(s) :> IStream<_> + let fromReadWriteDispose dis read write = + { new IStream<_> with + member x.Read () = + read() + member x.Write item = + write item + interface IDisposable with + member x.Dispose () = dis () } |> toCancelAbleStream + let fromReadWrite read write = fromReadWriteDispose id read write + open StreamExtensions + let toInterface buffersize (stream:System.IO.Stream) = + let buffer = Array.zeroCreate buffersize + let read () = async { + let! read = stream.ReadAsync(buffer, 0, buffer.Length) + let readData = + Array.sub buffer 0 read + return + if readData.Length > 0 then + Some readData + else None } + let write (src:byte array) = async { + do! stream.AsyncWrite(src, 0, src.Length) + stream.Flush() + } + let dispose () = + // BUG: Make all AsyncRead calls end! + stream.Flush() + //stream.Close() + stream.Dispose() + fromReadWriteDispose dispose read write + let toMaybeRead read () = async { + let! data = read() + return Some data } + + + let infiniteStream () = + let queue = new ConcurrentQueue<'a>() + fromReadWrite (toMaybeRead queue.DequeAsync) queue.EnqueueAsync + + let toLimitedStream (raw:IStream<_>) = + //let raw = infiniteStream() + let readFinished = ref false + let read () = + if !readFinished then + async.Return None + else + async { + let! data = raw.Read() + return + match data with + | Some s -> + match s with + | Some d -> Some d + | None -> + readFinished := true + None + | None -> + failwith "stream should not be limited as we are using an infiniteStream!" } + let isFinished = ref false + let finish () = async { + do! raw.Write None + isFinished := true } + let write item = + if !isFinished then + failwith "stream is in finished state so it should not be written to!" + raw.Write (Some item) + finish, + fromReadWriteDispose raw.Dispose read write + let limitedStream () = toLimitedStream (infiniteStream()) + + let createWriteOnlyPart onDispose (s:IStream<'a>) = + { new IStream<'a> with + member x.Dispose () = onDispose() + member x.Read () = raise <| System.NotSupportedException "Read is not supported" + member x.Write input = s.Write input } + + let buffer (stream:IStream<_>) = + let queue = infiniteStream() + let write item = async { + do! queue.Write item + do! stream.Write item } + fromReadWrite queue.Read (fun item -> invalidOp "Write is not allowed"), + fromReadWriteDispose stream.Dispose stream.Read write + + let combineReadAndWrite (s1:IStream<_>) (s2:IStream<_>) = + fromReadWrite s1.Read s2.Write + let appendFront data (s:IStream<_>) = + let first = ref true + let read () = + if !first then + first := false + async.Return (Some data) + else + s.Read() + fromReadWriteDispose s.Dispose read s.Write + + let crossStream (s1:IStream<_>) (s2:IStream<_>) = + combineReadAndWrite s1 s2, + combineReadAndWrite s2 s1 + let map f g (s:IStream<_>) = + let read () = async { + let! read = s.Read() + return f read } + let write item = s.Write (g item) + fromReadWriteDispose s.Dispose read write + + let filterRead f (s:IStream<_>) = + let rec read () = async { + let! data = s.Read() + return! + if f data then + async.Return data + else + read () } + fromReadWriteDispose s.Dispose read s.Write + + let filterWrite f (s:IStream<_>) = + let write item = + if f item then + s.Write (item) + else async.Return () + fromReadWriteDispose s.Dispose s.Read write + + /// Duplicates the given stream, which means returning two stream instances + /// which will read the same data. + /// At the same time buffers all data (ie read from s as fast as possible). + /// Any data written to the returned instances will be written to the given instance. + let duplicate (s:IStream<_>) = + let close1, s1 = limitedStream() + let close2, s2 = limitedStream() + + let closed = ref false + async { + while not !closed do + let! data = s.Read() + match data with + | Some item -> + do! s1.Write item + do! s2.Write item + | None -> + do! close1() + do! close2() + closed := true } |> Async.Start + combineReadAndWrite s1 s, + combineReadAndWrite s2 s + + let split f s = + let s1, s2 = duplicate s + s1 |> filterRead f, + s2 |> filterRead (not << f) + //let toSeq (s:IStream<_>) = + // asyncSeq { + // while true do + // let! data = s.Read() + // yield data } + //let ofSeq write (s:AsyncSeq<_>) = + // let current = ref s + // let read () = async { + // let! next = !current + // return + // match next with + // | Nil -> failwith "end of sequence" + // | Cons(item, next) -> + // current := next + // item } + // fromReadWrite read write + + let redirect bufferLen (toStream:IStream<_>) (fromStream:IStream<_>) = + let closeRead = ref false + let cts = new System.Threading.CancellationTokenSource() + let ev = new ManualResetEvent(false) + let regularFinish = new ManualResetEvent(false) + let redirectRun = + async { + do! Async.SwitchToThreadPool() + try + let buffer = Array.zeroCreate bufferLen + let streamFinished = ref false + while not !closeRead do + let! (read:Option<_>) = fromStream.Read() + closeRead := + match read with + | Some s -> false + | None -> + streamFinished := true + true + + if read.IsSome then + do! toStream.Write(read.Value) + toStream.Dispose() + if !streamFinished then + fromStream.Dispose() + regularFinish.Set() |> ignore + finally + ev.Set() |> ignore + } + let t = Async.StartAsTask(redirectRun, cancellationToken = cts.Token) + let nT = + t.ContinueWith( + new Action>(fun t -> + ev.Set() |> ignore)) + + let closeRedirect (timeout:int) waitFinish = + let regularFinished = + if waitFinish then + // BUG: Reset the timeout when we are still doing something + System.Threading.WaitHandle.WaitAll([|regularFinish :> WaitHandle|], timeout) + else false + if not regularFinished then + closeRead := true + cts.Cancel() + ManualResetEvent.WaitAll [|ev|] |> ignore + + closeRedirect + + let defaultInput, defaultOutput, defaultError = Console.OpenStandardInput(), Console.OpenStandardOutput(), Console.OpenStandardError() + + let getStandardInput = + let iStream = toInterface 1024 defaultInput + let modified = iStream |> fromInterface + Console.SetIn(new StreamReader(modified)) + fun () -> iStream + + let getStandardOutput = + let istream = defaultOutput |> toInterface 1024 + fun () -> istream + let getStandardError = + let istream = defaultError |> toInterface 1024 + fun () -> istream diff --git a/src/app/Fake.Core.Process/Proc.fs b/src/app/Fake.Core.Process/Proc.fs deleted file mode 100644 index c3a59028fe4..00000000000 --- a/src/app/Fake.Core.Process/Proc.fs +++ /dev/null @@ -1,406 +0,0 @@ -namespace Fake.Core - -open System.IO -open System.Diagnostics -open Fake.Core.ProcessHelpers - -[] -module StreamExtensions = - - type System.IO.Stream with - static member CombineWrite (target1:System.IO.Stream, target2:System.IO.Stream)= - if not target1.CanWrite || not target2.CanWrite then - raise <| System.ArgumentException("Streams need to be writeable to combine them.") - let notsupported () = raise <| System.InvalidOperationException("operation not suppotrted") - { new System.IO.Stream() with - member __.CanRead = false - member __.CanSeek = false - member __.CanTimeout = target1.CanTimeout || target2.CanTimeout - member __.CanWrite = true - member __.Length = target1.Length - member __.Position with get () = target1.Position and set _ = notsupported() - member __.Flush () = target1.Flush(); target2.Flush() - member __.FlushAsync (tok) = - async { - do! target1.FlushAsync(tok) - do! target2.FlushAsync(tok) - } - |> Async.StartImmediateAsTask - :> System.Threading.Tasks.Task - member __.Seek (_, _) = notsupported() - member __.SetLength (_) = notsupported() - member __.Read (_, _, _) = notsupported() - member __.Write (buffer, offset, count)= - target1.Write(buffer, offset, count) - target2.Write(buffer, offset, count) - override __.WriteAsync(buffer, offset, count, tok) = - async { - let! child1 = - target1.WriteAsync(buffer, offset, count, tok) - |> Async.AwaitTask - |> Async.StartChild - let! child2 = - target2.WriteAsync(buffer, offset, count, tok) - |> Async.AwaitTask - |> Async.StartChild - do! child1 - do! child2 - } - |> Async.StartImmediateAsTask - :> System.Threading.Tasks.Task - } - - static member InterceptStream (readStream:System.IO.Stream, track:System.IO.Stream)= - if not readStream.CanRead || not track.CanWrite then - raise <| System.ArgumentException("track Stream need to be writeable and readStream readable to intercept the readStream.") - { new System.IO.Stream() with - member __.CanRead = true - member __.CanSeek = readStream.CanSeek - member __.CanTimeout = readStream.CanTimeout || track.CanTimeout - member __.CanWrite = readStream.CanWrite - member __.Length = readStream.Length - member __.Position with get () = readStream.Position and set v = readStream.Position <- v - member __.Flush () = readStream.Flush(); track.Flush() - member __.FlushAsync (tok) = - async { - do! readStream.FlushAsync(tok) - do! track.FlushAsync(tok) - } - |> Async.StartImmediateAsTask - :> System.Threading.Tasks.Task - member __.Seek (offset, origin) = readStream.Seek(offset, origin) - member __.SetLength (l) = readStream.SetLength(l) - member __.Read (buffer, offset, count) = - let read = readStream.Read(buffer, offset, count) - track.Write(buffer, offset, read) - read - override __.ReadAsync (buffer, offset, count, _) = - async { - let! read = readStream.ReadAsync(buffer, offset, count) - do! track.WriteAsync(buffer, offset, read) - return read - } - |> Async.StartImmediateAsTask - member __.Write (buffer, offset, count)= - readStream.Write(buffer, offset, count) - override __.WriteAsync(buffer, offset, count, tok) = - readStream.WriteAsync(buffer, offset, count, tok) - override __.Dispose(t) = if t then readStream.Dispose() - } - -type IProcessHook = - inherit System.IDisposable - abstract member ProcessExited : int -> unit - abstract member ParseSuccess : int -> unit -type ResultGenerator<'TRes> = - { GetRawOutput : unit -> ProcessOutput - GetResult : ProcessOutput -> 'TRes } -type CreateProcess<'TRes> = - private { - Command : Command - WorkingDirectory : string option - Environment : (string * string) list option - StandardInput : StreamSpecification - StandardOutput : StreamSpecification - StandardError : StreamSpecification - GetRawOutput : (unit -> ProcessOutput) option - Setup : unit -> IProcessHook - GetResult : ProcessOutput -> 'TRes - } - member x.Proc = - { Command = x.Command - WorkingDirectory = x.WorkingDirectory - Environment = x.Environment - StandardInput = x.StandardInput - StandardOutput = x.StandardOutput - StandardError = x.StandardError - GetRawOutput = x.GetRawOutput } - - member internal x.ToStartInfo = - x.Proc.ToStartInfo - - member x.OutputRedirected = x.OutputRedirected - member x.CommandLine = x.CommandLine - -module CreateProcess = - let emptyHook = - { new IProcessHook with - member __.Dispose () = () - member __.ProcessExited _ = () - member __.ParseSuccess _ = () } - - let ofProc x = - { Command = x.Command - WorkingDirectory = x.WorkingDirectory - Environment = x.Environment - StandardInput = x.StandardInput - StandardOutput = x.StandardOutput - StandardError = x.StandardError - GetRawOutput = x.GetRawOutput - Setup = fun _ -> emptyHook - GetResult = fun _ -> () } - - let fromCommand command = - { Command = command - WorkingDirectory = None - // Problem: Environment not allowed when using ShellCommand - Environment = None - // Problem: Redirection not allowed when using ShellCommand - StandardInput = Inherit - // Problem: Redirection not allowed when using ShellCommand - StandardOutput = Inherit - // Problem: Redirection not allowed when using ShellCommand - StandardError = Inherit - GetRawOutput = None - GetResult = fun _ -> () - Setup = fun _ -> emptyHook } - let fromRawWindowsCommandLine command windowsCommandLine = - fromCommand <| RawCommand(command, Arguments.OfWindowsCommandLine windowsCommandLine) - let fromRawCommand command args = - fromCommand <| RawCommand(command, Arguments.OfArgs args) - - let ofStartInfo (p:System.Diagnostics.ProcessStartInfo) = - { Command = if p.UseShellExecute then ShellCommand p.FileName else RawCommand(p.FileName, Arguments.OfStartInfo p.Arguments) - WorkingDirectory = if System.String.IsNullOrWhiteSpace p.WorkingDirectory then None else Some p.WorkingDirectory - Environment = - p.Environment - |> Seq.map (fun kv -> kv.Key, kv.Value) - |> Seq.toList - |> Some - StandardInput = if p.RedirectStandardError then CreatePipe StreamRef.Empty else Inherit - StandardOutput = if p.RedirectStandardError then CreatePipe StreamRef.Empty else Inherit - StandardError = if p.RedirectStandardError then CreatePipe StreamRef.Empty else Inherit - GetRawOutput = None - GetResult = fun _ -> () - Setup = fun _ -> emptyHook - } - - let interceptStream target (s:StreamSpecification) = - match s with - | Inherit -> Inherit - | UseStream (close, stream) -> - let combined = Stream.CombineWrite(stream, target) - UseStream(close, combined) - | CreatePipe pipe -> - CreatePipe (StreamRef.Map (fun s -> Stream.InterceptStream(s, target)) pipe) - - let copyRedirectedProcessOutputsToStandardOutputs (c:CreateProcess<_>)= - { c with - StandardOutput = - let stdOut = System.Console.OpenStandardOutput() - interceptStream stdOut c.StandardOutput - StandardError = - let stdErr = System.Console.OpenStandardError() - interceptStream stdErr c.StandardError } - - let withWorkingDirectory workDir (c:CreateProcess<_>)= - { c with - WorkingDirectory = Some workDir } - let withCommand command (c:CreateProcess<_>)= - { c with - Command = command } - - let replaceFilePath newFilePath (c:CreateProcess<_>)= - { c with - Command = - match c.Command with - | ShellCommand s -> failwith "Expected RawCommand" - | RawCommand (_, c) -> RawCommand(newFilePath, c) } - let mapFilePath f (c:CreateProcess<_>)= - c - |> replaceFilePath (f (match c.Command with ShellCommand s -> failwith "Expected RawCommand" | RawCommand (file, _) -> f file)) - - let private combine (d1:IProcessHook) (d2:IProcessHook) = - { new IProcessHook with - member __.Dispose () = d1.Dispose(); d2.Dispose() - member __.ProcessExited e = d1.ProcessExited(e); d2.ProcessExited(e) - member __.ParseSuccess e = d1.ParseSuccess(e); d2.ParseSuccess(e) } - let addSetup f (c:CreateProcess<_>) = - { c with - Setup = fun _ -> combine (c.Setup()) (f()) } - - let withEnvironment env (c:CreateProcess<_>)= - { c with - Environment = Some env } - let withStandardOutput stdOut (c:CreateProcess<_>)= - { c with - StandardOutput = stdOut } - let withStandardError stdErr (c:CreateProcess<_>)= - { c with - StandardError = stdErr } - let withStandardInput stdIn (c:CreateProcess<_>)= - { c with - StandardInput = stdIn } - - let private withResultFuncRaw f x = - { Command = x.Command - WorkingDirectory = x.WorkingDirectory - Environment = x.Environment - StandardInput = x.StandardInput - StandardOutput = x.StandardOutput - StandardError = x.StandardError - GetRawOutput = x.GetRawOutput - GetResult = f - Setup = x.Setup } - let map f x = - withResultFuncRaw (x.GetResult >> f) x - let redirectOutput (c:CreateProcess<_>) = - match c.GetRawOutput with - | None -> - let outMem = new MemoryStream() - let errMem = new MemoryStream() - - let getOutput () = - outMem.Position <- 0L - errMem.Position <- 0L - let stdErr = (new StreamReader(errMem)).ReadToEnd() - let stdOut = (new StreamReader(outMem)).ReadToEnd() - { Output = stdOut; Error = stdErr } - - { c with - StandardOutput = UseStream (false, outMem) - StandardError = UseStream (false, errMem) - GetRawOutput = Some getOutput } - |> withResultFuncRaw id - | Some f -> - c |> withResultFuncRaw id - let withResultFunc f (x:CreateProcess<_>) = - match x.GetRawOutput with - | Some _ -> x |> withResultFuncRaw f - | None -> x |> redirectOutput |> withResultFuncRaw f - - let addOnExited f (r:CreateProcess<_>) = - r - |> addSetup (fun _ -> - { new IProcessHook with - member __.Dispose () = () - member __.ProcessExited exitCode = - if exitCode <> 0 then f exitCode - member __.ParseSuccess _ = () }) - let ensureExitCodeWithMessage msg (r:CreateProcess<_>) = - r - |> addOnExited (fun exitCode -> - if exitCode <> 0 then failwith msg) - - - let ensureExitCode (r:CreateProcess<_>) = - r - |> addOnExited (fun exitCode -> - if exitCode <> 0 then - let msg = - match r.GetRawOutput with - | Some f -> - let output = f() - (sprintf "Process exit code '%d' <> 0. Command Line: %s\nStdOut: %s\nStdErr: %s" exitCode r.CommandLine output.Output output.Error) - | None -> - (sprintf "Process exit code '%d' <> 0. Command Line: %s" exitCode r.CommandLine) - failwith msg - ) - - let warnOnExitCode msg (r:CreateProcess<_>) = - r - |> addOnExited (fun exitCode -> - if exitCode <> 0 then - let msg = - match r.GetRawOutput with - | Some f -> - let output = f() - (sprintf "%s. exit code '%d' <> 0. Command Line: %s\nStdOut: %s\nStdErr: %s" msg exitCode r.CommandLine output.Output output.Error) - | None -> - (sprintf "%s. exit code '%d' <> 0. Command Line: %s" msg exitCode r.CommandLine) - //if Env.isVerbose then - eprintfn "%s" msg - ) -type ProcessResults<'a> = - { ExitCode : int - CreateProcess : CreateProcess<'a> - Result : 'a } -module Proc = - let startRaw (c:CreateProcess<_>) = - async { - use hook = c.Setup() - - let! exitCode, output = RawProc.processStarter.Start(c.Proc) - - hook.ProcessExited(exitCode) - - let o, realResult = - match output with - | Some f -> f, true - | None -> { Output = ""; Error = "" }, false - - let strip (s:string) = - let subString (s:string) = - let splitMax = 300 - let half = splitMax / 2 - if s.Length < splitMax then s - else sprintf "%s [...] %s" (s.Substring(0, half)) (s.Substring(s.Length - half)) - - if s.Length < 1000 then - s - else - let splits = s.Split([|"\n"|], System.StringSplitOptions.None) - if splits.Length <= 1 then - // We need to use substring - subString s - else - splits - |> Seq.take 10 - |> fun s -> Seq.append s [" [ ... ] "] - |> fun s -> Seq.append s (splits |> Seq.skip (splits.Length - 10)) - |> Seq.map subString - |> fun s -> System.String.Join("\n", s) - - let strippedOutput = lazy strip o.Output - let strippedError = lazy strip o.Error - if realResult then - Trace.tracefn "Process Output: %s, Error: %s" strippedOutput.Value strippedError.Value - - let result = - try c.GetResult o - with e -> - let msg = - if realResult then - sprintf "Could not parse output from process, StdOutput: %s, StdError %s" strippedOutput.Value strippedError.Value - else - "Could not parse output from process, but RawOutput was not retrieved." - raise <| System.Exception(msg, e) - - hook.ParseSuccess exitCode - return { ExitCode = exitCode; CreateProcess = c; Result = result } - } - // Immediate makes sure we set the ref cell before we return the task... - |> Async.StartImmediateAsTask - - let start c = - async { - let! result = startRaw c - return result.Result - } - |> Async.StartImmediateAsTask - - /// Convenience method when you immediatly want to await the result of 'start', just note that - /// when used incorrectly this might lead to race conditions - /// (ie if you use StartAsTask and access reference cells in CreateProcess after that returns) - let startAndAwait c = start c |> Async.AwaitTaskWithoutAggregate - - let ensureExitCodeWithMessageGetResult msg (r:ProcessResults<_>) = - let { Setup = f } = - { r.CreateProcess with Setup = fun _ -> CreateProcess.emptyHook } - |> CreateProcess.ensureExitCodeWithMessage msg - let hook = f () - hook.ProcessExited r.ExitCode - r.Result - - let getResultIgnoreExitCode (r:ProcessResults<_>) = - r.Result - - let ensureExitCodeGetResult (r:ProcessResults<_>) = - let { Setup = f } = - { r.CreateProcess with Setup = fun _ -> CreateProcess.emptyHook } - |> CreateProcess.ensureExitCode - let hook = f () - hook.ProcessExited r.ExitCode - r.Result - - \ No newline at end of file diff --git a/src/app/Fake.Core.Process/Process.fs b/src/app/Fake.Core.Process/Process.fs index bfa342fd383..58627eaddc7 100644 --- a/src/app/Fake.Core.Process/Process.fs +++ b/src/app/Fake.Core.Process/Process.fs @@ -21,6 +21,10 @@ type ProcessResult = { ExitCode : int Results : ConsoleMessage list} member x.OK = x.ExitCode = 0 + + member internal x.ReportString = + String.Join("\n", x.Results |> Seq.map (fun m -> sprintf "%s: %s" (if m.IsError then "stderr" else "stdout") m.Message)) + member x.Messages = x.Results |> List.choose (function @@ -99,7 +103,7 @@ type ProcStartInfo = #endif /// When UseShellExecute is true, the fully qualified name of the directory that contains the process to be started. When the UseShellExecute property is false, the working directory for the process to be started. The default is an empty string (""). WorkingDirectory : string - } + } static member Create() = { Arguments = null CreateNoWindow = false @@ -126,7 +130,7 @@ type ProcStartInfo = Verb = "" #endif WorkingDirectory = "" } - [] + [] static member Empty = ProcStartInfo.Create() /// Sets the current environment variables. member x.WithEnvironment map = @@ -249,6 +253,8 @@ module internal Kernel32 = "Error = " + string hresult + " when calling GetProcessImageFileName" #endif +type AsyncProcessResult<'a> = { Result : System.Threading.Tasks.Task<'a>; Raw : System.Threading.Tasks.Task } + [] module Process = @@ -332,6 +338,30 @@ module Process = // psi.Arguments <- getMonoArguments() + " \"" + psi.FileName + "\" " + psi.Arguments // psi.FileName <- Environment.monoPath + /// [omit] + //let mutable redirectOutputToTrace = false + + let private redirectOutputToTraceVar = "Fake.Core.Process.redirectOutputToTrace" + let private tryGetRedirectOutputToTrace, _, public setRedirectOutputToTrace = + Fake.Core.FakeVar.defineAllowNoContext redirectOutputToTraceVar + let getRedirectOutputToTrace () = + match tryGetRedirectOutputToTrace() with + | Some v -> v + | None -> + let shouldEnable = false + setRedirectOutputToTrace shouldEnable + shouldEnable + + /// [omit] + //let mutable enableProcessTracing = true + let private enableProcessTracingVar = "Fake.Core.Process.enableProcessTracing" + let private getEnableProcessTracing, private removeEnableProcessTracing, public setEnableProcessTracing = + Fake.Core.FakeVar.defineAllowNoContext enableProcessTracingVar + let shouldEnableProcessTracing () = + match getEnableProcessTracing() with + | Some v -> v + | None -> + Fake.Core.Context.isFakeContext() /// If set to true the ProcessHelper will start all processes with a custom ProcessEncoding. /// If set to false (default) only mono processes will be changed. @@ -341,11 +371,7 @@ module Process = /// If AlwaysSetProcessEncoding is set to false (default) only mono processes will be changed. let mutable ProcessEncoding = Encoding.UTF8 - let internal rawStartProcess (proc : Process) = - try - let result = proc.Start() - if not result then failwithf "Could not start process (Start() returned false)." - with ex -> raise <| exn(sprintf "Start of process '%s' failed." proc.StartInfo.FileName, ex) + let inline internal recordProcess (proc:Process) = let startTime = try proc.StartTime with | :? System.InvalidOperationException @@ -359,35 +385,96 @@ module Process = DateTime.Now addStartedProcess(proc.Id, startTime) |> ignore + let inline internal rawStartProcessNoRecord (proc:Process) = + if String.isNullOrEmpty proc.StartInfo.WorkingDirectory |> not then + if Directory.Exists proc.StartInfo.WorkingDirectory |> not then + sprintf "Start of process '%s' failed. WorkingDir '%s' does not exist." proc.StartInfo.FileName + proc.StartInfo.WorkingDirectory + |> DirectoryNotFoundException + |> raise + try + let result = proc.Start() + if not result then failwithf "Could not start process (Start() returned false)." + with ex -> raise <| exn(sprintf "Start of process '%s' failed." proc.StartInfo.FileName, ex) + + let internal rawStartProcess (proc : Process) = + rawStartProcessNoRecord proc + recordProcess proc + + let mutable internal processStarter = + RawProc.createProcessStarter (fun p -> + let si = p.StartInfo + if Environment.isMono || AlwaysSetProcessEncoding then + si.StandardOutputEncoding <- ProcessEncoding + si.StandardErrorEncoding <- ProcessEncoding + + if shouldEnableProcessTracing() then + let commandLine = + sprintf "%s> \"%s\" %s" si.WorkingDirectory si.FileName si.Arguments + //Trace.tracefn "%s %s" proc.StartInfo.FileName proc.StartInfo.Arguments + Trace.tracefn "%s (In: %b, Out: %b, Err: %b)" commandLine si.RedirectStandardInput si.RedirectStandardOutput si.RedirectStandardError + + rawStartProcessNoRecord p + recordProcess p) + + [] + module internal Proc = + open Fake.Core.ProcessHelpers + let startRaw (c:CreateProcess<_>) = + async { + let hook = c.Hook + + let state = hook.PrepareState () + let! exitCode = + async { + let procRaw = + { Command = c.Command + WorkingDirectory = c.WorkingDirectory + Environment = c.Environment + Streams = c.Streams + OutputHook = + { new IRawProcessHook with + member x.Prepare streams = hook.PrepareStreams(state, streams) + member x.OnStart (p) = hook.ProcessStarted (state, p) } } + + let! e = processStarter.Start(procRaw) + return e + } + + let output = + hook.RetrieveResult (state, exitCode) + |> Async.StartImmediateAsTask + async { + try + let all = System.Threading.Tasks.Task.WhenAll([exitCode :> System.Threading.Tasks.Task; output:> System.Threading.Tasks.Task]) + let! streams = + all.ContinueWith (new System.Func (fun t -> ())) + |> Async.AwaitTaskWithoutAggregate + state.Dispose() + with e -> Trace.traceFAKE "Error in state dispose: %O" e } + |> Async.Start + return { Result = output; Raw = exitCode } + } + // Immediate makes sure we set the ref cell before we return the task... + |> Async.StartImmediateAsTask + + let start c = + async { + let! result = startRaw c + return! result.Result |> Async.AwaitTaskWithoutAggregate + } + |> Async.StartImmediateAsTask + let startRawSync c = (startRaw c).Result + + let startAndAwait c = start c |> Async.AwaitTaskWithoutAggregate + let run c = startAndAwait c |> Async.RunSynchronously + /// [omit] [] let startProcess (proc : Process) = rawStartProcess proc true - /// [omit] - //let mutable redirectOutputToTrace = false - let private redirectOutputToTraceVar = "Fake.Core.Process.redirectOutputToTrace" - let private tryGetRedirectOutputToTrace, _, public setRedirectOutputToTrace = - Fake.Core.FakeVar.defineAllowNoContext redirectOutputToTraceVar - let getRedirectOutputToTrace () = - match tryGetRedirectOutputToTrace() with - | Some v -> v - | None -> - let shouldEnable = false - setRedirectOutputToTrace shouldEnable - shouldEnable - - /// [omit] - //let mutable enableProcessTracing = true - let private enableProcessTracingVar = "Fake.Core.Process.enableProcessTracing" - let private getEnableProcessTracing, private removeEnableProcessTracing, public setEnableProcessTracing = - Fake.Core.FakeVar.defineAllowNoContext enableProcessTracingVar - let shouldEnableProcessTracing () = - match getEnableProcessTracing() with - | Some v -> v - | None -> - Fake.Core.Context.isFakeContext() let defaultEnvVar = ProcStartInfoData.defaultEnvVar let createEnvironmentMap () = ProcStartInfoData.createEnvironmentMap() @@ -466,12 +553,20 @@ module Process = |> setEnvironmentVariable defaultEnvVar defaultEnvVar + let internal getProcI config = + let startInfo : ProcStartInfo = + config { ProcStartInfo.Create() with UseShellExecute = false } + CreateProcess.ofStartInfo startInfo.AsStartInfo + //|> CreateProcess.getProcess + + [] let inline getProc config = let startInfo : ProcStartInfo = config { ProcStartInfo.Create() with UseShellExecute = false } let proc = new Process() proc.StartInfo <- startInfo.AsStartInfo proc + /// Runs the given process and returns the exit code. /// ## Parameters /// @@ -480,51 +575,33 @@ module Process = /// - `silent` - If this flag is set then the process output is redirected to the given output functions `errorF` and `messageF`. /// - `errorF` - A function which will be called with the error log. /// - `messageF` - A function which will be called with the message log. + [] let execRaw configProcessStartInfoF (timeOut : TimeSpan) silent errorF messageF = - use proc = getProc configProcessStartInfoF + let cp = getProcI configProcessStartInfoF - //platformInfoAction proc.StartInfo - if String.isNullOrEmpty proc.StartInfo.WorkingDirectory |> not then - if Directory.Exists proc.StartInfo.WorkingDirectory |> not then - sprintf "Start of process '%s' failed. WorkingDir '%s' does not exist." proc.StartInfo.FileName - proc.StartInfo.WorkingDirectory - |> DirectoryNotFoundException - |> raise - if silent then - proc.StartInfo.RedirectStandardOutput <- true - proc.StartInfo.RedirectStandardError <- true - if Environment.isMono || AlwaysSetProcessEncoding then - proc.StartInfo.StandardOutputEncoding <- ProcessEncoding - proc.StartInfo.StandardErrorEncoding <- ProcessEncoding - proc.ErrorDataReceived.Add(fun d -> - if isNull d.Data |> not then errorF d.Data) - proc.OutputDataReceived.Add(fun d -> - if isNull d.Data |> not then messageF d.Data) - if shouldEnableProcessTracing() && (not <| proc.StartInfo.FileName.EndsWith "fsi.exe") then - Trace.tracefn "%s %s" proc.StartInfo.FileName proc.StartInfo.Arguments - rawStartProcess proc - if silent then - proc.BeginErrorReadLine() - proc.BeginOutputReadLine() - if timeOut = TimeSpan.MaxValue then proc.WaitForExit() - else - if not <| proc.WaitForExit(int timeOut.TotalMilliseconds) then - try - proc.Kill() - with exn -> - Trace.traceError - <| sprintf "Could not kill process %s %s after timeout: %O" proc.StartInfo.FileName - proc.StartInfo.Arguments exn - failwithf "Process %s %s timed out." proc.StartInfo.FileName proc.StartInfo.Arguments - // See http://stackoverflow.com/a/16095658/1149924 why WaitForExit must be called twice. - proc.WaitForExit() - proc.ExitCode + let cp = + if silent then + cp + |> CreateProcess.redirectOutput + |> CreateProcess.withOutputEvents + (fun m -> if isNull m |> not then messageF m) + (fun m -> if isNull m |> not then errorF m) + |> CreateProcess.mapResult (fun p -> ()) + else + cp + + let result = + cp + |> CreateProcess.withTimeout timeOut + |> Proc.run + result.ExitCode /// Runs the given process and returns the process result. /// ## Parameters /// /// - `configProcessStartInfoF` - A function which overwrites the default ProcessStartInfo. /// - `timeOut` - The timeout for the process. + [] let execWithResult configProcessStartInfoF timeOut = let messages = ref [] @@ -550,6 +627,7 @@ module Process = /// info.Arguments <- "-v") (TimeSpan.FromMinutes 5.0) /// /// if result <> 0 then failwithf "MyProc.exe returned with a non-zero exit code" + [] let execSimple configProcessStartInfoF timeOut = execRaw configProcessStartInfoF timeOut (getRedirectOutputToTrace()) Trace.traceError Trace.trace @@ -577,30 +655,38 @@ module Process = myExecElevated cmd args timeOut /// Starts the given process and returns immediatly. + [] let fireAndForget configProcessStartInfoF = - use proc = getProc configProcessStartInfoF - rawStartProcess proc + getProcI configProcessStartInfoF + |> Proc.startRawSync + |> ignore + //rawStartProcess proc /// Runs the given process, waits for its completion and returns if it succeeded. + [] let directExec configProcessStartInfoF = - use proc = getProc configProcessStartInfoF - rawStartProcess proc - proc.WaitForExit() - proc.ExitCode = 0 + let result = + getProcI configProcessStartInfoF + |> Proc.run + result.ExitCode = 0 /// Starts the given process and forgets about it. + [] let start configProcessStartInfoF = - use proc = getProc configProcessStartInfoF - rawStartProcess proc + getProcI configProcessStartInfoF + |> Proc.startRawSync + |> ignore /// Adds quotes around the string /// [omit] + [] let quote (str:string) = // "\"" + str.Replace("\"","\\\"") + "\"" - CmdLineParsing.windowsArgvToCommandLine [ str ] + CmdLineParsing.windowsArgvToCommandLine true [ str ] /// Adds quotes around the string if needed /// [omit] + [] let quoteIfNeeded str = quote str //if String.isNullOrEmpty str then "" //elif str.Contains " " then quote str @@ -608,32 +694,39 @@ module Process = /// Adds quotes and a blank around the string´. /// [omit] + [] let toParam x = " " + quoteIfNeeded x /// Use default Parameters /// [omit] + [] let UseDefaults = id /// [omit] + [] let stringParam (paramName, paramValue) = if String.isNullOrEmpty paramValue then None else Some(paramName, paramValue) /// [omit] + [] let multipleStringParams paramName = Seq.map (fun x -> stringParam (paramName, x)) >> Seq.toList /// [omit] + [] let optionParam (paramName, paramValue) = match paramValue with | Some x -> Some(paramName, x.ToString()) | None -> None /// [omit] + [] let boolParam (paramName, paramValue) = if paramValue then Some(paramName, null) else None /// [omit] + [] let parametersToString flagPrefix delimiter parameters = parameters |> Seq.choose id @@ -646,70 +739,25 @@ module Process = else [ flagPrefix + paramName paramValue ]) - |> CmdLineParsing.windowsArgvToCommandLine + |> CmdLineParsing.windowsArgvToCommandLine true - /// Searches the given directories for all occurrences of the given file name - /// [omit] - let findFiles dirs file = - let files = - dirs - |> Seq.map (fun (path : string) -> - let dir = - path - |> String.replace "[ProgramFiles]" Environment.ProgramFiles - |> String.replace "[ProgramFilesX86]" Environment.ProgramFilesX86 - |> String.replace "[SystemRoot]" Environment.SystemRoot - |> DirectoryInfo.ofPath - if not dir.Exists then "" - else - let fi = dir.FullName @@ file - |> FileInfo.ofPath - if fi.Exists then fi.FullName - else "") - |> Seq.filter ((<>) "") - |> Seq.cache - files - - /// Searches the given directories for all occurrences of the given file name - /// [omit] - let tryFindFile dirs file = - let files = findFiles dirs file - if not (Seq.isEmpty files) then Some(Seq.head files) - else None + [] + let findFiles dirs file = ProcessUtils.findFiles dirs file - /// Searches the given directories for the given file, failing if not found. - /// [omit] - let findFile dirs file = - match tryFindFile dirs file with - | Some found -> found - | None -> failwithf "%s not found in %A." file dirs + [] + let tryFindFile dirs file = ProcessUtils.tryFindFile dirs file - /// Searches in PATH for the given file and returnes the result ordered by precendence + [] + let findFile dirs file = ProcessUtils.findFile dirs file + + [] let findFilesOnPath (file : string) : string seq = - Environment.pathDirectories - |> Seq.filter Path.isValidPath - |> Seq.append [ "." ] - |> fun path -> - // See https://unix.stackexchange.com/questions/280528/is-there-a-unix-equivalent-of-the-windows-environment-variable-pathext - if Environment.isWindows then - // Prefer PATHEXT, see https://github.com/fsharp/FAKE/issues/1911 - // and https://github.com/fsharp/FAKE/issues/1899 - Environment.environVarOrDefault "PATHEXT" ".COM;.EXE;.BAT" - |> String.split ';' - |> Seq.collect (fun postFix -> findFiles path (file + postFix)) - |> fun findings -> Seq.append findings (findFiles path file) - else findFiles path file - - /// Searches the current directory and the directories within the PATH - /// environment variable for the given file. If successful returns the full - /// path to the file. - /// ## Parameters - /// - `file` - The file to locate + ProcessUtils.findFilesOnPath file + + [] let tryFindFileOnPath (file : string) : string option = - findFilesOnPath file |> Seq.tryHead + ProcessUtils.tryFindFileOnPath file - /// Returns the AppSettings for the key - Splitted on ; - /// [omit] [] let appSettings (key : string) (fallbackValue : string) = let value = @@ -725,22 +773,17 @@ module Process = else fallbackValue value.Split([| ';' |], StringSplitOptions.RemoveEmptyEntries) - /// Tries to find the tool via Env-Var. If no path has the right tool we are trying the PATH system variable. - let tryFindTool envVar tool = - match Environment.environVarOrNone envVar with - | Some path -> Some path - | None -> tryFindFileOnPath tool + [] + let tryFindTool envVar tool = ProcessUtils.tryFindTool envVar tool - /// Tries to find the tool via AppSettings. If no path has the right tool we are trying the PATH system variable. - /// [omit] - let tryFindPath settingsName fallbackValue tool = + [] + let tryFindPath settingsName fallbackValue tool = let paths = appSettings settingsName fallbackValue match tryFindFile paths tool with | Some path -> Some path | None -> tryFindFileOnPath tool - /// Tries to find the tool via AppSettings. If no path has the right tool we are trying the PATH system variable. - /// [omit] + [] let findPath settingsName fallbackValue tool = match tryFindPath settingsName fallbackValue tool with | Some file -> file @@ -752,12 +795,13 @@ module Process = else str args |> Seq.collect (fun (k, v) -> [ delimit k; v ]) - |> CmdLineParsing.windowsArgvToCommandLine + |> CmdLineParsing.windowsArgvToCommandLine true /// Execute an external program asynchronously and return the exit code, /// logging output and error messages to FAKE output. You can compose the result /// with Async.Parallel to run multiple external programs at once, but be /// sure that none of them depend on the output of another. + [] let asyncShellExec (args : ExecParams) = async { if String.isNullOrEmpty args.Program then invalidArg "args" "You must specify a program to run!" @@ -855,9 +899,8 @@ module Process = /// [omit] let shellExec args = args |> asyncShellExec |> Async.RunSynchronously - let internal monoPath, monoVersion = - match tryFindTool "MONO" "mono" with + match ProcessUtils.tryFindTool "MONO" "mono" with | Some path -> let result = try execWithResult(fun proc -> @@ -987,3 +1030,67 @@ module ProcStartInfoExtensions = #endif /// When UseShellExecute is true, the fully qualified name of the directory that contains the process to be started. When the UseShellExecute property is false, the working directory for the process to be started. The default is an empty string (""). member x.WithWorkingDirectory dir = { x with WorkingDirectory = dir } + + + + + +[] +module Proc = + open Fake.Core.ProcessHelpers + let startRaw (c:CreateProcess<_>) = Process.Proc.startRaw c +(* + let o, realResult = + match output with + | Some f -> f, true + | None -> { Output = ""; Error = "" }, false + + let strip (s:string) = + let subString (s:string) = + let splitMax = 300 + let half = splitMax / 2 + if s.Length < splitMax then s + else sprintf "%s [...] %s" (s.Substring(0, half)) (s.Substring(s.Length - half)) + + if s.Length < 1000 then + s + else + let splits = s.Split([|"\n"|], System.StringSplitOptions.None) + if splits.Length <= 1 then + // We need to use substring + subString s + else + splits + |> Seq.take 10 + |> fun s -> Seq.append s [" [ ... ] "] + |> fun s -> Seq.append s (splits |> Seq.skip (splits.Length - 10)) + |> Seq.map subString + |> fun s -> System.String.Join("\n", s) + + let strippedOutput = lazy strip o.Output + let strippedError = lazy strip o.Error + if realResult then + Trace.tracefn "Process Output: %s, Error: %s" strippedOutput.Value strippedError.Value + + let result = + try c.GetResult o + with e -> + let msg = + if realResult then + sprintf "Could not parse output from process, StdOutput: %s, StdError %s" strippedOutput.Value strippedError.Value + else + "Could not parse output from process, but RawOutput was not retrieved." + raise <| System.Exception(msg, e) + + do! hook.ParseSuccess exitCode + return { ExitCode = exitCode; CreateProcess = c; Result = result }*) + + let startRawSync c = Process.Proc.startRawSync c + let start c = Process.Proc.start c + + /// Convenience method when you immediatly want to await the result of 'start', just note that + /// when used incorrectly this might lead to race conditions + /// (ie if you use StartAsTask and access reference cells in CreateProcess after that returns) + let startAndAwait c = Process.Proc.startAndAwait c + + let run c = Process.Proc.run diff --git a/src/app/Fake.Core.Process/ProcessUtils.fs b/src/app/Fake.Core.Process/ProcessUtils.fs new file mode 100644 index 00000000000..3dc315eac8a --- /dev/null +++ b/src/app/Fake.Core.Process/ProcessUtils.fs @@ -0,0 +1,90 @@ +/// Contains functions which can be used to start other tools. + +namespace Fake.Core + +open Fake.IO +open Fake.IO.FileSystemOperators + +[] +module ProcessUtils = + + /// Searches the given directories for all occurrences of the given file name + /// [omit] + let findFiles dirs file = + let files = + dirs + |> Seq.map (fun (path : string) -> + let dir = + path + |> String.replace "[ProgramFiles]" Environment.ProgramFiles + |> String.replace "[ProgramFilesX86]" Environment.ProgramFilesX86 + |> String.replace "[SystemRoot]" Environment.SystemRoot + |> DirectoryInfo.ofPath + if not dir.Exists then "" + else + let fi = dir.FullName @@ file + |> FileInfo.ofPath + if fi.Exists then fi.FullName + else "") + |> Seq.filter ((<>) "") + |> Seq.cache + files + + /// Searches the given directories for all occurrences of the given file name + /// [omit] + let tryFindFile dirs file = + let files = findFiles dirs file + if not (Seq.isEmpty files) then Some(Seq.head files) + else None + + /// Searches the given directories for the given file, failing if not found. + /// [omit] + let findFile dirs file = + match tryFindFile dirs file with + | Some found -> found + | None -> failwithf "%s not found in %A." file dirs + + /// Searches in PATH for the given file and returnes the result ordered by precendence + let findFilesOnPath (file : string) : string seq = + Environment.pathDirectories + |> Seq.filter Path.isValidPath + |> Seq.append [ "." ] + |> fun path -> + // See https://unix.stackexchange.com/questions/280528/is-there-a-unix-equivalent-of-the-windows-environment-variable-pathext + if Environment.isWindows then + // Prefer PATHEXT, see https://github.com/fsharp/FAKE/issues/1911 + // and https://github.com/fsharp/FAKE/issues/1899 + Environment.environVarOrDefault "PATHEXT" ".COM;.EXE;.BAT" + |> String.split ';' + |> Seq.collect (fun postFix -> findFiles path (file + postFix)) + |> fun findings -> Seq.append findings (findFiles path file) + else findFiles path file + + /// Searches the current directory and the directories within the PATH + /// environment variable for the given file. If successful returns the full + /// path to the file. + /// ## Parameters + /// - `file` - The file to locate + let tryFindFileOnPath (file : string) : string option = + findFilesOnPath file |> Seq.tryHead + + + /// Tries to find the tool via Env-Var. If no path has the right tool we are trying the PATH system variable. + let tryFindTool envVar tool = + match Environment.environVarOrNone envVar with + | Some path -> Some path + | None -> tryFindFileOnPath tool + + /// Tries to find the tool via AppSettings. If no path has the right tool we are trying the PATH system variable. + /// [omit] + let tryFindPath fallbackValue tool = + match tryFindFile fallbackValue tool with + | Some path -> Some path + | None -> tryFindFileOnPath tool + + /// Tries to find the tool via AppSettings. If no path has the right tool we are trying the PATH system variable. + /// [omit] + let findPath fallbackValue tool = + match tryFindPath fallbackValue tool with + | Some file -> file + | None -> tool \ No newline at end of file diff --git a/src/app/Fake.Core.Process/RawProc.fs b/src/app/Fake.Core.Process/RawProc.fs index 0c4c481f16f..0ed1efd1652 100644 --- a/src/app/Fake.Core.Process/RawProc.fs +++ b/src/app/Fake.Core.Process/RawProc.fs @@ -1,15 +1,60 @@ namespace Fake.Core +open System open System.Reflection +open Fake.Core open Fake.Core.ProcessHelpers +open System.Collections.Immutable +open System.Collections.Generic + +type IMap<'TKey, 'TValue> = IImmutableDictionary<'TKey, 'TValue> +module IMap = + let inline empty<'key, 'value> = ImmutableDictionary.Empty :> IMap<'key, 'value> + let inline tryFind k (m:IMap<_,_>) = + match m.TryGetValue k with + | true, v -> Some v + | _ -> None + let inline remove k (m:IMap<_,_>) : IMap<_,_> = + m.Remove(k) + let inline iter f (m:IMap<_,_>) = + for kv in m do + f kv.Key kv.Value + let inline add k v (m:IMap<_,_>) : IMap<_,_> = + m.SetItem(k, v) + let inline toSeq (m:IMap<_,_>) :seq<_ * _> = + m |> Seq.map (fun kv -> kv.Key, kv.Value) + +type EnvMap = IMap +module EnvMap = + let empty = + if Environment.isWindows + then ImmutableDictionary.Empty.WithComparers(StringComparer.OrdinalIgnoreCase) :> EnvMap + else IMap.empty + + let ofSeq l = + empty.AddRange(l |> Seq.map (fun (k, v) -> KeyValuePair<_,_>(k, v))) + + let create() = + ofSeq (Environment.environVars ()) + //|> IMap.add defaultEnvVar defaultEnvVar + + +/// The type of command to execute type Command = | ShellCommand of string /// Windows: https://msdn.microsoft.com/en-us/library/windows/desktop/bb776391(v=vs.85).aspx /// Linux(mono): https://github.com/mono/mono/blob/0bcbe39b148bb498742fc68416f8293ccd350fb6/eglib/src/gshell.c#L32-L104 (because we need to create a commandline string internally which need to go through that code) /// Linux(netcore): See https://github.com/fsharp/FAKE/pull/1281/commits/285e585ec459ac7b89ca4897d1323c5a5b7e4558 and https://github.com/dotnet/corefx/blob/master/src/System.Diagnostics.Process/src/System/Diagnostics/Process.Unix.cs#L443-L522 | RawCommand of executable:FilePath * arguments:Arguments + + member x.CommandLine = + match x with + | ShellCommand s -> s + | RawCommand (f, arg) -> sprintf "%s %s" f arg.ToWindowsCommandLine +/// Represents basically an "out" parameter, allows to retrieve a value after a certain point in time. +/// Used to retrieve "pipes" type DataRef<'T> = internal { retrieveRaw : (unit -> 'T) ref } static member Empty = @@ -19,36 +64,21 @@ type DataRef<'T> = member x.Value = (!x.retrieveRaw)() type StreamRef = DataRef -//type DataRef = -// static member Empty<'T> = DataRef + +/// Various options to redirect streams. type StreamSpecification = + /// Do not redirect, or use normal process inheritance | Inherit + /// Redirect to the given stream (the stream is provided by the user and is written only for 'stdout' & 'stderr' and read only for 'stdin') | UseStream of closeOnExit:bool * stream:System.IO.Stream + /// Retrieve the raw pipe from the process (the StreamRef is set with a stream you can write into for 'stdin' and read from for 'stdout' and 'stderr') | CreatePipe of StreamRef // The underlying framework creates pipes already -type ProcessOutput = { Output : string; Error : string } - -type RawCreateProcess = - internal { - Command : Command - WorkingDirectory : string option - Environment : (string * string) list option - StandardInput : StreamSpecification - StandardOutput : StreamSpecification - StandardError : StreamSpecification - GetRawOutput : (unit -> ProcessOutput) option - } - member internal x.ToStartInfo = - let p = new System.Diagnostics.ProcessStartInfo() - match x.Command with - | ShellCommand s -> - p.UseShellExecute <- true - p.FileName <- s - p.Arguments <- null - | RawCommand (filename, args) -> - p.UseShellExecute <- false - p.FileName <- filename - p.Arguments <- args.ToStartInfo +type internal StreamSpecs = + { StandardInput : StreamSpecification + StandardOutput : StreamSpecification + StandardError : StreamSpecification } + member x.SetStartInfo (p:System.Diagnostics.ProcessStartInfo) = match x.StandardInput with | Inherit -> p.RedirectStandardInput <- false @@ -65,36 +95,68 @@ type RawCreateProcess = | UseStream _ | CreatePipe _ -> p.RedirectStandardError <- true + +type internal IRawProcessHook = + abstract member Prepare : StreamSpecs -> StreamSpecs + abstract member OnStart : System.Diagnostics.Process -> unit + //abstract member Retrieve : IDisposable * System.Threading.Tasks.Task -> Async<'TRes> + +/// A raw (untyped) way to start a process +type internal RawCreateProcess = + internal { + Command : Command + WorkingDirectory : string option + Environment : EnvMap option + Streams : StreamSpecs + OutputHook : IRawProcessHook + } + member internal x.ToStartInfo = + let p = new System.Diagnostics.ProcessStartInfo() + match x.Command with + | ShellCommand s -> + p.UseShellExecute <- true + p.FileName <- s + p.Arguments <- null + | RawCommand (filename, args) -> + p.UseShellExecute <- false + p.FileName <- filename + p.Arguments <- args.ToStartInfo let setEnv key var = p.Environment.[key] <- var x.Environment |> Option.iter (fun env -> p.Environment.Clear() - env |> Seq.iter (fun (key, value) -> setEnv key value)) + env |> IMap.iter (fun key value -> setEnv key value)) #if FX_WINDOWSTLE p.WindowStyle <- System.Diagnostics.ProcessWindowStyle.Hidden #endif + match x.WorkingDirectory with + | Some work -> + p.WorkingDirectory <- work + | None -> () p - member x.OutputRedirected = x.GetRawOutput.IsSome - member x.CommandLine = - match x.Command with - | ShellCommand s -> s - | RawCommand (f, arg) -> sprintf "%s %s" f arg.ToWindowsCommandLine + member x.CommandLine = x.Command.CommandLine + +type RawProcessResult = { RawExitCode : int } -type IProcessStarter = - abstract Start : RawCreateProcess -> Async +type internal IProcessStarter = + abstract Start : RawCreateProcess -> Async> + +module internal RawProc = -module RawProc = // mono sets echo off for some reason, therefore interactive mode doesn't work as expected // this enables this tty feature which makes the interactive mode work as expected let private setEcho (b:bool) = - // See https://github.com/mono/mono/blob/master/mcs/class/corlib/System/ConsoleDriver.cs#L289 - let t = System.Type.GetType("System.ConsoleDriver").GetTypeInfo() if Environment.isMono then + // See https://github.com/mono/mono/blob/master/mcs/class/corlib/System/ConsoleDriver.cs#L289 + let t = + match System.Type.GetType("System.ConsoleDriver") with + | null -> null + | cd -> cd.GetTypeInfo() let flags = System.Reflection.BindingFlags.Static ||| System.Reflection.BindingFlags.NonPublic if isNull t then - Trace.traceFAKE "Expected to find System.ConsoleDriver.SetEcho" + Trace.traceFAKE "Expected to find System.ConsoleDriver type" false else let setEchoMethod = t.GetMethod("SetEcho", flags) @@ -107,28 +169,30 @@ module RawProc = open System.Diagnostics open System.IO - let mutable processStarter = + let internal createProcessStarter startProcessRaw = { new IProcessStarter with member __.Start c = async { let p = c.ToStartInfo - let commandLine = - sprintf "%s> \"%s\" %s" p.WorkingDirectory p.FileName p.Arguments + let streamSpec = c.OutputHook.Prepare c.Streams + streamSpec.SetStartInfo p - Trace.tracefn "%s... RedirectInput: %b, RedirectOutput: %b, RedirectError: %b" commandLine p.RedirectStandardInput p.RedirectStandardOutput p.RedirectStandardError - - use toolProcess = new Process(StartInfo = p) + let toolProcess = new Process(StartInfo = p) - let isStarted = ref false + let mutable isStarted = false + let mutable startTrigger = System.Threading.Tasks.TaskCompletionSource<_>() let mutable readOutputTask = System.Threading.Tasks.Task.FromResult Stream.Null let mutable readErrorTask = System.Threading.Tasks.Task.FromResult Stream.Null let mutable redirectStdInTask = System.Threading.Tasks.Task.FromResult Stream.Null let tok = new System.Threading.CancellationTokenSource() let start() = - if not <| !isStarted then + if not <| isStarted then toolProcess.EnableRaisingEvents <- true setEcho true |> ignore - Process.rawStartProcess toolProcess - isStarted := true + try + startProcessRaw toolProcess + finally + setEcho false |> ignore + c.OutputHook.OnStart (toolProcess) let handleStream parameter processStream isInputStream = async { @@ -138,10 +202,10 @@ module RawProc = | UseStream (shouldClose, stream) -> if isInputStream then do! stream.CopyToAsync(processStream, 81920, tok.Token) - |> Async.AwaitTask + |> Async.AwaitTaskWithoutAggregate else do! processStream.CopyToAsync(stream, 81920, tok.Token) - |> Async.AwaitTask + |> Async.AwaitTaskWithoutAggregate return if shouldClose then stream else Stream.Null | CreatePipe (r) -> @@ -151,50 +215,61 @@ module RawProc = if p.RedirectStandardInput then redirectStdInTask <- - handleStream c.StandardInput toolProcess.StandardInput.BaseStream true + handleStream streamSpec.StandardInput toolProcess.StandardInput.BaseStream true // Immediate makes sure we set the ref cell before we return... |> fun a -> Async.StartImmediateAsTask(a, cancellationToken = tok.Token) if p.RedirectStandardOutput then readOutputTask <- - handleStream c.StandardOutput toolProcess.StandardOutput.BaseStream false + handleStream streamSpec.StandardOutput toolProcess.StandardOutput.BaseStream false // Immediate makes sure we set the ref cell before we return... |> fun a -> Async.StartImmediateAsTask(a, cancellationToken = tok.Token) if p.RedirectStandardError then readErrorTask <- - handleStream c.StandardError toolProcess.StandardError.BaseStream false + handleStream streamSpec.StandardError toolProcess.StandardError.BaseStream false // Immediate makes sure we set the ref cell before we return... |> fun a -> Async.StartImmediateAsTask(a, cancellationToken = tok.Token) + let syncStart () = + try + start() + startTrigger.SetResult() + with e -> startTrigger.SetException(e) + // Wait for the process to finish - let! exitEvent = + let exitEvent = toolProcess.Exited // This way the handler gets added before actually calling start or "EnableRaisingEvents" - |> Event.guard start + |> Event.guard syncStart |> Async.AwaitEvent |> Async.StartImmediateAsTask - // Waiting for the process to exit (buffers) - toolProcess.WaitForExit() - - let delay = System.Threading.Tasks.Task.Delay 500 - let all = System.Threading.Tasks.Task.WhenAll([readErrorTask; readOutputTask; redirectStdInTask]) - let! t = System.Threading.Tasks.Task.WhenAny(all, delay) - |> Async.AwaitTask - if t = delay then - Trace.traceFAKE "At least one redirection task did not finish: \nReadErrorTask: %O, ReadOutputTask: %O, RedirectStdInTask: %O" readErrorTask.Status readOutputTask.Status redirectStdInTask.Status - tok.Cancel() - - // wait for finish -> AwaitTask has a bug which makes it unusable for chanceled tasks. - // workaround with continuewith - let! streams = all.ContinueWith (new System.Func, Stream[]> (fun t -> t.GetAwaiter().GetResult())) |> Async.AwaitTask - for s in streams do s.Dispose() - setEcho false |> ignore - - let output = - match c.GetRawOutput with - | Some f -> Some (f()) - | None -> None + + do! startTrigger.Task |> Async.AwaitTaskWithoutAggregate + let exitCode = + async { + do! exitEvent |> Async.AwaitTaskWithoutAggregate |> Async.Ignore + // Waiting for the process to exit (buffers) + toolProcess.WaitForExit() - return toolProcess.ExitCode, output } - } \ No newline at end of file + let delay = System.Threading.Tasks.Task.Delay 500 + let all = System.Threading.Tasks.Task.WhenAll([readErrorTask; readOutputTask; redirectStdInTask]) + let! t = System.Threading.Tasks.Task.WhenAny(all, delay) + |> Async.AwaitTaskWithoutAggregate + if t = delay then + Trace.traceFAKE "At least one redirection task did not finish: \nReadErrorTask: %O, ReadOutputTask: %O, RedirectStdInTask: %O" readErrorTask.Status readOutputTask.Status redirectStdInTask.Status + tok.Cancel() + + // wait for finish -> AwaitTask has a bug which makes it unusable for chanceled tasks. + // workaround with continuewith + let! streams = all.ContinueWith (new System.Func, Stream[]> (fun t -> t.GetAwaiter().GetResult())) |> Async.AwaitTaskWithoutAggregate + for s in streams do s.Dispose() + + let code = toolProcess.ExitCode + toolProcess.Dispose() + return { RawExitCode = code } + } + |> Async.StartImmediateAsTask + + return exitCode } + } diff --git a/src/app/Fake.Core.Process/VisibleTo.fs b/src/app/Fake.Core.Process/VisibleTo.fs new file mode 100644 index 00000000000..9a497f59ddc --- /dev/null +++ b/src/app/Fake.Core.Process/VisibleTo.fs @@ -0,0 +1,7 @@ + +namespace System +open System.Runtime.CompilerServices + +[] +[] +do () \ No newline at end of file diff --git a/src/app/Fake.DotNet.Cli/DotNet.fs b/src/app/Fake.DotNet.Cli/DotNet.fs index b4cb2e85786..03542f48f8e 100644 --- a/src/app/Fake.DotNet.Cli/DotNet.fs +++ b/src/app/Fake.DotNet.Cli/DotNet.fs @@ -779,7 +779,7 @@ module DotNet = let result = getVersion (fun opt -> opt.WithCommon (fun c -> { c with DotNetCliPath = dotnet; Version = None})) result = version with e -> - Trace.traceFAKE "Retrieving version failed, assuming because it doesn't match global.json, error was: %s" e.Message + Trace.traceFAKE "Retrieving version failed, assuming because it doesn't match global.json, error was: %O" e false ) ), passVersion diff --git a/src/app/Fake.DotNet.Testing.NUnit/Fake.DotNet.Testing.NUnit.fsproj b/src/app/Fake.DotNet.Testing.NUnit/Fake.DotNet.Testing.NUnit.fsproj index 8bbe82eb936..2f6226dc0e8 100644 --- a/src/app/Fake.DotNet.Testing.NUnit/Fake.DotNet.Testing.NUnit.fsproj +++ b/src/app/Fake.DotNet.Testing.NUnit/Fake.DotNet.Testing.NUnit.fsproj @@ -13,6 +13,7 @@ + diff --git a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs index 393cb78030b..ad30fb16d4e 100644 --- a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs +++ b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs @@ -309,35 +309,49 @@ let buildArgs (parameters:NUnit3Params) (assemblies: string seq) = |> StringBuilder.appendFileNamesIfNotNull assemblies |> StringBuilder.toText -let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = - let details = assemblies |> String.separated ", " - use __ = Trace.traceTask "NUnit" details +let internal createProcess (setParams : NUnit3Params -> NUnit3Params) (assemblies : string[]) = let parameters = NUnit3Defaults |> setParams - let assemblies = assemblies |> Seq.toArray if Array.isEmpty assemblies then failwith "NUnit: cannot run tests (the assembly list is empty)." let tool = parameters.ToolPath - let args = buildArgs parameters assemblies - Trace.trace (tool + " " + args) - let processTimeout = TimeSpan.MaxValue // Don't set a process timeout. The timeout is per test. - let result = - Process.execSimple ((fun info -> - { info with - FileName = tool - WorkingDirectory = getWorkingDir parameters - Arguments = args }) >> Process.withFramework) processTimeout - let errorDescription error = - match error with - | OK -> "OK" - | TestsFailed -> sprintf "NUnit test failed (%d)." error - | FatalError x -> sprintf "NUnit test failed. Process finished with exit code %s (%d)." x error - - match parameters.ErrorLevel with - | NUnit3ErrorLevel.DontFailBuild -> - match result with - | OK | TestsFailed -> () - | _ -> raise (FailedTestsException(errorDescription result)) - | NUnit3ErrorLevel.Error | FailOnFirstError -> - match result with - | OK -> () - | _ -> raise (FailedTestsException(errorDescription result)) - __.MarkSuccess() + let generatedArgs = buildArgs parameters assemblies + //let processTimeout = TimeSpan.MaxValue // Don't set a process timeout. The timeout is per test. + + let path = Path.GetTempFileName() + let args = (sprintf "@%s" path) + CreateProcess.fromRawWindowsCommandLine tool args + |> CreateProcess.withFramework + |> CreateProcess.withWorkingDirectory (getWorkingDir parameters) + //|> CreateProcess.withTimeout processTimeout + |> CreateProcess.addOnSetup (fun () -> + File.WriteAllText(path, generatedArgs) + Trace.trace(sprintf "Saved args to '%s' with value: %s" path generatedArgs) + ) + |> CreateProcess.addOnFinally (fun () -> + File.Delete(path) + ) + |> CreateProcess.addOnExited (fun result exitCode -> + let errorDescription error = + match error with + | OK -> "OK" + | TestsFailed -> sprintf "NUnit test failed (%d)." error + | FatalError x -> sprintf "NUnit test failed. Process finished with exit code %s (%d)." x error + + match parameters.ErrorLevel with + | NUnit3ErrorLevel.DontFailBuild -> + match exitCode with + | OK | TestsFailed -> () + | _ -> raise (FailedTestsException(errorDescription exitCode)) + | NUnit3ErrorLevel.Error | FailOnFirstError -> + match exitCode with + | OK -> () + | _ -> raise (FailedTestsException(errorDescription exitCode)) + ) + +let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = + let assemblies = assemblies |> Seq.toArray + let details = assemblies |> String.separated ", " + use __ = Trace.traceTask "NUnit" details + createProcess setParams assemblies + |> Proc.run + + __.MarkSuccess() \ No newline at end of file diff --git a/src/app/Fake.DotNet.Testing.NUnit/VisibleTo.fs b/src/app/Fake.DotNet.Testing.NUnit/VisibleTo.fs new file mode 100644 index 00000000000..9a497f59ddc --- /dev/null +++ b/src/app/Fake.DotNet.Testing.NUnit/VisibleTo.fs @@ -0,0 +1,7 @@ + +namespace System +open System.Runtime.CompilerServices + +[] +[] +do () \ No newline at end of file diff --git a/src/test/Fake.Core.UnitTests/Fake.ContextHelper.fs b/src/test/Fake.Core.UnitTests/Fake.ContextHelper.fs index 4f46363bfbd..df8aea0dd98 100644 --- a/src/test/Fake.Core.UnitTests/Fake.ContextHelper.fs +++ b/src/test/Fake.Core.UnitTests/Fake.ContextHelper.fs @@ -5,6 +5,8 @@ open Expecto let fakeContextTestCase name f = testCase name <| fun arg -> - use execContext = Fake.Core.Context.FakeExecutionContext.Create false "text.fsx" [] + use execContext = Fake.Core.Context.FakeExecutionContext.Create false (sprintf "text.fsx - %s" name) [] Fake.Core.Context.setExecutionContext (Fake.Core.Context.RuntimeContext.Fake execContext) - f arg + try f arg + finally + Fake.Core.Context.removeExecutionContext() \ No newline at end of file diff --git a/src/test/Fake.Core.UnitTests/Fake.Core.Context.fs b/src/test/Fake.Core.UnitTests/Fake.Core.Context.fs index 3c384017c86..c8f899c4ab9 100644 --- a/src/test/Fake.Core.UnitTests/Fake.Core.Context.fs +++ b/src/test/Fake.Core.UnitTests/Fake.Core.Context.fs @@ -6,6 +6,7 @@ open Expecto let tests = testList "Fake.Core.Context.Tests" [ testCase "Test that forceFakeContext works or throws properly" <| fun _ -> + try let c = let f = Fake.Core.Context.FakeExecutionContext.Create false "C:\\Testfile" [] Fake.Core.Context.setExecutionContext (Fake.Core.Context.RuntimeContext.Fake f) @@ -16,4 +17,6 @@ let tests = Fake.Core.Context.forceFakeContext() |> ignore Tests.failtest "Expected exception" with :? System.InvalidOperationException as e -> () + finally + Fake.Core.Context.removeExecutionContext() ] diff --git a/src/test/Fake.Core.UnitTests/Fake.Core.FakeVar.fs b/src/test/Fake.Core.UnitTests/Fake.Core.FakeVar.fs index e939e01c4eb..2950c39783c 100644 --- a/src/test/Fake.Core.UnitTests/Fake.Core.FakeVar.fs +++ b/src/test/Fake.Core.UnitTests/Fake.Core.FakeVar.fs @@ -71,8 +71,8 @@ let tests = testCase "Ability to define variable with no context when context required" <| fun _ -> let myGet, _, _ = FakeVar.define "Test" try - myGet() |> ignore - Tests.failtest "Expected exception" + let result = myGet() + Tests.failtest (sprintf "Expected exception, but got '%A'" result) with e -> Expect.equal "Cannot retrieve 'Test' as we have no fake context" e.Message "Incorrect failure message for variable failure case" ] diff --git a/src/test/Fake.Core.UnitTests/Fake.Core.Process.fs b/src/test/Fake.Core.UnitTests/Fake.Core.Process.fs index eee2c302198..915509b3921 100644 --- a/src/test/Fake.Core.UnitTests/Fake.Core.Process.fs +++ b/src/test/Fake.Core.UnitTests/Fake.Core.Process.fs @@ -11,14 +11,15 @@ let fsCheckConfig = { FsCheckConfig.defaultConfig with maxTest = 1000 } [] let tests = testList "Fake.Core.Process.Tests" [ - testPropertyWithConfig fsCheckConfig "toWindowsCommandLine is the inverse of fromWindowsCommandLine" <| + //Process.setEnableProcessTracing true + yield testPropertyWithConfig fsCheckConfig "toWindowsCommandLine is the inverse of fromWindowsCommandLine" <| fun (x: NonNull list) -> let input = x |> List.map (fun (NonNull s) -> s) let escaped = Args.toWindowsCommandLine input let backAgain = Args.fromWindowsCommandLine escaped Expect.sequenceEqual backAgain input (sprintf "Expect argument lists to be equal, intermediate was '%s'" escaped) - testCase "Test that we have a nice error message when a file doesn't exist" <| fun _ -> + yield testCase "Test that we have a nice error message when a file doesn't exist" <| fun _ -> try Process.start(fun proc -> { proc with @@ -29,8 +30,21 @@ let tests = with e -> let s = e.Message.Contains "FileDoesntExist.exe" Expect.isTrue s ("Expected file-path as part of the message '" + e.Message + "'") - - testCase "Test that we can read messages correctly" <| fun _ -> + yield testCase "Test that CreateProcess.ofStartInfo works (1)" <| fun _ -> + let shell, command = "cmd", "/C \"echo 1&& echo 2\"" + let cb = Process.getProcI (fun proc -> + { proc with + FileName = shell + Arguments = command }) + let file, args = + match cb.Command with + | ShellCommand cmd -> failwithf "Expected RawCommand" + | RawCommand (f, a) -> f, a + Expect.equal file "cmd" "Expected correct command" + Expect.sequenceEqual ["/C"; "echo 1&& echo 2"] args.Args "Expected correct args" + Expect.equal args.ToStartInfo command "Expect proper command (cmd is strange with regards to escaping)" + + yield testCase "Test that we can read messages correctly" <| fun _ -> let shell, command = if Environment.isWindows then "cmd", "/C \"echo 1&& echo 2\"" @@ -42,6 +56,8 @@ let tests = FileName = shell Arguments = command }) (TimeSpan.FromMinutes 1.) - Expect.equal ["1"; "2"] result.Messages "Messages are not read correctly" + Expect.equal result.Messages ["1"; "2"] + (sprintf "Messages are not read correctly.\n%s" + result.ReportString) ] diff --git a/src/test/Fake.Core.UnitTests/Fake.Core.UnitTests.fsproj b/src/test/Fake.Core.UnitTests/Fake.Core.UnitTests.fsproj index 7d33df4e58d..d305e3cf119 100644 --- a/src/test/Fake.Core.UnitTests/Fake.Core.UnitTests.fsproj +++ b/src/test/Fake.Core.UnitTests/Fake.Core.UnitTests.fsproj @@ -13,6 +13,7 @@ + @@ -25,6 +26,7 @@ + diff --git a/src/test/Fake.Core.UnitTests/Fake.DotNet.MSBuild.fs b/src/test/Fake.Core.UnitTests/Fake.DotNet.MSBuild.fs index d87d7c527e5..f886e712ddd 100644 --- a/src/test/Fake.Core.UnitTests/Fake.DotNet.MSBuild.fs +++ b/src/test/Fake.Core.UnitTests/Fake.DotNet.MSBuild.fs @@ -14,7 +14,7 @@ let tests = ConsoleLogParameters = [] Properties = ["OutputPath", "C:\\Test\\"] }) let expected = - if Environment.isUnix then "\"/p:RestorePackages=False\" \"/p:OutputPath=C:%5CTest%5C\"" - else "\"/m\" \"/nodeReuse:False\" \"/p:RestorePackages=False\" \"/p:OutputPath=C:%5CTest%5C\"" + if Environment.isUnix then "/p:RestorePackages=False /p:OutputPath=C:%5CTest%5C" + else "/m /nodeReuse:False /p:RestorePackages=False /p:OutputPath=C:%5CTest%5C" Expect.equal cmdLine expected "Expected a given cmdline." ] diff --git a/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs b/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs new file mode 100644 index 00000000000..f8a32a6d930 --- /dev/null +++ b/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs @@ -0,0 +1,44 @@ +module Fake.DotNet.Testing.NUnitTests + +open System.IO +open Fake.Core +open Fake.DotNet +open Fake.DotNet.Testing +open Expecto + +[] +let tests = + testList "Fake.DotNet.Testing.NUnit.Tests" [ + testCase "Test that we write and delete arguments file" <| fun _ -> + let cp = + NUnit3.createProcess (fun param -> + { param with + ToolPath = "mynunit.exe" + }) [| "assembly.dll" |] + let file, args = + match cp.Command with + | RawCommand(file, args) -> file, args + | _ -> failwithf "expected RawCommand" + let file, args = + match Environment.isWindows, Process.monoPath with + | false, Some s when file = s -> + Expect.equal args.Args.Length 3 "Expected mono arguments" + Expect.equal args.Args.[0] "--debug" "Expected --debug flag" + args.Args.[1], Arguments.OfArgs args.Args.[2..] + | true, _ -> file, args + | _ -> + Trace.traceFAKE "Mono was not found in test!" + file, args + Expect.equal file "mynunit.exe" "Expected mynunit.exe" + Expect.equal args.Args.Length 1 "expected a single argument" + let arg = args.Args.[0] + Expect.stringStarts arg "@" "Expected arg to start with @" + let argFile = arg.Substring(1) + + ( use state = cp.Hook.PrepareState() + let contents = File.ReadAllText argFile + let args = Args.fromWindowsCommandLine contents + Expect.sequenceEqual args ["--noheader"; "assembly.dll"] "Expected arg file to be correct" + ) + Expect.isFalse (File.Exists argFile) "File should be deleted" + ]