diff --git a/integrationtests/Paket.IntegrationTests/TestHelper.fs b/integrationtests/Paket.IntegrationTests/TestHelper.fs index 7bf440416e..cc6fad8dd4 100644 --- a/integrationtests/Paket.IntegrationTests/TestHelper.fs +++ b/integrationtests/Paket.IntegrationTests/TestHelper.fs @@ -60,6 +60,7 @@ let directPaketInPath command scenarioPath = (printfn "%s") string result #else + Environment.SetEnvironmentVariable("PAKET_DETAILED_ERRORS", "true") printfn "%s> paket %s" scenarioPath command let perfMessages = ResizeArray() let msgs = ResizeArray() diff --git a/src/Paket.Core/Common/Async.fs b/src/Paket.Core/Common/Async.fs index d8a49e60a6..8b24968855 100644 --- a/src/Paket.Core/Common/Async.fs +++ b/src/Paket.Core/Common/Async.fs @@ -2,11 +2,18 @@ namespace FSharp.Polyfill open System.Threading +type VolatileBarrier() = + [] + let mutable isStopped = false + member __.Proceed = not isStopped + member __.Stop() = isStopped <- true + /// Extensions for async workflows. [] module AsyncExtensions = open System open System.Threading.Tasks + open System.Threading type Microsoft.FSharp.Control.Async with /// Runs both computations in parallel and returns the result as a tuple. @@ -54,6 +61,36 @@ module AsyncExtensions = } |> fun a -> Async.Start(a, ct) ) } + + static member StartCatchCancellation(work, ?cancellationToken) = + Async.FromContinuations(fun (cont, econt, _) -> + // When the child is cancelled, report OperationCancelled + // as an ordinary exception to "error continuation" rather + // than using "cancellation continuation" + let ccont e = econt e + // Start the workflow using a provided cancellation token + Async.StartWithContinuations( work, cont, econt, ccont, + ?cancellationToken=cancellationToken) ) + + /// Like StartAsTask but gives the computation time to so some regular cancellation work + static member StartAsTaskProperCancel (computation : Async<_>, ?taskCreationOptions, ?cancellationToken:CancellationToken) : Task<_> = + let token = defaultArg cancellationToken Async.DefaultCancellationToken + let taskCreationOptions = defaultArg taskCreationOptions TaskCreationOptions.None + let tcs = new TaskCompletionSource<_>(taskCreationOptions) + + let a = + async { + try + // To ensure we don't cancel this very async (which is required to properly forward the error condition) + let! result = Async.StartCatchCancellation(computation, token) + do + tcs.SetResult(result) + with exn -> + tcs.SetException(exn) + } + Async.Start(a) + tcs.Task + static member map f a = async { return f a } static member tryFind (f : 'T -> bool) (tasks : Async<'T> seq) = async { @@ -64,7 +101,6 @@ module AsyncExtensions = 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) -> diff --git a/src/Paket.Core/Dependencies/PackageResolver.fs b/src/Paket.Core/Dependencies/PackageResolver.fs index f517a56322..1dcc55f552 100644 --- a/src/Paket.Core/Dependencies/PackageResolver.fs +++ b/src/Paket.Core/Dependencies/PackageResolver.fs @@ -11,6 +11,7 @@ open System.Diagnostics open Paket.PackageSources open System.Threading.Tasks open System.Threading +open FSharp.Polyfill type DependencySet = Set @@ -697,7 +698,7 @@ type RequestWork = type WorkHandle<'a> = private { Work : RequestWork; TaskSource : TaskCompletionSource<'a>; Cts : CancellationTokenSource } and ResolverRequestQueue = private { DynamicQueue : ResizeArray; Lock : obj; WaitingWorker : ResizeArray> } - // callback in a lock is bad practice.. + // callback in a lock is bad practice -> private member private x.With callback = lock x.Lock (fun () -> callback x.DynamicQueue x.WaitingWorker @@ -730,22 +731,27 @@ module ResolverRequestQueue = open System.Threading let Create() = { DynamicQueue = new ResizeArray(); Lock = new obj(); WaitingWorker = new ResizeArray<_>() } - let addWork prio (f: CancellationToken -> Task<'a>) (q:ResolverRequestQueue) = + let addWork cancellationTimeout prio (f: CancellationToken -> Task<'a>) (q:ResolverRequestQueue) = let tcs = new TaskCompletionSource<_>() let cts = new CancellationTokenSource() - let registration = cts.Token.Register(fun () -> - // We delay by a second to give the "regular" shutdown some time to finish "cleanly" - async { - do! Async.Sleep 1000 - tcs.TrySetCanceled () |> ignore - } |> Async.Start) + let registration = + match cancellationTimeout with + | Some timeout -> + cts.Token.Register(fun () -> + // We delay by a second to give the "regular" shutdown some time to finish "cleanly" + async { + do! Async.Sleep timeout + tcs.TrySetException (new TaskCanceledException("Worktask was canceled as the underlying task did not properly cancel itself after 1 second.")) |> ignore + } |> Async.Start) + |> Some + | None -> None let work = { StartWork = (fun tok -> // When someone is actually starting the work we need to ensure we finish it... let registration2 = tok.Register(fun () -> cts.Cancel()) let t = try - f tok + f cts.Token with e -> //Task.FromException (e) let tcs = new TaskCompletionSource<_>() @@ -753,7 +759,9 @@ module ResolverRequestQueue = tcs.Task t.ContinueWith(fun (t:Task<'a>) -> - registration.Dispose() + match registration with + | Some reg -> reg.Dispose() + | None -> () registration2.Dispose() if t.IsCanceled then tcs.TrySetException(new TaskCanceledException(t)) @@ -769,15 +777,18 @@ module ResolverRequestQueue = q.AddWork work { Work = work; TaskSource = tcs; Cts = cts } let startProcessing (ct:CancellationToken) ({ DynamicQueue = queue } as q) = + let linked = new CancellationTokenSource() async { + use _reg = ct.Register(fun () -> + linked.CancelAfter(1000)) while not ct.IsCancellationRequested do let! work = q.GetWork(ct) |> Async.AwaitTask match work with | Some work -> - do! work.StartWork(ct).ContinueWith(fun (t:Task) -> ()) |> Async.AwaitTask + do! work.StartWork(ct).ContinueWith(fun (_:Task) -> ()) |> Async.AwaitTask | None -> () } - |> fun a -> Async.StartAsTask(a, TaskCreationOptions.None) + |> fun a -> Async.StartAsTaskProperCancel(a, TaskCreationOptions.None, linked.Token) type WorkHandle<'a> with member x.Reprioritize prio = @@ -796,10 +807,20 @@ let Resolve (getVersionsRaw, getPreferredVersionsRaw, getPackageDetailsRaw, grou use cts = new CancellationTokenSource() let workerQueue = ResolverRequestQueue.Create() let workers = - // start maximal 7 requests at the same time. + // start maximal 8 requests at the same time. [ 0 .. 7 ] |> List.map (fun _ -> ResolverRequestQueue.startProcessing cts.Token workerQueue) + // mainly for failing unit-tests to be faster + let taskTimeout = + match Environment.GetEnvironmentVariable("PAKET_RESOLVER_TASK_TIMEOUT") with + | a when System.String.IsNullOrWhiteSpace a -> 30000 + | a -> + match System.Int32.TryParse a with + | true, v -> v + | _ -> traceWarnfn "PAKET_RESOLVER_TASK_TIMEOUT is not set to an interval in milliseconds, ignoring the value and defaulting to 30000" + 30000 + let getAndReport (sources:PackageSource list) blockReason (workHandle:WorkHandle<_>) = try if workHandle.Task.IsCompleted then @@ -808,11 +829,11 @@ let Resolve (getVersionsRaw, getPreferredVersionsRaw, getPackageDetailsRaw, grou else workHandle.Reprioritize WorkPriority.BlockingWork use d = Profile.startCategory (Profile.Category.ResolverAlgorithmBlocked blockReason) - let isFinished = workHandle.Task.Wait(30000) + let isFinished = workHandle.Task.Wait(taskTimeout) // When debugger is attached we just wait forever when calling .Result later ... // Try to cancel the work after 29sec, this will hopefully give a nice error message which operation failed if not isFinished && not Debugger.IsAttached then - traceWarnfn "A task did not finish within 30 seconds. Canceling the operation." + traceWarnfn "A task did not finish within 30 seconds. Cancelling the operation." workHandle.Cancel() let isFinished = workHandle.Task.Wait(3000) @@ -835,28 +856,34 @@ let Resolve (getVersionsRaw, getPreferredVersionsRaw, getPackageDetailsRaw, grou reraise() let startedGetPackageDetailsRequests = System.Collections.Concurrent.ConcurrentDictionary<_,WorkHandle<_>>() - let startRequestGetPackageDetails sources groupName packageName semVer = + let startRequestGetPackageDetails sources groupName packageName (semVer:SemVerInfo) = let key = (sources, packageName, semVer) startedGetPackageDetailsRequests.GetOrAdd (key, fun _ -> workerQueue - |> ResolverRequestQueue.addWork WorkPriority.BackgroundWork (fun ct -> + |> ResolverRequestQueue.addWork (Some 1000) WorkPriority.BackgroundWork (fun ct -> (getPackageDetailsRaw sources groupName packageName semVer : Async) - |> fun a -> Async.StartAsTask(a, cancellationToken = ct))) + |> fun a -> Async.StartAsTaskProperCancel(a, cancellationToken = ct))) let getPackageDetailsBlock sources groupName packageName semVer = let workHandle = startRequestGetPackageDetails sources groupName packageName semVer - getAndReport sources Profile.BlockReason.PackageDetails workHandle + try + getAndReport sources Profile.BlockReason.PackageDetails workHandle + with e -> + raise <| Exception (sprintf "Unable to retrieve package details for '%O'-%s" packageName semVer.AsString, e) let startedGetVersionsRequests = System.Collections.Concurrent.ConcurrentDictionary<_,WorkHandle<_>>() let startRequestGetVersions sources groupName packageName = let key = (sources, packageName) startedGetVersionsRequests.GetOrAdd (key, fun _ -> workerQueue - |> ResolverRequestQueue.addWork WorkPriority.BackgroundWork (fun ct -> + |> ResolverRequestQueue.addWork (Some 1000) WorkPriority.BackgroundWork (fun ct -> getVersionsRaw sources groupName packageName - |> fun a -> Async.StartAsTask(a, cancellationToken = ct))) + |> fun a -> Async.StartAsTaskProperCancel(a, cancellationToken = ct))) let getVersionsBlock sources resolverStrategy groupName packageName = let workHandle = startRequestGetVersions sources groupName packageName - let versions = getAndReport sources Profile.BlockReason.GetVersion workHandle |> Seq.toList + let versions = + try getAndReport sources Profile.BlockReason.GetVersion workHandle |> Seq.toList + with e -> + raise <| Exception (sprintf "Unable to retrieve package versions for '%O'" packageName, e) let sorted = match resolverStrategy with | ResolverStrategy.Max -> List.sortDescending versions @@ -1165,7 +1192,9 @@ let Resolve (getVersionsRaw, getPreferredVersionsRaw, getPackageDetailsRaw, grou } let inline calculate () = step (Step((currentConflict,startingStep,currentRequirement),[])) stackpack Seq.empty flags - + + // Flag to ensure that we don't hide underlying exceptions in the finally block. + let mutable exceptionThrown = false try #if DEBUG let mutable results = None @@ -1199,7 +1228,7 @@ let Resolve (getVersionsRaw, getPreferredVersionsRaw, getPackageDetailsRaw, grou stackpack.ConflictHistory.Clear() (step (Step((conflict ,{startingStep with Relax=true} - ,currentRequirement),[])) + ,currentRequirement),[])) stackpack Seq.empty flags) else conflict @@ -1210,9 +1239,30 @@ let Resolve (getVersionsRaw, getPreferredVersionsRaw, getPackageDetailsRaw, grou traceWarnfn "Resolution finished, but some errors were encountered:" AggregateException(resolution.Errors) |> printError + + exceptionThrown <- false resolution finally // some cleanup cts.Cancel() for w in workers do - w.Wait() + try + w.Wait() + with + | :? ObjectDisposedException -> + if verbose then + traceVerbose "Worker-Task was disposed" + () + | :? AggregateException as a -> + match a.InnerExceptions |> Seq.toArray with + | [| :? OperationCanceledException as c |] -> + // Task was cancelled... + if verbose then + traceVerbose "Worker-Task was canceled" + () + | _ -> + if exceptionThrown then + traceErrorfn "Error while waiting for worker to finish: %O" a + else reraise() + | e when exceptionThrown -> + traceErrorfn "Error while waiting for worker to finish: %O" e diff --git a/tests/Paket.Tests/Paket.Tests.fsproj b/tests/Paket.Tests/Paket.Tests.fsproj index 03aeccdfcb..f6c5820221 100644 --- a/tests/Paket.Tests/Paket.Tests.fsproj +++ b/tests/Paket.Tests/Paket.Tests.fsproj @@ -58,7 +58,6 @@ FsUnit.fs - @@ -95,6 +94,7 @@ + PreserveNewest diff --git a/tests/Paket.Tests/Resolver/DependencyGroupsAndRestrictions.fs b/tests/Paket.Tests/Resolver/DependencyGroupsAndRestrictions.fs index 22502d58ec..767a167087 100644 --- a/tests/Paket.Tests/Resolver/DependencyGroupsAndRestrictions.fs +++ b/tests/Paket.Tests/Resolver/DependencyGroupsAndRestrictions.fs @@ -11,7 +11,7 @@ open Paket.Requirements let resolve graph updateMode (cfg : DependenciesFile) = let groups = [Constants.MainDependencyGroup, None ] |> Map.ofSeq cfg.Resolve(true,noSha1,VersionsFromGraphAsSeq graph, (fun _ _ _ _ -> []),PackageDetailsFromGraph graph,(fun _ _ -> None),groups,updateMode).[Constants.MainDependencyGroup].ResolvedPackages.GetModelOrFail() - + let graph1 = GraphOfNuspecs [ """ diff --git a/tests/Paket.Tests/Resolver/ResolverRestrictionTests.fs b/tests/Paket.Tests/Resolver/ResolverRestrictionTests.fs index 60714bf653..c278ea5180 100644 --- a/tests/Paket.Tests/Resolver/ResolverRestrictionTests.fs +++ b/tests/Paket.Tests/Resolver/ResolverRestrictionTests.fs @@ -1,2 +1,239 @@ -module ResolverRestrictionTests +module ResolverErrorSituationTests + +open Paket +open NUnit.Framework +open FsUnit +open TestHelpers +open Paket.Domain +open Paket.PackageResolver +open Paket.Requirements +open System.Threading.Tasks +open System +open System.Threading +open FSharp.Polyfill + +let rec findExnWhichContains msg (exn:exn) = + match exn with + | _ when exn.Message.Contains msg -> Some exn + | :? AggregateException as a -> + a.InnerExceptions + |> Seq.tryPick (fun e -> findExnWhichContains msg e) + | _ when not (isNull exn.InnerException) -> + findExnWhichContains msg exn.InnerException + | _ -> None + +let resolve graph updateMode (cfg : DependenciesFile) = + let groups = [Constants.MainDependencyGroup, None ] |> Map.ofSeq + cfg.Resolve(true,noSha1,VersionsFromGraphAsSeq graph, (fun _ _ _ _ -> []),PackageDetailsFromGraph graph,(fun _ _ -> None),groups,updateMode).[Constants.MainDependencyGroup].ResolvedPackages.GetModelOrFail() + +let graph1 = + GraphOfNuspecs [ + """ + + + Chessie + 0.6.0 + + + + + + + + + + + + """ + """ + + + FSharp.Core + 4.0.0.1 + + + """ + """ + + + FSharp.Core + 4.0.1.7-alpha + + + + + + +""" + ] + +[] +let ``should fallback to timeoutexception when task never canceles``() = + use consoleTrace = Logging.event.Publish |> Observable.subscribe Logging.traceToConsole + let config = """ +source http://www.nuget.org/api/v2 +framework net46 + +nuget Chessie""" + let cfg = DependenciesFile.FromSource(config) + let groups = [Constants.MainDependencyGroup, None ] |> Map.ofSeq + try + // NOTE: This test is hard/improssible to debug, because of the Debugger.IsAttached checks in the resolver code! + System.Environment.SetEnvironmentVariable("PAKET_RESOLVER_TASK_TIMEOUT", "500") + try + let groupResults = + cfg.Resolve( + true,noSha1,VersionsFromGraphAsSeq graph1,(fun _ _ _ _ -> []), + // Will never finish... + (fun _ _ _ _ -> (new TaskCompletionSource<_>()).Task |> Async.AwaitTask), + (fun _ _ -> None),groups, UpdateMode.UpdateAll) + let resolved = groupResults.[Constants.MainDependencyGroup].ResolvedPackages.GetModelOrFail() + Assert.Fail "Expected exception" + with e -> + match findExnWhichContains "Unable to retrieve package details for 'Chessie'-0.6.0" e with + | Some e -> () + | None -> Assert.Fail(sprintf "Expected exception explaining Chessie could not be retrieved, but was %O" e) + finally + System.Environment.SetEnvironmentVariable("PAKET_RESOLVER_TASK_TIMEOUT", null) + +// This test-cases let you understand better why we need a custom 'StartAsTaskTimeout' implementation and cannot +// use the StartAsTask default implementation, uncomment and run to see the difference in behavior. +//[] +//let ``check task cancellation``() = +// let tcs = new TaskCompletionSource<_>() +// let cts = new CancellationTokenSource() +// use reg = cts.Token.Register(fun () -> tcs.SetException(Exception "Something bad happened")) +// let a = +// async { +// cts.CancelAfter 500 +// do! tcs.Task |> Async.AwaitTask +// printfn "test" +// return! async { +// do! Async.Sleep 100 +// return 4 } +// } |> fun a -> Async.RunSynchronously(a, cancellationToken = cts.Token) +// () +// +//[] +//let ``check task cancellation (task)``() = +// let tcs = new TaskCompletionSource<_>() +// let cts = new CancellationTokenSource() +// use reg = cts.Token.Register(fun () -> tcs.SetException(Exception "Something bad happened")) +// let a = +// async { +// cts.CancelAfter 500 +// do! tcs.Task |> Async.AwaitTask +// } |> fun a -> Async.StartAsTask(a, cancellationToken = cts.Token) +// a.Result +// () +//[] +//let ``check task cancellation 2``() = +// let tcs = new TaskCompletionSource<_>() +// let cts = new CancellationTokenSource() +// use reg = cts.Token.Register(fun () -> tcs.SetException(Exception "Something bad happened")) +// let a = +// async { +// do! tcs.Task |> Async.AwaitTask +// } +// +// async { +// do! Async.Sleep 500 +// cts.Cancel() +// } |> Async.Start +// +// let b = +// async { +// let! res = a +// printfn "test" +// do! Async.Sleep 100 +// return res +// } |> fun a -> Async.RunSynchronously(a, cancellationToken = cts.Token) +// () +// +//[] +//let ``check task cancellation 3``() = +// let tcs = new TaskCompletionSource<_>() +// let cts = new CancellationTokenSource() +// use reg = cts.Token.Register(fun () -> tcs.SetException(Exception "Something bad happened")) +// let a = +// async { +// do! tcs.Task |> Async.AwaitTask +// } +// +// async { +// do! Async.Sleep 500 +// cts.Cancel() +// } |> Async.Start +// +// let b = +// async { +// let! res = a +// printfn "test" +// do! Async.Sleep 100 +// return res +// } |> fun a -> Async.StartAsTask(a, cancellationToken = cts.Token) +// b.Result +// +//[] +//let ``check task cancellation 4``() = +// let tcs = new TaskCompletionSource<_>() +// let cts = new CancellationTokenSource() +// use reg = cts.Token.Register(fun () -> tcs.SetException(Exception "Something bad happened")) +// let a = +// async { +// do! tcs.Task |> Async.AwaitTask +// } +// +// async { +// do! Async.Sleep 500 +// cts.Cancel() +// } |> Async.Start +// +// let b = +// async { +// let! res = a +// printfn "test" +// do! Async.Sleep 100 +// return res +// } |> fun a -> Async.StartAsTaskTimeout(a, cancellationToken = cts.Token, cancelTimeout = 10000) +// b.Result + +[] +let ``should forward underlying cause when task properly cancels``() = + let config = """ +source http://www.nuget.org/api/v2 +framework net46 + +nuget Chessie""" + let cfg = DependenciesFile.FromSource(config) + let groups = [Constants.MainDependencyGroup, None ] |> Map.ofSeq + try + // NOTE: This test is hard/improssible to debug, because of the Debugger.IsAttached checks in the resolver code! + System.Environment.SetEnvironmentVariable("PAKET_RESOLVER_TASK_TIMEOUT", "500") + try + let groupResults = + cfg.Resolve( + true,noSha1,VersionsFromGraphAsSeq graph1,(fun _ _ _ _ -> []), + // Will throw a proper exception when canceled + (fun _ _ _ _ -> + async { + let tcs = new TaskCompletionSource<_>() + //let! tok = Async.CancellationToken + //use _reg = tok.Register(fun () -> tcs.SetException (new TaskCanceledException("Some Url 'Blub' didn't respond"))) + use! reg = Async.OnCancel (fun () -> + tcs.SetException (new Exception("Some Url 'Blub' didn't respond"))) + return! tcs.Task |> Async.AwaitTask + }), + (fun _ _ -> None),groups, UpdateMode.UpdateAll) + let resolved = groupResults.[Constants.MainDependencyGroup].ResolvedPackages.GetModelOrFail() + Assert.Fail "Expected exception" + with e -> + match findExnWhichContains "Some Url 'Blub' didn't respond" e with + | Some e -> () + | None -> Assert.Fail(sprintf "Expected exception explaining 'Some Url 'Blub' didn't respond', but was %O" e) + match findExnWhichContains "Unable to retrieve package details for 'Chessie'-0.6.0" e with + | Some e -> () + | None -> Assert.Fail(sprintf "Expected exception explaining Chessie could not be retrieved, but was %O" e) + finally + System.Environment.SetEnvironmentVariable("PAKET_RESOLVER_TASK_TIMEOUT", null)