├── .gitignore ├── .paket ├── paket.bootstrapper.exe └── paket.targets ├── Dockerfile ├── README.md ├── paket.dependencies ├── paket.lock ├── public └── rels │ ├── games.html │ ├── join.html │ ├── newgame.html │ └── play.html └── src ├── App.fsx ├── Hypermedia.fsx ├── TicTacToe.Dsls.fsx ├── TicTacToe.Instructions.fsx ├── TicTacToe.Interpreters.fsx └── TicTacToe.fsx /.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 | *.userosscache 8 | *.sln.docstates 9 | 10 | # User-specific files (MonoDevelop/Xamarin Studio) 11 | *.userprefs 12 | 13 | # Build results 14 | [Dd]ebug/ 15 | [Dd]ebugPublic/ 16 | [Rr]elease/ 17 | [Rr]eleases/ 18 | x64/ 19 | x86/ 20 | bld/ 21 | [Bb]in/ 22 | [Oo]bj/ 23 | [Ll]og/ 24 | 25 | # Visual Studio 2015 cache/options directory 26 | .vs/ 27 | # Uncomment if you have tasks that create the project's static files in wwwroot 28 | #wwwroot/ 29 | 30 | # MSTest test Results 31 | [Tt]est[Rr]esult*/ 32 | [Bb]uild[Ll]og.* 33 | 34 | # NUNIT 35 | *.VisualState.xml 36 | TestResult.xml 37 | 38 | # Build Results of an ATL Project 39 | [Dd]ebugPS/ 40 | [Rr]eleasePS/ 41 | dlldata.c 42 | 43 | # DNX 44 | project.lock.json 45 | artifacts/ 46 | 47 | *_i.c 48 | *_p.c 49 | *_i.h 50 | *.ilk 51 | *.meta 52 | *.obj 53 | *.pch 54 | *.pdb 55 | *.pgc 56 | *.pgd 57 | *.rsp 58 | *.sbr 59 | *.tlb 60 | *.tli 61 | *.tlh 62 | *.tmp 63 | *.tmp_proj 64 | *.log 65 | *.vspscc 66 | *.vssscc 67 | .builds 68 | *.pidb 69 | *.svclog 70 | *.scc 71 | 72 | # Chutzpah Test files 73 | _Chutzpah* 74 | 75 | # Visual C++ cache files 76 | ipch/ 77 | *.aps 78 | *.ncb 79 | *.opendb 80 | *.opensdf 81 | *.sdf 82 | *.cachefile 83 | *.VC.db 84 | *.VC.VC.opendb 85 | 86 | # Visual Studio profiler 87 | *.psess 88 | *.vsp 89 | *.vspx 90 | *.sap 91 | 92 | # TFS 2012 Local Workspace 93 | $tf/ 94 | 95 | # Guidance Automation Toolkit 96 | *.gpState 97 | 98 | # ReSharper is a .NET coding add-in 99 | _ReSharper*/ 100 | *.[Rr]e[Ss]harper 101 | *.DotSettings.user 102 | 103 | # JustCode is a .NET coding add-in 104 | .JustCode 105 | 106 | # TeamCity is a build add-in 107 | _TeamCity* 108 | 109 | # DotCover is a Code Coverage Tool 110 | *.dotCover 111 | 112 | # NCrunch 113 | _NCrunch_* 114 | .*crunch*.local.xml 115 | nCrunchTemp_* 116 | 117 | # MightyMoose 118 | *.mm.* 119 | AutoTest.Net/ 120 | 121 | # Web workbench (sass) 122 | .sass-cache/ 123 | 124 | # Installshield output folder 125 | [Ee]xpress/ 126 | 127 | # DocProject is a documentation generator add-in 128 | DocProject/buildhelp/ 129 | DocProject/Help/*.HxT 130 | DocProject/Help/*.HxC 131 | DocProject/Help/*.hhc 132 | DocProject/Help/*.hhk 133 | DocProject/Help/*.hhp 134 | DocProject/Help/Html2 135 | DocProject/Help/html 136 | 137 | # Click-Once directory 138 | publish/ 139 | 140 | # Publish Web Output 141 | *.[Pp]ublish.xml 142 | *.azurePubxml 143 | # TODO: Comment the next line if you want to checkin your web deploy settings 144 | # but database connection strings (with potential passwords) will be unencrypted 145 | *.pubxml 146 | *.publishproj 147 | 148 | # Microsoft Azure Web App publish settings. Comment the next line if you want to 149 | # checkin your Azure Web App publish settings, but sensitive information contained 150 | # in these scripts will be unencrypted 151 | PublishScripts/ 152 | 153 | # NuGet Packages 154 | *.nupkg 155 | # The packages folder can be ignored because of Package Restore 156 | **/packages/* 157 | # except build/, which is used as an MSBuild target. 158 | !**/packages/build/ 159 | # Uncomment if necessary however generally it will be regenerated when needed 160 | #!**/packages/repositories.config 161 | # NuGet v3's project.json files produces more ignoreable files 162 | *.nuget.props 163 | *.nuget.targets 164 | 165 | # Microsoft Azure Build Output 166 | csx/ 167 | *.build.csdef 168 | 169 | # Microsoft Azure Emulator 170 | ecf/ 171 | rcf/ 172 | 173 | # Windows Store app package directories and files 174 | AppPackages/ 175 | BundleArtifacts/ 176 | Package.StoreAssociation.xml 177 | _pkginfo.txt 178 | 179 | # Visual Studio cache files 180 | # files ending in .cache can be ignored 181 | *.[Cc]ache 182 | # but keep track of directories ending in .cache 183 | !*.[Cc]ache/ 184 | 185 | # Others 186 | ClientBin/ 187 | ~$* 188 | *~ 189 | *.dbmdl 190 | *.dbproj.schemaview 191 | *.pfx 192 | *.publishsettings 193 | node_modules/ 194 | orleans.codegen.cs 195 | 196 | # Since there are multiple workflows, uncomment next line to ignore bower_components 197 | # (https://github.com/github/gitignore/pull/1529#issuecomment-104372622) 198 | #bower_components/ 199 | 200 | # RIA/Silverlight projects 201 | Generated_Code/ 202 | 203 | # Backup & report files from converting an old project file 204 | # to a newer Visual Studio version. Backup files are not needed, 205 | # because we have git ;-) 206 | _UpgradeReport_Files/ 207 | Backup*/ 208 | UpgradeLog*.XML 209 | UpgradeLog*.htm 210 | 211 | # SQL Server files 212 | *.mdf 213 | *.ldf 214 | 215 | # Business Intelligence projects 216 | *.rdl.data 217 | *.bim.layout 218 | *.bim_*.settings 219 | 220 | # Microsoft Fakes 221 | FakesAssemblies/ 222 | 223 | # GhostDoc plugin setting file 224 | *.GhostDoc.xml 225 | 226 | # Node.js Tools for Visual Studio 227 | .ntvs_analysis.dat 228 | 229 | # Visual Studio 6 build log 230 | *.plg 231 | 232 | # Visual Studio 6 workspace options file 233 | *.opt 234 | 235 | # Visual Studio LightSwitch build output 236 | **/*.HTMLClient/GeneratedArtifacts 237 | **/*.DesktopClient/GeneratedArtifacts 238 | **/*.DesktopClient/ModelManifest.xml 239 | **/*.Server/GeneratedArtifacts 240 | **/*.Server/ModelManifest.xml 241 | _Pvt_Extensions 242 | 243 | # Paket dependency manager 244 | .paket/paket.exe 245 | paket-files/ 246 | 247 | # FAKE - F# Make 248 | .fake/ 249 | 250 | # JetBrains Rider 251 | .idea/ 252 | *.sln.iml -------------------------------------------------------------------------------- /.paket/paket.bootstrapper.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/battermann/tic-tac-toe-backend/3215d21226c5f4b137fdb3c5846dd6c6c67c1004/.paket/paket.bootstrapper.exe -------------------------------------------------------------------------------- /.paket/paket.targets: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | true 6 | 7 | true 8 | $(MSBuildThisFileDirectory) 9 | $(MSBuildThisFileDirectory)..\ 10 | /Library/Frameworks/Mono.framework/Commands/mono 11 | mono 12 | 13 | 14 | 15 | $(PaketRootPath)paket.exe 16 | $(PaketToolsPath)paket.exe 17 | $(PaketToolsPath)paket.bootstrapper.exe 18 | "$(PaketExePath)" 19 | $(MonoPath) --runtime=v4.0.30319 "$(PaketExePath)" 20 | "$(PaketBootStrapperExePath)" $(PaketBootStrapperCommandArgs) 21 | $(MonoPath) --runtime=v4.0.30319 $(PaketBootStrapperExePath) $(PaketBootStrapperCommandArgs) 22 | 23 | $(MSBuildProjectDirectory)\paket.references 24 | $(MSBuildStartupDirectory)\paket.references 25 | $(MSBuildProjectFullPath).paket.references 26 | $(PaketCommand) restore --references-files "$(PaketReferences)" 27 | $(PaketBootStrapperCommand) 28 | 29 | RestorePackages; $(BuildDependsOn); 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 39 | 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fsharp/fsharp 2 | COPY . . 3 | RUN mono ./.paket/paket.bootstrapper.exe 4 | RUN mono ./.paket/paket.exe restore 5 | RUN mono ./.paket/paket.exe generate-include-scripts 6 | CMD fsharpi --exec src/App.fsx $PORT -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Tic-Tac-Toe Backend 2 | 3 | ## Create Docker image 4 | 5 | ```bash 6 | docker build -t tictactoe . 7 | ``` 8 | 9 | ## Run Docker 10 | 11 | ```bash 12 | docker run -d -p 5000:5000 -e PORT=5000 tictactoe 13 | ``` -------------------------------------------------------------------------------- /paket.dependencies: -------------------------------------------------------------------------------- 1 | source http://nuget.org/api/v2 2 | framework: >= net40 3 | nuget Chessie = 0.6.0 4 | nuget Suave = 2.0.2 5 | nuget FSharp.Data = 2.3.2 -------------------------------------------------------------------------------- /paket.lock: -------------------------------------------------------------------------------- 1 | FRAMEWORK: >= NET40 2 | NUGET 3 | remote: http://www.nuget.org/api/v2 4 | Chessie (0.6) 5 | FSharp.Core 6 | FSharp.Core (4.0.0.1) 7 | FSharp.Data (2.3.2) 8 | Suave (2.0.2) 9 | FSharp.Core (>= 4.0.0.1) 10 | -------------------------------------------------------------------------------- /public/rels/games.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Show all games 5 | 6 | 7 |

Show all games

8 |

A list of all the games.

9 |

URL

10 | 

/games

11 |

Request

12 |

Method

13 |

14 |

URL parameters

15 | 

none

16 |

Content Type

17 | 

any

18 |

Data parameters

19 | 

none

20 |

Example

21 |

22 |

Response

23 |

The response contains a list of games.

24 |

Response code

25 | 

202 Accpeted

26 |

Content Type

27 | 

application/hal+json

28 |

Example

29 | 

{
30 |    "_embedded":{
31 |       "http://localhost:8000/rels/games":[
32 |          {
33 |             "_links":{
34 |                "http://localhost:8000/rels/join":{
35 |                   "href":"http://localhost:8000/games/06cee5ca-3ba5-4c9c-8d00-ac51e0d0f8c8/join"
36 |                },
37 |                "self":{
38 |                   "href":"http://localhost:8000/games/06cee5ca-3ba5-4c9c-8d00-ac51e0d0f8c8"
39 |                }
40 |             },
41 |             "id":"06cee5ca-3ba5-4c9c-8d00-ac51e0d0f8c8",
42 |             "status":"running"
43 |          },
44 |          {
45 |             "_links":{
46 |                "http://localhost:8000/rels/join":{
47 |                   "href":"http://localhost:8000/games/960005e1-0904-4eb9-850b-fbdcbd263e5e/join"
48 |                },
49 |                "self":{
50 |                   "href":"http://localhost:8000/games/960005e1-0904-4eb9-850b-fbdcbd263e5e"
51 |                }
52 |             },
53 |             "id":"960005e1-0904-4eb9-850b-fbdcbd263e5e",
54 |             "status":"running"
55 |          }
56 |       ]
57 |    },
58 |    "_links":{
59 |       "http://localhost:8000/rels/newgame":{
60 |          "href":"http://localhost:8000/games"
61 |       },
62 |       "self":{
63 |          "href":"http://localhost:8000/games"
64 |       }
65 |    }
66 | }

67 |

Errors

68 | 

500 Interal Server Error

69 | 70 | -------------------------------------------------------------------------------- /public/rels/join.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Join a new game 4 | 5 | 6 |

Join a new game

7 |

Join a game that has been started by someone else. The player that joins will be player O. Games can only be joined if no one else has joined them before.

8 |

URL

9 | 

/games/{id}/join

10 |

Request

11 |

Method

12 |

13 |

URL parameters

14 | 

none

15 |

Content Type

16 | 

any

17 |

Data parameters

18 | 

none

19 |

Example

20 |

21 |

Response

22 |

The response contains the player ID for player O. In subsequent request on the game (to make plays) this ID has to be transmitted in the request body. The URL of the game can be found in the Location Header.

23 |

Response code

24 | 

202 Accpeted

25 |

Content Type

26 | 

application/hal+json

27 |

Example

28 | 

Location http://localhost:8000/games/94a26c4a-75f7-45b2-8e20-a39f0f8818e8
29 | 
30 | { 
31 |     "playerId": "6acd905b-044e-47f8-9692-4b68d0c6ee07" 
32 | }

33 |

Errors

34 | 

409 Conflict, 404 Not Found, 500 Internal Server Error

35 | 36 | -------------------------------------------------------------------------------- /public/rels/newgame.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Start a new game 5 | 6 | 7 |

Start a new game

8 |

Start a new game. The game will be created and appended to the game list. The game is now open for player O to join.

9 |

URL

10 | 

/games

11 |

Request

12 |

Method

13 |

14 |

URL parameters

15 | 

none

16 |

Content Type

17 | 

any

18 |

Data parameters

19 | 

none

20 |

Example

21 |

22 |

Response

23 |

The response contains the player ID for player X. In subsequent request on the game (to make plays) this ID has to be transmitted in the request body. The request is processed asynchronously. Therefore the response code is 202 Accepted. The URL of the new game is provided by the Location Header.

24 |

Response code

25 | 

202 Accpeted

26 |

Content Type

27 | 

application/hal+json

28 |

Example

29 | 

Location http://localhost:8000/games/3f81eac5-26fc-4242-9444-126f785c43f6
30 | 
31 | { 
32 |     "playerId": "6acd905b-044e-47f8-9692-4b68d0c6ee07" 
33 | }

34 |

Errors

35 |

36 | 37 | -------------------------------------------------------------------------------- /public/rels/play.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Make a play 4 | 5 | 6 |

Make a play

7 |

This is the relation for making a play. The request has to provide the player ID and a description of the move in the request body. The move has a vertical and a horizontal position. Valid vertical positions are: "top", "vcenter", "bottom". Valid horizontal positions are: "left", "hcenter", "right".

8 |

URL

9 | 

/games/{id}/moves

10 |

Request

11 |

Method

12 |

13 |

URL parameters

14 | 

none

15 |

Content Type

16 | 

application/json

17 |

Data parameters

18 | 

vertical : string, horizontal : string, playerId : string

19 |

Example

20 | 

{
21 |     "vertical": "top",
22 |     "horizontal": "left",
23 |     "playerId": "47769197-0ca6-414c-a018-610896eb645b"
24 | }

25 |

Response

26 |

The request will be processed asynchronously. Therefore the response is empty. To get the current state of the game a new request to the game URL has to made.

27 |

Response code

28 | 

202 Accpeted

29 |

Content Type

30 |

31 |

Example

32 |

33 |

Errors

34 | 

409 Conflict, 404 Not Found, 400 Bad Request

35 | 36 | -------------------------------------------------------------------------------- /src/App.fsx: -------------------------------------------------------------------------------- 1 | #load "TicTacToe.Interpreters.fsx" 2 | #load "Hypermedia.fsx" 3 | #I "../packages" 4 | #r "Suave/lib/net40/Suave.dll" 5 | 6 | open System 7 | open System.Net 8 | 9 | open FSharp.Data 10 | 11 | open Suave.Web 12 | open Suave.Successful 13 | open Suave.Operators 14 | open Suave.Http 15 | open Suave.ServerErrors 16 | open System.IO 17 | open Suave 18 | open Suave.Filters 19 | open Suave.RequestErrors 20 | 21 | open Chessie.ErrorHandling 22 | 23 | open Hypermedia 24 | open Hal 25 | open FSharpDataIntepreter 26 | 27 | open TicTacToe 28 | open Dsls.TicTacToeDsl 29 | open Dsls.Free 30 | open Instructions 31 | open Types 32 | open Interpreters 33 | open Effects 34 | 35 | let () path1 path2 = Path.Combine(path1, path2) 36 | 37 | let GAMES = "games" 38 | let GAME = "game" 39 | let MOVES = "moves" 40 | let JOIN = "join" 41 | let PLAY = "play" 42 | let NEWGAME = "newgame" 43 | 44 | 45 | module Paths = 46 | let api = "api" 47 | let games = api GAMES 48 | let game id = (api GAMES) id 49 | let moves id = game id MOVES 50 | let join id = game id JOIN 51 | let rels = sprintf "docs/rels/%s" 52 | 53 | module Routes = 54 | let game = new PrintfFormat<(string -> string),unit,string,string,string>(("/" Paths.games) "%s") 55 | let moves = new PrintfFormat<(string -> string),unit,string,string,string>((("/" Paths.games) "%s") MOVES) 56 | let join = new PrintfFormat<(string -> string),unit,string,string,string>((("/" Paths.games) "%s") JOIN) 57 | 58 | let gamesRel host = host ("games" |> Paths.rels) 59 | let joinRel host = host ("join" |> Paths.rels) 60 | let playRel host = host ("play" |> Paths.rels) 61 | let newGameRel host = host ("newgame" |> Paths.rels) 62 | 63 | type PlayerId = PlayerId of Guid 64 | 65 | type Players = { 66 | x: PlayerId option 67 | o: PlayerId option 68 | } 69 | 70 | type PlayerMapMessage = 71 | | Add of GameId * Players 72 | | TryJoin of GameId * PlayerId * AsyncReplyChannel> 73 | | TryFind of GameId * AsyncReplyChannel 74 | 75 | [] 76 | module Responses = 77 | type Error = { 78 | error: string 79 | } 80 | with 81 | static member ToJson (x:Error) = 82 | JsonValue.Record [| "error", JsonValue.String(x.error) |] 83 | 84 | 85 | [] 86 | module Requests = 87 | let findString s arr = arr |> Array.find (fun (k,v) -> k = s) |> snd |> fun v -> v.ToString() 88 | 89 | type Play = { 90 | vertical: string 91 | horizontal: string 92 | playerId: string 93 | } 94 | with 95 | static member FromJson (x:JsonValue) = 96 | match x with 97 | | JsonValue.Record props -> 98 | { vertical = props |> findString "vertical" 99 | horizontal = props |> findString "horizontal" 100 | playerId = props |> findString "playerId" } 101 | | _ -> failwith "bad format" 102 | 103 | type Player = { 104 | playerId: string 105 | } 106 | with 107 | static member FromJson (x:JsonValue) = 108 | match x with 109 | | JsonValue.Record props -> 110 | { playerId = props |> findString "playerId" } 111 | | _ -> failwith "bad format" 112 | 113 | static member ToJson (x:Player) = 114 | JsonValue.Record [| "playerId", JsonValue.String(x.playerId) |] 115 | 116 | [] 117 | module Serialization = 118 | let serializeList (list: string list) : JsonValue = 119 | list |> List.map JsonValue.String |> List.toArray |> JsonValue.Array 120 | 121 | let serializeGrid (grid: string list list) : JsonValue = 122 | grid |> List.map serializeList |> List.toArray |> JsonValue.Array 123 | 124 | [] 125 | module Mappers = 126 | let jsonToString (json: JsonValue) = json.ToString(JsonSaveOptions.DisableFormatting) 127 | 128 | let toGameList url (rms: (Dsls.ReadModel.GameListItemRm * bool) list) = 129 | let toListItem (rm: Dsls.ReadModel.GameListItemRm, closed) = { 130 | Resource.empty with 131 | Resource.links = Map.ofList [ yield "self", Singleton (Link.create (Uri (url Paths.game rm.id))) 132 | if not closed then yield (joinRel url, Singleton (Link.create (Uri (url Paths.join rm.id)))) ] 133 | properties = Map.ofList [ "id", JObject <| JsonValue.String(rm.id) 134 | "status", JObject <| JsonValue.String(rm.status) ] 135 | } 136 | { 137 | Resource.empty with 138 | Resource.links = Map.ofList [ "self", Link.create (Uri (url Paths.games)) |> Singleton 139 | newGameRel url, Link.create (Uri (url Paths.games)) |> Singleton ] 140 | embedded = Map.ofList [ gamesRel url, rms |> List.map toListItem |> Collection ] 141 | } 142 | 143 | let toGameResponse url closedForJoin (rm: Dsls.ReadModel.GameRm) = 144 | { 145 | Resource.empty with 146 | Resource.links = Map.ofList [ yield "self", Singleton (Link.create (Uri (url Paths.game rm.id))) 147 | yield "collection", Singleton (Link.create (Uri (url Paths.games))) 148 | yield playRel url, Singleton (Link.create (Uri (url Paths.moves rm.id))) 149 | if not closedForJoin then yield (joinRel url, Singleton (Link.create (Uri (url Paths.join rm.id)) )) ] 150 | properties = Map.ofList [ "status", JObject <| JsonValue.String(rm.status) 151 | "id", JObject <| JsonValue.String(rm.id) 152 | "grid", JObject <| serializeGrid rm.grid] 153 | } 154 | 155 | [] 156 | module Deserialization = 157 | let getPlay (req : HttpRequest) = 158 | let getString rawForm = Text.Encoding.UTF8.GetString(rawForm) 159 | req.rawForm 160 | |> getString 161 | |> JsonValue.Parse 162 | |> Play.FromJson 163 | 164 | let bothPlayersJoined (playerMap: Actor) gameId = 165 | async { 166 | let! players = playerMap.PostAndAsyncReply(fun rc -> TryFind (gameId, rc)) 167 | match players with 168 | | Some { x = Some _ ; o = Some _ } -> return true 169 | | _ -> return false 170 | } 171 | 172 | let game interpret (playerMap: Actor) (id: string) baseUrl: WebPart = 173 | let gameId = Guid(id) |> GameId 174 | fun (ctx: HttpContext) -> 175 | async { 176 | let! rm = interpret (Queries.game(gameId)) |> Async.ofAsyncResult 177 | let! closedForJoin = bothPlayersJoined playerMap gameId 178 | return! 179 | match rm with 180 | | Ok (v,_) -> 181 | OK (v |> toGameResponse baseUrl closedForJoin |> FSharpDataIntepreter.Hal.toJson |> jsonToString) ctx 182 | | Bad errs -> 183 | INTERNAL_ERROR ({ error = (errs |> String.concat ", ") } |> (Error.ToJson >> jsonToString)) ctx 184 | } 185 | 186 | let gamesWithJoinableFlag (interpret: Free<_> -> Effect<_>) (playerMap: Actor) = 187 | asyncTrial { 188 | let! games = interpret (Queries.games) 189 | let! gamesWithFlag = 190 | games |> List.map (fun (g: Dsls.ReadModel.GameListItemRm) -> bothPlayersJoined playerMap (Guid(g.id) |> GameId) |> Async.map (fun b -> g,b)) 191 | |> Async.Parallel 192 | return gamesWithFlag |> Array.toList 193 | } 194 | 195 | let games interpret (playerMap: Actor) baseUrl: WebPart = 196 | fun (ctx: HttpContext) -> 197 | async { 198 | let! rmWithJoinableFlag = gamesWithJoinableFlag interpret playerMap |> Async.ofAsyncResult 199 | return! 200 | match rmWithJoinableFlag with 201 | | Ok (v,_) -> 202 | OK (v |> toGameList baseUrl |> FSharpDataIntepreter.Hal.toJson |> jsonToString) ctx 203 | | Bad errs -> 204 | INTERNAL_ERROR ({ error = (errs |> String.concat ", ") } |> Error.ToJson |> jsonToString) ctx 205 | } 206 | 207 | let start interpret (playerMap: Actor) baseUrl: WebPart = 208 | let gameId = Guid.NewGuid() 209 | let playerId = Guid.NewGuid() 210 | do playerMap.Post(Add(GameId gameId, { x = PlayerId playerId |> Some; o = None })) 211 | // handle cmd asynchronously 212 | do interpret (Commands.handle(GameId gameId, Start)) |> Async.ofAsyncResult|> Async.map ignore |> Async.Start 213 | let body = { playerId = playerId.ToString() } |> Player.ToJson |> jsonToString 214 | ACCEPTED body >=> Writers.setHeader "Location" (baseUrl Paths.game (gameId.ToString())) 215 | 216 | let join (playerMap: Actor) (gameId: string) baseUrl: WebPart = 217 | let playerId = Guid.NewGuid() 218 | fun (ctx: HttpContext) -> 219 | async { 220 | let! result = playerMap.PostAndAsyncReply(fun rc -> TryJoin (Guid(gameId) |> GameId, playerId |> PlayerId, rc)) 221 | match result with 222 | | Ok _ -> 223 | let body = { playerId = playerId.ToString() } |> Player.ToJson |> jsonToString 224 | return! (ACCEPTED body >=> Writers.setHeader "Location" (baseUrl Paths.game (gameId.ToString()))) ctx 225 | | Bad errs -> 226 | return! 227 | if errs |> List.exists ((=) "game already running") then 228 | CONFLICT ({ error = (errs |> String.concat ", ") } |> Error.ToJson |> jsonToString) ctx 229 | elif errs |> List.exists ((=) "game invalid") then 230 | NOT_FOUND ({ error = (errs |> String.concat ", ") } |> Error.ToJson |> jsonToString) ctx 231 | else 232 | INTERNAL_ERROR ({ error = (errs |> String.concat ", ")} |> Error.ToJson |> jsonToString) ctx 233 | 234 | } 235 | 236 | let play interpret (playerMap: Actor) (id: string) (play:Play) baseUrl: WebPart = 237 | let toPosition (v: string, h: string) = 238 | match (v.ToLower(),h.ToLower()) with 239 | | "top", "left" -> (Top, Left) |> Some 240 | | "top", "hcenter" -> (Top, HCenter) |> Some 241 | | "top", "right" -> (Top, Right) |> Some 242 | | "vcenter", "left" -> (VCenter, Left) |> Some 243 | | "vcenter", "hcenter" -> (VCenter, HCenter) |> Some 244 | | "vcenter", "right" -> (VCenter, Right) |> Some 245 | | "bottom", "left" -> (Bottom, Left) |> Some 246 | | "bottom", "hcenter" -> (Bottom, HCenter) |> Some 247 | | "bottom", "right" -> (Bottom, Right) |> Some 248 | | _ -> None 249 | 250 | let maybePosition = toPosition (play.vertical, play.horizontal) 251 | let gameId = Guid(id) |> GameId 252 | fun (ctx: HttpContext) -> 253 | async { 254 | let! players = playerMap.PostAndAsyncReply(fun rc -> TryFind (gameId, rc)) 255 | let! closedForJoin = bothPlayersJoined playerMap gameId 256 | match players, maybePosition, closedForJoin with 257 | | Some { x = Some plX; o = Some plO }, Some(v,h), true -> 258 | let cmd = if (Guid(play.playerId) |> PlayerId) = plX then PlayX else PlayO 259 | // handle cmd asyncronously 260 | do interpret (Commands.handle(gameId, cmd (v, h))) |> Async.ofAsyncResult|> Async.map ignore |> Async.Start 261 | return! (ACCEPTED "{}" >=> Writers.setHeader "Location" (baseUrl Paths.game (gameId.ToString()))) ctx 262 | | Some _, Some _, false -> return! CONFLICT ({ error = "opponent hasn't joined game yet" } |> Error.ToJson |> jsonToString) ctx 263 | | _, None, _ -> return! BAD_REQUEST ({ error = "unknown position" } |> Error.ToJson |> jsonToString) ctx 264 | | _ -> return! NOT_FOUND ({ error = "unknown player id" } |> Error.ToJson |> jsonToString) ctx 265 | } 266 | 267 | let playersMapActor = 268 | Actor.Start(fun inbox -> 269 | let rec loop (playersMap: Map) = 270 | async { 271 | let! msg = inbox.Receive() 272 | match msg with 273 | | Add (gameId, players) -> 274 | return! loop (playersMap.Add(gameId, players)) 275 | | TryJoin (gameId, player, rc) -> 276 | match playersMap.TryFind gameId with 277 | | Some { x = Some _; o = Some _ } -> 278 | rc.Reply(fail "game already running") 279 | return! loop playersMap 280 | | Some { x = Some pX; o = None } -> 281 | rc.Reply(ok ()) 282 | return! loop (playersMap.Add(gameId, { x = Some pX; o = player |> Some })) 283 | | _ -> 284 | rc.Reply(fail "game invalid") 285 | return! loop playersMap 286 | | TryFind (gameId, rc) -> 287 | rc.Reply(playersMap.TryFind gameId) 288 | return! loop playersMap 289 | } 290 | loop Map.empty) 291 | 292 | let interpret free = 293 | TicTacToe.interpret 294 | Domain.interpret 295 | EventBus.interpret 296 | EventStore.interpret 297 | ReadModel.interpret free 298 | 299 | let app = 300 | let urlWithHost (request : HttpRequest) = 301 | let host = 302 | request.headers 303 | |> List.find (fst >> (=) "host") 304 | |> snd 305 | sprintf "%s://%s" request.url.Scheme host 306 | 307 | let setJsonHeader = Writers.setMimeType "application/hal+json" 308 | 309 | let setCorsHaeders = 310 | Writers.setHeader "Access-Control-Allow-Origin" "*" 311 | >=> Writers.setHeader "Access-Control-Allow-Headers" "content-type" 312 | >=> Writers.setHeader "Access-Control-Expose-Headers" "content-type, location" 313 | >=> Writers.setHeader "Access-Control-Allow-Methods" "POST, GET, OPTIONS, DELETE, PATCH" 314 | 315 | let setHeaders = setJsonHeader >=> setCorsHaeders 316 | 317 | choose [ 318 | GET >=> choose [ 319 | path ("/" Paths.api) >=> request (urlWithHost >> fun host -> 320 | { Resource.empty with links = Map.ofList [ "self", Singleton (Link.create (Uri (host Paths.api))) 321 | gamesRel host, Singleton (Link.create (Uri (host Paths.games))) ] } 322 | |> FSharpDataIntepreter.Hal.toJson|> jsonToString |> OK) 323 | >=> setHeaders 324 | path ("/" Paths.games) >=> request (urlWithHost >> games interpret playersMapActor) >=> setHeaders 325 | pathScan Routes.game (fun gameId -> 326 | request (urlWithHost >> game interpret playersMapActor gameId)) >=> setHeaders 327 | path ("/" Paths.rels GAMES) >=> Files.file "./public/rels/games.html" >=> setCorsHaeders 328 | path ("/" Paths.rels NEWGAME) >=> Files.file "./public/rels/newgame.html" >=> setCorsHaeders 329 | path ("/" Paths.rels JOIN) >=> Files.file "./public/rels/join.html" >=> setCorsHaeders 330 | path ("/" Paths.rels PLAY) >=> Files.file "./public/rels/play.html" >=> setCorsHaeders 331 | ] 332 | POST >=> choose [ 333 | path ("/" Paths.games) >=> request (urlWithHost >> start interpret playersMapActor) >=> setHeaders 334 | pathScan Routes.join (fun gameId -> 335 | request (urlWithHost >> join playersMapActor gameId)) >=> setHeaders 336 | pathScan Routes.moves (fun gameId -> 337 | request (fun req -> play interpret playersMapActor gameId (getPlay req) (urlWithHost req))) 338 | >=> setHeaders 339 | ] 340 | ] 341 | 342 | let config = 343 | let ip = IPAddress.Parse "0.0.0.0" 344 | let [|_; port|] = fsi.CommandLineArgs 345 | { defaultConfig with 346 | //logger = Logging.LoggerEx .saneDefaultsFor Logging.LogLevel.Info 347 | bindings= [ HttpBinding.create HTTP ip (uint16 port) ] } 348 | 349 | interpret (ReadModel.subscribe()) 350 | 351 | startWebServer config app 352 | -------------------------------------------------------------------------------- /src/Hypermedia.fsx: -------------------------------------------------------------------------------- 1 | module Hypermedia 2 | 3 | #load "../paket-files/include-scripts/net40/include.fsharp.data.fsx" 4 | 5 | let merge (maps: Map<_,_> seq): Map<_,_> = 6 | List.concat (maps |> Seq.map Map.toList) |> Map.ofList 7 | 8 | /// Represents a minimal generic Json object to describe a hypermedia resource. 9 | type JsonModel<'a> = 10 | | JObject of 'a 11 | | JRecord of Map> 12 | | JString of string 13 | | JArray of JsonModel<'a> list 14 | | JBool of bool 15 | 16 | /// Define Hypertext Application Language (HAL) resources. 17 | /// Transform HAL resource to specific Json implementations. 18 | module Hal = 19 | 20 | // todo ensure that _links and _embedded are unique 21 | 22 | open System 23 | open System.Reflection 24 | open Microsoft.FSharp.Reflection 25 | 26 | /// A link representation according to the HAL specification (https://tools.ietf.org/html/draft-kelly-json-hal-08). 27 | type Link = { 28 | href: Uri 29 | templated: bool option 30 | mediaType: string option 31 | deprication: Uri option 32 | name: string option 33 | profile: Uri option 34 | title: string option 35 | hreflang: string option 36 | } 37 | 38 | type Curies = Map 39 | 40 | type MaybeSingleton<'a> = 41 | | Singleton of 'a 42 | | Collection of 'a list 43 | 44 | module MaybeSingleton = 45 | let map f maybeSingleton = 46 | match maybeSingleton with 47 | | Singleton x -> Singleton (f x) 48 | | Collection xs -> Collection (xs |> List.map f) 49 | 50 | /// A resource representation according to the HAL specification (https://tools.ietf.org/html/draft-kelly-json-hal-08). 51 | type Resource<'a> = { 52 | curies: Curies 53 | links: Map> 54 | embedded: Map>> 55 | properties: Map> 56 | payload: obj option 57 | } 58 | 59 | [] 60 | [] 61 | module internal Curies = 62 | let internal tryFindName (curies: Curies) (relation: string): string option = 63 | let tryCreateUri str = 64 | match Uri.TryCreate(str, UriKind.Absolute) with 65 | | true, uri -> Some uri 66 | | _ -> None 67 | 68 | let matchUriWithTemplate (name: string, template: Uri) (uri: Uri): string option = 69 | if template.Segments |> Array.length <> (uri.Segments |> Array.length) then 70 | None 71 | else 72 | Array.zip template.Segments uri.Segments 73 | |> Array.tryFind (fst >> ((=) "%7Brel%7D")) 74 | |> Option.map (snd >> sprintf "%s:%s" name) 75 | 76 | curies 77 | |> Map.toSeq 78 | |> Seq.map matchUriWithTemplate 79 | |> Seq.choose (fun tryMatch -> tryCreateUri relation |> Option.bind tryMatch) 80 | |> Seq.tryHead 81 | 82 | let internal replace (curies: Curies) (map: Map>) = 83 | map 84 | |> Map.toList 85 | |> List.map (fun (relation, x) -> 86 | match tryFindName curies relation with 87 | | Some name -> name, x 88 | | _ -> relation, x) 89 | |> Map.ofList 90 | 91 | let rec replaceRelations curies resource = 92 | { resource with 93 | links = replace curies resource.links 94 | embedded = (replace curies resource.embedded) |> Map.map (fun _ emb -> emb |> MaybeSingleton.map (replaceRelations curies)) 95 | } 96 | 97 | [] 98 | [] 99 | module Link = 100 | let create href = { 101 | href = href 102 | templated = None 103 | mediaType = None 104 | deprication = None 105 | name = None 106 | profile = None 107 | title = None 108 | hreflang = None 109 | } 110 | 111 | let internal serializeSingleLink (link: Link) : JsonModel<'a> = 112 | Map.ofList 113 | [ yield ("href", JString (string link.href)) 114 | yield! match link.templated with Some b -> [ "templated", JBool b ] | _ -> [] 115 | yield! match link.mediaType with Some mt -> [ "type", JString mt ] | _ -> [] 116 | yield! match link.deprication with Some dep -> [ "deprication", JString (dep.ToString()) ] | _ -> [] 117 | yield! match link.name with Some name -> [ "name", JString name ] | _ -> [] 118 | yield! match link.profile with Some prof -> [ "profile", JString (prof.ToString()) ] | _ -> [] 119 | yield! match link.title with Some title -> [ "title", JString title ] | _ -> [] 120 | yield! match link.hreflang with Some lang -> [ "hreflang", JString lang ] | _ -> [] ] 121 | |> JRecord 122 | 123 | let internal serialize (links: Map>) (curies: Curies) : JsonModel<'a> option = 124 | 125 | let linksWithCuries = 126 | curies 127 | |> Map.toList 128 | |> List.map (fun (name, href) -> { create href with name = Some name; templated = Some true }) 129 | |> fun x -> "curies", Collection x 130 | |> links.Add 131 | 132 | let serializeLinkList = function 133 | | Singleton l -> serializeSingleLink l 134 | | Collection ls -> JArray (ls |> List.map serializeSingleLink) 135 | 136 | let nonEmptyLinks = 137 | linksWithCuries 138 | |> Map.filter (fun _ link -> 139 | match link with 140 | | Singleton _ -> true 141 | | Collection xs -> not (xs |> List.isEmpty)) 142 | 143 | if nonEmptyLinks |> Map.isEmpty then 144 | None 145 | else 146 | nonEmptyLinks 147 | |> Map.map (fun _ l -> serializeLinkList l) 148 | |> JRecord 149 | |> Some 150 | 151 | /// Contains functions to transform resources to Json representations. 152 | [] 153 | module Resource = 154 | 155 | /// Returns an empty resource object the represents a valid HAL resource. 156 | let empty = { 157 | curies = Map.empty 158 | links = Map.empty 159 | embedded = Map.empty 160 | properties = Map.empty 161 | payload = None 162 | } 163 | 164 | let internal tryToMap(x: 'T) = 165 | let objectToMap(obj: obj) = 166 | obj.GetType().GetProperties(BindingFlags.DeclaredOnly ||| BindingFlags.Public ||| BindingFlags.Instance) 167 | |> Array.map (fun prop -> prop.Name, prop.GetValue(obj, null)) 168 | |> Map.ofArray 169 | 170 | let recordToMap (record:'T) = 171 | [ for p in FSharpType.GetRecordFields(typeof<'T>) -> 172 | p.Name, p.GetValue(record) ] 173 | |> Map.ofSeq 174 | 175 | try 176 | if FSharp.Reflection.FSharpType.IsRecord(typeof<'T>) then 177 | x |> recordToMap 178 | else 179 | x |> objectToMap 180 | with 181 | | _ -> Map.empty 182 | 183 | let rec internal serialize (resource: Resource<'a>) : JsonModel<'a> = 184 | 185 | let withResolvedCuries = Curies.replaceRelations resource.curies resource 186 | 187 | let embedded = 188 | let embeddedMap = 189 | withResolvedCuries.embedded 190 | |> Map.map (fun rel res -> 191 | match res with 192 | | Singleton x -> serialize x 193 | | Collection xs -> JArray (xs |> List.map serialize)) 194 | 195 | if embeddedMap |> Map.isEmpty then 196 | Map.empty 197 | else 198 | Map.ofList [ "_embedded", embeddedMap |> JRecord ] 199 | 200 | let links = 201 | match Link.serialize withResolvedCuries.links resource.curies with 202 | | Some ls -> Map.ofList [ "_links", ls ] 203 | | _ -> Map.empty 204 | 205 | let properties = 206 | match resource.payload with 207 | | Some pl -> 208 | let payload = 209 | try 210 | pl |> tryToMap |> Map.map (fun _ v -> JObject (v :?> 'a)) 211 | with 212 | | _ -> Map.empty 213 | merge [ resource.properties; payload ] 214 | | _ -> resource.properties 215 | 216 | [ links; properties; embedded ] 217 | |> merge 218 | |> JRecord 219 | 220 | /// Serializes a HAL resource representation to a specific Json representation. 221 | /// The interpreter transforms the generic Json representation to a specific representation. 222 | let toJson interpreter resource = 223 | resource |> serialize |> interpreter 224 | 225 | let withPayload (payload: obj) resource : Resource = 226 | { resource with payload = payload |> Some } 227 | 228 | let withLinks links resource = 229 | { resource with links = Map.ofList links } 230 | let addLink rel link resource = 231 | { resource with links = resource.links.Add(rel, Singleton link) } 232 | 233 | let addLinkCollection rel link resource = 234 | { resource with links = resource.links.Add(rel, Collection link) } 235 | 236 | let addEmbedded name embedded resource = 237 | { resource with embedded = resource.embedded.Add(name, Singleton embedded) } 238 | 239 | let addEmbeddedCollection name embedded resource = 240 | { resource with embedded = resource.embedded.Add(name, Collection embedded) } 241 | 242 | let withCuries curies resource = 243 | { resource with curies = Map.ofList curies } 244 | 245 | let withProperties props resource = 246 | { resource with properties = props |> Map.ofList |> Map.map (fun _ x -> JObject x) } 247 | 248 | let addProperty name prop resource = 249 | { resource with properties = resource.properties.Add(name, JObject prop) } 250 | 251 | module Siren = 252 | 253 | open System 254 | 255 | type Rel = Rel of string 256 | type Title = Title of string 257 | type Class = Class of string 258 | type MediaType = MediaType of string 259 | type Href = Href of Uri 260 | type Name = Name of string 261 | type Value = Value of string 262 | 263 | type HttpMethod = GET | PUT | POST | DELETE | PATCH 264 | 265 | type InputType = 266 | | Hidden | Text | Search | Tel | Url | Email | Password 267 | | Datetime | Date | Month | Week | Time | DatetimeLocal | Number 268 | | Range | Color | Checkbox | Radio | File 269 | 270 | type Field = { 271 | classes: Class list 272 | inputType: InputType option 273 | value: Value option 274 | title: Title option 275 | } 276 | 277 | type Action = { 278 | classes: Class list 279 | httpMethod: HttpMethod option 280 | href: Href 281 | title: Title option 282 | mediaType: MediaType option 283 | fields: Map 284 | } 285 | 286 | type Link = { 287 | href: Href 288 | rel: Rel * Rel list 289 | classes: Class list 290 | title: Title option 291 | mediaType: MediaType option 292 | } 293 | 294 | type Entity<'a> = { 295 | properties: Map> 296 | entities: SubEntity<'a> list 297 | actions: Map 298 | links: Link list 299 | classes: Class list 300 | title: Title option 301 | } 302 | 303 | and SubEntity<'a> = 304 | | EmbeddedRepresentation of Entity<'a> * Rel 305 | | EmbeddedLink of Link 306 | 307 | let mkProperty name items = 308 | if items |> List.isEmpty then 309 | List.empty 310 | else 311 | [ name, JArray items ] 312 | 313 | [] 314 | module internal Attributes = 315 | let CLASS = "class" 316 | let HREF = "href" 317 | let TITLE = "title" 318 | let TYPE = "type" 319 | let FIELDS = "fields" 320 | let NAME = "name" 321 | let REL = "rel" 322 | let LINKS = "links" 323 | let VALUE = "value" 324 | let METHOD = "method" 325 | let ACTIONS = "actions" 326 | let ENTITIES = "entities" 327 | let PROPERTIES = "properties" 328 | 329 | [] 330 | [] 331 | module internal InputType = 332 | let serialize inputType = 333 | match inputType with 334 | | Hidden -> "hidden" 335 | | Text -> "text" 336 | | Search -> "search" 337 | | Tel -> "tel" 338 | | Url -> "url" 339 | | Email -> "email" 340 | | Password -> "password" 341 | | Datetime -> "datetime" 342 | | Date -> "date" 343 | | Month -> "month" 344 | | Week -> "week" 345 | | Time -> "time" 346 | | DatetimeLocal -> "datetime-local" 347 | | Number-> "number" 348 | | Range -> "range" 349 | | Color -> "color" 350 | | Checkbox -> "checkbox" 351 | | Radio -> "radio" 352 | | File-> "file" 353 | 354 | [] 355 | [] 356 | module internal HttpMethod = 357 | let serialize httpMethod = 358 | match httpMethod with 359 | | GET -> "GET" 360 | | PUT -> "PUT" 361 | | POST -> "POST" 362 | | DELETE -> "DELETE" 363 | | PATCH -> "PATCH" 364 | 365 | [] 366 | [] 367 | module internal Field = 368 | let empty : Field = { 369 | classes = List.empty 370 | inputType = None 371 | value = None 372 | title = None 373 | } 374 | 375 | let internal serialize name (field: Field) = 376 | field.classes |> List.map (fun (Class c) -> JString c) |> mkProperty CLASS 377 | |> fun props -> 378 | let inputType = 379 | match field.inputType with Some t -> t | _ -> InputType.Text 380 | |> InputType.serialize 381 | |> fun x -> TYPE, JString x 382 | inputType :: props 383 | |> fun props -> 384 | match field.value with Some (Value v) -> (VALUE, JString v) :: props | _ -> props 385 | |> fun props -> 386 | match field.title with Some (Title t) -> (TITLE, JString t) :: props | _ -> props 387 | |> fun props -> (NAME, JString name) :: props 388 | |> Map.ofList 389 | |> JRecord 390 | 391 | 392 | [] 393 | [] 394 | module internal Action = 395 | let create href : Action = { 396 | classes = List.empty 397 | httpMethod = None 398 | href = href 399 | title = None 400 | mediaType = None 401 | fields = Map.empty 402 | } 403 | 404 | let serialize name (action: Action) = 405 | action.classes |> List.map (fun (Class c) -> JString c) |> mkProperty CLASS 406 | |> fun props -> 407 | let httpMethod = 408 | match action.httpMethod with Some m -> m | _ -> HttpMethod.GET 409 | |> HttpMethod.serialize 410 | |> fun x -> METHOD, JString x 411 | httpMethod :: props 412 | |> fun props -> 413 | let (Href href) = action.href 414 | (HREF, JString (href.ToString())) :: props 415 | |> fun props -> 416 | match action.title with Some (Title t) -> (TITLE, JString t) :: props | _ -> props 417 | |> fun props -> 418 | let mediaType = 419 | match action.mediaType with Some (MediaType mt) -> mt | _ -> "application/x-www-form-urlencoded" 420 | |> fun x -> TYPE, JString x 421 | mediaType :: props 422 | |> fun props -> 423 | List.concat [ props; action.fields |> Map.toList |> List.map (fun (Name n, f) -> f |> Field.serialize n) |> mkProperty FIELDS ] 424 | |> fun props -> (NAME, JString name) :: props 425 | |> Map.ofList 426 | |> JRecord 427 | 428 | [] 429 | [] 430 | module Link = 431 | 432 | let create rel href : Link = { 433 | href = href 434 | rel = rel, [] 435 | classes = List.empty 436 | title = None 437 | mediaType = None 438 | } 439 | 440 | let internal serialize (link: Link) = 441 | link.classes |> List.map (fun (Class c) -> JString c) |> mkProperty CLASS 442 | |> fun props -> 443 | let (Href href) = link.href 444 | (HREF, JString (href.ToString())) :: props 445 | |> fun props -> 446 | match link.title with Some (Title t) -> (TITLE, JString t) :: props | _ -> props 447 | |> fun props -> 448 | match link.mediaType with Some (MediaType mt) -> (TYPE, JString mt) :: props | _ -> props 449 | |> fun props -> 450 | List.concat [ props; fst link.rel :: snd link.rel |> List.map (fun (Rel rel) -> JString rel) |> mkProperty REL ] 451 | |> Map.ofList 452 | |> JRecord 453 | 454 | let withClasses classes link : Link = 455 | { link with classes = classes |> List.map Class } 456 | 457 | [] 458 | [] 459 | module internal Entity = 460 | 461 | let empty : Entity<'a> = { 462 | properties = Map.empty 463 | entities = List.empty 464 | actions = Map.empty 465 | links = List.empty 466 | classes = List.empty 467 | title = None 468 | } 469 | 470 | let rec serializeRec (rel: Rel option) (entity: Entity<'a>) = 471 | entity.classes |> List.map (fun (Class c) -> JString c) |> mkProperty CLASS 472 | |> fun props -> 473 | match entity.title with Some (Title t) -> (TITLE, JString t) :: props | _ -> props 474 | |> fun props -> 475 | match rel with Some (Rel r) -> (REL, JArray [ JString r ]) :: props | _ -> props 476 | |> fun props -> 477 | if entity.properties |> (not << Map.isEmpty) then 478 | let properties = (PROPERTIES, entity.properties |> Map.toList |> List.map (fun (Name n, v) -> n,v) |> Map.ofList |> JRecord) 479 | properties :: props 480 | else 481 | props 482 | |> fun props -> 483 | let embedded = 484 | entity.entities 485 | |> List.map 486 | (function 487 | | EmbeddedRepresentation (e,r) -> serializeRec (Some r) e 488 | | EmbeddedLink link -> link |> Link.serialize) 489 | |> mkProperty ENTITIES 490 | [ embedded; props ] 491 | |> fun propss -> 492 | (entity.links |> List.map Link.serialize |> mkProperty LINKS) :: propss 493 | |> fun propss -> 494 | List.concat ((entity.actions |> Map.toList |> List.map (fun (Name n, v) -> Action.serialize n v) |> mkProperty ACTIONS) :: propss) 495 | |> Map.ofList 496 | |> JRecord 497 | 498 | let withClasses classes entity : Entity<_> = 499 | { entity with classes = classes |> List.map Class } 500 | 501 | let addProperty name prop entity: Entity<'a> = 502 | { entity with properties = entity.properties.Add(Name name, JObject prop) } 503 | 504 | let withLinks links entity: Entity<'a> = 505 | { entity with links = links } 506 | 507 | let addEmbeddedLink link entity = 508 | { entity with entities = EmbeddedLink link :: entity.entities } 509 | 510 | let addEmbeddedEntity embedded rel entity = 511 | { entity with entities = EmbeddedRepresentation (embedded, Rel rel) :: entity.entities } 512 | 513 | let withActions actions entity = 514 | { entity with actions = actions |> List.map (fun (k,v) -> Name k, v) |> Map.ofList } 515 | 516 | let serialize entity = serializeRec None entity 517 | 518 | let toJson interpreter entity = 519 | entity |> serialize |> interpreter 520 | 521 | /// Contains the interpreter to transform an `JsonModel` into an `obj`. 522 | module ObjectInterpreter = 523 | 524 | /// Transforms an `JsonModel` into an `obj`. 525 | let rec interpret (instance: JsonModel) : obj = 526 | match instance with 527 | | JObject a -> a 528 | | JBool b -> b :> obj 529 | | JString s -> s :> obj 530 | | JRecord map -> map |> Map.map (fun _ v -> interpret v) :> obj 531 | | JArray a -> a |> List.map interpret :> obj 532 | 533 | [] 534 | module Siren = 535 | let toJson entity = Siren.Entity.toJson interpret entity 536 | 537 | [] 538 | module Hal = 539 | /// Serializes a HAL resource as `obj` 540 | let toJson resource = Hal.Resource.toJson interpret resource 541 | 542 | module FSharpDataIntepreter = 543 | 544 | open FSharp.Data 545 | 546 | /// Transforms an `JsonModel` into a `FSharp.Data.JsonValue`. 547 | let rec internal interpret (instance: JsonModel) : JsonValue = 548 | match instance with 549 | | JObject a -> a 550 | | JBool b -> JsonValue.Boolean b 551 | | JString s -> JsonValue.String s 552 | | JRecord map -> JsonValue.Record (map |> Map.toArray |> Array.map (fun (k,v) -> k, interpret v)) 553 | | JArray a -> JsonValue.Array (a |> List.map interpret |> List.toArray) 554 | 555 | [] 556 | module Hal = 557 | /// Serializes a HAL resource as `FSharp.Data.JsonValue` 558 | let toJson resource = Hal.Resource.toJson interpret resource 559 | 560 | [] 561 | module Siren = 562 | let toJSon entity = Siren.Entity.toJson interpret entity -------------------------------------------------------------------------------- /src/TicTacToe.Dsls.fsx: -------------------------------------------------------------------------------- 1 | module TicTacToe.Dsls 2 | 3 | #load "TicTacToe.fsx" 4 | 5 | open TicTacToe 6 | 7 | type Continuation<'output, 'next> = 'output -> 'next 8 | 9 | 10 | module Domain = 11 | type Domain<'next> = 12 | | Handle of (State * Command) * Continuation 13 | | Replay of Event list * Continuation 14 | 15 | let map f x = 16 | match x with 17 | | Handle(v, cont) -> Handle(v, cont >> f) 18 | | Replay(v, cont) -> Replay(v, cont >> f) 19 | 20 | 21 | module ReadModel = 22 | type GridRm = string list list 23 | type GameRm = { 24 | id: string 25 | grid: GridRm 26 | status: string 27 | } 28 | type GameListItemRm = { 29 | id: string 30 | status: string 31 | } 32 | 33 | type ReadModel<'next> = 34 | | SubscribeToEventBus of unit * Continuation 35 | | Game of GameId * Continuation 36 | | Games of unit * Continuation 37 | 38 | let map f x = 39 | match x with 40 | | SubscribeToEventBus(v, cont) -> SubscribeToEventBus(v, cont >> f) 41 | | Game(v, cont) -> Game(v, cont >> f) 42 | | Games(v, cont) -> Games(v, cont >> f) 43 | 44 | 45 | module EventStore = 46 | type EventStore<'next> = 47 | | GetStream of GameId * 48 | Continuation 49 | | Append of (GameId * Version * Event list) * 50 | Continuation 51 | 52 | let map f x = 53 | match x with 54 | | GetStream(v, cont) -> GetStream(v, cont >> f) 55 | | Append(v, cont) -> Append(v, cont >> f) 56 | 57 | 58 | module EventBus = 59 | type EventBus<'next> = 60 | | Publish of (GameId * Event list) * Continuation 61 | let map f x = 62 | match x with 63 | | Publish(v, cont) -> Publish(v, cont >> f) 64 | 65 | 66 | module TicTacToeDsl = 67 | type TicTacToeDsl<'next> = 68 | | Domain of Domain.Domain<'next> 69 | | EventStore of EventStore.EventStore<'next> 70 | | ReadModel of ReadModel.ReadModel<'next> 71 | | EventBus of EventBus.EventBus<'next> 72 | 73 | 74 | let map (f: 'a -> 'b) (dsl : TicTacToeDsl<'a>) : TicTacToeDsl<'b> = 75 | match dsl with 76 | | Domain d -> Domain.map f d |> Domain 77 | | EventStore es -> EventStore.map f es |> EventStore 78 | | EventBus bus -> EventBus.map f bus |> EventBus 79 | | ReadModel rm -> ReadModel.map f rm |> ReadModel 80 | 81 | 82 | module Free = 83 | open TicTacToeDsl 84 | 85 | type Free<'a> = 86 | | Pure of 'a 87 | | Free of TicTacToeDsl> 88 | 89 | [] 90 | module FreeMonad = 91 | let rec bind (f: 'a -> Free<'b>) (dsl : Free<'a>) : Free<'b> = 92 | match dsl with 93 | | Pure value -> f value 94 | | Free t -> map (bind f) t |> Free 95 | 96 | let liftF(dsl:TicTacToeDsl<'a>) : Free<'a> = 97 | Free (map Pure dsl) 98 | 99 | type FreeBuilder() = 100 | member x.Bind(dsl, f) = FreeMonad.bind f dsl 101 | member x.Return(value) = Pure value 102 | member x.Zero() = Pure () 103 | 104 | let free = new FreeBuilder() -------------------------------------------------------------------------------- /src/TicTacToe.Instructions.fsx: -------------------------------------------------------------------------------- 1 | module TicTacToe.Instructions 2 | 3 | #load "TicTacToe.Dsls.fsx" 4 | 5 | open Dsls.Free 6 | open Dsls.TicTacToeDsl 7 | 8 | module private Domain = 9 | open Dsls.Domain 10 | 11 | let handle v = FreeMonad.liftF(Handle(v, id) |> Domain) 12 | let replay v = FreeMonad.liftF(Replay(v, id) |> Domain) 13 | 14 | module private EventBus = 15 | open Dsls.EventBus 16 | 17 | let publish v = FreeMonad.liftF(Publish(v, id) |> EventBus) 18 | 19 | module private EventStore = 20 | open Dsls.EventStore 21 | 22 | let append v = FreeMonad.liftF(Append(v, id) |> EventStore) 23 | let getStream v = FreeMonad.liftF(GetStream(v, id) |> EventStore) 24 | 25 | module ReadModel = 26 | open Dsls.ReadModel 27 | 28 | let subscribe v = FreeMonad.liftF(SubscribeToEventBus(v, id) |> ReadModel) 29 | 30 | module Queries = 31 | open Dsls.ReadModel 32 | 33 | let game v = FreeMonad.liftF(Game(v, id) |> ReadModel) 34 | let games = FreeMonad.liftF(Games((), id) |> ReadModel) 35 | 36 | module Commands = 37 | let handle (id: GameId, cmd: Command) = 38 | free { 39 | let! events = EventStore.getStream id 40 | let! state = Domain.replay events 41 | let! (v, newEvents) = Domain.handle (state, cmd) 42 | do! EventStore.append (id, v, newEvents) 43 | do! EventBus.publish (id, newEvents) 44 | return () 45 | } 46 | -------------------------------------------------------------------------------- /src/TicTacToe.Interpreters.fsx: -------------------------------------------------------------------------------- 1 | module TicTacToe.Interpreters 2 | 3 | #load "TicTacToe.Instructions.fsx" 4 | 5 | open TicTacToe 6 | open TicTacToe.Instructions 7 | open Dsls 8 | 9 | #nowarn "40" 10 | type Actor<'T> = MailboxProcessor<'T> 11 | 12 | module Effects = 13 | open Chessie.ErrorHandling 14 | 15 | type Error = string 16 | type Effect<'a> = AsyncResult<'a, Error> 17 | let ofResult r: Effect<'a> = r |> Async.singleton |> AR 18 | 19 | let effects = asyncTrial 20 | 21 | let bind (f: 'a -> Effect<'b>) (x: Effect<'a>): Effect<'b> = 22 | effects { 23 | let! v = x 24 | return! f v 25 | } 26 | 27 | let (>>=) x f = bind f x 28 | 29 | let singleton x: Effect<'a> = ok x |> ofResult 30 | 31 | 32 | module TicTacToe = 33 | open Chessie.ErrorHandling 34 | open Effects 35 | open Dsls.TicTacToeDsl 36 | open Free 37 | 38 | let rec interpret dom chan es rm dsl = 39 | let interpretRec = interpret dom chan es rm 40 | match dsl with 41 | | Pure v -> singleton v 42 | | Free free -> 43 | match free with 44 | | Domain x -> dom x >>= interpretRec 45 | | EventBus x -> chan x >>= interpretRec 46 | | EventStore x -> es x >>= interpretRec 47 | | ReadModel x -> rm x >>= interpretRec 48 | 49 | 50 | module Domain = 51 | open Chessie.ErrorHandling 52 | open Effects 53 | open Dsls.Domain 54 | 55 | let interpret dsl: Effect<'a> = 56 | match dsl with 57 | | Handle((state, cmd), cont) -> 58 | Domain.handle state cmd |> Trial.lift cont |> Effects.ofResult 59 | | Replay(events, cont) -> 60 | Domain.replay events |> Trial.lift cont |> Effects.ofResult 61 | 62 | 63 | module EventStore = 64 | open Chessie.ErrorHandling 65 | open Effects 66 | open Dsls.EventStore 67 | 68 | type Stream = { mutable events: (Event * Version) list } 69 | 70 | type EventStoreMsg = 71 | | AppendToStream of string * int * Event list * AsyncReplyChannel> 72 | | TryGetStream of string * AsyncReplyChannel 73 | 74 | let eventStoreActor = 75 | Actor.Start(fun inbox -> 76 | let rec loop (eventStore: Map) = 77 | async { 78 | let! msg = inbox.Receive() 79 | match msg with 80 | | AppendToStream (streamId, v, events, rc) -> 81 | let eventsWithVersion = 82 | events 83 | |> List.mapi (fun i e -> (e, Version (v + i + 1))) 84 | match eventStore.TryFind streamId with 85 | | Some(stream) -> 86 | if (stream.events |> List.last |> snd) <> Version v then 87 | rc.Reply(fail "resource has been modified, cannot make changes") 88 | else 89 | ignore (stream.events <- stream.events @ eventsWithVersion) 90 | rc.Reply(ok ()) 91 | return! loop eventStore 92 | | None -> 93 | rc.Reply(ok ()) 94 | return! loop (eventStore.Add(streamId, { events = eventsWithVersion })) 95 | | TryGetStream (streamId, rc) -> 96 | rc.Reply(eventStore.TryFind streamId) 97 | return! loop eventStore 98 | } 99 | loop Map.empty) 100 | 101 | let interpret dsl = 102 | match dsl with 103 | | GetStream(GameId gId, cont) -> 104 | async { 105 | let! maybeStream = eventStoreActor.PostAndAsyncReply(fun rc -> TryGetStream (gId.ToString(), rc)) 106 | return 107 | match maybeStream with 108 | | Some(stream) -> 109 | stream.events 110 | |> List.map fst 111 | | None -> [] 112 | |> cont |> ok 113 | } |> AR 114 | 115 | | Append(((GameId gId), (Version v), newEvents), cont) -> 116 | async { 117 | let! result = eventStoreActor.PostAndAsyncReply(fun rc -> AppendToStream (gId.ToString(), v, newEvents, rc)) 118 | return cont result 119 | } |> AR 120 | 121 | 122 | module EventBus = 123 | open Chessie.ErrorHandling 124 | open Effects 125 | open Dsls.EventBus 126 | 127 | type Actor<'T> = MailboxProcessor<'T> 128 | 129 | type EventBusMsg = 130 | | Subscribe of (GameId * Event -> unit) 131 | | PublishEvents of GameId * Event list 132 | 133 | let eventBusActor = 134 | Actor.Start(fun inbox -> 135 | let rec loop (handlers: List unit>) = 136 | async { 137 | let! msg = inbox.Receive() 138 | match msg with 139 | | Subscribe handler -> 140 | return! loop (handler :: handlers) 141 | | PublishEvents (id, events) -> 142 | handlers |> List.iter (fun handle -> 143 | events |> List.iter (fun event -> 144 | handle (id, event))) 145 | return! loop handlers 146 | } 147 | loop List.empty) 148 | 149 | let interpret dsl = 150 | match dsl with 151 | | Publish((id, events), cont) -> 152 | do eventBusActor.Post(PublishEvents(id, events)) 153 | () |> cont |> ok |> Effects.ofResult 154 | 155 | 156 | module ReadModel = 157 | open Chessie.ErrorHandling 158 | open Effects 159 | open Dsls.ReadModel 160 | 161 | let emptyGridRm = [ 162 | [""; ""; ""] 163 | [""; ""; ""] 164 | [""; ""; ""] 165 | ] 166 | 167 | let updateGrid (rm: GameRm) pos mark = 168 | let update m (grid: GridRm) (v,h) = 169 | grid |> List.mapi (fun v' hLine -> 170 | if v' = v then 171 | hLine 172 | |> List.mapi (fun h' m' -> if h' = h then m else m') 173 | else 174 | hLine) 175 | 176 | let mapToCoords (v,h) = 177 | match (v,h) with 178 | | Top, Left -> 0,0 179 | | Top, HCenter -> 0,1 180 | | Top, Right -> 0,2 181 | | VCenter, Left -> 1,0 182 | | VCenter, HCenter -> 1,1 183 | | VCenter, Right -> 1,2 184 | | Bottom, Left -> 2,0 185 | | Bottom, HCenter -> 2,1 186 | | Bottom, Right -> 2,2 187 | 188 | mapToCoords pos |> update mark rm.grid 189 | 190 | type ReadModelMsg = 191 | | AddGame of GameId * string 192 | | UpdateGame of GameId * Position * string * string 193 | | UpdateGameStatus of GameId * string 194 | | UpsertGames of GameId * GameListItemRm 195 | | TryFind of GameId * AsyncReplyChannel 196 | | GameList of AsyncReplyChannel 197 | 198 | let readModelsActor = 199 | Actor.Start(fun inbox -> 200 | let rec loop (games: Map, gameList: Map) = 201 | async { 202 | let! msg = inbox.Receive() 203 | match msg with 204 | | AddGame (GameId gameId, status) -> 205 | return! loop (games.Add(GameId gameId, { id = gameId.ToString(); grid = emptyGridRm; status = status }), gameList) 206 | | UpdateGameStatus (gameId, status) -> 207 | match games.TryFind gameId with 208 | | Some ({ id = id; grid = grid; status = _ }) -> 209 | return! loop (games.Add(gameId, { id = id; grid = grid; status = status }), gameList) 210 | | _ -> return! loop (games, gameList) 211 | | UpdateGame (gameId, pos, marker, status) -> 212 | match games.TryFind gameId with 213 | | Some rm -> 214 | let grid = updateGrid rm pos marker 215 | return! loop (games.Add(gameId, { rm with grid = grid; status = status }), gameList) 216 | | None -> return! loop (games, gameList) 217 | | UpsertGames (gameId, listItem) -> 218 | return! loop (games, gameList.Add(gameId, listItem)) 219 | | TryFind (gameId, rc) -> 220 | rc.Reply(games.TryFind gameId) 221 | return! loop (games, gameList) 222 | | GameList rc -> 223 | rc.Reply(gameList |> Map.toList |> List.map snd) 224 | return! loop (games, gameList) 225 | } 226 | loop (Map.empty, Map.empty)) 227 | 228 | let eventHandler (GameId id, event) = 229 | match event with 230 | | Started -> 231 | do readModelsActor.Post(UpsertGames(GameId id, { id = id.ToString(); status = "running" })) 232 | do readModelsActor.Post(AddGame(GameId id, "player X to play")) 233 | | PlayerXPlayed pos -> 234 | do readModelsActor.Post(UpdateGame(GameId id, pos, "X", "player O to play")) 235 | do readModelsActor.Post(UpdateGameStatus(GameId id, "player O to play")) 236 | | PlayerOPlayed pos -> 237 | do readModelsActor.Post(UpdateGame(GameId id, pos, "O", "player X to play")) 238 | do readModelsActor.Post(UpdateGameStatus(GameId id, "player X to play")) 239 | | PlayerXWon -> 240 | do readModelsActor.Post(UpsertGames(GameId id, { id = id.ToString(); status = "finished (player X won)" })) 241 | do readModelsActor.Post(UpdateGameStatus(GameId id, "player X won")) 242 | | PlayerOWon -> 243 | do readModelsActor.Post(UpsertGames(GameId id, { id = id.ToString(); status = "finished (player O won)" })) 244 | do readModelsActor.Post(UpdateGameStatus(GameId id, "player O won")) 245 | | Tied -> 246 | do readModelsActor.Post(UpsertGames(GameId id, { id = id.ToString(); status = "finished (tie)" })) 247 | do readModelsActor.Post(UpdateGameStatus(GameId id, "tie")) 248 | 249 | let interpret dsl = 250 | match dsl with 251 | | SubscribeToEventBus(_, cont) -> 252 | do EventBus.eventBusActor.Post(EventBus.Subscribe(eventHandler)) 253 | () |> cont |> Effects.singleton 254 | | Game(id, cont) -> 255 | async{ 256 | let! maybeGame = readModelsActor.PostAndAsyncReply(fun rc -> TryFind(id, rc)) 257 | return 258 | maybeGame |> Trial.failIfNone "not found" 259 | |> Trial.lift cont 260 | } |> AR 261 | | Games(_, cont) -> 262 | async { 263 | let! games = readModelsActor.PostAndAsyncReply(fun rc -> GameList(rc)) 264 | return games |> cont |> ok 265 | } |> AR 266 | -------------------------------------------------------------------------------- /src/TicTacToe.fsx: -------------------------------------------------------------------------------- 1 | module TicTacToe 2 | 3 | #r "../packages/Chessie/lib/net40/Chessie.dll" 4 | 5 | open System 6 | 7 | [] 8 | module Types = 9 | open Chessie.ErrorHandling 10 | 11 | type GameId = GameId of Guid 12 | 13 | type Marker = X | O | Empty 14 | 15 | type Horizontal = Left | HCenter | Right 16 | type Vertical = Top | VCenter | Bottom 17 | 18 | type Position = Vertical * Horizontal 19 | 20 | type Square = Vertical * Horizontal * Marker 21 | 22 | type Player = 23 | | PlayerX 24 | | PlayerO 25 | 26 | type Grid = Square list 27 | 28 | type Game = 29 | | Initial 30 | | PlayerXToPlay of Grid 31 | | PlayerOToPlay of Grid 32 | | PlayerXWins of Grid 33 | | PlayerOWins of Grid 34 | | Tie of Grid 35 | 36 | type Version = Version of int 37 | type State = Version * Game 38 | 39 | type Error = String 40 | 41 | type Command = 42 | | Start 43 | | PlayX of Position 44 | | PlayO of Position 45 | 46 | type Event = 47 | | Started 48 | | PlayerXPlayed of Position 49 | | PlayerOPlayed of Position 50 | | PlayerXWon 51 | | PlayerOWon 52 | | Tied 53 | 54 | type VersionedEvents = GameId * Version * Event list 55 | 56 | 57 | module Domain = 58 | open Chessie.ErrorHandling 59 | let private hLines = [ 60 | [(Top, Left); (Top, HCenter); (Top, Right)] 61 | [(VCenter, Left); (VCenter, HCenter); (VCenter, Right)] 62 | [(Bottom, Left); (Bottom, HCenter); (Bottom, Right)] 63 | ] 64 | 65 | let private vLines = [ 66 | [(Top, Left); (VCenter, Left); (Bottom, Left)] 67 | [(Top, HCenter); (VCenter, HCenter); (Bottom, HCenter)] 68 | [(Top, Right); (VCenter, Right); (Bottom, Right)] 69 | ] 70 | 71 | let private diag = [ 72 | [(Top, Left); (VCenter, HCenter); (Bottom, Right)] 73 | [(Bottom, Left); (VCenter, HCenter); (Top, Right)] 74 | ] 75 | 76 | let private marker = function PlayerX _ -> X | PlayerO _ -> O 77 | 78 | let private equals (v, h) (v', h', _) = v' = v && h' = h 79 | 80 | let private placeMarker grid player (v, h) = 81 | if grid |> List.exists (equals (v, h)) then 82 | fail "square already marked" 83 | else 84 | ok ((v, h, marker player) :: grid, player, v, h) 85 | 86 | let private getMarker (grid: Grid) pos = 87 | let square = grid |> List.tryFind (equals pos) 88 | match square with 89 | | Some (_,_,m) -> m 90 | | None -> Empty 91 | 92 | let private isLineOnlyPlayerBy player grid line = 93 | line 94 | |> List.map (getMarker grid) 95 | |> List.forall (fun m -> 96 | match m, player with 97 | | X, PlayerX -> true 98 | | O, PlayerO -> true 99 | | _ -> false) 100 | 101 | let private eval (grid, player, v, h) = 102 | let wins = isLineOnlyPlayerBy player grid 103 | 104 | match hLines @ vLines @ diag |> List.exists wins, player with 105 | | true, PlayerX -> PlayerXWins grid 106 | | true, PlayerO -> PlayerOWins grid 107 | | _, PlayerX when grid |> List.length < 9 -> PlayerOToPlay grid 108 | | _, PlayerO when grid |> List.length < 9 -> PlayerXToPlay grid 109 | | _ -> Tie grid 110 | 111 | let replay (events: Event list) : Result = 112 | 113 | let replayError errs = errs |> List.map (fun err -> sprintf "replay error, %s" err) 114 | 115 | let apply state event: Result = 116 | match state, event with 117 | | Initial, Started -> 118 | PlayerXToPlay [] |> ok 119 | | PlayerXToPlay grid, PlayerXPlayed pos -> 120 | placeMarker grid PlayerX pos |> Trial.lift eval |> Trial.mapFailure replayError 121 | | PlayerOToPlay grid, PlayerOPlayed pos -> 122 | placeMarker grid PlayerO pos |> Trial.lift eval |> Trial.mapFailure replayError 123 | | PlayerXToPlay grid, _ -> 124 | fail "replay error, wrong turn" 125 | | PlayerOToPlay grid, _ -> fail "replay error, wrong turn" 126 | | _ -> 127 | fail "replay error, game is finished" 128 | 129 | let folder errorOrState event = 130 | trial { 131 | let! (Version v, s) = errorOrState 132 | let! game = apply s event 133 | return v + 1 |> Version, game 134 | } 135 | 136 | events |> List.fold folder (ok (Version -1, Initial)) 137 | 138 | let handle (version: Version, game: Game) (cmd: Command): Result = 139 | let xToPlayAndXPlays grid pos = 140 | trial { 141 | let! state = placeMarker grid PlayerX pos 142 | let evaluatedState = eval state 143 | let events = 144 | match evaluatedState with 145 | | PlayerOToPlay _ -> [PlayerXPlayed pos] 146 | | PlayerXWins _ -> [PlayerXPlayed pos; PlayerXWon] 147 | | _ -> [] 148 | return version, events 149 | } 150 | 151 | let oToPlayAndOPlays grid pos = 152 | trial { 153 | let! state = placeMarker grid PlayerO pos 154 | let evaluatedState = eval state 155 | let events = 156 | match evaluatedState with 157 | | PlayerXToPlay _ -> [PlayerOPlayed pos] 158 | | PlayerOWins _ -> [PlayerOPlayed pos; PlayerOWon] 159 | | Tie _ -> [PlayerOPlayed pos; Tied] 160 | | _ -> [] 161 | return version, events 162 | } 163 | 164 | match game, cmd with 165 | | Initial, Start -> 166 | ok (version, [Started]) 167 | | PlayerXToPlay grid, PlayX pos -> 168 | xToPlayAndXPlays grid pos 169 | | PlayerOToPlay grid, PlayO pos -> 170 | oToPlayAndOPlays grid pos 171 | | PlayerXToPlay grid, PlayO _ -> 172 | fail "not your turn" 173 | | PlayerOToPlay grid, PlayX _ -> 174 | fail "not your turn" 175 | | _ -> fail "game is finished" 176 | --------------------------------------------------------------------------------