dream sql_sessions

first one...

.gitea/workflows/build.yaml

@@ -0,0 +1,34 @@
+name: build
+run-name: build
+on: [push]
+
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    container:
+      image: zapashcanon/gitea-ocaml-ci:latest
+    steps:
+      - name: checkout
+        uses: actions/checkout@v4
+      - name: depext
+        run: |
+          opam install . --depext-only --with-test --with-doc --with-dev-setup -y
+      - name: setup
+        run: |
+          opam install . --deps-only --with-test --with-doc --with-dev-setup -y
+      - name: build
+        run: |
+          opam exec -- dune build @install
+      - name: test
+        run: |
+          opam exec -- dune runtest
+      - name: lint-doc
+        run: |
+          ODOC_WARN_ERROR=true opam exec -- dune build @doc 2> output.txt
+          $(exit $(wc -l output.txt | cut -d " " -f1))
+      - name: lint-fmt
+        run: |
+          opam exec -- dune build @fmt || (echo "\n⚠️ please run \`dune fmt\` and try again" && exit 1)
+      - name: lint-fresh-opam-file
+        run: |
+          git diff --exit-code *.opam || (echo "⚠️ please run \`dune build\`, commit the changes to the opam file, and then try again" && exit 1)

.ocamlformat

@@ -1,4 +1,4 @@
-version=0.23.0
+version=0.27.0
 assignment-operator=end-line
 break-cases=fit
 break-fun-decl=wrap

src/app.ml

@@ -19,22 +19,22 @@ let config_dir =
   | Some config_dir -> config_dir
 
 let config =
-  let filename = Filename.concat config_dir "config.scfg" in
-  if not @@ Sys.file_exists filename then
-    failwith
-    @@ Format.sprintf "configuration file `%s` does not exist, please create it"
-         filename;
-  Dream.log "config file: %s" filename;
-  match Scfg.Parse.from_file filename with
-  | Error e -> failwith e
-  | Ok config -> config
+  let filename = Fpath.add_seg config_dir "config.scfg" in
+  let filename_str = Fpath.to_string filename in
+  if not @@ Sys.file_exists filename_str then []
+  else begin
+    Dream.log "config file: %s" filename_str;
+    match Scfg.Parse.from_file filename with
+    | Error (`Msg e) -> failwith e
+    | Ok config -> config
+  end
 
 let open_registration =
   match Scfg.Query.get_dir "open_registration" config with
   | None -> true
   | Some open_registration -> (
     match Scfg.Query.get_param 0 open_registration with
-    | Error e -> failwith e
+    | Error (`Msg e) -> failwith e
     | Ok "true" -> true
     | Ok "false" -> false
     | Ok _unknown ->
@@ -47,7 +47,7 @@ let port =
   | None -> 8080
   | Some port -> (
     match Scfg.Query.get_param 0 port with
-    | Error e -> failwith e
+    | Error (`Msg e) -> failwith e
     | Ok n -> (
       try
         let n = int_of_string n in
@@ -59,10 +59,14 @@ let port =
 let () = Dream.log "port: %d" port
 
 let hostname =
+  let default_hostname = Format.sprintf "localhost:%d" port in
   match Scfg.Query.get_dir "hostname" config with
-  | None -> Format.sprintf "localhost:%d" port
+  | None -> default_hostname
   | Some hostname ->
-    Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 hostname)
+    Result.fold
+      ~error:(fun (`Msg e) -> failwith e)
+      ~ok:Fun.id
+      (Scfg.Query.get_param 0 hostname)
 
 let () = Dream.log "hostname: %s" hostname
 
@@ -71,24 +75,22 @@ let log =
   | None -> true
   | Some log -> (
     match Scfg.Query.get_param 0 log with
-    | Error e -> failwith e
+    | Error (`Msg e) -> failwith e
     | Ok "true" -> true
     | Ok "false" -> false
     | Ok _unknown -> failwith "invalid `log` value in configuration file" )
 
 let () = Dream.log "log: %b" log
 
-let get_dirs name =
-  let dirs = Scfg.Query.get_dirs name config in
-  List.map
-    (fun dir ->
-      Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 dir) )
-    dirs
+let about =
+  let default_about = "Pellest is great !" in
+  match Scfg.Query.get_dir "about" config with
+  | None -> default_about
+  | Some about -> (
+    match Scfg.Query.get_param 0 about with
+    | Error (`Msg e) -> failwith e
+    | Ok about -> about )
 
 let random_state = Random.State.make_self_init ()
 
 let () = Random.set_state random_state
-
-let about =
-  (* TODO read from about.txt *)
-  "This is pellest"

src/asset.ml

@@ -0,0 +1,10 @@
+let loader _root path _request =
+  match Content.read ("assets/" ^ path) with
+  | None ->
+    Dream.empty `Not_Found
+    (* Template.err (`Bad_Request, "file doesn't exist") *)
+  | Some asset ->
+    (* TODO cache-control: ~headers:[ ("Cache-Control", "max-age=151200") ] *)
+    Dream.respond asset
+
+let get = Dream.static ~loader ""

src/content/assets/css/leaflet.css

@@ -1,640 +0,0 @@
-/* required styles */
-
-.leaflet-pane,
-.leaflet-tile,
-.leaflet-marker-icon,
-.leaflet-marker-shadow,
-.leaflet-tile-container,
-.leaflet-pane > svg,
-.leaflet-pane > canvas,
-.leaflet-zoom-box,
-.leaflet-image-layer,
-.leaflet-layer {
-	position: absolute;
-	left: 0;
-	top: 0;
-	}
-.leaflet-container {
-	overflow: hidden;
-	}
-.leaflet-tile,
-.leaflet-marker-icon,
-.leaflet-marker-shadow {
-	-webkit-user-select: none;
-	   -moz-user-select: none;
-	        user-select: none;
-	  -webkit-user-drag: none;
-	}
-/* Prevents IE11 from highlighting tiles in blue */
-.leaflet-tile::selection {
-	background: transparent;
-}
-/* Safari renders non-retina tile on retina better with this, but Chrome is worse */
-.leaflet-safari .leaflet-tile {
-	image-rendering: -webkit-optimize-contrast;
-	}
-/* hack that prevents hw layers "stretching" when loading new tiles */
-.leaflet-safari .leaflet-tile-container {
-	width: 1600px;
-	height: 1600px;
-	-webkit-transform-origin: 0 0;
-	}
-.leaflet-marker-icon,
-.leaflet-marker-shadow {
-	display: block;
-	}
-/* .leaflet-container svg: reset svg max-width decleration shipped in Joomla! (joomla.org) 3.x */
-/* .leaflet-container img: map is broken in FF if you have max-width: 100% on tiles */
-.leaflet-container .leaflet-overlay-pane svg,
-.leaflet-container .leaflet-marker-pane img,
-.leaflet-container .leaflet-shadow-pane img,
-.leaflet-container .leaflet-tile-pane img,
-.leaflet-container img.leaflet-image-layer,
-.leaflet-container .leaflet-tile {
-	max-width: none !important;
-	max-height: none !important;
-	}
-
-.leaflet-container.leaflet-touch-zoom {
-	-ms-touch-action: pan-x pan-y;
-	touch-action: pan-x pan-y;
-	}
-.leaflet-container.leaflet-touch-drag {
-	-ms-touch-action: pinch-zoom;
-	/* Fallback for FF which doesn't support pinch-zoom */
-	touch-action: none;
-	touch-action: pinch-zoom;
-}
-.leaflet-container.leaflet-touch-drag.leaflet-touch-zoom {
-	-ms-touch-action: none;
-	touch-action: none;
-}
-.leaflet-container {
-	-webkit-tap-highlight-color: transparent;
-}
-.leaflet-container a {
-	-webkit-tap-highlight-color: rgba(51, 181, 229, 0.4);
-}
-.leaflet-tile {
-	filter: inherit;
-	visibility: hidden;
-	}
-.leaflet-tile-loaded {
-	visibility: inherit;
-	}
-.leaflet-zoom-box {
-	width: 0;
-	height: 0;
-	-moz-box-sizing: border-box;
-	     box-sizing: border-box;
-	z-index: 800;
-	}
-/* workaround for https://bugzilla.mozilla.org/show_bug.cgi?id=888319 */
-.leaflet-overlay-pane svg {
-	-moz-user-select: none;
-	}
-
-.leaflet-pane         { z-index: 400; }
-
-.leaflet-tile-pane    { z-index: 200; }
-.leaflet-overlay-pane { z-index: 400; }
-.leaflet-shadow-pane  { z-index: 500; }
-.leaflet-marker-pane  { z-index: 600; }
-.leaflet-tooltip-pane   { z-index: 650; }
-.leaflet-popup-pane   { z-index: 700; }
-
-.leaflet-map-pane canvas { z-index: 100; }
-.leaflet-map-pane svg    { z-index: 200; }
-
-.leaflet-vml-shape {
-	width: 1px;
-	height: 1px;
-	}
-.lvml {
-	behavior: url(#default#VML);
-	display: inline-block;
-	position: absolute;
-	}
-
-
-/* control positioning */
-
-.leaflet-control {
-	position: relative;
-	z-index: 800;
-	pointer-events: visiblePainted; /* IE 9-10 doesn't have auto */
-	pointer-events: auto;
-	}
-.leaflet-top,
-.leaflet-bottom {
-	position: absolute;
-	z-index: 1000;
-	pointer-events: none;
-	}
-.leaflet-top {
-	top: 0;
-	}
-.leaflet-right {
-	right: 0;
-	}
-.leaflet-bottom {
-	bottom: 0;
-	}
-.leaflet-left {
-	left: 0;
-	}
-.leaflet-control {
-	float: left;
-	clear: both;
-	}
-.leaflet-right .leaflet-control {
-	float: right;
-	}
-.leaflet-top .leaflet-control {
-	margin-top: 10px;
-	}
-.leaflet-bottom .leaflet-control {
-	margin-bottom: 10px;
-	}
-.leaflet-left .leaflet-control {
-	margin-left: 10px;
-	}
-.leaflet-right .leaflet-control {
-	margin-right: 10px;
-	}
-
-
-/* zoom and fade animations */
-
-.leaflet-fade-anim .leaflet-tile {
-	will-change: opacity;
-	}
-.leaflet-fade-anim .leaflet-popup {
-	opacity: 0;
-	-webkit-transition: opacity 0.2s linear;
-	   -moz-transition: opacity 0.2s linear;
-	        transition: opacity 0.2s linear;
-	}
-.leaflet-fade-anim .leaflet-map-pane .leaflet-popup {
-	opacity: 1;
-	}
-.leaflet-zoom-animated {
-	-webkit-transform-origin: 0 0;
-	    -ms-transform-origin: 0 0;
-	        transform-origin: 0 0;
-	}
-.leaflet-zoom-anim .leaflet-zoom-animated {
-	will-change: transform;
-	}
-.leaflet-zoom-anim .leaflet-zoom-animated {
-	-webkit-transition: -webkit-transform 0.25s cubic-bezier(0,0,0.25,1);
-	   -moz-transition:    -moz-transform 0.25s cubic-bezier(0,0,0.25,1);
-	        transition:         transform 0.25s cubic-bezier(0,0,0.25,1);
-	}
-.leaflet-zoom-anim .leaflet-tile,
-.leaflet-pan-anim .leaflet-tile {
-	-webkit-transition: none;
-	   -moz-transition: none;
-	        transition: none;
-	}
-
-.leaflet-zoom-anim .leaflet-zoom-hide {
-	visibility: hidden;
-	}
-
-
-/* cursors */
-
-.leaflet-interactive {
-	cursor: pointer;
-	}
-.leaflet-grab {
-	cursor: -webkit-grab;
-	cursor:    -moz-grab;
-	cursor:         grab;
-	}
-.leaflet-crosshair,
-.leaflet-crosshair .leaflet-interactive {
-	cursor: crosshair;
-	}
-.leaflet-popup-pane,
-.leaflet-control {
-	cursor: auto;
-	}
-.leaflet-dragging .leaflet-grab,
-.leaflet-dragging .leaflet-grab .leaflet-interactive,
-.leaflet-dragging .leaflet-marker-draggable {
-	cursor: move;
-	cursor: -webkit-grabbing;
-	cursor:    -moz-grabbing;
-	cursor:         grabbing;
-	}
-
-/* marker & overlays interactivity */
-.leaflet-marker-icon,
-.leaflet-marker-shadow,
-.leaflet-image-layer,
-.leaflet-pane > svg path,
-.leaflet-tile-container {
-	pointer-events: none;
-	}
-
-.leaflet-marker-icon.leaflet-interactive,
-.leaflet-image-layer.leaflet-interactive,
-.leaflet-pane > svg path.leaflet-interactive,
-svg.leaflet-image-layer.leaflet-interactive path {
-	pointer-events: visiblePainted; /* IE 9-10 doesn't have auto */
-	pointer-events: auto;
-	}
-
-/* visual tweaks */
-
-.leaflet-container {
-	background: #ddd;
-	outline: 0;
-	}
-.leaflet-container a {
-	color: #0078A8;
-	}
-.leaflet-container a.leaflet-active {
-	outline: 2px solid orange;
-	}
-.leaflet-zoom-box {
-	border: 2px dotted #38f;
-	background: rgba(255,255,255,0.5);
-	}
-
-
-/* general typography */
-.leaflet-container {
-	font: 12px/1.5 "Helvetica Neue", Arial, Helvetica, sans-serif;
-	}
-
-
-/* general toolbar styles */
-
-.leaflet-bar {
-	box-shadow: 0 1px 5px rgba(0,0,0,0.65);
-	border-radius: 4px;
-	}
-.leaflet-bar a,
-.leaflet-bar a:hover {
-	background-color: #fff;
-	border-bottom: 1px solid #ccc;
-	width: 26px;
-	height: 26px;
-	line-height: 26px;
-	display: block;
-	text-align: center;
-	text-decoration: none;
-	color: black;
-	}
-.leaflet-bar a,
-.leaflet-control-layers-toggle {
-	background-position: 50% 50%;
-	background-repeat: no-repeat;
-	display: block;
-	}
-.leaflet-bar a:hover {
-	background-color: #f4f4f4;
-	}
-.leaflet-bar a:first-child {
-	border-top-left-radius: 4px;
-	border-top-right-radius: 4px;
-	}
-.leaflet-bar a:last-child {
-	border-bottom-left-radius: 4px;
-	border-bottom-right-radius: 4px;
-	border-bottom: none;
-	}
-.leaflet-bar a.leaflet-disabled {
-	cursor: default;
-	background-color: #f4f4f4;
-	color: #bbb;
-	}
-
-.leaflet-touch .leaflet-bar a {
-	width: 30px;
-	height: 30px;
-	line-height: 30px;
-	}
-.leaflet-touch .leaflet-bar a:first-child {
-	border-top-left-radius: 2px;
-	border-top-right-radius: 2px;
-	}
-.leaflet-touch .leaflet-bar a:last-child {
-	border-bottom-left-radius: 2px;
-	border-bottom-right-radius: 2px;
-	}
-
-/* zoom control */
-
-.leaflet-control-zoom-in,
-.leaflet-control-zoom-out {
-	font: bold 18px 'Lucida Console', Monaco, monospace;
-	text-indent: 1px;
-	}
-
-.leaflet-touch .leaflet-control-zoom-in, .leaflet-touch .leaflet-control-zoom-out  {
-	font-size: 22px;
-	}
-
-
-/* layers control */
-
-.leaflet-control-layers {
-	box-shadow: 0 1px 5px rgba(0,0,0,0.4);
-	background: #fff;
-	border-radius: 5px;
-	}
-.leaflet-control-layers-toggle {
-	background-image: url(/assets/img/layers.png);
-	width: 36px;
-	height: 36px;
-	}
-.leaflet-retina .leaflet-control-layers-toggle {
-	background-image: url(/assets/img/layers-2x.png);
-	background-size: 26px 26px;
-	}
-.leaflet-touch .leaflet-control-layers-toggle {
-	width: 44px;
-	height: 44px;
-	}
-.leaflet-control-layers .leaflet-control-layers-list,
-.leaflet-control-layers-expanded .leaflet-control-layers-toggle {
-	display: none;
-	}
-.leaflet-control-layers-expanded .leaflet-control-layers-list {
-	display: block;
-	position: relative;
-	}
-.leaflet-control-layers-expanded {
-	padding: 6px 10px 6px 6px;
-	color: #333;
-	background: #fff;
-	}
-.leaflet-control-layers-scrollbar {
-	overflow-y: scroll;
-	overflow-x: hidden;
-	padding-right: 5px;
-	}
-.leaflet-control-layers-selector {
-	margin-top: 2px;
-	position: relative;
-	top: 1px;
-	}
-.leaflet-control-layers label {
-	display: block;
-	}
-.leaflet-control-layers-separator {
-	height: 0;
-	border-top: 1px solid #ddd;
-	margin: 5px -10px 5px -6px;
-	}
-
-/* Default icon URLs */
-.leaflet-default-icon-path {
-	background-image: url(/assets/img/marker-icon.png);
-	}
-
-
-/* attribution and scale controls */
-
-.leaflet-container .leaflet-control-attribution {
-	background: #fff;
-	background: rgba(255, 255, 255, 0.7);
-	margin: 0;
-	}
-.leaflet-control-attribution,
-.leaflet-control-scale-line {
-	padding: 0 5px;
-	color: #333;
-	}
-.leaflet-control-attribution a {
-	text-decoration: none;
-	}
-.leaflet-control-attribution a:hover {
-	text-decoration: underline;
-	}
-.leaflet-container .leaflet-control-attribution,
-.leaflet-container .leaflet-control-scale {
-	font-size: 11px;
-	}
-.leaflet-left .leaflet-control-scale {
-	margin-left: 5px;
-	}
-.leaflet-bottom .leaflet-control-scale {
-	margin-bottom: 5px;
-	}
-.leaflet-control-scale-line {
-	border: 2px solid #777;
-	border-top: none;
-	line-height: 1.1;
-	padding: 2px 5px 1px;
-	font-size: 11px;
-	white-space: nowrap;
-	overflow: hidden;
-	-moz-box-sizing: border-box;
-	     box-sizing: border-box;
-
-	background: #fff;
-	background: rgba(255, 255, 255, 0.5);
-	}
-.leaflet-control-scale-line:not(:first-child) {
-	border-top: 2px solid #777;
-	border-bottom: none;
-	margin-top: -2px;
-	}
-.leaflet-control-scale-line:not(:first-child):not(:last-child) {
-	border-bottom: 2px solid #777;
-	}
-
-.leaflet-touch .leaflet-control-attribution,
-.leaflet-touch .leaflet-control-layers,
-.leaflet-touch .leaflet-bar {
-	box-shadow: none;
-	}
-.leaflet-touch .leaflet-control-layers,
-.leaflet-touch .leaflet-bar {
-	border: 2px solid rgba(0,0,0,0.2);
-	background-clip: padding-box;
-	}
-
-
-/* popup */
-
-.leaflet-popup {
-	position: absolute;
-	text-align: center;
-	margin-bottom: 20px;
-	}
-.leaflet-popup-content-wrapper {
-	padding: 1px;
-	text-align: left;
-	border-radius: 12px;
-	}
-.leaflet-popup-content {
-	margin: 13px 19px;
-	line-height: 1.4;
-	}
-.leaflet-popup-content p {
-	margin: 18px 0;
-	}
-.leaflet-popup-tip-container {
-	width: 40px;
-	height: 20px;
-	position: absolute;
-	left: 50%;
-	margin-left: -20px;
-	overflow: hidden;
-	pointer-events: none;
-	}
-.leaflet-popup-tip {
-	width: 17px;
-	height: 17px;
-	padding: 1px;
-
-	margin: -10px auto 0;
-
-	-webkit-transform: rotate(45deg);
-	   -moz-transform: rotate(45deg);
-	    -ms-transform: rotate(45deg);
-	        transform: rotate(45deg);
-	}
-.leaflet-popup-content-wrapper,
-.leaflet-popup-tip {
-	background: white;
-	color: #333;
-	box-shadow: 0 3px 14px rgba(0,0,0,0.4);
-	}
-.leaflet-container a.leaflet-popup-close-button {
-	position: absolute;
-	top: 0;
-	right: 0;
-	padding: 4px 4px 0 0;
-	border: none;
-	text-align: center;
-	width: 18px;
-	height: 14px;
-	font: 16px/14px Tahoma, Verdana, sans-serif;
-	color: #c3c3c3;
-	text-decoration: none;
-	font-weight: bold;
-	background: transparent;
-	}
-.leaflet-container a.leaflet-popup-close-button:hover {
-	color: #999;
-	}
-.leaflet-popup-scrolled {
-	overflow: auto;
-	border-bottom: 1px solid #ddd;
-	border-top: 1px solid #ddd;
-	}
-
-.leaflet-oldie .leaflet-popup-content-wrapper {
-	-ms-zoom: 1;
-	}
-.leaflet-oldie .leaflet-popup-tip {
-	width: 24px;
-	margin: 0 auto;
-
-	-ms-filter: "progid:DXImageTransform.Microsoft.Matrix(M11=0.70710678, M12=0.70710678, M21=-0.70710678, M22=0.70710678)";
-	filter: progid:DXImageTransform.Microsoft.Matrix(M11=0.70710678, M12=0.70710678, M21=-0.70710678, M22=0.70710678);
-	}
-.leaflet-oldie .leaflet-popup-tip-container {
-	margin-top: -1px;
-	}
-
-.leaflet-oldie .leaflet-control-zoom,
-.leaflet-oldie .leaflet-control-layers,
-.leaflet-oldie .leaflet-popup-content-wrapper,
-.leaflet-oldie .leaflet-popup-tip {
-	border: 1px solid #999;
-	}
-
-
-/* div icon */
-
-.leaflet-div-icon {
-	background: #fff;
-	border: 1px solid #666;
-	}
-
-
-/* Tooltip */
-/* Base styles for the element that has a tooltip */
-.leaflet-tooltip {
-	position: absolute;
-	padding: 6px;
-	background-color: #fff;
-	border: 1px solid #fff;
-	border-radius: 3px;
-	color: #222;
-	white-space: nowrap;
-	-webkit-user-select: none;
-	-moz-user-select: none;
-	-ms-user-select: none;
-	user-select: none;
-	pointer-events: none;
-	box-shadow: 0 1px 3px rgba(0,0,0,0.4);
-	}
-.leaflet-tooltip.leaflet-clickable {
-	cursor: pointer;
-	pointer-events: auto;
-	}
-.leaflet-tooltip-top:before,
-.leaflet-tooltip-bottom:before,
-.leaflet-tooltip-left:before,
-.leaflet-tooltip-right:before {
-	position: absolute;
-	pointer-events: none;
-	border: 6px solid transparent;
-	background: transparent;
-	content: "";
-	}
-
-/* Directions */
-
-.leaflet-tooltip-bottom {
-	margin-top: 6px;
-}
-.leaflet-tooltip-top {
-	margin-top: -6px;
-}
-.leaflet-tooltip-bottom:before,
-.leaflet-tooltip-top:before {
-	left: 50%;
-	margin-left: -6px;
-	}
-.leaflet-tooltip-top:before {
-	bottom: 0;
-	margin-bottom: -12px;
-	border-top-color: #fff;
-	}
-.leaflet-tooltip-bottom:before {
-	top: 0;
-	margin-top: -12px;
-	margin-left: -6px;
-	border-bottom-color: #fff;
-	}
-.leaflet-tooltip-left {
-	margin-left: -6px;
-}
-.leaflet-tooltip-right {
-	margin-left: 6px;
-}
-.leaflet-tooltip-left:before,
-.leaflet-tooltip-right:before {
-	top: 50%;
-	margin-top: -6px;
-	}
-.leaflet-tooltip-left:before {
-	right: 0;
-	margin-right: -12px;
-	border-left-color: #fff;
-	}
-.leaflet-tooltip-right:before {
-	left: 0;
-	margin-left: -12px;
-	border-right-color: #fff;
-	}

src/content/assets/css/style.css

@@ -5,13 +5,17 @@ html {
 body {
   height: 100%;
   padding-top: 0rem;
-  color: #5a5a5a;
-  background-color: #e8eaf6;
+  color: #af8e6c;
+  background-color: #2f341f;
   line-height: 1.6;
   font-size: 18px;
 }
 
-#page-title {
+a {
+  color: #ec44ee
+}
+
+h1 {
   text-align: center;
 }
 
@@ -19,3 +23,7 @@ main {
   height: 100%;
   width: 100%;
 }
+
+.centered {
+  text-align: center;
+}

src/content/assets/js/dune

@@ -1,8 +1,8 @@
 (rule
- (target client.js)
+ (target island_client.js)
  (deps
-  (file ../../../js/client.bc.js))
+  (file ../../../island_client.bc.js))
  (action
   (with-stdout-to
    %{target}
-   (cat ../../../js/client.bc.js))))
+   (cat ../../../island_client.bc.js))))

src/db.ml

@@ -3,25 +3,38 @@ open Caqti_request.Infix
 let db_root = App.data_dir
 
 let () =
-  match Bos.OS.Dir.create (Fpath.v db_root) with
-  | Ok true -> Dream.log "created %s" db_root
-  | Ok false -> Dream.log "%s already exists" db_root
+  match Bos.OS.Dir.create db_root with
+  | Ok true -> Dream.log "created %s" (Fpath.to_string db_root)
+  | Ok false -> Dream.log "%s already exists" (Fpath.to_string db_root)
   | Error (`Msg _) ->
-    Dream.warning (fun log -> log "error when creating %s" db_root)
+    Dream.warning (fun log ->
+        log "error when creating %s" (Fpath.to_string db_root) )
 
-let db = Filename.concat db_root (App.App_id.application ^ ".db")
+let db = Fpath.add_seg db_root (App.App_id.application ^ ".db")
 
-let db_uri = Format.sprintf "sqlite3://%s" db
+let db_uri = Format.sprintf "sqlite3://%s" (Fpath.to_string db)
 
 module Db =
   (val Caqti_blocking.connect (Uri.of_string db_uri) |> Caqti_blocking.or_fail)
 
+let set_foreign_keys_on = Caqti_type.(unit ->. unit) "PRAGMA foreign_keys = ON"
+
+let create_dream_session =
+  Caqti_type.(unit ->. unit)
+    "CREATE TABLE IF NOT EXISTS dream_session (id TEXT PRIMARY KEY, label TEXT \
+     NOT NULL, expires_at REAL NOT NULL, payload TEXT NOT NULL)"
+
 let () =
-  let set_foreign_keys_on =
-    Caqti_type.(unit ->. unit) "PRAGMA foreign_keys = ON"
+  let exec_unsafe q v =
+    match Db.exec q v with
+    | Error e ->
+      Dream.error (fun log -> log "%s" (Caqti_error.show e));
+      exit 1
+    | Ok () -> ()
   in
-  if Result.is_error (Db.exec set_foreign_keys_on ()) then
-    Dream.error (fun log -> log "can't set foreign_keys on")
+  exec_unsafe set_foreign_keys_on ();
+  exec_unsafe create_dream_session ();
+  ()
 
 let () =
   let query =
@@ -36,7 +49,10 @@ let () =
     exit 1
 
 let unwrap_err = function
-  | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
+  | Error e ->
+    Error
+      ( `Internal_Server_Error
+      , Format.sprintf "db error: %s" (Caqti_error.show e) )
   | Ok _ as ok -> ok
 
 let exec q v = Db.exec q v |> unwrap_err

src/dune

@@ -2,19 +2,21 @@
  (name pellest)
  (modules
   app
+  asset
   content
-  pellest
-  util
-  template
-  home
-  register
-  login
-  user
-  syntax
   db
-  tyx_util)
+  home
+  island
+  login
+  logout
+  pellest
+  register
+  syntax
+  template
+  tyx_util
+  user
+  ws)
  (libraries
-  uuidm
   bos
   caqti
   caqti.blocking
@@ -22,23 +24,36 @@
   directories
   dream
   emile
+  shared
   fpath
   lambdasoup
   lwt
   safepass
   scfg
-  uri
   tyxml
   tyxml.functor
-  yojson)
+  uri
+  uuidm
+  unix)
  (preprocess
   (pps lwt_ppx)))
 
+(executable
+ (name island_client)
+ (modules island_client ws_client)
+ (libraries js_of_ocaml brr shared)
+ (modes js))
+
+(library
+ (name shared)
+ (modules log map network state time)
+ (libraries))
+
 (rule
  (target content.ml)
  (deps
   (source_tree content)
-  (file content/assets/js/client.js))
+  island_client.bc.js)
  (action
   (with-stdout-to
    %{null}

src/home.ml

@@ -1,11 +1,21 @@
 open Tyxml.Html
 
-let f _request =
-  let page_title = "Pellest is the best game ever!" in
-  let about = div [ txt App.about ] in
-  let link_to_register =
-    div [ a ~a:[ a_href "/register" ] [ txt "Register" ] ]
+let get request =
+  let title = "Pellest is the best game ever!" in
+  let page =
+    if User.is_logged_in request then
+      let welcome =
+        div [ txt (Format.sprintf "welcome %s" (User.get_nick_unsafe request)) ]
+      in
+      let island =
+        div [ a ~a:[ a_href "/island" ] [ txt "🏝️ Go to your island !" ] ]
+      in
+      let logout = div [ a ~a:[ a_href "/logout" ] [ txt "Logout" ] ] in
+      [ welcome; island; logout ]
+    else
+      let about = div [ txt App.about ] in
+      let register = div [ a ~a:[ a_href "/register" ] [ txt "Register" ] ] in
+      let login = div [ a ~a:[ a_href "/login" ] [ txt "Login" ] ] in
+      [ about; login; register ]
   in
-  let link_to_login = div [ a ~a:[ a_href "/login" ] [ txt "Login" ] ] in
-  let page = div [ about; link_to_login; link_to_register ] in
-  Template.render ~page_title ~scripts:[] page
+  Template.render ~title ~scripts:[] (div page)

src/island.ml

@@ -0,0 +1,71 @@
+open Tyxml.Html
+open Syntax
+
+let mk_img hidden name =
+  let a = [ a_id name ] in
+  img
+    ~src:(Format.sprintf "/assets/img/%s.png" name)
+    ~alt:name
+    ~a:(if hidden then a_hidden () :: a else a)
+    ()
+
+let get request =
+  let** () = User.assert_logged request in
+
+  let title = "Your island" in
+
+  let topbar =
+    let mana_img = mk_img false "mana" in
+    let mana_lvl = span ~a:[ a_id "mana_lvl" ] [ txt "0" ] in
+    let wheat_img = mk_img false "wheat" in
+    let wheat_lvl = span ~a:[ a_id "wheat_lvl" ] [ txt "0" ] in
+    div
+      ~a:[ a_class [ "centered" ] ]
+      [ mana_img; mana_lvl; wheat_img; wheat_lvl ]
+  in
+
+  let canvas =
+    div
+      ~a:[ a_class [ "centered" ] ]
+      [ canvas
+          ~a:[ a_id "canvas" ]
+          [ txt "please update your browser or enable javascript" ]
+      ]
+  in
+
+  let canvas_images =
+    div
+    @@ List.map (mk_img true)
+         [ "grass"
+         ; "papy_left"
+         ; "papy_right"
+         ; "papy_down"
+         ; "papy_up"
+         ; "water"
+         ; "wheat"
+         ]
+  in
+
+  let bottombar =
+    let medidate_button =
+      button ~a:[ a_id "medidate_button" ] [ txt "Medidate" ]
+    in
+    let plant_wheat_button =
+      button ~a:[ a_id "plant_wheat_button" ] [ txt "Plant wheat" ]
+    in
+    div ~a:[ a_class [ "centered" ] ] [ medidate_button; plant_wheat_button ]
+  in
+
+  let page = div [ topbar; canvas; bottombar; canvas_images ] in
+
+  let js =
+    script
+      ~a:
+        [ (*a_mime_type "text/javascript" ; *)
+          a_src "/assets/js/island_client.js"
+        ; a_defer ()
+        ]
+      (txt "")
+  in
+
+  Template.render ~title ~scripts:[ js ] page

src/island_client.ml

@@ -0,0 +1,300 @@
+open Brr
+open Brr_io
+open Brr_canvas
+open Shared
+
+module G = struct
+  include Brr.G
+
+  let request_animation_frame f =
+    (ignore : int -> unit) @@ Brr.G.request_animation_frame f
+end
+
+let get_el id =
+  match Document.find_el_by_id G.document (Jstr.of_string id) with
+  | None -> Log.err "could not find element with id `%s`" id
+  | Some el -> el
+
+let tile_size = 40
+
+let width = 875
+
+let height = 675
+
+let canvas =
+  let el = get_el "canvas" in
+  Canvas.of_el el
+
+let context = C2d.get_context canvas
+
+let tiles_per_w =
+  let n = width / tile_size in
+  if n mod 2 = 0 then n - 1 else n
+
+let tiles_per_h =
+  let n = height / tile_size in
+  if n mod 2 = 0 then n - 1 else n
+
+let orig_x = (width - (tiles_per_w * tile_size)) / 2
+
+let orig_y = (height - (tiles_per_h * tile_size)) / 2
+
+let grass = C2d.image_src_of_el (get_el "grass")
+
+let papy_left = C2d.image_src_of_el (get_el "papy_left")
+
+let papy_right = C2d.image_src_of_el (get_el "papy_right")
+
+let papy_down = C2d.image_src_of_el (get_el "papy_down")
+
+let papy_up = C2d.image_src_of_el (get_el "papy_up")
+
+let water = C2d.image_src_of_el (get_el "water")
+
+let wheat = C2d.image_src_of_el (get_el "wheat")
+
+let draw_canvas =
+  let offset_conv =
+    let m = float_of_int @@ (tile_size / 2) in
+    fun offset -> m *. offset
+  in
+  let papy_x = float_of_int (width - tile_size) /. 2. in
+  let papy_y = (float_of_int height /. 2.) -. (float_of_int tile_size *. 1.5) in
+  let half_tiles_per_w = tiles_per_w / 2 in
+  let half_tiles_per_h = tiles_per_h / 2 in
+  fun state ->
+    let open State in
+    (* TODO: it could be possible to optimize starting/ending index by looking at the offset *)
+    for x = -2 to tiles_per_w + 1 do
+      let map_x = x + state.player_pos.x - half_tiles_per_w in
+      let tile_x =
+        float_of_int ((x * tile_size) + orig_x) +. offset_conv state.offset_x
+      in
+      for y = -2 to tiles_per_h + 1 do
+        let map_y = y + state.player_pos.y - half_tiles_per_h in
+        let tile_y =
+          float_of_int ((y * tile_size) + orig_y) +. offset_conv state.offset_y
+        in
+        let tile_img =
+          match Map.get_tile_kind ~x:map_x ~y:map_y state.map with
+          | Grass -> grass
+          | Water -> water
+          | Black -> water
+          | Wheat -> wheat
+        in
+        C2d.draw_image context tile_img ~x:tile_x ~y:tile_y
+      done
+    done;
+    let papy =
+      match state.player_pos.dir with
+      | Left -> papy_left
+      | Right -> papy_right
+      | Down -> papy_down
+      | Up -> papy_up
+    in
+    C2d.draw_image context papy ~x:papy_x ~y:papy_y
+
+let draw_topbar state =
+  (* draw mana level *)
+  let mana_lvl = Jv.get Jv.global "mana_lvl" in
+  Jv.set mana_lvl "innerHTML"
+    (Jv.of_string @@ string_of_int state.Shared.State.mana);
+  (* draw wheat level *)
+  let wheat_lvl = Jv.get Jv.global "wheat_lvl" in
+  Jv.set wheat_lvl "innerHTML" (Jv.of_string @@ string_of_int state.wheat)
+
+(* queue for action to be done *)
+let input_queue = Queue.create ()
+
+(* queue for action' to apply to client state *)
+let to_apply_queue : State.action' Queue.t = Queue.create ()
+
+let send_action state = function
+  (* actions we don't need to send to the server *)
+  (*
+    | (State.Move_offset _ | Move _) as action -> begin
+    match State.check_action state action with
+    | Error e ->
+      (* TODO: display this in the window *)
+      Log.debug "invalid action: %s@\n" e
+    | Ok actions -> List.iter (fun a -> Queue.add a to_apply_queue) actions
+  end
+  *)
+  (* actions we want to send to the server *)
+  | (State.Move_offset _ | Move _ | Meditate | Plant_wheat) as action -> (
+    match State.check_action state action with
+    | Error e ->
+      (* TODO: display this in the window *)
+      Log.debug "invalid action: %s@\n" e
+    | Ok _actions ->
+      Log.debug "sending action %a to server@\n" State.pp_action action;
+      Ws_client.send (Network.Action_msg action) )
+
+module Kb : sig
+  (* this keeps an ordered sequence of unique values,
+     it's the responsability of the caller to make sure
+     the same element is not added twice ! *)
+
+  type t = string
+
+  val add : t -> unit
+
+  val rm : t -> unit
+
+  val get_last : unit -> t option
+end = struct
+  type t = string
+
+  let last = ref []
+
+  let add k = last := k :: !last
+
+  let rm k = last := List.filter (( <> ) k) !last
+
+  let get_last () = match !last with [] -> None | key :: _keys -> Some key
+end
+
+let keypress_handler =
+  (* be careful to add in the correct array ! *)
+  let codes = Hashtbl.create 512 in
+  Array.iter
+    (fun code -> Hashtbl.add codes code ())
+    [| "ArrowDown"
+     ; "ArrowLeft"
+     ; "ArrowRight"
+     ; "ArrowUp"
+     ; "KeyA"
+     ; "KeyD"
+     ; "KeyS"
+     ; "KeyW"
+    |];
+  let keys = Hashtbl.create 512 in
+  Array.iter (fun key -> Hashtbl.add keys key ()) [| "m"; "p" |];
+  (* TODO: I'm not sure the Hashtbl business is worth it.
+     Before, we were matching on values instead of calling Hashtbl.mem.
+     It should be better with Hashtbl but it wasn't benchmarked. *)
+  fun ~down ->
+    let f = if down then Kb.add else Kb.rm in
+    fun ev ->
+      let ev = Ev.as_type ev in
+      (* repeat is true if and only if an event as already been sent since the key has been pressed
+         in this case, it's already in the sequence so we just skip it, we know it'll eventually be
+         released on keydown before it can appears again *)
+      if not @@ Ev.Keyboard.repeat ev then
+        let code = Ev.Keyboard.code ev |> Jstr.to_string in
+        if Hashtbl.mem codes code then f code
+        else
+          let key = Ev.Keyboard.key ev |> Jstr.to_string in
+          if Hashtbl.mem keys key then f key
+
+let apply_last_key () =
+  let open State in
+  Kb.get_last ()
+  |> Option.iter (fun code_or_key ->
+         let act =
+           (* when you add something here, don't forget to add the corresponding case in `keypress_handler` *)
+           match code_or_key with
+           | "KeyW" | "ArrowUp" -> Move_offset Up
+           | "KeyA" | "ArrowLeft" -> Move_offset Left
+           | "KeyS" | "ArrowDown" -> Move_offset Down
+           | "KeyD" | "ArrowRight" -> Move_offset Right
+           | "m" -> Meditate
+           | "p" -> Plant_wheat
+           | _ ->
+             (* if this happen, it means we're adding
+                bad values in `keypress_handler`
+                and that should be fixed *)
+             assert false
+         in
+         Queue.add act input_queue )
+
+let render state =
+  draw_canvas state;
+  draw_topbar state
+
+let rec game_loop state last_auto_update timestamp =
+  render state;
+  let should_auto_update =
+    timestamp -. last_auto_update
+    >= Time.ms_to_float (Time.s_to_ms State.auto_update_rate)
+  in
+
+  let last_auto_update =
+    if should_auto_update then timestamp else last_auto_update
+  in
+  apply_last_key ();
+  let state =
+    (* apply queue of actions *)
+    let state = Queue.fold State.perform_action state to_apply_queue in
+    Queue.clear to_apply_queue;
+    (* send input action to server *)
+    Queue.iter (send_action state) input_queue;
+    Queue.clear input_queue;
+    (* state auto update *)
+    if should_auto_update then State.auto_update state else state
+  in
+  G.request_animation_frame (game_loop state last_auto_update)
+
+let () =
+  (* init canvas *)
+  Canvas.set_w canvas width;
+  Canvas.set_h canvas height;
+  C2d.set_fill_style context (C2d.color (Jstr.v "#FF1188"));
+  C2d.fill_rect context ~x:0. ~y:0. ~w:(float_of_int width)
+    ~h:(float_of_int height);
+
+  (* get state from server*)
+  let initial_state_fut = Ev.next Message.Ev.message Ws_client.ws_target in
+
+  (* attach message listener to update state *)
+  Ws_client.on_update_state_message (fun server_msg ->
+      match server_msg with
+      | Full_state _state ->
+        (* TODO reset state to received state *)
+        Log.debug "received `Full_state` message@\n"
+      | Update_result res -> (
+        match res with
+        | Error e -> Log.debug "received update result error: %s@\n" e
+        | Ok actions ->
+          List.iter (fun action -> Queue.add action to_apply_queue) actions ) );
+
+  (* bind keys *)
+  let _e : Ev.listener =
+    Ev.listen Ev.keydown
+      (keypress_handler ~down:true)
+      (Window.as_target G.window)
+  in
+  let _e : Ev.listener =
+    Ev.listen Ev.keyup
+      (keypress_handler ~down:false)
+      (Window.as_target G.window)
+  in
+
+  (* bind buttons *)
+  let _e : Ev.listener =
+    let meditate_button =
+      Jv.get Jv.global "medidate_button" |> Ev.target_of_jv
+    in
+    Ev.listen Ev.click
+      (fun _ev -> Queue.add State.Meditate input_queue)
+      meditate_button
+  in
+
+  let _e : Ev.listener =
+    let plant_wheat_button =
+      Jv.get Jv.global "plant_wheat_button" |> Ev.target_of_jv
+    in
+    Ev.listen Ev.click
+      (fun _ev -> Queue.add (State.Plant_wheat : State.action) input_queue)
+      plant_wheat_button
+  in
+
+  Fut.await initial_state_fut (fun msg ->
+      match Ws_client.to_server_msg msg with
+      | Update_result _res_msg ->
+        Log.err
+          "invalid first server message received; received Update expected \
+           Full_state"
+      | Full_state state ->
+        (* start game *)
+        G.request_animation_frame (game_loop state 0.) )

src/js/dune

@@ -1,10 +0,0 @@
-(executable
- (name client)
- (modules client)
- (libraries brr utils)
- (modes js))
-
-(library
- (name utils)
- (modules utils)
- (libraries brr))

src/js/geo.ml

@@ -1,97 +0,0 @@
-open Utils
-open Leaflet
-
-let map =
-  let options = Jv.obj [| ("zoomControl", Jv.of_bool false) |] in
-  Map.create_on ~options "map"
-
-let () =
-  let osm_layer = Layer.create_tile_osm None in
-  Layer.add_to map osm_layer
-
-let storage = Brr_io.Storage.local Brr.G.window
-
-let save_view () =
-  let latlng = Map.get_center map in
-  let zoom = Map.get_zoom map |> Jstr.of_int in
-  let lat = Latlng.lat latlng |> Jstr.of_float in
-  let lng = Latlng.lng latlng |> Jstr.of_float in
-  match Brr_io.Storage.set_item storage (Jstr.v "lat") lat with
-  | (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
-  | Ok () -> (
-    match Brr_io.Storage.set_item storage (Jstr.v "lng") lng with
-    | (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
-    | Ok () -> (
-      match Brr_io.Storage.set_item storage (Jstr.v "zoom") zoom with
-      | (exception Jv.Error _) | Error _ -> failwith "can't set zoom storage"
-      | Ok () -> () ) )
-
-(* wrap Leaflet.Map.set_view to save last position to storage *)
-let set_view latlng ~zoom =
-  log "set view wrapper@\n";
-  (*we need to wrap coordinates so we don't drift into a parralel universe and lose track of markers :^) *)
-  (* todo: use `worldCopyJump` option on map creation *)
-  let wrapped_latlng = Map.wrap_latlng latlng map in
-  Map.set_view wrapped_latlng ~zoom map;
-  save_view ()
-
-(* set map's view *)
-(* try to set map's view to last position viewed by using web storage *)
-let () =
-  log "setting view@\n";
-  let lat = Brr_io.Storage.get_item storage (Jstr.v "lat") in
-  let lng = Brr_io.Storage.get_item storage (Jstr.v "lng") in
-  let zoom = Brr_io.Storage.get_item storage (Jstr.v "zoom") in
-  match (lat, lng, zoom) with
-  | Some lat, Some lng, Some zoom ->
-    let lat = Jstr.to_float lat in
-    let lng = Jstr.to_float lng in
-    let zoom =
-      match Jstr.to_int zoom with
-      | None -> failwith "view storage bug"
-      | Some zoom -> Some zoom
-    in
-    let latlng = Latlng.create lat lng in
-    set_view latlng ~zoom
-  | _ ->
-    let latlng = Latlng.create 51.505 (-0.09) in
-    set_view latlng ~zoom:(Some 13)
-
-let () =
-  log "add on (move/zoom)end event@\n";
-  let on_moveend _event =
-    log "on moveend event@\n";
-    save_view ()
-  in
-  let on_zoomend _event =
-    log "on zoomend event@\n";
-    save_view ()
-  in
-  Map.on Event.Move_end on_moveend map;
-  Map.on Event.Zoom_end on_zoomend map
-
-let watch_geolocation f =
-  let open Brr_io.Geolocation in
-  log "geolocalize@\n";
-
-  let update_location geo =
-    log "update_location@\n";
-    match geo with
-    | Error e ->
-      (* todo: popup error message for user *)
-      log "geolocation failure: %s@\n" @@ Jstr.to_string @@ Error.message e
-    | Ok geo ->
-      (* monitors geolocation update with f *)
-      f geo;
-      (* set view *)
-      let lat = Pos.latitude geo in
-      let lng = Pos.longitude geo in
-      let latlng = Latlng.create lat lng in
-      set_view latlng ~zoom:None
-    (* TODO update/make camel marker on the map *)
-  in
-
-  (* watch l ~opts f monitors the position of l determined with opts by periodically calling f. Stop watching by calling unwatch with the returned identifier. *)
-  let l = of_navigator Brr.G.navigator in
-  let opts = opts ~high_accuracy:true () in
-  watch l ~opts update_location

src/js/utils.ml

@@ -1,14 +0,0 @@
-open Brr
-
-let log = Format.printf
-
-let find_by_id_opt id = Document.find_el_by_id G.document (Jstr.of_string id)
-
-let find_by_id id =
-  match find_by_id_opt id with
-  | None -> failwith (Format.sprintf "element `%s` not found" id)
-  | Some el -> el
-
-let add_event_to_class event name handler =
-  let el_list = El.find_by_class (Jstr.of_string name) in
-  List.iter (fun el -> Ev.listen event (handler el) (El.as_target el)) el_list

src/log.ml

@@ -0,0 +1,9 @@
+let debug_on = ref true
+
+let debug_output = ref Format.std_formatter
+
+let debug t =
+  if !debug_on then Format.fprintf !debug_output t
+  else Format.ifprintf Format.err_formatter t
+
+let err f = Format.kasprintf failwith f

src/login.ml

@@ -1,16 +1,42 @@
 open Tyxml.Html
 open Tyx_util
+open Syntax
+
+let get request =
+  let** () = User.assert_not_logged request in
+  let title = "Pellest|Login" in
+
+  let action =
+    match Dream.query request "redirect" with
+    | None -> "/login"
+    | Some r -> Format.sprintf "/login?redirect=%s" r
+  in
 
-let f request =
-  (* todo page titles? *)
-  let page_title = "Pellest|Login" in
   let login =
     let submit = button ~a:[ a_id "submit_login" ] [ txt "submit" ] in
-    let login = make_input_text "login" in
-    let password = make_input_text "password" in
-    div
-      [ make_form request ~action:"/login" ~items:[ login; password; submit ] ]
+    let login =
+      input ~a:[ a_id "login"; a_name "login"; a_input_type `Text ] ()
+    in
+    let password =
+      input ~a:[ a_id "password"; a_name "password"; a_input_type `Password ] ()
+    in
+    div [ make_form request ~action ~items:[ login; password; submit ] ]
   in
   let text = div [ txt "login ~!" ] in
   let page = div [ text; login ] in
-  Template.render ~page_title ~scripts:[] page
+  Template.render ~title ~scripts:[] page
+
+let post request =
+  let** () = User.assert_not_logged request in
+  match%lwt Dream.form request with
+  | `Ok [ ("login", login); ("password", password) ] ->
+    let** () = User.login ~login ~password request in
+    let url =
+      match Dream.query request "redirect" with
+      | None -> "/"
+      | Some redirect -> Dream.from_percent_encoded redirect
+    in
+    Dream.respond ~status:`See_Other
+      ~headers:[ ("Location", url) ]
+      "Logged in: Happy pellesting!"
+  | _form -> Template.err (`Bad_Request, "invalid form")

src/logout.ml

@@ -0,0 +1,16 @@
+open Syntax
+
+let get request =
+  let** () = User.assert_logged request in
+  let title = "Logout" in
+  let%lwt () = Dream.invalidate_session request in
+
+  match Dream.query request "redirect" with
+  | None ->
+    let page = Tyxml.Html.txt "logged out" in
+    Template.render ~title ~scripts:[] page
+  | Some redirect ->
+    let url = Dream.from_percent_encoded redirect in
+    Dream.respond ~status:`See_Other
+      ~headers:[ ("Location", url) ]
+      "Logged out: Happy nopellesting!"

src/map.ml

@@ -0,0 +1,84 @@
+type dir =
+  | Left
+  | Right
+  | Down
+  | Up
+
+type background =
+  | Grass
+  | Water
+  | Black
+  | Wheat
+
+let pp_dir fmt dir =
+  let s =
+    match dir with
+    | Left -> "Left"
+    | Right -> "Right"
+    | Down -> "Down"
+    | Up -> "Up"
+  in
+  Format.pp_print_string fmt s
+
+let pp_background fmt b =
+  let s =
+    match b with
+    | Grass -> "Grass"
+    | Water -> "Water"
+    | Black -> "Black"
+    | Wheat -> "Wheat"
+  in
+  Format.pp_print_string fmt s
+
+type position =
+  { x : int
+  ; y : int
+  ; dir : dir
+  }
+
+let pp_position fmt p =
+  Format.fprintf fmt "(x = %d; y = %d; dir = %a)" p.x p.y pp_dir p.dir
+
+type t =
+  { tiles : background array array
+  ; width : int
+  ; height : int
+  }
+
+let init () =
+  let width = 100 in
+  let height = 90 in
+  let tiles =
+    Array.init width (fun _x ->
+        Array.init height (fun _y ->
+            if Random.int 1000 <= 42 then Water else Grass ) )
+  in
+  { tiles; width; height }
+
+let get_tile_kind ~x ~y map =
+  try map.tiles.(x).(y) with Invalid_argument _ -> Black
+
+let count_wheat map =
+  Array.fold_left
+    (fun count a ->
+      let count' =
+        Array.fold_left
+          (fun count -> function
+            | Wheat -> succ count | Black | Grass | Water -> count )
+          0 a
+      in
+      count + count' )
+    0 map
+
+let check_move map ({ x; y; _ } as pos) movement_dir =
+  let x, y =
+    match movement_dir with
+    | Left -> (x - 1, y)
+    | Right -> (x + 1, y)
+    | Down -> (x, y + 1)
+    | Up -> (x, y - 1)
+  in
+  match get_tile_kind ~x ~y map with
+  | (Black | Water) as bg ->
+    Error (Format.asprintf "can't move on %a" pp_background bg)
+  | Grass | Wheat -> Ok { pos with x; y }

src/network.ml

@@ -0,0 +1,11 @@
+let marshal o = Marshal.to_string o [] |> Format.sprintf "%S"
+
+let unmarshal o =
+  let s = Scanf.sscanf o "%S" (fun s -> s) in
+  Marshal.from_string s 0
+
+type server_message =
+  | Full_state of State.t
+  | Update_result of (State.action' list, string) result
+
+type client_message = Action_msg of State.action

src/pellest.ml

@@ -1,52 +1,41 @@
-open Util
+let regularly_call_fun f v =
+  let () = Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> f ())) in
+  let (_ : Unix.interval_timer_status) =
+    Unix.setitimer Unix.ITIMER_REAL { Unix.it_interval = v; Unix.it_value = v }
+  in
+  ()
 
-let home_get request = Home.f request |> Dream.html
+let update_offline_user_state () =
+  (* TODO *)
+  ()
 
-let register_get request = Register.f request |> Dream.html
+let update_online_user_state () =
+  Hashtbl.filter_map_inplace
+    (fun _user_id state -> Some (Shared.State.auto_update state))
+    User.state_ht
 
-let login_get request = Login.f request |> Dream.html
+let to_repeat () =
+  update_online_user_state ();
+  update_offline_user_state ()
 
-let login_post request =
-  match%lwt Dream.form request with
-  | `Ok [ ("login", login); ("password", password) ] -> (
-    match User.login ~login ~password request with
-    | Error e -> render e
-    | Ok () ->
-      let url =
-        match Dream.query request "redirect" with
-        | None -> "/"
-        | Some redirect -> Dream.from_percent_encoded redirect
-      in
-      Dream.respond ~status:`See_Other
-        ~headers:[ ("Location", url) ]
-        "Logged in: Happy geo-posting!" )
-  | form -> handle_invalid_form form
-
-let register_post request =
-  match%lwt Dream.form request with
-  | `Ok [ ("email", email); ("nick", nick); ("password", password) ] -> (
-    match User.register ~email ~nick ~password with
-    | Error e -> render e
-    | Ok () ->
-      let res =
-        Result.fold ~error:Fun.id
-          ~ok:(fun _ -> "User created ! Welcome !")
-          (User.login ~login:nick ~password request)
-      in
-      render res )
-  | form -> Util.handle_invalid_form form
+let () =
+  regularly_call_fun to_repeat
+    (Shared.Time.s_to_float Shared.State.auto_update_rate)
 
 let () =
   let logger = if App.log then Dream.logger else Fun.id in
-  Dream.run ~port:App.port
-    ~error_handler:(Dream.error_template Util.error_template)
-  @@ logger @@ Dream.memory_sessions
+  Dream.run ~port:App.port @@ logger @@ Dream.sql_pool Db.db_uri
+  @@ Dream.sql_sessions ~lifetime:3600.
   @@ Dream.router
        Dream.
-         [ get "/assets/**" (Dream.static ~loader:Util.asset_loader "")
-         ; get "/" home_get
-         ; get "/login" login_get
-         ; post "/login" login_post
-         ; get "/register" register_get
-         ; post "/register" register_post
+         [ get "/assets/**" Asset.get
+         ; get "/" Home.get
+         ; get "/island" Island.get
+         ; get "/island/ws" (fun request ->
+               Dream.websocket @@ Ws.handle_client request )
+         ; get "/login" Login.get
+         ; post "/login" Login.post
+         ; get "logout" Logout.get
+         ; get "/register" Register.get
+         ; post "/register" Register.post
          ]

src/register.ml

@@ -1,14 +1,19 @@
 open Tyxml.Html
 open Tyx_util
+open Syntax
 
-let f request =
-  (* todo page titles? *)
-  let page_title = "Pellest|Register" in
+let get request =
+  let** () = User.assert_not_logged request in
+  let title = "Pellest|Register" in
   let register =
     let submit = button ~a:[ a_id "submet_reginster" ] [ txt "submit" ] in
-    let nick = make_input_text "nick" in
-    let password = make_input_text "password" in
-    let email = make_input_text "email" in
+    let nick = input ~a:[ a_id "nick"; a_name "nick"; a_input_type `Text ] () in
+    let password =
+      input ~a:[ a_id "password"; a_name "password"; a_input_type `Password ] ()
+    in
+    let email =
+      input ~a:[ a_id "email"; a_name "email"; a_input_type `Text ] ()
+    in
     div
       [ make_form request ~action:"/register"
           ~items:[ nick; password; email; submit ]
@@ -16,4 +21,14 @@ let f request =
   in
   let text = div [ txt "register a new pellestian ~!" ] in
   let page = div [ text; register ] in
-  Template.render ~page_title ~scripts:[] page
+  Template.render ~title ~scripts:[] page
+
+let post request =
+  let** () = User.assert_not_logged request in
+  match%lwt Dream.form request with
+  | `Ok [ ("email", email); ("nick", nick); ("password", password) ] ->
+    let** () = User.register ~email ~nick ~password in
+    let** () = User.login ~login:nick ~password request in
+    Template.render ~title:"Welcome !" ~scripts:[]
+      (Tyxml.Html.txt "User created ! Welcome !")
+  | _form -> Template.err (`Bad_Request, "invalid form")

src/state.ml

@@ -0,0 +1,156 @@
+module Offset : sig
+  val check_move :
+    x:float -> y:float -> Map.dir -> float * float * Map.dir Option.t
+end = struct
+  let limit = 1.
+
+  let step = 0.25
+
+  let check_move ~x ~y = function
+    | Map.Left ->
+      let x' = x +. step in
+      if x' >= limit then begin
+        let x' = ~-.limit in
+        (x', y, Some Map.Left)
+      end
+      else (x', y, None)
+    | Right ->
+      let x' = x -. step in
+      if x' <= ~-.limit then begin
+        let x' = limit in
+        (x', y, Some Right)
+      end
+      else (x', y, None)
+    | Down ->
+      let y' = y -. step in
+      if y' <= ~-.limit then begin
+        let y' = limit in
+        (x, y', Some Down)
+      end
+      else (x, y', None)
+    | Up ->
+      let y' = y +. step in
+      if y' >= limit then begin
+        let y' = ~-.limit in
+        (x, y', Some Up)
+      end
+      else (x, y', None)
+end
+
+type t =
+  { map : Map.t
+  ; mana : int
+  ; wheat : int
+  ; player_pos : Map.position
+  ; offset_x : float
+  ; offset_y : float
+  }
+
+let init () =
+  { map = Map.init ()
+  ; mana = 0
+  ; wheat = 0
+  ; player_pos = { x = 0; y = 0; dir = Down }
+  ; offset_x = 0.
+  ; offset_y = 0.
+  }
+
+type action =
+  | Meditate
+  (* TODO some action do not needs to be checked by server *)
+  | Move_offset of Map.dir
+  | Move of Map.dir
+  | Plant_wheat
+(* TODO: we don't need dir so we should change the type of Map.position *)
+
+(* type for result of action send to the client by the server *)
+type action' =
+  | Add_mana of int
+  | Set_player_position of Map.position
+  | Set_offset of float * float
+  | Plant_wheat of int * int
+
+let pp_action fmt = function
+  | Meditate -> Format.pp_print_string fmt "Meditate"
+  | Move_offset dir -> Format.fprintf fmt "Move_offset %a" Map.pp_dir dir
+  | Move dir -> Format.fprintf fmt "Move %a" Map.pp_dir dir
+  | Plant_wheat -> Format.fprintf fmt "Plant_wheat"
+
+let pp_action' fmt = function
+  | Add_mana n -> Format.fprintf fmt "Add_mana %d" n
+  | Set_player_position pos ->
+    Format.fprintf fmt "Set_player_position (%a)" Map.pp_position pos
+  | Set_offset (x, y) -> Format.fprintf fmt "Set_offset (%f, %f)" x y
+  | Plant_wheat (x, y) -> Format.fprintf fmt "Plant_wheat (%d, %d)" x y
+
+let plant_wheat_cost = 10
+
+let rec check_action state = function
+  | Meditate ->
+    if state.mana < 99 then Ok [ Add_mana 1 ] else Error "maximum mana"
+  | Move dir -> (
+    match Map.check_move state.map state.player_pos dir with
+    | Error _e as error -> error
+    | Ok pos -> Ok [ Set_player_position pos ] )
+  | Move_offset dir ->
+    if dir <> state.player_pos.dir then
+      Ok [ Set_player_position { state.player_pos with dir } ]
+    else
+      let offset_x, offset_y, dir' =
+        Offset.check_move ~x:state.offset_x ~y:state.offset_y dir
+      in
+      let offset_action =
+        [ Set_player_position { state.player_pos with dir }
+        ; Set_offset (offset_x, offset_y)
+        ]
+      in
+      begin
+        match dir' with
+        | None -> Ok offset_action
+        | Some dir' -> begin
+          match check_action state (Move dir') with
+          | Error _e as e -> e
+          | Ok actions -> Ok (offset_action @ actions)
+        end
+      end
+  | Plant_wheat -> (
+    let { Map.x; y; dir } = state.player_pos in
+    let x, y =
+      match dir with
+      | Down -> (x, y + 1)
+      | Left -> (x - 1, y)
+      | Right -> (x + 1, y)
+      | Up -> (x, y - 1)
+    in
+    match Map.get_tile_kind ~x ~y state.map with
+    | Map.Black -> Error "can't plant wheat in space !"
+    | Water -> Error "can't plant wheat in water !"
+    | Wheat -> Error "there's already some wheat there !"
+    | Grass ->
+      if state.mana >= plant_wheat_cost then Ok [ Plant_wheat (x, y) ]
+      else Error "not enough mana..." )
+
+let perform_action state = function
+  | Add_mana n -> { state with mana = state.mana + n }
+  | Set_player_position player_pos -> { state with player_pos }
+  | Set_offset (offset_x, offset_y) -> { state with offset_x; offset_y }
+  | Plant_wheat (x, y) ->
+    state.map.tiles.(x).(y) <- Map.Wheat;
+    { state with mana = state.mana - plant_wheat_cost }
+
+let auto_update state =
+  let state =
+    match check_action state Meditate with
+    | Error _e -> state
+    | Ok actions -> List.fold_left perform_action state actions
+  in
+  let count_wheat = Map.count_wheat state.map.tiles in
+  { state with wheat = state.wheat + count_wheat }
+
+let auto_update_rate = Time.mk_s 1
+
+let pp fmt { mana; wheat; player_pos; map; offset_x; offset_y } =
+  let bg = Map.get_tile_kind ~x:player_pos.x ~y:player_pos.y map in
+  Format.fprintf fmt
+    "mana = %d; wheat = %d; player_pos = %a; %a; offset_x = %f; offset_y = %f"
+    mana wheat Map.pp_position player_pos Map.pp_background bg offset_x offset_y

src/syntax.ml

@@ -1,12 +1,16 @@
-(* let bindings for early return when encountering an error *)
-(* see https://ocaml.org/releases/4.13/htmlman/bindingops.html *)
-
 let ( let* ) o f = Result.fold ~ok:f ~error:Result.error o
 
-let unwrap_list f ids =
-  let l = List.map f ids in
-  let res = List.find_opt Result.is_error l in
-  match res with
-  | None -> Ok (List.map Result.get_ok l)
-  | Some (Ok _) -> assert false
-  | Some (Error _e as error) -> error
+type extended_status =
+  [ Dream.status
+  | `See_Other_Redirect of (string * string) list
+  ]
+
+let ( let** ) o f =
+  match o with
+  | Error (kind, msg) -> begin
+    match kind with
+    | `See_Other_Redirect headers ->
+      Dream.respond ~status:`See_Other ~headers msg
+    | #Dream.status as status -> Template.err (status, msg)
+  end
+  | Ok v -> f v

src/template.ml

@@ -1,6 +1,6 @@
 open Tyxml
 
-let render ~page_title ~scripts content =
+let generic ~page_title ~scripts content =
   let open Html in
   let head =
     head
@@ -10,6 +10,13 @@ let render ~page_title ~scripts content =
         ]
       @ scripts )
   in
-  let body = body [ main [ content ] ] in
+  let body = body [ main [ div [ content ] ] ] in
   let page = html head body in
   Format.asprintf "%a@." (pp ~indent:true ()) page
+
+let render ~title ~scripts content =
+  Dream.html @@ generic ~page_title:title ~scripts content
+
+let err (status, msg) =
+  let code = Dream.status_to_int status in
+  Dream.html ~code @@ generic ~page_title:"Error" ~scripts:[] (Html.txt msg)

src/time.ml

@@ -0,0 +1,27 @@
+include (
+  struct
+    type s = int
+
+    type ms = int
+
+    let mk_s = Fun.id
+
+    let s_to_float = float_of_int
+
+    let s_to_ms s = 1000 * s
+
+    let ms_to_float = float_of_int
+  end :
+    sig
+      type s
+
+      type ms
+
+      val mk_s : int -> s
+
+      val s_to_float : s -> float
+
+      val s_to_ms : s -> ms
+
+      val ms_to_float : ms -> float
+    end )

src/tyx_util.ml

@@ -1,7 +1,10 @@
 open Tyxml.Html
 
-let make_input_text id = input ~a:[ a_id id; a_name id; a_input_type `Text ] ()
+let csrf_tag request =
+  let open Tyxml.Html in
+  let token = Dream.csrf_token request in
+  input ~a:[ a_name "dream.csrf"; a_input_type `Hidden; a_value token ] ()
 
 let make_form request ~action ~items =
   (* TODO labels ...? *)
-  form ~a:[ a_action action; a_method `Post ] (Util.csrf_tag request :: items)
+  form ~a:[ a_action action; a_method `Post ] (csrf_tag request :: items)

src/user.ml

@@ -32,37 +32,36 @@ module Q = struct
 
   let is_already_user =
     Db.find
-    @@ (tup2 string string ->! int)
+    @@ (t2 string string ->! int)
          "SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
 
   let upload_user =
     Db.exec
-    @@ (tup4 string string string string ->. unit)
+    @@ (t4 string string string string ->. unit)
          "INSERT INTO user VALUES (?, ?, ?, ?)"
 
   let list_nicks = Db.collect_list @@ (unit ->* string) "SELECT nick FROM user"
 
   let get_user =
     Db.find
-    @@ (string ->! tup4 string string string string)
+    @@ (string ->! t4 string string string string)
          "SELECT * FROM user WHERE user_id=?"
 
   let update_bio =
     Db.exec
-    @@ (tup2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
+    @@ (t2 string string ->. unit) "UPDATE user SET bio=? WHERE user_id=?"
 
   let update_nick =
     Db.exec
-    @@ (tup2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
+    @@ (t2 string string ->. unit) "UPDATE user SET nick=? WHERE user_id=?"
 
   let update_email =
     Db.exec
-    @@ (tup2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
+    @@ (t2 string string ->. unit) "UPDATE user SET email=? WHERE user_id=?"
 
   let update_password =
     Db.exec
-    @@ (tup2 string string ->. unit)
-         "UPDATE user SET password=? WHERE user_id=?"
+    @@ (t2 string string ->. unit) "UPDATE user SET password=? WHERE user_id=?"
 
   let get_email =
     Db.find @@ (string ->! string) "SELECT email FROM user WHERE user_id=?"
@@ -71,11 +70,11 @@ module Q = struct
     Db.exec @@ (string ->. unit) "DELETE FROM user WHERE user_id=?"
 
   let upload_banished =
-    Db.exec @@ (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
+    Db.exec @@ (t2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
 
   let get_banished =
     Db.find
-    @@ (tup2 string string ->! tup2 string string)
+    @@ (t2 string string ->! t2 string string)
          "SELECT * FROM banished WHERE nick=? OR email=?"
 end
 
@@ -102,13 +101,15 @@ let login ~login ~password request =
   let try_password user_id =
     let* good_password = Q.get_password user_id in
     if Bcrypt.verify password (Bcrypt.hash_of_string good_password) then
+      (* TODO lwt
+         await them *)
       let _unit_lwt = Dream.invalidate_session request in
-      let _unit_lwt = Dream.put_session "user_id" user_id request in
+      let _unit_lwt = Dream.set_session_field request "user_id" user_id in
       let* nick = get_nick user_id in
-      let _unit_lwt = Dream.put_session "nick" nick request in
+      let _unit_lwt = Dream.set_session_field request "nick" nick in
       Ok ()
-    else if is_banished login then Error "YOU ARE BANISHED"
-    else Error "wrong password"
+    else if is_banished login then Error (`Forbidden, "YOU ARE BANISHED")
+    else Error (`Forbidden, "wrong password")
   in
 
   let id_from_nick = get_id_from_nick login in
@@ -120,7 +121,7 @@ let login ~login ~password request =
     List.iter
       (fun id -> if Result.is_ok @@ try_password id then raise Exit)
       user_id_list;
-    Error "invalid login"
+    Error (`Forbidden, "invalid login")
   with Exit -> Ok ()
 
 let valid_nick nick =
@@ -141,25 +142,28 @@ let register ~email ~nick ~password =
   let password = Bcrypt.hash password in
   let password = Bcrypt.string_of_hash password in
 
-  if not valid then Error "Something is wrong"
+  if not valid then Error (`Bad_Request, "invalid nick, email or password")
   else
     let* nb = Q.is_already_user (nick, email) in
     if nb = 0 then
       let user_id = Uuidm.to_string (Uuidm.v4_gen App.random_state ()) in
       Q.upload_user (user_id, nick, password, email)
-    else Error "nick or email already exists"
+    else Error (`Conflict, "nick or email already exists")
 
 let list () =
   let* users = Q.list_nicks () in
   Ok
     (Format.asprintf "<ul>%a</ul>"
        (Format.pp_print_list (fun fmt -> function
-          | s -> Format.fprintf fmt {|<li><a href="/user/%s">%s</a></li>|} s s )
-       )
+         | s -> Format.fprintf fmt {|<li><a href="/user/%s">%s</a></li>|} s s ))
        users )
 
+let get_nick_unsafe request = Option.get @@ Dream.session_field request "nick"
+
+let is_logged_in request = Option.is_some @@ Dream.session_field request "nick"
+
 let profile request =
-  match Dream.session "nick" request with
+  match Dream.session_field request "nick" with
   | None -> "not logged in"
   | Some nick -> Format.sprintf "Hello %s !" nick
 
@@ -174,20 +178,20 @@ let delete_user user_id = Q.delete_user user_id
 let update_nick nick user_id =
   if valid_nick nick then
     if not (exist_nick nick) then Q.update_nick (nick, user_id)
-    else Error "nick already taken"
-  else Error "invalid nick"
+    else Error (`Conflict, "nick already taken")
+  else Error (`Bad_Request, "invalid nick")
 
 let update_email email user_id =
   if valid_email email then
     if not (exist_email email) then Q.update_email (email, user_id)
-    else Error "email already taken"
-  else Error "invalid email"
+    else Error (`Conflict, "email already taken")
+  else Error (`Bad_Request, "invalid email")
 
 let update_password password user_id =
   if valid_password password then
     let password = Bcrypt.hash password |> Bcrypt.string_of_hash in
     Q.update_password (password, user_id)
-  else Error "invalid password"
+  else Error (`Bad_Request, "invalid password")
 
 let public_profile user_id =
   let* user = get_user user_id in
@@ -211,3 +215,35 @@ let public_profile user_id =
       user.nick user.nick
   in
   Ok user_info
+
+let assert_logged request =
+  if is_logged_in request then Ok ()
+  else
+    let target = Dream.target request in
+    let redirect_url =
+      Format.sprintf "/login?redirect=%s" (Dream.to_percent_encoded target)
+    in
+    Error
+      ( `See_Other_Redirect [ ("Location", redirect_url) ]
+      , "you should be logged in" )
+
+let assert_not_logged request =
+  if is_logged_in request then
+    (* redirect to the home page *)
+    Error
+      (`See_Other_Redirect [ ("Location", "/") ], "you shouldn't be logged in")
+  else Ok ()
+
+(* TODO save states *)
+
+let state_ht : (string, Shared.State.t) Hashtbl.t = Hashtbl.create 1
+
+let set_state = Hashtbl.replace state_ht
+
+let get_state user_id =
+  match Hashtbl.find_opt state_ht user_id with
+  | Some state -> Ok state
+  | None ->
+    let state = Shared.State.init () in
+    Hashtbl.replace state_ht user_id state;
+    Ok state

src/util.ml

@@ -1,34 +0,0 @@
-let handle_invalid_form = function
-  | `Ok _ -> Dream.respond ~status:`Bad_Request "invalid form"
-  | `Many_tokens _ | `Missing_token _ | `Invalid_token _ | `Wrong_session _
-  | `Expired _ | `Wrong_content_type ->
-    Dream.empty `Bad_Request
-
-let asset_loader _root path _request =
-  match Content.read ("assets/" ^ path) with
-  | None -> Dream.empty `Not_Found
-  | Some asset ->
-    (* TODO cache-control: ~headers:[ ("Cache-Control", "max-age=151200") ] *)
-    Dream.respond asset
-
-let error_template _error _debug_info response =
-  let open Lwt.Syntax in
-  let status = Dream.status response in
-  let code = Dream.status_to_int status in
-  (*TODO improve: can't use template.elm.html because it needs "request" *)
-  let* body = Dream.body response in
-  let reason =
-    if String.equal "" body then Dream.status_to_string status else body
-  in
-  Dream.set_body response (Format.sprintf "%d: %s" code reason);
-  Lwt.return response
-
-let csrf_tag request =
-  let open Tyxml.Html in
-  let token = Dream.csrf_token request in
-  input ~a:[ a_name "dream.csrf"; a_input_type `Hidden; a_value token ] ()
-
-let render s =
-  let open Tyxml.Html in
-  let page = div [ txt s ] in
-  Dream.html @@ Template.render ~page_title:"blblbl" ~scripts:[] page

src/ws.ml

@@ -0,0 +1,52 @@
+open Lwt.Syntax
+open Shared
+
+let get_state_unsafe user_id =
+  match User.get_state user_id with
+  | Error _e -> assert false
+  | Ok state -> state
+
+let handle_client request client =
+  match Dream.session_field request "user_id" with
+  | None -> Dream.log "User does not exists" |> Lwt.return
+  | Some user_id ->
+    (* send user island state for the first time *)
+    let state = get_state_unsafe user_id in
+    let* () =
+      Dream.send ~text_or_binary:`Text client
+        (Network.marshal (Network.Full_state state))
+    in
+
+    let rec loop () =
+      match%lwt Dream.receive client with
+      | None ->
+        (* TODO: backup everything to database *)
+        Dream.close_websocket client
+      | Some s ->
+        let state = get_state_unsafe user_id in
+        let (Network.Action_msg action : Network.client_message) =
+          Network.unmarshal s
+        in
+        Dream.log "checking action %a" State.pp_action action;
+        Dream.log "current state %a" State.pp state;
+        let res =
+          match State.check_action state action with
+          | Error msg as e ->
+            Dream.log "check_action error: %s" msg;
+            e
+          | Ok action' ->
+            Dream.log "check_action ok: %a"
+              (Format.pp_print_list
+                 ~pp_sep:(fun fmt () -> Format.fprintf fmt " ; ")
+                 State.pp_action' )
+              action';
+            let state = List.fold_left State.perform_action state action' in
+            User.set_state user_id state;
+            Ok action'
+        in
+        let* () =
+          Dream.send client (Network.marshal (Network.Update_result res))
+        in
+        loop ()
+    in
+    loop ()

src/ws_client.ml

@@ -0,0 +1,35 @@
+open Brr
+open Brr_io
+open Shared
+
+let ws =
+  let ws_url =
+    let location = Window.location G.window in
+    let host = Uri.host location |> Jstr.to_string in
+    let port =
+      Option.fold ~none:""
+        ~some:(fun port -> Format.sprintf ":%d" port)
+        (Uri.port location)
+    in
+    let ws = if host = "localhost" then "ws" else "wss" in
+    Jstr.of_string @@ Format.sprintf "%s://%s%s/island/ws" ws host port
+  in
+  Websocket.create ws_url
+
+let ws_target = Websocket.as_target ws
+
+let on_event ws_event f =
+  let (_ : Ev.listener) = Ev.listen ws_event f ws_target in
+  ()
+
+let to_server_msg ev =
+  let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in
+  let server_msg : Network.server_message = Network.unmarshal data in
+  server_msg
+
+let on_update_state_message f =
+  on_event Message.Ev.message (fun ev -> f (to_server_msg ev))
+
+let send (msg : Network.client_message) =
+  let s = Jstr.of_string (Network.marshal msg) in
+  Websocket.send_string ws s