pseudo-dynamic json parsing into a DU with FSharp.Data

jsonsample.fsx

type ParseError = string list
 
type HashBlocking = { CustomerField: string; ProviderField: string }
type SuffixArrayBlocking = { CustomerField: string; ProviderField: string }
 
type BlockingMethod =
    | Hash of HashBlocking
    | SuffixArray of SuffixArrayBlocking
 
type FieldConfig = 
    {
        FieldName: string
        FieldType: string
    }
 
type Configuration = 
    {
        CustomerDescriptor: FieldConfig list
        ProviderDescriptor: FieldConfig list
        Blocking: BlockingMethod list
    }
 
open System.Reflection
open Microsoft.FSharp.Reflection
 
open SafeBlock.Types
 
open FSharp.Data.Json
open FSharp.Data.Json.Extensions
 
let isChoice1 o = match o with | Choice1Of2 _ -> true | Choice2Of2 _ -> false
let getChoice1 o = match o with | Choice1Of2 o -> o | Choice2Of2 _ -> failwith "Expected Choice1, but was Choice2"
let getChoice2 o = match o with | Choice2Of2 o -> o | Choice1Of2 _ -> failwith "Expected Choice2, but was Choice1"
 
let jsonToFieldConfig (key: string, value: JsonValue) : (FieldConfig, ParseError) Choice = 
    match value with
    | JsonValue.String s -> { FieldName = key; FieldType = s } |> Choice1Of2
    | _ -> ["Type of " + key + " is not a json string"] |> Choice2Of2
 
let jsonToDescriptor (json: JsonValue) : (FieldConfig list, ParseError) Choice =
    match json with
    | JsonValue.Object objects -> 
        let tupled = objects |> Map.toList
        let fieldResults, failedResults = tupled |> List.map jsonToFieldConfig |> List.zip (tupled |> List.map fst) |> List.partition (snd >> isChoice1)
        if failedResults |> List.isEmpty then
            fieldResults |> List.map (snd >> getChoice1) |> Choice1Of2
        else
            [  for key, fieldConfig in failedResults do
                    match fieldConfig with | Choice1Of2 _ -> () | Choice2Of2 e -> yield ("Errors found while parsing field: " + key); yield! e
            ] |> Choice2Of2
    | _ -> Choice2Of2 ["Descriptor must contain a json object."]
 
 
let blockingTypes : (string, ((string, string) Map -> BlockingMethod)) Map =
    let cases = FSharpType.GetUnionCases typeof<BlockingMethod>
    [
        for case in cases do
            let fieldpi : PropertyInfo =
                let fs = case.GetFields() in if fs.Length <> 1 then failwith "All BlockingMethod cases must have a single member."
                                          else fs.[0]
            let fieldType = fieldpi.PropertyType
            if not <| FSharpType.IsRecord fieldType then failwith "All BlockingMethod cases must have a single member which contains a record." 
            
            let fields = FSharpType.GetRecordFields fieldType 
            let fieldNames = fields |> Array.map (fun f -> f.Name)
            let rCtor = FSharpValue.PreComputeRecordConstructor fieldType
            let uCtor = FSharpValue.PreComputeUnionConstructor case
 
            let func m =
                try
                    let values = fieldNames |> Array.map (fun fn -> m |> Map.find fn |> box) 
                    uCtor [|rCtor values|] :?> BlockingMethod
                with ex -> failwith ("Failed while constructing a BlockingMethod configuration: " + ex.Message)
            yield case.Name, func
    ] |> Map.ofList
 
 
let jsonToBlockingConfig (blockType: string) (json: JsonValue) : (BlockingMethod, ParseError) Choice  = 
    let bCtor = blockingTypes |> Map.tryFind blockType
    match bCtor, json with
    | Some ctor, JsonValue.Object objects -> 
        let kvpairs = objects |> Map.map (fun k -> function | JsonValue.String s -> s | _ -> failwith "Only strings are currently supported in the blocking configuration")
        ctor kvpairs |> Choice1Of2
    | None, _ -> Choice2Of2 ["Constructor not found for BlockingMethod: " + blockType]
    | Some _, _ -> Choice2Of2 ["Config must contain a json object type."]
 
let jsonToBlocking (json: JsonValue) : (BlockingMethod, ParseError) Choice  = 
    match json with
    | JsonValue.Object objects -> 
        let gf v =  objects |> Map.tryFind v
        match gf "Type", gf "Config" with
        | Some (JsonValue.String rtype), Some cfg -> 
            match jsonToBlockingConfig rtype cfg with
            | Choice1Of2 blk -> blk |> Choice1Of2
            | Choice2Of2 err -> ("Errors found while parsing the Blocking field: " + rtype) :: err |> Choice2Of2
        | Some rtype, Some cfg -> ["Type field of Blocking definition should contain a string"] |> Choice2Of2
        | None, _ -> ["Blocking definition must include a Type field."] |> Choice2Of2
        | _, None -> ["Blocking definition must include a Config field."] |> Choice2Of2
    | _ -> Choice2Of2 ["Each item in the Blocking array must contain a json object."]
 
 
let jsonToBlockingList (json: JsonValue) : (BlockingMethod list, ParseError) Choice =
    match json with
    | JsonValue.Array array -> 
        let res = array |> Array.toList |> List.map jsonToBlocking
        let blocks, failed = res |> List.partition isChoice1 |> fun (b,f) -> b |> List.map getChoice1, f |> List.map getChoice2
        if failed |> List.isEmpty then blocks |> Choice1Of2
        else ("Errors found in one or more Blocking definitions." :: List.collect id failed) |> Choice2Of2        
    | _ -> Choice2Of2 ["Blocking must contain a json object."]
    
 
let jsonToConfiguration (jsonFile: JsonValue) : (Configuration, ParseError) Choice  =
    match jsonFile with
    | JsonValue.Object objects ->
        let gf v =  objects |> Map.tryFind v
        match gf "CustomerDescriptor", gf "ProviderDescriptor", gf "Blocking" with
        | Some (cd), Some(pd), Some (blocks) -> 
            match jsonToDescriptor cd, jsonToDescriptor pd, jsonToBlockingList blocks with
            | Choice1Of2 cds, Choice1Of2 pds, Choice1Of2 blk -> { CustomerDescriptor = cds; ProviderDescriptor = pds; Blocking = blk } |> Choice1Of2 
            | cdo, pdo, bko -> 
                [
                    match cdo with | Choice1Of2 _ -> () | Choice2Of2 e -> yield! "Errors found while parsing CustomerDescriptor." :: e
                    match pdo with | Choice1Of2 _ -> () | Choice2Of2 e -> yield! "Errors found while parsing ProviderDescriptor." :: e
                    match bko with | Choice1Of2 _ -> () | Choice2Of2 e -> yield! "Errors found while parsing Blocking." :: e
                ] |> Choice2Of2
        | cdo, pdo, bo -> 
            [ 
                if cdo.IsNone then yield "CustomerDescriptor field not found on top level json object."
                if pdo.IsNone then yield "ProviderDescriptor field not found on top level json object."
                if bo.IsNone  then yield "Blocking field not found on top level json object."
            ] |> Choice2Of2
    | _ -> Choice2Of2 ["Top level of configuration file must be a json object."]
 
let fileToConfiguration (filename: string) : (Configuration, ParseError) Choice = 
    use file = System.IO.File.OpenRead(filename)
    let json = JsonValue.Load file
    jsonToConfiguration json
 
let textToConfiguration (text: string) : (Configuration, ParseError) Choice = 
    let json = JsonValue.Parse text
    jsonToConfiguration json
 
open System
open Xunit
 
open SafeBlock.Types
open SafeBlock.IO
 
 
let ``simple config`` = """
{
    "CustomerDescriptor": { "CName": "String" },
    "ProviderDescriptor": { "PName": "String" },
    "Blocking": [{"Type": "Hash", "Config": { "CustomerField": "CName", "ProviderField": "PName" } } ]
}"""
 
[<Fact>]
let ``simplest possible config file should parse`` () =
    let config = textToConfiguration ``simple config``
    match config with
    | Choice2Of2 err ->
        let failtext = err |> List.fold (fun s t -> s + Environment.NewLine + t) ""
        failwith failtext
    | Choice1Of2 success ->
        Assert.Equal(1, success.Blocking.Length)
        Assert.Equal(success.Blocking.[0], (BlockingMethod.Hash {CustomerField = "CName"; ProviderField = "PName"}))
        Assert.Equal(1, success.CustomerDescriptor.Length)
        Assert.Equal(success.CustomerDescriptor.[0], { FieldName = "CName"; FieldType = "String" })
        Assert.Equal(1, success.ProviderDescriptor.Length)
        Assert.Equal(success.ProviderDescriptor.[0], { FieldName = "PName"; FieldType = "String" })

Woah. I had no idea F# was "just" ML with extensions.