Improve error reporting

integrationtests/Paket.IntegrationTests/TestHelper.fs

@@ -72,20 +72,26 @@ let directPaketInPath command scenarioPath =
                 perfMessages.Add(msg)
 
         msgs.Add((isError, msg))
-        if isError then
-            printfn "ERR: %s" msg
-        //else printfn "%s" msg
 
     let result =
-        ExecProcessWithLambdas (fun info ->
-          info.FileName <- paketToolPath
-          info.WorkingDirectory <- scenarioPath
-          info.Arguments <- command) 
-          (System.TimeSpan.FromMinutes 7.)
-          true
-          (addAndPrint true)
-          (addAndPrint false)
-
+        try
+            ExecProcessWithLambdas (fun info ->
+              info.FileName <- paketToolPath
+              info.WorkingDirectory <- scenarioPath
+              info.Arguments <- command)
+              (System.TimeSpan.FromMinutes 7.)
+              true
+              (addAndPrint true)
+              (addAndPrint false)
+        with exn ->
+            if exn.Message.Contains "timed out" then
+                printfn "PROCESS TIMED OUT, OUTPUT WAS: "
+            else
+                printfn "ExecProcessWithLambdas failed. Output was: "
+
+            for isError, msg in msgs do
+                printfn "%s%s" (if isError then "ERR: " else "") msg
+            reraise()
     // Only throw after the result <> 0 check because the current test might check the argument parsing
     // this is the only case where no performance is printed
     let isUsageError = result <> 0 && msgs |> Seq.filter fst |> Seq.map snd |> Seq.exists (fun msg -> msg.Contains "USAGE:")
@@ -96,6 +102,11 @@ let directPaketInPath command scenarioPath =
         for msg in perfMessages do
             printfn "%s" msg
 
+    // always print stderr
+    for isError, msg in msgs do
+        if isError then
+            printfn "ERR: %s" msg
+
     if result <> 0 then 
         let errors = String.Join(Environment.NewLine,msgs |> Seq.filter fst |> Seq.map snd)
         failwith errors      

src/Paket.Core/Common/Async.fs

@@ -6,6 +6,7 @@ open System.Threading
 [<AutoOpen>]
 module AsyncExtensions = 
   open System
+  open System.Threading.Tasks
 
   type Microsoft.FSharp.Control.Async with 
      /// Runs both computations in parallel and returns the result as a tuple.
@@ -17,34 +18,47 @@ module AsyncExtensions =
             let! b'' = b'
             return (a'',b'')
         }
-
-    static member Choice(tasks : Async<'T option> seq) = async {
+    static member map f a =
+        async { return f a }
+    static member tryFind (f : 'T -> bool) (tasks : Async<'T> seq) = async {
          match Seq.toArray tasks with
-         | [||] -> return None
-         | [|t|] -> return! t
+         | [||] -> return [||], None
+         | [|t|] ->
+            let! res = t
+            let task = Task.FromResult res
+            return if f res then [|task|], Some 0 else [|task|], None
          | tasks ->
-
+    
          let! t = Async.CancellationToken
          return! Async.FromContinuations <|
              fun (sc,ec,cc) ->
-                 let noneCount = ref 0
+                 let currentIndex = ref 0
                  let exnCount = ref 0
                  let innerCts = CancellationTokenSource.CreateLinkedTokenSource t
-
-                 let scont (result : 'T option) =
-                     match result with
-                     | Some _ when Interlocked.Increment exnCount = 1 -> innerCts.Cancel() ; sc result
-                     | None when Interlocked.Increment noneCount = tasks.Length -> sc None
+                 let results = Array.init tasks.Length (fun _ -> TaskCompletionSource<'T>())
+                 let retResults = results |> Array.map (fun tcs -> tcs.Task)
+
+                 let scont index (result : 'T) =
+                     results.[index].TrySetResult result |> ignore
+                     match f result with
+                     | true when Interlocked.Increment exnCount = 1 ->
+                        innerCts.Cancel()
+                        sc (retResults, (Some index))
+                     | false when Interlocked.Increment currentIndex = tasks.Length ->
+                        sc (retResults,None)
                      | _ -> ()
-
-                 let econt (exn : exn) =
+
+                 let econt index (exn : exn) =
+                     results.[index].TrySetException exn |> ignore
                      if Interlocked.Increment exnCount = 1 then 
                          innerCts.Cancel() ; ec exn
-
-                 let ccont (exn : OperationCanceledException) =
+
+                 let ccont index (exn : OperationCanceledException) =
+                     results.[index].TrySetCanceled () |> ignore
                      if Interlocked.Increment exnCount = 1 then
                          innerCts.Cancel(); cc exn
-
-                 for task in tasks do
-                     ignore <| System.Threading.Tasks.Task.Factory.StartNew(fun () -> Async.StartWithContinuations(task, scont, econt, ccont, innerCts.Token))
+
+                 for i, task in tasks |> Seq.mapi (fun i t -> i, t) do
+                     ignore <| System.Threading.Tasks.Task.Factory.StartNew(fun () -> 
+                        Async.StartWithContinuations(task, scont i, econt i, ccont i, innerCts.Token))
      }

src/Paket.Core/Common/Logging.fs

@@ -98,4 +98,60 @@ let setLogFile fileName =
     else
         if fi.Directory.Exists |> not then
             fi.Directory.Create()
-    event.Publish |> Observable.subscribe traceToFile
+    event.Publish |> Observable.subscribe traceToFile
+
+/// [omit]
+[<RequireQualifiedAccess>]
+type private ExnType =
+    | First
+    | Aggregated
+    | Inner
+
+/// [omit]
+let printErrorExt printFirstStack printAggregatedStacks printInnerStacks (exn:exn) =
+    let defaultMessage = AggregateException().Message
+    let rec printErrorHelper exnType useArrow indent (exn:exn) =
+        let handleError () =
+            let s = if useArrow then "->" else "- "
+            let indentString = new String('\t', indent)
+            let splitMsg = exn.Message.Split([|"\r\n"; "\n"|], StringSplitOptions.None)
+            let typeString =
+                let t = exn.GetType()
+                if t = typeof<Exception> || t = typeof<AggregateException> then
+                    ""
+                else sprintf "%s: " t.Name
+            traceErrorfn "%s%s %s%s" indentString s typeString (String.Join(sprintf "%s%s   " Environment.NewLine indentString , splitMsg))
+            let printStack =
+                match String.IsNullOrWhiteSpace exn.StackTrace, exnType with
+                | false, ExnType.First when printFirstStack -> true
+                | false, ExnType.Aggregated when printAggregatedStacks -> true
+                | false, ExnType.Inner when printInnerStacks -> true
+                | _ -> false
+            if printStack then
+                traceErrorfn "%s   StackTrace:" indentString
+                let split = exn.StackTrace.Split([|"\r\n"; "\n"|], StringSplitOptions.None)
+                traceErrorfn "%s     %s" indentString (String.Join(sprintf "%s%s     " Environment.NewLine indentString, split))
+        match exn with
+        | :? AggregateException as aggr ->
+            if aggr.InnerExceptions.Count = 1 then
+                let inner = aggr.InnerExceptions.[0]
+                if aggr.Message = defaultMessage || aggr.Message = inner.Message then
+                    // skip as no new information is available.
+                    printErrorHelper exnType useArrow indent inner
+                else
+                    handleError()
+                    printErrorHelper ExnType.Aggregated true indent inner
+            else
+                handleError()
+                for inner in aggr.InnerExceptions do
+                    printErrorHelper ExnType.Aggregated false (indent + 1) inner
+        | _ ->
+            handleError()
+            if not (isNull exn.InnerException) then
+                printErrorHelper ExnType.Inner true indent exn.InnerException
+
+    printErrorHelper ExnType.First true 0 exn
+
+/// [omit]
+let printError (exn:exn) =
+    printErrorExt verbose verbose false exn

src/Paket.Core/Common/Logging.fsi

@@ -36,4 +36,8 @@ val event : Event<Trace>
 
 val traceToConsole : Trace -> unit
 
-val setLogFile : string -> IDisposable
+val setLogFile : string -> IDisposable
+
+val printError : exn -> unit
+
+val printErrorExt : printFirstStack:bool -> printAggregatedStacks:bool -> printInnerStacks:bool -> exn -> unit

src/Paket.Core/Common/Utils.fs

@@ -545,11 +545,6 @@ open System.Diagnostics
 open System.Threading
 open System.Collections.Generic
 
-let innerText (exn:Exception) =
-    match exn.InnerException with
-    | null -> ""
-    | exn -> Environment.NewLine + " Details: " + exn.Message
-
 /// [omit]
 let downloadFromUrl (auth:Auth option, url : string) (filePath: string) =
     async {
@@ -560,7 +555,7 @@ let downloadFromUrl (auth:Auth option, url : string) (filePath: string) =
             do! task
         with
         | exn ->
-            failwithf "Could not download from %s%s Message: %s%s" url Environment.NewLine exn.Message (innerText exn)
+            raise <| Exception(sprintf "Could not download from '%s'" url, exn)
     }
 
 /// [omit]
@@ -575,8 +570,8 @@ let getFromUrl (auth:Auth option, url : string, contentType : string) =
             return! client.DownloadStringTaskAsync (Uri url) |> Async.AwaitTask
         with
         | exn -> 
-            failwithf "Could not retrieve data from %s%s Message: %s%s" url Environment.NewLine exn.Message (innerText exn)
-            return ""
+            return raise <| Exception(sprintf "Could not retrieve data from '%s'" url, exn)
+
     }
 
 let getXmlFromUrl (auth:Auth option, url : string) =
@@ -593,8 +588,7 @@ let getXmlFromUrl (auth:Auth option, url : string) =
             return! client.DownloadStringTaskAsync (Uri url) |> Async.AwaitTask
         with
         | exn -> 
-            failwithf "Could not retrieve data from %s%s Message: %s%s" url Environment.NewLine exn.Message (innerText exn)
-            return ""
+            return raise <| Exception(sprintf "Could not retrieve data from '%s'" url, exn)
     }
 
 /// [omit]
@@ -612,11 +606,12 @@ let safeGetFromUrl (auth:Auth option, url : string, contentType : string) =
 #endif
             use _ = Profile.startCategory Profile.Category.NuGetRequest
             let! raw = client.DownloadStringTaskAsync(uri) |> Async.AwaitTask
-            return Some raw
+            return FSharp.Core.Result.Ok raw
         with e ->
             if verbose then
                 Logging.verbosefn "Error while retrieving '%s': %O" url e
-            return None
+            let cap = System.Runtime.ExceptionServices.ExceptionDispatchInfo.Capture e
+            return FSharp.Core.Result.Error cap
     }
 
 let mutable autoAnswer = None
@@ -689,15 +684,15 @@ let RunInLockedAccessMode(rootFolder,action) =
             waitForUnlocked 0
             File.WriteAllText(fileName, string p.Id)
         with
-        | exn when exn.Message = "timeout" -> 
-            failwithf "Could not acquire lock to %s.%sThe process timed out." fileName Environment.NewLine
-        | exn -> 
+        | exn when exn.Message = "timeout" ->
+            failwithf "Could not acquire lock to '%s'.%sThe process timed out." fileName Environment.NewLine
+        | exn ->
             if trials > 0 then 
                 let trials = trials - 1
                 tracefn "Could not acquire lock to %s.%s%s%sTrials left: %d." fileName Environment.NewLine exn.Message Environment.NewLine trials
                 acquireLock startTime timeOut trials
             else
-                failwithf "Could not acquire lock to %s.%s%s" fileName Environment.NewLine exn.Message
+                raise <| Exception(sprintf "Could not acquire lock to '%s'." fileName, exn)
 
     let rec releaseLock() =
         try
@@ -840,7 +835,7 @@ let parseKeyValuePairs (s:string) : Dictionary<string,string> =
         d
     with
     | exn -> 
-        failwithf "Could not parse %s as key/value pairs.%s%s" s Environment.NewLine exn.Message
+        raise <| Exception(sprintf "Could not parse '%s' as key/value pairs." s, exn)
 
 let downloadStringSync (url : string) (client : WebClient) = 
     try 

src/Paket.Core/Dependencies/GitCommandHelper.fs

@@ -167,17 +167,19 @@ let ExecProcessWithLambdas configProcessStartInfoF (timeOut : TimeSpan) silent e
             if d.Data <> null then messageF d.Data)
     try 
         start proc
-    with exn -> failwithf "Start of process %s failed. %s" proc.StartInfo.FileName exn.Message
+    with exn -> raise <| Exception(sprintf "Start of process %s failed." proc.StartInfo.FileName, exn)
     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 ->  ()
-            failwithf "Process %s %s timed out." proc.StartInfo.FileName proc.StartInfo.Arguments
+            let inner =
+                try 
+                    proc.Kill()
+                    null
+                with exn -> exn
+            raise <| Exception(sprintf "Process %s %s timed out." proc.StartInfo.FileName proc.StartInfo.Arguments, inner)
     proc.ExitCode
 
 
@@ -234,7 +236,7 @@ let fireAndForget configProcessStartInfoF =
     configProcessStartInfoF proc.StartInfo
     try 
         start proc
-    with exn -> failwithf "Start of process %s failed. %s" proc.StartInfo.FileName exn.Message
+    with exn -> raise <| Exception(sprintf "Start of process %s failed." proc.StartInfo.FileName, exn)
 
 /// Fires the given git command ind the given repository directory and returns immediatly.
 let fireAndForgetGitCommand repositoryDir command = 
@@ -250,7 +252,7 @@ let directExec configProcessStartInfoF =
     configProcessStartInfoF proc.StartInfo
     try 
         start proc
-    with exn -> failwithf "Start of process %s failed. %s" proc.StartInfo.FileName exn.Message
+    with exn -> raise <| Exception(sprintf "Start of process %s failed." proc.StartInfo.FileName, exn)
     proc.WaitForExit()
     proc.ExitCode = 0
 
@@ -286,7 +288,7 @@ let runFullGitCommand repositoryDir command =
             msg |> Seq.iter (tracefn "%s")
         msg |> Seq.toArray
     with 
-    | exn -> failwithf "Could not run \"git %s\".\r\nError: %s" command exn.Message
+    | exn -> raise <| Exception(sprintf "Could not run \"git %s\"." command, exn)
 
 /// Runs the git command and returns the first line of the result.
 let runSimpleGitCommand repositoryDir command =
@@ -302,4 +304,4 @@ let runSimpleGitCommand repositoryDir command =
             msg |> Seq.iter (tracefn "%s")
         msg.[0]
     with 
-    | exn -> failwithf "Could not run \"git %s\".\r\nError: %s" command exn.Message
+    | exn -> raise <| Exception(sprintf "Could not run \"git %s\"." command, exn)