├── .gitattributes ├── .gitignore ├── .paket └── paket.bootstrapper.exe ├── FunDomain.Persistence.EventStore.Acceptance ├── EndToEnd.fs ├── FunDomain.Persistence.EventStore.Acceptance.fsproj ├── IdExample.fs ├── LogExample.fs ├── app.config └── paket.references ├── FunDomain.Persistence.EventStore ├── FunDomain.Persistence.EventStore.fsproj ├── GesAgent.fs ├── GesGateway.fs └── paket.references ├── FunDomain.Persistence.Fixtures └── Fixtures.fs ├── FunDomain.Persistence.NEventStore.Acceptance ├── CreateSqlLocalDb.ps1 ├── EndToEnd.fs ├── FunDomain.Persistence.NEventStore.Acceptance.fsproj ├── app.config └── paket.references ├── FunDomain.Persistence.NEventStore ├── FunDomain.Persistence.NEventStore.fsproj ├── NesGateway.fs ├── Projector.fs └── paket.references ├── FunDomain.Tests ├── EventBatchFacts.fs ├── FunDomain.Tests.fsproj ├── SerializationFacts.fs ├── app.config ├── packages.config └── paket.references ├── FunDomain.sln ├── FunDomain ├── CommandHandler.fs ├── EncodedEvent.fs ├── EventBatch.fs ├── FunDomain.fsproj ├── Serialization.fs └── paket.references ├── LICENSE ├── README.md ├── Samples ├── Uno.Tests │ ├── Uno.Tests.fsproj │ ├── When playing a second turn.fs │ ├── When playing card.fs │ ├── When starting game.fs │ ├── app.config │ └── paket.references ├── Uno.sln └── Uno │ ├── Builders.fs │ ├── Game.fs │ ├── Uno.fs │ ├── Uno.fsproj │ └── paket.references ├── build.cmd ├── build.fsx ├── paket.dependencies └── paket.lock /.gitattributes: -------------------------------------------------------------------------------- 1 | ############################################################################### 2 | # Set default behavior to automatically normalize line endings. 3 | ############################################################################### 4 | * text=auto 5 | 6 | ############################################################################### 7 | # Set default behavior for command prompt diff. 8 | # 9 | # This is need for earlier builds of msysgit that does not have it on by 10 | # default for csharp files. 11 | # Note: This is only used by command line 12 | ############################################################################### 13 | #*.cs diff=csharp 14 | 15 | ############################################################################### 16 | # Set the merge driver for project and solution files 17 | # 18 | # Merging from the command prompt will add diff markers to the files if there 19 | # are conflicts (Merging from VS is not affected by the settings below, in VS 20 | # the diff markers are never inserted). Diff markers may cause the following 21 | # file extensions to fail to load in VS. An alternative would be to treat 22 | # these files as binary and thus will always conflict and require user 23 | # intervention with every merge. To do so, just uncomment the entries below 24 | ############################################################################### 25 | #*.sln merge=binary 26 | #*.csproj merge=binary 27 | #*.vbproj merge=binary 28 | #*.vcxproj merge=binary 29 | #*.vcproj merge=binary 30 | #*.dbproj merge=binary 31 | #*.fsproj merge=binary 32 | #*.lsproj merge=binary 33 | #*.wixproj merge=binary 34 | #*.modelproj merge=binary 35 | #*.sqlproj merge=binary 36 | #*.wwaproj merge=binary 37 | 38 | ############################################################################### 39 | # behavior for image files 40 | # 41 | # image files are treated as binary by default. 42 | ############################################################################### 43 | #*.jpg binary 44 | #*.png binary 45 | #*.gif binary 46 | 47 | ############################################################################### 48 | # diff behavior for common document formats 49 | # 50 | # Convert binary document formats to text before diffing them. This feature 51 | # is only available from the command line. Turn it on by uncommenting the 52 | # entries below. 53 | ############################################################################### 54 | #*.doc diff=astextplain 55 | #*.DOC diff=astextplain 56 | #*.docx diff=astextplain 57 | #*.DOCX diff=astextplain 58 | #*.dot diff=astextplain 59 | #*.DOT diff=astextplain 60 | #*.pdf diff=astextplain 61 | #*.PDF diff=astextplain 62 | #*.rtf diff=astextplain 63 | #*.RTF diff=astextplain 64 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ## Ignore Visual Studio temporary files, build results, and 2 | ## files generated by popular Visual Studio add-ons. 3 | 4 | # User-specific files 5 | *.suo 6 | *.user 7 | *.sln.docstates 8 | 9 | # Build results 10 | [Dd]ebug/ 11 | [Dd]ebugPublic/ 12 | [Rr]elease/ 13 | x64/ 14 | build/ 15 | bld/ 16 | [Bb]in/ 17 | [Oo]bj/ 18 | 19 | # MSTest test Results 20 | [Tt]est[Rr]esult*/ 21 | [Bb]uild[Ll]og.* 22 | 23 | #NUNIT 24 | *.VisualState.xml 25 | TestResult.xml 26 | 27 | # Build Results of an ATL Project 28 | [Dd]ebugPS/ 29 | [Rr]eleasePS/ 30 | dlldata.c 31 | 32 | *_i.c 33 | *_p.c 34 | *_i.h 35 | *.ilk 36 | *.meta 37 | *.obj 38 | *.pch 39 | *.pdb 40 | *.pgc 41 | *.pgd 42 | *.rsp 43 | *.sbr 44 | *.tlb 45 | *.tli 46 | *.tlh 47 | *.tmp 48 | *.tmp_proj 49 | *.log 50 | *.vspscc 51 | *.vssscc 52 | .builds 53 | *.pidb 54 | *.svclog 55 | *.scc 56 | 57 | # Chutzpah Test files 58 | _Chutzpah* 59 | 60 | # Visual C++ cache files 61 | ipch/ 62 | *.aps 63 | *.ncb 64 | *.opensdf 65 | *.sdf 66 | *.cachefile 67 | 68 | # Visual Studio profiler 69 | *.psess 70 | *.vsp 71 | *.vspx 72 | 73 | # TFS 2012 Local Workspace 74 | $tf/ 75 | 76 | # Guidance Automation Toolkit 77 | *.gpState 78 | 79 | # ReSharper is a .NET coding add-in 80 | _ReSharper*/ 81 | *.[Rr]e[Ss]harper 82 | *.DotSettings.user 83 | 84 | # JustCode is a .NET coding addin-in 85 | .JustCode 86 | 87 | # TeamCity is a build add-in 88 | _TeamCity* 89 | 90 | # DotCover is a Code Coverage Tool 91 | *.dotCover 92 | 93 | # NCrunch 94 | *.ncrunch* 95 | _NCrunch_* 96 | .*crunch*.local.xml 97 | 98 | # MightyMoose 99 | *.mm.* 100 | AutoTest.Net/ 101 | 102 | # Web workbench (sass) 103 | .sass-cache/ 104 | 105 | # Installshield output folder 106 | [Ee]xpress/ 107 | 108 | # DocProject is a documentation generator add-in 109 | DocProject/buildhelp/ 110 | DocProject/Help/*.HxT 111 | DocProject/Help/*.HxC 112 | DocProject/Help/*.hhc 113 | DocProject/Help/*.hhk 114 | DocProject/Help/*.hhp 115 | DocProject/Help/Html2 116 | DocProject/Help/html 117 | 118 | # Click-Once directory 119 | publish/ 120 | 121 | # Publish Web Output 122 | *.[Pp]ublish.xml 123 | *.azurePubxml 124 | 125 | # NuGet Packages Directory 126 | #packages/ 127 | ## TODO: If the tool you use requires repositories.config uncomment the next line 128 | #!packages/repositories.config 129 | 130 | # Enable "build/" folder in the NuGet Packages folder since NuGet packages use it for MSBuild targets 131 | # This line needs to be after the ignore of the build folder (and the packages folder if the line above has been uncommented) 132 | !packages/build/ 133 | 134 | # Windows Azure Build Output 135 | csx/ 136 | *.build.csdef 137 | 138 | # Windows Store app package directory 139 | AppPackages/ 140 | 141 | # Others 142 | sql/ 143 | *.Cache 144 | ClientBin/ 145 | [Ss]tyle[Cc]op.* 146 | ~$* 147 | *~ 148 | *.dbmdl 149 | *.dbproj.schemaview 150 | *.pfx 151 | *.publishsettings 152 | node_modules/ 153 | 154 | # RIA/Silverlight projects 155 | Generated_Code/ 156 | 157 | # Backup & report files from converting an old project file to a newer 158 | # Visual Studio version. Backup files are not needed, because we have git ;-) 159 | _UpgradeReport_Files/ 160 | Backup*/ 161 | UpgradeLog*.XML 162 | UpgradeLog*.htm 163 | 164 | # SQL Server files 165 | *.mdf 166 | *.ldf 167 | 168 | # Business Intelligence projects 169 | *.rdl.data 170 | *.bim.layout 171 | *.bim_*.settings 172 | 173 | # Microsoft Fakes 174 | FakesAssemblies/ 175 | 176 | packages/ 177 | .build/ 178 | .fake 179 | .vs 180 | .paket/paket.exe -------------------------------------------------------------------------------- /.paket/paket.bootstrapper.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bartelink/FunDomain/1069756192f1a5e3c4b40845d8f5115bdea4ee61/.paket/paket.bootstrapper.exe -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore.Acceptance/EndToEnd.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Persistence.EventStore.Acceptance.EndToEnd 2 | 3 | open FunDomain.Persistence.EventStore // Store 4 | open FunDomain.Persistence.Fixtures // fullGameCommands, gameTopicId, randomGameId, establishProjection 5 | open Swensen.Unquote 6 | open Uno // Card Builders 7 | open Uno.Game // Commands, aggregate 8 | open Xunit 9 | 10 | let playCircuit (store : Store) = async { 11 | let monitor = DirectionMonitor() 12 | let projection = establishProjection monitor 13 | let gameId = randomGameId() 14 | let topicId = gameTopicId gameId 15 | let handle = CommandHandler.ofGesStore store topicId evolve decide 16 | use! sub = store.subscribeStream topicId projection 17 | for cmd in fullCircuitCommands gameId do 18 | printfn "Processing %A against Stream %A" cmd topicId 19 | do! handle cmd 20 | return fun () -> monitor.CurrentDirectionOfGame gameId } 21 | 22 | // Requires an EventStore 3.0 or later (with default parameters) instance to be running on the current machine 23 | let createStore() = GesGateway.create <| System.Net.IPEndPoint(System.Net.IPAddress.Loopback, 1113) 24 | 25 | [] 26 | let ``Can play a circuit and consume projection using GetEventStore``() = 27 | async { 28 | use! store = createStore() 29 | let! checkResult = playCircuit store 30 | fun () -> 31 | let finalDirection = checkResult() 32 | CounterClockWise =! finalDirection 33 | |> withRetryingAndDelaying 10 100 } |> Async.StartAsTask -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore.Acceptance/FunDomain.Persistence.EventStore.Acceptance.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | 55b61236-4168-4fa8-92e3-d298897f1979 9 | Library 10 | FunDomain.Persistence.EventStore.Acceptance 11 | FunDomain.Persistence.EventStore.Acceptance 12 | v4.5 13 | 4.4.0.0 14 | true 15 | FunDomain.Persistence.EventStore.Acceptance 16 | ..\ 17 | 18 | 19 | 20 | true 21 | full 22 | false 23 | false 24 | bin\Debug\ 25 | DEBUG;TRACE 26 | 3 27 | bin\Debug\FunDomain.Persistence.EventStore.Acceptance.XML 28 | 29 | 30 | pdbonly 31 | true 32 | true 33 | bin\Release\ 34 | TRACE 35 | 3 36 | bin\Release\FunDomain.Persistence.EventStore.Acceptance.XML 37 | 38 | 39 | 11 40 | 41 | 42 | 43 | 44 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 45 | 46 | 47 | 48 | 49 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 50 | 51 | 52 | 53 | 54 | 55 | 56 | True 57 | 58 | 59 | 60 | 61 | 62 | FunDomain.Persistence.EventStore 63 | {7f6b835c-7627-46a8-88dd-af4c9eada0ee} 64 | True 65 | 66 | 67 | FunDomain 68 | {b163b5c5-e0f9-4c92-a823-612f32d84693} 69 | True 70 | 71 | 72 | Uno 73 | {4ee8261c-4629-4b28-a141-9c210c5235a9} 74 | True 75 | 76 | 77 | 78 | 79 | 80 | 81 | Fixtures.fs 82 | 83 | 84 | 85 | 86 | 87 | 94 | 95 | 96 | 97 | 98 | ..\packages\EventStore.Client\lib\net40\EventStore.ClientAPI.dll 99 | True 100 | True 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | ..\packages\Unquote\lib\net45\Unquote.dll 110 | True 111 | True 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | ..\packages\xunit.abstractions\lib\net35\xunit.abstractions.dll 121 | True 122 | True 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | ..\packages\xunit.assert\lib\portable-net45+win8+wp8+wpa81\xunit.assert.dll 132 | True 133 | True 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | ..\packages\xunit.extensibility.core\lib\portable-net45+win8+wp8+wpa81\xunit.core.dll 143 | True 144 | True 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | ..\packages\xunit.extensibility.execution\lib\net45\xunit.execution.desktop.dll 154 | True 155 | True 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | <__paket__xunit_runner_visualstudio_props>net20\xunit.runner.visualstudio 164 | 165 | 166 | 167 | 168 | -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore.Acceptance/IdExample.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Persistence.EventStore.Acceptance.IdExample 2 | 3 | open FunDomain 4 | open FunDomain.Persistence.EventStore 5 | open FunDomain.Persistence.Fixtures 6 | open Swensen.Unquote 7 | open Xunit 8 | 9 | type Event = 10 | | Updated of int 11 | 12 | type State = { Current : int } 13 | let (|InitialState|) = function 14 | | None -> { Current = -1 } 15 | | Some s -> s 16 | 17 | let evolve (InitialState state) = 18 | function 19 | | Updated x when state.Current = x - 1 -> { state with Current = x } 20 | | Updated _ as e -> failwithf "event %A not permitted in state %A" e state 21 | >> Some 22 | 23 | type Command = 24 | | Update of int 25 | 26 | let decide = function 27 | | InitialState { Current = current } -> 28 | function 29 | | Update x when current = x -> [] 30 | | Update x when current + 1 = x -> [ Updated x ] 31 | | Update _ as c -> failwithf "Command %A not permitted in State %A" c current 32 | 33 | let run = Seq.fold evolve None >> decide 34 | 35 | [] 36 | let ``Can send 0 initially``() = 37 | [] 38 | |> run <| Update 0 39 | =! [ Updated 0 ] 40 | 41 | [] 42 | let ``Can not handle non-zero initally``() = 43 | <@ [] |> run <| Update 5 @> 44 | |> raisesWith <| fun e -> <@ (e : exn).Message = "Command Update 5 not permitted in State -1" @> 45 | 46 | [] 47 | let ``Can handle sequenced updates``() = 48 | [ Updated 0 49 | Updated 1 ] 50 | |> run <| Update 2 51 | =! [Updated 2] 52 | 53 | module Agent = 54 | let recieve<'msg> (inbox : MailboxProcessor<'msg>) = inbox.Receive() 55 | let start = MailboxProcessor.Start 56 | 57 | let fold handle (initialState : 'state) inbox = 58 | let rec loop state = 59 | async { 60 | let! evt = recieve<'event> inbox 61 | let state = handle state evt 62 | return! loop state 63 | } 64 | loop initialState 65 | 66 | let foldAsync handle initialState inbox = 67 | let rec loop state = async { let! evt = recieve inbox 68 | let! state = handle state evt 69 | return! loop state } 70 | loop initialState 71 | 72 | open System 73 | open System.Net 74 | 75 | // Requires an EventStore 3.0 or later (with default parameters) instance to be running on the current machine 76 | let createStore() = GesGateway.create <| IPEndPoint(IPAddress.Loopback, 1113) 77 | 78 | type CountMonitor() = 79 | let mutable max = 0 80 | let handle _ = function 81 | | Updated x -> max <- x 82 | let agent = Agent.start <| Agent.fold handle () 83 | member __.Post = agent.Post 84 | member __.Max = max 85 | 86 | module Dispatcher = 87 | let forStreamProjector handler (batch : EventBatch) = batch.mapToUnion() |> Seq.iter handler 88 | let forGlobalProjector handler s (batch : EventBatch) = batch.mapToUnion() |> Seq.iter (fun e -> handler s e) 89 | 90 | module Subscriptions = 91 | [] 92 | let ``Can manage updates with GES using global subscription``() = 93 | async { 94 | use! store = createStore() 95 | let topic = string <| Guid.NewGuid() 96 | let monitor = CountMonitor() 97 | let dispatcher = Dispatcher.forGlobalProjector (fun s e -> monitor.Post e) 98 | use! sub = store.subscribeAll ("admin", "changeit") dispatcher 99 | let handle = CommandHandler.ofGesStore store topic evolve decide 100 | do! handle <| Update 0 101 | do! handle <| Update 1 102 | (fun () -> monitor.Max =! 1) |> withRetryingAndDelaying 5 100 } |> Async.StartAsTask 103 | 104 | [] 105 | let ``Can manage updates with GES using local subscription``() = 106 | async { 107 | use! store = createStore() 108 | let topic = string <| Guid.NewGuid() 109 | let monitor = CountMonitor() 110 | let dispatcher = Dispatcher.forStreamProjector monitor.Post 111 | use! sub = store.subscribeStream topic dispatcher 112 | let handle = CommandHandler.ofGesStore store topic evolve decide 113 | do! handle <| Update 0 114 | do! handle <| Update 1 115 | (fun () -> monitor.Max =! 1) |> withRetryingAndDelaying 5 100 } |> Async.StartAsTask 116 | 117 | module ParallelUpdates = 118 | // See also CommandHandler.create 119 | module CommandHandlerIdempotent = 120 | open EventStore.ClientAPI.Exceptions 121 | 122 | let inline create 123 | (read : int -> int -> Async) 124 | (appendIdempotent : (byte [] -> Guid) -> 'token -> EncodedEvent seq -> Async<'token>) 125 | (determisticGuidOfBytes : byte [] -> Guid) 126 | (evolve : 'state option -> 'event -> 'state option) 127 | (decide : 'state option -> 'command -> 'event list) = 128 | let saveEvents token (state : 'state option) events = 129 | async { 130 | try 131 | let! token' = events 132 | |> CommandHandler.save (appendIdempotent determisticGuidOfBytes) token 133 | let state' = Seq.fold evolve state events 134 | return Some(token', state') 135 | with :? AggregateException as e when (e.Flatten().InnerException :? WrongExpectedVersionException) -> 136 | return None 137 | } 138 | fun (interpret : 'state option -> 'command) bookmark -> 139 | async { 140 | let! (token, state) = match bookmark with 141 | | None -> CommandHandler.load read evolve None 142 | | Some bookmark -> bookmark |> async.Return 143 | let command = interpret state 144 | let events = decide state command 145 | if List.isEmpty events then return None 146 | else return! events |> saveEvents token state 147 | } 148 | 149 | let act (r : Random) topic (monitor : CountMonitor) = 150 | async { 151 | use! store = createStore() 152 | let dispatcher = Dispatcher.forStreamProjector monitor.Post 153 | use! sub = store.subscribeStream topic dispatcher 154 | let handle = 155 | let read = store.read topic 156 | let append = store.appendIdempotent topic 157 | CommandHandlerIdempotent.create read append DetermisticGuid.ofBytes evolve decide 158 | let interpret (InitialState { Current = current }) = 159 | let incrementOrMaybeNot = (current + r.Next(2)) 160 | Update incrementOrMaybeNot 161 | 162 | let! b1 = handle interpret None 163 | let! b2 = handle interpret b1 164 | let! b3 = handle interpret b2 165 | let! b4 = handle interpret b3 166 | let! b5 = handle interpret b4 167 | let! b6 = handle interpret b5 168 | let maxSaved = 169 | [ b1; b2; b3; b4; b5; b6 ] 170 | |> List.map (Option.map (fun (_, InitialState { Current = current }) -> current)) 171 | |> List.max 172 | return maxSaved 173 | } 174 | 175 | [] 176 | let ``Can manage parallel updates with GES``() = 177 | async { 178 | let actRandom = act <| Random() 179 | let topic = string <| Guid.NewGuid() 180 | let actRandomOnTopic = actRandom topic 181 | let monitor1, monitor2 = CountMonitor(), CountMonitor() 182 | let! act1 = actRandomOnTopic monitor1 |> Async.StartChild 183 | let! current1 = actRandomOnTopic monitor2 184 | let! current2 = act1 185 | fun () -> 186 | let max1, max2 = monitor1.Max, monitor2.Max 187 | defaultArg (max current1 current2) 42 =! max max1 max2 188 | |> withRetryingAndDelaying 10 100 } |> Async.StartAsTask -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore.Acceptance/LogExample.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Persistence.EventStore.Acceptance.LogExample 2 | 3 | open FunDomain.Persistence.EventStore.GesAgent 4 | open FunDomain.Persistence.Fixtures 5 | open Swensen.Unquote 6 | open System 7 | open System.Net 8 | open Xunit 9 | 10 | type Event = 11 | | Started of started : DateTime 12 | 13 | let evolve = function 14 | | None -> function 15 | | Started date -> Some date 16 | | Some s -> function 17 | | Started e -> e |> failwithf "%A but got %A" s 18 | 19 | type Command = 20 | | Start of DateTime 21 | 22 | let decide = function 23 | | None -> function 24 | | Start date -> [ Started date ] 25 | | Some s -> function 26 | | Start date -> date |> failwithf "%A but got %A" s 27 | 28 | [] 29 | let CanRountrip() = 30 | let storeEndpoint = IPEndPoint(IPAddress.Loopback, 1113) 31 | let topic = string <| Guid.NewGuid() 32 | let mutable success = false 33 | let inputDate = DateTime.Today 34 | 35 | let dispatch = 36 | function 37 | | EventAppeared(Started date) -> success <- date = inputDate 38 | 39 | let _ = createEventStreamerAgent storeEndpoint topic dispatch 40 | let handle = createCommandHandlerAgent storeEndpoint topic evolve decide 41 | handle.Post <| Start inputDate 42 | (fun () -> success =! true) |> withRetryingAndDelaying 50 100 -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore.Acceptance/app.config: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore.Acceptance/paket.references: -------------------------------------------------------------------------------- 1 | EventStore.Client 2 | Unquote 3 | xunit 4 | xunit.runner.visualstudio -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore/FunDomain.Persistence.EventStore.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | 7f6b835c-7627-46a8-88dd-af4c9eada0ee 9 | Library 10 | FunDomain.Persistence.EventStore 11 | FunDomain.Persistence.EventStore 12 | v4.5 13 | 4.4.0.0 14 | FunDomain.Persistence.EventStore 15 | 16 | 17 | 18 | true 19 | full 20 | false 21 | false 22 | bin\Debug\ 23 | DEBUG;TRACE 24 | 3 25 | bin\Debug\FunDomain.Persistence.EventStore.XML 26 | 27 | 28 | pdbonly 29 | true 30 | true 31 | bin\Release\ 32 | TRACE 33 | 3 34 | bin\Release\FunDomain.Persistence.EventStore.XML 35 | 36 | 37 | 11 38 | 39 | 40 | 41 | 42 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 43 | 44 | 45 | 46 | 47 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | True 60 | 61 | 62 | 63 | FunDomain 64 | {b163b5c5-e0f9-4c92-a823-612f32d84693} 65 | True 66 | 67 | 68 | 75 | 76 | 77 | 78 | 79 | ..\packages\EventStore.Client\lib\net40\EventStore.ClientAPI.dll 80 | True 81 | True 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | ..\packages\FSharp.Control.AsyncSeq\lib\net45\FSharp.Control.AsyncSeq.dll 91 | True 92 | True 93 | 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore/GesAgent.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Persistence.EventStore.GesAgent 2 | 3 | open FSharp.Control 4 | open FunDomain 5 | open FunDomain.Persistence.EventStore 6 | open System.Collections.Concurrent 7 | 8 | module Agent = 9 | let receive<'msg> (inbox : MailboxProcessor<'msg>) = inbox.Receive() 10 | let tryReceive<'msg> (inbox : MailboxProcessor<'msg>) = inbox.TryReceive 0 11 | let start = MailboxProcessor.Start 12 | 13 | let foldReceive handle (initialState : 'state) inbox = 14 | let rec loop state = 15 | async { 16 | let! evt = receive<'event> inbox 17 | let state = handle state evt 18 | return! loop state 19 | } 20 | loop initialState 21 | 22 | let foldTryReceive handle (initialState : 'state) inbox = 23 | let rec loop state = 24 | async { 25 | let! event = tryReceive<'event> inbox 26 | let state' = handle state event 27 | return! loop state' 28 | } 29 | loop initialState 30 | 31 | let foldReceiveAsync handle initialState inbox = 32 | let rec loop state = async { let! evt = receive inbox 33 | let! state = handle state evt 34 | return! loop state } 35 | loop initialState 36 | 37 | let createBoundedStreamer (store : Store) stream bufferSize = 38 | asyncSeq { 39 | // 'inspired by' https://gist.github.com/eulerfx/a4a29502f673f13b6a23 40 | use buffer = new BlockingCollection<_>(bufferSize : int) 41 | let inline onEvent (batch : EventBatch) = batch.mapToUnion() |> Seq.iter buffer.Add 42 | use! sub = store.subscribeStream stream onEvent 43 | yield! buffer.GetConsumingEnumerable() |> AsyncSeq.ofSeq 44 | } 45 | 46 | type Command = 47 | | Stop 48 | 49 | type Output<'e> = 50 | | EventAppeared of 'e 51 | 52 | let createEventStreamerAgent storeEndpoint topicName dispatch = 53 | let body inbox = 54 | let rec loop state = 55 | async { 56 | match state with 57 | | None -> 58 | let! store = GesGateway.create storeEndpoint 59 | let ticksObservable = createBoundedStreamer store topicName 10000 |> AsyncSeq.toObservable 60 | let sub = ticksObservable |> Observable.subscribe (dispatch << EventAppeared) 61 | return! loop <| Some(store, sub) 62 | | Some(store, sub) -> 63 | let! cmd = Agent.receive inbox 64 | match cmd with 65 | | Stop -> 66 | sub.Dispose() 67 | store.Dispose() 68 | } 69 | loop None 70 | Agent.start body 71 | 72 | let inline createCommandHandlerAgent storeEndpoint topic evolve decide = 73 | let body inbox = 74 | let rec loop state = 75 | async { 76 | match state with 77 | | None -> 78 | let! store = GesGateway.create storeEndpoint 79 | return! CommandHandler.ofGesStoreIdempotent store topic evolve decide |> Some |> loop 80 | | Some persistingHandler -> 81 | let! cmd = Agent.receive inbox 82 | do! persistingHandler cmd 83 | } 84 | loop None 85 | Agent.start body -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore/GesGateway.fs: -------------------------------------------------------------------------------- 1 | namespace FunDomain.Persistence.EventStore 2 | 3 | open FunDomain 4 | open System 5 | open System.Net 6 | open EventStore.ClientAPI 7 | 8 | // http://stackoverflow.com/a/23444419/11635 9 | module Async = 10 | let AwaitTaskVoid : Threading.Tasks.Task -> Async = Async.AwaitIAsyncResult >> Async.Ignore 11 | 12 | /// Expose GES 3+'s Task Async (only) operations as F# functions yielding Async<'T> 13 | [] 14 | module private EventStoreExtensions = 15 | type EventStore.ClientAPI.IEventStoreConnection with 16 | member this.AsyncConnect() = Async.AwaitTaskVoid <| this.ConnectAsync() 17 | member this.AsyncAppendToStream stream expectedVersion events = 18 | Async.AwaitTask <| this.AppendToStreamAsync(stream, expectedVersion, events) 19 | member this.AsyncReadStreamEventsForward stream start count resolveLinkTos = 20 | Async.AwaitTask <| this.ReadStreamEventsForwardAsync(stream, start, count, resolveLinkTos) 21 | member this.AsyncSubscribeToAll resolveLinkTos eventAppeared credentials = 22 | Async.AwaitTask <| this.SubscribeToAllAsync(resolveLinkTos, Action<_, _>(eventAppeared), null, credentials) 23 | member this.AsyncSubscribeToStream stream resolveLinkTos onEvent onDrop = 24 | Async.AwaitTask 25 | <| this.SubscribeToStreamAsync(stream, resolveLinkTos, Action<_, _>(onEvent), Action<_, _, _>(onDrop), null) 26 | 27 | // TODO port https://github.com/LogosBible/Logos.Utility/blob/master/src/Logos.Utility/GuidUtility.cs 28 | module DetermisticGuid = 29 | let ofBytes (bytes : byte []) = 30 | use provider = new System.Security.Cryptography.MD5CryptoServiceProvider() 31 | provider.ComputeHash bytes |> Guid 32 | 33 | /// Wrapper yielded by create* functions with create/append functions matching FunDomain.CommandHandler requirements 34 | [] 35 | type Store private (inner') = 36 | // Hoop jumping a la C++ pimpl pattern to avoid foisting an EventStore.Client package reference on consumers 37 | let inner : IEventStoreConnection = unbox inner' 38 | 39 | let toEncodedEvent (e : ResolvedEvent) = 40 | { EventType = e.Event.EventType 41 | Data = e.Event.Data } 42 | 43 | let batchEvent e = EventBatch [| toEncodedEvent e |] 44 | let dispatchTo projection = (fun _ e -> projection <| batchEvent e) 45 | let dispatchWithStreamIdTo projection = (fun s e -> projection s <| batchEvent e) 46 | 47 | let appendWithIdGenerator streamId generator expectedVersion newEncodedEvents = 48 | async { 49 | let isJson, metadata = true, null 50 | let! wr = [| for e in newEncodedEvents -> EventData(generator e.Data, e.EventType, isJson, e.Data, metadata) |] 51 | |> inner.AsyncAppendToStream streamId expectedVersion 52 | return wr.NextExpectedVersion 53 | } 54 | 55 | member this.Dispose() = (this :> IDisposable).Dispose() 56 | 57 | member this.Dispose disposing = 58 | if disposing then inner.Dispose() 59 | 60 | interface IDisposable with 61 | member this.Dispose() = 62 | this.Dispose true 63 | GC.SuppressFinalize this 64 | 65 | static member internal wrap connection = new Store(box connection) 66 | 67 | member this.append streamId = 68 | let ignoreTheData _ = Guid.NewGuid() 69 | appendWithIdGenerator streamId ignoreTheData 70 | 71 | member this.appendIdempotent = appendWithIdGenerator 72 | 73 | member this.read streamId version count = 74 | async { 75 | let! slice = inner.AsyncReadStreamEventsForward streamId version count (*resolveLinkTos*) true 76 | let nextSliceToken = 77 | if slice.IsEndOfStream then None 78 | else Some slice.NextEventNumber 79 | 80 | let events = slice.Events |> Seq.map toEncodedEvent 81 | return events, slice.LastEventNumber, nextSliceToken 82 | } 83 | 84 | member this.subscribeAll (username, password) projection = 85 | inner.AsyncSubscribeToAll (*resolveLinkTos*) true (dispatchWithStreamIdTo projection) 86 | (SystemData.UserCredentials(username, password)) 87 | member this.subscribeStream stream projection = 88 | // 'inspired by' https://gist.github.com/eulerfx/a4a29502f673f13b6a23 89 | let inline onDrop (subs : EventStoreSubscription) (reason : SubscriptionDropReason) (ex : exn) = 90 | printfn "SUBSCRIPTION DROPPED! last position=%O reason=%O ex=%O" subs.LastEventNumber reason ex 91 | inner.AsyncSubscribeToStream stream false (dispatchTo projection) onDrop 92 | 93 | module GesGateway = 94 | let create (tcpEndpoint : IPEndPoint) = 95 | async { 96 | let storeConn = EventStoreConnection.Create tcpEndpoint 97 | do! storeConn.AsyncConnect() 98 | return storeConn |> Store.wrap 99 | } 100 | 101 | module CommandHandler = 102 | let ofGesStore (store : Store) streamId = 103 | CommandHandler.create { read = store.read streamId; append = store.append streamId } 104 | let ofGesStoreIdempotent (store : Store) streamId = 105 | CommandHandler.create { read = store.read streamId; append = store.appendIdempotent streamId DetermisticGuid.ofBytes } -------------------------------------------------------------------------------- /FunDomain.Persistence.EventStore/paket.references: -------------------------------------------------------------------------------- 1 | EventStore.Client 2 | FSharp.Control.AsyncSeq -------------------------------------------------------------------------------- /FunDomain.Persistence.Fixtures/Fixtures.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Persistence.Fixtures 2 | 3 | open FunDomain // CachingEventBatch 4 | open Uno // Card Builders 5 | open Uno.Game // Commands, aggregate 6 | 7 | type FlowEvents = 8 | | DirectionChanged of DirectionChanged 9 | | GameStarted of GameStarted 10 | 11 | type Logger() = 12 | let agent = 13 | MailboxProcessor.Start <| fun inbox -> async { 14 | while true do 15 | let! evt = inbox.Receive () 16 | evt |> function 17 | | GameStarted { GameId = GameId no } -> 18 | printfn "Started: %i" no 19 | | DirectionChanged { GameId = GameId no; Direction = direction } -> 20 | printfn "Game %i direction is now: %A" no direction } 21 | member this.Post = agent.Post 22 | 23 | type DirectionMonitor() = 24 | // NB we can have multiple concurrent readers (+single writer) hence this needs to be a concurrency-safe collection 25 | let gameDirections = System.Collections.Concurrent.ConcurrentDictionary<_,_> () 26 | let agent = 27 | MailboxProcessor.Start <| fun inbox -> async { 28 | while true do 29 | let! evt = inbox.Receive () 30 | evt |> function 31 | | GameStarted e -> gameDirections.[e.GameId] <- ClockWise 32 | | DirectionChanged e -> gameDirections.[e.GameId] <- e.Direction } 33 | member this.Post = agent.Post 34 | member this.CurrentDirectionOfGame gameId = gameDirections.[gameId] 35 | 36 | let establishProjection (monitor:DirectionMonitor) = 37 | let logger = Logger() 38 | 39 | fun (batch:EventBatch) -> 40 | let dispatchFlowEvent evt = 41 | monitor.Post evt 42 | logger.Post evt 43 | batch.mapToUnion () |> Seq.iter dispatchFlowEvent 44 | 45 | let fullCircuitCommands gameId = [ 46 | StartGame { GameId=gameId; PlayerCount=4; FirstCard=red 3 } 47 | PlayCard { GameId=gameId; Player=0; Card=blue 3 } 48 | PlayCard { GameId=gameId; Player=1; Card=blue 8 } 49 | PlayCard { GameId=gameId; Player=2; Card=yellow 8 } 50 | PlayCard { GameId=gameId; Player=3; Card=yellow 4 } 51 | PlayCard { GameId=gameId; Player=0; Card=green 4 } 52 | PlayCard { GameId=gameId; Player=1; Card=KickBack Green } ] 53 | 54 | let gameTopicId (GameId no) = sprintf "Game-%s" <| string no 55 | 56 | let randomGameId () = 57 | let gameNo = System.Random().Next() 58 | GameId gameNo 59 | 60 | let withRetryingAndDelaying maxCount (delayMs:int) assertion = 61 | for count in [ 1..maxCount ] do 62 | try 63 | assertion() 64 | with _ when count <> maxCount -> 65 | System.Threading.Thread.Sleep delayMs -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore.Acceptance/CreateSqlLocalDb.ps1: -------------------------------------------------------------------------------- 1 | # requires SQL Server 2012 LocalDb 2 | SqlLocalDb create UnoNes -s 3 | sqlcmd -S "(localdb)\UnoNes" -E -Q "CREATE DATABASE UnoNes" -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore.Acceptance/EndToEnd.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Persistence.NEventStore.Acceptance.EndToEnd 2 | 3 | open FunDomain.Persistence.Fixtures // fullGameCommands, gameTopicId, randomGameId, establishProjection 4 | open FunDomain.Persistence.NEventStore // Projector, StreamId 5 | open Swensen.Unquote 6 | open Uno // Card Builders 7 | open Uno.Game // Commands, aggregate 8 | open Xunit 9 | 10 | // Shadow with explicit declaration of desired bucketing 11 | let gameTopicId id = 12 | { Bucket = None 13 | StreamId = gameTopicId id } 14 | 15 | let playCircuit (store : Store) = async { 16 | let monitor = DirectionMonitor() 17 | let projection = establishProjection monitor 18 | let projector = Projector(store, 10, projection) 19 | let gameId = randomGameId() 20 | let topicId = gameTopicId gameId 21 | let handle = CommandHandler.ofNes store topicId evolve decide 22 | for cmd in fullCircuitCommands gameId do 23 | printfn "Processing %A against Stream %A" cmd topicId 24 | do! handle cmd 25 | projector.Pulse() 26 | do! Async.AwaitEvent projector.sleeping 27 | printfn "Projection queue empty" 28 | return monitor.CurrentDirectionOfGame gameId } 29 | 30 | [] 31 | let ``Can play a circuit and consume projection using NES InMemory``() = 32 | async { 33 | let store = NesGateway.createInMemory() 34 | let! finalDirection = playCircuit store 35 | test <@ CounterClockWise = finalDirection @> } |> Async.StartAsTask 36 | 37 | // NB Requires a SQL Server Instance with a DB Created 38 | // Any SQL server version will do, but the app.config OOTB will be satisfied if you run ./CreateSqlLocalDb.ps1 39 | [] 40 | let ``Can play a circuit and consume projection using NES SqlPersistence``() = 41 | async { 42 | let connectionStringName = "UnoNes" 43 | let store = NesGateway.createInMsSql connectionStringName 44 | store.executeDdlIfNecessary() 45 | let! finalDirection = playCircuit store 46 | test <@ CounterClockWise = finalDirection @> } |> Async.StartAsTask -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore.Acceptance/FunDomain.Persistence.NEventStore.Acceptance.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | 483336f5-083a-49c1-ae4b-a3e7ddcd3e60 9 | Library 10 | FunDomain.Persistence.NEventStore.Acceptance 11 | FunDomain.Persistence.NEventStore.Acceptance 12 | v4.5 13 | 4.4.0.0 14 | true 15 | FunDomain.Persistence.NEventStore.Acceptance 16 | 17 | 18 | 19 | true 20 | full 21 | false 22 | false 23 | bin\Debug\ 24 | DEBUG;TRACE 25 | 3 26 | bin\Debug\FunDomain.Persistence.NEventStore.Acceptance.XML 27 | 28 | 29 | pdbonly 30 | true 31 | true 32 | bin\Release\ 33 | TRACE 34 | 3 35 | bin\Release\FunDomain.Persistence.NEventStore.Acceptance.XML 36 | 37 | 38 | 11 39 | 40 | 41 | 42 | 43 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 44 | 45 | 46 | 47 | 48 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 49 | 50 | 51 | 52 | 53 | 60 | 61 | 62 | 63 | 64 | 65 | Fixtures.fs 66 | 67 | 68 | 69 | 70 | 71 | Uno 72 | {4ee8261c-4629-4b28-a141-9c210c5235a9} 73 | True 74 | 75 | 76 | True 77 | 78 | 79 | FunDomain.Persistence.NEventStore 80 | {7a26b0dc-7834-497a-9e88-91d1fc15e10b} 81 | True 82 | 83 | 84 | FunDomain 85 | {b163b5c5-e0f9-4c92-a823-612f32d84693} 86 | True 87 | 88 | 89 | 90 | 91 | 92 | 93 | ..\packages\Unquote\lib\net45\Unquote.dll 94 | True 95 | True 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | ..\packages\xunit.abstractions\lib\net35\xunit.abstractions.dll 105 | True 106 | True 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | ..\packages\xunit.assert\lib\portable-net45+win8+wp8+wpa81\xunit.assert.dll 116 | True 117 | True 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | ..\packages\xunit.extensibility.core\lib\portable-net45+win8+wp8+wpa81\xunit.core.dll 127 | True 128 | True 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | ..\packages\xunit.extensibility.execution\lib\net45\xunit.execution.desktop.dll 138 | True 139 | True 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | <__paket__xunit_runner_visualstudio_props>net20\xunit.runner.visualstudio 148 | 149 | 150 | 151 | 152 | -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore.Acceptance/app.config: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore.Acceptance/paket.references: -------------------------------------------------------------------------------- 1 | Unquote 2 | xunit 3 | xunit.runner.visualstudio -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore/FunDomain.Persistence.NEventStore.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | 7a26b0dc-7834-497a-9e88-91d1fc15e10b 9 | Library 10 | FunStore.NEventStore 11 | FunDomain.Persistence.Nes 12 | v4.5 13 | 4.4.0.0 14 | FunDomain.Persistence.NEventStore 15 | 16 | 17 | 18 | 19 | 20 | true 21 | full 22 | false 23 | false 24 | bin\Debug\ 25 | DEBUG;TRACE 26 | 3 27 | bin\Debug\FunStore.NEventStore.XML 28 | 29 | 30 | pdbonly 31 | true 32 | true 33 | bin\Release\ 34 | TRACE 35 | 3 36 | bin\Release\FunStore.NEventStore.XML 37 | 38 | 39 | 11 40 | 41 | 42 | 43 | 44 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 45 | 46 | 47 | 48 | 49 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 50 | 51 | 52 | 53 | 54 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | True 69 | 70 | 71 | FunDomain 72 | {b163b5c5-e0f9-4c92-a823-612f32d84693} 73 | True 74 | 75 | 76 | 77 | 78 | 79 | 80 | ..\packages\NEventStore\lib\net40\NEventStore.dll 81 | True 82 | True 83 | 84 | 85 | 86 | 87 | -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore/NesGateway.fs: -------------------------------------------------------------------------------- 1 | namespace FunDomain.Persistence.NEventStore 2 | 3 | open FunDomain 4 | 5 | open NEventStore 6 | open NEventStore.Persistence 7 | open NEventStore.Persistence.Sql.SqlDialects 8 | 9 | open System 10 | open System.Collections.Generic 11 | 12 | /// Opaque token yielded by Streamer.read and consumed by Streamer.append 13 | type Token = { CommitSequence:int; StreamRevision:int } 14 | 15 | /// Identifier of a stream in NEventStore 16 | type StreamId = { Bucket:string option; StreamId:string } 17 | 18 | type CheckpointToken = { Token:string option } with 19 | static member initial = { Token = None } 20 | 21 | // NB Tuple signature used here is shared with CommandHandler (and GesGateway) 22 | [] 23 | module private EncodedEventMapping = 24 | let toEventMessage { EventType = eventType; Data = data } = 25 | let headers = Dictionary<_,_>(capacity=1) 26 | headers.["type"] <- box eventType 27 | let body = box data 28 | EventMessage(Headers=headers, Body=body) 29 | 30 | let toGatewayEventTypeAndData (commit:ICommit) = 31 | seq { for em in commit.Events -> { EventType = em.Headers.["type"] :?> string; Data = em.Body |> unbox } } 32 | 33 | /// Wrapper yielded by create* functions with create/append functions matching FunDomain.CommandHandler requirements 34 | type Store private (inner') = 35 | // Hoop jumping a la C++ pimpl pattern to avoid foisting an NEventStore package reference consumers 36 | let inner : IPersistStreams = unbox inner' 37 | 38 | let defaultBucket bucketId = defaultArg bucketId "default" 39 | 40 | let load { Bucket=bucketId; StreamId=streamId } minRevision maxRevision = 41 | inner.GetFrom(bucketId |> defaultBucket, streamId, minRevision, maxRevision) 42 | let poll { Token=token } = 43 | inner.GetFrom(defaultArg token null) 44 | let commit attempt = 45 | let commit = inner.Commit attempt 46 | {CommitSequence = commit.CommitSequence; StreamRevision=commit.StreamRevision} 47 | 48 | let (|LastCommit|_|) (commits:ICommit array) = 49 | if commits.Length = 0 then None 50 | else Some <| Seq.last commits 51 | 52 | let (|LastCommitToken|) = function 53 | | LastCommit last -> { CommitSequence = last.CommitSequence; StreamRevision = last.StreamRevision } 54 | | _ -> { CommitSequence = 0; StreamRevision = 0 } 55 | 56 | let readStream streamId minRevision sliceSize = async { 57 | let maxRevision = minRevision + sliceSize - 1 58 | let commits = load streamId minRevision maxRevision |> Array.ofSeq 59 | 60 | return commits |> function 61 | | LastCommitToken token when commits.Length = sliceSize -> 62 | commits, token, Some <| token.StreamRevision + 1 63 | | LastCommitToken token -> 64 | commits, token, None } 65 | 66 | let appendToStream {Bucket=bucketId; StreamId=streamId} streamMeta token encodedEvents = async { 67 | let commitId, commitStamp, commitHeaders = streamMeta 68 | let eventMessages = encodedEvents |> Seq.map toEventMessage 69 | let attempt = 70 | CommitAttempt( 71 | bucketId |> defaultBucket, streamId, 72 | token.StreamRevision + 1, 73 | commitId, 74 | token.CommitSequence + 1, 75 | commitStamp, 76 | commitHeaders, 77 | eventMessages) 78 | return commit attempt } 79 | 80 | let fetch token = async { 81 | return poll token 82 | |> Seq.map (fun commit -> 83 | let token = { Token = Some commit.CheckpointToken } 84 | let encodedEvents = commit |> toGatewayEventTypeAndData 85 | token, encodedEvents) } 86 | 87 | static member internal wrap persister = Store( box persister) 88 | 89 | member this.executeDdlIfNecessary () = inner.Initialize() 90 | 91 | member this.append stream token events = async { 92 | let commitMetadata() = 93 | let commitId = Guid.NewGuid() 94 | let commitDateTime = DateTime.UtcNow 95 | let commitHeaders = null 96 | commitId, commitDateTime, commitHeaders 97 | let metadata = commitMetadata() 98 | return! appendToStream stream metadata token events } 99 | 100 | member this.read stream minRevision sliceSize = async { 101 | let! commits, sliceLastToken, nextMinRevision = readStream stream minRevision sliceSize 102 | let events = commits |> Seq.collect toGatewayEventTypeAndData 103 | return events, sliceLastToken, nextMinRevision } 104 | 105 | member this.project checkpointToken projection = async { 106 | let! batch = fetch checkpointToken 107 | let dispatchElements _ (checkpoint, elements) = 108 | elements |> projection 109 | Some checkpoint 110 | return batch |> Seq.fold dispatchElements None } 111 | 112 | module NesGateway = 113 | let createFromStore (inner:IStoreEvents) = 114 | inner.Advanced |> Store.wrap 115 | 116 | let createInMemory () = 117 | Wireup.Init() 118 | .LogToOutputWindow() 119 | .UsingInMemoryPersistence() 120 | .UsingJsonSerialization() 121 | .Build() 122 | |> createFromStore 123 | 124 | let createInMsSql (connectionName:string) = 125 | Wireup.Init() 126 | .UsingSqlPersistence(connectionName) 127 | .WithDialect(new MsSqlDialect()) 128 | .UsingJsonSerialization() 129 | .Compress() 130 | .Build() 131 | |> createFromStore 132 | 133 | module CommandHandler = 134 | let ofNes (store : Store) streamId = 135 | CommandHandler.create { read = store.read streamId; append = store.append streamId } -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore/Projector.fs: -------------------------------------------------------------------------------- 1 | namespace FunDomain.Persistence.NEventStore 2 | 3 | open FunDomain 4 | 5 | open System.Threading 6 | 7 | type Projector( store:Store, sleepMs, projection ) = 8 | let empty = new Event() 9 | let wakeEvent = new AutoResetEvent false 10 | let _ = 11 | MailboxProcessor.Start <| 12 | fun inbox -> 13 | let rec loop token = async { 14 | let project events = projection <| EventBatch events 15 | let! nextToken = store.project token project 16 | match nextToken with 17 | | Some token -> 18 | return! loop token 19 | | _ -> 20 | empty.Trigger () 21 | let! _ = Async.AwaitWaitHandle (wakeEvent,sleepMs) 22 | return! loop token } 23 | 24 | async { 25 | return! loop CheckpointToken.initial } 26 | member this.sleeping = empty.Publish 27 | member this.Pulse = wakeEvent.Set >> ignore -------------------------------------------------------------------------------- /FunDomain.Persistence.NEventStore/paket.references: -------------------------------------------------------------------------------- 1 | NEventStore -------------------------------------------------------------------------------- /FunDomain.Tests/EventBatchFacts.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Tests.EventBatchFacts 2 | 3 | open FunDomain 4 | 5 | open Xunit 6 | open Swensen.Unquote 7 | 8 | module ``Event types with unique names enlisted into overlapping DUs`` = 9 | type SignificantThingOccurred = { Id:int } 10 | type LoggedIn = { Name:string; Value:string } 11 | type LoggedOut = { Name:string } 12 | 13 | type ProducerEvents = 14 | | ET1 of SignificantThingOccurred 15 | | ET2 of LoggedIn 16 | | ET3 of LoggedOut 17 | 18 | let [] ``Can serialize, emitting item typeName together with a neutral DU body`` () = 19 | let input = ET1 { Id = 5 } 20 | let encoded = EncodedEvent.serializeUnionByCaseItemTypeName input 21 | printfn "%s" <| System.Text.Encoding.Default.GetString encoded.Data 22 | test <@ "SignificantThingOccurred" = encoded.EventType @> 23 | 24 | type UninterestedProjection = 25 | | ET2 of LoggedOut 26 | | ET3 of LoggedIn 27 | 28 | let [] ``deserialize into incompatible DU yields None`` () = 29 | let input = ET1 { Id = 5 } 30 | let encoded = EncodedEvent.serializeUnionByCaseItemTypeName input 31 | test <@ None = encoded.deserializeUnionByCaseItemType () @> 32 | 33 | type CompatibleProjection = 34 | | ET2 of LoggedIn 35 | | ET3 of SignificantThingOccurred 36 | 37 | let [] ``deserialize into compatible DU yields compatible case`` () = 38 | let input = ET1 { Id = 5 } 39 | let encoded = EncodedEvent.serializeUnionByCaseItemTypeName input 40 | let compatible = ET3 { Id = 5 } 41 | test <@ Some compatible = encoded.deserializeUnionByCaseItemType () @> -------------------------------------------------------------------------------- /FunDomain.Tests/FunDomain.Tests.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | 2b266883-0ff6-4f17-9d8b-5f90b6a93b15 9 | Library 10 | FunDomain.Tests 11 | FunDomain.Tests 12 | v4.5 13 | true 14 | 4.4.0.0 15 | FunDomain.Tests 16 | 17 | 18 | 19 | 20 | 21 | true 22 | full 23 | false 24 | false 25 | bin\Debug\ 26 | DEBUG;TRACE 27 | 3 28 | bin\Debug\FunDomain.Tests.XML 29 | 30 | 31 | pdbonly 32 | true 33 | true 34 | bin\Release\ 35 | TRACE 36 | 3 37 | bin\Release\FunDomain.Tests.XML 38 | 39 | 40 | 11 41 | 42 | 43 | 44 | 45 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 46 | 47 | 48 | 49 | 50 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 51 | 52 | 53 | 54 | 55 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | True 72 | 73 | 74 | 75 | FunDomain 76 | {b163b5c5-e0f9-4c92-a823-612f32d84693} 77 | True 78 | 79 | 80 | 81 | 82 | 83 | 84 | ..\packages\Newtonsoft.Json\lib\net45\Newtonsoft.Json.dll 85 | True 86 | True 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | ..\packages\Unquote\lib\net45\Unquote.dll 96 | True 97 | True 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | ..\packages\xunit.abstractions\lib\net35\xunit.abstractions.dll 107 | True 108 | True 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | ..\packages\xunit.assert\lib\portable-net45+win8+wp8+wpa81\xunit.assert.dll 118 | True 119 | True 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | ..\packages\xunit.extensibility.core\lib\portable-net45+win8+wp8+wpa81\xunit.core.dll 129 | True 130 | True 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | ..\packages\xunit.extensibility.execution\lib\net45\xunit.execution.desktop.dll 140 | True 141 | True 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | <__paket__xunit_runner_visualstudio_props>net20\xunit.runner.visualstudio 150 | 151 | 152 | 153 | 154 | -------------------------------------------------------------------------------- /FunDomain.Tests/SerializationFacts.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Tests.SerializationFacts 2 | 3 | open FunDomain.Serialization 4 | 5 | open Newtonsoft.Json 6 | open System.IO 7 | open Xunit 8 | open Swensen.Unquote 9 | 10 | module ``Fixups for JsonNet intrinsic behavior`` = 11 | let serialize converters o = 12 | let serializer = createSerializer converters 13 | use w = new StringWriter() 14 | serializer.Serialize(w, o) 15 | w.ToString() 16 | 17 | let deserialize<'a> converters s = 18 | let serializer = createSerializer converters 19 | use r = new StringReader(s) 20 | serializer.Deserialize<'a>(new JsonTextReader(r)) 21 | 22 | module structs = 23 | type Digit = struct val value:int; new value = { value = value } end 24 | 25 | let [] ``a value should be serialized as its content`` () = 26 | let serialize = serialize [ valueConverter typeof ] 27 | 28 | test <@ "7" = (Digit 7 |> serialize) @> 29 | 30 | let [] ``a value should be deserialized from its content`` () = 31 | let deserialize = deserialize [ valueConverter typeof ] 32 | 33 | test <@ Digit 7 = ("7" |> deserialize) @> 34 | 35 | module ``Single case DUs`` = 36 | type GameId = GameId of int 37 | 38 | let [] ``a single case union should be serialized as its content`` () = 39 | let serialize = serialize [ unionConverter ] 40 | 41 | test <@ "1234" = (GameId 1234 |> serialize) @> 42 | 43 | let [] ``a single case union should be deserialized from its content`` () = 44 | let deserialize = deserialize [ unionConverter ] 45 | 46 | test <@ GameId 1234 = ("1234" |> deserialize) @> -------------------------------------------------------------------------------- /FunDomain.Tests/app.config: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /FunDomain.Tests/packages.config: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | -------------------------------------------------------------------------------- /FunDomain.Tests/paket.references: -------------------------------------------------------------------------------- 1 | Newtonsoft.Json 2 | Unquote 3 | xunit 4 | xunit.runner.visualstudio -------------------------------------------------------------------------------- /FunDomain.sln: -------------------------------------------------------------------------------- 1 |  2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio 14 4 | VisualStudioVersion = 14.0.24720.0 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{E6B5B493-7BD0-46F3-A52B-25698A127BC3}" 7 | ProjectSection(SolutionItems) = preProject 8 | paket.dependencies = paket.dependencies 9 | paket.lock = paket.lock 10 | EndProjectSection 11 | EndProject 12 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FunDomain.Persistence.NEventStore", "FunDomain.Persistence.NEventStore\FunDomain.Persistence.NEventStore.fsproj", "{7A26B0DC-7834-497A-9E88-91D1FC15E10B}" 13 | EndProject 14 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FunDomain.Persistence.NEventStore.Acceptance", "FunDomain.Persistence.NEventStore.Acceptance\FunDomain.Persistence.NEventStore.Acceptance.fsproj", "{483336F5-083A-49C1-AE4B-A3E7DDCD3E60}" 15 | EndProject 16 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FunDomain", "FunDomain\FunDomain.fsproj", "{B163B5C5-E0F9-4C92-A823-612F32D84693}" 17 | EndProject 18 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Uno", "Samples\Uno\Uno.fsproj", "{4EE8261C-4629-4B28-A141-9C210C5235A9}" 19 | EndProject 20 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Uno.Tests", "Samples\Uno.Tests\Uno.Tests.fsproj", "{4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}" 21 | EndProject 22 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FunDomain.Tests", "FunDomain.Tests\FunDomain.Tests.fsproj", "{2B266883-0FF6-4F17-9D8B-5F90B6A93B15}" 23 | EndProject 24 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FunDomain.Persistence.EventStore", "FunDomain.Persistence.EventStore\FunDomain.Persistence.EventStore.fsproj", "{7F6B835C-7627-46A8-88DD-AF4C9EADA0EE}" 25 | EndProject 26 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FunDomain.Persistence.EventStore.Acceptance", "FunDomain.Persistence.EventStore.Acceptance\FunDomain.Persistence.EventStore.Acceptance.fsproj", "{55B61236-4168-4FA8-92E3-D298897F1979}" 27 | EndProject 28 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{B827F641-0ED0-474D-94FB-03BD85071E83}" 29 | ProjectSection(SolutionItems) = preProject 30 | .gitattributes = .gitattributes 31 | .gitignore = .gitignore 32 | README.md = README.md 33 | EndProjectSection 34 | EndProject 35 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".build", ".build", "{11FD159C-B533-4EAB-869E-615A29E84B6E}" 36 | ProjectSection(SolutionItems) = preProject 37 | build.cmd = build.cmd 38 | build.fsx = build.fsx 39 | EndProjectSection 40 | EndProject 41 | Global 42 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 43 | Debug|Any CPU = Debug|Any CPU 44 | Release|Any CPU = Release|Any CPU 45 | EndGlobalSection 46 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 47 | {7A26B0DC-7834-497A-9E88-91D1FC15E10B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 48 | {7A26B0DC-7834-497A-9E88-91D1FC15E10B}.Debug|Any CPU.Build.0 = Debug|Any CPU 49 | {7A26B0DC-7834-497A-9E88-91D1FC15E10B}.Release|Any CPU.ActiveCfg = Release|Any CPU 50 | {7A26B0DC-7834-497A-9E88-91D1FC15E10B}.Release|Any CPU.Build.0 = Release|Any CPU 51 | {483336F5-083A-49C1-AE4B-A3E7DDCD3E60}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 52 | {483336F5-083A-49C1-AE4B-A3E7DDCD3E60}.Debug|Any CPU.Build.0 = Debug|Any CPU 53 | {483336F5-083A-49C1-AE4B-A3E7DDCD3E60}.Release|Any CPU.ActiveCfg = Release|Any CPU 54 | {483336F5-083A-49C1-AE4B-A3E7DDCD3E60}.Release|Any CPU.Build.0 = Release|Any CPU 55 | {B163B5C5-E0F9-4C92-A823-612F32D84693}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 56 | {B163B5C5-E0F9-4C92-A823-612F32D84693}.Debug|Any CPU.Build.0 = Debug|Any CPU 57 | {B163B5C5-E0F9-4C92-A823-612F32D84693}.Release|Any CPU.ActiveCfg = Release|Any CPU 58 | {B163B5C5-E0F9-4C92-A823-612F32D84693}.Release|Any CPU.Build.0 = Release|Any CPU 59 | {4EE8261C-4629-4B28-A141-9C210C5235A9}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 60 | {4EE8261C-4629-4B28-A141-9C210C5235A9}.Debug|Any CPU.Build.0 = Debug|Any CPU 61 | {4EE8261C-4629-4B28-A141-9C210C5235A9}.Release|Any CPU.ActiveCfg = Release|Any CPU 62 | {4EE8261C-4629-4B28-A141-9C210C5235A9}.Release|Any CPU.Build.0 = Release|Any CPU 63 | {4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 64 | {4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}.Debug|Any CPU.Build.0 = Debug|Any CPU 65 | {4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}.Release|Any CPU.ActiveCfg = Release|Any CPU 66 | {4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}.Release|Any CPU.Build.0 = Release|Any CPU 67 | {2B266883-0FF6-4F17-9D8B-5F90B6A93B15}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 68 | {2B266883-0FF6-4F17-9D8B-5F90B6A93B15}.Debug|Any CPU.Build.0 = Debug|Any CPU 69 | {2B266883-0FF6-4F17-9D8B-5F90B6A93B15}.Release|Any CPU.ActiveCfg = Release|Any CPU 70 | {2B266883-0FF6-4F17-9D8B-5F90B6A93B15}.Release|Any CPU.Build.0 = Release|Any CPU 71 | {7F6B835C-7627-46A8-88DD-AF4C9EADA0EE}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 72 | {7F6B835C-7627-46A8-88DD-AF4C9EADA0EE}.Debug|Any CPU.Build.0 = Debug|Any CPU 73 | {7F6B835C-7627-46A8-88DD-AF4C9EADA0EE}.Release|Any CPU.ActiveCfg = Release|Any CPU 74 | {7F6B835C-7627-46A8-88DD-AF4C9EADA0EE}.Release|Any CPU.Build.0 = Release|Any CPU 75 | {55B61236-4168-4FA8-92E3-D298897F1979}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 76 | {55B61236-4168-4FA8-92E3-D298897F1979}.Debug|Any CPU.Build.0 = Debug|Any CPU 77 | {55B61236-4168-4FA8-92E3-D298897F1979}.Release|Any CPU.ActiveCfg = Release|Any CPU 78 | {55B61236-4168-4FA8-92E3-D298897F1979}.Release|Any CPU.Build.0 = Release|Any CPU 79 | EndGlobalSection 80 | GlobalSection(SolutionProperties) = preSolution 81 | HideSolutionNode = FALSE 82 | EndGlobalSection 83 | EndGlobal 84 | -------------------------------------------------------------------------------- /FunDomain/CommandHandler.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.CommandHandler 2 | 3 | // Reading 4 | 5 | type StreamReader<'token> = int -> int -> Async 6 | 7 | let inline load 8 | (read : StreamReader<'token>) 9 | (evolve : 'state -> 'event -> 'state) 10 | (initialState : 'state) : Async<'token*'state> = 11 | let rec fold version currentState = 12 | async { 13 | let sliceSize = 500 14 | let! encodedEvents, token, nextVersion = read version sliceSize 15 | let updatedState = 16 | encodedEvents 17 | |> Seq.choose EncodedEvent.deserializeUnionByCaseItemTypeName<'event> 18 | |> Seq.fold evolve currentState 19 | match nextVersion with 20 | | Some minVersion -> return! fold minVersion updatedState 21 | | None -> return token, updatedState } 22 | fold 0 initialState 23 | 24 | // Appending 25 | 26 | type StreamAppender<'token> = 'token -> EncodedEvent seq -> Async<'token> 27 | 28 | let inline save (append : StreamAppender<'token>) (token : 'token) = 29 | List.map EncodedEvent.serializeUnionByCaseItemTypeName 30 | >> append token 31 | 32 | // Deciding 33 | 34 | type Streamer<'token> = 35 | { read : StreamReader<'token> 36 | append : StreamAppender<'token> } 37 | 38 | let inline create 39 | { read = read; append = append } 40 | (evolve : 'state option -> 'event -> 'state option) 41 | (decide : 'state option -> 'command -> 'event list) 42 | command = async { 43 | let! token, initialState = load read evolve None 44 | let decision = decide initialState command 45 | do! save append token decision |> Async.Ignore } -------------------------------------------------------------------------------- /FunDomain/EncodedEvent.fs: -------------------------------------------------------------------------------- 1 | namespace FunDomain 2 | 3 | open FunDomain.Serialization 4 | 5 | open Microsoft.FSharp.Reflection 6 | open Newtonsoft.Json 7 | open System.IO 8 | 9 | type EncodedEvent = { EventType:string; Data:byte[] } with 10 | member this.deserializeUnionByCaseItemType<'a> () = 11 | let isItemOfEventType (case:UnionCaseInfo) = 12 | let item = case.GetFields() |> Seq.exactlyOne 13 | item.PropertyType.Name = this.EventType 14 | 15 | FSharpType.GetUnionCases(typeof<'a>) 16 | |> Array.tryFind isItemOfEventType 17 | |> Option.map (fun case -> 18 | let serializer = createUnionSerializer<'a> case 19 | use stream = new MemoryStream(this.Data) 20 | use reader = new JsonTextReader(new StreamReader(stream)) 21 | serializer.Deserialize<'a>(reader)) 22 | 23 | [] 24 | module EncodedEvent = 25 | let serializeUnionByCaseItemTypeName (o:'a) = 26 | let case,fields = FSharpValue.GetUnionFields(o, typeof<'a>) 27 | let serializer = createUnionSerializer<'a> case 28 | use stream = new MemoryStream() 29 | use writer = new StreamWriter(stream) 30 | let item = fields |> Seq.exactlyOne 31 | serializer.Serialize(writer, o) 32 | writer.Flush() 33 | { EventType = item.GetType().Name; Data = stream.ToArray() } 34 | 35 | let deserializeUnionByCaseItemTypeName<'e> (event:EncodedEvent) = 36 | event.deserializeUnionByCaseItemType<'e> () -------------------------------------------------------------------------------- /FunDomain/EventBatch.fs: -------------------------------------------------------------------------------- 1 | namespace FunDomain 2 | 3 | type EventBatch(encodedEvents) = 4 | let cached = Seq.cache encodedEvents 5 | member this.mapToUnion<'e> () = 6 | cached |> Seq.choose EncodedEvent.deserializeUnionByCaseItemTypeName<'e> -------------------------------------------------------------------------------- /FunDomain/FunDomain.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | b163b5c5-e0f9-4c92-a823-612f32d84693 9 | Library 10 | FunDomain 11 | FunDomain 12 | v4.5 13 | 4.4.0.0 14 | FunDomain 15 | 16 | 17 | true 18 | full 19 | false 20 | false 21 | bin\Debug\ 22 | DEBUG;TRACE 23 | 3 24 | bin\Debug\FunDomain.XML 25 | 26 | 27 | pdbonly 28 | true 29 | true 30 | bin\Release\ 31 | TRACE 32 | 3 33 | bin\Release\FunDomain.XML 34 | 35 | 36 | 11 37 | 38 | 39 | 40 | 41 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 42 | 43 | 44 | 45 | 46 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 47 | 48 | 49 | 50 | 51 | 58 | 59 | 60 | Serialization.fs 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | True 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | ..\packages\Newtonsoft.Json\lib\net45\Newtonsoft.Json.dll 78 | True 79 | True 80 | 81 | 82 | 83 | 84 | -------------------------------------------------------------------------------- /FunDomain/Serialization.fs: -------------------------------------------------------------------------------- 1 | module FunDomain.Serialization 2 | 3 | // This module provides Json serialization to store 4 | // events in the event store 5 | 6 | // It is based on Json.net but provides 7 | // a specialization for cleaner F# type serialization 8 | 9 | open System 10 | open System.Reflection 11 | open Newtonsoft.Json 12 | open Microsoft.FSharp.Reflection 13 | 14 | // Basic reflection for converters 15 | module private Reflection = 16 | let isGeneric td (t:Type) = 17 | t.IsGenericType && t.GetGenericTypeDefinition() = td 18 | 19 | let isList t = isGeneric typedefof> t 20 | let isOption t = isGeneric typedefof> t 21 | 22 | let propertyName (case: PropertyInfo) = case.Name 23 | 24 | let (|NamedCase|UnionCase|SingleCase|) v = 25 | let t = v.GetType() 26 | match FSharpValue.GetUnionFields(v, t) with 27 | | case, [||] -> NamedCase case.Name 28 | | case, values -> 29 | let names = 30 | case.GetFields() 31 | |> Seq.map propertyName 32 | let values = Seq.zip names values |> Seq.toList 33 | match values with 34 | | [ value ] when FSharpType.GetUnionCases(t).Length = 1 -> 35 | SingleCase(case.Name, value) 36 | | _ -> UnionCase(case.Name, values) 37 | 38 | let getCase t caseName = 39 | FSharpType.GetUnionCases(t) 40 | |> Array.find (fun c -> c.Name = caseName) 41 | let getFields (case: UnionCaseInfo) = 42 | case.GetFields() 43 | |> Array.mapi (fun i c -> c.Name, (i,c.PropertyType)) 44 | |> Map.ofArray 45 | 46 | /// Returns all value type containing a single property from 47 | /// specified assembly 48 | let getValues (assembly: Assembly) = 49 | let isStruct (t: Type) = t.IsValueType 50 | let hasOneProperty (t: Type) = Array.length (t.GetProperties()) = 1 51 | assembly.GetTypes() 52 | |> Seq.filter isStruct 53 | |> Seq.filter hasOneProperty 54 | 55 | 56 | // Json function used by converters 57 | module private Json = 58 | let writeObject (w: JsonWriter) (s: JsonSerializer) properties = 59 | let writeProperty (name, value) = 60 | w.WritePropertyName(name) 61 | s.Serialize(w, value) 62 | w.WriteStartObject() 63 | List.iter writeProperty properties 64 | w.WriteEndObject() 65 | 66 | let read (r: JsonReader) = r.Read() |> ignore 67 | 68 | let deserializeField (r: JsonReader) (s:JsonSerializer) case = 69 | let fieldMap = Reflection.getFields case 70 | fun () -> 71 | let fieldName = string r.Value 72 | read r 73 | let i, fieldType = Map.find fieldName fieldMap 74 | let prop = i, s.Deserialize(r, fieldType) 75 | read r 76 | prop 77 | 78 | let readCaseName (r: JsonReader) shouldSkip = 79 | if r.TokenType = JsonToken.PropertyName then 80 | read r 81 | 82 | let name = string r.Value 83 | if shouldSkip then 84 | read r 85 | name 86 | 87 | let deserializeUnion (r: JsonReader) (s:JsonSerializer) (t: Type) getCase = 88 | if r.TokenType = JsonToken.StartObject then 89 | read r 90 | let case = getCase r true 91 | 92 | 93 | let deserializeField = case |> deserializeField r s 94 | 95 | let rec loop values = 96 | if r.TokenType = JsonToken.EndObject then 97 | values 98 | else 99 | let fieldValue = deserializeField() 100 | loop (fieldValue :: values) 101 | 102 | let values = 103 | loop [] 104 | |> Seq.sortBy fst 105 | |> Seq.map snd 106 | |> Seq.toArray 107 | 108 | FSharpValue.MakeUnion(case,values) 109 | else 110 | match FSharpType.GetUnionCases t with 111 | | [| case |] when case.GetFields().Length = 1 -> 112 | FSharpValue.MakeUnion(case, [| s.Deserialize(r, case.GetFields().[0].PropertyType) |]) 113 | | _ -> 114 | let case = getCase r false 115 | FSharpValue.MakeUnion(case, null) 116 | 117 | open Reflection 118 | 119 | // This converter reads/writes a discriminated union 120 | // as a record, adding a "_Case" field. 121 | let unionConverter = 122 | { new JsonConverter() with 123 | member this.WriteJson(w,v,s) = 124 | match v with 125 | | NamedCase name -> w.WriteValue name 126 | | SingleCase(name, (_,fieldValue)) -> s.Serialize(w,fieldValue) 127 | | UnionCase(name, fields) -> 128 | ("_Case", box name) :: fields 129 | |> Json.writeObject w s 130 | 131 | member this.ReadJson(r,t,v,s) = 132 | Json.deserializeUnion r s t (fun r s -> Json.readCaseName r s |> Reflection.getCase t) 133 | 134 | member this.CanConvert t = 135 | FSharpType.IsUnion t && not (isList t || isOption t) } 136 | 137 | // This converter reads/writes a discriminated union 138 | // but doesn't serialize the case. It is intended to be 139 | // stored in the EventType of the event store. 140 | let private rootUnionConverter<'a> (case: UnionCaseInfo) = 141 | { new JsonConverter() with 142 | member this.WriteJson(w,v,s) = 143 | match v with 144 | | NamedCase _ -> () 145 | | SingleCase(_, (_,value)) -> s.Serialize(w, value) 146 | | UnionCase(_, fields) -> 147 | fields 148 | |> Json.writeObject w s 149 | 150 | member this.ReadJson(r,t,v,s) = 151 | Json.deserializeUnion r s t (fun _ _ -> case) 152 | 153 | member this.CanConvert t = 154 | t = typeof<'a> || t.BaseType = typeof<'a> } 155 | 156 | // This converter writes options as value or null 157 | let private optionConverter = 158 | { new JsonConverter() with 159 | member this.WriteJson(w,v,s) = 160 | match FSharpValue.GetUnionFields(v,v.GetType()) with 161 | | _, [|v|] -> s.Serialize(w, v) 162 | | _ -> w.WriteNull() 163 | 164 | member this.ReadJson(r,t,v,s) = 165 | let optionType = 166 | match t.GetGenericArguments() with 167 | | [|o|] -> o 168 | | _ -> failwith "Option should have a single generic argument" 169 | let cases = FSharpType.GetUnionCases(t) 170 | 171 | if r.TokenType = JsonToken.Null then 172 | FSharpValue.MakeUnion(cases.[0], null) 173 | else 174 | FSharpValue.MakeUnion(cases.[1], [| s.Deserialize(r,optionType) |]) 175 | 176 | member this.CanConvert t = isOption t } 177 | 178 | /// Serializes a value type containing a single property 179 | /// as its inner value. It is used for digit and GameId 180 | let valueConverter (valueType: Type) = 181 | let field = 182 | match valueType.GetProperties() with 183 | | [| p |] -> p 184 | | _ -> invalidArg "valueType" "The type passed to valueConverter should have a single property" 185 | let innerType = field.PropertyType 186 | let ctor = valueType.GetConstructor [| innerType |] 187 | { new JsonConverter() with 188 | member this.WriteJson(w,v,s) = 189 | s.Serialize(w, field.GetValue(v)) 190 | member this.ReadJson(r,t,v,s) = 191 | ctor.Invoke([| s.Deserialize(r, innerType) |]) 192 | member this.CanConvert t = t = valueType } 193 | 194 | let converters<'a> = 195 | let valueConverters = 196 | getValues typeof<'a>.Assembly 197 | |> Seq.map valueConverter 198 | |> Seq.toList 199 | [ unionConverter; optionConverter] 200 | @ valueConverters 201 | 202 | let createSerializer converters = 203 | let serializer = new JsonSerializer() 204 | converters |> List.iter serializer.Converters.Add 205 | serializer 206 | 207 | let createUnionSerializer<'a> (case:UnionCaseInfo) = 208 | createSerializer <| rootUnionConverter<'a> case :: converters<'a> 209 | // 210 | //let deserializeUnion<'a> eventType data = 211 | // FSharpType.GetUnionCases(typeof<'a>) 212 | // |> Array.tryFind (fun c -> c.Name = eventType) 213 | // |> Option.map (fun case -> 214 | // let serializer = createUnionSerializer<'a> case 215 | // use stream = new IO.MemoryStream(data: byte[]) 216 | // use reader = new JsonTextReader(new IO.StreamReader(stream)) 217 | // serializer.Deserialize<'a>(reader)) 218 | // 219 | //let serializeUnion (o:'a) = 220 | // let case,_ = FSharpValue.GetUnionFields(o, typeof<'a>) 221 | // let serializer = createUnionSerializer<'a> case 222 | // use stream = new IO.MemoryStream() 223 | // use writer = new IO.StreamWriter(stream) 224 | // serializer.Serialize(writer, o) 225 | // writer.Flush() 226 | // case.Name, stream.ToArray() -------------------------------------------------------------------------------- /FunDomain/paket.references: -------------------------------------------------------------------------------- 1 | Newtonsoft.Json -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, bartelink 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of the {organization} nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bartelink/FunDomain/1069756192f1a5e3c4b40845d8f5115bdea4ee61/README.md -------------------------------------------------------------------------------- /Samples/Uno.Tests/Uno.Tests.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | 4bc74eb0-b9f1-4cfb-a4f1-c85505bd8698 9 | Library 10 | Uno.Tests 11 | Uno.Tests 12 | v4.5 13 | 4.4.0.0 14 | Uno.Tests 15 | true 16 | 17 | 18 | true 19 | full 20 | false 21 | false 22 | bin\Debug\ 23 | DEBUG;TRACE 24 | 3 25 | bin\Debug\Uno.Tests.XML 26 | 27 | 28 | pdbonly 29 | true 30 | true 31 | bin\Release\ 32 | TRACE 33 | 3 34 | bin\Release\Uno.Tests.XML 35 | 36 | 37 | 11 38 | 39 | 40 | 41 | 42 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 43 | 44 | 45 | 46 | 47 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 48 | 49 | 50 | 51 | 52 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | True 69 | 70 | 71 | FunDomain 72 | {b163b5c5-e0f9-4c92-a823-612f32d84693} 73 | True 74 | 75 | 76 | Uno 77 | {4ee8261c-4629-4b28-a141-9c210c5235a9} 78 | True 79 | 80 | 81 | 82 | 83 | 84 | 85 | ..\..\packages\Unquote\lib\net45\Unquote.dll 86 | True 87 | True 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | ..\..\packages\xunit.abstractions\lib\net35\xunit.abstractions.dll 97 | True 98 | True 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | ..\..\packages\xunit.assert\lib\portable-net45+win8+wp8+wpa81\xunit.assert.dll 108 | True 109 | True 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | ..\..\packages\xunit.extensibility.core\lib\portable-net45+win8+wp8+wpa81\xunit.core.dll 119 | True 120 | True 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | ..\..\packages\xunit.extensibility.execution\lib\net45\xunit.execution.desktop.dll 130 | True 131 | True 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | <__paket__xunit_runner_visualstudio_props>net20\xunit.runner.visualstudio 140 | 141 | 142 | 143 | 144 | -------------------------------------------------------------------------------- /Samples/Uno.Tests/When playing a second turn.fs: -------------------------------------------------------------------------------- 1 | module Uno.Tests.``When playing a second turn`` 2 | 3 | open Uno // UL 4 | open Game // direct access to our SUT 5 | 6 | open Swensen.Unquote 7 | open Xunit 8 | 9 | let run = Seq.fold evolve None >> decide 10 | let gameId = GameId 1 11 | 12 | let context = [ 13 | GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = red 3; FirstPlayer = 0 } 14 | CardPlayed { GameId = gameId; Player = 0; Card = red 9; NextPlayer = 1 } ] 15 | 16 | let [] ``Same color should be accepted``() = 17 | test <@ context |> run <| PlayCard { GameId = gameId; Player = 1; Card = red 8 } 18 | = [ CardPlayed { GameId = gameId; Player = 1; Card = red 8; NextPlayer = 2 } ] @> 19 | 20 | let [] ``Same value should be accepted``() = 21 | test <@ context |> run <| PlayCard { GameId = gameId; Player = 1; Card = yellow 9 } 22 | = [ CardPlayed { GameId = gameId; Player = 1; Card = yellow 9; NextPlayer = 2 } ] @> 23 | 24 | let [] ``Different value and color should be rejected``() = 25 | test <@ context |> run <| PlayCard { GameId = gameId; Player = 1; Card = yellow 8 } 26 | = [ PlayedWrongCard { GameId = gameId; Player = 1; Card = yellow 8}] @> 27 | 28 | let [] ``Player should play at his turn``() = 29 | test <@ context |> run <| PlayCard { GameId = gameId; Player = 2; Card = green 9 } 30 | = [ PlayedAtWrongTurn { GameId = gameId; Player = 2; Card = green 9 }] @> 31 | 32 | let [] ``After a full round it should be player 0 turn``() = 33 | test <@ [ GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = red 3; FirstPlayer = 0 } 34 | CardPlayed { GameId = gameId; Player = 0; Card = red 9; NextPlayer = 1 } 35 | CardPlayed { GameId = gameId; Player = 1; Card = red 8; NextPlayer = 2 } 36 | CardPlayed { GameId = gameId; Player = 2; Card = red 6; NextPlayer = 3 } ] 37 | |> run <| PlayCard { GameId = gameId; Player = 3; Card = red 1 } 38 | = [ CardPlayed { GameId = gameId; Player = 3; Card = red 1; NextPlayer = 0 } ] @> 39 | -------------------------------------------------------------------------------- /Samples/Uno.Tests/When playing card.fs: -------------------------------------------------------------------------------- 1 | module Uno.Tests.``When playing card`` 2 | 3 | open Uno // UL 4 | open Game // direct access to our SUT 5 | 6 | open Swensen.Unquote 7 | open Xunit 8 | 9 | let run = Seq.fold evolve None >> decide 10 | let gameId = GameId 1 11 | let context = [ GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = red 3; FirstPlayer = 0 }] 12 | 13 | let [] ``Same color should be accepted``() = 14 | test <@ context |> run <| PlayCard { GameId = gameId; Player = 0; Card = red 9 } 15 | = [ CardPlayed { GameId = gameId; Player = 0; Card = red 9; NextPlayer = 1 } ] @> 16 | 17 | let [] ``Same value should be accepted``() = 18 | test <@ context |> run <| PlayCard { GameId = gameId; Player = 0; Card = yellow 3 } 19 | = [ CardPlayed { GameId = gameId; Player = 0; Card = yellow 3; NextPlayer = 1 } ] @> 20 | 21 | let [] ``Different value and color should be rejected``() = 22 | test <@ context |> run <| PlayCard { GameId = gameId; Player = 0; Card = yellow 8 } 23 | = [ PlayedWrongCard { GameId = gameId; Player = 0; Card = yellow 8}] @> 24 | 25 | let [] ``First player should play at his turn``() = 26 | test <@ context |> run <| PlayCard { GameId = gameId; Player = 2; Card = green 3 } 27 | = [ PlayedAtWrongTurn { GameId = gameId; Player = 2; Card = green 3 } ] @> 28 | 29 | let [] ``First player player after starting with kickback should be the dealer, next one should be on the right`` () = 30 | test <@ [ GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = KickBack Green; FirstPlayer = 0 } 31 | DirectionChanged { GameId = gameId; Direction = CounterClockWise } ] 32 | |> run <| PlayCard { GameId = gameId; Player = 0; Card = green 3 } 33 | = [ CardPlayed { GameId = gameId; Player = 0; Card = green 3; NextPlayer = 3 }] @> 34 | 35 | let [] ``First player player after starting with skip should be the one after the dealer``() = 36 | test <@ [ GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = Skip Green; FirstPlayer = 1 } ] 37 | |> run <| PlayCard { GameId = gameId; Player = 1; Card = green 3 } 38 | = [ CardPlayed { GameId = gameId; Player = 1; Card = green 3; NextPlayer = 2 } ] @> -------------------------------------------------------------------------------- /Samples/Uno.Tests/When starting game.fs: -------------------------------------------------------------------------------- 1 | module Uno.Tests.``When starting game`` 2 | 3 | open Uno // UL 4 | open Game // direct access to our SUT 5 | 6 | open Swensen.Unquote 7 | open System 8 | open Xunit 9 | 10 | let run = Seq.fold evolve None >> decide 11 | let gameId = GameId 1 12 | 13 | let [] ``Started game should be started``() = 14 | test <@ [] |> run <| StartGame { GameId = gameId; PlayerCount = 4; FirstCard = red 3 } 15 | = [ GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = red 3; FirstPlayer = 0 } ] @> 16 | 17 | let [] ``0 players should be rejected``() = 18 | <@ [] |> run <| StartGame { GameId = gameId; PlayerCount = 0; FirstCard = red 3 } @> 19 | |> raises 20 | 21 | let [] ``Game should not be started twice``() = 22 | <@ [ GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = red 3; FirstPlayer = 0 } ] 23 | |> run <| StartGame { GameId = gameId; PlayerCount = 4; FirstCard = red 2 } @> 24 | |> raises 25 | 26 | let [] ``Starting with a kickback should change direction``() = 27 | test <@ [] |> run <| StartGame { GameId = gameId; PlayerCount = 4; FirstCard = KickBack Yellow } 28 | = [ GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = KickBack Yellow; FirstPlayer = 0} 29 | DirectionChanged { GameId = gameId; Direction = CounterClockWise } ] @> 30 | 31 | let [] ``Starting with a skip should skip dealer's turn``() = 32 | test <@ [] |> run <| StartGame { GameId = gameId; PlayerCount = 4; FirstCard = Skip Yellow } 33 | = [ GameStarted { GameId = gameId; PlayerCount = 4; FirstCard = Skip Yellow; FirstPlayer = 1} ] @> -------------------------------------------------------------------------------- /Samples/Uno.Tests/app.config: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /Samples/Uno.Tests/paket.references: -------------------------------------------------------------------------------- 1 | Unquote 2 | xunit 3 | xunit.runner.visualstudio -------------------------------------------------------------------------------- /Samples/Uno.sln: -------------------------------------------------------------------------------- 1 |  2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio 2013 4 | VisualStudioVersion = 12.0.30501.0 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = ".paket", ".paket", "{A5890975-E0BD-41B8-8ED5-5398F38ED747}" 7 | ProjectSection(SolutionItems) = preProject 8 | ..\paket.dependencies = ..\paket.dependencies 9 | EndProjectSection 10 | EndProject 11 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Uno", "Uno\Uno.fsproj", "{4EE8261C-4629-4B28-A141-9C210C5235A9}" 12 | EndProject 13 | Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Uno.Tests", "Uno.Tests\Uno.Tests.fsproj", "{4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}" 14 | EndProject 15 | Global 16 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 17 | Debug|Any CPU = Debug|Any CPU 18 | Release|Any CPU = Release|Any CPU 19 | EndGlobalSection 20 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 21 | {4EE8261C-4629-4B28-A141-9C210C5235A9}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 22 | {4EE8261C-4629-4B28-A141-9C210C5235A9}.Debug|Any CPU.Build.0 = Debug|Any CPU 23 | {4EE8261C-4629-4B28-A141-9C210C5235A9}.Release|Any CPU.ActiveCfg = Release|Any CPU 24 | {4EE8261C-4629-4B28-A141-9C210C5235A9}.Release|Any CPU.Build.0 = Release|Any CPU 25 | {4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 26 | {4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}.Debug|Any CPU.Build.0 = Debug|Any CPU 27 | {4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}.Release|Any CPU.ActiveCfg = Release|Any CPU 28 | {4BC74EB0-B9F1-4CFB-A4F1-C85505BD8698}.Release|Any CPU.Build.0 = Release|Any CPU 29 | EndGlobalSection 30 | GlobalSection(SolutionProperties) = preSolution 31 | HideSolutionNode = FALSE 32 | EndGlobalSection 33 | EndGlobal 34 | -------------------------------------------------------------------------------- /Samples/Uno/Builders.fs: -------------------------------------------------------------------------------- 1 | namespace Uno 2 | 3 | [] 4 | module Builders = 5 | let digit value color = 6 | if value < 0 || value > 9 then invalidArg "value" "A digit value should be from 0 to 9" 7 | DigitCard( value |> Digit,color) 8 | 9 | let red n = digit n Red 10 | let green n = digit n Green 11 | let blue n = digit n Blue 12 | let yellow n = digit n Yellow -------------------------------------------------------------------------------- /Samples/Uno/Game.fs: -------------------------------------------------------------------------------- 1 | module Uno.Game 2 | 3 | //////////////////////////////////////////////////////////////////////////////// 4 | // Event Contracts 5 | 6 | type Direction = 7 | | ClockWise 8 | | CounterClockWise 9 | 10 | // Events 11 | type GameStarted = { GameId:GameId; PlayerCount:int; FirstCard:Card; FirstPlayer:int } 12 | type CardPlayed = { GameId:GameId; Player:int; Card:Card; NextPlayer:int } 13 | type PlayedAtWrongTurn = { GameId:GameId; Player:int; Card:Card } 14 | type PlayedWrongCard = { GameId:GameId; Player:int; Card:Card } 15 | type DirectionChanged = { GameId:GameId; Direction:Direction } 16 | 17 | type Event = 18 | | GameStarted of GameStarted 19 | | CardPlayed of CardPlayed 20 | | PlayedAtWrongTurn of PlayedAtWrongTurn 21 | | PlayedWrongCard of PlayedWrongCard 22 | | DirectionChanged of DirectionChanged 23 | 24 | //////////////////////////////////////////////////////////////////////////////// 25 | // Inferences per Event 26 | 27 | type Inference = 28 | | Started of firstPlayer:int * playerCount:int * card:Card 29 | | Played of Card 30 | | NextIs of int 31 | | DirectionBecomes of Direction 32 | 33 | let infer : Event -> Inference list = function 34 | | GameStarted e -> [Started (e.FirstPlayer, e.PlayerCount, e.FirstCard)] 35 | | CardPlayed e -> [Played e.Card; NextIs e.NextPlayer] 36 | | PlayedAtWrongTurn _ 37 | | PlayedWrongCard _ -> [] 38 | | DirectionChanged e -> [DirectionBecomes e.Direction] 39 | 40 | //////////////////////////////////////////////////////////////////////////////// 41 | // State / Evolution function for folding inference into same 42 | 43 | type Turn = 44 | { Player : int 45 | PlayerCount : int 46 | Direction : Direction } 47 | 48 | type State = 49 | { Turn : Turn 50 | TopCard : Card } 51 | 52 | let evolve': State option -> Inference -> State option = function 53 | | None -> 54 | function 55 | | Started (firstPlayer=firstPlayer; playerCount=playerCount; card=card) -> 56 | { TopCard = card 57 | Turn = { Turn.Player = firstPlayer 58 | PlayerCount = playerCount 59 | Direction = ClockWise } } 60 | | _ -> failwith "malformed event stream; expecting Start" 61 | >> Some 62 | | Some ({Turn = t} as s) -> 63 | function 64 | | Started _ -> failwith "illegal restart" 65 | | Played c -> 66 | { s with TopCard = c } 67 | | DirectionBecomes d -> 68 | { s with Turn = { t with Direction = d } } 69 | | NextIs p -> 70 | if p < 0 || p >= t.PlayerCount then 71 | invalidArg "player" "The player value should be between 0 and player count" 72 | { s with Turn = { t with Player = p } } 73 | >> Some 74 | let evolve s = infer >> Seq.fold evolve' s 75 | 76 | //////////////////////////////////////////////////////////////////////////////// 77 | // Decision type and decision function 78 | 79 | type Context = Context of game:GameId * player:int 80 | type Decision = 81 | | StartForward of ctx: Context * card: Card * playerCount:int 82 | | StartBackward of ctx: Context * card: Card * playerCount:int 83 | | Play of Context * card:Card * nextTurn: Turn 84 | | PlayAndReverse of Context * card:Card * nextTurn: Turn 85 | | WrongCard of Context * card: Card 86 | | OutOfTurn of Context * card: Card 87 | 88 | let interpret: Decision -> Event list = function 89 | | StartForward (Context (game, player), card, playerCount) -> 90 | [ GameStarted { GameId = game; FirstPlayer = player; PlayerCount = playerCount; FirstCard = card } ] 91 | | StartBackward (Context (game, player), card, playerCount) -> 92 | [ GameStarted { GameId = game; FirstPlayer = player; PlayerCount = playerCount; FirstCard = card } 93 | DirectionChanged { GameId = game; Direction = Direction.CounterClockWise } ] 94 | | Play (Context (game, player), card, nextTurn) -> 95 | [ CardPlayed { GameId = game; Player = player; Card = card; NextPlayer = nextTurn.Player } ] 96 | | PlayAndReverse (Context (game, player), card, nextTurn) -> 97 | [ CardPlayed { GameId = game; Player = player; Card = card; NextPlayer = nextTurn.Player } 98 | DirectionChanged { GameId = game; Direction = nextTurn.Direction } ] 99 | | WrongCard (Context (game, player), card) -> 100 | [ PlayedWrongCard { GameId = game; Player = player; Card = card } ] 101 | | OutOfTurn (Context (game, player), card) -> 102 | [ PlayedAtWrongTurn { GameId = game; Player = player; Card = card } ] 103 | 104 | [] 105 | module Turn = 106 | let next turn = 107 | let selectNextPlayer turn = 108 | match turn.Direction with 109 | | ClockWise -> (turn.Player + 1) % turn.PlayerCount 110 | | CounterClockWise -> // the + count is here to avoid having negative result 111 | (turn.Player - 1 + turn.PlayerCount) % turn.PlayerCount 112 | { turn with Turn.Player = selectNextPlayer turn } 113 | 114 | let skip = next >> next 115 | 116 | let reverse turn = 117 | match turn.Direction with 118 | | ClockWise -> { turn with Direction = CounterClockWise } 119 | | CounterClockWise -> { turn with Direction = ClockWise } 120 | 121 | let (|Color|) = function 122 | | DigitCard (_,c) 123 | | KickBack c 124 | | Skip c -> c 125 | 126 | let (|SameColor|_|) = function 127 | | Color c1c,Color c2c when c1c=c2c -> Some c1c 128 | | _ -> None 129 | 130 | let (|SameValue|_|) = function 131 | | DigitCard(n1,_),DigitCard (n2,_) when n1 = n2 -> Some () 132 | | KickBack _, KickBack _ -> Some () 133 | | _ -> None 134 | 135 | type Command = 136 | | StartGame of StartGame 137 | | PlayCard of PlayCard 138 | 139 | let decide' : State option -> Command -> Decision = function 140 | | None -> function 141 | | StartGame c -> 142 | if c.PlayerCount <= 2 then invalidArg "playerCount" "There should be at least 3 players" 143 | let ctx nextPlayer = Context (c.GameId, nextPlayer) 144 | match c.FirstCard with 145 | | KickBack _ -> StartBackward (ctx 0, c.FirstCard, c.PlayerCount) 146 | | Skip _ -> StartForward (ctx 1, c.FirstCard, c.PlayerCount) 147 | | _ -> StartForward (ctx 0, c.FirstCard, c.PlayerCount) 148 | | _ -> invalidOp "The game needs to be started first" 149 | | Some state -> function 150 | | StartGame _ -> invalidOp "The game cannot be started more than once" 151 | | PlayCard c when state.Turn.Player <> c.Player -> 152 | OutOfTurn (Context (c.GameId, c.Player), c.Card) 153 | | PlayCard c -> 154 | let ctx = Context (c.GameId, c.Player) 155 | match c.Card, state.TopCard with 156 | | SameColor _ 157 | | SameValue -> 158 | match c.Card with 159 | | KickBack _ -> PlayAndReverse (ctx, c.Card, state.Turn |> Turn.reverse |> Turn.next) 160 | | Skip _ -> Play (ctx, c.Card, state.Turn |> Turn.skip) 161 | | _ -> Play (ctx, c.Card, state.Turn |> Turn.next) 162 | | _ -> WrongCard (ctx, c.Card) 163 | let decide s = decide' s >> interpret -------------------------------------------------------------------------------- /Samples/Uno/Uno.fs: -------------------------------------------------------------------------------- 1 | namespace Uno 2 | 3 | type Digit = Digit of int 4 | 5 | type Color = 6 | | Red 7 | | Green 8 | | Blue 9 | | Yellow 10 | 11 | type Card = 12 | | DigitCard of Value:Digit * Color:Color 13 | | KickBack of Color:Color 14 | | Skip of Color:Color 15 | 16 | type GameId = GameId of int 17 | 18 | // Commands 19 | type StartGame = { GameId:GameId; PlayerCount:int; FirstCard:Card } 20 | type PlayCard = { GameId:GameId; Player:int; Card:Card } -------------------------------------------------------------------------------- /Samples/Uno/Uno.fsproj: -------------------------------------------------------------------------------- 1 |  2 | 3 | 4 | 5 | Debug 6 | AnyCPU 7 | 2.0 8 | 4ee8261c-4629-4b28-a141-9c210c5235a9 9 | Library 10 | Uno 11 | Uno 12 | v4.5 13 | 4.4.0.0 14 | Uno 15 | 16 | 17 | 18 | true 19 | full 20 | false 21 | false 22 | bin\Debug\ 23 | DEBUG;TRACE 24 | 3 25 | bin\Debug\Uno.XML 26 | 27 | 28 | pdbonly 29 | true 30 | true 31 | bin\Release\ 32 | TRACE 33 | 3 34 | bin\Release\Uno.XML 35 | 36 | 37 | 38 | True 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 11 48 | 49 | 50 | 51 | 52 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 53 | 54 | 55 | 56 | 57 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 58 | 59 | 60 | 61 | 62 | 69 | 70 | 71 | 72 | <__paket__xunit_runner_visualstudio_props>net20\xunit.runner.visualstudio 73 | 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /Samples/Uno/paket.references: -------------------------------------------------------------------------------- 1 | xunit.runner.visualstudio -------------------------------------------------------------------------------- /build.cmd: -------------------------------------------------------------------------------- 1 | @echo off 2 | cls 3 | 4 | if not exist .paket\paket.exe ( 5 | .paket\paket.bootstrapper.exe 6 | if errorlevel 1 ( 7 | exit /b %errorlevel% 8 | ) 9 | ) 10 | 11 | if not exist packages ( 12 | .paket\paket.exe restore 13 | if errorlevel 1 ( 14 | exit /b %errorlevel% 15 | ) 16 | ) 17 | 18 | packages\FAKE\tools\FAKE.exe build.fsx %* 19 | -------------------------------------------------------------------------------- /build.fsx: -------------------------------------------------------------------------------- 1 | #r "packages/FAKE/tools/FakeLib.dll" 2 | open Fake 3 | 4 | let buildDir = "./.build/" 5 | 6 | Target "Clean" (fun _ -> 7 | CleanDir buildDir 8 | ) 9 | 10 | Target "Build" (fun _ -> 11 | !! "*.sln" 12 | |> MSBuildRelease buildDir "Build" 13 | |> Log "Build-Output: " 14 | ) 15 | 16 | RunTargetOrDefault "Build" -------------------------------------------------------------------------------- /paket.dependencies: -------------------------------------------------------------------------------- 1 | source https://www.nuget.org/api/v2/ 2 | 3 | framework >= net45 4 | 5 | # Component dependencies 6 | nuget EventStore.Client 7 | nuget FSharp.Control.AsyncSeq 8 | nuget NEventStore 9 | nuget Newtonsoft.Json 10 | 11 | # Test dependencies 12 | nuget Unquote 13 | nuget xunit 14 | nuget xunit.runner.visualstudio 15 | 16 | # Build tools 17 | nuget FAKE -------------------------------------------------------------------------------- /paket.lock: -------------------------------------------------------------------------------- 1 | FRAMEWORK: >= NET45 2 | NUGET 3 | remote: https://www.nuget.org/api/v2 4 | specs: 5 | EventStore.Client (3.5.0) 6 | FAKE (4.20.0) 7 | FSharp.Control.AsyncSeq (2.0.3) 8 | NEventStore (5.2.0) 9 | Newtonsoft.Json (8.0.2) 10 | Unquote (3.1.1) 11 | xunit (2.1.0) 12 | xunit.assert (2.1.0) 13 | xunit.core (2.1.0) 14 | xunit.abstractions (2.0.0) 15 | xunit.assert (2.1.0) 16 | xunit.core (2.1.0) 17 | xunit.extensibility.core (2.1.0) 18 | xunit.extensibility.execution (2.1.0) 19 | xunit.extensibility.core (2.1.0) 20 | xunit.abstractions (2.0.0) 21 | xunit.extensibility.execution (2.1.0) 22 | xunit.extensibility.core (2.1.0) 23 | xunit.runner.visualstudio (2.1.0) 24 | --------------------------------------------------------------------------------