Merge pull request #248 from LoopPerfect/feat/better-output

Feat/better output

Author: nikhedonia

buckaroo-tests/Solver.fs

@@ -121,11 +121,11 @@ type TestingSourceExplorer (cookBook : CookBook, lockBook : LockBook) =
 
 let solve (cookBook : CookBook) (lockBookEntries : LockBookEntries) root style =
     let lockBook = lockBookOf lockBookEntries
-    let console = new ConsoleManager(LoggingLevel.Debug);
+    let console = new ConsoleManager(LoggingLevel.Silent);
     let context : TaskContext = {
       Console = console;
       DownloadManager = DownloadManager(console, "/tmp");
-      GitManager = new GitManager(new GitCli(console), "/tmp");
+      GitManager = new GitManager(console, new GitCli(console), "/tmp");
       SourceExplorer = TestingSourceExplorer(cookBook, lockBook)
     }
 

buckaroo/ConsoleManager.fs

@@ -3,41 +3,11 @@ module Buckaroo.Console
 open System
 open Buckaroo.RichOutput
 
-[<CustomComparison>]
-[<CustomEquality>]
 type LoggingLevel =
-  | Trace
-  | Debug
-  | Info
-
-  override this.Equals (obj) =
-    match obj with
-    | :? LoggingLevel as other ->
-      match (this, other) with
-      | (Trace, Trace) -> true
-      | (Debug, Debug) -> true
-      | (Info, Info) -> true
-      | _ -> false
-    | _ -> false
-
-  override this.GetHashCode () =
-    match this with
-    | Trace -> 0
-    | Debug -> 1
-    | Info -> 2
-
-  interface IComparable with
-    override this.CompareTo obj =
-      let score x =
-        match x with
-        | Trace -> 0
-        | Debug -> 1
-        | Info -> 2
-
-      match obj with
-      | :? LoggingLevel as other -> (score this) - (score other)
-      | _ -> 0
-
+| Trace
+| Debug
+| Info
+| Silent
 
 type OutputCategory =
 | Normal
@@ -97,7 +67,6 @@ type ConsoleManager (minimumLoggingLevel : LoggingLevel) =
       let! message = inbox.Receive()
       match message with
       | Output (m, l, c) ->
-        // TODO: Respect minimum logging level
         if l >= minimumLoggingLevel
         then
           match c with
@@ -106,11 +75,12 @@ type ConsoleManager (minimumLoggingLevel : LoggingLevel) =
           | Error -> Console.Error.WriteLine(m)
         ()
       | RichOutput (m, l, c) ->
-        // TODO: Respect minimum logging level
-        match c with
-        | Normal -> renderRichOutput m
-        | Warning -> renderRichOutput m
-        | Error -> renderRichOutput m
+        if l >= minimumLoggingLevel
+        then
+          match c with
+          | Normal -> renderRichOutput m
+          | Warning -> renderRichOutput m
+          | Error -> renderRichOutput m
         ()
       | Input channel ->
         let response = Console.ReadLine()
@@ -151,3 +121,11 @@ type ConsoleManager (minimumLoggingLevel : LoggingLevel) =
 
   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)

buckaroo/DefaultSourceExplorer.fs

@@ -3,15 +3,17 @@ namespace Buckaroo
 open FSharp.Control
 open Buckaroo.Console
 open FSharpx
+open RichOutput
 
 type DefaultSourceExplorer (console : ConsoleManager, downloadManager : DownloadManager, gitManager : GitManager) =
+  let log = namespacedLogger console "explorer"
   let toOptional = Async.Catch >> (Async.map Choice.toOption)
 
-  let fromCache url revision path =
+  let fromFileCache url revision path =
     gitManager.FetchFile url revision path |> toOptional
 
-  let cacheOrGit (f: string->string->Async<string>, url:string, rev:string, path: string) = async {
-    let! cached = fromCache url rev path
+  let cacheOrGit (f: string->string->Async<string>, url : string, rev : string, path : string) = async {
+    let! cached = fromFileCache url rev path
     match cached with
     | Some data -> return data
     | None -> return! f rev path
@@ -143,7 +145,6 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download
 
   let fetchVersionsFromGit gitUrl = asyncSeq {
     let! refs = gitManager.FetchRefs gitUrl
-
     // Sem-vers
     yield!
       refs
@@ -306,11 +307,20 @@ type DefaultSourceExplorer (console : ConsoleManager, downloadManager : Download
 
     member this.FetchLock location =
       async {
-        let! content = fetchFile location Constants.LockFileName
+        let! maybeContent = fetchFile location Constants.LockFileName |> Async.Catch |> Async.map(Choice.toOption)
         return
-          match Lock.parse content with
-          | Result.Ok manifest -> manifest
-          | Result.Error errorMessage ->
-            new System.Exception("Invalid " + Constants.LockFileName + " file. \n" + errorMessage)
-            |> raise
+          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")
+          | 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
       }

buckaroo/GitCli.fs

@@ -3,8 +3,12 @@ namespace Buckaroo
 open System
 open System.Text
 open Buckaroo.Console
+open RichOutput
 
 type GitCli (console : ConsoleManager) =
+
+  let log = namespacedLogger console "git"
+
   let nl = System.Environment.NewLine
   let runBash command = async {
     let rt =
@@ -105,6 +109,7 @@ type GitCli (console : ConsoleManager) =
     }
 
     member this.ShallowClone (url : String) (directory : string) = async {
+      log((text "shallow cloning ") + (highlight url), LoggingLevel.Info)
       do!
         runBash ("git clone --bare --depth=1 " + url + " " + directory)
         |> Async.Ignore

buckaroo/GitManager.fs

@@ -7,11 +7,15 @@ open System.Text.RegularExpressions
 open FSharpx.Control
 open FSharp.Control
 open FSharpx
+open Console
+open RichOutput
 
 type CloneRequest =
 | CloneRequest of string * AsyncReplyChannel<Async<string>>
 
-type GitManager (git : IGit, cacheDirectory : string) =
+type GitManager (console : ConsoleManager, git : IGit, cacheDirectory : string) =
+
+  let log = namespacedLogger console "git"
 
   let mutable refsCache = Map.empty
 
@@ -37,7 +41,7 @@ type GitManager (git : IGit, cacheDirectory : string) =
     let folder = sanitizeFilename(url).ToLower() + "-" + hash.Substring(0, 16)
     Path.Combine(cacheDirectory, folder)
 
-  let mailboxProcessor = MailboxProcessor.Start(fun inbox -> async {
+  let mailboxCloneProcessor = MailboxProcessor.Start(fun inbox -> async {
     let mutable cloneCache : Map<string, Async<string>> = Map.empty
     while true do
       let! message = inbox.Receive()
@@ -63,11 +67,11 @@ type GitManager (git : IGit, cacheDirectory : string) =
     return! this.DefaultBranch targetDirectory
   }
   member this.Clone (url : string) : Async<string> = async {
-    let! res = mailboxProcessor.PostAndAsyncReply(fun ch -> CloneRequest(url, ch))
+    let! res = mailboxCloneProcessor.PostAndAsyncReply(fun ch -> CloneRequest(url, ch))
     return! res
   }
 
-  member this.CopyFromCache  (gitUrl : string) (revision : Revision) (installPath : string) : Async<Unit> = async {
+  member this.CopyFromCache (gitUrl : string) (revision : Revision) (installPath : string) : Async<Unit> = async {
     let! hasGit = Files.directoryExists (Path.Combine (installPath, ".git/"))
     if hasGit then
       do! git.Unshallow installPath
@@ -116,7 +120,9 @@ type GitManager (git : IGit, cacheDirectory : string) =
     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
           (
@@ -135,6 +141,12 @@ type GitManager (git : IGit, cacheDirectory : string) =
           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
   }
   member this.FetchFile (url : string) (revision : Revision) (file : string) : Async<string> =

buckaroo/PackageIdentifier.fs

@@ -20,18 +20,17 @@ module PackageIdentifier =
     | GitLab x -> "gitlab.com/" + x.Owner + "/" + x.Project
     | Adhoc x -> x.Owner + "/" + x.Project
 
-  let showRich (id : PackageIdentifier) = 
-    let host = text >> (foreground System.ConsoleColor.Magenta)
-    let owner = text >> (foreground System.ConsoleColor.Cyan)
-    let project = text >> (foreground System.ConsoleColor.Green)
-    let subtle = text >> (foreground System.ConsoleColor.DarkGray)
+  let showRich (id : PackageIdentifier) =
+    let host = highlight
+    let owner = highlight
+    let project = highlight
 
     match id with
     | GitHub x -> (host "github.com") + (subtle "/") + (owner x.Owner) + (subtle "/") + (project x.Project)
     | BitBucket x -> (host "bitbucket.org") + (subtle "/") + x.Owner + (subtle "/") + (project x.Project)
     | GitLab x -> (host "gitlab.com") + (subtle "/") + x.Owner + (subtle "/") + (project x.Project)
     | Adhoc x -> (owner x.Owner) + (subtle "/") + (project x.Project)
-  
+
   let private gitHubIdentifierParser =
     CharParsers.regex @"[a-zA-Z.\d](?:[a-zA-Z_.\d]|-(?=[a-zA-Z_.\d])){0,38}"