get display to work

src/content/assets/css/style.css

@@ -23,3 +23,7 @@ main {
   height: 100%;
   width: 100%;
 }
+
+.centered {
+  text-align: center;
+}

src/content/assets/js/dune

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

src/dune

@@ -4,18 +4,18 @@
   app
   asset
   content
-  pellest
-  template
+  db
   home
-  register
+  island
   login
   logout
-  user
+  pellest
+  register
   syntax
-  db
-  tyx_util)
+  template
+  tyx_util
+  user)
  (libraries
-  uuidm
   bos
   caqti
   caqti.blocking
@@ -28,9 +28,10 @@
   lwt
   safepass
   scfg
-  uri
   tyxml
   tyxml.functor
+  uri
+  uuidm
   yojson)
  (preprocess
   (pps lwt_ppx)))
@@ -38,8 +39,17 @@
 (rule
  (target content.ml)
  (deps
-  (source_tree content))
+  (source_tree content)
+  island_client.bc.js)
  (action
   (with-stdout-to
    %{null}
    (run ocaml-crunch -m plain content -o %{target}))))
+
+(executable
+ (name island_client)
+ (modules island_client)
+ (libraries js_of_ocaml brr)
+ (modes js)
+ (preprocess
+  (pps js_of_ocaml-ppx)))

src/home.ml

@@ -2,14 +2,20 @@ open Tyxml.Html
 
 let get request =
   let title = "Pellest is the best game ever!" in
-  let about = div [ txt App.about ] in
-  let register_link = div [ a ~a:[ a_href "/register" ] [ txt "Register" ] ] in
-  let login_link = div [ a ~a:[ a_href "/login" ] [ txt "Login" ] ] in
-  let logout_link = div [ a ~a:[ a_href "/logout" ] [ txt "Logout" ] ] in
   let page =
-    div
-    @@
-    if User.is_logged_in request then [ about; logout_link ]
-    else [ about; login_link; register_link ]
+    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
-  Template.render ~title ~scripts:[] page
+  Template.render ~title ~scripts:[] (div page)

src/island.ml

@@ -0,0 +1,29 @@
+open Tyxml.Html
+open Syntax
+
+let get request =
+  let** () = User.assert_logged request in
+  let title = "Your island" in
+  let canvas =
+    canvas
+      ~a:[ a_id "canvas" ]
+      [ txt "please update your browser or enable javascript" ]
+  in
+  let img_grass =
+    img ~src:"/assets/img/grass.png" ~alt:"grass"
+      ~a:[ a_hidden (); a_id "grass" ]
+      ()
+  in
+  let page = div ~a:[ a_class [ "centered" ] ] @@ [ canvas; img_grass ] 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,55 @@
+let tile_size = 40
+
+let width = 835
+
+let height = 635
+
+let canvas = Jv.get Jv.global "canvas"
+
+let context = Jv.call canvas "getContext" [| Jv.of_string "2d" |]
+
+let init_bg () =
+  Jv.set canvas "width" (Jv.of_int width);
+  Jv.set canvas "height" (Jv.of_int height);
+  Jv.set context "fillStyle" (Jv.of_string "#FF1188");
+  Jv.call context "fillRect"
+    [| Jv.of_int 0; Jv.of_int 0; Jv.of_int width; Jv.of_int height |]
+
+let window = Jv.get Jv.global "window"
+
+let () =
+  let (_ : Jv.t) =
+    Jv.call window "addEventListener" [| Jv.of_string "load"; Jv.repr init_bg |]
+  in
+  ()
+
+let tiles_per_w = width / tile_size
+
+let tiles_per_h = height / tile_size
+
+let orig_x = (width - (tiles_per_w * tile_size)) / 2
+
+let orig_y = (height - (tiles_per_h * tile_size)) / 2
+
+let grass = Jv.get Jv.global "grass"
+
+let draw_background () =
+  for x = 0 to tiles_per_w - 1 do
+    for y = 0 to tiles_per_h - 1 do
+      let (_ : Jv.t) =
+        Jv.call context "drawImage"
+          [| grass
+           ; Jv.of_int (orig_x + (x * tile_size))
+           ; Jv.of_int (orig_y + (y * tile_size))
+          |]
+      in
+      ()
+    done
+  done
+
+let () =
+  let (_ : Jv.t) =
+    Jv.call window "addEventListener"
+      [| Jv.of_string "load"; Jv.repr draw_background |]
+  in
+  ()

src/logout.ml

@@ -1,7 +1,7 @@
 open Syntax
 
 let get request =
-  let** () = User.asserd_logged request in
+  let** () = User.assert_logged request in
   let title = "Logout" in
   let%lwt () = Dream.invalidate_session request in
   let page = Tyxml.Html.txt "logged out" in

src/pellest.ml

@@ -5,6 +5,7 @@ let () =
        Dream.
          [ get "/assets/**" Asset.get
          ; get "/" Home.get
+         ; get "/island" Island.get
          ; get "/login" Login.get
          ; post "/login" Login.post
          ; get "logout" Logout.get

src/user.ml

@@ -158,6 +158,8 @@ let list () =
        )
        users )
 
+let get_nick_unsafe request = Option.get @@ Dream.session "nick" request
+
 let is_logged_in request = Option.is_some @@ Dream.session "nick" request
 
 let profile request =
@@ -214,7 +216,7 @@ let public_profile user_id =
   in
   Ok user_info
 
-let asserd_logged request =
+let assert_logged request =
   if is_logged_in request then Ok ()
   else Error (`Forbidden, "you should be logged in")