diff --git a/src/content/assets/css/style.css b/src/content/assets/css/style.css index 7d7808b..7d57117 100644 --- a/src/content/assets/css/style.css +++ b/src/content/assets/css/style.css @@ -23,3 +23,7 @@ main { height: 100%; width: 100%; } + +.centered { + text-align: center; +} diff --git a/src/content/assets/js/dune b/src/content/assets/js/dune new file mode 100644 index 0000000..2883df4 --- /dev/null +++ b/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)))) diff --git a/src/dune b/src/dune index ba4e8db..2a1d301 100644 --- a/src/dune +++ b/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))) diff --git a/src/home.ml b/src/home.ml index 741aea4..d870dc7 100644 --- a/src/home.ml +++ b/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) diff --git a/src/island.ml b/src/island.ml new file mode 100644 index 0000000..aee8cd7 --- /dev/null +++ b/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 diff --git a/src/island_client.ml b/src/island_client.ml new file mode 100644 index 0000000..a4226cc --- /dev/null +++ b/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 + () diff --git a/src/logout.ml b/src/logout.ml index 97a8a30..94a273d 100644 --- a/src/logout.ml +++ b/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 diff --git a/src/pellest.ml b/src/pellest.ml index b40e123..3d1d478 100644 --- a/src/pellest.ml +++ b/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 diff --git a/src/user.ml b/src/user.ml index 752f6bd..2b2b354 100644 --- a/src/user.ml +++ b/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")