Allocation example from Equinox 174

Author: bartelink

equinox-fc/Domain.Tests/AllocationTests.fs

@@ -0,0 +1,10 @@
+module AllocationTests
+
+open Allocation
+open FsCheck.Xunit
+open Swensen.Unquote
+
+let [<Property>] ``codec can roundtrip`` event =
+    let ee = Events.codec.Encode(None,event)
+    let ie = FsCodec.Core.TimelineEvent.Create(0L, ee.EventType, ee.Data)
+    test <@ Some event = Events.codec.TryDecode ie @>

equinox-fc/Domain.Tests/AllocatorTests.fs

@@ -0,0 +1,59 @@
+module AllocatorTests
+
+open Allocator
+open FsCheck.Xunit
+open Swensen.Unquote
+open System
+
+type Command =
+    | Commence of AllocationId * DateTimeOffset
+    | Complete of AllocationId * Events.Reason
+
+type Result =
+    | Accepted
+    | Conflict of AllocationId
+
+let execute cmd state =
+    match cmd with
+    | Commence (a,c) ->
+        match decideCommence a c state with
+        | CommenceResult.Accepted, es ->  Accepted,es
+        | CommenceResult.Conflict a, es -> Conflict a,es
+    | Complete (a,r) -> let es = decideComplete a r state in Accepted, es
+
+let [<Property>] properties c1 c2 =
+    let res,events = execute c1 Folds.initial
+    let state1 = Folds.fold Folds.initial events
+    match c1, res, events, state1 with
+    | Commence (a,c), Accepted, [Events.Commenced ({ allocationId = ea; cutoff = ec } as e)], state ->
+        test <@ a = ea && c = ec && state = Some e @>
+    | Complete _, Accepted, [], None ->
+        () // Non-applicable Complete requests are simply ignored
+    | _, res, l, _ ->
+        test <@ List.isEmpty l && res = Accepted @>
+
+    let res,events = execute c2 state1
+    let state2 = Folds.fold state1 events
+    match state1, c2, res, events, state2 with
+    // As per above, normal commence
+    | None, Commence (a,c), Accepted, [Events.Commenced ({ allocationId = ea; cutoff = ec } as e)], state ->
+        test <@ a = ea && c = ec && state = Some e @>
+    // Idempotent accept if same allocationId
+    | Some active as s1, Commence (a,_), Accepted, [], s2 ->
+        test <@ s1 = s2 && active.allocationId = a @>
+    // Conflict reports owner allocator
+    | Some active as s1, Commence (a2,_), Conflict a1, [], s2 ->
+        test <@ s1 = s2 && a2 <> a1 && a1 = active.allocationId @>
+    // Correct complete for same allocator is accepted
+    | Some active, Complete (a,r), Accepted, [Events.Completed { allocationId = ea; reason = er }], None ->
+        test <@ er = r && ea = a && active.allocationId = a @>
+    // Completes not for the same allocator are ignored
+    | Some active as s1, Complete (a,_), Accepted, [], s2 ->
+        test <@ active.allocationId <> a && s2 = s1 @>
+    | _, _, res, l, _ ->
+        test <@ List.isEmpty l && res = Accepted @>
+
+let [<Property>] ``codec can roundtrip`` event =
+    let ee = Events.codec.Encode(None,event)
+    let ie = FsCodec.Core.TimelineEvent.Create(0L, ee.EventType, ee.Data)
+    test <@ Some event = Events.codec.TryDecode ie @>

equinox-fc/Domain.Tests/Domain.Tests.fsproj

@@ -12,6 +12,10 @@
         <Compile Include="LocationSeriesTests.fs" />
         <Compile Include="LocationEpochTests.fs" />
         <Compile Include="LocationTests.fs" />
+        <Compile Include="TicketTests.fs" />
+        <Compile Include="TicketListTests.fs" />
+        <Compile Include="AllocatorTests.fs" />
+        <Compile Include="AllocationTests.fs" />
     </ItemGroup>
 
     <ItemGroup>

equinox-fc/Domain.Tests/TicketListTests.fs

@@ -0,0 +1,45 @@
+module TicketListTests
+
+open FsCheck.Xunit
+open Swensen.Unquote
+open TicketList
+
+let [<Property>] properties c1 c2 =
+    let events = interpret c1 Folds.initial
+    let state1 = Folds.fold Folds.initial events
+    match c1, events, state1 with
+    // Empty request -> no Event
+    | (_,[]), [], state ->
+        test <@ Set.isEmpty state @>
+    | (a,t), [Events.Allocated { allocatorId = ea; ticketIds = et }], state ->
+        test <@ a = ea @>
+        test <@ state = set t @>
+        test <@ state = set et @>
+    | _, l, _ ->
+        test <@ List.isEmpty l @>
+
+    let events = interpret c2 state1
+    let state2 = Folds.fold state1 events
+    test <@ Folds.fold state2 [Folds.snapshot state2] = state2 @>
+    match state1, c2, events, state2 with
+    // Empty request -> no Event, same state
+    | s1, (_,[]), [], state ->
+        test <@ state = s1 @>
+    // Redundant request -> No Event, same state
+    | s1, (_,t), [], _ ->
+        test <@ Set.isSuperset s1 (set t) @>
+    // Two consecutive commands should both manifest in the state
+    | s1, (a,t), [Events.Allocated { allocatorId = ea; ticketIds = et }], state ->
+        test <@ a = ea @>
+        let et = Set et
+        test <@ Set.isSuperset (set t) et @>
+        test <@ Set.intersect s1 et |> Set.isEmpty @>
+        test <@ Set.isSuperset state s1 @>
+        test <@ Set.isSuperset state et @>
+    | _, _, l, _ ->
+        test <@ List.isEmpty l @>
+
+let [<Property>] ``codec can roundtrip`` event =
+    let ee = Events.codec.Encode(None,event)
+    let ie = FsCodec.Core.TimelineEvent.Create(0L, ee.EventType, ee.Data)
+    test <@ Some event = Events.codec.TryDecode ie @>

equinox-fc/Domain.Tests/TicketTests.fs

@@ -0,0 +1,82 @@
+module TicketTests
+
+open FsCheck.Xunit
+open Swensen.Unquote
+open Ticket
+open Ticket.Folds
+
+/// We want to generate Allocate requests with and without the same listId in some cases
+let (|MaybeSameCommands|) = function
+    | Allocate _ as x, Allocate _, cmd3, Choice1Of2 () -> x, x, cmd3
+    | cmd1, (Allocate _ as x), Allocate _, Choice1Of2 () -> cmd1, x, x
+    | cmd1, cmd2, cmd3, (Choice1Of2 ()|Choice2Of2 ()) -> cmd1, cmd2, cmd3
+
+/// Explicitly generate sequences with the same allocator running twice or three times
+let (|MaybeSameIds|) = function
+    | Choice1Of4 a -> a, a, a
+    | Choice2Of4 (a,b) -> a, a, b
+    | Choice3Of4 (a,b) -> a, b, b
+    | Choice4Of4 (a,b,c) -> a, b, c
+
+let (|Invariants|) = function
+    // Revokes always succeed iff Unallocated
+    | Unallocated, Revoke, true, [], Unallocated ->
+        ()
+    // Everything else fails
+    | _, _, res, e, _ ->
+        test <@ not res && List.isEmpty e @>
+
+let (|ReservedCases|_|) allocator = function
+    // Reserve given unallocated
+    | Unallocated, Reserve, true, [Events.Reserved { allocatorId = a }], state ->
+        test <@ a = allocator && state = Reserved a  @>
+        Some ()
+    // Idempotent reserve request
+    | Reserved a, Reserve, true, [], _ ->
+        test <@ a = allocator @>
+        Some ()
+    // Revokes not by the owner are reported as successful, but we force the real owner to do the real relinquish
+    | (Reserved by | Allocated(by,_)), Revoke, true, [], _ ->
+        test <@ by <> allocator @>
+        Some ()
+    // Revokes succeed iff by the owner
+    | (Reserved by | Allocated(by,_)), Revoke, true, [Events.Revoked], Unallocated ->
+        test <@ by = allocator @>
+        Some ()
+    // Reservations can transition to Allocations as long as it's the same Allocator requesting
+    | Reserved a, Allocate l, true, [Events.Allocated { allocatorId = ea; listId = el }], Allocated (sa,sl) ->
+        test <@ a = allocator && a = ea && a = sa && l = el && l = sl @>
+        Some()
+    | _ -> None
+
+let [<Property>] properties (MaybeSameIds (a1,a2,a3)) (MaybeSameCommands (c1,c2,c3)) =
+    let res, events = decide a1 c1 Folds.initial
+    let state1 = Folds.fold Folds.initial events
+
+    match Folds.initial, c1, res, events, state1 with
+    | _, Reserve, true, [Events.Reserved { allocatorId = a }], Reserved sa ->
+        test <@ a = a1 && sa = a1  @>
+    | Invariants -> ()
+
+    let res, events = decide a2 c2 state1
+    let state2 = Folds.fold state1 events
+    match state1, c2, res, events, state2 with
+    | ReservedCases a2 -> ()
+    | Invariants -> ()
+
+    let res, events = decide a3 c3 state2
+    let state3 = Folds.fold state2 events
+    match state2, c3, res, events, state3 with
+    // Idempotent allocate ignore
+    | Allocated (a,l), Allocate l3, true, [], _ ->
+        test <@ a = a3 && l = l3 @>
+    // Allocated -> Revoked
+    | Allocated (a,_), Revoke, true, [Events.Revoked], Unallocated ->
+        test <@ a = a3 @>
+    | ReservedCases a3 -> ()
+    | Invariants -> ()
+
+let [<Property>] ``codec can roundtrip`` event =
+    let ee = Events.codec.Encode(None,event)
+    let ie = FsCodec.Core.TimelineEvent.Create(0L, ee.EventType, ee.Data)
+    test <@ Some event = Events.codec.TryDecode ie @>