Improve JSON encode decode roundtripping, support gauge

- Improves #410

RELEASE_NOTES.md

@@ -1,3 +1,7 @@
+#### 5.0.0-rc.9
+* BREAKING: move Logary.Message.Patterns to Logary.MessagePatterns, thanks @haf
+* Roundtripping JSON encode/decode, thanks @haf
+
 #### 5.0.0-rc.8
 * Prometheus Support 🎉, thanks @lust4life
 * Google Pub/Sub support 🎊, thanks @haf

src/Logary.Tests/Json.fs

@@ -1,7 +1,6 @@
 module Logary.Tests.Json
 
 open System
-open System.Globalization
 open Logary
 open Logary.Internals.Chiron
 open Logary.Formatting
@@ -112,6 +111,40 @@ let testEncode<'a> fsCheckConfig =
 let ptestEncode<'a> fsCheckConfig =
   ptestPropertyWithConfig fsCheckConfig typeof<'a>.Name (fun (a: 'a) -> Json.encode a |> ignore)
 
+let testRoundtrip<'a when 'a : equality> fsCheckConfig (decoder: JsonDecoder<'a>) =
+  testPropertyWithConfig fsCheckConfig typeof<'a>.Name (fun (a: 'a) ->
+    let encoded = Json.encode a
+    try
+      encoded
+        |> decoder
+        |> JsonResult.getOrThrow
+        |> Expect.equal "Should eq to input" a
+    with _ ->
+      printfn "Encoded %A" encoded
+      reraise()
+    )
+
+module Expect =
+  module Message =
+    let equal (message: string) (expected: Message) (actual: Message) =
+      actual.name
+        |> Expect.equal "name" expected.name
+      actual.level
+        |> Expect.equal "level" expected.level
+      actual.timestamp
+        |> Expect.equal "timestamp" expected.timestamp
+      actual.value
+        |> Expect.equal "value" expected.value
+
+      for KeyValue (k, v) in actual.context do
+        match expected.context |> HashMap.tryFind k with
+        | None ->
+          failtestf "Failed to find key %s in actual's Message.context" k
+        | Some v ->
+          v |> Expect.equal "value" v
+
+      ()
+
 let tests fsc =
   testList "json" [
     testCase "accessing .context" <| fun () ->
@@ -158,7 +191,7 @@ let tests fsc =
           Logary.LogLevel.Debug
             |> Json.encode
             |> Expect.equal "Encodes to 'debug'" (String "debug")
-            
+
         testCase "FSharpFunc" <| fun () ->
           let example = fun (a: int) (b: float) -> float a * b
           match Json.encode example with
@@ -232,9 +265,8 @@ let tests fsc =
 
     testList "decoding" [
       testCase "message" <| fun () ->
-        match Json.parse jsonRawInput |> JsonResult.bind Json.decodeMessage with
+        match Json.parse jsonRawInput |> JsonResult.bind Json.Decode.message with
         | JPass m ->
-          let m = m.[0]
           DateTimeOffset.ofEpoch m.timestamp
             |> Expect.equal "Should have timestamp from 'timestamp' prop in JSON"
                             (DateTimeOffset.Parse("2018-03-19T15:33:40Z"))
@@ -244,7 +276,7 @@ let tests fsc =
       testCase "message crash (regression)" <| fun () ->
         let res =
           Json.parse jsonInputCrash
-            |> JsonResult.bind Json.decodeMessage
+            |> JsonResult.bind Json.Decode.messageBatch
             |> JsonResult.getOrThrow
         res |> Expect.isNonEmpty "Should have message values"
 
@@ -324,7 +356,7 @@ let tests fsc =
       ]
 
       testCase "simplest possible batch JSON" <| fun () ->
-        match Json.parse jsonBatch |> JsonResult.bind Json.decodeMessage with
+        match Json.parse jsonBatch |> JsonResult.bind Json.Decode.messageBatch with
         | JPass ms ->
           let m = ms.[0]
           m.name.isEmpty
@@ -346,21 +378,23 @@ let tests fsc =
 
         | JFail err ->
           failtestf "Parse failure %A" err
-          
+
       testList "fields and context" [
         let sample = """{"message":"Hi {user}", "context":{"app":"native"}, "fields": {"user":"haf"}, "lastly": true, "myObj": {"isProp":"nested"} }"""
         let subject =
           Json.parse sample
-            |> JsonResult.bind Json.decodeMessage
+            |> JsonResult.bind Json.Decode.message
             |> JsonResult.getOrThrow
-            |> Array.head
 
         yield testCase "field" <| fun () ->
           subject |> Message.tryGetField "user" |> Expect.equal "Field equals" (Some "haf")
+
         yield testCase "context" <| fun () ->
           subject |> Message.tryGetContext "app" |> Expect.equal "Field equals" (Some "native")
+
         yield testCase "field from outside" <| fun () ->
           subject |> Message.tryGetField "lastly" |> Expect.equal "Should have a true value" (Some true)
+
         yield testCase "nested obj from outside" <| fun () ->
           let expected = HashMap.empty |> HashMap.add "isProp" (box "nested") |> HashMap.toList
           subject
@@ -370,5 +404,35 @@ let tests fsc =
             |> Expect.equal "Should have a true value" expected
       ]
     ]
+
+    testList "roundtrip" [
+      testRoundtrip<PointName> fsc Json.Decode.pointName
+      testRoundtrip<Value> fsc Json.Decode.gaugeValue
+      testRoundtrip<Gauge> fsc Json.Decode.gauge
+      testRoundtrip<LogLevel> fsc Json.Decode.level
+
+      testCase "small record" <| fun () ->
+        let subject = Message.event Info "Hi" |> Message.setContext "user" (foo ())
+        let encoded = subject |> Json.encode
+        encoded
+          |> Expect.Json.isObjectX "encodes Message to JsonObject"
+          |> JsonObject.find "context"
+          |> JsonResult.getOrThrow
+          |> Expect.Json.isObjectX "encodes context to JsonObject"
+          |> JsonObject.find "user"
+          |> JsonResult.getOrThrow
+          |> Expect.Json.isObject "Encodes the Record as JsonObject"
+
+      testCase "default gauge" <| fun () ->
+        let input = Message.gaugef (PointName [| "car" |]) "throttle" 0.45
+        let encoded = input |> Json.encode
+        let decoded = encoded |> Json.Decode.message |> JsonResult.getOrThrow
+        decoded |> Expect.Message.equal "Should eq decoded" input
+
+      ptestCase "complex message" <| fun () ->
+        let encoded = Json.encode complexMessage
+        let decoded = encoded |> Json.Decode.message |> JsonResult.getOrThrow
+        decoded |> Expect.Message.equal "Should eq after roundtrip" complexMessage
+    ]
   ]
 

src/Logary.Tests/Program.fs

@@ -89,6 +89,7 @@ type Arbs =
       | Pow (_, n)    -> isNormal n
       | Offset (_, f) -> isNormal f
       | Scaled (_, f) -> isNormal f
+      | Other x -> not (isNull x)
       | _ -> true)
 
   static member Gauge() =

src/Logary/Codecs/Codecs.fs

@@ -17,7 +17,7 @@ module Codec =
   let json: Codec =
     fun input ->
       let line = input.utf8String ()
-      match Json.parse line |> JsonResult.bind Json.decodeMessage with
+      match Json.parse line |> JsonResult.bind Json.Decode.messageBatch with
       | JPass message ->
         Ok message
       | JFail failure ->

src/Logary/DataModel.fs

@@ -156,7 +156,7 @@ module PointName =
   /// treat this value like an immutable value.
   [<CompiledName "OfArray">]
   let ofArray (hiera: string[]) =
-    PointName hiera
+     PointName hiera
 
   [<CompiledName "Parse">]
   let parse (s: string) =
@@ -244,6 +244,41 @@ type Message =
     /// The # of seconds since UNIX epoch 1970-01-01T00:00:00Z
     member x.timestampEpochS: int64 =
       x.timestamp / Constants.NanosPerSecond
+
+
+/// Patterns to match against the context; useful for extracting the data
+/// slightly more semantically than "obj"-everything. Based on the known prefixes
+/// in `KnownLiterals`.
+module MessagePatterns =
+  open KnownLiterals
+
+  /// Pattern match the key
+  let (|Intern|Field|Gauge|Tags|Context|) (KeyValue (key: string, value: obj)) =
+    match key with
+    | _ when key = TagsContextName ->
+      let tags = unbox<Set<string>> value
+      Tags tags
+
+    | _ when key.StartsWith FieldsPrefix ->
+      let k = key.Substring FieldsPrefix.Length
+      Field (k, value)
+
+    | _ when key.Equals(DefaultGaugeName, StringComparison.InvariantCulture) ->
+      Gauge (String.Empty, unbox<Gauge> value)
+
+    | _ when key.StartsWith GaugeNamePrefix ->
+      let k = key.Substring GaugeNamePrefix.Length
+      Gauge (k, unbox<Gauge> value)
+
+    | _ when key.StartsWith LogaryPrefix ->
+      Intern
+
+    | _ ->
+      match value with
+      | :? Gauge as g ->
+        Gauge (key, g)
+      | _ ->
+        Context (key, value)
 
 /// A Span focuses primarily on a timed scope of execution, which will come to end. This
 /// abstraction is primarily used for tracing.