diff --git a/buckaroo-cli/Program.fs b/buckaroo-cli/Program.fs index d418ed1..c12d593 100644 --- a/buckaroo-cli/Program.fs +++ b/buckaroo-cli/Program.fs @@ -15,10 +15,10 @@ let main argv = let! exitCode = async { try match Buckaroo.Command.parse input with - | Result.Ok (command, loggingLevel) -> + | Result.Ok (command, loggingLevel, fetchStyle) -> do! command - |> Buckaroo.Command.runCommand loggingLevel + |> Buckaroo.Command.runCommand loggingLevel fetchStyle return 0 | Result.Error error -> Console.WriteLine error diff --git a/buckaroo-tests/Command.fs b/buckaroo-tests/Command.fs index 0351926..a002f85 100644 --- a/buckaroo-tests/Command.fs +++ b/buckaroo-tests/Command.fs @@ -15,32 +15,37 @@ let private ijkXyz = GitHub { Owner = "ijk"; Project = "xyz" } [] let ``Command.parse works correctly`` () = let cases = [ - (Result.Ok (Command.Init, defaultLoggingLevel), "init"); + (Result.Ok (Command.Init, defaultLoggingLevel, RemoteFirst), "init"); - (Result.Ok (Command.Install, defaultLoggingLevel), " install "); + (Result.Ok (Command.Install, defaultLoggingLevel, RemoteFirst), " install "); - (Result.Ok (Command.Resolve Quick, defaultLoggingLevel), "resolve"); - (Result.Ok (Command.Resolve Quick, verboseLoggingLevel), "resolve --verbose"); - (Result.Ok (Command.Resolve Upgrading, defaultLoggingLevel), "resolve --upgrade "); - (Result.Ok (Command.Resolve Upgrading, verboseLoggingLevel), "resolve --upgrade --verbose"); + (Result.Ok (Command.Resolve Quick, defaultLoggingLevel, RemoteFirst), "resolve"); + (Result.Ok (Command.Resolve Quick, verboseLoggingLevel, RemoteFirst), "resolve --verbose"); + (Result.Ok (Command.Resolve Upgrading, defaultLoggingLevel, RemoteFirst), "resolve --upgrade "); + (Result.Ok (Command.Resolve Upgrading, verboseLoggingLevel, RemoteFirst), "resolve --upgrade --verbose"); + (Result.Ok (Command.Resolve Quick, defaultLoggingLevel, CacheFirst), "resolve --cache-first "); + (Result.Ok (Command.Resolve Quick, verboseLoggingLevel, CacheFirst), "resolve --cache-first --verbose"); - (Result.Ok (Command.UpgradeDependencies [], defaultLoggingLevel), "upgrade"); - (Result.Ok (Command.UpgradeDependencies [ abcDef ], defaultLoggingLevel), "upgrade abc/def"); - (Result.Ok (Command.UpgradeDependencies [], verboseLoggingLevel), " upgrade --verbose "); - (Result.Ok (Command.UpgradeDependencies [ abcDef ], verboseLoggingLevel), "upgrade abc/def --verbose "); + (Result.Ok (Command.UpgradeDependencies [], defaultLoggingLevel, RemoteFirst), "upgrade"); + (Result.Ok (Command.UpgradeDependencies [ abcDef ], defaultLoggingLevel, RemoteFirst), "upgrade abc/def"); + (Result.Ok (Command.UpgradeDependencies [], verboseLoggingLevel, RemoteFirst), " upgrade --verbose "); + (Result.Ok (Command.UpgradeDependencies [ abcDef ], verboseLoggingLevel, RemoteFirst), "upgrade abc/def --verbose "); + (Result.Ok (Command.UpgradeDependencies [], verboseLoggingLevel, CacheFirst), " upgrade --cache-first --verbose "); + (Result.Ok (Command.UpgradeDependencies [ abcDef ], verboseLoggingLevel, CacheFirst), "upgrade abc/def --cache-first --verbose "); ( Result.Ok ( Command.AddDependencies [ { Package = ijkXyz; Constraint = Constraint.wildcard; Targets = None } ], - defaultLoggingLevel + defaultLoggingLevel, + RemoteFirst ), "add github.com/ijk/xyz " ); ( - Result.Ok (Command.UpgradeDependencies [ abcDef; ijkXyz ], verboseLoggingLevel), + Result.Ok (Command.UpgradeDependencies [ abcDef; ijkXyz ], verboseLoggingLevel, RemoteFirst), "upgrade abc/def github.com/ijk/xyz --verbose " ); ] diff --git a/buckaroo-tests/Constraint.fs b/buckaroo-tests/Constraint.fs index 677dcd8..83bf32d 100644 --- a/buckaroo-tests/Constraint.fs +++ b/buckaroo-tests/Constraint.fs @@ -16,21 +16,21 @@ let ``Constraint.parse works correctly`` () = ("*", Constraint.wildcard |> Some); ("revision=aabbccddee", Version.Git(GitVersion.Revision "aabbccddee") |> Exactly |> Some); ("!*", Constraint.wildcard |> Constraint.Complement |> Some); - ("any(branch=master)", Some(Any [Exactly (Version.Git(GitVersion.Branch "master"))])); - ("any(any(branch=master))", Some(Any [ Any [Exactly (Version.Git(GitVersion.Branch "master"))]])); - ("any(revision=aabbccddee branch=master)", Some (Any [ + ("any(branch=master)", Some(Any <| Set [ Exactly (Version.Git(GitVersion.Branch "master"))])); + ("any(any(branch=master))", Some(Any <| Set[ Any <| Set [ Exactly (Version.Git(GitVersion.Branch "master"))]])); + ("any(revision=aabbccddee branch=master)", Some (Any <| Set[ Exactly (Version.Git(GitVersion.Revision "aabbccddee")); Exactly (Version.Git(GitVersion.Branch "master"))])); - ("all(*)", Some(All [Constraint.wildcard])); + ("all(*)", Some(All <| Set[Constraint.wildcard])); ( "all(branch=master !revision=aabbccddee)", - Some (All [Exactly (Version.Git(GitVersion.Branch "master")); Complement (Exactly (Version.Git(GitVersion.Revision "aabbccddee")))]) + Some (All <| Set[Exactly (Version.Git(GitVersion.Branch "master")); Complement (Exactly (Version.Git(GitVersion.Revision "aabbccddee")))]) ); ( "all(branch=master !any(revision=aabbccddee branch=develop))", - Some (All [ + Some (All <| Set[ Exactly (Version.Git(GitVersion.Branch "master")); - Complement (Any([ + Complement (Any(Set[ Exactly (Version.Git(GitVersion.Revision "aabbccddee")); Exactly (Version.Git(GitVersion.Branch "develop")); ])) @@ -52,12 +52,12 @@ let ``Constraint.parse works correctly`` () = "+1.0.0", Some (Constraint.rangeToConstraint RangeType.Patch (SemVer.create (1, 0, 0, 0))) ); - ("all(branch=master ^1.0.0)", Some (All [ + ("all(branch=master ^1.0.0)", Some (All <| Set[ Exactly (Git (GitVersion.Branch "master")); Constraint.rangeToConstraint RangeType.Major (SemVer.create (1, 0, 0, 0)) ] )); - ("all(^1.0.0 branch=master)", Some (All [ + ("all(^1.0.0 branch=master)", Some (All <| Set[ Constraint.rangeToConstraint RangeType.Major (SemVer.create (1, 0, 0, 0)); Exactly (Git (GitVersion.Branch "master")) ])) @@ -100,6 +100,7 @@ let ``Constraint.simplify works correctly`` () = ("any(all(revision=aabbccddee))", "revision=aabbccddee"); ("all(any(revision=aabbccddee))", "revision=aabbccddee"); ("any(branch=master any(revision=aabbccddee))", "any(revision=aabbccddee branch=master)"); + ("any(all() revision=aabbccddee)", "any(revision=aabbccddee all())"); ] for (input, expected) in cases do let actual = diff --git a/buckaroo-tests/Manifest.fs b/buckaroo-tests/Manifest.fs index 7c8ac1f..0240f26 100644 --- a/buckaroo-tests/Manifest.fs +++ b/buckaroo-tests/Manifest.fs @@ -87,7 +87,7 @@ let ``Manifest.toToml roundtrip 1`` () = ] Dependencies = Set [{ Targets = Some ([{Folders=["foo"; "bar"]; Name = "xxx"}]) - Constraint = All [Constraint.Exactly (Version.SemVer SemVer.zero)] + Constraint = All <| Set[Constraint.Exactly (Version.SemVer SemVer.zero)] Package = PackageIdentifier.GitHub { Owner = "abc"; Project = "def" } }] } @@ -123,12 +123,12 @@ let ``Manifest.toToml roundtrip 2`` () = ] Dependencies = Set [{ Targets = Some ([{Folders=["foo"; "bar"]; Name = "xxx"}]) - Constraint = All [Constraint.Exactly (Version.SemVer SemVer.zero)] + Constraint = All <| Set[Constraint.Exactly (Version.SemVer SemVer.zero)] Package = PackageIdentifier.GitHub { Owner = "abc"; Project = "def" } }] PrivateDependencies = Set [{ Targets = Some ([{Folders=["foo"; "bar"]; Name = "yyy"}]) - Constraint = Any [Constraint.Exactly (Version.SemVer SemVer.zero)] + Constraint = Any <|Set[Constraint.Exactly (Version.SemVer SemVer.zero)] Package = PackageIdentifier.GitHub { Owner = "abc"; Project = "def" } }] } diff --git a/buckaroo-tests/Solver.fs b/buckaroo-tests/Solver.fs index f2f486e..888b1eb 100644 --- a/buckaroo-tests/Solver.fs +++ b/buckaroo-tests/Solver.fs @@ -11,8 +11,9 @@ open Buckaroo.Tests type CookBook = List * Manifest> type LockBookEntries = List<(string*int) * List>> type LockBook = Map + let package name = PackageIdentifier.Adhoc { - Owner = "test"; + Owner = "test" Project = name } @@ -89,7 +90,7 @@ type TestingSourceExplorer (cookBook : CookBook, lockBook : LockBook) = Revision = r }) |> AsyncSeq.ofSeq - | _ -> raise <| new System.SystemException "package not found" + | _ -> raise <| System.SystemException "Package not found" } member this.LockLocation (location : PackageLocation) : Async = async { @@ -120,11 +121,11 @@ type TestingSourceExplorer (cookBook : CookBook, lockBook : LockBook) = let solve (partial : Solution) (cookBook : CookBook) (lockBookEntries : LockBookEntries) root style = let lockBook = lockBookOf lockBookEntries - let console = new ConsoleManager(LoggingLevel.Silent); + let console = ConsoleManager (LoggingLevel.Silent) let context : TaskContext = { - Console = console; - DownloadManager = DownloadManager(console, "/tmp"); - GitManager = new GitManager(console, new GitCli(console), "/tmp"); + Console = console + DownloadManager = DownloadManager(console, "/tmp") + GitManager = new GitManager(CacheFirst, console, new GitCli(console), "/tmp") SourceExplorer = TestingSourceExplorer(cookBook, lockBook) } @@ -133,7 +134,7 @@ let solve (partial : Solution) (cookBook : CookBook) (lockBookEntries : LockBook root style (lockBook |> Map.tryFind (packageLock ("root", 0))) -let getLockedRev (p : string) (r: Resolution) = +let getLockedRev (p : string) (r : _) = match r with | Ok solution -> let (resolved, _) = solution.Resolutions.[package p] @@ -143,7 +144,7 @@ let getLockedRev (p : string) (r: Resolution) = | _ -> "" () -let isOk (r: Resolution) = +let isOk (r : _) = match r with | Ok _ -> true | _ -> false @@ -228,7 +229,7 @@ let ``Solver can compute version intersections`` () = let ``Solver can compute intersection of branches`` () = let root = manifest [ - ("a", All [Exactly (br "b"); Exactly (br "a")]) + ("a", All <| Set[Exactly (br "b"); Exactly (br "a")]) ] let spec = [ @@ -346,7 +347,7 @@ let ``Solver handles negated constraints also`` () = let root = manifest [ ("a", Exactly (br "a")) - ("b", Any [Exactly (br "a"); Exactly (br "b")]) + ("b", Any <|Set[Exactly (br "a"); Exactly (br "b")]) ] let spec = [ @@ -357,7 +358,7 @@ let ``Solver handles negated constraints also`` () = Set[ver 2; br "a"], manifest []) (package "b", - Set[ver 2; br "b"], + Set[ver 2; br "a"], manifest []) (package "a", Set[ver 3; br "a"], diff --git a/buckaroo/AddCommand.fs b/buckaroo/AddCommand.fs index 2fdb7be..2b5f1e6 100644 --- a/buckaroo/AddCommand.fs +++ b/buckaroo/AddCommand.fs @@ -1,13 +1,14 @@ module Buckaroo.AddCommand -open System open System.IO open Buckaroo.RichOutput -open Buckaroo +open Buckaroo.Logger let task (context : Tasks.TaskContext) dependencies = async { - context.Console.Write ( - (text "Adding ") + + let logger = createLogger context.Console None + + logger.RichInfo ( + (text "Adding dependency on ") + ( dependencies |> Seq.map Dependency.showRich @@ -16,6 +17,7 @@ let task (context : Tasks.TaskContext) dependencies = async { ) let! manifest = Tasks.readManifest "." + let newManifest = { manifest with Dependencies = @@ -26,6 +28,7 @@ let task (context : Tasks.TaskContext) dependencies = async { if manifest = newManifest then + logger.Warning ("The dependency already exists in the manifest") return () else let! maybeLock = async { @@ -37,15 +40,16 @@ let task (context : Tasks.TaskContext) dependencies = async { return None } - let! resolution = Solver.solve context Solution.empty newManifest ResolutionStyle.Quick maybeLock + let! resolution = + Solver.solve context Solution.empty newManifest ResolutionStyle.Quick maybeLock match resolution with - | Resolution.Ok solution -> + | Result.Ok solution -> do! Tasks.writeManifest newManifest do! Tasks.writeLock (Lock.fromManifestAndSolution newManifest solution) do! InstallCommand.task context - | _ -> - () - context.Console.Write ("Success. " |> text |> foreground ConsoleColor.Green) + logger.Success ("The dependency was added to the manifest and installed") + | _ -> + logger.Error ("Failed to add the dependency") } diff --git a/buckaroo/Command.fs b/buckaroo/Command.fs index 642de92..8f7d460 100644 --- a/buckaroo/Command.fs +++ b/buckaroo/Command.fs @@ -31,6 +31,13 @@ module Command = return Option.isSome maybeSkip } + let cacheFirstParser : Parser = parse { + let! cacheFirst = + CharParsers.skipString "--cache-first" + |> Primitives.opt + return Option.isSome cacheFirst + } + let startParser : Parser = parse { do! CharParsers.spaces return Start @@ -170,13 +177,27 @@ module Command = do! CharParsers.spaces - let! isVerbose = verboseParser - + let! isCacheFirst = cacheFirstParser do! CharParsers.spaces - let loggingLevel = if isVerbose then LoggingLevel.Trace else LoggingLevel.Info + let! isVerbose = verboseParser + do! CharParsers.spaces - return (command, loggingLevel) + let loggingLevel = + if isVerbose + then + LoggingLevel.Trace + else + LoggingLevel.Info + + let fetchStyle = + if isCacheFirst + then + CacheFirst + else + RemoteFirst + + return (command, loggingLevel, fetchStyle) } let parse (x : string) = @@ -210,15 +231,13 @@ module Command = let! resolution = Solver.solve context Solution.empty newManifest ResolutionStyle.Quick maybeLock match resolution with - | Resolution.Ok solution -> + | Result.Ok solution -> do! Tasks.writeManifest newManifest do! Tasks.writeLock (Lock.fromManifestAndSolution newManifest solution) do! InstallCommand.task context - | _ -> () - - System.Console.WriteLine ("Success. ") - return () + System.Console.WriteLine ("Success. ") + | _ -> () } let init context = async { @@ -232,8 +251,8 @@ module Command = context.Console.Write( ("warning " |> warn) + ("There is already a buckaroo.toml file in this directory" |> text)) } - let runCommand loggingLevel command = async { - let! context = Tasks.getContext loggingLevel + let runCommand loggingLevel fetchStyle command = async { + let! context = Tasks.getContext loggingLevel fetchStyle do! match command with @@ -241,7 +260,7 @@ module Command = | Init -> init context | Help -> HelpCommand.task context | Version -> VersionCommand.task context - | Resolve style -> ResolveCommand.task context Solution.empty style + | Resolve style -> ResolveCommand.task context Solution.empty style |> Async.Ignore | Install -> InstallCommand.task context | Quickstart -> QuickstartCommand.task context | UpgradeDependencies dependencies -> UpgradeCommand.task context dependencies diff --git a/buckaroo/ConsoleManager.fs b/buckaroo/ConsoleManager.fs index 6bee310..faa397a 100644 --- a/buckaroo/ConsoleManager.fs +++ b/buckaroo/ConsoleManager.fs @@ -113,19 +113,11 @@ type ConsoleManager (minimumLoggingLevel : LoggingLevel) = member this.Error (message, loggingLevel) = actor.Post (Output (message, loggingLevel, OutputCategory.Error)) - member this.Read() = - actor.PostAndAsyncReply(fun channel -> Input channel) - - member this.ReadSecret() = - actor.PostAndAsyncReply(fun channel -> InputSecret channel) - - member this.Flush() = - actor.PostAndAsyncReply(fun channel -> Flush channel) - -let namespacedLogger (console : ConsoleManager) (componentName : string) (x : RichOutput, logLevel : LoggingLevel) = - ( - "[" + componentName + "] " - |> RichOutput.text - |> RichOutput.foreground System.ConsoleColor.DarkGray - ) + - x |> fun x -> console.Write (x, logLevel) \ No newline at end of file + member this.Read () = + actor.PostAndAsyncReply Input + + member this.ReadSecret () = + actor.PostAndAsyncReply InputSecret + + member this.Flush () = + actor.PostAndAsyncReply Flush diff --git a/buckaroo/Constants.fs b/buckaroo/Constants.fs index 7fc179d..2f6eecc 100644 --- a/buckaroo/Constants.fs +++ b/buckaroo/Constants.fs @@ -1,7 +1,7 @@ module Buckaroo.Constants [] -let Version = "2.1.1" +let Version = "2.2.0" [] let PackagesDirectory = "buckaroo" @@ -20,3 +20,6 @@ let BuckarooMacrosFileName = "buckaroo_macros.bzl" [] let BuckarooDepsFileName = "BUCKAROO_DEPS" + +[] +let MaxConsecutiveFailures = 10 diff --git a/buckaroo/Constraint.fs b/buckaroo/Constraint.fs index 1d4d795..fa2c65a 100644 --- a/buckaroo/Constraint.fs +++ b/buckaroo/Constraint.fs @@ -21,8 +21,8 @@ type RangeComparatorTypes = type Constraint = | Exactly of Version | Range of RangeComparatorTypes * SemVer -| Any of List -| All of List +| Any of Set +| All of Set | Complement of Constraint #nowarn "40" @@ -31,13 +31,13 @@ module Constraint = open FParsec - let wildcard = All [] + let wildcard = All Set.empty let intersection (c : Constraint) (d : Constraint) : Constraint = - All [ c; d ] + All (Set[ c; d ]) let union (c : Constraint) (d : Constraint) : Constraint = - Any [ c; d ] + Any (Set[ c; d ]) let complement (c : Constraint) : Constraint = Complement c @@ -67,6 +67,24 @@ module Constraint = | SemVer semVer -> semVer |> isWithinRange (op, v) | _ -> false ) + + [] + let private MaxChanceOfSuccess = 1024 + + let rec chanceOfSuccess (x : Constraint) : int = + match x with + | Exactly (Version.Git (Revision _)) -> 1 + | Exactly (Version.Git (Tag _)) -> 2 + | Exactly (Version.SemVer _) -> 3 + | Range _ -> 4 + | Exactly (Version.Git (Branch _)) -> 5 + | Any xs -> xs |> Seq.map chanceOfSuccess |> Seq.append [ 0 ] |> Seq.sum + | All xs -> + (xs |> Seq.map chanceOfSuccess |> Seq.append [ 0 ] |> Seq.max) - + (xs |> Seq.map chanceOfSuccess |> Seq.append [ 0 ] |> Seq.sum) + | Complement x -> MaxChanceOfSuccess - (chanceOfSuccess x) + + // TODO: Better Sorting!!!!! let rec compare (x : Constraint) (y : Constraint) : int = match (x, y) with | (Exactly u, Exactly v) -> Version.compare u v @@ -120,31 +138,36 @@ module Constraint = let iterate c = match c with | Complement (Complement x) -> x - | Constraint.All [ x ] -> x | Constraint.All xs -> - xs - |> Seq.collect (fun x -> - match x with - | All xs -> xs - | _ -> [ x ] - ) - |> Seq.sort - |> Seq.distinct - |> Seq.toList - |> Constraint.All - | Constraint.Any [ x ] -> x + match xs |> Set.toList with + | [ x ] -> x + | xs -> + xs + |> Seq.collect (fun x -> + match x with + | All xs -> xs + | _ -> Set[ x ] + ) + |> Seq.sortDescending + |> Seq.distinct + |> Set + |> Constraint.All | Constraint.Any xs -> - xs - |> Seq.collect (fun x -> - match x with - | Any xs -> xs - | _ -> [ x ] - ) - |> Seq.sort - |> Seq.distinct - |> Seq.toList - |> Constraint.Any + match xs |> Set.toList with + | [ x ] -> x + | xs -> + xs + |> Seq.collect (fun x -> + match x with + | Any xs -> xs + | _ -> Set[ x ] + ) + |> Seq.sortDescending + |> Seq.distinct + |> Set + |> Constraint.Any | _ -> c + let next = iterate c if next = c then @@ -154,7 +177,7 @@ module Constraint = let wildcardParser = parse { do! CharParsers.skipString "*" - return All [] + return All Set.empty } let symbolParser<'T> (token : string, symbol : 'T) = parse { @@ -178,10 +201,10 @@ module Constraint = | Patch -> { semVer with Patch = semVer.Patch + 1; Increment = 0 } Constraint.All - [ + (Set[ Constraint.Range (GTE, semVer); Constraint.Range (LT, max); - ] + ]) let rangeParser = parse { let! rangeType = rangeTypeParser @@ -227,7 +250,7 @@ module Constraint = let! elements = CharParsers.spaces1 |> Primitives.sepBy parser do! CharParsers.skipString ")" - return Any elements + return Any (Set elements) } let allParser = parse { @@ -235,7 +258,7 @@ module Constraint = let! elements = CharParsers.spaces1 |> Primitives.sepBy parser do! CharParsers.skipString ")" - return All elements + return All (Set elements) } return! choice [ @@ -248,6 +271,7 @@ module Constraint = allParser ] } + let parse (x : string) : Result = match run (parser .>> CharParsers.eof) x with | Success(result, _, _) -> Result.Ok result diff --git a/buckaroo/DefaultSourceExplorer.fs b/buckaroo/DefaultSourceExplorer.fs index 4a52439..cb75dfe 100644 --- a/buckaroo/DefaultSourceExplorer.fs +++ b/buckaroo/DefaultSourceExplorer.fs @@ -1,16 +1,17 @@ namespace Buckaroo open FSharp.Control -open Buckaroo.Console open FSharpx -open RichOutput +open Buckaroo.Console +open Buckaroo.RichOutput +open Buckaroo.Logger type DefaultSourceExplorer (console : ConsoleManager, downloadManager : DownloadManager, gitManager : GitManager) = - let log = namespacedLogger console "explorer" + let logger = createLogger console (Some "explorer") let toOptional = Async.Catch >> (Async.map Choice.toOption) let fromFileCache url revision path = - gitManager.getFile url revision path |> toOptional + gitManager.GetFile url revision path |> toOptional let cacheOrApi (api, url : string, rev : string, path : string) = async { let! cached = fromFileCache url rev path @@ -22,7 +23,7 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download let extractFileFromHttp (source : HttpLocation) (filePath : string) = async { if Option.defaultValue ArchiveType.Zip source.Type <> ArchiveType.Zip then - return raise (new System.Exception("Only zip is currently supported")) + return raise (System.Exception("Only zip is currently supported")) let! pathToZip = downloadManager.DownloadToCache source.Url use file = System.IO.File.OpenRead pathToZip @@ -44,10 +45,10 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download | [ root ] -> return root | [] -> return - raise (new System.Exception("Strip prefix " + stripPrefix + " did not match any paths! ")) + raise (System.Exception("Strip prefix " + stripPrefix + " did not match any paths! ")) | _ -> return - raise (new System.Exception("Strip prefix " + stripPrefix + " matched multiple paths: " + (string roots))) + raise (System.Exception("Strip prefix " + stripPrefix + " matched multiple paths: " + (string roots))) | None -> return "" } @@ -72,7 +73,7 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download cacheOrApi (GitLabApi.fetchFile gitLab.Package, url, gitLab.Revision, path) | PackageLock.Git git -> let url = git.Url - cacheOrApi(gitManager.getFile git.Url, url, git.Revision, path) + cacheOrApi(gitManager.GetFile git.Url, url, git.Revision, path) | PackageLock.Http (http, _) -> extractFileFromHttp http path @@ -188,7 +189,6 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download // TODO: Revisions? } - interface ISourceExplorer with member this.FetchVersions locations package = asyncSeq { @@ -300,8 +300,7 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download let errorMessage = "Invalid " + Constants.ManifestFileName + " file. \n" + (Manifest.ManifestParseError.show error) - new System.Exception(errorMessage) - |> raise + raise <| System.Exception errorMessage } member this.FetchLock (location, versions) = @@ -310,16 +309,16 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download return match maybeContent with | None -> - log( - (warn "warning ") + (text "Could not fetch ") + (highlight Constants.LockFileName) + (text " from ") + - (PackageLock.show location |> highlight) + (warn " 404"), LoggingLevel.Info) - raise <| new System.Exception("Could not fetch " + Constants.LockFileName + " file") + logger.RichWarning ( + (text "Could not fetch ") + (highlight Constants.LockFileName) + (text " from ") + + (PackageLock.show location |> highlight) + (warn " 404")) + raise <| System.Exception("Could not fetch " + Constants.LockFileName + " file") | Some content -> match Lock.parse content with | Result.Ok manifest -> manifest | Result.Error errorMessage -> - log( - (warn "warning ") + (text "Could not parse ") + (highlight Constants.LockFileName) + (text " from ") + - (PackageLock.show location |> highlight) + (text " ") + (warn errorMessage), LoggingLevel.Info) - new System.Exception("Invalid " + Constants.LockFileName + " file") |> raise + logger.RichWarning( + (text "Could not parse ") + (highlight Constants.LockFileName) + (text " from ") + + (PackageLock.show location |> highlight) + (text " ") + (warn errorMessage)) + System.Exception("Invalid " + Constants.LockFileName + " file") |> raise } diff --git a/buckaroo/Dependency.fs b/buckaroo/Dependency.fs index 24bfbc5..50d4ce8 100644 --- a/buckaroo/Dependency.fs +++ b/buckaroo/Dependency.fs @@ -9,6 +9,7 @@ type Dependency = { module Dependency = open FParsec + open Buckaroo.RichOutput let satisfies (dependency : Dependency) (atom : Atom) = atom.Package = dependency.Package && atom.Versions |> Constraint.satisfies dependency.Constraint @@ -23,15 +24,17 @@ module Dependency = let showRich (x : Dependency) = ( - PackageIdentifier.show x.Package - |> RichOutput.text - |> RichOutput.foreground System.ConsoleColor.Cyan - ) + - "@" + - ( - Constraint.show x.Constraint - |> RichOutput.text - |> RichOutput.foreground System.ConsoleColor.DarkRed + ( + PackageIdentifier.show x.Package + |> text + |> foreground System.ConsoleColor.Magenta + ) + + " at " + + ( + Constraint.show x.Constraint + |> text + |> foreground System.ConsoleColor.Magenta + ) ) + ( x.Targets diff --git a/buckaroo/GitCli.fs b/buckaroo/GitCli.fs index b840cdd..133d525 100644 --- a/buckaroo/GitCli.fs +++ b/buckaroo/GitCli.fs @@ -2,15 +2,16 @@ namespace Buckaroo open System open System.Text -open Buckaroo.Console -open RichOutput open FSharp.Control open FSharpx -open Bash +open Buckaroo.Console +open Buckaroo.RichOutput +open Buckaroo.Bash +open Buckaroo.Logger type GitCli (console : ConsoleManager) = - let log = namespacedLogger console "git" + let logger = createLogger console (Some "git") let nl = System.Environment.NewLine @@ -29,7 +30,7 @@ type GitCli (console : ConsoleManager) = console.Write (rt, LoggingLevel.Debug) - let stdout = new StringBuilder() + let stdout = StringBuilder () do! Bash.runBashSync exe args (stdout.Append >> ignore) ignore @@ -161,7 +162,7 @@ type GitCli (console : ConsoleManager) = } member this.ShallowClone (url : String) (directory : string) = async { - log((text "Shallow cloning ") + (highlight url), LoggingLevel.Info) + logger.RichInfo ((text "Shallow cloning ") + (highlight url)) do! runBash "git" ("clone --bare --depth=1 " + url + " " + directory) |> Async.Ignore diff --git a/buckaroo/GitLabApi.fs b/buckaroo/GitLabApi.fs index aeff618..bc1a9c5 100644 --- a/buckaroo/GitLabApi.fs +++ b/buckaroo/GitLabApi.fs @@ -11,6 +11,5 @@ let fetchFile (package : GitLabPackageIdentifier) (commit : Revision) (file : st let url = "https://gitlab.com/" + (package.Groups |> String.concat "/") + "/" + package.Project + "/raw/" + commit + "/" + file - return! Http.AsyncRequestString(url) } diff --git a/buckaroo/GitManager.fs b/buckaroo/GitManager.fs index 295ccbe..52c9bbc 100644 --- a/buckaroo/GitManager.fs +++ b/buckaroo/GitManager.fs @@ -4,18 +4,24 @@ open System open System.IO open System.Security.Cryptography open System.Text.RegularExpressions -open FSharpx.Control open FSharp.Control open FSharpx -open Console -open RichOutput +open FSharpx.Control +open Buckaroo.Console +open Buckaroo.Logger +open Buckaroo.RichOutput -type CloneRequest = +type GitManagerRequest = | CloneRequest of string * AsyncReplyChannel> +| FetchRefs of string * AsyncReplyChannel> + +type FetchStyle = +| RemoteFirst +| CacheFirst -type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) = +type GitManager (style: FetchStyle, console : ConsoleManager, git : IGit, cacheDirectory : string) = - let log = namespacedLogger console "git" + let logger = createLogger console (Some "git") let mutable refsCache = Map.empty @@ -28,8 +34,10 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) let regexSearch = new string(Path.GetInvalidFileNameChars()) + new string(Path.GetInvalidPathChars()) + - "@.:\\/"; - let r = new Regex(String.Format("[{0}]", Regex.Escape(regexSearch))) + "@.:\\/" + + let r = Regex(String.Format("[{0}]", Regex.Escape(regexSearch))) + Regex.Replace(r.Replace(x, "-"), "-{2,}", "-") let cloneFolderName (url : string) = @@ -41,6 +49,20 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) let folder = sanitizeFilename(url).ToLower() + "-" + hash.Substring(0, 16) Path.Combine(cacheDirectory, folder) + let pickRefsToFetch (style: FetchStyle) (remote : Async>) (cache: Async>) = async { + match style with + | RemoteFirst -> + let! x = remote + if x |> List.isEmpty |> not then + return x + else return! cache + | CacheFirst -> + let! x = cache + if x |> List.isEmpty |> not then + return x + else return! remote + } + let mailboxCloneProcessor = MailboxProcessor.Start(fun inbox -> async { let mutable cloneCache : Map> = Map.empty while true do @@ -62,6 +84,45 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) |> Async.Cache cloneCache <- cloneCache |> Map.add url task replyChannel.Reply(task) + | FetchRefs (url, replyChannel) -> + match refsCache |> Map.tryFind url with + | Some task -> replyChannel.Reply (task) + | None -> + let task = + async { + logger.RichInfo ((text "Fetching refs from ") + (highlight url)) + + let cacheDir = cloneFolderName url + let startTime = System.DateTime.Now + + let! refs = + pickRefsToFetch + style + (git.RemoteRefs url + |> Async.Catch + |> Async.map (Choice.toOption >> Option.defaultValue([]))) + (git.RemoteRefs cacheDir + |> Async.Catch + |> Async.map (Choice.toOption >> Option.defaultValue([]))) + + let endTime = System.DateTime.Now + + if refs |> List.isEmpty then + raise <| SystemException("No internet connection and the cache is empty") + + logger.RichSuccess( + (text "Fetched ") + + (refs |> List.length |> string |> info) + + (text " refs in ") + + ((endTime - startTime).TotalSeconds.ToString("N3"))) + + return refs + } + |> Async.Cache + + refsCache <- refsCache |> Map.add url task + + replyChannel.Reply (task) }) member this.Clone (url : string) : Async = async { @@ -70,8 +131,11 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) } member this.CopyFromCache (gitUrl : string) (revision : Revision) (installPath : string) : Async = async { - let! hasGit = Files.directoryExists (Path.Combine (installPath, ".git/")) - if hasGit then + let! hasGit = + Files.directoryExists (Path.Combine (installPath, ".git/")) + + if hasGit + then do! git.UpdateRefs installPath return! git.Checkout installPath revision else @@ -94,6 +158,7 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) |> Async.Ignore | None -> let! defaultBranch = git.DefaultBranch targetDirectory + yield AsyncSeq.interleave (if defaultBranch <> "master" @@ -115,48 +180,20 @@ type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) |> AsyncSeq.take 1 |> AsyncSeq.lastOrDefault false - if not success then - raise <| new Exception("Failed to fetch: " + url + " " + commit) + if not success + then + raise <| Exception("Failed to fetch: " + url + " " + commit) } member this.FetchRefs (url : string) = async { - match refsCache |> Map.tryFind url with - | Some refs -> return refs - | None -> - log( (text "Fetching refs from ") + (highlight url), LoggingLevel.Info) - let cacheDir = cloneFolderName url - let startTime = System.DateTime.Now - let! refs = - Async.Parallel - ( - (git.RemoteRefs url - |> Async.Catch - |> Async.map(Choice.toOption >> Option.defaultValue([]))), - (git.RemoteRefs cacheDir - |> Async.Catch - |> Async.map(Choice.toOption >> Option.defaultValue([]))) - ) - |> Async.map(fun (a, b) -> - if a.Length = 0 && b.Length = 0 then - raise <| new SystemException("No internet connection and the cache is empty") - else if a.Length > 0 - then a - else b - ) - refsCache <- refsCache |> Map.add url refs - let endTime = System.DateTime.Now - log((success "success ") + - (text "fetched ") + - ((refs|>List.length).ToString() |> info) + - (text " refs in ") + - ((endTime-startTime).TotalSeconds.ToString("N3")|>info), LoggingLevel.Info) - return refs + let! res = mailboxCloneProcessor.PostAndAsyncReply(fun ch -> FetchRefs(url, ch)) + return! res } - member this.getFile (url : string) (revision : Revision) (file : string) : Async = + member this.GetFile (url : string) (revision : Revision) (file : string) : Async = async { - let targetDirectory = cloneFolderName(url) - // TODO: preemptivly clone and fetch + let targetDirectory = cloneFolderName url + // TODO: Preemptively clone and fetch return! git.ReadFile targetDirectory revision file } diff --git a/buckaroo/InstallCommand.fs b/buckaroo/InstallCommand.fs index 944eadf..73e9a8d 100644 --- a/buckaroo/InstallCommand.fs +++ b/buckaroo/InstallCommand.fs @@ -7,67 +7,15 @@ open Buckaroo open Buckaroo.BuckConfig open Buckaroo.Tasks open Buckaroo.Console +open Buckaroo.Logger open Buckaroo.RichOutput -type Logger = - { - Info : string -> Unit - Success : string -> Unit - Trace : string -> Unit - Warning : string -> Unit - Error : string -> Unit - } - -let private createLogger (console : ConsoleManager) = - let prefix = - "info " - |> text - |> foreground ConsoleColor.Blue - - let info (x : string) = - console.Write (prefix + x, LoggingLevel.Info) - - let prefix = - "success " - |> text - |> foreground ConsoleColor.Green - - let success (x : string) = - console.Write (prefix + x, LoggingLevel.Info) - - let trace (x : string) = - console.Write (x, LoggingLevel.Trace) - - let prefix = - "warning " - |> text - |> foreground ConsoleColor.Yellow - - let warning (x : string) = - console.Write (prefix + x, LoggingLevel.Info) - - let prefix = - "error " - |> text - |> foreground ConsoleColor.Red - - let error (x : string) = - console.Write (prefix + x, LoggingLevel.Info) - - { - Info = info; - Success = success; - Trace = trace; - Warning = warning; - Error = error; - } - let private fetchManifestFromLock (lock : Lock) (sourceExplorer : ISourceExplorer) (package : PackageIdentifier) = async { let location = match lock.Packages |> Map.tryFind package with | Some lockedPackage -> (lockedPackage.Location, lockedPackage.Versions) | None -> - new Exception("Lock file does not contain " + (PackageIdentifier.show package)) + Exception ("Lock file does not contain " + (PackageIdentifier.show package)) |> raise return! sourceExplorer.FetchManifest location @@ -242,7 +190,7 @@ let private compareReceipt logger installPath location = async { } let installPackageSources (context : Tasks.TaskContext) (installPath : string) (location : PackageLock) (versions : Set) = async { - let logger = createLogger context.Console + let logger = createLogger context.Console None let downloadManager = context.DownloadManager let gitManager = context.GitManager @@ -286,7 +234,7 @@ let installPackageSources (context : Tasks.TaskContext) (installPath : string) ( if discoveredHash <> sha256 then return - new Exception("Hash mismatch for " + http.Url + "! Expected " + sha256 + "but found " + discoveredHash) + Exception("Hash mismatch for " + http.Url + "! Expected " + sha256 + "but found " + discoveredHash) |> raise do! Files.deleteDirectoryIfExists installPath |> Async.Ignore do! Files.mkdirp installPath @@ -480,7 +428,7 @@ let writeTopLevelFiles (context : Tasks.TaskContext) (root : string) (lock : Loc } let task (context : Tasks.TaskContext) = async { - let logger = createLogger context.Console + let logger = createLogger context.Console None logger.Info "Installing packages..." diff --git a/buckaroo/Logger.fs b/buckaroo/Logger.fs new file mode 100644 index 0000000..eb4f02a --- /dev/null +++ b/buckaroo/Logger.fs @@ -0,0 +1,83 @@ +module Buckaroo.Logger + +open System +open Buckaroo.Console +open Buckaroo.RichOutput + +type Logger = + { + Info : string -> Unit + RichInfo : RichOutput -> Unit + Success : string -> Unit + RichSuccess : RichOutput -> Unit + Trace : string -> Unit + Warning : string -> Unit + RichWarning : RichOutput -> Unit + Error : string -> Unit + RichError : RichOutput -> Unit + } + +let createLogger (console : ConsoleManager) (componentName : string option) = + let componentPrefix = + componentName + |> Option.map (fun x -> "[" + x + "] " |> text |> foreground ConsoleColor.DarkGray) + |> Option.defaultValue (text "") + + let prefix = + "info " + |> text + |> foreground ConsoleColor.Blue + + let info (x : string) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let richInfo (x : RichOutput) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let prefix = + "success " + |> text + |> foreground ConsoleColor.Green + + let success (x : string) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let richSuccess (x : RichOutput) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let trace (x : string) = + console.Write (componentPrefix + x, LoggingLevel.Trace) + + let prefix = + "warning " + |> text + |> foreground ConsoleColor.Yellow + + let warning (x : string) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let richWarning (x : RichOutput) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let prefix = + "error " + |> text + |> foreground ConsoleColor.Red + + let error (x : string) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + let richError (x : RichOutput) = + console.Write (componentPrefix + prefix + x, LoggingLevel.Info) + + { + Info = info + RichInfo = richInfo + Success = success + RichSuccess = richSuccess + Trace = trace + Warning = warning + RichWarning = richWarning + Error = error + RichError = richError + } diff --git a/buckaroo/Manifest.fs b/buckaroo/Manifest.fs index 8a6af0e..37a0655 100644 --- a/buckaroo/Manifest.fs +++ b/buckaroo/Manifest.fs @@ -29,7 +29,6 @@ type ManifestParseError = | Location of LocationParseError | ConflictingLocations of AdhocPackageIdentifier * PackageSource * PackageSource - module Manifest = open Buckaroo.Result diff --git a/buckaroo/Prefetch.fs b/buckaroo/Prefetch.fs new file mode 100644 index 0000000..d151df3 --- /dev/null +++ b/buckaroo/Prefetch.fs @@ -0,0 +1,48 @@ +module Buckaroo.Prefetch + +open FSharp.Control + +type private PrefetcherMessage = +| Completed +| Prefetch of PackageIdentifier + +type Prefetcher (sourceExplorer : ISourceExplorer, limit : int) = + let agent = MailboxProcessor.Start(fun inbox -> + let rec waiting () = + inbox.Scan (fun x -> + match x with + | Completed -> Some (working (limit - 1)) + | _ -> None + ) + and working inFlightCount = async { + while true do + let! message = inbox.Receive () + + return! + match message with + | Completed -> working (inFlightCount - 1) + | Prefetch package -> + async { + try + do! + sourceExplorer.FetchVersions Map.empty package + |> AsyncSeq.tryFirst + |> Async.Catch + |> Async.Ignore + + finally + inbox.Post (Completed) + } + |> Async.Start + + if inFlightCount < limit + then + working (inFlightCount + 1) + else + waiting () + } + + working 0 + ) + + member this.Prefetch (package) = agent.Post (Prefetch package) diff --git a/buckaroo/QuickstartCommand.fs b/buckaroo/QuickstartCommand.fs index 4fbe499..fa9a60d 100644 --- a/buckaroo/QuickstartCommand.fs +++ b/buckaroo/QuickstartCommand.fs @@ -66,7 +66,7 @@ let private defaultMain = |> String.concat "\n" let isValidProjectName (candidate : string) = - (new Regex(@"^[A-Za-z0-9\-_]{2,32}$")).IsMatch(candidate) + (Regex(@"^[A-Za-z0-9\-_]{2,32}$")).IsMatch(candidate) let requestProjectName (context : TaskContext) = async { let mutable candidate = "" @@ -92,7 +92,7 @@ let task (context : Tasks.TaskContext) = async { do! Files.writeFile "BUCK" (defaultBuck projectName) do! Files.writeFile "main.cpp" defaultMain - do! ResolveCommand.task context Solution.empty ResolutionStyle.Quick + do! ResolveCommand.task context Solution.empty ResolutionStyle.Quick |> Async.Ignore do! InstallCommand.task context context.Console.Write("To start your app: ") diff --git a/buckaroo/Resolution.fs b/buckaroo/Resolution.fs index 6b658a4..3d0676f 100644 --- a/buckaroo/Resolution.fs +++ b/buckaroo/Resolution.fs @@ -8,28 +8,10 @@ type ResolutionStyle = | Quick | Upgrading -type NotSatisfiable = { - Package : PackageIdentifier - Constraint : Constraint - Msg : string -} with - override this.ToString () = - (string this.Constraint) + - " cannot be satisfied for " + (string this.Package) + - " because: " + this.Msg - - -type Resolution = -| Conflict of Set -| Backtrack of Solution * NotSatisfiable -| Avoid of Solution * NotSatisfiable -| Error of System.Exception -| Ok of Solution - module Solution = let empty = { - Resolutions = Map.empty; + Resolutions = Map.empty } type SolutionMergeError = @@ -66,33 +48,3 @@ module Solution = ) |> String.concat "\n" f solution 0 - -module Resolution = - let show resolution = - match resolution with - | Conflict xs -> - "Conflict! " + - ( - xs - |> Seq.map (fun (d, v) -> (Dependency.show d) + "->" + (Version.show v)) - |> String.concat " " - ) - | Backtrack (_, f) -> f.ToString() - | Avoid (_, e) -> "Error! " + e.ToString() - | Error e -> "Error! " + e.Message - | Ok solution -> "Success! " + (Solution.show solution) - - let merge (a : Resolution) (b : Resolution) : Resolution = - match (a, b) with - | (Backtrack _, _) -> a - | (_, Backtrack _) -> b - | (Avoid _, _) -> a - | (_, Avoid _) -> b - | (Conflict _, _) -> a - | (_, Conflict _) -> b - | (Error _, _) -> a - | (_, Error _) -> b - | (Ok x, Ok y) -> - match Solution.merge x y with - | Result.Ok z -> Ok z - | Result.Error _ -> Resolution.Conflict (set []) // TODO \ No newline at end of file diff --git a/buckaroo/ResolveCommand.fs b/buckaroo/ResolveCommand.fs index e0b0673..4afd9f1 100644 --- a/buckaroo/ResolveCommand.fs +++ b/buckaroo/ResolveCommand.fs @@ -2,25 +2,19 @@ module Buckaroo.ResolveCommand open System open Buckaroo.RichOutput +open Buckaroo.Logger +open Buckaroo.SearchStrategy let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { - let log (x : RichOutput) = context.Console.Write x - - let logInfo (x : RichOutput) = - ("info " |> text |> foreground ConsoleColor.Blue) + x - |> log - - let logError (x : RichOutput) = - ("error " |> text |> foreground ConsoleColor.Red) + x - |> log + let logger = createLogger context.Console None let! maybeLock = async { try return! Tasks.readLockIfPresent with error -> - logError ("The existing lock-file is invalid. " |> text) - logInfo ( + logger.Error "The existing lock-file is invalid. " + logger.RichInfo ( (text "Perhaps you want to delete ") + (text "buckaroo.lock.toml" |> foreground ConsoleColor.Magenta) + (text " and try again?") @@ -35,7 +29,7 @@ let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { let resolve = async { let resolveStart = DateTime.Now - logInfo <| (text "Resolve start: ") + (resolveStart |> Toml.formatDateTime |> text |> foreground ConsoleColor.Cyan) + logger.RichInfo <| (text "Resolve start: ") + (resolveStart |> Toml.formatDateTime |> text |> foreground ConsoleColor.Cyan) let styleName = match resolutionStyle with @@ -44,56 +38,46 @@ let task (context : Tasks.TaskContext) partialSolution resolutionStyle = async { |> text |> foreground ConsoleColor.Cyan - (text "Resolving dependencies using ") + (styleName) + " strategy... " |> logInfo + (text "Resolving dependencies using ") + (styleName) + " strategy... " |> logger.RichInfo - let! resolution = Solver.solve context partialSolution manifest resolutionStyle maybeLock + let! resolution = + Solver.solve context partialSolution manifest resolutionStyle maybeLock let resolveEnd = DateTime.Now - logInfo <| (text "Resolve end: ") + (resolveEnd |> Toml.formatDateTime |> text |> foreground ConsoleColor.Cyan) - logInfo <| (text "Resolve time: ") + (resolveEnd - resolveStart |> string |> text |> foreground ConsoleColor.Cyan) + logger.RichInfo <| (text "Resolve end: ") + (resolveEnd |> Toml.formatDateTime |> text |> foreground ConsoleColor.Cyan) + logger.RichInfo <| (text "Resolve time: ") + (resolveEnd - resolveStart |> string |> text |> foreground ConsoleColor.Cyan) match resolution with - | Resolution.Backtrack (_, f) -> - "Error! " |> text |> foreground ConsoleColor.Red |> log - f.Constraint.ToString() + " for " + f.Package.ToString() + " coudn't be satisfied because: " + f.Msg - |> string |> text |> log - | Resolution.Avoid (_, f) -> - "Error! " |> text |> foreground ConsoleColor.Red |> log - f.Constraint.ToString() + " for " + f.Package.ToString() + " coudn't be satisfied because: " + f.Msg - |> string |> text |> log - | Resolution.Conflict x -> - "Conflict! " |> text |> foreground ConsoleColor.Red |> log - x |> string |> text |> log - - return () - | Resolution.Error e -> - "Error! " |> text |> foreground ConsoleColor.Red |> log - e |> string |> text |> log - return () - | Resolution.Ok solution -> - "Success! " |> text |> foreground ConsoleColor.Green |> log + | Result.Error e -> + (SearchStrategyError.show e) |> logger.RichError + + return false + | Result.Ok solution -> + "A solution to the constraints was found" |> text |> logger.RichSuccess let lock = Lock.fromManifestAndSolution manifest solution try let! previousLock = Tasks.readLock let diff = Lock.showDiff previousLock lock - diff |> text |> log + diff |> text |> logger.RichInfo with _ -> () do! Tasks.writeLock lock - return () + "The lock-file was updated" |> text |> logger.RichSuccess + + return true } match (resolutionStyle, maybeLock) with | (Quick, Some lock) -> if lock.ManifestHash = Manifest.hash manifest then - logInfo <| (text "The existing lock-file is already up-to-date! ") + logger.RichInfo <| (text "The existing lock-file is already up-to-date! ") - return () + return true else return! resolve | (_, _) -> diff --git a/buckaroo/RichOutput.fs b/buckaroo/RichOutput.fs index 75faece..e9fe768 100644 --- a/buckaroo/RichOutput.fs +++ b/buckaroo/RichOutput.fs @@ -39,6 +39,19 @@ type RichOutput = Segments = a.Segments @ b.Segments } + static member (+) (a : string, b : RichOutput) = + { + b with + Segments = + [ + { + Foreground = None + Background = None + Text = a + } + ] @ b.Segments + } + let zero = [] let length richOutput = diff --git a/buckaroo/SearchStrategy.fs b/buckaroo/SearchStrategy.fs new file mode 100644 index 0000000..92e7d62 --- /dev/null +++ b/buckaroo/SearchStrategy.fs @@ -0,0 +1,57 @@ +module Buckaroo.SearchStrategy + +type PackageConstraint = PackageIdentifier * Set + +type LocatedVersionSet = PackageLocation * Set + +type SearchStrategyError = +| LimitReached of PackageConstraint * int +| Unresolvable of PackageConstraint +| NoManifest of PackageIdentifier +| NoPrivateSolution of PackageIdentifier +| TransitiveConflict of Set * SearchStrategyError> + +module SearchStrategyError = + + open System + open Buckaroo.RichOutput + + let private showPackage p = + p + |> PackageIdentifier.show + |> text + |> foreground ConsoleColor.Blue + + let private showConstraint c = + c + |> Constraint.simplify + |> Constraint.show + |> text + |> foreground ConsoleColor.Blue + + let private showCore (p, cs) = + (showPackage p) + " at " + (showConstraint (All cs)) + + let rec show (e : SearchStrategyError) = + match e with + | LimitReached ((p, c), l) -> + "We reached the limit of " + (string l) + " consecutive failures for " + + (showPackage p) + " at " + + (showConstraint (All c)) + ". " + | Unresolvable (p, c) -> + "The package " + (showPackage p) + " at " + (showConstraint (All c)) + " is unresolvable. " + | NoManifest p -> "We could not find any manifests for " + (showPackage p) + ". " + | NoPrivateSolution p -> + "We could not resolve a private dependency for " + (showPackage p) + "." + | TransitiveConflict xs -> + (text "We had the following conflicts: \n") + + ( + xs + |> Seq.collect (fun (cores, reason) -> + cores + |> Seq.map (fun core -> + (" " + (core |> showCore) + ": ") + (show reason) + ) + ) + |> RichOutput.concat (text "\n") + ) diff --git a/buckaroo/Solver.fs b/buckaroo/Solver.fs index c3922a1..c6ce81d 100644 --- a/buckaroo/Solver.fs +++ b/buckaroo/Solver.fs @@ -1,595 +1,756 @@ -namespace Buckaroo +module Buckaroo.Solver +open FSharp.Control open FSharpx.Collections open Buckaroo.Tasks open Buckaroo.Console -open RichOutput -open FSharp.Control +open Buckaroo.RichOutput +open Buckaroo.Logger +open Buckaroo.Constraint +open Buckaroo.Result +open Buckaroo.SearchStrategy +open Buckaroo.Prefetch + +type LocatedAtom = Atom * PackageLock + +type Constraints = Map> + +type ResolutionPath = +| Root of Manifest +| Node of PackageIdentifier * Set * ResolvedVersion + +type SolverState = { + Locations : Map + Root : Set + Selections : Map + Hints : Map> +} + +type ResolutionRequest = +| MarkBadPath of List * PackageConstraint * SearchStrategyError * AsyncReplyChannel +| ProposeCandidates of Constraints * PackageConstraint * seq * AsyncReplyChannel>> +| GetCandidates of Constraints * PackageConstraint * PackageSources * AsyncReplyChannel>> + + +let private ifError x = + match x with + | Result.Error e -> Some e + | _ -> None + +let private ifOk x = + match x with + | Result.Ok v -> Some v + | _ -> None + +let private resultOrDefaultWith f x = + match x with + | Result.Ok v -> v + | Result.Error e -> f e + +let toDnf c = + let d = simplify c + match d with + | All xs -> xs + | _ -> Set [ d ] + +let toPackageConstraint (dep : Dependency) : PackageConstraint = + (dep.Package, toDnf dep.Constraint) + +let constraintsOf (ds: seq) = + ds + |> Seq.groupBy fst + |> Seq.map (fun (k, xs) -> (k, xs |> Seq.map snd |> Set.unionMany)) + |> Map.ofSeq + +let constraintsOfSelection selections = + Map.valueList selections + |> Seq.map ( + (fun m -> m.Manifest.Dependencies) >> + (Set.map toPackageConstraint) + ) + |> Seq.fold Set.union Set.empty + |> constraintsOf + +let pruneSelections (selections: Map) (deps: Set) = + let rec loop (visited: Set) (deps: Set) : seq = seq { + let notVisited = + deps + |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) + |> Seq.toList -module Solver = + if notVisited |> List.isEmpty + then () + else + let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited - open FSharp.Control - open Buckaroo.Result + yield! + notVisited + |> Seq.filter (fun d -> selections |> Map.containsKey d.Package) + |> Seq.map (fun d -> (d.Package, selections.[d.Package])) - [] - let MaxConsecutiveFailures = 10 + let next = + notVisited + |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.fold (fun deps (rv, _) -> Set.union rv.Manifest.Dependencies deps) Set.empty - type LocatedAtom = Atom * PackageLocation + yield! loop nextVisited next + } - type Constraints = Map> + loop Set.empty deps |> Map.ofSeq + +let isUnresolved (selections : Map) (constraints : Map>) (dep : Dependency) = + let c = constraints.[dep.Package] |> All |> Constraint.simplify + selections + |> Map.tryFind dep.Package + |> Option.map fst + |> Option.map (fun rv -> rv.Versions |> Constraint.satisfies c |> not) + |> Option.defaultValue true + +let findUnresolved pick (selections: Map) (deps: Set) = + let constraints = + Map.valueList selections + |> Seq.map fst + |> Seq.map (fun m -> m.Manifest.Dependencies) + |> Seq.map (Set.map toPackageConstraint) + |> Seq.fold Set.union (deps |> Set.map toPackageConstraint) + |> constraintsOf + + let rec loop (visited: Set) (deps: Set) : seq> = seq { + let notVisited = + deps + |> Seq.filter (fun d -> visited |> Set.contains d.Package |> not) + |> Seq.toList + + if notVisited |> List.isEmpty + then () + else + let nextVisited = deps |> Seq.map (fun d -> d.Package) |> Set |> Set.union visited - type SolverState = { - Solution : Solution - Constraints : Constraints - Depth : int - Visited : Set - Locations : Map - Hints : AsyncSeq - Failures: Map> + let next = + notVisited + |> Seq.choose (fun d -> selections |> Map.tryFind d.Package) + |> Seq.map fst + |> Seq.fold (fun deps m -> Set.union m.Manifest.Dependencies deps) Set.empty + + yield! + pick + (notVisited + |> Seq.filter (isUnresolved selections constraints) + |> Seq.map (fun d -> (d.Package, constraints.[d.Package]))) + (loop nextVisited next) } - type SearchStrategyError = - | NotSatisfiable of NotSatisfiable + loop Set.empty deps - type LocatedVersionSet = PackageLocation * Set - type SearchStrategy = ISourceExplorer -> SolverState -> AsyncSeq> +let breadthFirst = findUnresolved (fun a b -> seq { + yield! a + yield! b +}) - let private withTimeout timeout action = - async { - let! child = Async.StartChild (action, timeout) - return! child - } +let depthFirst = findUnresolved (fun a b -> seq { + yield! b + yield! a +}) - let fetchCandidatesForConstraint sourceExplorer locations package constraints = asyncSeq { - let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations package (Constraint.simplify constraints) +let fetchCandidatesForConstraint sourceExplorer locations p c = asyncSeq { + let candidatesToExplore = SourceExplorer.fetchLocationsForConstraint sourceExplorer locations p c - let mutable hasCandidates = false - let mutable branchFailures = Map.empty + let mutable hasCandidates = false + let mutable branchFailures = Map.empty - for x in candidatesToExplore do - if branchFailures |> Map.exists (fun _ v -> v > MaxConsecutiveFailures) then - yield - NotSatisfiable { - Package = package; - Constraint = constraints - Msg = (string MaxConsecutiveFailures) + " consecutive versions didn't have a valid manifest" + for x in candidatesToExplore do + if branchFailures |> Map.exists (fun _ v -> v > Constants.MaxConsecutiveFailures) then + let d = (p, Set [ c ]) + yield + LimitReached (d, Constants.MaxConsecutiveFailures) + |> Result.Error + else + yield! + match x with + | Candidate (packageLocation, c) -> asyncSeq { + let branches = + c + |> Seq.choose (fun v -> + match v with + | Version.Git (Branch b) -> Some b + | _ -> None + ) + + try + let! lock = sourceExplorer.LockLocation packageLocation + do! sourceExplorer.FetchManifest (lock, c) |> Async.Ignore + yield Result.Ok (p, (packageLocation, c)) + + hasCandidates <- true + + for branch in branches do + branchFailures <- + branchFailures + |> Map.add branch 0 + + with _ -> + for branch in branches do + branchFailures <- + branchFailures + |> Map.insertWith (fun i j -> i + j + 1) branch 0 } - |> Result.Error - else - yield! - match x with - | Candidate (packageLocation, c) -> asyncSeq { - let branches = - c - |> Seq.choose (fun v -> - match v with - | Version.Git (Branch b) -> Some b - | _ -> None - ) - - try - let! lock = sourceExplorer.LockLocation packageLocation - do! sourceExplorer.FetchManifest (lock, c) |> Async.Ignore - yield Result.Ok (package, (packageLocation, c)) - - hasCandidates <- true - - for branch in branches do - branchFailures <- - branchFailures - |> Map.add branch 0 - - with _ -> - for branch in branches do - branchFailures <- - branchFailures - |> Map.insertWith (fun i j -> i + j + 1) branch 0 - } - | Unsatisfiable u -> asyncSeq { - yield - Result.Error (NotSatisfiable { - Package = package; - Constraint = u - Msg = "Constraint not satisfiable" - }) + | FetchResult.Unsatisfiable (All xs) -> asyncSeq { + let d = (p, Set xs) + yield d |> Unresolvable |> Result.Error + } + | FetchResult.Unsatisfiable u -> asyncSeq { + let d = (p, Set[u]) + yield d |> Unresolvable |> Result.Error } - if hasCandidates = false - then - yield - Result.Error (NotSatisfiable { - Package = package; - Constraint = constraints; - Msg = "No Version we tested had a valid manifest" - }) - } - - let constraintsOf (ds: Set) = - ds - |> Seq.map (fun x -> (x.Package, x.Constraint)) - |> Seq.groupBy fst - |> Seq.map (fun (k, xs) -> (k, xs |> Seq.map snd |> Set.ofSeq)) - |> Map.ofSeq - - let findConflicts (solution : Solution) (dependencies : Constraints) = seq { - let maybeConflict = - Set.intersect - (dependencies |> Map.keys |> Set.ofSeq) - (solution.Resolutions |> Map.keys |> Set.ofSeq) - - yield! - maybeConflict - |> Set.toSeq - |> Seq.map (fun package -> - (package, - Constraint.satisfies - (Constraint.All (dependencies.[package] |> Set.toList )) - (fst solution.Resolutions.[package]).Versions )) - |> Seq.filter(snd >> not) - |> Seq.map fst - } - - let findUnsatisfied (solution : Solution) (dependencies : Constraints) = seq { - yield! Set.difference - (dependencies |> Map.keys |> Set.ofSeq) - (solution.Resolutions |> Map.keys |> Set.ofSeq) - } - - let private lockToHints (lock : Lock) = - lock.Packages - |> Map.toSeq - |> Seq.map (fun (k, v) -> ({ Package = k; Versions = v.Versions }, v.Location)) - - let private mergeLocations (a : Map) (b : Map) = - let folder state next = result { - let (key : AdhocPackageIdentifier, source) = next - let! s = state - match (s |> Map.tryFind key, source) with - | Some (PackageSource.Http l), PackageSource.Http r -> - let conflicts = - l - |> Map.toSeq - |> Seq.map (fun (v, s) -> (v, s, r.[v])) - |> Seq.filter(fun (_, sl, sr) -> sl <> sr) - |> Seq.toList - - match (conflicts |> List.length > 0) with - | false -> - return! - Result.Error - (ConflictingLocations (key, PackageSource.Http l, PackageSource.Http r)) - | true -> - return s - |> Map.add - key - (PackageSource.Http (Map(Seq.concat [ (Map.toSeq l) ; (Map.toSeq r) ]))) - - | Some (PackageSource.Git _), PackageSource.Git _ -> - return - s - |> Map.add key source - | Some a, b -> - return! Result.Error - (ConflictingLocations (key, a, b)) - | None, _-> - return - s - |> Map.add key source - } - - a - |> Map.toSeq - |> Seq.fold folder (Result.Ok b) + if not hasCandidates + then + let d = (p, Set [c]) + yield + Unresolvable d + |> Result.Error +} - let quickSearchStrategy (sourceExplorer : ISourceExplorer) (state : SolverState) = asyncSeq { - let unsatisfied = - findUnsatisfied state.Solution state.Constraints - |> Set.ofSeq +let resolutionManager (context : TaskContext) : MailboxProcessor = + MailboxProcessor.Start(fun inbox -> async { + let mutable unresolvableCores : Map, SearchStrategyError> = Map.empty + let mutable underconstraintDeps : Set = Set.empty + let mutable world : Map>> = Map.empty - yield! - state.Hints - |> AsyncSeq.filter (fun (atom, _) -> unsatisfied |> Set.contains atom.Package) - |> AsyncSeq.map (fun (atom, lock) -> - Result.Ok (atom.Package, (PackageLock.toLocation lock, atom.Versions)) - ) + let sourceExplorer = context.SourceExplorer + let logger = createLogger context.Console (Some "solver") + let findBadCores (constraints : Constraints) = + unresolvableCores + |> Map.toSeq + |> Seq.filter (fun (core, _) -> + core + |> Set.forall (fun (p, bs) -> + constraints + |> Map.tryFind p + |> Option.map (Set.isSubset bs) + |> Option.defaultValue false + )) + + let trackLocal locations (p, cs) constraintsContext = asyncSeq { + let mutable hadCandidate = false + let c = cs |> All |> Constraint.simplify + + let conflicts = findBadCores (Map.ofSeq [ (p, cs) ]) |> Seq.tryHead + + match conflicts with + | Some (dep, _) -> + yield Result.Error (Unresolvable dep.MinimumElement) + | None -> + let candidates = + fetchCandidatesForConstraint sourceExplorer locations p c + |> AsyncSeq.takeWhile (fun _ -> + findBadCores constraintsContext |> Seq.isEmpty + ) - for package in unsatisfied do - let constraints = - state.Constraints - |> Map.tryFind package - |> Option.defaultValue Set.empty - |> Seq.toList - |> Constraint.All + for candidate in candidates do + match candidate with + | Result.Error (Unresolvable d) -> + unresolvableCores <- (unresolvableCores |> Map.add (Set [d]) (Unresolvable d)) + let (p, cs) = d + logger.RichWarning ( + "Unresolvable: " + + PackageIdentifier.showRich p + + subtle "@" + + (highlight <| Constraint.show (All cs |> simplify)) + ) + yield Result.Error <| Unresolvable d + | Result.Error (LimitReached (d, Constants.MaxConsecutiveFailures)) -> + if hadCandidate && (Set.contains d underconstraintDeps |> not) + then + underconstraintDeps <- (underconstraintDeps |> Set.add d) + let (p, cs) = d + logger.RichWarning ( + text("No manifest found for: ") + + PackageIdentifier.showRich p + + subtle "@" + + Constraint.show (All cs) + ) + logger.Warning ("... is this a valid Buckaroo package?") + + yield Result.Error <| LimitReached (d, Constants.MaxConsecutiveFailures) + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let packageConstraints = + manifest.Dependencies + |> Set.map (fun d -> (d.Package, d.Constraint |> toDnf)) + + world <- ( + world + |> Map.insertWith Set.union (p, cs) (Set [packageConstraints]) + ) + + let conflicts = + manifest.Dependencies + |> Set.map toPackageConstraint + |> constraintsOf + |> Map.insertWith Set.union p cs + |> findBadCores + |> Set + + if conflicts |> Set.isEmpty + then + hadCandidate <- true + yield candidate + else + yield Result.Error (TransitiveConflict conflicts) + | _ -> () - yield! fetchCandidatesForConstraint sourceExplorer state.Locations package constraints - } - let upgradeSearchStrategy (sourceExplorer : ISourceExplorer) (state : SolverState) = asyncSeq { - let unsatisfied = findUnsatisfied state.Solution state.Constraints + } - for package in unsatisfied do - let constraints = - state.Constraints - |> Map.tryFind package - |> Option.defaultValue Set.empty - |> Seq.toList - |> Constraint.All + let trackGlobal (constraints : Constraints) (candidates : AsyncSeq>) = + asyncSeq { + for candidate in candidates do + match candidate with + | Result.Error e -> + yield Result.Error e + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let conflicts = + manifest.Dependencies + |> Seq.map toPackageConstraint + |> Seq.append (constraints |> Map.toSeq) + |> constraintsOf + |> findBadCores + |> Set + + if Set.isEmpty conflicts + then + yield candidate + else + yield Result.Error (TransitiveConflict conflicts) + () + () + } - yield! fetchCandidatesForConstraint sourceExplorer state.Locations package constraints - } + let depsFromPath p = + match p with + | Root m -> Set.union m.Dependencies m.PrivateDependencies + | Node (_, _, rv) -> rv.Manifest.Dependencies - let private printManifestInfo log (state: SolverState) (manifest:Manifest) = - let newDepCount = - manifest.Dependencies - |> Seq.filter(fun (x : Dependency) -> state.Constraints.ContainsKey x.Package |> not) - |> Seq.length - - if newDepCount > 0 then - log(("Manifest introduces " |> text) + - (manifest.Dependencies - |> Seq.filter(fun (x : Dependency) -> state.Constraints.ContainsKey x.Package |> not) - |> Seq.length - |> string - |> info) + - ((" new dependenc" + if newDepCount > 1 then "ies" else "y") |> text), LoggingLevel.Info) - - let private candidateToAtom (sourceExplorer : ISourceExplorer) (state: SolverState) (package, (location, versions)) = async { - let! packageLock = sourceExplorer.LockLocation location - return (package, (packageLock, versions)) - } - let private filterAtom state (package, (packageLock, _)) = ( - (Set.contains (package, packageLock) state.Visited |> not) && - (match state.Solution.Resolutions |> Map.tryFind package with - | Some (rv, _) -> rv.Lock = packageLock - | None -> true) - ) + while true do + let! req = inbox.Receive() + match req with + | ProposeCandidates (constraints, (p, cs), lockedPackages, channel) -> + lockedPackages + |> AsyncSeq.ofSeq + |> AsyncSeq.mapAsync(fun lp -> async { + try + let! manifest = sourceExplorer.FetchManifest (lp.Location, lp.Versions) + + let conflicts = + manifest.Dependencies + |> Set.map toPackageConstraint + |> constraintsOf + |> Map.insertWith Set.union p cs + |> findBadCores + |> Seq.map (Set.singleton >> TransitiveConflict) + + if conflicts |> Seq.isEmpty |> not + then + return Result.Error (NoManifest p) // TODO ... + else + let rv: ResolvedVersion = { + Manifest = manifest + Lock = lp.Location + Versions = lp.Versions + } + return Result.Ok rv + with _ -> + return Result.Error (NoManifest p) + }) + |> AsyncSeq.filter (fun x -> + match x with + | Result.Error _ -> false + | _ -> true + ) + |> AsyncSeq.takeWhile (fun _ -> + findBadCores constraints |> Seq.isEmpty + ) + |> channel.Reply + | GetCandidates (constraints, dep, locations, channel) -> + trackLocal locations dep constraints + |> trackGlobal constraints + |> channel.Reply + | MarkBadPath (path, failedDep, error, channel) -> + match error with + | TransitiveConflict conflicts -> + let unresolvables = + conflicts + |> Seq.choose (fun (_, e) -> + match e with + | Unresolvable (p, bs) -> Some (p, bs) + | _ -> None + ) + + for (p, bs) in unresolvables do + let contributions = + match world |> Map.tryFind failedDep with + | None -> + Set.empty + | Some buckets -> + buckets + |> Set.map(fun deps -> + deps + |> Seq.filter (fun (q, _) -> p = q) + |> Seq.map (fun (_, cs) -> cs) + |> Set.unionMany) + + for contrib in contributions do + let core = + path + |> Seq.filter (fun x -> + match x with + | Node (q, _, _) -> p <> q + | _ -> true) + |> Seq.map (depsFromPath >> + ( + fun deps -> + deps + |> Seq.map (fun x -> (x.Package, x.Constraint |> toDnf)) + |> Seq.filter (fun (q, cs) -> p = q && cs <> contrib) + |> Seq.map (fun (q, cs) -> (q, Set.intersect cs bs)) + |> Seq.map (fun (q, cs) -> (q, Set.difference cs contrib)) + |> Seq.filter (fun (_, cs) -> cs.IsEmpty |> not) + |> Set + ) + ) + |> Set.unionMany + |> Set.add failedDep + + unresolvableCores <- + unresolvableCores + |> Map.add core (SearchStrategyError.Unresolvable (p, bs)) + | _ -> () + + + channel.Reply () + }) + +let getHints (resolver: MailboxProcessor) state selections p cs = asyncSeq { + + let constraints = + selections + |> Map.valueList + |> Seq.map (fst >> (fun m -> m.Manifest.Dependencies)) + |> Seq.append [ state.Root ] + |> Seq.map (Set.map toPackageConstraint) + |> Set.unionMany + |> constraintsOf + + let c = All cs + let candidates = + state.Hints + |> Map.tryFind p + |> Option.defaultValue [] + |> Seq.filter (fun lp -> lp.Versions |> Constraint.satisfies c) + |> Seq.distinct + + let! request = + resolver.PostAndAsyncReply + (fun channel -> + ProposeCandidates (constraints, (p, cs), candidates, channel)) + + yield! request +} + +let fetchHints (sourceExplorer : ISourceExplorer) (state: SolverState) (resolvedVersion : ResolvedVersion) : Async = async { + try + let! lock = + sourceExplorer.FetchLock + (resolvedVersion.Lock, resolvedVersion.Versions) - let unlock (solution : Solution) (packages : Set) : Solution = { - Resolutions = - solution.Resolutions - |> Map.toSeq - |> Seq.filter (fst >> packages.Contains >> not) - |> Map.ofSeq - } + let hints = + Seq.append + (state.Hints |> Map.toSeq) + (lock.Packages + |> Map.toSeq + |> Seq.map (fun (k, v) -> (k, [v]))) + |> Seq.groupBy fst + |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> List.concat)) + |> Map.ofSeq - let private recoverOrFail atom state log resolutions = - resolutions - |> AsyncSeq.map (fun resolution -> - match resolution with - | Resolution.Backtrack (s, f) -> - log("trying to recover from: " + f.ToString() + " [" + atom.ToString() + "]" |> text, LoggingLevel.Info) - if state.Constraints.ContainsKey f.Package && - match f.Constraint with - | All xs -> xs |> List.forall state.Constraints.[f.Package].Contains - | x -> state.Constraints.[f.Package].Contains x - then resolution - else - log("Trying different resolution to workaround: " + f.ToString() |> text, LoggingLevel.Info) - Resolution.Avoid (s, f) - | x -> x - ) - |> AsyncSeq.takeWhileInclusive (fun resolution -> - match resolution with - | Resolution.Backtrack (_, f) -> - log("Backtracking due to failure " + f.ToString() |> text, LoggingLevel.Debug) - false - | _ -> true - ) - - let private mergeConstraints c1 c2 = - c2 - |> Seq.fold - (fun m (dep : Dependency) -> - Map.insertWith - Set.union - dep.Package - (Set[dep.Constraint]) - m) - c1 - - let private updateState (package, packageLock) (freshHints) (manifest: Manifest) (state: SolverState) = - let mergedLocations = - match mergeLocations state.Locations manifest.Locations with - | Result.Ok xs -> xs - | Result.Error e -> raise (new System.Exception(e.ToString())) - - let nextConstraints = mergeConstraints state.Constraints manifest.Dependencies - - {state with - Constraints = nextConstraints - Visited = - state.Visited - |> Set.add (package, packageLock); - Locations = mergedLocations; - Hints = - state.Hints - |> AsyncSeq.append freshHints - } + return { + state with Hints = hints + } + with _ -> + return state +} + +let collectPrivateHints (state : SolverState) (p : PackageIdentifier) = + state.Hints + |> Map.tryFind p + |> Option.defaultValue [] + |> Seq.map (fun l -> l.PrivatePackages |> Map.toSeq) + |> Seq.collect id + |> Seq.groupBy fst + |> Seq.map (fun (k, vs) -> (k, vs |> Seq.map snd |> Seq.distinct |> Seq.map List.singleton |> List.concat)) + |> Map.ofSeq + +let getCandidates (resolver: MailboxProcessor) (sourceExplorer: ISourceExplorer) state selections p cs = asyncSeq { + + let constraints = + selections + |> Map.valueList + |> Seq.map (fst >> (fun m -> m.Manifest.Dependencies)) + |> Seq.append [ state.Root ] + |> Seq.map (Set.map toPackageConstraint) + |> Set.unionMany + |> constraintsOf + + let manifests = + selections + |> Map.valueList + |> Seq.map (fst >> (fun rv -> rv.Manifest)) + |> Seq.toList - let private unlockConflicts (state: SolverState) = + let locations = + manifests + |> Seq.map (fun m -> m.Locations |> Map.toSeq) + |> Seq.fold Seq.append (state.Locations |> Map.toSeq) + |> Map.ofSeq - let conflicts = - findConflicts state.Solution state.Constraints - |> Set.ofSeq + let! requested = + resolver.PostAndAsyncReply + (fun channel -> + GetCandidates (constraints, (p, cs), locations, channel)) - { - state with - Solution = unlock state.Solution conflicts - } + yield! + requested + |> AsyncSeq.mapAsync(fun candidate -> async { + match candidate with + | Result.Error e -> + return Result.Error e + | Result.Ok (_, (location, versions)) -> + let! lock = sourceExplorer.LockLocation location + let! manifest = sourceExplorer.FetchManifest (lock, versions) + let resolvedVersion = { + Lock = lock + Versions = versions + Manifest = manifest + } - let private addPrivatePackageSolution state package resolvedVersion solution = - { - state with - Solution = { - state.Solution with - Resolutions = - state.Solution.Resolutions - |> Map.add package (resolvedVersion, solution) - }} - - let private getHintsFromLockTask log state package lockTask = asyncSeq { - try - log( (text "Fetching lock-file for ") + (PackageIdentifier.showRich package) + "...", LoggingLevel.Debug) - let! lock = lockTask - log( (success "success ") + (text "Fetched the lock-file for ") + (PackageIdentifier.showRich package), LoggingLevel.Info) - yield! - lock - |> lockToHints - |> Seq.filter (fun (atom, packageLock) -> - Set.contains (atom.Package, packageLock) state.Visited |> not && - state.Solution.Resolutions |> Map.containsKey atom.Package |> not) - |> AsyncSeq.ofSeq - with error -> - log(string error|>text, LoggingLevel.Debug) - () + return Result.Ok resolvedVersion + }) + |> AsyncSeq.distinctUntilChangedWith (fun prev next -> + match prev, next with + | (Result.Ok p), (Result.Ok n) -> + p.Manifest = n.Manifest // All revisions with an identical manifest will have the same outcome + | (_, _) -> prev = next + ) +} + +let zipState state clause = + Result.map (fun candidate -> (clause, state, candidate)) + >> Result.mapError(fun e -> (clause, e)) + +let mergeHint sourceExplorer next = async { + match next with + | Result.Ok (clause, state, rv) -> + let! nextState = fetchHints sourceExplorer state rv + return Result.Ok (clause, nextState, rv) + | Result.Error e -> return Result.Error e +} + +let quickStrategy resolver sourceExplorer state selections = asyncSeq { + let unresolved = + breadthFirst selections state.Root + |> Seq.sortByDescending (snd >> All >> simplify >> Constraint.chanceOfSuccess) + + for (p, cs) in unresolved do + yield! + (AsyncSeq.append + (getHints resolver state selections p cs) + (getCandidates resolver sourceExplorer state selections p cs)) + |> AsyncSeq.map (zipState state (p, cs)) + |> AsyncSeq.mapAsync (mergeHint sourceExplorer) +} + +let upgradeStrategy resolver sourceExplorer state selections = asyncSeq { + let unresolved = + breadthFirst selections state.Root + |> Seq.sortByDescending (snd >> All >> simplify >> Constraint.chanceOfSuccess) + + for (p, cs) in unresolved do + yield! + getCandidates resolver sourceExplorer state selections p cs + |> AsyncSeq.map (zipState state (p, cs)) +} + +let private privateStep step ((p, _), state, rv) = + let m = rv.Manifest + let privateState : SolverState = { + Hints = collectPrivateHints state p + Root = m.PrivateDependencies + Locations = state.Locations + Selections = Map.empty } + (step privateState [ Root m ]) + |> AsyncSeq.choose ifOk + |> AsyncSeq.tryFirst - let private solvePrivate solver state dependencies = - let privatePackagesSolverState = { - Solution = Solution.empty - Locations = Map.empty - Visited = Set.empty - Hints = state.Hints - Depth = state.Depth + 1 - Constraints = constraintsOf dependencies - Failures = state.Failures - } +let rec private step (context : TaskContext) (resolver : MailboxProcessor) (prefetcher : Prefetcher) strategy (state : SolverState) (path: List): AsyncSeq> = asyncSeq { + let logger = createLogger context.Console (Some "solver") + let nextStep = step context resolver prefetcher strategy - solver - privatePackagesSolverState - |> AsyncSeq.choose (fun resolution -> - match resolution with - | Resolution.Ok solution -> Some solution - | _ -> None - ) + let selections = pruneSelections state.Selections state.Root - let rec private step (context : TaskContext) (strategy : SearchStrategy) (state : SolverState) : AsyncSeq = asyncSeq { + if breadthFirst selections state.Root |> Seq.isEmpty + then + yield Result.Ok { Resolutions = selections } + else + let results = + asyncSeq { + let xs : AsyncSeq> = strategy state selections - let sourceExplorer = context.SourceExplorer - let log = namespacedLogger context.Console ("solver") + for x in xs do + match x with + | Result.Ok ((p, cs), state, rv) -> + if path |> List.contains (Node (p, cs, rv)) |> not + then + logger.Info ( + "Trying " + (PackageIdentifier.show p) + " at " + + (rv.Versions |> Seq.map Version.show |> String.concat ", ")) + + for p in rv.Manifest.Dependencies |> Seq.map (fun d -> d.Package) |> Seq.distinct do + prefetcher.Prefetch p + + let! privateSolution = privateStep nextStep ((p, cs), state, rv) + + match privateSolution with + | None -> + yield Result.Error ((p, cs), NoPrivateSolution p) // TODO: propagate error + | Some ps -> + let node = Node (p, cs, rv) + let nextState = { + state with + Selections = selections |> Map.add p (rv, ps) + } + yield! nextStep nextState (node :: path) + | Result.Error e -> yield Result.Error e + } + |> AsyncSeq.cache + + yield! results + + // Record bad path when no solution is found + let! solution = + results + |> AsyncSeq.choose ifOk + |> AsyncSeq.tryFirst + + match solution with + | Some _ -> () + | None -> + let errors = + results + |> AsyncSeq.choose ifError + |> AsyncSeq.distinctUntilChanged + + for ((p, cs), error) in errors do + context.Console.Write(string error, LoggingLevel.Trace) + do! resolver.PostAndAsyncReply (fun ch -> MarkBadPath (path, (p, cs), error, ch)) +} + +let solutionCollector resolutions = async { + let! xs = + resolutions + |> AsyncSeq.take 2048 + |> AsyncSeq.takeWhileInclusive (Result.isOk >> not) + |> AsyncSeq.toListAsync - let unsatisfied = - findUnsatisfied state.Solution state.Constraints - |> Seq.toList + return + xs + |> List.tryLast + |> Option.defaultValue (Result.Error (TransitiveConflict Set.empty)) +} - let unsatisfiables = - unsatisfied - |> Seq.filter (fun u -> - let allConstraints = state.Constraints.[u] - let badConstraints = state.Failures |> Map.findOrDefault u (Set[]) +let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manifest) (style : ResolutionStyle) (lock : Lock option) = async { + let hints = + lock + |> Option.map (fun l -> l.Packages |> (Map.map (fun _ v -> [ v ]))) + |> Option.defaultValue Map.empty - Set.intersect - allConstraints - badConstraints - |> Set.isEmpty |> not) + let state = { + Root = Set.union + manifest.Dependencies + manifest.PrivateDependencies + Hints = hints + Selections = partialSolution.Resolutions + Locations = manifest.Locations + } - if Seq.isEmpty unsatisfiables |> not - then () - elif Seq.isEmpty unsatisfied - then - yield Resolution.Ok state.Solution - else - let totalDeps = state.Constraints |> Map.count - let satisfiedDepsCount = totalDeps - (unsatisfied |> Seq.length) - - log( ("Resolved " |> text) + - (satisfiedDepsCount.ToString() |> highlight) + - (subtle "/") + - (totalDeps.ToString() |> highlight), - LoggingLevel.Info) - - let atomsToExplore = - strategy sourceExplorer state - |> AsyncSeq.mapAsync (fun x -> - match x with - | Result.Ok candidate -> - candidate - |> candidateToAtom sourceExplorer state - |> fun x -> async { - let! result = x; - return Result.Ok result; } - | Result.Error e -> async { return Result.Error e } - ) - |> AsyncSeq.filter (fun x -> - match x with - | Result.Ok atom -> filterAtom state atom - | _ -> true) - - let rec loop state atoms = asyncSeq { - let! atom = atoms |> AsyncSeq.tryFirst - match atom with - | None -> () - | Some (Result.Error (NotSatisfiable e)) -> - log("failed to retrive valid version for:" + e.ToString() |> text, LoggingLevel.Info) - yield Resolution.Backtrack (state.Solution, e) - | Some(Result.Ok (package, (packageLock, versions))) -> - log(("Exploring " |> text) + (PackageIdentifier.showRich package) + "...", LoggingLevel.Info) - - // We pre-emptively grab the lock - let! lockTask = - sourceExplorer.FetchLock (packageLock, versions) - |> Async.StartChild - - log("Fetching manifest..." |> text, LoggingLevel.Info) - let manifestFetchStart = System.DateTime.Now - let! manifest = sourceExplorer.FetchManifest (packageLock, versions) - let manifestFetchEnd = System.DateTime.Now - log((success "success ") + - ("Manifest fetched in " |> text) + - (info ((manifestFetchEnd - manifestFetchStart).TotalSeconds.ToString("N3") + "s")), - LoggingLevel.Info) - printManifestInfo log state manifest - - let versionSetStr = - packageLock - |> PackageLock.toLocation - |> PackageLocation.versionSetFromLocation - |> Set.union versions - |> Version.showRichSet - - log ( (success "success ") + (text "Resolved ") + (PackageIdentifier.showRich package) + (subtle " -> ") + versionSetStr, LoggingLevel.Info) - - let resolvedVersion = { - Versions = versions; - Lock = packageLock; - Manifest = manifest; - } + let resolver = resolutionManager context - let freshHints = lockTask |> getHintsFromLockTask log state package - - let privatePackagesSolutions = - solvePrivate - (step context strategy) - state - manifest.PrivateDependencies - - let newState = - state - |> updateState (package, packageLock) freshHints manifest - |> unlockConflicts - - let resolutions = - privatePackagesSolutions - |> AsyncSeq.map(addPrivatePackageSolution newState package resolvedVersion) - |> AsyncSeq.collect (step context strategy) - |> recoverOrFail (packageLock, versions) newState log - |> recoverOrFail (packageLock, versions) state log - |> AsyncSeq.scan - (fun (failures, _) resolution -> - match resolution with - | Resolution.Avoid (_, f) -> - ((failures - |> Map.insertWith - Set.union f.Package - (Set[f.Constraint])), - resolution) - | _ -> (failures, resolution)) - (newState.Failures, Resolution.Ok newState.Solution) - |> AsyncSeq.skip 1 - |> AsyncSeq.cache - - yield! resolutions |> AsyncSeq.map snd - - let! maybeLastState = AsyncSeq.tryLast resolutions - match maybeLastState with - | None -> () - | Some (_, Backtrack _) -> () - | Some (failures, _) -> - yield! loop {state with Failures = failures} (atoms |> AsyncSeq.skip 1) - } + let prefetcher = Prefetcher (context.SourceExplorer, 10) - // here we start the loop - yield! loop state atomsToExplore - } + let strategy = + match style with + | Quick -> quickStrategy resolver context.SourceExplorer + | Upgrading -> upgradeStrategy resolver context.SourceExplorer - let solutionCollector resolutions = - resolutions - |> AsyncSeq.take (1024) - |> AsyncSeq.takeWhileInclusive (fun x -> - match x with - | Backtrack _ -> false - | _ -> true) - |> AsyncSeq.filter (fun x -> - match x with - | Ok _ -> true - | Backtrack _ -> true - | _ -> false) - |> AsyncSeq.take 1 - |> AsyncSeq.toListAsync - |> Async.RunSynchronously - |> List.tryHead + let resolutions = + step context resolver prefetcher strategy state [ Root manifest ] - let solve (context : TaskContext) (partialSolution : Solution) (manifest : Manifest) (style : ResolutionStyle) (lock : Lock option) = async { - let hints = - lock - |> Option.map (lockToHints >> AsyncSeq.ofSeq) - |> Option.defaultValue AsyncSeq.empty - - let strategy = - match style with - | Quick -> quickSearchStrategy - | Upgrading -> upgradeSearchStrategy - - let state = { - Solution = partialSolution; - Constraints = - Set.unionMany [ manifest.Dependencies; manifest.PrivateDependencies ] - |> constraintsOf - Depth = 0; - Visited = Set.empty; - Locations = manifest.Locations; - Hints = hints; - Failures = Map.empty - } + let! result = + resolutions + |> AsyncSeq.map (Result.mapError snd) + |> solutionCollector - let resolutions = - step context strategy state + context.Console.Write(string result, LoggingLevel.Trace) - let result = - resolutions - |> solutionCollector - |> Option.defaultValue (Set.empty |> Resolution.Conflict) + return result +} - context.Console.Write(string result, LoggingLevel.Trace) +let rec fromLock (sourceExplorer : ISourceExplorer) (lock : Lock) : Async = async { + let rec packageLockToSolution (locked : LockedPackage) : Async = async { + let! manifest = sourceExplorer.FetchManifest (locked.Location, locked.Versions) + let! resolutions = + locked.PrivatePackages + |> Map.toSeq + |> AsyncSeq.ofSeq + |> AsyncSeq.mapAsync (fun (k, lock) -> async { + let! solution = packageLockToSolution lock + return (k, solution) + }) + |> AsyncSeq.toListAsync + + let resolvedVersion : ResolvedVersion = { + Versions = locked.Versions; + Lock = locked.Location; + Manifest = manifest; + } - return result + return (resolvedVersion, { Resolutions = resolutions |> Map.ofSeq }) } + let! resolutions = + lock.Packages + |> Map.toSeq + |> AsyncSeq.ofSeq + |> AsyncSeq.mapAsync(fun (package, lockedPakckage) -> async { + let! solution = lockedPakckage |> packageLockToSolution + return (package, solution) + }) + |> AsyncSeq.toListAsync - let rec fromLock (sourceExplorer : ISourceExplorer) (lock : Lock) : Async = async { - let rec packageLockToSolution (locked : LockedPackage) : Async = async { - let! manifest = sourceExplorer.FetchManifest (locked.Location, locked.Versions) - let! resolutions = - locked.PrivatePackages - |> Map.toSeq - |> AsyncSeq.ofSeq - |> AsyncSeq.mapAsync (fun (k, lock) -> async { - let! solution = packageLockToSolution lock - return (k, solution) - }) - |> AsyncSeq.toListAsync - - let resolvedVersion : ResolvedVersion = { - Versions = locked.Versions; - Lock = locked.Location; - Manifest = manifest; - } - - return (resolvedVersion, { Resolutions = resolutions |> Map.ofSeq }) - } + return { + Resolutions = resolutions |> Map.ofSeq + } +} - let! resolutions = - lock.Packages +let unlock (solution : Solution) (packages : Set) : Solution = { + Resolutions = + solution.Resolutions |> Map.toSeq - |> AsyncSeq.ofSeq - |> AsyncSeq.mapAsync(fun (package, lockedPakckage) -> async { - let! solution = lockedPakckage |> packageLockToSolution - return (package, solution) - }) - |> AsyncSeq.toListAsync - - return { - Resolutions = resolutions |> Map.ofSeq - } - } + |> Seq.filter (fst >> packages.Contains >> not) + |> Map.ofSeq +} diff --git a/buckaroo/SourceExplorer.fs b/buckaroo/SourceExplorer.fs index f0d0769..8e46fcd 100644 --- a/buckaroo/SourceExplorer.fs +++ b/buckaroo/SourceExplorer.fs @@ -53,7 +53,7 @@ module SourceExplorer = |> AsyncSeq.fold (fun s x -> Set.add x s) Set.empty yield! - loop (Constraint.All []) + loop (Constraint.All Set.empty) |> AsyncSeq.filter (fun x -> match x with | Candidate (location, _) -> @@ -65,7 +65,7 @@ module SourceExplorer = | Any xs -> yield! xs - |> List.distinct + |> Set.toList |> List.sortDescending |> List.map loop |> AsyncSeq.mergeAll @@ -103,7 +103,7 @@ module SourceExplorer = ) else xs - |> List.distinct + |> Set.toList |> List.sort |> List.map (loop >> (AsyncSeq.scan (fun s x -> Set.add x s) Set.empty)) |> List.reduce (AsyncSeq.combineLatestWith (fun x y -> diff --git a/buckaroo/Tasks.fs b/buckaroo/Tasks.fs index c3bf969..7f6d24b 100644 --- a/buckaroo/Tasks.fs +++ b/buckaroo/Tasks.fs @@ -30,11 +30,11 @@ let private getCachePath = async { | path -> path } -let getContext loggingLevel = async { - let consoleManager = new ConsoleManager(loggingLevel) +let getContext loggingLevel fetchStyle = async { + let consoleManager = ConsoleManager(loggingLevel) let! cachePath = getCachePath - let downloadManager = new DownloadManager(consoleManager, cachePath) + let downloadManager = DownloadManager(consoleManager, cachePath) let! hasGit = Bash.runBashSync "git" "version" ignore ignore @@ -53,7 +53,7 @@ let getContext loggingLevel = async { then GitLib(consoleManager) :> IGit else GitCli(consoleManager) :> IGit - let gitManager = GitManager(consoleManager, git, cachePath) + let gitManager = GitManager(fetchStyle, consoleManager, git, cachePath) let sourceExplorer = DefaultSourceExplorer(consoleManager, downloadManager, gitManager) return { @@ -92,9 +92,9 @@ let readLock = async { match Lock.parse content with | Result.Ok lock -> lock | Result.Error error -> - new Exception("Error reading lock file. " + error) |> raise + Exception("Error reading lock file. " + error) |> raise else - return new Exception("No lock file was found. Perhaps you need to run 'buckaroo resolve'?") |> raise + return Exception("No lock file was found. Perhaps you need to run 'buckaroo resolve'?") |> raise } let readLockIfPresent = async { diff --git a/buckaroo/UpgradeCommand.fs b/buckaroo/UpgradeCommand.fs index 0ef8fe5..94e8575 100644 --- a/buckaroo/UpgradeCommand.fs +++ b/buckaroo/UpgradeCommand.fs @@ -5,60 +5,52 @@ open System.IO open Buckaroo open Buckaroo.Tasks open Buckaroo.RichOutput +open Buckaroo.Logger +open Buckaroo let task context (packages : List) = async { + let logger = createLogger context.Console None + if Seq.isEmpty packages then - context.Console.Write ( - ( - "info " - |> text - |> foreground ConsoleColor.Blue - ) + - "Upgrading all packages... " - ) + logger.Info "Upgrading all packages... " else - context.Console.Write ( - ( - "info " - |> text - |> foreground ConsoleColor.Blue - ) + - "Upgrading [ " + (packages |> Seq.map PackageIdentifier.show |> String.concat " ") + " ]... " - ) - - if File.Exists (Constants.LockFileName) - then - let! lock = Tasks.readLock - let! partial = - if packages |> Seq.isEmpty - then async { return Solution.empty } + logger.Info + <| "Upgrading [ " + (packages |> Seq.map PackageIdentifier.show |> String.concat " ") + " ]... " + + let extractPartialSolution = + async { + if File.Exists (Constants.LockFileName) + then + let! lock = Tasks.readLock + let! partial = + if packages |> Seq.isEmpty + then async { return Solution.empty } + else + async { + let! solution = Solver.fromLock context.SourceExplorer lock + + return solution + } + + return partial else - async { - let! solution = Solver.fromLock context.SourceExplorer lock + logger.Warning + "There is no lock-file to upgrade. A fresh lock-file will be generated. " - return - packages - |> Set.ofList - |> Solver.unlock solution - } + return Solution.empty + } - do! ResolveCommand.task context partial ResolutionStyle.Upgrading - do! InstallCommand.task context + let! partial = extractPartialSolution - return () - else - context.Console.Write ( - ( - "warning " - |> text - |> foreground ConsoleColor.Yellow - ) + - "There is no lock-file to upgrade. A fresh lock-file will be generated. " - ) + let! resolveSucceeded = + ResolveCommand.task context partial ResolutionStyle.Upgrading - do! ResolveCommand.task context Solution.empty ResolutionStyle.Upgrading + if resolveSucceeded + then do! InstallCommand.task context + else + logger.Error "The upgrade failed. No packages were changed. " - return () + return () } \ No newline at end of file diff --git a/buckaroo/buckaroo.fsproj b/buckaroo/buckaroo.fsproj index 77d6f55..9172b2c 100644 --- a/buckaroo/buckaroo.fsproj +++ b/buckaroo/buckaroo.fsproj @@ -20,6 +20,7 @@ + @@ -43,6 +44,8 @@ + +