diff --git a/deploy/docker/Dockerfile b/deploy/docker/Dockerfile index 0ec84cd..89d1e5b 100644 --- a/deploy/docker/Dockerfile +++ b/deploy/docker/Dockerfile @@ -2,8 +2,7 @@ FROM ocaml/opam:alpine-ocaml-5.3-flambda AS build WORKDIR /usr/app -RUN opam repository add git https://github.com/ocaml/opam-repository.git --all-switches --set-default && \ - sudo apk add --no-cache --update \ +RUN sudo apk add --no-cache --update \ make linux-headers pkgconfig musl-dev gmp-dev libev-dev sqlite-dev nodejs npm ADD --chown=opam scrum-cards.opam package.json package-lock.json ./ @@ -12,8 +11,8 @@ ARG OPAMJOBS=2 ENV OPAMJOBS=$OPAMJOBS RUN npm install -RUN opam update -RUN opam install . --yes --deps-only && eval $(opam env) +RUN opam repository add git https://github.com/ocaml/opam-repository.git --all-switches --set-default && \ + opam install . --yes --deps-only && eval $(opam env) ADD --chown=opam . . RUN make release diff --git a/dune-project b/dune-project index 30ad6a5..942ba2b 100644 --- a/dune-project +++ b/dune-project @@ -24,7 +24,6 @@ (synopsis "A scrum estimation poker application") (depends ocaml - core cmdliner crunch cohttp-lwt-unix diff --git a/scrum-cards.opam b/scrum-cards.opam index 8741651..0dbd312 100644 --- a/scrum-cards.opam +++ b/scrum-cards.opam @@ -8,7 +8,6 @@ homepage: "https://github.com/ewert-online/scrum-cards" bug-reports: "https://github.com/ewert-online/scrum-cards/issues" depends: [ "ocaml" - "core" "cmdliner" "crunch" "cohttp-lwt-unix" diff --git a/src/server/dune b/src/server/dune index 5cd3c8a..c6206ba 100644 --- a/src/server/dune +++ b/src/server/dune @@ -1,9 +1,8 @@ (library (name server) - (flags :standard -open Shared_server) + (flags :standard -open Shared_server -open Lwt.Syntax) (libraries shared_server - core mirage-crypto-rng.unix cohttp cohttp-lwt-unix @@ -17,7 +16,7 @@ irmin-fs.unix randomconv) (preprocess - (pps ppx_jane ppx_irmin))) + (pps ppx_irmin))) (rule (target assets.ml) diff --git a/src/server/game.ml b/src/server/game.ml index 1df11e4..705f336 100644 --- a/src/server/game.ml +++ b/src/server/game.ml @@ -1,19 +1,16 @@ -open Core - module RandomId = struct let make ~len () = let string n = Mirage_crypto_rng.generate n in let seq gen = Seq.unfold (fun () -> Some (gen (), ())) () in - let list gen n = seq gen |> Seq.take n |> Stdlib.List.of_seq in + let list gen n = seq gen |> Seq.take n in let alphanum () = match Randomconv.int ~bound:10 string >= 5 with - | false -> Char.of_int_exn (48 + Randomconv.int ~bound:9 string) - | true -> Char.of_int_exn (97 + Randomconv.int ~bound:25 string) + | false -> Char.chr (48 + Randomconv.int ~bound:9 string) + | true -> Char.chr (97 + Randomconv.int ~bound:25 string) in let random_list = list alphanum len in - let id = String.of_char_list random_list in - + let id = String.of_seq random_list in id ;; end @@ -24,17 +21,17 @@ let create ~name ~deck ~reveal = let deck = Shared.Game.Deck.make deck in let game = Storage.Contents.{ name; deck; reveal } in - let%bind.Lwt store = Storage.main_branch () in + let* store = Storage.main_branch () in let rec insert () = let id = RandomId.make ~len:9 () in - let%bind.Lwt exists = Storage.Store.mem store [ id ] in + let* exists = Storage.Store.mem store [ id ] in match exists with | true -> insert () | false -> let info = Storage.Info.v ~author:"Example" "Create game with id %S" id in (try - let%bind.Lwt () = Storage.Store.set_exn ~info store [ id ] game in + let* () = Storage.Store.set_exn ~info store [ id ] game in Lwt.return id with | _ -> insert ()) @@ -44,7 +41,7 @@ let create ~name ~deck ~reveal = ;; let load id = - let%bind.Lwt store = Storage.main_branch () in - let%bind.Lwt game = Storage.Store.find store [ id ] in + let* store = Storage.main_branch () in + let* game = Storage.Store.find store [ id ] in Lwt.return game ;; diff --git a/src/server/player_session.ml b/src/server/player_session.ml index f7e15f7..697a9b4 100644 --- a/src/server/player_session.ml +++ b/src/server/player_session.ml @@ -22,16 +22,15 @@ let name = "scrum-cards.session" let store = Session.Backend.create () let get_session request = - let%bind.Lwt session = - request |> Cohttp.Request.headers |> Session.of_header store name - in + let* session = request |> Cohttp.Request.headers |> Session.of_header store name in match session with | Error _ | Ok None -> Lwt.return_none | Ok (Some session) -> Lwt.return_some session ;; let is_valid request = - match%bind.Lwt get_session request with + let* session = get_session request in + match session with | None -> Lwt.return_false | Some session -> (try @@ -42,22 +41,22 @@ let is_valid request = ;; let invalidate request = - let%bind.Lwt session = - request |> Cohttp.Request.headers |> Session.of_header store name - in + let* session = request |> Cohttp.Request.headers |> Session.of_header store name in match session with | Error _ | Ok None -> Lwt.return_unit | Ok (Some session) -> Session.clear store session ;; let get_key request = - match%bind.Lwt get_session request with + let* session = get_session request in + match session with | None -> Lwt.return_none | Some session -> Lwt.return_some session.Session.key ;; let get_spectator request = - match%bind.Lwt get_session request with + let* session = get_session request in + match session with | None -> Lwt.return_none | Some session -> (try @@ -68,7 +67,8 @@ let get_spectator request = ;; let get_name request = - match%bind.Lwt get_session request with + let* session = get_session request in + match session with | None -> Lwt.return_none | Some session -> (try @@ -79,7 +79,8 @@ let get_name request = ;; let get_played_card request = - match%bind.Lwt get_session request with + let* session = get_session request in + match session with | None -> Lwt.return_none | Some session -> (try @@ -90,7 +91,8 @@ let get_played_card request = ;; let set_played_card request played_card = - match%bind.Lwt get_session request with + let* session = get_session request in + match session with | None -> Lwt.return_unit | Some session -> (try @@ -102,7 +104,8 @@ let set_played_card request played_card = ;; let set_payload request payload = - match%bind.Lwt get_session request with + let* session = get_session request in + match session with | None -> Lwt.return () | Some session -> (try diff --git a/src/server/routes.ml b/src/server/routes.ml index db19d68..b3f218d 100644 --- a/src/server/routes.ml +++ b/src/server/routes.ml @@ -38,7 +38,7 @@ let join_game _id request = let run = let open Player_session in let request_headers = Cohttp.Request.headers request in - let%bind.Lwt session = Session.of_header_or_create store name "" request_headers in + let* session = Session.of_header_or_create store name "" request_headers in let headers = Session.to_cookie_hdrs ~path:"/" ~http_only:true name session in home ~headers request in @@ -77,7 +77,7 @@ let static path request = module Api = struct let create_game body request = let run = - let%bind.Lwt body = Cohttp_lwt.Body.to_string body in + let* body = Cohttp_lwt.Body.to_string body in let payload = Shared.Api.Game.Api.Create.request_of_json @@ Yojson.Basic.from_string body in @@ -86,7 +86,7 @@ module Api = struct let deck = payload.deck in let reveal = payload.reveal in - let%bind.Lwt game_id = Game.create ~name ~deck ~reveal in + let* game_id = Game.create ~name ~deck ~reveal in Respond.yojson @@ Shared.Api.Game.Api.Create.response_to_json { id = game_id } in @@ -98,7 +98,7 @@ module Api = struct let get_game id request = let run = - let%bind.Lwt game = Game.load id in + let* game = Game.load id in match game with | None -> Respond.empty `Not_found @@ -119,7 +119,7 @@ module Api = struct let join_game body _id request = let run = - let%bind.Lwt body = Cohttp_lwt.Body.to_string body in + let* body = Cohttp_lwt.Body.to_string body in let payload = Shared.Api.Game.Api.Join.request_of_json @@ Yojson.Basic.from_string body in @@ -131,7 +131,7 @@ module Api = struct | `Player -> false in - let%bind.Lwt () = + let* () = Player_session.set_payload request Player_session.Payload.{ name; spectator; played_card = None } @@ -146,7 +146,7 @@ module Api = struct let leave_game id request = let run = - let%bind.Lwt () = Player_session.invalidate request in + let* () = Player_session.invalidate request in Cohttp_lwt_unix.Server.respond_redirect ~uri:(Uri.of_string Shared.Routes.(Builder.sprintf (join_game ()) id)) () @@ -159,9 +159,9 @@ module Api = struct let who_am_i request = let run = - let%bind.Lwt id = Player_session.get_key request in - let%bind.Lwt name = Player_session.get_name request in - let%bind.Lwt spectator = Player_session.get_spectator request in + let* id = Player_session.get_key request in + let* name = Player_session.get_name request in + let* spectator = Player_session.get_spectator request in match id, name, spectator with | Some id, Some name, Some true -> diff --git a/src/server/storage.ml b/src/server/storage.ml index 811d9eb..0fedc3e 100644 --- a/src/server/storage.ml +++ b/src/server/storage.ml @@ -1,5 +1,3 @@ -open Core - module Contents = struct type t = { name : string @@ -16,7 +14,7 @@ module Store = Irmin_fs_unix.KV.Make (Contents) let config = Irmin_fs.config (Filename.concat (Stdlib.Sys.getcwd ()) "db") let main_branch () = - let%bind.Lwt repo = Store.Repo.v config in + let* repo = Store.Repo.v config in Store.main repo ;; diff --git a/src/server/websocket_handler.ml b/src/server/websocket_handler.ml index 9680424..3e35def 100644 --- a/src/server/websocket_handler.ml +++ b/src/server/websocket_handler.ml @@ -1,5 +1,3 @@ -open Core - module Game = struct type t = { result : (string * int) list option @@ -12,105 +10,122 @@ module Game = struct ; typ : Shared.Api.Player.typ ; name : string ; selected_value : Shared.Api.Player.card_value option - ; pinged : Time_float.t option + ; pinged : float option } - let storage : (string, t) Hashtbl.t = Hashtbl.create (module String) + let storage : (string, t) Hashtbl.t = Hashtbl.create 1 let get_players game_id = - let game = Hashtbl.find storage game_id in + let game = Hashtbl.find_opt storage game_id in match game with | None -> [] | Some game -> game.players ;; let add_player game_id player = - Hashtbl.change storage game_id ~f:(function - | None -> Some { result = None; players = [ player ] } + let game = + match Hashtbl.find_opt storage game_id with + | None -> { result = None; players = [ player ] } | Some game -> - if List.exists game.players ~f:(fun { id; _ } -> String.equal id player.id) - then Some game + if List.exists (fun { id; _ } -> String.equal id player.id) game.players + then game else ( let players = player :: game.players in - Some { game with players })) + { game with players }) + in + + Hashtbl.replace storage game_id game ;; let update_players game_id f = - Hashtbl.change storage game_id ~f:(function - | None -> None - | Some game -> Some { game with players = List.map game.players ~f }) + match Hashtbl.find_opt storage game_id with + | None -> () + | Some game -> + Hashtbl.replace storage game_id { game with players = List.map f game.players } ;; let update_or_remove_players game_id f = - Hashtbl.change storage game_id ~f:(function - | None -> None - | Some game -> Some { game with players = List.filter_map game.players ~f }) + match Hashtbl.find_opt storage game_id with + | None -> () + | Some game -> + Hashtbl.replace + storage + game_id + { game with players = List.filter_map f game.players } ;; let update_players_and_return game_id f = let updatedPlayers = ref [] in - Hashtbl.change storage game_id ~f:(function - | None -> None + let () = + match Hashtbl.find_opt storage game_id with + | None -> () | Some game -> - let players = List.map game.players ~f in + let players = List.map f game.players in updatedPlayers := players; - Some { game with players }); + Hashtbl.replace storage game_id { game with players } + in !updatedPlayers ;; let remove_player game_id player_id = - Hashtbl.change storage game_id ~f:(function - | None -> None - | Some game -> - let players = - List.filter game.players ~f:(fun data -> not @@ String.equal data.id player_id) - in - Some { game with players }) + match Hashtbl.find_opt storage game_id with + | None -> () + | Some game -> + let players = + List.filter (fun data -> not @@ String.equal data.id player_id) game.players + in + Hashtbl.replace storage game_id { game with players } ;; let reveal game_id = - Hashtbl.change storage game_id ~f:(function - | None -> None - | Some game -> - let result = - let module Map = Stdlib.Map.Make (String) in - List.fold game.players ~init:Map.empty ~f:(fun acc player -> - match player.selected_value with - | None -> acc - | Some value -> - (match Map.find_opt value acc with - | None -> Map.add value 1 acc - | Some x -> Map.add value (x + 1) acc)) - |> Map.to_list - in - Some { game with result = Some result }) + match Hashtbl.find_opt storage game_id with + | None -> () + | Some game -> + let result = + let module Map = Stdlib.Map.Make (String) in + Map.to_list + @@ List.fold_left + (fun acc player -> + match player.selected_value with + | None -> acc + | Some value -> + (match Map.find_opt value acc with + | None -> Map.add value 1 acc + | Some x -> Map.add value (x + 1) acc)) + Map.empty + game.players + in + Hashtbl.replace storage game_id { game with result = Some result } ;; let reset game_id = - Hashtbl.change storage game_id ~f:(function - | None -> None - | Some game -> Some { game with result = None }) + match Hashtbl.find_opt storage game_id with + | None -> () + | Some game -> Hashtbl.replace storage game_id { game with result = None } ;; let is_revealed game_id = - match Hashtbl.find storage game_id with + match Hashtbl.find_opt storage game_id with | None -> false | Some { result = None } -> false | Some { result = Some _ } -> true ;; let get_public_game_state game_id = - match Hashtbl.find storage game_id with + match Hashtbl.find_opt storage game_id with | None -> Shared.Api.Game.{ result = None; players = [] } | Some game -> let players = - List.map game.players ~f:(fun { id; name; typ; selected_value; _ } -> - let played_card = - Option.map selected_value ~f:(fun v -> - if Option.is_some game.result then `Revealed v else `Hidden) - in - Shared.Api.Player.{ id; typ; name; played_card }) + List.map + (fun { id; name; typ; selected_value; _ } -> + let played_card = + Option.map + (fun v -> if Option.is_some game.result then `Revealed v else `Hidden) + selected_value + in + Shared.Api.Player.{ id; typ; name; played_card }) + game.players in Shared.Api.Game.{ result = game.result; players } ;; @@ -146,7 +161,7 @@ let send_current_game_state ~client_id ?(only_me = false) request game_id = ;; let send_current_card ~client_id request game_id = - let%bind.Lwt card = Player_session.get_played_card request in + let* card = Player_session.get_played_card request in send ~client_id ~only_me:true @@ -164,16 +179,16 @@ let handle_message ~client_id request game_id message = let message = Yojson.Basic.from_string message in match Shared.Api.Websocket.request_of_json message with | Shared.Api.Websocket.PlayCard value -> - let%bind.Lwt () = Player_session.set_played_card request (Some value) in - let%bind.Lwt () = send_current_card ~client_id request game_id in + let* () = Player_session.set_played_card request (Some value) in + let* () = send_current_card ~client_id request game_id in Game.update_players game_id (function | data when String.equal data.id client_id -> { data with selected_value = Some value } | p -> p); send_current_game_state ~client_id request game_id | Shared.Api.Websocket.RevokeCard -> - let%bind.Lwt () = Player_session.set_played_card request None in - let%bind.Lwt () = send_current_card ~client_id request game_id in + let* () = Player_session.set_played_card request None in + let* () = send_current_card ~client_id request game_id in Game.update_players game_id (function | data when String.equal data.id client_id -> { data with selected_value = None } | p -> p); @@ -186,8 +201,8 @@ let handle_message ~client_id request game_id message = Game.update_players game_id (fun data -> { data with selected_value = None }); send ~client_id request game_id (Shared.Api.Websocket.response_to_json Reset) | Shared.Api.Websocket.ResetMe -> - let%bind.Lwt () = Player_session.set_played_card request None in - let%bind.Lwt () = send_current_card ~client_id request game_id in + let* () = Player_session.set_played_card request None in + let* () = send_current_card ~client_id request game_id in send_current_game_state ~client_id ~only_me:true request game_id | Shared.Api.Websocket.Pong -> Lwt.return @@ -199,7 +214,7 @@ let handle_message ~client_id request game_id message = let handle_client ~session request game_id socket message_stream = let client_id = session.Player_session.Session.key in - let current_time = Time_float.now () in + let current_time = Unix.time () in let ping_message = Yojson.Basic.to_string @@ Shared.Api.Websocket.response_to_json Ping in @@ -208,14 +223,11 @@ let handle_client ~session request game_id socket message_stream = | None -> player.socket (Some (Websocket.Frame.create ~content:ping_message ())); Some { player with pinged = Some current_time } - | Some time -> - if Time_float.Span.(Time_float.abs_diff current_time time > of_int_sec 10) - then None - else Some player); + | Some time -> if current_time -. time > 10. then None else Some player); - let%bind.Lwt name = Player_session.get_name request in - let%bind.Lwt spectator = Player_session.get_spectator request in - let%bind.Lwt selected_value = Player_session.get_played_card request in + let* name = Player_session.get_name request in + let* spectator = Player_session.get_spectator request in + let* selected_value = Player_session.get_played_card request in let typ = match spectator with @@ -233,13 +245,14 @@ let handle_client ~session request game_id socket message_stream = ; selected_value ; pinged = None }; - let%bind.Lwt () = send_current_game_state ~client_id request game_id in - let%bind.Lwt () = send_current_card ~client_id request game_id in + let* () = send_current_game_state ~client_id request game_id in + let* () = send_current_card ~client_id request game_id in let rec loop () = - match%bind.Lwt Lwt_stream.get message_stream with + let* message = Lwt_stream.get message_stream in + match message with | Some Websocket.Frame.{ opcode = Opcode.Text; content; _ } -> - let%bind.Lwt () = handle_message ~client_id request game_id content in + let* () = handle_message ~client_id request game_id content in loop () | Some Websocket.Frame.{ opcode = Opcode.Ping; _ } -> let pong = Websocket.Frame.create ~opcode:Websocket.Frame.Opcode.Pong () in @@ -249,7 +262,7 @@ let handle_client ~session request game_id socket message_stream = let close = if String.length content >= 2 then ( - let content = String.sub content ~pos:0 ~len:2 in + let content = String.sub content 0 2 in Websocket.Frame.create ~opcode:Websocket.Frame.Opcode.Close ~content ()) else Websocket.Frame.close 1000 in @@ -262,7 +275,7 @@ let handle_client ~session request game_id socket message_stream = ;; let route game_id request = - let%bind.Lwt session = Player_session.get_session request in + let* session = Player_session.get_session request in match session with | Some session -> let message_stream, push = Lwt_stream.create () in @@ -275,13 +288,11 @@ let route game_id request = | _ -> () in - let%bind.Lwt response, socket = - Websocket_cohttp_lwt.upgrade_connection request handler - in + let* response, socket = Websocket_cohttp_lwt.upgrade_connection request handler in Lwt.async (fun () -> handle_client ~session request game_id socket message_stream); Lwt.return response | None -> - let%bind.Lwt response = + let* response = Cohttp_lwt_unix.Server.respond ~status:`Unauthorized ~body:`Empty () in Lwt.return (`Response response)