From f5ef27681171c1eac4ff8c0a33ac4515ae622f45 Mon Sep 17 00:00:00 2001 From: Chris Blyth Date: Thu, 27 Sep 2018 16:02:11 +0100 Subject: [PATCH 01/12] Write the NUnit arguements to a temp file and pass that to NUnit console --- src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs index 393cb78030b..b6e141f29e8 100644 --- a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs +++ b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs @@ -316,7 +316,11 @@ let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = 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 + let generatedArgs = buildArgs parameters assemblies + let path = Path.Combine(Path.GetTempPath(), (sprintf "%s.txt" (Guid.NewGuid().ToString()))) + File.WriteAllText(path, generatedArgs) + Trace.trace(sprintf "Saved args to '%s' with value: %s" path generatedArgs) + let args = (sprintf "@%s" path) Trace.trace (tool + " " + args) let processTimeout = TimeSpan.MaxValue // Don't set a process timeout. The timeout is per test. let result = @@ -325,6 +329,9 @@ let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = FileName = tool WorkingDirectory = getWorkingDir parameters Arguments = args }) >> Process.withFramework) processTimeout + + File.Delete(path) + let errorDescription error = match error with | OK -> "OK" From da51beafd8c40efbf444f59116eaaae6e45d20a1 Mon Sep 17 00:00:00 2001 From: Chris Blyth Date: Fri, 28 Sep 2018 08:41:05 +0100 Subject: [PATCH 02/12] Reformat to be a try/finally --- src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs | 59 +++++++++++---------- 1 file changed, 31 insertions(+), 28 deletions(-) diff --git a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs index b6e141f29e8..44eee896afe 100644 --- a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs +++ b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs @@ -317,34 +317,37 @@ let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = if Array.isEmpty assemblies then failwith "NUnit: cannot run tests (the assembly list is empty)." let tool = parameters.ToolPath let generatedArgs = buildArgs parameters assemblies - let path = Path.Combine(Path.GetTempPath(), (sprintf "%s.txt" (Guid.NewGuid().ToString()))) - File.WriteAllText(path, generatedArgs) - Trace.trace(sprintf "Saved args to '%s' with value: %s" path generatedArgs) - let args = (sprintf "@%s" path) - 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 - - File.Delete(path) + let path = Path.GetTempFileName() + + try + File.WriteAllText(path, generatedArgs) + Trace.trace(sprintf "Saved args to '%s' with value: %s" path generatedArgs) + let args = (sprintf "@%s" path) + Trace.trace (tool + " " + args) + + 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)) + + finally + File.Delete(path) - 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() From fb8cc8218b7af79731a73317d1ed283efe1e402d Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Mon, 8 Oct 2018 18:15:53 +0200 Subject: [PATCH 03/12] start --- src/app/Fake.Core.Process/CmdLineParsing.fs | 17 ++++++++++++----- src/app/Fake.Core.Process/Proc.fs | 2 +- src/app/Fake.Core.Process/RawProc.fs | 12 ++++++++++-- 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/src/app/Fake.Core.Process/CmdLineParsing.fs b/src/app/Fake.Core.Process/CmdLineParsing.fs index 1a24d5f093f..a716c16c779 100644 --- a/src/app/Fake.Core.Process/CmdLineParsing.fs +++ b/src/app/Fake.Core.Process/CmdLineParsing.fs @@ -108,15 +108,19 @@ module internal CmdLineParsing = type FilePath = string +/// Helper functions for proper command line parsing module 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 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 } + private { Args : string array } static member Empty = { Args = [||] } /// See https://msdn.microsoft.com/en-us/library/17w5ykft.aspx static member OfWindowsCommandLine cmd = @@ -126,6 +130,9 @@ 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 diff --git a/src/app/Fake.Core.Process/Proc.fs b/src/app/Fake.Core.Process/Proc.fs index c3a59028fe4..46b327a8bd6 100644 --- a/src/app/Fake.Core.Process/Proc.fs +++ b/src/app/Fake.Core.Process/Proc.fs @@ -219,7 +219,7 @@ module CreateProcess = { c with Setup = fun _ -> combine (c.Setup()) (f()) } - let withEnvironment env (c:CreateProcess<_>)= + let withEnvironment (env: (string * string) list) (c:CreateProcess<_>)= { c with Environment = Some env } let withStandardOutput stdOut (c:CreateProcess<_>)= diff --git a/src/app/Fake.Core.Process/RawProc.fs b/src/app/Fake.Core.Process/RawProc.fs index 0c4c481f16f..e017a4228c6 100644 --- a/src/app/Fake.Core.Process/RawProc.fs +++ b/src/app/Fake.Core.Process/RawProc.fs @@ -3,6 +3,7 @@ open System.Reflection open Fake.Core.ProcessHelpers +/// 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 @@ -10,6 +11,8 @@ type Command = /// 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 +/// 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,15 +22,20 @@ 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 +/// The output of the process. If ordering between stdout and stderr is important you need to use streams. type ProcessOutput = { Output : string; Error : string } +/// A raw (untyped) way to start a process type RawCreateProcess = internal { Command : Command From b0b4e666b3be31d319cc58a55ad9b492e34999b8 Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 00:52:16 +0200 Subject: [PATCH 04/12] Add unit test for #2114 --- src/app/Fake.Core.Process/CmdLineParsing.fs | 8 +- .../Fake.Core.Process.fsproj | 1 + src/app/Fake.Core.Process/Proc.fs | 760 +++++++++++++++++- src/app/Fake.Core.Process/Process.fs | 20 +- src/app/Fake.Core.Process/RawProc.fs | 59 +- src/app/Fake.Core.Process/VisibleTo.fs | 7 + .../Fake.DotNet.Testing.NUnit.fsproj | 1 + src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs | 43 +- .../Fake.DotNet.Testing.NUnit/VisibleTo.fs | 7 + .../Fake.Core.UnitTests.fsproj | 2 + .../Fake.DotNet.Testing.NUnit.fs | 36 + 11 files changed, 881 insertions(+), 63 deletions(-) create mode 100644 src/app/Fake.Core.Process/VisibleTo.fs create mode 100644 src/app/Fake.DotNet.Testing.NUnit/VisibleTo.fs create mode 100644 src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs diff --git a/src/app/Fake.Core.Process/CmdLineParsing.fs b/src/app/Fake.Core.Process/CmdLineParsing.fs index a716c16c779..741338cc530 100644 --- a/src/app/Fake.Core.Process/CmdLineParsing.fs +++ b/src/app/Fake.Core.Process/CmdLineParsing.fs @@ -120,7 +120,7 @@ module Args = /// Represents a list of arguments type Arguments = - private { 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 = @@ -136,3 +136,9 @@ type Arguments = static member OfStartInfo cmd = Arguments.OfWindowsCommandLine cmd /// 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/Fake.Core.Process.fsproj b/src/app/Fake.Core.Process/Fake.Core.Process.fsproj index d783a2d7a91..6f3170a5796 100644 --- a/src/app/Fake.Core.Process/Fake.Core.Process.fsproj +++ b/src/app/Fake.Core.Process/Fake.Core.Process.fsproj @@ -28,6 +28,7 @@ + diff --git a/src/app/Fake.Core.Process/Proc.fs b/src/app/Fake.Core.Process/Proc.fs index 46b327a8bd6..8a0ae74d03c 100644 --- a/src/app/Fake.Core.Process/Proc.fs +++ b/src/app/Fake.Core.Process/Proc.fs @@ -88,18 +88,586 @@ module StreamExtensions = override __.Dispose(t) = if t then readStream.Dispose() } -type IProcessHook = + +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 + +/// Hook for events when an CreateProcess is executed. +type internal IProcessHook = inherit System.IDisposable - abstract member ProcessExited : int -> unit - abstract member ParseSuccess : int -> unit -type ResultGenerator<'TRes> = - { GetRawOutput : unit -> ProcessOutput - GetResult : ProcessOutput -> 'TRes } + abstract member ProcessStarted : System.Diagnostics.Process -> unit + abstract member ProcessExited : int -> Async + abstract member ParseSuccess : int -> Async +/// Generator for results +//type ResultGenerator<'TRes> = +// { GetRawOutput : unit -> ProcessOutput +// GetResult : ProcessOutput -> 'TRes } +/// Handle for creating a process and returning potential results. type CreateProcess<'TRes> = - private { + internal { Command : Command WorkingDirectory : string option - Environment : (string * string) list option + Environment : EnvMap option StandardInput : StreamSpecification StandardOutput : StreamSpecification StandardError : StreamSpecification @@ -107,7 +675,7 @@ type CreateProcess<'TRes> = Setup : unit -> IProcessHook GetResult : ProcessOutput -> 'TRes } - member x.Proc = + member internal x.Proc = { Command = x.Command WorkingDirectory = x.WorkingDirectory Environment = x.Environment @@ -116,20 +684,22 @@ type CreateProcess<'TRes> = StandardError = x.StandardError GetRawOutput = x.GetRawOutput } - member internal x.ToStartInfo = + member x.ToStartInfo = x.Proc.ToStartInfo member x.OutputRedirected = x.OutputRedirected member x.CommandLine = x.CommandLine +/// Module for creating and modifying CreateProcess<'TRes> instances module CreateProcess = - let emptyHook = + let internal emptyHook = { new IProcessHook with member __.Dispose () = () - member __.ProcessExited _ = () - member __.ParseSuccess _ = () } + member __.ProcessStarted _ = () + member __.ProcessExited _ = async.Return () + member __.ParseSuccess _ = async.Return () } - let ofProc x = + let internal ofProc (x:RawCreateProcess) = { Command = x.Command WorkingDirectory = x.WorkingDirectory Environment = x.Environment @@ -165,7 +735,7 @@ module CreateProcess = Environment = p.Environment |> Seq.map (fun kv -> kv.Key, kv.Value) - |> Seq.toList + |> EnvMap.ofSeq |> Some StandardInput = if p.RedirectStandardError then CreatePipe StreamRef.Empty else Inherit StandardOutput = if p.RedirectStandardError then CreatePipe StreamRef.Empty else Inherit @@ -213,22 +783,70 @@ module CreateProcess = 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<_>) = + member __.ProcessStarted proc = + d1.ProcessStarted proc + d2.ProcessStarted proc + member __.ProcessExited e = + async { + do! d1.ProcessExited(e) + do! d2.ProcessExited(e) + } + member __.ParseSuccess e = + async { + do! d1.ParseSuccess(e) + do! d2.ParseSuccess(e) + } + } + let internal addSetup f (c:CreateProcess<_>) = { c with Setup = fun _ -> combine (c.Setup()) (f()) } - + + let addOnSetup f (c:CreateProcess<_>) = + { c with + Setup = fun _ -> f(); c.Setup() } + let addOnFinally f (c:CreateProcess<_>) = + c + |> addSetup (fun _ -> + { new IProcessHook with + member __.Dispose () = f () + member __.ProcessStarted _ = () + member __.ProcessExited _ = async.Return () + member __.ParseSuccess _ = async.Return () } ) + let addOnStarted f (c:CreateProcess<_>) = + c + |> addSetup (fun _ -> + { new IProcessHook with + member __.Dispose () = () + member __.ProcessStarted proc = f proc + member __.ProcessExited _ = async.Return () + member __.ParseSuccess _ = async.Return () } ) + 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 withStandardOutput stdOut (c:CreateProcess<_>)= + 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 private withStandardOutput stdOut (c:CreateProcess<_>)= { c with StandardOutput = stdOut } - let withStandardError stdErr (c:CreateProcess<_>)= + let private withStandardError stdErr (c:CreateProcess<_>)= { c with StandardError = stdErr } - let withStandardInput stdIn (c:CreateProcess<_>)= + let private withStandardInput stdIn (c:CreateProcess<_>)= { c with StandardInput = stdIn } @@ -269,14 +887,61 @@ module CreateProcess = | Some _ -> x |> withResultFuncRaw f | None -> x |> redirectOutput |> withResultFuncRaw f + let withOutputEvents onStdOut onStdErr (c:CreateProcess<_>) = + 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 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 with + StandardOutput = + outMem + |> InternalStreams.StreamModule.createWriteOnlyPart (fun () -> closeOut() |> Async.RunSynchronously) + |> InternalStreams.StreamModule.fromInterface + |> fun s -> interceptStream s c.StandardOutput + StandardError = + errMem + |> InternalStreams.StreamModule.createWriteOnlyPart (fun () -> closeErr() |> Async.RunSynchronously) + |> InternalStreams.StreamModule.fromInterface + |> fun s -> interceptStream s c.StandardError } + |> addSetup (fun _ -> + let tOut = watchStream onStdOut outMemS + let tErr = watchStream onStdErr errMemS + { new IProcessHook with + member __.Dispose () = + outMem.Dispose() + errMem.Dispose() + member __.ProcessStarted _ = () + member __.ProcessExited exitCode = + async { + do! closeOut () + do! closeErr () + do! tOut + do! tErr + } + member __.ParseSuccess _ = async.Return () } + ) + let addOnExited f (r:CreateProcess<_>) = r |> addSetup (fun _ -> { new IProcessHook with member __.Dispose () = () + member __.ProcessStarted _ = () member __.ProcessExited exitCode = - if exitCode <> 0 then f exitCode - member __.ParseSuccess _ = () }) + async { + f exitCode + } + member __.ParseSuccess _ = async.Return () }) let ensureExitCodeWithMessage msg (r:CreateProcess<_>) = r |> addOnExited (fun exitCode -> @@ -311,6 +976,40 @@ module CreateProcess = //if Env.isVerbose then eprintfn "%s" msg ) + + /// 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 + + let withTimeout (timeout:System.TimeSpan) (c:CreateProcess<_>) = + let mutable startTime = None + c + |> addOnStarted (fun proc -> + startTime <- Some <| System.Diagnostics.Stopwatch.StartNew() + async { + do! Async.Sleep(int timeout.TotalMilliseconds) + if not proc.HasExited 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 + } + |> Async.StartImmediate) + |> addOnExited (fun exitCode -> + match exitCode, startTime with + | 0, _ -> () + | _, Some sw when sw.Elapsed > timeout -> + failwithf "Process '%s' timed out." c.CommandLine + | _ -> ()) + type ProcessResults<'a> = { ExitCode : int CreateProcess : CreateProcess<'a> @@ -320,9 +1019,9 @@ module Proc = async { use hook = c.Setup() - let! exitCode, output = RawProc.processStarter.Start(c.Proc) + let! exitCode, output = RawProc.processStarter.Start(c.Proc, hook.ProcessStarted) - hook.ProcessExited(exitCode) + do! hook.ProcessExited(exitCode) let o, realResult = match output with @@ -366,7 +1065,7 @@ module Proc = "Could not parse output from process, but RawOutput was not retrieved." raise <| System.Exception(msg, e) - hook.ParseSuccess exitCode + do! hook.ParseSuccess exitCode return { ExitCode = exitCode; CreateProcess = c; Result = result } } // Immediate makes sure we set the ref cell before we return the task... @@ -384,12 +1083,15 @@ module Proc = /// (ie if you use StartAsTask and access reference cells in CreateProcess after that returns) let startAndAwait c = start c |> Async.AwaitTaskWithoutAggregate + let runRaw c = (startRaw c).Result + let run c = startAndAwait c |> Async.RunSynchronously + 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 + hook.ProcessExited r.ExitCode |> Async.RunSynchronously r.Result let getResultIgnoreExitCode (r:ProcessResults<_>) = @@ -400,7 +1102,7 @@ module Proc = { r.CreateProcess with Setup = fun _ -> CreateProcess.emptyHook } |> CreateProcess.ensureExitCode let hook = f () - hook.ProcessExited r.ExitCode + hook.ProcessExited r.ExitCode |> Async.RunSynchronously 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 15fa53c2965..1046230f68f 100644 --- a/src/app/Fake.Core.Process/Process.fs +++ b/src/app/Fake.Core.Process/Process.fs @@ -98,7 +98,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 @@ -125,7 +125,7 @@ type ProcStartInfo = Verb = "" #endif WorkingDirectory = "" } - [] + [] static member Empty = ProcStartInfo.Create() /// Sets the current environment variables. member x.WithEnvironment map = @@ -340,11 +340,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 @@ -358,6 +354,16 @@ module Process = DateTime.Now addStartedProcess(proc.Id, startTime) |> ignore + let inline internal rawStartProcessNoRecord (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 internal rawStartProcess (proc : Process) = + rawStartProcessNoRecord proc + recordProcess proc + /// [omit] [] let startProcess (proc : Process) = diff --git a/src/app/Fake.Core.Process/RawProc.fs b/src/app/Fake.Core.Process/RawProc.fs index e017a4228c6..77d772f33eb 100644 --- a/src/app/Fake.Core.Process/RawProc.fs +++ b/src/app/Fake.Core.Process/RawProc.fs @@ -1,7 +1,44 @@ 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 = @@ -40,7 +77,7 @@ type RawCreateProcess = internal { Command : Command WorkingDirectory : string option - Environment : (string * string) list option + Environment : EnvMap option StandardInput : StreamSpecification StandardOutput : StreamSpecification StandardError : StreamSpecification @@ -67,18 +104,22 @@ type RawCreateProcess = p.RedirectStandardOutput <- false | UseStream _ | CreatePipe _ -> p.RedirectStandardOutput <- true + if Environment.isMono || Process.AlwaysSetProcessEncoding then + p.StandardOutputEncoding <- Process.ProcessEncoding match x.StandardError with | Inherit -> p.RedirectStandardError <- false | UseStream _ | CreatePipe _ -> p.RedirectStandardError <- true + if Environment.isMono || Process.AlwaysSetProcessEncoding then + p.StandardErrorEncoding <- Process.ProcessEncoding 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 @@ -91,7 +132,7 @@ type RawCreateProcess = | RawCommand (f, arg) -> sprintf "%s %s" f arg.ToWindowsCommandLine type IProcessStarter = - abstract Start : RawCreateProcess -> Async + abstract Start : RawCreateProcess * (System.Diagnostics.Process -> unit) -> Async module RawProc = // mono sets echo off for some reason, therefore interactive mode doesn't work as expected @@ -115,9 +156,9 @@ module RawProc = open System.Diagnostics open System.IO - let mutable processStarter = + let createProcessStarter globalStartFunc = { new IProcessStarter with - member __.Start c = async { + member __.Start (c, startFunc) = async { let p = c.ToStartInfo let commandLine = sprintf "%s> \"%s\" %s" p.WorkingDirectory p.FileName p.Arguments @@ -135,7 +176,9 @@ module RawProc = if not <| !isStarted then toolProcess.EnableRaisingEvents <- true setEcho true |> ignore - Process.rawStartProcess toolProcess + Process.rawStartProcessNoRecord toolProcess + globalStartFunc toolProcess + startFunc toolProcess isStarted := true let handleStream parameter processStream isInputStream = @@ -205,4 +248,6 @@ module RawProc = | None -> None return toolProcess.ExitCode, output } - } \ No newline at end of file + } + + let mutable processStarter = createProcessStarter Process.recordProcess \ No newline at end of file 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.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 44eee896afe..162eb1ec0b2 100644 --- a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs +++ b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs @@ -309,28 +309,27 @@ 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 generatedArgs = buildArgs parameters assemblies - let processTimeout = TimeSpan.MaxValue // Don't set a process timeout. The timeout is per test. + //let processTimeout = TimeSpan.MaxValue // Don't set a process timeout. The timeout is per test. + let path = Path.GetTempFileName() - - try + 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) - let args = (sprintf "@%s" path) - Trace.trace (tool + " " + args) - - let result = Process.execSimple ((fun info -> { info with - FileName = tool - WorkingDirectory = getWorkingDir parameters - Arguments = args }) >> Process.withFramework) processTimeout - + ) + |> CreateProcess.addOnFinally (fun () -> + File.Delete(path) + ) + |> CreateProcess.addOnExited (fun result -> let errorDescription error = match error with | OK -> "OK" @@ -346,8 +345,14 @@ let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = match result with | OK -> () | _ -> raise (FailedTestsException(errorDescription result)) + ) - finally - File.Delete(path) - - __.MarkSuccess() +let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = + let assemblies = assemblies |> Seq.toArray + let details = assemblies |> String.separated ", " + use __ = Trace.traceTask "NUnit" details + let p = createProcess setParams assemblies + p + |> 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.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.Testing.NUnit.fs b/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs new file mode 100644 index 00000000000..021659ede50 --- /dev/null +++ b/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs @@ -0,0 +1,36 @@ +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" + if not Environment.isMono then + 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 hook = cp.Setup() + let contents = File.ReadAllText argFile + let args = Args.fromWindowsCommandLine contents + Expect.sequenceEqual args ["--noheader"; "assembly.dll"] "Expected arg file to be correct" + hook.ProcessExited 0 |> Async.RunSynchronously) + Expect.isFalse (File.Exists argFile) "File should be deleted" + + ] From ec294307c40aca5f2881d2b05424bed04ffa1d39 Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 08:57:26 +0200 Subject: [PATCH 05/12] fix test on unix --- .../Fake.DotNet.Testing.NUnit.fs | 36 +++++++++++-------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs b/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs index 021659ede50..cee5e8c6d0d 100644 --- a/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs +++ b/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs @@ -19,18 +19,26 @@ let tests = match cp.Command with | RawCommand(file, args) -> file, args | _ -> failwithf "expected RawCommand" - if not Environment.isMono then - 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 hook = cp.Setup() - let contents = File.ReadAllText argFile - let args = Args.fromWindowsCommandLine contents - Expect.sequenceEqual args ["--noheader"; "assembly.dll"] "Expected arg file to be correct" - hook.ProcessExited 0 |> Async.RunSynchronously) - Expect.isFalse (File.Exists argFile) "File should be deleted" - + 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 hook = cp.Setup() + let contents = File.ReadAllText argFile + let args = Args.fromWindowsCommandLine contents + Expect.sequenceEqual args ["--noheader"; "assembly.dll"] "Expected arg file to be correct" + hook.ProcessExited 0 |> Async.RunSynchronously) + Expect.isFalse (File.Exists argFile) "File should be deleted" ] From 2be05650b15bfcdcd672dd96137e659126753c06 Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 09:30:21 +0200 Subject: [PATCH 06/12] update pr template --- .github/PULL_REQUEST_TEMPLATE.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index fa11a60ab9f..dae3076b297 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -8,8 +8,13 @@ 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) + - [] (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`) From 688a5560055e840b2ddaedfdc86ac144b16ac94f Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 09:51:23 +0200 Subject: [PATCH 07/12] simplify a bit --- src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs index 162eb1ec0b2..75448bebe6f 100644 --- a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs +++ b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs @@ -351,8 +351,7 @@ let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = let assemblies = assemblies |> Seq.toArray let details = assemblies |> String.separated ", " use __ = Trace.traceTask "NUnit" details - let p = createProcess setParams assemblies - p + createProcess setParams assemblies |> Proc.run __.MarkSuccess() \ No newline at end of file From 206f88300a7f19a8b14fafcfc76269a2136cc70d Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 14:56:58 +0200 Subject: [PATCH 08/12] cleanup of the new api --- src/app/Fake.Core.Process/Proc.fs | 604 +++++++++++------- src/app/Fake.Core.Process/RawProc.fs | 132 ++-- src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs | 10 +- .../Fake.DotNet.Testing.NUnit.fs | 4 +- 4 files changed, 444 insertions(+), 306 deletions(-) diff --git a/src/app/Fake.Core.Process/Proc.fs b/src/app/Fake.Core.Process/Proc.fs index 8a0ae74d03c..39498334cb7 100644 --- a/src/app/Fake.Core.Process/Proc.fs +++ b/src/app/Fake.Core.Process/Proc.fs @@ -1,5 +1,6 @@ namespace Fake.Core +open System open System.IO open System.Diagnostics open Fake.Core.ProcessHelpers @@ -653,11 +654,37 @@ module internal InternalStreams = fun () -> istream /// Hook for events when an CreateProcess is executed. -type internal IProcessHook = - inherit System.IDisposable - abstract member ProcessStarted : System.Diagnostics.Process -> unit - abstract member ProcessExited : int -> Async - abstract member ParseSuccess : int -> Async +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 @@ -668,62 +695,52 @@ type CreateProcess<'TRes> = Command : Command WorkingDirectory : string option Environment : EnvMap option - StandardInput : StreamSpecification - StandardOutput : StreamSpecification - StandardError : StreamSpecification - GetRawOutput : (unit -> ProcessOutput) option - Setup : unit -> IProcessHook - GetResult : ProcessOutput -> 'TRes + Streams : StreamSpecs + Hook : IProcessHook<'TRes> } - member internal x.Proc = - { Command = x.Command - WorkingDirectory = x.WorkingDirectory - Environment = x.Environment - StandardInput = x.StandardInput - StandardOutput = x.StandardOutput - StandardError = x.StandardError - GetRawOutput = x.GetRawOutput } - member x.ToStartInfo = - x.Proc.ToStartInfo + //member x.OutputRedirected = x.HasRedirect + member x.CommandLine = x.Command.CommandLine - member x.OutputRedirected = x.OutputRedirected - member x.CommandLine = x.CommandLine /// Module for creating and modifying CreateProcess<'TRes> instances module CreateProcess = let internal emptyHook = - { new IProcessHook with - member __.Dispose () = () - member __.ProcessStarted _ = () - member __.ProcessExited _ = async.Return () - member __.ParseSuccess _ = async.Return () } + { new IProcessHook> with + member __.PrepareState () = null + member __.PrepareStreams (_, specs) = specs + member __.ProcessStarted (_,_) = () + member __.RetrieveResult (_, t) = + async { + let! raw = Async.AwaitTask t + return { ExitCode = raw.RawExitCode; Result = () } + } } - let internal ofProc (x:RawCreateProcess) = + (*let internal ofProc (x:RawCreateProcess) = { 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 _ -> () } + 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 - // 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 } + 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 = @@ -737,31 +754,34 @@ module CreateProcess = |> Seq.map (fun kv -> kv.Key, kv.Value) |> EnvMap.ofSeq |> 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) = + 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 -> Inherit + | 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 _ -> Inherit) target s 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 } + 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 @@ -780,46 +800,105 @@ module 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 __.ProcessStarted proc = - d1.ProcessStarted proc - d2.ProcessStarted proc - member __.ProcessExited e = - async { - do! d1.ProcessExited(e) - do! d2.ProcessExited(e) - } - member __.ParseSuccess e = + + 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 { - do! d1.ParseSuccess(e) - do! d2.ParseSuccess(e) - } - } - let internal addSetup f (c:CreateProcess<_>) = - { c with - Setup = fun _ -> combine (c.Setup()) (f()) } + 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 with - Setup = fun _ -> f(); c.Setup() } + c + |> appendSimpleFuncs + (fun _ -> f()) + (fun state p -> ()) + (fun prev state exitCode -> prev) + (fun _ -> ()) let addOnFinally f (c:CreateProcess<_>) = c - |> addSetup (fun _ -> - { new IProcessHook with - member __.Dispose () = f () - member __.ProcessStarted _ = () - member __.ProcessExited _ = async.Return () - member __.ParseSuccess _ = async.Return () } ) + |> appendSimpleFuncs + (fun _ -> ()) + (fun state p -> ()) + (fun prev state exitCode -> prev) + (fun _ -> f ()) let addOnStarted f (c:CreateProcess<_>) = c - |> addSetup (fun _ -> - { new IProcessHook with - member __.Dispose () = () - member __.ProcessStarted proc = f proc - member __.ProcessExited _ = async.Return () - member __.ParseSuccess _ = async.Return () } ) + |> appendSimpleFuncs + (fun _ -> ()) + (fun state p -> f ()) + (fun prev state exitCode -> prev) + (fun _ -> ()) let withEnvironment (env: (string * string) list) (c:CreateProcess<_>)= { c with @@ -840,58 +919,69 @@ module CreateProcess = |> IMap.add envKey envVar |> Some } - let private withStandardOutput stdOut (c:CreateProcess<_>)= + let withStandardOutput stdOut (c:CreateProcess<_>)= { c with - StandardOutput = stdOut } - let private withStandardError stdErr (c:CreateProcess<_>)= + Streams = + { c.Streams with + StandardOutput = stdOut } } + let withStandardError stdErr (c:CreateProcess<_>)= { c with - StandardError = stdErr } - let private withStandardInput stdIn (c:CreateProcess<_>)= + Streams = + { c.Streams with + StandardError = stdErr } } + let withStandardInput stdIn (c:CreateProcess<_>)= { c with - StandardInput = stdIn } + Streams = + { c.Streams 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 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<_>) = - 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 - + 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)) outMem streams.StandardError + }) + (fun (outMem, errMem) p -> ()) + (fun prev (outMem, errMem) exitCode -> + async { + let! prevResult = prev + let! exitCode = exitCode |> Async.AwaitTask + 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 closeOut, outMem = InternalStreams.StreamModule.limitedStream() - let closeErr, errMem = InternalStreams.StreamModule.limitedStream() - let outMemS = InternalStreams.StreamModule.fromInterface outMem - let errMemS = InternalStreams.StreamModule.fromInterface errMem let watchStream onF (stream:System.IO.Stream) = async { let reader = new System.IO.StreamReader(stream) @@ -902,80 +992,104 @@ module CreateProcess = onF line } |> fun a -> Async.StartImmediateAsTask(a) - { c with - StandardOutput = - outMem - |> InternalStreams.StreamModule.createWriteOnlyPart (fun () -> closeOut() |> Async.RunSynchronously) - |> InternalStreams.StreamModule.fromInterface - |> fun s -> interceptStream s c.StandardOutput - StandardError = - errMem - |> InternalStreams.StreamModule.createWriteOnlyPart (fun () -> closeErr() |> Async.RunSynchronously) - |> InternalStreams.StreamModule.fromInterface - |> fun s -> interceptStream s c.StandardError } - |> addSetup (fun _ -> - let tOut = watchStream onStdOut outMemS - let tErr = watchStream onStdErr errMemS - { new IProcessHook with - member __.Dispose () = - outMem.Dispose() - errMem.Dispose() - member __.ProcessStarted _ = () - member __.ProcessExited exitCode = - async { - do! closeOut () - do! closeErr () - do! tOut - do! tErr - } - member __.ParseSuccess _ = async.Return () } - ) + 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 (r:CreateProcess<_>) = - r - |> addSetup (fun _ -> - { new IProcessHook with - member __.Dispose () = () - member __.ProcessStarted _ = () - member __.ProcessExited exitCode = - async { - f exitCode - } - member __.ParseSuccess _ = async.Return () }) + 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 exitCode -> - if exitCode <> 0 then failwith msg) + |> 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 exitCode -> + |> addOnExited (fun data exitCode -> if exitCode <> 0 then + let output = tryGetOutput (data :> obj) let msg = - match r.GetRawOutput with - | Some f -> - let output = f() + 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 + (sprintf "Process exit code '%d' <> 0. Command Line: %s" exitCode r.CommandLine) + failwith msg + else + data ) let warnOnExitCode msg (r:CreateProcess<_>) = r - |> addOnExited (fun exitCode -> + |> addOnExited (fun data exitCode -> if exitCode <> 0 then + let output = tryGetOutput (data :> obj) let msg = - match r.GetRawOutput with - | Some f -> - let output = f() + 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) /// 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<_>) = @@ -987,42 +1101,73 @@ module CreateProcess = 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 + + type internal TimeoutState = + { Stopwatch : System.Diagnostics.Stopwatch + mutable Process : Process } let withTimeout (timeout:System.TimeSpan) (c:CreateProcess<_>) = let mutable startTime = None c - |> addOnStarted (fun proc -> - startTime <- Some <| System.Diagnostics.Stopwatch.StartNew() - async { - do! Async.Sleep(int timeout.TotalMilliseconds) - if not proc.HasExited 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 - } - |> Async.StartImmediate) - |> addOnExited (fun exitCode -> - match exitCode, startTime with - | 0, _ -> () - | _, Some sw when sw.Elapsed > timeout -> - failwithf "Process '%s' timed out." c.CommandLine - | _ -> ()) + |> appendSimpleFuncs + (fun _ -> + { Stopwatch = System.Diagnostics.Stopwatch.StartNew() + Process = null }) + (fun state proc -> + state.Process <- proc + state.Stopwatch.Restart() + async { + do! Async.Sleep(int timeout.TotalMilliseconds) + if not proc.HasExited 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 + } + |> Async.StartImmediate) + (fun prev state exitCode -> + async { + let! e = exitCode |> Async.AwaitTask + state.Stopwatch.Stop() + let! prevResult = prev + match e.RawExitCode with + | 0 -> + return prevResult + | _ when state.Stopwatch.Elapsed > timeout -> + failwithf "Process '%s' timed out." c.CommandLine + | _ -> + return prevResult + }) + (fun state -> state.Stopwatch.Stop()) + + +type AsyncProcessResult<'a> = { Result : System.Threading.Tasks.Task<'a>; Raw : System.Threading.Tasks.Task } -type ProcessResults<'a> = - { ExitCode : int - CreateProcess : CreateProcess<'a> - Result : 'a } module Proc = let startRaw (c:CreateProcess<_>) = async { - use hook = c.Setup() + let hook = c.Hook - let! exitCode, output = RawProc.processStarter.Start(c.Proc, hook.ProcessStarted) + use state = hook.PrepareState () + 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! exitCode = RawProc.processStarter.Start(procRaw) - do! hook.ProcessExited(exitCode) + let output = + hook.RetrieveResult (state, exitCode) + |> Async.StartImmediateAsTask + return { Result = output; Raw = exitCode } +(* let o, realResult = match output with | Some f -> f, true @@ -1066,7 +1211,7 @@ module Proc = raise <| System.Exception(msg, e) do! hook.ParseSuccess exitCode - return { ExitCode = exitCode; CreateProcess = c; Result = result } + return { ExitCode = exitCode; CreateProcess = c; Result = result }*) } // Immediate makes sure we set the ref cell before we return the task... |> Async.StartImmediateAsTask @@ -1074,7 +1219,7 @@ module Proc = let start c = async { let! result = startRaw c - return result.Result + return! result.Result |> Async.AwaitTask } |> Async.StartImmediateAsTask @@ -1085,24 +1230,3 @@ module Proc = let runRaw c = (startRaw c).Result let run c = startAndAwait c |> Async.RunSynchronously - - 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 |> Async.RunSynchronously - 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 |> Async.RunSynchronously - r.Result - - \ 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 77d772f33eb..fdfc290781e 100644 --- a/src/app/Fake.Core.Process/RawProc.fs +++ b/src/app/Fake.Core.Process/RawProc.fs @@ -47,6 +47,11 @@ type Command = /// 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" @@ -69,31 +74,11 @@ type StreamSpecification = /// 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 -/// The output of the process. If ordering between stdout and stderr is important you need to use streams. -type ProcessOutput = { Output : string; Error : string } - -/// A raw (untyped) way to start a process -type RawCreateProcess = - internal { - Command : Command - WorkingDirectory : string option - Environment : EnvMap 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 @@ -114,6 +99,32 @@ type RawCreateProcess = if Environment.isMono || Process.AlwaysSetProcessEncoding then p.StandardErrorEncoding <- Process.ProcessEncoding + +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 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 @@ -125,14 +136,12 @@ type RawCreateProcess = #endif 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 * (System.Diagnostics.Process -> unit) -> Async + abstract Start : RawCreateProcess -> Async> module RawProc = // mono sets echo off for some reason, therefore interactive mode doesn't work as expected @@ -158,8 +167,11 @@ module RawProc = open System.IO let createProcessStarter globalStartFunc = { new IProcessStarter with - member __.Start (c, startFunc) = async { + member __.Start c = async { let p = c.ToStartInfo + let streamSpec = c.OutputHook.Prepare c.Streams + streamSpec.SetStartInfo p + let commandLine = sprintf "%s> \"%s\" %s" p.WorkingDirectory p.FileName p.Arguments @@ -178,7 +190,7 @@ module RawProc = setEcho true |> ignore Process.rawStartProcessNoRecord toolProcess globalStartFunc toolProcess - startFunc toolProcess + c.OutputHook.OnStart (toolProcess) isStarted := true let handleStream parameter processStream isInputStream = @@ -202,52 +214,54 @@ 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) // 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 |> 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 + let exitCode = + async { + do! exitEvent |> Async.AwaitTask |> Async.Ignore + // Waiting for the process to exit (buffers) + toolProcess.WaitForExit() - return toolProcess.ExitCode, output } + 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 + + return { RawExitCode = toolProcess.ExitCode } + } + |> Async.StartImmediateAsTask + + return exitCode } } let mutable processStarter = createProcessStarter Process.recordProcess \ No newline at end of file diff --git a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs index 75448bebe6f..ad30fb16d4e 100644 --- a/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs +++ b/src/app/Fake.DotNet.Testing.NUnit/NUnit3.fs @@ -329,7 +329,7 @@ let internal createProcess (setParams : NUnit3Params -> NUnit3Params) (assemblie |> CreateProcess.addOnFinally (fun () -> File.Delete(path) ) - |> CreateProcess.addOnExited (fun result -> + |> CreateProcess.addOnExited (fun result exitCode -> let errorDescription error = match error with | OK -> "OK" @@ -338,13 +338,13 @@ let internal createProcess (setParams : NUnit3Params -> NUnit3Params) (assemblie match parameters.ErrorLevel with | NUnit3ErrorLevel.DontFailBuild -> - match result with + match exitCode with | OK | TestsFailed -> () - | _ -> raise (FailedTestsException(errorDescription result)) + | _ -> raise (FailedTestsException(errorDescription exitCode)) | NUnit3ErrorLevel.Error | FailOnFirstError -> - match result with + match exitCode with | OK -> () - | _ -> raise (FailedTestsException(errorDescription result)) + | _ -> raise (FailedTestsException(errorDescription exitCode)) ) let run (setParams : NUnit3Params -> NUnit3Params) (assemblies : string seq) = diff --git a/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs b/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs index cee5e8c6d0d..f8a32a6d930 100644 --- a/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs +++ b/src/test/Fake.Core.UnitTests/Fake.DotNet.Testing.NUnit.fs @@ -35,10 +35,10 @@ let tests = Expect.stringStarts arg "@" "Expected arg to start with @" let argFile = arg.Substring(1) - ( use hook = cp.Setup() + ( 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" - hook.ProcessExited 0 |> Async.RunSynchronously) + ) Expect.isFalse (File.Exists argFile) "File should be deleted" ] From 04e6664681a03247a95ef76805ea0396df514c38 Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 17:22:57 +0200 Subject: [PATCH 09/12] move stuff around and mark a lot of APIs internal --- .github/PULL_REQUEST_TEMPLATE.md | 1 + src/app/Fake.Core.Process/CreateProcess.fs | 491 +++++++++++++++ src/app/Fake.Core.Process/CreateProcessExt.fs | 14 + .../Fake.Core.Process.fsproj | 7 +- .../{Proc.fs => InternalStreams.fs} | 580 +----------------- src/app/Fake.Core.Process/Process.fs | 295 +++++---- src/app/Fake.Core.Process/ProcessUtils.fs | 90 +++ src/app/Fake.Core.Process/RawProc.fs | 24 +- 8 files changed, 793 insertions(+), 709 deletions(-) create mode 100644 src/app/Fake.Core.Process/CreateProcess.fs create mode 100644 src/app/Fake.Core.Process/CreateProcessExt.fs rename src/app/Fake.Core.Process/{Proc.fs => InternalStreams.fs} (54%) create mode 100644 src/app/Fake.Core.Process/ProcessUtils.fs diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index dae3076b297..e1112f2a2bf 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -15,6 +15,7 @@ Feel free to open the PR and ask for help > 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.Process/CreateProcess.fs b/src/app/Fake.Core.Process/CreateProcess.fs new file mode 100644 index 00000000000..f5cc42977a6 --- /dev/null +++ b/src/app/Fake.Core.Process/CreateProcess.fs @@ -0,0 +1,491 @@ +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.AwaitTask 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 _ -> Inherit) 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)) outMem streams.StandardError + }) + (fun (outMem, errMem) p -> ()) + (fun prev (outMem, errMem) exitCode -> + async { + let! prevResult = prev + let! exitCode = exitCode |> Async.AwaitTask + 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 } + let withTimeout (timeout:System.TimeSpan) (c:CreateProcess<_>) = + c + |> appendSimpleFuncs + (fun _ -> + { Stopwatch = System.Diagnostics.Stopwatch.StartNew() }) + (fun state proc -> + state.Stopwatch.Restart() + async { + do! Async.Sleep(int timeout.TotalMilliseconds) + if not proc.HasExited 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 + } + |> Async.StartImmediate) + (fun prev state exitCode -> + async { + let! e = exitCode |> Async.AwaitTask + 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 6f3170a5796..72f0fa99142 100644 --- a/src/app/Fake.Core.Process/Fake.Core.Process.fsproj +++ b/src/app/Fake.Core.Process/Fake.Core.Process.fsproj @@ -33,10 +33,13 @@ - + - + + + + diff --git a/src/app/Fake.Core.Process/Proc.fs b/src/app/Fake.Core.Process/InternalStreams.fs similarity index 54% rename from src/app/Fake.Core.Process/Proc.fs rename to src/app/Fake.Core.Process/InternalStreams.fs index 39498334cb7..6be482e65f1 100644 --- a/src/app/Fake.Core.Process/Proc.fs +++ b/src/app/Fake.Core.Process/InternalStreams.fs @@ -1,4 +1,4 @@ -namespace Fake.Core +namespace Fake.Core open System open System.IO @@ -652,581 +652,3 @@ module internal InternalStreams = let getStandardError = let istream = defaultError |> toInterface 1024 fun () -> istream - -/// 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.AwaitTask 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 _ -> Inherit) 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)) outMem streams.StandardError - }) - (fun (outMem, errMem) p -> ()) - (fun prev (outMem, errMem) exitCode -> - async { - let! prevResult = prev - let! exitCode = exitCode |> Async.AwaitTask - 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) - - /// 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 - - - type internal TimeoutState = - { Stopwatch : System.Diagnostics.Stopwatch - mutable Process : Process } - let withTimeout (timeout:System.TimeSpan) (c:CreateProcess<_>) = - let mutable startTime = None - c - |> appendSimpleFuncs - (fun _ -> - { Stopwatch = System.Diagnostics.Stopwatch.StartNew() - Process = null }) - (fun state proc -> - state.Process <- proc - state.Stopwatch.Restart() - async { - do! Async.Sleep(int timeout.TotalMilliseconds) - if not proc.HasExited 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 - } - |> Async.StartImmediate) - (fun prev state exitCode -> - async { - let! e = exitCode |> Async.AwaitTask - state.Stopwatch.Stop() - let! prevResult = prev - match e.RawExitCode with - | 0 -> - return prevResult - | _ when state.Stopwatch.Elapsed > timeout -> - failwithf "Process '%s' timed out." c.CommandLine - | _ -> - return prevResult - }) - (fun state -> state.Stopwatch.Stop()) - - -type AsyncProcessResult<'a> = { Result : System.Threading.Tasks.Task<'a>; Raw : System.Threading.Tasks.Task } - -module Proc = - let startRaw (c:CreateProcess<_>) = - async { - let hook = c.Hook - - use state = hook.PrepareState () - 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! exitCode = RawProc.processStarter.Start(procRaw) - - let output = - hook.RetrieveResult (state, exitCode) - |> Async.StartImmediateAsTask - - return { Result = output; Raw = 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) - - do! 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.AwaitTask - } - |> 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 runRaw c = (startRaw c).Result - let run c = startAndAwait c |> Async.RunSynchronously diff --git a/src/app/Fake.Core.Process/Process.fs b/src/app/Fake.Core.Process/Process.fs index 1046230f68f..0fcc45663b4 100644 --- a/src/app/Fake.Core.Process/Process.fs +++ b/src/app/Fake.Core.Process/Process.fs @@ -248,6 +248,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 = @@ -364,6 +366,53 @@ module Process = rawStartProcessNoRecord proc recordProcess proc + let mutable internal processStarter = + RawProc.createProcessStarter (fun p -> + if Environment.isMono || AlwaysSetProcessEncoding then + p.StartInfo.StandardOutputEncoding <- ProcessEncoding + p.StartInfo.StandardErrorEncoding <- ProcessEncoding + rawStartProcessNoRecord p + recordProcess p) + + [] + module internal Proc = + open Fake.Core.ProcessHelpers + let startRaw (c:CreateProcess<_>) = + async { + let hook = c.Hook + + use state = hook.PrepareState () + 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! exitCode = processStarter.Start(procRaw) + + let output = + hook.RetrieveResult (state, exitCode) + |> Async.StartImmediateAsTask + + 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.AwaitTask + } + |> Async.StartImmediateAsTask + let startAndAwait c = start c |> Async.AwaitTaskWithoutAggregate + let runRaw c = (startRaw c).Result + let run c = startAndAwait c |> Async.RunSynchronously + /// [omit] [] let startProcess (proc : Process) = @@ -454,12 +503,20 @@ module Process = |> setEnvironmentVariable defaultEnvVar defaultEnvVar + let inline 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 /// @@ -468,51 +525,31 @@ 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 messageF errorF + |> 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 [] @@ -538,6 +575,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 @@ -565,30 +603,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.start + |> 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.start + |> ignore /// Adds quotes around the string /// [omit] + [] let quote (str:string) = // "\"" + str.Replace("\"","\\\"") + "\"" CmdLineParsing.windowsArgvToCommandLine [ 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 @@ -596,32 +642,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 @@ -636,68 +689,23 @@ module Process = paramValue ]) |> CmdLineParsing.windowsArgvToCommandLine - /// 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 = @@ -713,22 +721,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 @@ -746,6 +749,7 @@ module Process = /// 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!" @@ -843,9 +847,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 -> @@ -975,3 +978,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 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 runRaw c = Process.Proc.runRaw 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 fdfc290781e..55df27a85fd 100644 --- a/src/app/Fake.Core.Process/RawProc.fs +++ b/src/app/Fake.Core.Process/RawProc.fs @@ -89,15 +89,11 @@ type internal StreamSpecs = p.RedirectStandardOutput <- false | UseStream _ | CreatePipe _ -> p.RedirectStandardOutput <- true - if Environment.isMono || Process.AlwaysSetProcessEncoding then - p.StandardOutputEncoding <- Process.ProcessEncoding match x.StandardError with | Inherit -> p.RedirectStandardError <- false | UseStream _ | CreatePipe _ -> p.RedirectStandardError <- true - if Environment.isMono || Process.AlwaysSetProcessEncoding then - p.StandardErrorEncoding <- Process.ProcessEncoding type internal IRawProcessHook = @@ -106,7 +102,7 @@ type internal IRawProcessHook = //abstract member Retrieve : IDisposable * System.Threading.Tasks.Task -> Async<'TRes> /// A raw (untyped) way to start a process -type RawCreateProcess = +type internal RawCreateProcess = internal { Command : Command WorkingDirectory : string option @@ -140,10 +136,11 @@ type RawCreateProcess = type RawProcessResult = { RawExitCode : int } -type IProcessStarter = +type internal IProcessStarter = abstract Start : RawCreateProcess -> Async> -module RawProc = +module internal 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) = @@ -165,7 +162,7 @@ module RawProc = open System.Diagnostics open System.IO - let createProcessStarter globalStartFunc = + let internal createProcessStarter startProcessRaw = { new IProcessStarter with member __.Start c = async { let p = c.ToStartInfo @@ -177,7 +174,7 @@ module RawProc = 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 readOutputTask = System.Threading.Tasks.Task.FromResult Stream.Null @@ -188,8 +185,7 @@ module RawProc = if not <| !isStarted then toolProcess.EnableRaisingEvents <- true setEcho true |> ignore - Process.rawStartProcessNoRecord toolProcess - globalStartFunc toolProcess + startProcessRaw toolProcess c.OutputHook.OnStart (toolProcess) isStarted := true @@ -257,11 +253,11 @@ module RawProc = for s in streams do s.Dispose() setEcho false |> ignore - return { RawExitCode = toolProcess.ExitCode } + let code = toolProcess.ExitCode + toolProcess.Dispose() + return { RawExitCode = code } } |> Async.StartImmediateAsTask return exitCode } } - - let mutable processStarter = createProcessStarter Process.recordProcess \ No newline at end of file From 5ba591fef7a31cf3aa6d17de1625248854ab128c Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 17:51:21 +0200 Subject: [PATCH 10/12] try to fix tests --- src/app/Fake.Core.Process/Process.fs | 9 +++++---- src/app/Fake.Core.Process/RawProc.fs | 9 ++++++--- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/src/app/Fake.Core.Process/Process.fs b/src/app/Fake.Core.Process/Process.fs index 0fcc45663b4..bda580bd6ab 100644 --- a/src/app/Fake.Core.Process/Process.fs +++ b/src/app/Fake.Core.Process/Process.fs @@ -409,8 +409,9 @@ module Process = return! result.Result |> Async.AwaitTask } |> Async.StartImmediateAsTask + let startRawSync c = (startRaw c).Result + let startAndAwait c = start c |> Async.AwaitTaskWithoutAggregate - let runRaw c = (startRaw c).Result let run c = startAndAwait c |> Async.RunSynchronously /// [omit] @@ -606,7 +607,7 @@ module Process = [] let fireAndForget configProcessStartInfoF = getProcI configProcessStartInfoF - |> Proc.start + |> Proc.startRawSync |> ignore //rawStartProcess proc @@ -622,7 +623,7 @@ module Process = [] let start configProcessStartInfoF = getProcI configProcessStartInfoF - |> Proc.start + |> Proc.startRawSync |> ignore /// Adds quotes around the string @@ -1033,6 +1034,7 @@ module Proc = 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 @@ -1040,5 +1042,4 @@ module Proc = /// (ie if you use StartAsTask and access reference cells in CreateProcess after that returns) let startAndAwait c = Process.Proc.startAndAwait c - let runRaw c = Process.Proc.runRaw c let run c = Process.Proc.run diff --git a/src/app/Fake.Core.Process/RawProc.fs b/src/app/Fake.Core.Process/RawProc.fs index 55df27a85fd..33774c12cf2 100644 --- a/src/app/Fake.Core.Process/RawProc.fs +++ b/src/app/Fake.Core.Process/RawProc.fs @@ -144,12 +144,15 @@ module internal 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) From 8e1c5e877001518d6eb29b5b572ec5f0fac58e7c Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 21:13:20 +0200 Subject: [PATCH 11/12] Fix existing tests. Simplify command line when quotes are not required --- src/app/Fake.Core.Context/Context.fs | 23 +++- src/app/Fake.Core.Process/CmdLineParsing.fs | 46 ++++--- src/app/Fake.Core.Process/CreateProcess.fs | 29 +++-- src/app/Fake.Core.Process/Process.fs | 123 +++++++++++------- src/app/Fake.Core.Process/RawProc.fs | 37 +++--- .../Fake.Core.UnitTests/Fake.ContextHelper.fs | 6 +- .../Fake.Core.UnitTests/Fake.Core.Context.fs | 3 + .../Fake.Core.UnitTests/Fake.Core.FakeVar.fs | 4 +- .../Fake.Core.UnitTests/Fake.Core.Process.fs | 26 +++- .../Fake.DotNet.MSBuild.fs | 4 +- 10 files changed, 189 insertions(+), 112 deletions(-) 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 741338cc530..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("\\`", "\\\\`") @@ -111,7 +115,7 @@ type FilePath = string /// Helper functions for proper command line parsing module 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 args + 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) diff --git a/src/app/Fake.Core.Process/CreateProcess.fs b/src/app/Fake.Core.Process/CreateProcess.fs index f5cc42977a6..d16f7d8d7eb 100644 --- a/src/app/Fake.Core.Process/CreateProcess.fs +++ b/src/app/Fake.Core.Process/CreateProcess.fs @@ -64,7 +64,7 @@ module CreateProcess = member __.ProcessStarted (_,_) = () member __.RetrieveResult (_, t) = async { - let! raw = Async.AwaitTask t + let! raw = Async.AwaitTaskWithoutAggregate t return { ExitCode = raw.RawExitCode; Result = () } } } @@ -122,7 +122,7 @@ module CreateProcess = | CreatePipe pipe -> CreatePipe (StreamRef.Map (fun s -> Stream.InterceptStream(s, target)) pipe) let interceptStream target (s:StreamSpecification) = - interceptStreamFallback (fun _ -> Inherit) target s + interceptStreamFallback (fun _ -> failwithf "cannot intercept stream when it is not redirected. Please redirect the stream first!") target s let copyRedirectedProcessOutputsToStandardOutputs (c:CreateProcess<_>)= { c with @@ -315,13 +315,13 @@ module CreateProcess = StandardOutput = interceptStreamFallback (fun _ -> UseStream (false, outMem)) outMem streams.StandardOutput StandardError = - interceptStreamFallback (fun _ -> UseStream (false, errMem)) outMem streams.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.AwaitTask + let! exitCode = exitCode |> Async.AwaitTaskWithoutAggregate outMem.Position <- 0L errMem.Position <- 0L let stdErr = (new StreamReader(errMem)).ReadToEnd() @@ -444,28 +444,31 @@ module CreateProcess = else data) type internal TimeoutState = - { Stopwatch : System.Diagnostics.Stopwatch } + { Stopwatch : System.Diagnostics.Stopwatch + mutable HasExited : bool } let withTimeout (timeout:System.TimeSpan) (c:CreateProcess<_>) = c |> appendSimpleFuncs (fun _ -> - { Stopwatch = System.Diagnostics.Stopwatch.StartNew() }) + { Stopwatch = System.Diagnostics.Stopwatch.StartNew() + HasExited = false }) (fun state proc -> state.Stopwatch.Restart() async { do! Async.Sleep(int timeout.TotalMilliseconds) - if not proc.HasExited then - try + 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 + 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.AwaitTask + let! e = exitCode |> Async.AwaitTaskWithoutAggregate + state.HasExited <- true state.Stopwatch.Stop() let! prevResult = prev match e.RawExitCode with diff --git a/src/app/Fake.Core.Process/Process.fs b/src/app/Fake.Core.Process/Process.fs index bda580bd6ab..5c01b740955 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 @@ -333,6 +337,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. @@ -357,6 +385,12 @@ module Process = 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)." @@ -368,9 +402,17 @@ module Process = let mutable internal processStarter = RawProc.createProcessStarter (fun p -> + let si = p.StartInfo if Environment.isMono || AlwaysSetProcessEncoding then - p.StartInfo.StandardOutputEncoding <- ProcessEncoding - p.StartInfo.StandardErrorEncoding <- ProcessEncoding + 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) @@ -381,23 +423,35 @@ module Process = async { let hook = c.Hook - use state = hook.PrepareState () - 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! exitCode = processStarter.Start(procRaw) + 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 = + 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... @@ -406,7 +460,7 @@ module Process = let start c = async { let! result = startRaw c - return! result.Result |> Async.AwaitTask + return! result.Result |> Async.AwaitTaskWithoutAggregate } |> Async.StartImmediateAsTask let startRawSync c = (startRaw c).Result @@ -420,29 +474,6 @@ module 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() @@ -504,7 +535,7 @@ module Process = |> setEnvironmentVariable defaultEnvVar defaultEnvVar - let inline internal getProcI config = + let internal getProcI config = let startInfo : ProcStartInfo = config { ProcStartInfo.Create() with UseShellExecute = false } CreateProcess.ofStartInfo startInfo.AsStartInfo @@ -534,7 +565,9 @@ module Process = if silent then cp |> CreateProcess.redirectOutput - |> CreateProcess.withOutputEvents messageF errorF + |> 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 @@ -631,7 +664,7 @@ module Process = [] let quote (str:string) = // "\"" + str.Replace("\"","\\\"") + "\"" - CmdLineParsing.windowsArgvToCommandLine [ str ] + CmdLineParsing.windowsArgvToCommandLine true [ str ] /// Adds quotes around the string if needed /// [omit] @@ -688,7 +721,7 @@ module Process = else [ flagPrefix + paramName paramValue ]) - |> CmdLineParsing.windowsArgvToCommandLine + |> CmdLineParsing.windowsArgvToCommandLine true [] let findFiles dirs file = ProcessUtils.findFiles dirs file @@ -744,7 +777,7 @@ 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 diff --git a/src/app/Fake.Core.Process/RawProc.fs b/src/app/Fake.Core.Process/RawProc.fs index 33774c12cf2..c5b14363f69 100644 --- a/src/app/Fake.Core.Process/RawProc.fs +++ b/src/app/Fake.Core.Process/RawProc.fs @@ -172,25 +172,23 @@ module internal RawProc = let streamSpec = c.OutputHook.Prepare c.Streams streamSpec.SetStartInfo p - let commandLine = - sprintf "%s> \"%s\" %s" p.WorkingDirectory p.FileName p.Arguments - - Trace.tracefn "%s... RedirectInput: %b, RedirectOutput: %b, RedirectError: %b" commandLine p.RedirectStandardInput p.RedirectStandardOutput p.RedirectStandardError - 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 - startProcessRaw toolProcess + try + startProcessRaw toolProcess + finally + setEcho false |> ignore c.OutputHook.OnStart (toolProcess) - isStarted := true let handleStream parameter processStream isInputStream = async { @@ -200,10 +198,10 @@ module internal 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) -> @@ -229,32 +227,39 @@ module internal RawProc = // 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 = toolProcess.Exited // This way the handler gets added before actually calling start or "EnableRaisingEvents" - |> Event.guard start + |> Event.guard syncStart |> Async.AwaitEvent |> Async.StartImmediateAsTask + + do! startTrigger.Task |> Async.AwaitTaskWithoutAggregate let exitCode = async { - do! exitEvent |> Async.AwaitTask |> Async.Ignore + do! exitEvent |> Async.AwaitTaskWithoutAggregate |> Async.Ignore // 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 + |> 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.AwaitTask + let! streams = all.ContinueWith (new System.Func, Stream[]> (fun t -> t.GetAwaiter().GetResult())) |> Async.AwaitTaskWithoutAggregate for s in streams do s.Dispose() - setEcho false |> ignore let code = toolProcess.ExitCode toolProcess.Dispose() 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.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." ] From 0e84da6ffa41ab41ece14d73093acb1676389318 Mon Sep 17 00:00:00 2001 From: Matthias Dittrich Date: Tue, 9 Oct 2018 22:47:13 +0200 Subject: [PATCH 12/12] Fix some tests & oversights --- src/app/Fake.Core.Process/CreateProcess.fs | 4 +++- src/app/Fake.Core.Process/RawProc.fs | 4 ++++ src/app/Fake.DotNet.Cli/DotNet.fs | 2 +- 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/app/Fake.Core.Process/CreateProcess.fs b/src/app/Fake.Core.Process/CreateProcess.fs index d16f7d8d7eb..72c3e500272 100644 --- a/src/app/Fake.Core.Process/CreateProcess.fs +++ b/src/app/Fake.Core.Process/CreateProcess.fs @@ -455,7 +455,9 @@ module CreateProcess = (fun state proc -> state.Stopwatch.Restart() async { - do! Async.Sleep(int timeout.TotalMilliseconds) + 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() diff --git a/src/app/Fake.Core.Process/RawProc.fs b/src/app/Fake.Core.Process/RawProc.fs index c5b14363f69..0ed1efd1652 100644 --- a/src/app/Fake.Core.Process/RawProc.fs +++ b/src/app/Fake.Core.Process/RawProc.fs @@ -130,6 +130,10 @@ type internal RawCreateProcess = #if FX_WINDOWSTLE p.WindowStyle <- System.Diagnostics.ProcessWindowStyle.Hidden #endif + match x.WorkingDirectory with + | Some work -> + p.WorkingDirectory <- work + | None -> () p member x.CommandLine = x.Command.CommandLine 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