applicative event-sourcing

ApplicativeEventSourcing.fs

namespace EventSourcing

module View =
 
    /// the View's builder-type - includes bookkepping for intermediate types and should be hidden
    /// from (poor) users view
    type T<'e,'i,'a> = private { foldF : 'i -> 'e  -> 'i; project : 'i -> 'a; init : 'i }
 
    /// creates a view, based on a fold over intermediate values and a final projection
    let createWithProjection (p : 'i -> 'a) (i : 'i) (f : 'i -> 'e -> 'i) =
        { foldF = f
          project = p
          init = i
        }
 
    /// create a view based on simple fold
    let create (init : 'a) (f : 'a -> 'e -> 'a) =
        createWithProjection id init f
 
    /// folds events over a view (starting form init) into a final output
    let foldFrom (b : T<'e,'i,'a>) (init : 'i) : 'e seq -> 'a =
        Seq.fold b.foldF init >> b.project
 
    /// folds events over a view into a final output
    let fold (b : T<'e,'i,'a>) : 'e seq -> 'a =
        foldFrom b (b.init)
 
 
    // those views are applicative - so let's implement the operations:
    let map (f : 'a -> 'b) (a : T<'e,'i,'a>) : T<'e,'i,'b> =
        { foldF = a.foldF
          project = a.project >> f
          init = a.init
        }
 
    let sequence (f : T<'e,'i1,('a -> 'b)>) (a : T<'e,'i2,'a>) : T<'e, 'i1*'i2,'b> =
        { foldF = fun (i1,i2) e -> (f.foldF i1 e, a.foldF i2 e)
          project = fun (i1,i2) -> (f.project i1) (a.project i2)
          init = (f.init, a.init)
        }
 
    /// pure for the view-applicative (remark: pure itself is a reserved word in F# ^^ )
    let pureV (f : 'a -> 'b) : T<'e, unit,'a -> 'b> =
        { foldF = fun () _ -> ()
          project = fun () -> f
          init = ()
        }

[<AutoOpen>]
module ViewOperations =
    open View
    let (<*>) = sequence
    let (<?>) = map

module EventStore =
    open System
    open System.Collections.Generic

    type EntityId  = Guid

    type T =
        abstract entityIds : unit     -> HashSet<EntityId>
        abstract getEvents : EntityId -> 'e seq
        abstract addEvent  : EntityId -> 'e -> unit

    let createMemoryStore () : T =
        let mem = Dictionary<EntityId, (Type * List<obj>)>()
        let add id (e : 'e) =
            let t = typeof<'e>
            match mem.TryGetValue id with
            | (true, (t',l)) when t'=t -> 
                l.Add (box e)
            | (true, _) ->
                failwith "wrong eventtype for this id"
            | (false, _) ->
                let l = List<_>()
                l.Add (box e)
                mem.[id] <- (t, l)
        let get id : 'e seq =
            let t = typeof<'e>
            match mem.TryGetValue id with
            | (true, (t',l)) when t'=t ->
                l.ToArray() 
                |> Seq.ofArray
                |> Seq.map unbox
            | (true, _) ->
                failwith "wrong eventtype for this id"
            | _ ->
                Seq.empty
        let ids () = HashSet(mem.Keys)
        { new T with
            member i.entityIds ()  = ids ()
            member i.getEvents id  = get id
            member i.addEvent id e = add id e }

    let store (es : T) (id : EntityId) (e : 'e) = es.addEvent id e

    let read (es : T) (vw : View.T<'e,_,'a>) (id : EntityId) : 'a =
        es.getEvents id
        |> View.fold vw

    let exists (es : T) (id : EntityId) : bool =
        es.entityIds().Contains(id)
 
module Example =
    open System
 
    // it's all about cargo containers, that gets created, moved and loaded/unloaded
 
    [<Measure>] type kg
    [<Measure>] type t
    let toKg (t : float<t>)   : float<kg> = t  * 1000.0<kg/t>
    let toT  (kg : float<kg>) : float<t>  = kg / 1000.0<kg/t>
 
    type Id       = Guid
    type Location = String
    type Goods    = string
    type Weight   = float<t>
 
    type Container = 
        | Created    of Id
        | MovedTo    of Location
        | Loaded     of Goods * Weight
        | Unloaded   of Goods * Weight
 
    // let's begin with the fun part
    // insted of focusing on complete aggregates
    // we define some basic views:
 
    /// the id of a container 
    let id = 
        View.create Guid.Empty (fun s ev ->
            match ev with
            | Created i -> if s = Guid.Empty 
                            then i
                           else failwith "should not create a container twice"
            | _ -> s)
 
    /// the current location of a container
    let location = 
        View.create "" (fun s ev ->
            match ev with
            | MovedTo l -> l
            | _ -> s )
 
    /// the netto-weight, assuming a container itself is 2.33t
    let nettoWeight = 
        View.create 2.33<t> (fun s ev ->
            match ev with
            | Loaded (_,w) -> s + w
            | Unloaded (_,w) -> s - w
            | _ -> s )
 
    /// weight of a given good (0 if not loaded)
    let goodWeight (g : Goods) = 
        View.create 0.0<t> (fun s ev ->
            match ev with
            | Loaded (g',w) when g' = g   -> s + w
            | Unloaded (g',w) when g' = g -> s - w
            | _ -> s )

            /// the loaded goods (with their weight)
    let goods =
        View.createWithProjection Map.toList Map.empty (fun m ev ->
            match ev with
            | Loaded (g,w) ->   match m.TryFind g with
                                | Some w' -> m |> Map.remove g |> Map.add g (w+w')
                                | None    -> m |> Map.add g w
            | Unloaded (g,w) -> match m.TryFind g with
                                | Some cur -> if cur < w 
                                                then failwith (sprintf "tried to unload %.2ft %s but there are only %.2ft" (cur / 1.0<t>) g (w / 1.0<t>)) 
                                              elif cur = w
                                                then m |> Map.remove g
                                              else m |> Map.remove g |> Map.add g (cur-w)
                                | None    -> failwith (sprintf "tried to unload %.2ft non-loaded goods %s" (w / 1.0<t>) g)
            | _            -> m
            )
 
    // of course we can compose these:
 
    /// is the container heavier than it should be? (assuming the max. weight is 28t)
    let isOverloaded = View.pureV (fun netto -> netto > 28.0<t>) <*> nettoWeight
 
    /// collects information about the current state of a certain container
    type ContainerInfo = { id : Id; location : Location; netto : Weight; overloaded : bool; goods : (Goods * Weight) list }
    let createInfo i l n o g = { id = i; location = l; netto = n; overloaded = o; goods = g }
 
    /// current container-info
    let containerInfo =
        createInfo <?> id <*> location <*> nettoWeight <*> isOverloaded <*> goods

    // commands

    let createContainer (store : EventStore.T) : Id =
        let id = Id.NewGuid()
        let ev = Created id
        EventStore.store store id ev
        id

    let moveTo (store : EventStore.T) (id : Id) (l : Location) =
        if not <| EventStore.exists store id then failwith "container not found"
        let ev = MovedTo l
        EventStore.store store id ev

    let loadGood (store : EventStore.T) (id : Id) (g : Goods, w : Weight) =
        if not <| EventStore.exists store id then failwith "container not found"
        let ev = Loaded (g,w)
        EventStore.store store id ev

    let unloadGood (store : EventStore.T) (id : Id) (g : Goods, w : Weight) =
        let loaded = EventStore.read store (goodWeight g) id
        if w > loaded then failwith "cannot unload more than is loaded"
        let ev = Unloaded (g,w)
        EventStore.store store id ev

    /// run a basic example
    let run() =

        let store = EventStore.createMemoryStore ()

        // insert some sample history
        let id = createContainer store
        moveTo store id "Bremen"
        loadGood store id ("Tomaten", 3500.0<kg> |> toT)
        moveTo store id "Hamburg"
        unloadGood store id ("Tomaten", 2.5<t>)
        loadGood store id ("Fisch", 20.0<t>)

        // aggregate the history into a container-info and print it
        EventStore.read store containerInfo id
        |> (fun ci -> printfn "Container %A currently in %s, loaded with: %A for a total of %.2ft is overloaded: %A" 
                        ci.id ci.location (List.map fst ci.goods) (ci.netto / 1.0<t>) ci.overloaded)

module Main =   

    [<EntryPoint>]
    let main argv = 
        Example.run()
        0 // return an integer exit code