Add tests 2436

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()

src/Paket.Core/Common/Async.fs

@@ -2,11 +2,18 @@ namespace FSharp.Polyfill
 
 open System.Threading
 
+type VolatileBarrier() =
+    [<VolatileField>]
+    let mutable isStopped = false
+    member __.Proceed = not isStopped
+    member __.Stop() = isStopped <- true
+
 /// Extensions for async workflows.
 [<AutoOpen>]
 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) ->

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<PackageName * VersionRequirement * FrameworkRestrictions>
 
@@ -697,7 +698,7 @@ type RequestWork =
 type WorkHandle<'a> = private { Work : RequestWork; TaskSource : TaskCompletionSource<'a>; Cts : CancellationTokenSource }
 and ResolverRequestQueue =
     private { DynamicQueue : ResizeArray<RequestWork>; Lock : obj; WaitingWorker : ResizeArray<TaskCompletionSource<RequestWork option>> }
-    // 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,30 +731,37 @@ module ResolverRequestQueue =
     open System.Threading
 
     let Create() = { DynamicQueue = new ResizeArray<RequestWork>(); 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<_>()
                         tcs.SetException e
                         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<PackageDetails>)
-                    |> 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

tests/Paket.Tests/Paket.Tests.fsproj

@@ -58,7 +58,6 @@
       <Link>FsUnit.fs</Link>
     </Compile>
     <Compile Include="AssemblyInfo.fs" />
-    <Compile Include="NuGetLocal\NuGetLocalSpecs.fs" />
     <Compile Include="TestHelpers.fs" />
     <Compile Include="UtilsSpecs.fs" />
     <Compile Include="Versioning\SemVerSpecs.fs" />
@@ -95,6 +94,7 @@
     <None Include="Nuspec\WindowsAzure.Storage.nuspec" />
     <None Include="Nuspec\EasyNetQ.nuspec" />
     <Compile Include="Nuspec\NuspecSpecs.fs" />
+    <Compile Include="NuGetLocal\NuGetLocalSpecs.fs" />
     <None Include="NuGetLocal\case1\package.name.0.1.0-alpha2.nupkg">
       <CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
     </None>

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 [
     """<?xml version="1.0" encoding="utf-8" standalone="yes"?>