fix exception raised by at.optional on non-object in path

glennsl · Jun 12, 2018 · 688cbde · 688cbde
1 parent 57cd4af
commit 688cbde
Show file tree

Hide file tree

Showing 2 changed files with 78 additions and 56 deletions.
diff --git a/__tests__/Json_decode_test.ml b/__tests__/Json_decode_test.ml
@@ -557,6 +557,13 @@ describe "obj - at.optional" (fun () ->
         "b": null 
       } |})
       |> toEqual None);
+  test "non-object in path" (fun () ->
+    expect @@ 
+      optionalAt ["a"; "y"] (nullAs Js.null) (parseOrRaise {| {
+        "a": "", 
+        "b": null 
+      } |})
+      |> toEqual None);
   test "decoder error" (fun () ->
     expectFn 
       (optionalAt ["a"; "x"; "y"] (nullAs Js.null)) (parseOrRaise {| {

diff --git a/src/Json_decode.ml b/src/Json_decode.ml
@@ -133,17 +133,24 @@ let tuple4 decodeA decodeB decodeC decodeD json =
   else
     raise @@ DecodeError ("Expected array, got " ^ _stringify json)
 
+let _isObject json =
+  Js.typeof json = "object" && 
+  not (Js.Array.isArray json) && 
+  not ((Obj.magic json : 'a Js.null) == Js.null)
+
 let _jsonDict json =
-  if Js.typeof json = "object" && 
-     not (Js.Array.isArray json) && 
-     not ((Obj.magic json : 'a Js.null) == Js.null)
-  then
-    (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t)
+  if _isObject json then
+    Some (Obj.magic (json : Js.Json.t) : Js.Json.t Js.Dict.t)
   else
-    raise @@ DecodeError ("Expected object, got " ^ _stringify json)
+    None
+
+let _assertJsonDict json =
+  match _jsonDict json with
+  | Some dict -> dict
+  | None      -> raise @@ DecodeError ("Expected object, got " ^ _stringify json)
 
 let dict decode json = 
-  let source = _jsonDict json in
+  let source = _assertJsonDict json in
   let keys = Js.Dict.keys source in
   let l = Js.Array.length keys in
   let target = Js.Dict.empty () in
@@ -173,59 +180,67 @@ type obj_getters = {
 }
 
 exception FieldNotFound of string
+exception NotAnObject
 
 let obj builder json =
-  let _dict = _jsonDict json in (* TODO: optimize object check *)
-
-  let tag msg key =
-    msg ^ "\n\tat field '" ^ key ^ "'"
-  in
-
-  let get key decode json =
-    match Js.Dict.get (_jsonDict json) key with
-    | Some value -> begin
-      try decode value with
-      | FieldNotFound msg -> raise (FieldNotFound (tag msg key))
-      | DecodeError msg   -> raise (DecodeError (tag msg key))
-      end
-    | None -> raise (FieldNotFound ("Expected required field '" ^ key ^ "'"))
-  in
-
-  let field: field_getters = {
-    optional = (fun key decode -> 
-      match get key decode json with
-      | x -> Some x
-      | exception FieldNotFound _ -> None);
-
-    required = fun key decode ->
-      try get key decode json with
-      | FieldNotFound msg -> raise (DecodeError msg)
-  } in
-
-  let rec getPath key_path decode =
-    match key_path with 
-      | [key]     -> get key decode
-      | key::rest -> get key (getPath rest decode)
-      | []        -> raise @@ Invalid_argument ("Expected key_path to contain at least one element")
-  in
-
-  let at = {
-    optional = (fun path decode ->
-      match getPath path decode json with
-      | x -> Some x
-      | exception FieldNotFound _ -> None);
-
-    required = fun path decode ->
-      try getPath path decode json with
-      | FieldNotFound msg -> raise (DecodeError msg)
-  } in
-
-  builder { field; at }
+  if not (_isObject json) then
+    raise @@ DecodeError ("Expected object, got " ^ _stringify json)
+  else
+    let tag msg key =
+      msg ^ "\n\tat field '" ^ key ^ "'"
+    in
+
+    let get key decode json =
+      match _jsonDict json with
+      | Some dict ->
+        begin
+          match Js.Dict.get dict key with
+          | Some value -> begin
+            try decode value with
+            | FieldNotFound msg -> raise (FieldNotFound (tag msg key))
+            | DecodeError msg   -> raise (DecodeError (tag msg key))
+            end
+          | None -> raise (FieldNotFound ("Expected required field '" ^ key ^ "'"))
+        end
+      | None -> raise NotAnObject
+    in
+
+    let field: field_getters = {
+      optional = (fun key decode -> 
+        match get key decode json with
+        | x -> Some x
+        | exception FieldNotFound _ -> None);
+
+      required = fun key decode ->
+        try get key decode json with
+        | FieldNotFound msg -> raise (DecodeError msg)
+    } in
+
+    let rec getPath key_path decode =
+      match key_path with 
+        | [key]     -> get key decode
+        | key::rest -> get key (getPath rest decode)
+        | []        -> raise @@ Invalid_argument ("Expected key_path to contain at least one element")
+    in
+
+    let at = {
+      optional = (fun path decode ->
+        match getPath path decode json with
+        | x -> Some x
+        | exception FieldNotFound _ -> None
+        | exception NotAnObject -> None);
+
+      required = fun path decode ->
+        try getPath path decode json with
+        | FieldNotFound msg -> raise (DecodeError msg)
+        | NotAnObject ->
+          raise @@ DecodeError ("Expected object, got " ^ _stringify json);
+    } in
+
+    builder { field; at }
 
 let field key decode json =
-  let dict = _jsonDict json in
-
-  match Js.Dict.get dict key with
+  match Js.Dict.get (_assertJsonDict json) key with
   | Some value -> begin
     try
       decode value