Event parser

EventParser.fs

namespace Utilities

type EventType = string
type EventData = string

type EventParser<'union, 'meta> =
    {
        Deserializers : Map<EventType, EventData option -> Result<'union, exn>>
        Serialize : 'union -> Result<EventType * EventData option, exn>
        ParseMeta : string -> Result<'meta, exn>
    }

type ParseConfig =
    {
        ParseObj: System.Type -> string -> obj
        Serialize: obj -> string
    }


module EventParser =

    open Microsoft.FSharp.Reflection

    module Internal =

        let serializeCustomEx serialize (value: 'union) =
            let case, fieldValues = FSharpValue.GetUnionFields(value, typeof<'union>)
            let jsonOpt =
                Array.tryHead fieldValues
                |> Option.map serialize
            (case.Name, jsonOpt)


        let createParserCustom<'t> (parseObj: System.Type -> string -> obj) =
            let deserializeEx (value: string) : 't =
                parseObj typeof<'t> value
                :?> 't
            Result.liftEx id deserializeEx


        let createEventParserCustom<'union> parseObj (case: UnionCaseInfo) =
            let fieldOpt = Array.tryHead (case.GetFields())
            let deserializeEx =
                match fieldOpt with
                | None ->
                    let deserialize (_: string option) =
                        FSharpValue.MakeUnion(case, Array.empty)
                        :?> 'union
                    deserialize
                | Some field ->
                    let deserialize (json: string option) =
                        parseObj field.PropertyType json.Value
                        |> fun o -> FSharpValue.MakeUnion(case, Array.singleton o)
                        :?> 'union
                    deserialize
            Result.liftEx id deserializeEx


    /// Merge deserializers for old events into the current event parser.
    /// The resulting parser will deserialize both current and old events,
    /// but old events will be translated to a current event using the upgrade function.
    ///
    /// NOTE: Old and current type names should not overlap.
    let mergeDeserializers (old: EventParser<'old, 'meta>) (upgrade: 'old -> 'event) (parser: EventParser<'event, 'meta>) =
        let update newMap oldType oldDeserialize =
            let deserialize s =
                oldDeserialize s
                |> Result.map upgrade
            Map.add oldType deserialize newMap
        let deserializers = Map.fold update parser.Deserializers old.Deserializers
        { parser with
            Deserializers = deserializers
        }


    let deserialize (parser: EventParser<'event, 'meta>) sType sEventOpt =
        match Map.tryFind sType parser.Deserializers with
        | None -> None
        | Some deserialize ->
            Some (deserialize sEventOpt)


    /// Creates a Map of parsers for each union case.
    /// The Map key is the union case name.
    let createCustom<'union, 'meta> cfg : EventParser<'union, 'meta> =
        let parserMap =
            FSharpType.GetUnionCases(typeof<'union>)
            |> Array.map (fun case -> case.Name, Internal.createEventParserCustom<'union> cfg.ParseObj case)
            |> Map.ofArray
        {
            Deserializers = parserMap
            Serialize = Result.liftEx id (Internal.serializeCustomEx cfg.Serialize)
            ParseMeta = Internal.createParserCustom<'meta> cfg.ParseObj
        }

Result.fs

namespace Utilities

module Result =

    /// change a function to return a Result when it may throw an exception
    let liftEx fEx f x =
        try
            Ok (f x)
        with ex ->
            Error (fEx ex)