From be2a16e0b90a475d06fbf0d69093c583510c658f Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Mon, 5 Dec 2022 22:35:38 +0100 Subject: [PATCH 01/81] update .ocamlformat --- .ocamlformat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.ocamlformat b/.ocamlformat index f81fbf5..c54116a 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.23.0 +version=0.24.1 assignment-operator=end-line break-cases=fit break-fun-decl=wrap From 97864116bba944b74d42522b51bc3b19b6cdd6be Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Mon, 5 Dec 2022 22:44:30 +0100 Subject: [PATCH 02/81] do not force file to exist --- src/app.ml | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/src/app.ml b/src/app.ml index d213823..9c3c619 100644 --- a/src/app.ml +++ b/src/app.ml @@ -20,14 +20,13 @@ let 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 + if not @@ Sys.file_exists filename then [] + else begin + Dream.log "config file: %s" filename; + match Scfg.Parse.from_file filename with + | Error e -> failwith e + | Ok config -> config + end let open_registration = match Scfg.Query.get_dir "open_registration" config with @@ -59,8 +58,9 @@ 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) @@ -78,17 +78,15 @@ let log = 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 random_state = Random.State.make_self_init () let () = Random.set_state random_state let about = - (* TODO read from about.txt *) - "This is pellest" + 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 e -> failwith e + | Ok about -> about ) From 20f18bcd764a6e2b920c4adbbdc1160941cc62cf Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 6 Dec 2022 00:12:14 +0100 Subject: [PATCH 03/81] clean code --- src/asset.ml | 10 + src/content/assets/css/leaflet.css | 640 ---------------------- src/content/assets/img/layers-2x.png | Bin 1259 -> 0 bytes src/content/assets/img/layers.png | Bin 696 -> 0 bytes src/content/assets/img/marker-icon-2x.png | Bin 2464 -> 0 bytes src/content/assets/img/marker-icon.png | Bin 1466 -> 0 bytes src/content/assets/img/marker-shadow.png | Bin 618 -> 0 bytes src/content/assets/js/dune | 8 - src/db.ml | 5 +- src/dune | 4 +- src/home.ml | 14 +- src/js/client.ml | 0 src/js/dune | 10 - src/js/geo.ml | 97 ---- src/js/leaflet/leaflet.js | 6 - src/js/utils.ml | 14 - src/login.ml | 22 +- src/pellest.ml | 53 +- src/register.ml | 17 +- src/syntax.ml | 8 +- src/template.ml | 24 +- src/tyx_util.ml | 7 +- src/user.ml | 20 +- src/util.ml | 34 -- 24 files changed, 99 insertions(+), 894 deletions(-) create mode 100644 src/asset.ml delete mode 100644 src/content/assets/css/leaflet.css delete mode 100644 src/content/assets/img/layers-2x.png delete mode 100644 src/content/assets/img/layers.png delete mode 100644 src/content/assets/img/marker-icon-2x.png delete mode 100644 src/content/assets/img/marker-icon.png delete mode 100644 src/content/assets/img/marker-shadow.png delete mode 100644 src/content/assets/js/dune delete mode 100644 src/js/client.ml delete mode 100644 src/js/dune delete mode 100644 src/js/geo.ml delete mode 100644 src/js/leaflet/leaflet.js delete mode 100644 src/js/utils.ml diff --git a/src/asset.ml b/src/asset.ml new file mode 100644 index 0000000..f02f0d6 --- /dev/null +++ b/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 "" diff --git a/src/content/assets/css/leaflet.css b/src/content/assets/css/leaflet.css deleted file mode 100644 index 3385b5e..0000000 --- a/src/content/assets/css/leaflet.css +++ /dev/null @@ -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; - } diff --git a/src/content/assets/img/layers-2x.png b/src/content/assets/img/layers-2x.png deleted file mode 100644 index 200c333dca9652ac4cba004d609e5af4eee168c1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1259 zcmeAS@N?(olHy`uVBq!ia0y~yU@!q;4i*LmhWx_I2@DJ@n><|{Ln;`Pe)y|cT4BSrpMM7AKE|dn|XR+k!t#k(tv`Q zFW(sEd!8~#>$+9`f9l__#fF!KZ}B_rzo8eC{r}xGzO@x)!A}C+%Y(`<1s-2^LiGH- zNefThzU1_3Qe}!q>B&sRiQ8E#H9j`Wp1zeElOM1<_xPqG{7q&i{}sRA|NWDBa`yhi zf4~1}Z!&l?D{`K~v~Df`g0pk31-#L={QUP&^~BTfPt276eJZ4F#OLLkrWm<1w?G}$K(_Zg>&?>%7rSDWy?-oPVGDw+3f6ddKzommMznMtmE1m^mE;|X)^@3r5^M>q%(7WwwkhRUVZzX zFui*B_UL;{ERE{7ySzCa{A5c-^`03^s-Cnw)fD`#!?J7Jk{=GMTBd1ws=RS{H7RMA z+lH2N3m&&zxMt!%-Q)BVRe@_$r#$1#RlV@>f}~i)v%B7(D}^uiKE0`=J9&~rL}git za^vjh=XaOCc>eeO>kuD~_nyZSSrR*HoRZ?^jT=9HS|#-C z#I0=$9oqx1b}%c7@V%LR;e=gTTa&Q*O*Q|E%7{caZdK)_+ZJf zZ?&H!g%0t3zQ`e9eahh1=NZBi3YOTd+htU}IKfpW%e~b`fYbPb(yyJ0eX|!$;Jmtc zpGlI(Uq{=OPOf@MjvXyZfAUxkxkT|?T2R1T7_4W$NpIDXdncV=-Og(5O3XcC)5tQ> zz+Ah^=e$i`pnF#TudS&IcRlWTsKE8W$-*hoo%u=2$;`|LE*k2wcM@{W?B28Hj1!|( z?&`3_D`smL6xn7gD*L#dPAd}*D+qeymA_@1k^7b7fk)o?9(Qdv5?I?{*Qdo6H_a$Z zWx4ILe&t;!1-}-TBu7TxOI@rh@5%8t*~M7);;#tq)bxD@K>`uh2LySGU20__qc2Mz zz5e8&(8Q{b_nT$qIxJK3ZwNANm$G;z+!`QW&+ygqZIXsCQ=*b?Q`wxE@t%9{h$R(y z`}7A0eZ8=B>r+-n=MV*-1+Ej;cKH>13)vbyyUbGSW~KP1V^g_>mQb1#clPCv9d}vs ze&jIq>z1(p^?bgvyl$yv;Vr)mizp0?3uUtD~sA1FSi+%x^t@XE}h@-tYzk9 zqoeJq#fQ#h%zQM#GO;LXnVpKdkC%5qo68}Ws3tQNA+-xadlV-caB*y5$@NebP0l+XkKIZj$K diff --git a/src/content/assets/img/layers.png b/src/content/assets/img/layers.png deleted file mode 100644 index 1a72e5784b2b456eac5d7670738db80697af3377..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 696 zcmeAS@N?(olHy`uVBq!ia0y~yV2}b~4i*Lm24?3LR|W>AdQTU}kP61$5aS9JMv;5A zx9={r3D-Qo$}jd-@Kme(q}h{gk8N9f^YEHSI?4X$wi&*^XXUqVf93n@6)G0|HB0O+ z{oGRd;!&;aKiPjre@~N1y8by_{oP(ApF5A&Z+bmlV3plXXQ4Q^(0Q+y~?G3 z!a`R6-Bzb}>nxoMS3g;|c>CL9(`O!9VDQ7}^1l9i({>+QJ4%7S^9P-Qtwc)jUmWjVlF-6H4cVyjqg@ zMm}=+(G^1+f9k%t3*NyNhGDITISixbZs=XtX?<#@#To^} zllR&yC7Q0b2+Ufee$_3@VyDHEwjITj6hhx>ORdzOd~VN~YpdKO9dmD=@;Ir&?!Ka0 ze9@!>sms1^+w^n(%oWF3dR*t__&0jzGw-8qqez~?-<4~x zU6bljyRxA4^qUU`2YDx)`}y=x*@+KtSBac>;qcY?zuAd~x7`1fA4n|jeLTA^%I{0R z&%u&I8&&`GCa_jieR-P2?K98qLyM^QzxM~_RzHi!*UqnACyylIHN^Rj+B6T>B0g6wD2rb>45pm~>lr(g1)bIG-PU&x&EkqfVSO*&yS z;hbgfS=;Jm?$a(hPCjqmxW%!3m-FO{289cX=kK>@-tIN=m|6E(zuA|q`_Fk#J#X4| z*0y{tG5mYrJM&be(p=rT6IlmmfW5UU2Hz<2n7J+mwrr-TRF?&V zs_)#7Uw`VB9X@~mmHni1?h{YB&A71m;5DZS7tY*$5wYNs%e3=LkK8nDKjS{>tX=Pg zt!M9fH?R8l@Bi^z&p&_vW!`i4?dR`v_g=Q2d_K5+tzXB6px$jMQ@2gtej$F@_2e0Q z9Xb!V_n&Z^e9@s{ZR~{2!982zCT(|`dj84V&nBH`ww%75u>873@7dlh=bfjXH|{(W z7d!Ji0|SF|NswPKgN%7_eosI1qqlQh)VQ0z2_?Q_-+JKUU7huPe~$OxD4((Q%=1rn z?q4@-&3bU7TsbLBvg!I5S2dYWD;2#S7ZU|h_he3U@wtzOHt*icIpHmL zy?Ai&|Ch$MFYn&^pnlOR%aGe&>)tMux+?e~{z}Q!-sv)H?Z4&ghKAqWlXPcq>ejrS z$BVzazm`65urEF{ge%(WbpDLf>%-W3W7Q8Z-diaxRrFdX{@IL*dsFs5{QGXyqWOP4-1PE)zwr(UqLCNG@BDShIb@BbQOH~rvz6x(1rM{&)h zCI2^1ie0}woOhbaNv}DX8hPC_CNKHouloIxr(aOX;V(s%tEQ{y7mEGo6BjSNdm(Vs z!BXu_x9&`h);d4=?!Ti)lNFxZ-a1{#+&m+>>+vSZ{Dx(nJA39omT)(Wd}d*OchY}> zS=Wlr9G}5lbce-J`;++A6P>4z=5$@YRO0(?M@{jf7aF}sW!InoesgvD`S0uR{y+7c zJM*Z^%fdw#&#l*lSVe4|v9FI;Blz0)M}eM4}1S7y|fO|lGIHmwo6)ysN) z@`Y2E&hx0QzQ6Ic0N5mtVH?#oTPjdTv<|H^U?6ohXl5NmKFtfVaU1XGt93HWL;;RCz(~i-B@2 ztMZwa3;7ji`<>cuYUsWYyyfT~aW>~)Ttdp0haa*^A7`rEIn48j^>mNb9mZLUU;Dgq zb(BBsvZ#Nx_Uel(roBAMoph#Zi{zHxs=z<2V(tqsuD&`oda+X07I6J*oa%H2;&Oq~}6b8UMv1o^cHB zw@!+h7H6D zE$XK?O<(fKWT9kaoQA9NCob2O4UaD6IrQb)Yuwtmc1m82EZ4gF#as5z)n(u0^CphP zQoO8O{?ujuQ*uXBbiS=f+M{6qXZNIC-#wKX9$WmgkWlOGG%UQt>8v8C#bLHj^{?#p zq^}Oqw=ccclsgm}$Rb#}qSsU0T>Y|%q3Of?gq$MZT@r_@Zu{PyecS50-wK8AYV-e2 zfB!+nf3KYzTfhAMRX%I(>aI5GIrFb~>*ZDV4V`!wuLxajKX3Ps*sJFZ{dk2L|LmL? zzat=TpVAF?U;l!InHzU3j`scCuEl+urt8mrgm91(dc6j+tP z6A`%Mx>-aj?~J8<#TLO+mYPp{qlT&iN z&a1S3<*O-TZj{@!u_4N6X2lKeSu#n_P@}6L{b6Jl@&cjG~%U8!&Dx}z( zrMAAcayuD$-&lEawocKa4aqJsJ&X3~rhP8ov`9`;z3BX#j-a~m>C=zc{$M|Ob;m?a ziOFe4?k@Rq<_XD> zB4=;4Zhd?AM&|77+xND~`rPKZmAu(>+oP1++ovkt{rkN7+x4_tFaL!ukK6nGo$YfQ z^*v9n8!cmLEqlSVG%sR-0gvk$*DRbW z{m-p)*DZrjd!y_xaa_#o*4U(@uKo4!Pp!ij7T!1}%l>}rjh7!Q-(N81zW?~clRw*E z{?k)GYWmiy#bRlmL;oJl&J$aiudgm)F0-iHas2Qk`y1cI?%sa8bcrAT(b;!%I<0P9 z{GTy@w!r#Jyj6z3I9)}Su6`_XYb*QXS!FV5bHD9z{itSs)R*aqqTRyE=Ymg+ZNB$v zHnpZ&)$hNave^Ci{e>)>+mm|UX)=F2arlas*Y!VZ^`gp;W=x!PmHFb<*?e}lzMCE0 zvRk9d-y7$jUC*^W@geu4@I-OlYNyz3uMQ~hJ@ZAvR^;ZhPs}lPSAO%o7BSQa zbpPGC@q~NNuAHs@aeMx#hPkYYE#J1MVCVaHeA;*K{uFcFvg=QSSx&=`UA`hqVtqd? zdYU5{zPVBEP0{7r*yQI8{Cgfe_xwDKZM9d}j|Vzyjy`R7nLK@io8wY#kL`E7Jf<68x9vugLJO(0z-KZ&Qdg!24aAb07_69#wwGGo2xYnJYN`~G6Y z{f5WJTvyi~d3Pw}=hJ5XJrB~|HdTa{+%+rHYo0wvW<#>j?DETdO_@vH{3w)qU%ji; z_NZx&{M3G{ii77TKhyiAxALr4;M%-PCKi?|B^8>h(u}9Bzu_-jd+e)R*D9HVSAKyF zecrkG`QJvbip||uzVh)2I2K)AknA*Z-`f1(ke>{yQhV!uK44yNk^b+!z|FQq$H>U% z4;rj)&CipZ6`-=U+SoNLchL;9^D}-vc+R=`7mwnv#>0hg<$|tQStOh|DXSMGs-QM%v9#OT6aOo!0u!OS>mk{4v*^-gU{kUv-=DI!X3RTGs59 zrms7aq`qxvdDNrlbwOV>GmT$cCUm!OcDu!Xn-2~CQ?8YY{CTrg$>;Sw`KWyp56!-# zvTn<7$3qHR4xXKK)bzH)nQ1H9&39e2*J8I>_;hw(^Yq=jSu~fmADQ`g-w!kW*($3f zq`R`zS+DL4=#y?Q`_N(ZtLBi%<=QzX-b%(U=MFlvzxDbXmD0JBS)OidXsr40A^42_ zgQZVg7!FDwD~idOcvfy#ai6Y&gUYVfn=F;xwLJ0PR(xmSKH_ux;D=dz-;~^0xZPL! z1ozroz7KYO?cK)hC-BfMm|Z;L!tIi4FB=3m3Vm8)$!*y6sqlWqio>o2PxU5+TD=Tg zTYBn%ncKVvzMt<;x^8t&I-EsdU*;9>P2#^cg&*=|96!BiOWgcbr%qb!*P729?QZ?6 zRrA<$=6|mncDLWmyzk*RUeFH>vO3!Qi?h`T=KR)_2Cros(q` zrr!L0L#TAiV);U2p+@gxZ`B_y65O@-44>dO5ph1@TNmwv1>fy$%wBo$+&WgT#8pop z)W1KvrsG3JiO}O;u{)0M6cpu=b+0}4U()?P(=nGF;+fwCy{@FkvLxKGX3gAtJaCcS qX{9?EN|FMnBE=+YEB(x$$D3}plVUPRyu-l2z~JfX=d#Wzp$P!`FXGq$ diff --git a/src/content/assets/img/marker-shadow.png b/src/content/assets/img/marker-shadow.png deleted file mode 100644 index 9fd2979532a19a15b824ce763c76e04a8dafadfb..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 618 zcmeAS@N?(olHy`uVBq!ia0y~yV9*3%4i*Lm2ByptwG0eQhMq2tAr*{oFSYhPb`W5> zz-9dRf4!`+aT{;(+DlW`OuKvh(cD`Fe?o50tvmGJPyYYkI}^-Pj=%i->5t$_?z+Eg z<0t)EHE)aXMy2F{nEjj_T;IYwdK?Rnnaqjf{1)D-;#kNmzt4GE;O+QxK@S+5(^AaU z7N=aDb)V1U?7Vn^%sUpxJr3q=Te918=e*elN$zhlHIzdXC1oeM8Mbg5Nj2o3WOPw+ zpMOwu*&gweJLb*OS~P7Ar@rLmS*ayg8lq+dZ0+?Zm6nX!yo^w|MJ60@P{_ADQggak&v`^0oPSK8g z6Zm$gzJVJ145{rKZ=dn?y=(KrV#&L&JR6VjWuMu>*SMBLWeLMd-$OHax6Mdiqt~NQ zs^Y#(?6|a*=efdFwcBoGHo3%{*nZNbWKCU{!`kM%S>CBD4~8GC3UcaXD%fwav8F%f z=oGOgmCmZ50aHZd{ 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 diff --git a/src/dune b/src/dune index 8352fbb..ce55c43 100644 --- a/src/dune +++ b/src/dune @@ -2,6 +2,7 @@ (name pellest) (modules app + asset content pellest util @@ -37,8 +38,7 @@ (rule (target content.ml) (deps - (source_tree content) - (file content/assets/js/client.js)) + (source_tree content)) (action (with-stdout-to %{null} diff --git a/src/home.ml b/src/home.ml index 2b03752..5a0c562 100644 --- a/src/home.ml +++ b/src/home.ml @@ -1,11 +1,9 @@ open Tyxml.Html -let f _request = - let page_title = "Pellest is the best game ever!" in +let get _request = + let 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" ] ] - 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 + 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 page = div [ about; login_link; register_link ] in + Template.render ~title ~scripts:[] page diff --git a/src/js/client.ml b/src/js/client.ml deleted file mode 100644 index e69de29..0000000 diff --git a/src/js/dune b/src/js/dune deleted file mode 100644 index c404ab0..0000000 --- a/src/js/dune +++ /dev/null @@ -1,10 +0,0 @@ -(executable - (name client) - (modules client) - (libraries brr utils) - (modes js)) - -(library - (name utils) - (modules utils) - (libraries brr)) diff --git a/src/js/geo.ml b/src/js/geo.ml deleted file mode 100644 index 476d102..0000000 --- a/src/js/geo.ml +++ /dev/null @@ -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 diff --git a/src/js/leaflet/leaflet.js b/src/js/leaflet/leaflet.js deleted file mode 100644 index 21f499c..0000000 --- a/src/js/leaflet/leaflet.js +++ /dev/null @@ -1,6 +0,0 @@ -/* @preserve - * Leaflet 1.7.1, a JS library for interactive maps. http://leafletjs.com - * (c) 2010-2019 Vladimir Agafonkin, (c) 2010-2011 CloudMade - */ -!function(t,i){"object"==typeof exports&&"undefined"!=typeof module?i(exports):"function"==typeof define&&define.amd?define(["exports"],i):i(t.L={})}(this,function(t){"use strict";function h(t){for(var i,e,n=1,o=arguments.length;n=this.min.x&&e.x<=this.max.x&&i.y>=this.min.y&&e.y<=this.max.y},intersects:function(t){t=O(t);var i=this.min,e=this.max,n=t.min,o=t.max,s=o.x>=i.x&&n.x<=e.x,r=o.y>=i.y&&n.y<=e.y;return s&&r},overlaps:function(t){t=O(t);var i=this.min,e=this.max,n=t.min,o=t.max,s=o.x>i.x&&n.xi.y&&n.y=n.lat&&e.lat<=o.lat&&i.lng>=n.lng&&e.lng<=o.lng},intersects:function(t){t=N(t);var i=this._southWest,e=this._northEast,n=t.getSouthWest(),o=t.getNorthEast(),s=o.lat>=i.lat&&n.lat<=e.lat,r=o.lng>=i.lng&&n.lng<=e.lng;return s&&r},overlaps:function(t){t=N(t);var i=this._southWest,e=this._northEast,n=t.getSouthWest(),o=t.getNorthEast(),s=o.lat>i.lat&&n.lati.lng&&n.lng';var i=t.firstChild;return i.style.behavior="url(#default#VML)",i&&"object"==typeof i.adj}catch(t){return!1}}();function kt(t){return 0<=navigator.userAgent.toLowerCase().indexOf(t)}var Bt={ie:tt,ielt9:it,edge:et,webkit:nt,android:ot,android23:st,androidStock:at,opera:ht,chrome:ut,gecko:lt,safari:ct,phantom:_t,opera12:dt,win:pt,ie3d:mt,webkit3d:ft,gecko3d:gt,any3d:vt,mobile:yt,mobileWebkit:xt,mobileWebkit3d:wt,msPointer:Pt,pointer:Lt,touch:bt,mobileOpera:Tt,mobileGecko:Mt,retina:zt,passiveEvents:Ct,canvas:St,svg:Zt,vml:Et},At=Pt?"MSPointerDown":"pointerdown",It=Pt?"MSPointerMove":"pointermove",Ot=Pt?"MSPointerUp":"pointerup",Rt=Pt?"MSPointerCancel":"pointercancel",Nt={},Dt=!1;function jt(t,i,e,n){function o(t){Ut(t,r)}var s,r,a,h,u,l,c,_;function d(t){t.pointerType===(t.MSPOINTER_TYPE_MOUSE||"mouse")&&0===t.buttons||Ut(t,h)}return"touchstart"===i?(u=t,l=e,c=n,_=p(function(t){t.MSPOINTER_TYPE_TOUCH&&t.pointerType===t.MSPOINTER_TYPE_TOUCH&&Ri(t),Ut(t,l)}),u["_leaflet_touchstart"+c]=_,u.addEventListener(At,_,!1),Dt||(document.addEventListener(At,Wt,!0),document.addEventListener(It,Ht,!0),document.addEventListener(Ot,Ft,!0),document.addEventListener(Rt,Ft,!0),Dt=!0)):"touchmove"===i?(h=e,(a=t)["_leaflet_touchmove"+n]=d,a.addEventListener(It,d,!1)):"touchend"===i&&(r=e,(s=t)["_leaflet_touchend"+n]=o,s.addEventListener(Ot,o,!1),s.addEventListener(Rt,o,!1)),this}function Wt(t){Nt[t.pointerId]=t}function Ht(t){Nt[t.pointerId]&&(Nt[t.pointerId]=t)}function Ft(t){delete Nt[t.pointerId]}function Ut(t,i){for(var e in t.touches=[],Nt)t.touches.push(Nt[e]);t.changedTouches=[t],i(t)}var Vt=Pt?"MSPointerDown":Lt?"pointerdown":"touchstart",qt=Pt?"MSPointerUp":Lt?"pointerup":"touchend",Gt="_leaflet_";var Kt,Yt,Xt,Jt,$t,Qt,ti=fi(["transform","webkitTransform","OTransform","MozTransform","msTransform"]),ii=fi(["webkitTransition","transition","OTransition","MozTransition","msTransition"]),ei="webkitTransition"===ii||"OTransition"===ii?ii+"End":"transitionend";function ni(t){return"string"==typeof t?document.getElementById(t):t}function oi(t,i){var e,n=t.style[i]||t.currentStyle&&t.currentStyle[i];return n&&"auto"!==n||!document.defaultView||(n=(e=document.defaultView.getComputedStyle(t,null))?e[i]:null),"auto"===n?null:n}function si(t,i,e){var n=document.createElement(t);return n.className=i||"",e&&e.appendChild(n),n}function ri(t){var i=t.parentNode;i&&i.removeChild(t)}function ai(t){for(;t.firstChild;)t.removeChild(t.firstChild)}function hi(t){var i=t.parentNode;i&&i.lastChild!==t&&i.appendChild(t)}function ui(t){var i=t.parentNode;i&&i.firstChild!==t&&i.insertBefore(t,i.firstChild)}function li(t,i){if(void 0!==t.classList)return t.classList.contains(i);var e=pi(t);return 0this.options.maxZoom)?this.setZoom(t):this},panInsideBounds:function(t,i){this._enforcingBounds=!0;var e=this.getCenter(),n=this._limitCenter(e,this._zoom,N(t));return e.equals(n)||this.panTo(n,i),this._enforcingBounds=!1,this},panInside:function(t,i){var e,n,o=A((i=i||{}).paddingTopLeft||i.padding||[0,0]),s=A(i.paddingBottomRight||i.padding||[0,0]),r=this.getCenter(),a=this.project(r),h=this.project(t),u=this.getPixelBounds(),l=u.getSize().divideBy(2),c=O([u.min.add(o),u.max.subtract(s)]);return c.contains(h)||(this._enforcingBounds=!0,e=a.subtract(h),n=A(h.x+e.x,h.y+e.y),(h.xc.max.x)&&(n.x=a.x-e.x,0c.max.y)&&(n.y=a.y-e.y,0=this.options.transform3DLimit&&this._resetView(this.getCenter(),this.getZoom())},_findEventTargets:function(t,i){for(var e,n=[],o="mouseout"===i||"mouseover"===i,s=t.target||t.srcElement,r=!1;s;){if((e=this._targets[m(s)])&&("click"===i||"preclick"===i)&&!t._simulated&&this._draggableMoved(e)){r=!0;break}if(e&&e.listens(i,!0)){if(o&&!Vi(s,t))break;if(n.push(e),o)break}if(s===this._container)break;s=s.parentNode}return n.length||r||o||!Vi(s,t)||(n=[this]),n},_handleDOMEvent:function(t){var i;this._loaded&&!Ui(t)&&("mousedown"!==(i=t.type)&&"keypress"!==i&&"keyup"!==i&&"keydown"!==i||Pi(t.target||t.srcElement),this._fireDOMEvent(t,i))},_mouseEvents:["click","dblclick","mouseover","mouseout","contextmenu"],_fireDOMEvent:function(t,i,e){var n;if("click"===t.type&&((n=h({},t)).type="preclick",this._fireDOMEvent(n,n.type,e)),!t._stopped&&(e=(e||[]).concat(this._findEventTargets(t,i))).length){var o=e[0];"contextmenu"===i&&o.listens(i,!0)&&Ri(t);var s,r={originalEvent:t};"keypress"!==t.type&&"keydown"!==t.type&&"keyup"!==t.type&&(s=o.getLatLng&&(!o._radius||o._radius<=10),r.containerPoint=s?this.latLngToContainerPoint(o.getLatLng()):this.mouseEventToContainerPoint(t),r.layerPoint=this.containerPointToLayerPoint(r.containerPoint),r.latlng=s?o.getLatLng():this.layerPointToLatLng(r.layerPoint));for(var a=0;athis.options.zoomAnimationThreshold)return!1;var n=this.getZoomScale(i),o=this._getCenterOffset(t)._divideBy(1-1/n);return!(!0!==e.animate&&!this.getSize().contains(o))&&(M(function(){this._moveStart(!0,!1)._animateZoom(t,i,!0)},this),!0)},_animateZoom:function(t,i,e,n){this._mapPane&&(e&&(this._animatingZoom=!0,this._animateToCenter=t,this._animateToZoom=i,ci(this._mapPane,"leaflet-zoom-anim")),this.fire("zoomanim",{center:t,zoom:i,noUpdate:n}),setTimeout(p(this._onZoomTransitionEnd,this),250))},_onZoomTransitionEnd:function(){this._animatingZoom&&(this._mapPane&&_i(this._mapPane,"leaflet-zoom-anim"),this._animatingZoom=!1,this._move(this._animateToCenter,this._animateToZoom),M(function(){this._moveEnd(!0)},this))}});function Yi(t){return new Xi(t)}var Xi=S.extend({options:{position:"topright"},initialize:function(t){c(this,t)},getPosition:function(){return this.options.position},setPosition:function(t){var i=this._map;return i&&i.removeControl(this),this.options.position=t,i&&i.addControl(this),this},getContainer:function(){return this._container},addTo:function(t){this.remove(),this._map=t;var i=this._container=this.onAdd(t),e=this.getPosition(),n=t._controlCorners[e];return ci(i,"leaflet-control"),-1!==e.indexOf("bottom")?n.insertBefore(i,n.firstChild):n.appendChild(i),this._map.on("unload",this.remove,this),this},remove:function(){return this._map&&(ri(this._container),this.onRemove&&this.onRemove(this._map),this._map.off("unload",this.remove,this),this._map=null),this},_refocusOnMap:function(t){this._map&&t&&0",n=document.createElement("div");return n.innerHTML=e,n.firstChild},_addItem:function(t){var i,e=document.createElement("label"),n=this._map.hasLayer(t.layer);t.overlay?((i=document.createElement("input")).type="checkbox",i.className="leaflet-control-layers-selector",i.defaultChecked=n):i=this._createRadioElement("leaflet-base-layers_"+m(this),n),this._layerControlInputs.push(i),i.layerId=m(t.layer),zi(i,"click",this._onInputClick,this);var o=document.createElement("span");o.innerHTML=" "+t.name;var s=document.createElement("div");return e.appendChild(s),s.appendChild(i),s.appendChild(o),(t.overlay?this._overlaysList:this._baseLayersList).appendChild(e),this._checkDisabledLayers(),e},_onInputClick:function(){var t,i,e=this._layerControlInputs,n=[],o=[];this._handlingClick=!0;for(var s=e.length-1;0<=s;s--)t=e[s],i=this._getLayer(t.layerId).layer,t.checked?n.push(i):t.checked||o.push(i);for(s=0;si.options.maxZoom},_expandIfNotCollapsed:function(){return this._map&&!this.options.collapsed&&this.expand(),this},_expand:function(){return this.expand()},_collapse:function(){return this.collapse()}}),$i=Xi.extend({options:{position:"topleft",zoomInText:"+",zoomInTitle:"Zoom in",zoomOutText:"−",zoomOutTitle:"Zoom out"},onAdd:function(t){var i="leaflet-control-zoom",e=si("div",i+" leaflet-bar"),n=this.options;return this._zoomInButton=this._createButton(n.zoomInText,n.zoomInTitle,i+"-in",e,this._zoomIn),this._zoomOutButton=this._createButton(n.zoomOutText,n.zoomOutTitle,i+"-out",e,this._zoomOut),this._updateDisabled(),t.on("zoomend zoomlevelschange",this._updateDisabled,this),e},onRemove:function(t){t.off("zoomend zoomlevelschange",this._updateDisabled,this)},disable:function(){return this._disabled=!0,this._updateDisabled(),this},enable:function(){return this._disabled=!1,this._updateDisabled(),this},_zoomIn:function(t){!this._disabled&&this._map._zoomthis._map.getMinZoom()&&this._map.zoomOut(this._map.options.zoomDelta*(t.shiftKey?3:1))},_createButton:function(t,i,e,n,o){var s=si("a",e,n);return s.innerHTML=t,s.href="#",s.title=i,s.setAttribute("role","button"),s.setAttribute("aria-label",i),Oi(s),zi(s,"click",Ni),zi(s,"click",o,this),zi(s,"click",this._refocusOnMap,this),s},_updateDisabled:function(){var t=this._map,i="leaflet-disabled";_i(this._zoomInButton,i),_i(this._zoomOutButton,i),!this._disabled&&t._zoom!==t.getMinZoom()||ci(this._zoomOutButton,i),!this._disabled&&t._zoom!==t.getMaxZoom()||ci(this._zoomInButton,i)}});Ki.mergeOptions({zoomControl:!0}),Ki.addInitHook(function(){this.options.zoomControl&&(this.zoomControl=new $i,this.addControl(this.zoomControl))});var Qi=Xi.extend({options:{position:"bottomleft",maxWidth:100,metric:!0,imperial:!0},onAdd:function(t){var i="leaflet-control-scale",e=si("div",i),n=this.options;return this._addScales(n,i+"-line",e),t.on(n.updateWhenIdle?"moveend":"move",this._update,this),t.whenReady(this._update,this),e},onRemove:function(t){t.off(this.options.updateWhenIdle?"moveend":"move",this._update,this)},_addScales:function(t,i,e){t.metric&&(this._mScale=si("div",i,e)),t.imperial&&(this._iScale=si("div",i,e))},_update:function(){var t=this._map,i=t.getSize().y/2,e=t.distance(t.containerPointToLatLng([0,i]),t.containerPointToLatLng([this.options.maxWidth,i]));this._updateScales(e)},_updateScales:function(t){this.options.metric&&t&&this._updateMetric(t),this.options.imperial&&t&&this._updateImperial(t)},_updateMetric:function(t){var i=this._getRoundNum(t),e=i<1e3?i+" m":i/1e3+" km";this._updateScale(this._mScale,e,i/t)},_updateImperial:function(t){var i,e,n,o=3.2808399*t;5280Leaflet'},initialize:function(t){c(this,t),this._attributions={}},onAdd:function(t){for(var i in(t.attributionControl=this)._container=si("div","leaflet-control-attribution"),Oi(this._container),t._layers)t._layers[i].getAttribution&&this.addAttribution(t._layers[i].getAttribution());return this._update(),this._container},setPrefix:function(t){return this.options.prefix=t,this._update(),this},addAttribution:function(t){return t&&(this._attributions[t]||(this._attributions[t]=0),this._attributions[t]++,this._update()),this},removeAttribution:function(t){return t&&this._attributions[t]&&(this._attributions[t]--,this._update()),this},_update:function(){if(this._map){var t=[];for(var i in this._attributions)this._attributions[i]&&t.push(i);var e=[];this.options.prefix&&e.push(this.options.prefix),t.length&&e.push(t.join(", ")),this._container.innerHTML=e.join(" | ")}}});Ki.mergeOptions({attributionControl:!0}),Ki.addInitHook(function(){this.options.attributionControl&&(new te).addTo(this)});Xi.Layers=Ji,Xi.Zoom=$i,Xi.Scale=Qi,Xi.Attribution=te,Yi.layers=function(t,i,e){return new Ji(t,i,e)},Yi.zoom=function(t){return new $i(t)},Yi.scale=function(t){return new Qi(t)},Yi.attribution=function(t){return new te(t)};var ie=S.extend({initialize:function(t){this._map=t},enable:function(){return this._enabled||(this._enabled=!0,this.addHooks()),this},disable:function(){return this._enabled&&(this._enabled=!1,this.removeHooks()),this},enabled:function(){return!!this._enabled}});ie.addTo=function(t,i){return t.addHandler(i,this),this};var ee,ne={Events:Z},oe=bt?"touchstart mousedown":"mousedown",se={mousedown:"mouseup",touchstart:"touchend",pointerdown:"touchend",MSPointerDown:"touchend"},re={mousedown:"mousemove",touchstart:"touchmove",pointerdown:"touchmove",MSPointerDown:"touchmove"},ae=E.extend({options:{clickTolerance:3},initialize:function(t,i,e,n){c(this,n),this._element=t,this._dragStartTarget=i||t,this._preventOutline=e},enable:function(){this._enabled||(zi(this._dragStartTarget,oe,this._onDown,this),this._enabled=!0)},disable:function(){this._enabled&&(ae._dragging===this&&this.finishDrag(),Si(this._dragStartTarget,oe,this._onDown,this),this._enabled=!1,this._moved=!1)},_onDown:function(t){var i,e;!t._simulated&&this._enabled&&(this._moved=!1,li(this._element,"leaflet-zoom-anim")||ae._dragging||t.shiftKey||1!==t.which&&1!==t.button&&!t.touches||((ae._dragging=this)._preventOutline&&Pi(this._element),xi(),Xt(),this._moving||(this.fire("down"),i=t.touches?t.touches[0]:t,e=bi(this._element),this._startPoint=new k(i.clientX,i.clientY),this._parentScale=Ti(e),zi(document,re[t.type],this._onMove,this),zi(document,se[t.type],this._onUp,this))))},_onMove:function(t){var i,e;!t._simulated&&this._enabled&&(t.touches&&1i&&(e.push(t[n]),o=n);oi.max.x&&(e|=2),t.yi.max.y&&(e|=8),e}function de(t,i,e,n){var o,s=i.x,r=i.y,a=e.x-s,h=e.y-r,u=a*a+h*h;return 0this._layersMaxZoom&&this.setZoom(this._layersMaxZoom),void 0===this.options.minZoom&&this._layersMinZoom&&this.getZoom()t.y!=n.y>t.y&&t.x<(n.x-e.x)*(t.y-e.y)/(n.y-e.y)+e.x&&(u=!u);return u||Oe.prototype._containsPoint.call(this,t,!0)}});var Ne=Ce.extend({initialize:function(t,i){c(this,i),this._layers={},t&&this.addData(t)},addData:function(t){var i,e,n,o=g(t)?t:t.features;if(o){for(i=0,e=o.length;iu.x&&(l=s.x+n-u.x+h.x),s.x-l-a.x<0&&(l=s.x-a.x),s.y+e+h.y>u.y&&(c=s.y+e-u.y+h.y),s.y-c-a.y<0&&(c=s.y-a.y),(l||c)&&t.fire("autopanstart").panBy([l,c]))},_onCloseButtonClick:function(t){this._close(),Ni(t)},_getAnchor:function(){return A(this._source&&this._source._getPopupAnchor?this._source._getPopupAnchor():[0,0])}});Ki.mergeOptions({closePopupOnClick:!0}),Ki.include({openPopup:function(t,i,e){return t instanceof tn||(t=new tn(e).setContent(t)),i&&t.setLatLng(i),this.hasLayer(t)?this:(this._popup&&this._popup.options.autoClose&&this.closePopup(),this._popup=t,this.addLayer(t))},closePopup:function(t){return t&&t!==this._popup||(t=this._popup,this._popup=null),t&&this.removeLayer(t),this}}),Me.include({bindPopup:function(t,i){return t instanceof tn?(c(t,i),(this._popup=t)._source=this):(this._popup&&!i||(this._popup=new tn(i,this)),this._popup.setContent(t)),this._popupHandlersAdded||(this.on({click:this._openPopup,keypress:this._onKeyPress,remove:this.closePopup,move:this._movePopup}),this._popupHandlersAdded=!0),this},unbindPopup:function(){return this._popup&&(this.off({click:this._openPopup,keypress:this._onKeyPress,remove:this.closePopup,move:this._movePopup}),this._popupHandlersAdded=!1,this._popup=null),this},openPopup:function(t,i){return this._popup&&this._map&&(i=this._popup._prepareOpen(this,t,i),this._map.openPopup(this._popup,i)),this},closePopup:function(){return this._popup&&this._popup._close(),this},togglePopup:function(t){return this._popup&&(this._popup._map?this.closePopup():this.openPopup(t)),this},isPopupOpen:function(){return!!this._popup&&this._popup.isOpen()},setPopupContent:function(t){return this._popup&&this._popup.setContent(t),this},getPopup:function(){return this._popup},_openPopup:function(t){var i=t.layer||t.target;this._popup&&this._map&&(Ni(t),i instanceof Be?this.openPopup(t.layer||t.target,t.latlng):this._map.hasLayer(this._popup)&&this._popup._source===i?this.closePopup():this.openPopup(i,t.latlng))},_movePopup:function(t){this._popup.setLatLng(t.latlng)},_onKeyPress:function(t){13===t.originalEvent.keyCode&&this._openPopup(t)}});var en=Qe.extend({options:{pane:"tooltipPane",offset:[0,0],direction:"auto",permanent:!1,sticky:!1,interactive:!1,opacity:.9},onAdd:function(t){Qe.prototype.onAdd.call(this,t),this.setOpacity(this.options.opacity),t.fire("tooltipopen",{tooltip:this}),this._source&&this._source.fire("tooltipopen",{tooltip:this},!0)},onRemove:function(t){Qe.prototype.onRemove.call(this,t),t.fire("tooltipclose",{tooltip:this}),this._source&&this._source.fire("tooltipclose",{tooltip:this},!0)},getEvents:function(){var t=Qe.prototype.getEvents.call(this);return bt&&!this.options.permanent&&(t.preclick=this._close),t},_close:function(){this._map&&this._map.closeTooltip(this)},_initLayout:function(){var t="leaflet-tooltip "+(this.options.className||"")+" leaflet-zoom-"+(this._zoomAnimated?"animated":"hide");this._contentNode=this._container=si("div",t)},_updateLayout:function(){},_adjustPan:function(){},_setPosition:function(t){var i,e=this._map,n=this._container,o=e.latLngToContainerPoint(e.getCenter()),s=e.layerPointToContainerPoint(t),r=this.options.direction,a=n.offsetWidth,h=n.offsetHeight,u=A(this.options.offset),l=this._getAnchor(),c="top"===r?(i=a/2,h):"bottom"===r?(i=a/2,0):(i="center"===r?a/2:"right"===r?0:"left"===r?a:s.xthis.options.maxZoom||nthis.options.maxZoom||void 0!==this.options.minZoom&&oe.max.x)||!i.wrapLat&&(t.ye.max.y))return!1}if(!this.options.bounds)return!0;var n=this._tileCoordsToBounds(t);return N(this.options.bounds).overlaps(n)},_keyToBounds:function(t){return this._tileCoordsToBounds(this._keyToTileCoords(t))},_tileCoordsToNwSe:function(t){var i=this._map,e=this.getTileSize(),n=t.scaleBy(e),o=n.add(e);return[i.unproject(n,t.z),i.unproject(o,t.z)]},_tileCoordsToBounds:function(t){var i=this._tileCoordsToNwSe(t),e=new R(i[0],i[1]);return this.options.noWrap||(e=this._map.wrapLatLngBounds(e)),e},_tileCoordsToKey:function(t){return t.x+":"+t.y+":"+t.z},_keyToTileCoords:function(t){var i=t.split(":"),e=new k(+i[0],+i[1]);return e.z=+i[2],e},_removeTile:function(t){var i=this._tiles[t];i&&(ri(i.el),delete this._tiles[t],this.fire("tileunload",{tile:i.el,coords:this._keyToTileCoords(t)}))},_initTile:function(t){ci(t,"leaflet-tile");var i=this.getTileSize();t.style.width=i.x+"px",t.style.height=i.y+"px",t.onselectstart=a,t.onmousemove=a,it&&this.options.opacity<1&&mi(t,this.options.opacity),ot&&!st&&(t.style.WebkitBackfaceVisibility="hidden")},_addTile:function(t,i){var e=this._getTilePos(t),n=this._tileCoordsToKey(t),o=this.createTile(this._wrapCoords(t),p(this._tileReady,this,t));this._initTile(o),this.createTile.length<2&&M(p(this._tileReady,this,t,null,o)),vi(o,e),this._tiles[n]={el:o,coords:t,current:!0},i.appendChild(o),this.fire("tileloadstart",{tile:o,coords:t})},_tileReady:function(t,i,e){i&&this.fire("tileerror",{error:i,tile:e,coords:t});var n=this._tileCoordsToKey(t);(e=this._tiles[n])&&(e.loaded=+new Date,this._map._fadeAnimated?(mi(e.el,0),z(this._fadeFrame),this._fadeFrame=M(this._updateOpacity,this)):(e.active=!0,this._pruneTiles()),i||(ci(e.el,"leaflet-tile-loaded"),this.fire("tileload",{tile:e.el,coords:t})),this._noTilesToLoad()&&(this._loading=!1,this.fire("load"),it||!this._map._fadeAnimated?M(this._pruneTiles,this):setTimeout(p(this._pruneTiles,this),250)))},_getTilePos:function(t){return t.scaleBy(this.getTileSize()).subtract(this._level.origin)},_wrapCoords:function(t){var i=new k(this._wrapX?o(t.x,this._wrapX):t.x,this._wrapY?o(t.y,this._wrapY):t.y);return i.z=t.z,i},_pxBoundsToTileRange:function(t){var i=this.getTileSize();return new I(t.min.unscaleBy(i).floor(),t.max.unscaleBy(i).ceil().subtract([1,1]))},_noTilesToLoad:function(){for(var t in this._tiles)if(!this._tiles[t].loaded)return!1;return!0}});var sn=on.extend({options:{minZoom:0,maxZoom:18,subdomains:"abc",errorTileUrl:"",zoomOffset:0,tms:!1,zoomReverse:!1,detectRetina:!1,crossOrigin:!1},initialize:function(t,i){this._url=t,(i=c(this,i)).detectRetina&&zt&&0')}}catch(t){return function(t){return document.createElement("<"+t+' xmlns="urn:schemas-microsoft.com:vml" class="lvml">')}}}(),_n={_initContainer:function(){this._container=si("div","leaflet-vml-container")},_update:function(){this._map._animatingZoom||(hn.prototype._update.call(this),this.fire("update"))},_initPath:function(t){var i=t._container=cn("shape");ci(i,"leaflet-vml-shape "+(this.options.className||"")),i.coordsize="1 1",t._path=cn("path"),i.appendChild(t._path),this._updateStyle(t),this._layers[m(t)]=t},_addPath:function(t){var i=t._container;this._container.appendChild(i),t.options.interactive&&t.addInteractiveTarget(i)},_removePath:function(t){var i=t._container;ri(i),t.removeInteractiveTarget(i),delete this._layers[m(t)]},_updateStyle:function(t){var i=t._stroke,e=t._fill,n=t.options,o=t._container;o.stroked=!!n.stroke,o.filled=!!n.fill,n.stroke?(i=i||(t._stroke=cn("stroke")),o.appendChild(i),i.weight=n.weight+"px",i.color=n.color,i.opacity=n.opacity,n.dashArray?i.dashStyle=g(n.dashArray)?n.dashArray.join(" "):n.dashArray.replace(/( *, *)/g," "):i.dashStyle="",i.endcap=n.lineCap.replace("butt","flat"),i.joinstyle=n.lineJoin):i&&(o.removeChild(i),t._stroke=null),n.fill?(e=e||(t._fill=cn("fill")),o.appendChild(e),e.color=n.fillColor||n.color,e.opacity=n.fillOpacity):e&&(o.removeChild(e),t._fill=null)},_updateCircle:function(t){var i=t._point.round(),e=Math.round(t._radius),n=Math.round(t._radiusY||e);this._setPath(t,t._empty()?"M0 0":"AL "+i.x+","+i.y+" "+e+","+n+" 0,23592600")},_setPath:function(t,i){t._path.v=i},_bringToFront:function(t){hi(t._container)},_bringToBack:function(t){ui(t._container)}},dn=Et?cn:J,pn=hn.extend({getEvents:function(){var t=hn.prototype.getEvents.call(this);return t.zoomstart=this._onZoomStart,t},_initContainer:function(){this._container=dn("svg"),this._container.setAttribute("pointer-events","none"),this._rootGroup=dn("g"),this._container.appendChild(this._rootGroup)},_destroyContainer:function(){ri(this._container),Si(this._container),delete this._container,delete this._rootGroup,delete this._svgSize},_onZoomStart:function(){this._update()},_update:function(){var t,i,e;this._map._animatingZoom&&this._bounds||(hn.prototype._update.call(this),i=(t=this._bounds).getSize(),e=this._container,this._svgSize&&this._svgSize.equals(i)||(this._svgSize=i,e.setAttribute("width",i.x),e.setAttribute("height",i.y)),vi(e,t.min),e.setAttribute("viewBox",[t.min.x,t.min.y,i.x,i.y].join(" ")),this.fire("update"))},_initPath:function(t){var i=t._path=dn("path");t.options.className&&ci(i,t.options.className),t.options.interactive&&ci(i,"leaflet-interactive"),this._updateStyle(t),this._layers[m(t)]=t},_addPath:function(t){this._rootGroup||this._initContainer(),this._rootGroup.appendChild(t._path),t.addInteractiveTarget(t._path)},_removePath:function(t){ri(t._path),t.removeInteractiveTarget(t._path),delete this._layers[m(t)]},_updatePath:function(t){t._project(),t._update()},_updateStyle:function(t){var i=t._path,e=t.options;i&&(e.stroke?(i.setAttribute("stroke",e.color),i.setAttribute("stroke-opacity",e.opacity),i.setAttribute("stroke-width",e.weight),i.setAttribute("stroke-linecap",e.lineCap),i.setAttribute("stroke-linejoin",e.lineJoin),e.dashArray?i.setAttribute("stroke-dasharray",e.dashArray):i.removeAttribute("stroke-dasharray"),e.dashOffset?i.setAttribute("stroke-dashoffset",e.dashOffset):i.removeAttribute("stroke-dashoffset")):i.setAttribute("stroke","none"),e.fill?(i.setAttribute("fill",e.fillColor||e.color),i.setAttribute("fill-opacity",e.fillOpacity),i.setAttribute("fill-rule",e.fillRule||"evenodd")):i.setAttribute("fill","none"))},_updatePoly:function(t,i){this._setPath(t,$(t._parts,i))},_updateCircle:function(t){var i=t._point,e=Math.max(Math.round(t._radius),1),n="a"+e+","+(Math.max(Math.round(t._radiusY),1)||e)+" 0 1,0 ",o=t._empty()?"M0 0":"M"+(i.x-e)+","+i.y+n+2*e+",0 "+n+2*-e+",0 ";this._setPath(t,o)},_setPath:function(t,i){t._path.setAttribute("d",i)},_bringToFront:function(t){hi(t._path)},_bringToBack:function(t){ui(t._path)}});function mn(t){return Zt||Et?new pn(t):null}Et&&pn.include(_n),Ki.include({getRenderer:function(t){var i=(i=t.options.renderer||this._getPaneRenderer(t.options.pane)||this.options.renderer||this._renderer)||(this._renderer=this._createRenderer());return this.hasLayer(i)||this.addLayer(i),i},_getPaneRenderer:function(t){if("overlayPane"===t||void 0===t)return!1;var i=this._paneRenderers[t];return void 0===i&&(i=this._createRenderer({pane:t}),this._paneRenderers[t]=i),i},_createRenderer:function(t){return this.options.preferCanvas&&ln(t)||mn(t)}});var fn=Re.extend({initialize:function(t,i){Re.prototype.initialize.call(this,this._boundsToLatLngs(t),i)},setBounds:function(t){return this.setLatLngs(this._boundsToLatLngs(t))},_boundsToLatLngs:function(t){return[(t=N(t)).getSouthWest(),t.getNorthWest(),t.getNorthEast(),t.getSouthEast()]}});pn.create=dn,pn.pointsToPath=$,Ne.geometryToLayer=De,Ne.coordsToLatLng=We,Ne.coordsToLatLngs=He,Ne.latLngToCoords=Fe,Ne.latLngsToCoords=Ue,Ne.getFeature=Ve,Ne.asFeature=qe,Ki.mergeOptions({boxZoom:!0});var gn=ie.extend({initialize:function(t){this._map=t,this._container=t._container,this._pane=t._panes.overlayPane,this._resetStateTimeout=0,t.on("unload",this._destroy,this)},addHooks:function(){zi(this._container,"mousedown",this._onMouseDown,this)},removeHooks:function(){Si(this._container,"mousedown",this._onMouseDown,this)},moved:function(){return this._moved},_destroy:function(){ri(this._pane),delete this._pane},_resetState:function(){this._resetStateTimeout=0,this._moved=!1},_clearDeferredResetState:function(){0!==this._resetStateTimeout&&(clearTimeout(this._resetStateTimeout),this._resetStateTimeout=0)},_onMouseDown:function(t){if(!t.shiftKey||1!==t.which&&1!==t.button)return!1;this._clearDeferredResetState(),this._resetState(),Xt(),xi(),this._startPoint=this._map.mouseEventToContainerPoint(t),zi(document,{contextmenu:Ni,mousemove:this._onMouseMove,mouseup:this._onMouseUp,keydown:this._onKeyDown},this)},_onMouseMove:function(t){this._moved||(this._moved=!0,this._box=si("div","leaflet-zoom-box",this._container),ci(this._container,"leaflet-crosshair"),this._map.fire("boxzoomstart")),this._point=this._map.mouseEventToContainerPoint(t);var i=new I(this._point,this._startPoint),e=i.getSize();vi(this._box,i.min),this._box.style.width=e.x+"px",this._box.style.height=e.y+"px"},_finish:function(){this._moved&&(ri(this._box),_i(this._container,"leaflet-crosshair")),Jt(),wi(),Si(document,{contextmenu:Ni,mousemove:this._onMouseMove,mouseup:this._onMouseUp,keydown:this._onKeyDown},this)},_onMouseUp:function(t){var i;1!==t.which&&1!==t.button||(this._finish(),this._moved&&(this._clearDeferredResetState(),this._resetStateTimeout=setTimeout(p(this._resetState,this),0),i=new R(this._map.containerPointToLatLng(this._startPoint),this._map.containerPointToLatLng(this._point)),this._map.fitBounds(i).fire("boxzoomend",{boxZoomBounds:i})))},_onKeyDown:function(t){27===t.keyCode&&this._finish()}});Ki.addInitHook("addHandler","boxZoom",gn),Ki.mergeOptions({doubleClickZoom:!0});var vn=ie.extend({addHooks:function(){this._map.on("dblclick",this._onDoubleClick,this)},removeHooks:function(){this._map.off("dblclick",this._onDoubleClick,this)},_onDoubleClick:function(t){var i=this._map,e=i.getZoom(),n=i.options.zoomDelta,o=t.originalEvent.shiftKey?e-n:e+n;"center"===i.options.doubleClickZoom?i.setZoom(o):i.setZoomAround(t.containerPoint,o)}});Ki.addInitHook("addHandler","doubleClickZoom",vn),Ki.mergeOptions({dragging:!0,inertia:!st,inertiaDeceleration:3400,inertiaMaxSpeed:1/0,easeLinearity:.2,worldCopyJump:!1,maxBoundsViscosity:0});var yn=ie.extend({addHooks:function(){var t;this._draggable||(t=this._map,this._draggable=new ae(t._mapPane,t._container),this._draggable.on({dragstart:this._onDragStart,drag:this._onDrag,dragend:this._onDragEnd},this),this._draggable.on("predrag",this._onPreDragLimit,this),t.options.worldCopyJump&&(this._draggable.on("predrag",this._onPreDragWrap,this),t.on("zoomend",this._onZoomEnd,this),t.whenReady(this._onZoomEnd,this))),ci(this._map._container,"leaflet-grab leaflet-touch-drag"),this._draggable.enable(),this._positions=[],this._times=[]},removeHooks:function(){_i(this._map._container,"leaflet-grab"),_i(this._map._container,"leaflet-touch-drag"),this._draggable.disable()},moved:function(){return this._draggable&&this._draggable._moved},moving:function(){return this._draggable&&this._draggable._moving},_onDragStart:function(){var t,i=this._map;i._stop(),this._map.options.maxBounds&&this._map.options.maxBoundsViscosity?(t=N(this._map.options.maxBounds),this._offsetLimit=O(this._map.latLngToContainerPoint(t.getNorthWest()).multiplyBy(-1),this._map.latLngToContainerPoint(t.getSouthEast()).multiplyBy(-1).add(this._map.getSize())),this._viscosity=Math.min(1,Math.max(0,this._map.options.maxBoundsViscosity))):this._offsetLimit=null,i.fire("movestart").fire("dragstart"),i.options.inertia&&(this._positions=[],this._times=[])},_onDrag:function(t){var i,e;this._map.options.inertia&&(i=this._lastTime=+new Date,e=this._lastPos=this._draggable._absPos||this._draggable._newPos,this._positions.push(e),this._times.push(i),this._prunePositions(i)),this._map.fire("move",t).fire("drag",t)},_prunePositions:function(t){for(;1i.max.x&&(t.x=this._viscousLimit(t.x,i.max.x)),t.y>i.max.y&&(t.y=this._viscousLimit(t.y,i.max.y)),this._draggable._newPos=this._draggable._startPos.add(t))},_onPreDragWrap:function(){var t=this._worldWidth,i=Math.round(t/2),e=this._initialWorldOffset,n=this._draggable._newPos.x,o=(n-i+e)%t+i-e,s=(n+i+e)%t-i-e,r=Math.abs(o+e)i.getMaxZoom()&&1 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 diff --git a/src/login.ml b/src/login.ml index 2d594b1..da927b2 100644 --- a/src/login.ml +++ b/src/login.ml @@ -1,9 +1,8 @@ open Tyxml.Html open Tyx_util -let f request = - (* todo page titles? *) - let page_title = "Pellest|Login" in +let get request = + let title = "Pellest|Login" in let login = let submit = button ~a:[ a_id "submit_login" ] [ txt "submit" ] in let login = make_input_text "login" in @@ -13,4 +12,19 @@ let f request = 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 open Syntax 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 geo-posting!" + | _form -> Template.err (`Bad_Request, "invalid form") diff --git a/src/pellest.ml b/src/pellest.ml index f2ba14a..0c45150 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -1,52 +1,13 @@ -open Util - -let home_get request = Home.f request |> Dream.html - -let register_get request = Register.f request |> Dream.html - -let login_get request = Login.f request |> Dream.html - -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 () = 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) + Dream.run ~port:App.port ~error_handler:(Dream.error_template Template.error) @@ logger @@ Dream.memory_sessions @@ 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 "/login" Login.get + ; post "/login" Login.post + ; get "/register" Register.get + ; post "/register" Register.post ] diff --git a/src/register.ml b/src/register.ml index f629fc0..08da6a6 100644 --- a/src/register.ml +++ b/src/register.ml @@ -1,9 +1,8 @@ open Tyxml.Html open Tyx_util -let f request = - (* todo page titles? *) - let page_title = "Pellest|Register" in +let get request = + 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 @@ -16,4 +15,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 open Syntax 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") diff --git a/src/syntax.ml b/src/syntax.ml index 62a0617..74f5f57 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -3,10 +3,4 @@ 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 +let ( let** ) o f = match o with Error e -> Template.err e | Ok v -> f v diff --git a/src/template.ml b/src/template.ml index 5ca3080..23e5266 100644 --- a/src/template.ml +++ b/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,26 @@ 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) + +let error _error _debug_info suggested_response = + let status = Dream.status suggested_response in + let code = Dream.status_to_int status in + let reason = Dream.status_to_string status in + + Dream.set_header suggested_response "Content-Type" Dream.text_html; + + let content = Html.txt @@ Format.sprintf "%d: %s" code reason in + let body = generic ~page_title:"Error" ~scripts:[] content in + + Dream.set_body suggested_response body; + Lwt.return suggested_response diff --git a/src/tyx_util.ml b/src/tyx_util.ml index e516b4b..0d71f9d 100644 --- a/src/tyx_util.ml +++ b/src/tyx_util.ml @@ -1,7 +1,12 @@ open Tyxml.Html +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_input_text id = input ~a:[ a_id id; a_name id; a_input_type `Text ] () 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) diff --git a/src/user.ml b/src/user.ml index 1944b05..357c6b0 100644 --- a/src/user.ml +++ b/src/user.ml @@ -107,8 +107,8 @@ let login ~login ~password request = let* nick = get_nick user_id in let _unit_lwt = Dream.put_session "nick" nick request 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 +120,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,13 +141,13 @@ 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 @@ -174,20 +174,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 diff --git a/src/util.ml b/src/util.ml index 36c635c..e69de29 100644 --- a/src/util.ml +++ b/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 From ac2ede257fae3c1ec8f0cd0c65d645392fb3a215 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 6 Dec 2022 00:25:40 +0100 Subject: [PATCH 04/81] upload tiles --- src/content/assets/img/favicon.png | Bin 0 -> 1859 bytes src/content/assets/img/grass.png | Bin 0 -> 4889 bytes src/content/assets/img/papy_bottom.png | Bin 0 -> 855 bytes src/content/assets/img/papy_left.png | Bin 0 -> 1303 bytes src/content/assets/img/papy_right.png | Bin 0 -> 857 bytes src/content/assets/img/papy_top.png | Bin 0 -> 838 bytes src/content/assets/img/tree0.png | Bin 0 -> 941 bytes src/content/assets/img/tree1.png | Bin 0 -> 865 bytes src/content/assets/img/water.png | Bin 0 -> 1523 bytes src/content/assets/img/wheat.png | Bin 0 -> 671 bytes 10 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 src/content/assets/img/favicon.png create mode 100644 src/content/assets/img/grass.png create mode 100644 src/content/assets/img/papy_bottom.png create mode 100644 src/content/assets/img/papy_left.png create mode 100644 src/content/assets/img/papy_right.png create mode 100644 src/content/assets/img/papy_top.png create mode 100644 src/content/assets/img/tree0.png create mode 100644 src/content/assets/img/tree1.png create mode 100644 src/content/assets/img/water.png create mode 100644 src/content/assets/img/wheat.png diff --git a/src/content/assets/img/favicon.png b/src/content/assets/img/favicon.png new file mode 100644 index 0000000000000000000000000000000000000000..418307c56ca8c8eccda6535ff9db4743fef30285 GIT binary patch literal 1859 zcmeAS@N?(olHy`uVBq!ia0y~yV9)?z4mJh`hMs>rav2yHTQZ%U13aCb6$*;-(=u~X z85lGs)=sqbIP4&EH2!jzlBlb7hXu<@KQR|qnWbH>8v<@|t+kpF^NZD2YLbY!`@yXb z9vn})dhlpuID5FGz#oRflA@rJi9-LUi$oo%D7e#K{#~y8J;TDdv{jNb7(&h(P1?9( z#>sVEbJueyHPrPi@K0JM=dZi$q2<1J4zS-JYD^n(Wi650XZb{*fn`&RYu?>?LN%O|=OEpRWfe9geXz?S6g?!xdN1Q+aG zKAC}mfwRCPvY3HEPZ@+6E0)@qF)%Q&mw5WRvOnWt5f(8B@VT^;fq~V*)5S3);_%*? z^%+x2Wsb+6SG;^RYMw`d(&N5k$99QM>D&C~O}pDdPEq5)b+SB5Qr;MutDTzK(U!Sj zZnNZ?f0B+OuJs*X-Dh76GmAZU)?yoHQTEF3$5T#j+w<&I<@e+BURLJretvHD{QvKM z*4fQ}|GUzD{`>ErAMnUgL+}sxQ$#7o0zP8c@@moIWJbCEi0yiQkvA2SpPx&95+u?YvU=64Sv<~K`sSisU$up97Pa$9G;ueX zr){{uC}2hW)2GXLoL8;dwajCQmH7iHsdJ~^nuP`>t=hLQ`s`U&<5vgO8Z|pOKc!vC z%+m{~t=;bB<+JndGAXHZY5Z$eo?M<#5TU@zq@0y=$7c0Ak?Oro`mDlD=Fh*}y|E** z@j!QV4zBn z?)KXu3I>xHcl0uGYNbU~$A4I!(3xA`c%b7>p7BqvqB~KxPj&C!cpKo1R85|L0+`{9$YW@3j4STrQ`SO z&bP4J7w&3$a7?@XO`hxP>Bolop{h(vpItMVUBGAKD*OuyrPNJ6KhGkXW^H zr^^0%Bjy7Ah&Q%#8_z~J&2DPXz5V0wX}-bDd|&!QFq_$YCg*D_ zx2wnH&pCK7l`m;y>yDUMvzZlg5zI0tHoTa_@{O6%ai*^F^wr%FISZQ?DmEWFWH!5c zFZ&#$1-9KxFO454Z8$%zEHP2q+4&gLvEz#N`wz2KuWn3lNZ+h;_rK^H)_nptc?W)4 z@_zbkEg|oJO66s${fEtr_V-->{uaHE{Bx5k9~YOx#1G38-)lbD+0#^$CYJj1#)6d* z^J0ZK?O9nZG_-^kFV4RF;~x7Qvj^?Fa}{|kPKNNDuf5>remy8eg_d0AwHkl^o+UzdM5_w?zqri1tMuQ#Wrws*Mkva#I?_Ip>E6Q&z^>{0%;yF21H zFf=qamMscwUbKk0{7hO%Xld`cbE;Ravn literal 0 HcmV?d00001 diff --git a/src/content/assets/img/grass.png b/src/content/assets/img/grass.png new file mode 100644 index 0000000000000000000000000000000000000000..31641ec2c4d4bb816a3e778883c0e0ef10a94d1f GIT binary patch literal 4889 zcmeAS@N?(olHy`uVBq!ia0y~yV9)?z4mJh`hMs>rav2yHTQZ%U13aCb6$*;-(=u~X z85lGs)=sqbIP4&EH2!jzlBlb7hXu<@KQR|qnWbH>8v<@|t+kpF^NZD2YLbY!`@yXb z9vn})dhlpuID5FGz#oRflA@rJi9-LUi$oo%D7e#K{#~y8J;TDdv{jNb7(&h(P1?9( z#>sVEbJueyHPrPi@K0JM=dZi$q2<1J4zS-JYD^n(Wi650XZb{*fn`&RYu?>?LN%O|=OEpRWfe9geXz?S6g?!xdN1Q+aG zKAC}mfwRCPvY3HEPZ@+6E0)@qF)%Q&mw5WRvOnWt5z-U2SKhRNfk9Br)5S3);;`y< z&&{#N6K{O1FQ0!oeb@7I`3I^GFnbCpaC9koOf2&8Ej-n?I%s9rTi2j_R^2tcDHBWW zoXS>)tlH$cbB$NXMz1MrJeGI{D={#!D4sbm`(1UpMe_HTmm{Bi*R4zXGhe@A@A8KV zhwMXld}S)!xI8PX>@4fK)#55Y#XMi!%<($%kHJ_+V&9yDjf?+GZFcUKZ*%DUr*Q1v z+J^})C48UKTz<(Z;COWS+E3YSYS;kC(+)@VA$2=iPWtq2NUC@_o@4?Kj@gQrN|@Ok03|!8z+c zVZEz`p5*yYSi=0oE7(l*liddXx(x@r3?Bw9E>FHO{Yt;i?0o4zNscCb7sSg~ykL||?KS-B*V!keBlcJ47{An~r)C$IO4Q$0JZGD?R`b-XTiZH*_Z6idel$Pq z#8IiwwvHtWJlL9Ey;N*|y?cW|kKL?`&sg6+7Rn6MUC6nDU-h79|E|YaK*T?*?ITNgOTqmBbzWtYlNX9t@p;ae__wg{we8!dO%LPTA}e>L2c+=*owfY; z9Rr&kKD$z1%1N5=e!6S<^&*>Wb&m3d+l&`&)U=Gw{G6mG@n99x-#)juf6m_1-Osxy z`{jxbGtGNkPdvLew3$pb@#VaK{Y15(o#B<%q*-SdZp@Ke&#_*8$={ww_a?nsEgEID ztD3hcRkF@v`K?t4o*&t}u&*lQ^+t8xi5EIb8~)!ql=@=Z!QWD)QVZ)Btf*N!^74YTVoW;RsT7*?3J9nXUmf1vx;SnUWh)u zAJ$WDJmr^i`RRP~8#btDvZO+TQ&bB{(q5PH~cjsL_EHrU@N!Y^WoV|9*HeDT$ z1fM8g{b=arQZiThhUk{<+>5epkH-2dF}b9@oZRuDHSuSH=RWhrJNBk*+uZ$km%7b| zE$y~h$2UZ-KNxnw>&dnG&p)hHsZ>^%NKLt|c{itZefXE-nql6r-1(|K7u?_L5MZtK zyDM?_Cd-@%d)p&-zU>e#+2*{JFWuzgeAOGjnI~}z*4Ztv+s?9eX{F{#zGpiYIp-^# zQqR7kvFOhhwOw3!f|FuyEC2o{ve5a-vJ)Kl?zOGAin$roqM*(kWUjD##Y=O>B6Wq> zXE}ABMdojNk-`0UuHZM;7oIJ$dJ?ZSBWFz7x4k!V{-NniTXO@Z2X*b%Kk?6G`9#T& zzTSIF`*zO}s+pl&;%;8&Ij>jaok+`1hOY&^)scy7om=x;wl8|$_;-owpM~y!!WMj& z`Kon*UH9CY%wG+TcONnN?>4DWG>re=ahxKN1EA=9aW(iGi?_qbI<9~7OB93zt z+!@dET-l|1*K>n^)+S}&c*l~phwCOQ)|`Ivmhke(u)qQkk zvHmfU;?pmVO-Ng~ac<)GPkg^FF>LJgJSl)}#cR3Uwr=x9Pb3~n+v%X^n5%jt zsrSyyiSxNb(}}$y-{$D;n1|RTpB9+H_*Q%SN`W$u8rUC zudgiJ+P-|+xx5u^eFr~tzP-uz`{RryUzY4!Xd!xJ@|;gMHD7(rJtisgw(HlONAJRp z*w1`WcQYt=d&QD-<*;wbv2V6xkez%_e&g5t^^4w> zw3u(pl#4ErxP1SmWvS`A*T$F1pNEt>?wfo;R{GAWgg?((QUwy^9jnZi?cU`QbK0}X z@>816%un7t$v@L7Lj_K>R75|l3txOs zBGE5uxKQ%QU|~@G6_V({YtzvrCd!^Ph`iZ_j7N2wlu@j-K8!_2Ao( zmPNcS&Tg^6onqtQrLbznN>FS(3Kz^@mVr zt!Fd*t-gGoQ>3{$B~^@-A2D(C1lMf9q08*N-!Xzc0?X_3ej-+gr&a zD;L#H4-4$2ngyJAOY@^l+}Ej9Jh7<1s%RkG=UNcJrM`ZNkjIyLFrVl;o>! zF?*Lh)7V$h#%cB=wco2==3ZC5jpDg>o%(-FPZjTVz4)dqQEkCd=-O|&#`D|u74B?p ztdAxtZx9l$xHOrg^r&zN=dmd}rapi3I{3-4$?`o9wkXbFpTgWJ%ep4)_y-G@QyuHH zKIXIiI6UiR$?U6+o(Z-_=Q$TKYW+92-hQLxMz-m%+YE)K3-zOq*!p|6?obzOp0=#b z?<$W=*XrOqc`e`Deu$h}u+VawOPn%0m-$AX%~Muw-f?Whos|=k`|C9_i=4lmmiWfK z%9oeD?O5e6GZh2guazBKj{A5%e3wf3c+2qb>Iwh0OW(tse3{9*>RSrEe|Z_~SoKoK-Cp>|U!g$tBW7y*I3Mv{*?QoqYLL~L z8-e~Te`5~3opODXp`h*T^HP&G9In@1Syk{`R_X8j@IP;S0^H`+YN%Tr#;UX%O%u7k&N^z}|AO29|6Z2(h&A!T(zfJdHUF@+>5KR+o3YWwsxzkTi2b|=@75LYo2wYP z>qK9%Iml-!6ZvM*!DtSB%Rd=SE*JjqI~w=$!&=8XuLIUQ&C>19@p|$?o!umm+3m6p zYh+2|uX5Fw{KrfBdH-Dr*3sT%o_t3~>85vKp@R+U_e8Jlv6t*NzbJF~u<-ex{dR8q zW*WX&u5wv6M>OF7-o~g4J>9AsTuQ3mwdbE z&~?Vt&<)?i!!3WypXXfPudt@T-~7Z!nM~FzVjtt0{+2n0mz{`6Hg*k({AJGc>%Qj~ zpM-beKVlN}w3qyfZ+pUfT;;yndhb`a+kgB|yWs6R<9SJ)>;KED%T{Fsch@X3EbPx~ zQ+Yh6>b&4S+eM3A7YD97>=Sipfs2%PS?26Nk7r~o;;=hWFq`$+UY=CpO%KKXZE&2V zWbOOSuO*VR>3ee9eff#zieCSJUtIfbb?}_76<4|%xnGu7{o1Iy*W&PWK1uB_LCVXR zDo-D@fvXA4dUe!4!Ip0#}`x@x?TkMI4QuM_+tv_Tn{_j(iZ8>4vXnRZGrJ)aN zkk+fis=Lm8Om;Mwb4e!8qns_|k>%0ac8je(|F5dPk>@d*cW%Y|Z#gV3C)*atHLMSu zu5x#c+D*9$KI$*xIm1p*%G$B4JYl`Yqxm_;KRgsqO?vmd?N>KP@kZq{I#o7me6AX-$4iQ3|H|(Fp6d3# zeaFT_^74mjAMLT z33rE@;KzScKD8=xm`*k9Nax-Bz1_suYo*qrTGxt;3G!BtX3u(7=p0n>XU*XmY~>=G zDnAGnE^M#p6BEoWYU2+&^2I){GP?Q`KU+>8_Yt8lTMq9tb^U*zsoYaJw!KbmDfd`k7(EPbhV^TEd(W-gNFW=mH*yKtdwRLWurKBt^j1<%u2^3Q$n zWeIH6^iumBu5pVsufXm5k%<$9eX5r1uvFPM@xs0}7q2TV@>Z;}NHp2H!@#9SSt|A8 zYpLkD7vkj==4tKS)ciOS0c@G`h3Pee~oFcKonQX|-Y|%Rh$&ZBnKZ z0rJyK_S+w^Y)?D$bMNmHw?$u_=Jd2xDlLAM&bBn)W&4+7hj|5-rdddAd>1yQpC?PX z;~x85u3wv{+^qgR2dG+2`G;T$<{_ypi#&+Vm>cwp4Y3j#YZca%Ey?B#D%D}PH{zM=@ z*RM+dYrGosx3@f=FpD=yaG_N1nW#&#XJ4I}(8GM{xb~y{chq(~&Uig5<@Ccznwu($ z4n6uazhKWdF`W6>|6feAPd%I@m?#^(aiQU_|LuR) zYJRMAQ0M8*cqykbX`B1r?2S7e_t+`j?tYPbFk#MSt2o2oKbRWjC+rnp`2RuSu?yWD zDOD4{t>!ZPmGY*2e)^8tnn&$*B=_4d5V4&&Y0dQX1;&fAZGQ#&7zA87o_$4WdHvad zx~K`qoF~P0UKKpL*|_BS%k#DuZ!4EPxN)NE-f@=ddHYs)l=%G4?w9dgR4=!|#zy(a vR<&DPoc~;1K5j1la#bYK^3Ji({~6k!a9I_GS)?#9Ffe$!`njxgN@xNA_((=D literal 0 HcmV?d00001 diff --git a/src/content/assets/img/papy_bottom.png b/src/content/assets/img/papy_bottom.png new file mode 100644 index 0000000000000000000000000000000000000000..2a1eb0c94e1f01f249c7f1a36a453f7478706704 GIT binary patch literal 855 zcmeAS@N?(olHy`uVBq!ia0y~yV9;P-UFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciOEZSM8Cnnpv_#X37`Lw&)>*MmQQ%>do=U=y-n8>3q zq`-)de#A5FJ+m}CVP6!xuS;)3-RuoZ>f)n5-u`GZ!+Q>kr@?fGynhV30dM>J&t{uB zUbZTnCAHz;wxDQ_ry&!LERSH&mRO~BWB1vGdxOQL#8)pin_={A-TO>~=_#LV(pdev zeT(H})-H>j_5AC?lk)GUdH#JAJtwBIeYK+I-8FmF<*v0dC%d)&6?^R|Wc6NE+*qhm zde&xn{!C}b(x+ZoTHBg#=`4x;$YrJs8B!It@r0LmD}B?b@v@TDjl-->elG#x3ac8eqgeR_gZVx z<~e`&CwXDiII r4z724p?EPP>-upUl;HcJ)2Myf%uVBo+Ro<;3=9mOu6{1-oD!MFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciV9 zv}A6)K2f1!$H8Snd-N6v9`NvW*|_jPy{*UvbK4-+rDgkUvakQ&eBjbdjRheqeajZb zJ&DO-+Z&g9=44J-=3%x)H7un6<28xIVvW(w1JWN z*y+dbEf4UhEYDf)d~mXRs8(0f_SJhV{?FT)VGlmm_%VpBh>(nn zI$9Pi@a^|fzQ~(*D*wpI*KVG$&zZ}E!|GSjr1<*G5@*%wj@Pe6RUGav<|~;iB3$^Y zi@C9xRXI*K{DWh;wjuMA>zDti?$N2JJr?9~(J3|ElU1DS2;0lN%kRsVmsCzYwE6hn z?dQ#p9p81g>L*XbOPxHowaXQvycPy5c(q41c=cURrBEMBk6V*MBv!Fn%=61!8(?we z!`aJwc)HI@_NbK!+veFEU6EwbYbVd!rR6l$H#*m2>Q?n7WDA64?=4PX z*)enR{VDrDS8~6wKGM5OWy0RwEQwI}zD?d(1O3;)tK{TwDxUc(j{{C3j$1xy!< zYTC>n%wR0wxn%XNQFHgT<;pwO-(!1jqH<-U^@r8d?;OgPJ-(cOk^1Ak@_i@&PI@L& zxlG*nGh@k7u7?~(sX>kZ6rDeR$m+V6ZLn14R@mXLhsEuCZ~gvosP4+Gy&~5Wg&WFr z^ERtjpHAkyFK?jWVgGBok8p$7tHTfP|5cbbKdSC-s_AAohKIRF&ihy{Yh%cd{pa^- z!lRPMd!_}gKfCHbQy~AU2CW5LE0|!^0a@)2?3MCwJo8eUjxaDVFnGH9xvXFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciKPA7hJ8 z>o&}e&nvq*>1fWRUQ6}>&Zsjp=bAQ#G{=7I5^>T_o0nF=V0(F|pJB%==SL5Hn?&5_ zZ;!CaF;L(2|JJ{@ntGi>6?SKrs=N=5dQ&vPbD8iLq1V4$ImPa64BYR<+FgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciwk zz$k={8vlDQ;P$IEc(%KAO=p<0+y3GitNyoy)s)!qx^+%g;B@13`FyikMM72J?0;)p zi!bS({v``a6Pg4k&x^T{Fhyb3{~W&`HXU!)CGTiI;-r4ni0^B2;VR?$4Q^*kk8i(! zEu_|T!HgBRHL`SGFJdd6_g$Z1O}mPY&)p|iZ@Ahg>KAD~_Pw=i!JYOME3fgWZB~1G zR^E8SL6hI7idLR}d$yTZO?}?dZ%8vQ?07& zOLF&jyB0aVSA4rm#%%wQ+2$QOg{Ax%>5I0o;zsTH_ z*kj+nY$=&=Ba8RC+D|j{zCZii89UcrEtHH&j*K$(U0yjcCc7qOa)pWf$(AS;2POnc cQ2)Rx_09d(2lK#81_lNOPgg&ebxsLQ00NAIaR2}S literal 0 HcmV?d00001 diff --git a/src/content/assets/img/tree0.png b/src/content/assets/img/tree0.png new file mode 100644 index 0000000000000000000000000000000000000000..0ff700414396d9397c4156a16e207cce9c1f82ec GIT binary patch literal 941 zcmeAS@N?(olHy`uVBq!ia0y~yV9;P-UFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ci4%}ex-G4a_v{r8s z)51%Z&#aRxo@tq}cm9>Mvs>kSA01M)>3-~gJMzOCFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciFMKHPQ;o{RjhO`p7|p7t-`wZN8I)FUvK)}^93}&_Ec8b+aO$=da^>%wm~PR#Z!BM#5wLv z#*o963c3xN_w$!bx$Au;p+0i1|K3Cf1+$l#A|Mr?E7mrL@IG(6B4u(oQqi;_&w_i2 zhyjlu_fGLWXD1Zwv`%*p$o^EJb-zJv;}N!Okvlv(Iai%F{JhCJZRc@Y(X%mAnEtJ0 zQ*C%yFw5;BgLv~~r*n*YeCmx$j`47-OBy!my_rav2yHTQZ%U13aCb6$*;-(=u~X z85lGs)=sqbIP4&EH2!jzlBlb7hXu<@KQR|qnWbH>8v<@|t+kpF^NZD2YLbY!`@yXb z9vn})dhlpuID5FGz#oRflA@rJi9-LUi$oo%D7e#K{#~y8J;TDdv{jNb7(&h(P1?9( z#>sVEbJueyHPrPi@K0JM=dZi$q2<1J4zS-JYD^n(Wi650XZb{*fn`&RYu?>?LN%O|=OEpRWfe9geXz?S6g?!xdN1Q+aG zKAC}mfwRCPvY3HEPZ@+6E0)@qF)%Q&mw5WRvOnWt5i-%UV_oRaz`*>$)5S3);_%jp zx07xe@Jz{J-SK)$|HbzA$zK(#9AtLaFWID1=CLC?%_zkwXYJRGQPK7Pe%)K zP7rF$lKxyXnSFKhjJqFHly2Ui@A~90W7mH18FyTsJShJavoNB(pp-%U!=*>xkN)pA z2xFKiJLhL{m6LBSx5K_J<{t%*uQtwQoUrrbkNpR8eyQ-6R|~A)-0_ETedvdnic>as zKJLGeFFaA3VOH6f)p-+-obL9Ik#SM6ch_{Z|H zu<-Wv+cD-1&nAmJ+V~{Smf`G^zKI<6%Z~EAG-{S@ofF0o(P;T;R>Xl-a~S3vde1af z=Dvw}!__*4S*t#*-XQTuUnc2H^9*LeYdrIgocXJ!lz+ifNT6EeIO87Cg?e&_xVR7A zv9&xP{4AlxWCHhAnY?DfvS*g92Aj*7WP-vMH(7R_=>J`_pYe>p$VsV(Y%@B0!ZfDL z)S7y5Z|8|}!OH#be{SoXzeTyf%4lU7hq$v;+$@F~k=P|YcW-Y!8Cnl0%WHmK zHp6y~(;k0}88l4H`deQFe41RGW2~|8)Se%@7m5vIRwM zZ}{92O@+7?pAC6ceaWnKvy;Voy);&>O-}iuuP**diK{u+pSUeF;b5Z1_jHEfhkc6- z89KDo%J&?13YW7ii&5EVIBVs_>wWA&%Rfm!$!4@vzmnPVBzD*RjkhP*r3q|2{Xm0R zHBvw2L_c>&hs!+YQe#G~qhak&>q`00JyE^4KW#>i;$hLKmHezU3kGaxqX^HpHRW$D;I0F zI%{)pJ<1~(CCcsA?l|#=yG9QScg7Y)At7$j14Y{pFgLnPF`W{f&&Q$p%we~sNs{cW zAO`uJzt|Q%dR)l=XTyomov9a2Em`b#txs=C(BX{qi~@%Pv;X?KoVB#H%DCd!J;~4g j#FhhJTplr+|7Y!7bEV8%{^S(~1_lOCS3j3^P6rav2yH^D>>C12U7785lGsmQFmY z?Gh+)te#C!nR`l#VYgy;;G&e3foaW0C7xy%zc-YBb#BMqYIWajr;a&AcJ!`q{ok;5 z)6ywQs*yjLYjT&owp}Nc`RvZQ+IrjPHu>*s^;*<)rk1~UQ;h#GCq+qa=G@u+CN{#$ z=J6%D@IJjY`SN4URqOhrvr6{9yuNqU{na~WO~16RX_ni=#8m5f8+;BQS(ToBPb4qg zGTHNogT=EG4Tq*jnKRd2n#23Uck^VgK1Yx5Jt_Y;{A>?Bcar-%r~Buyz`y4f?^l_l zcgDy2?WDWC-ji4gm1c-U9y_!+KFiT)^&9CQAAL6}$*Jbg7V5Lu^yG-N@K%l3%R$DA zmOtI7@$%09=P%RR*qYxxw76pb>t8m%NzUQx)85z1{rY!Z@QU4m%7t&@C(d!Z=Xzf& z`(kZIZ2RTzO=<5A++-`cce^e5kH^+c&NF%T%yBp^vnAH~veSgC?=6p)Pl%cvU&6Y( z`hxcNXz~4wKCd%$cV;!@GcYi47I;J!Gcf2WgD_*oQu{In28QdNE{-7)?#X}tPkU&8 zSb@#we0;ZIg8>hZncZatKAR1f-DEv7d3b*bq{w{PDUmK>pdBn_9dhw}Q_P-*8 Date: Tue, 6 Dec 2022 00:25:44 +0100 Subject: [PATCH 05/81] update style --- src/content/assets/css/style.css | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/content/assets/css/style.css b/src/content/assets/css/style.css index ac08288..7d7808b 100644 --- a/src/content/assets/css/style.css +++ b/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; } From 1736a4c905aa0136e441f31d11204fe19d8ec060 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 6 Dec 2022 01:00:39 +0100 Subject: [PATCH 06/81] clean code --- src/dune | 2 +- src/home.ml | 10 ++++++++-- src/login.ml | 10 +++++++--- src/logout.ml | 8 ++++++++ src/pellest.ml | 4 ++-- src/register.ml | 14 ++++++++++---- src/template.ml | 13 ------------- src/tyx_util.ml | 2 -- src/user.ml | 10 ++++++++++ src/util.ml | 0 10 files changed, 46 insertions(+), 27 deletions(-) create mode 100644 src/logout.ml delete mode 100644 src/util.ml diff --git a/src/dune b/src/dune index ce55c43..ba4e8db 100644 --- a/src/dune +++ b/src/dune @@ -5,11 +5,11 @@ asset content pellest - util template home register login + logout user syntax db diff --git a/src/home.ml b/src/home.ml index 5a0c562..741aea4 100644 --- a/src/home.ml +++ b/src/home.ml @@ -1,9 +1,15 @@ open Tyxml.Html -let get _request = +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 page = div [ about; login_link; register_link ] 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 ] + in Template.render ~title ~scripts:[] page diff --git a/src/login.ml b/src/login.ml index da927b2..d6a83b8 100644 --- a/src/login.ml +++ b/src/login.ml @@ -1,12 +1,16 @@ open Tyxml.Html open Tyx_util +open Syntax let get request = + let** () = User.assert_not_logged request in let 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 + 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:"/login" ~items:[ login; password; submit ] ] in @@ -15,7 +19,7 @@ let get request = Template.render ~title ~scripts:[] page let post request = - let open Syntax in + 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 diff --git a/src/logout.ml b/src/logout.ml new file mode 100644 index 0000000..97a8a30 --- /dev/null +++ b/src/logout.ml @@ -0,0 +1,8 @@ +open Syntax + +let get request = + let** () = User.asserd_logged request in + let title = "Logout" in + let%lwt () = Dream.invalidate_session request in + let page = Tyxml.Html.txt "logged out" in + Template.render ~title ~scripts:[] page diff --git a/src/pellest.ml b/src/pellest.ml index 0c45150..b40e123 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -1,13 +1,13 @@ let () = let logger = if App.log then Dream.logger else Fun.id in - Dream.run ~port:App.port ~error_handler:(Dream.error_template Template.error) - @@ logger @@ Dream.memory_sessions + Dream.run ~port:App.port @@ logger @@ Dream.memory_sessions @@ Dream.router Dream. [ get "/assets/**" Asset.get ; get "/" Home.get ; get "/login" Login.get ; post "/login" Login.post + ; get "logout" Logout.get ; get "/register" Register.get ; post "/register" Register.post ] diff --git a/src/register.ml b/src/register.ml index 08da6a6..700cb89 100644 --- a/src/register.ml +++ b/src/register.ml @@ -1,13 +1,19 @@ open Tyxml.Html open Tyx_util +open Syntax 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 ] @@ -18,7 +24,7 @@ let get request = Template.render ~title ~scripts:[] page let post request = - let open Syntax in + 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 diff --git a/src/template.ml b/src/template.ml index 23e5266..fa99a35 100644 --- a/src/template.ml +++ b/src/template.ml @@ -20,16 +20,3 @@ let render ~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) - -let error _error _debug_info suggested_response = - let status = Dream.status suggested_response in - let code = Dream.status_to_int status in - let reason = Dream.status_to_string status in - - Dream.set_header suggested_response "Content-Type" Dream.text_html; - - let content = Html.txt @@ Format.sprintf "%d: %s" code reason in - let body = generic ~page_title:"Error" ~scripts:[] content in - - Dream.set_body suggested_response body; - Lwt.return suggested_response diff --git a/src/tyx_util.ml b/src/tyx_util.ml index 0d71f9d..5a27465 100644 --- a/src/tyx_util.ml +++ b/src/tyx_util.ml @@ -5,8 +5,6 @@ let csrf_tag request = let token = Dream.csrf_token request in input ~a:[ a_name "dream.csrf"; a_input_type `Hidden; a_value token ] () -let make_input_text id = input ~a:[ a_id id; a_name id; a_input_type `Text ] () - let make_form request ~action ~items = (* TODO labels ...? *) form ~a:[ a_action action; a_method `Post ] (csrf_tag request :: items) diff --git a/src/user.ml b/src/user.ml index 357c6b0..752f6bd 100644 --- a/src/user.ml +++ b/src/user.ml @@ -158,6 +158,8 @@ let list () = ) users ) +let is_logged_in request = Option.is_some @@ Dream.session "nick" request + let profile request = match Dream.session "nick" request with | None -> "not logged in" @@ -211,3 +213,11 @@ let public_profile user_id = user.nick user.nick in Ok user_info + +let asserd_logged request = + if is_logged_in request then Ok () + else Error (`Forbidden, "you should be logged in") + +let assert_not_logged request = + if is_logged_in request then Error (`Forbidden, "you shoudn't be logged in") + else Ok () diff --git a/src/util.ml b/src/util.ml deleted file mode 100644 index e69de29..0000000 From b504b1a69d5c3865380eb4062ad3e3cc5e00a31e Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 6 Dec 2022 02:31:33 +0100 Subject: [PATCH 07/81] get display to work --- src/content/assets/css/style.css | 4 +++ src/content/assets/js/dune | 8 +++++ src/dune | 28 ++++++++++------ src/home.ml | 24 ++++++++------ src/island.ml | 29 +++++++++++++++++ src/island_client.ml | 55 ++++++++++++++++++++++++++++++++ src/logout.ml | 2 +- src/pellest.ml | 1 + src/user.ml | 4 ++- 9 files changed, 135 insertions(+), 20 deletions(-) create mode 100644 src/content/assets/js/dune create mode 100644 src/island.ml create mode 100644 src/island_client.ml 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") From dddcf9b4881ed2ea3130c429959dc398ac88ef44 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 6 Dec 2022 03:08:30 +0100 Subject: [PATCH 08/81] draw canvas from a map --- src/island.ml | 19 +++++++--- src/island_client.ml | 89 ++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 100 insertions(+), 8 deletions(-) diff --git a/src/island.ml b/src/island.ml index aee8cd7..a6b2ad8 100644 --- a/src/island.ml +++ b/src/island.ml @@ -1,6 +1,13 @@ open Tyxml.Html open Syntax +let mk_img name = + img + ~src:(Format.sprintf "/assets/img/%s.png" name) + ~alt:name + ~a:[ a_hidden (); a_id name ] + () + let get request = let** () = User.assert_logged request in let title = "Your island" in @@ -9,12 +16,14 @@ let get request = ~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" ] - () + let img_grass = mk_img "grass" in + let img_papy_bottom = mk_img "papy_bottom" in + let img_water = mk_img "water" in + + let page = + div ~a:[ a_class [ "centered" ] ] + @@ [ canvas; img_grass; img_papy_bottom; img_water ] in - let page = div ~a:[ a_class [ "centered" ] ] @@ [ canvas; img_grass ] in let js = script diff --git a/src/island_client.ml b/src/island_client.ml index a4226cc..187b2dd 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -1,3 +1,23 @@ +module Map = struct + type background = + | Grass + | Water + | Black + + let width = 1000 + + let height = 1000 + + let player_pos = ref (500, 500) + + let m = + Array.init width (fun _x -> + Array.init height (fun _y -> + if Random.int 1000 = 42 then Water else Grass ) ) + + let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black +end + let tile_size = 40 let width = 835 @@ -33,19 +53,63 @@ let orig_y = (height - (tiles_per_h * tile_size)) / 2 let grass = Jv.get Jv.global "grass" -let draw_background () = +let papy_bottom = Jv.get Jv.global "papy_bottom" + +let water = Jv.get Jv.global "water" + +let draw_map () = + let player_x, player_y = !Map.player_pos in + Format.printf "player_x = %d@\nplayer_y = %d@\n" player_x player_y; for x = 0 to tiles_per_w - 1 do + let mapx = x + player_x - (tiles_per_w / 2) in for y = 0 to tiles_per_h - 1 do + let mapy = y + player_y - (tiles_per_h / 2) in + let img = + match Map.get_tile_kind ~x:mapx ~y:mapy with + | Grass -> grass + | Water -> water + | Black -> water + in let (_ : Jv.t) = Jv.call context "drawImage" - [| grass + [| img ; Jv.of_int (orig_x + (x * tile_size)) ; Jv.of_int (orig_y + (y * tile_size)) |] in () done - done + done; + let (_ : Jv.t) = + Jv.call context "drawImage" + [| papy_bottom + ; Jv.of_int ((width / 2) - (tile_size / 2)) + ; Jv.of_int ((height / 2) - (tile_size / 2)) + |] + in + () + +let () = + let (_ : Jv.t) = + Jv.call window "addEventListener" + [| Jv.of_string "load"; Jv.repr draw_map |] + in + () + +(* + 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) = @@ -53,3 +117,22 @@ let () = [| Jv.of_string "load"; Jv.repr draw_background |] in () + +let draw_papy () = + let (_ : Jv.t) = + Jv.call context "drawImage" + [| papy_bottom + ; Jv.of_int ((width / 2) - (tile_size / 2)) + ; Jv.of_int ((height / 2) - (tile_size / 2)) + |] + in + () + +let () = + let (_ : Jv.t) = + Jv.call window "addEventListener" + [| Jv.of_string "load"; Jv.repr draw_papy |] + in + () + +*) From 9833eb520eaa5fd9c965a469cfbe0b651f9207e9 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 6 Dec 2022 03:30:16 +0100 Subject: [PATCH 09/81] add basic movements --- src/island_client.ml | 39 +++++++++++++++++++++++++++++++++------ 1 file changed, 33 insertions(+), 6 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 187b2dd..1eb731c 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -1,3 +1,5 @@ +let () = Random.self_init () + module Map = struct type background = | Grass @@ -8,12 +10,12 @@ module Map = struct let height = 1000 - let player_pos = ref (500, 500) + let player_pos = ref (20, 3) let m = Array.init width (fun _x -> Array.init height (fun _y -> - if Random.int 1000 = 42 then Water else Grass ) ) + if Random.int 1000 <= 42 then Water else Grass ) ) let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black end @@ -82,10 +84,7 @@ let draw_map () = done; let (_ : Jv.t) = Jv.call context "drawImage" - [| papy_bottom - ; Jv.of_int ((width / 2) - (tile_size / 2)) - ; Jv.of_int ((height / 2) - (tile_size / 2)) - |] + [| papy_bottom; Jv.of_int (width / 2); Jv.of_int (height / 2) |] in () @@ -96,6 +95,34 @@ let () = in () +let kb_handler e = + let x, y = !Map.player_pos in + let x, y = + match Jv.to_string @@ Jv.get e "key" with + | "z" -> (x, y - 1) + | "q" -> (x - 1, y) + | "s" -> (x, y + 1) + | "d" -> (x + 1, y) + | _s -> (x, y) + in + let x = max 0 x in + let x = min (Map.width - 1) x in + let y = max 0 y in + let y = min (Map.height - 1) y in + Map.player_pos := (x, y); + draw_map () + +let bind_keys () = + Jv.call window "addEventListener" + [| Jv.of_string "keydown"; Jv.repr kb_handler |] + +let () = + let (_ : Jv.t) = + Jv.call window "addEventListener" + [| Jv.of_string "load"; Jv.repr bind_keys |] + in + () + (* let draw_background () = for x = 0 to tiles_per_w - 1 do From 82dcc24eedb72cc2ec1bdf20d5ad55a8aab45c7d Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 00:10:41 +0100 Subject: [PATCH 10/81] Brrrr --- src/island_client.ml | 89 ++++++++++++++++++++------------------------ src/login.ml | 4 +- 2 files changed, 43 insertions(+), 50 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 1eb731c..02f5cd6 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -20,30 +20,32 @@ module Map = struct let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black end +open Brr +open Brr_canvas + +let get_el id = + match Document.find_el_by_id G.document (Jstr.of_string id) with + | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) + | Some el -> el + let tile_size = 40 let width = 835 let height = 635 -let canvas = Jv.get Jv.global "canvas" +let canvas = + let el = get_el "canvas" in + Canvas.of_el el -let context = Jv.call canvas "getContext" [| Jv.of_string "2d" |] +let context = C2d.get_context canvas 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 - () + 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) let tiles_per_w = width / tile_size @@ -53,11 +55,11 @@ 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 grass = C2d.image_src_of_el (get_el "grass") -let papy_bottom = Jv.get Jv.global "papy_bottom" +let papy_bottom = C2d.image_src_of_el (get_el "papy_bottom") -let water = Jv.get Jv.global "water" +let water = C2d.image_src_of_el (get_el "water") let draw_map () = let player_x, player_y = !Map.player_pos in @@ -66,39 +68,25 @@ let draw_map () = let mapx = x + player_x - (tiles_per_w / 2) in for y = 0 to tiles_per_h - 1 do let mapy = y + player_y - (tiles_per_h / 2) in - let img = + let tile_img = match Map.get_tile_kind ~x:mapx ~y:mapy with | Grass -> grass | Water -> water | Black -> water in - let (_ : Jv.t) = - Jv.call context "drawImage" - [| img - ; Jv.of_int (orig_x + (x * tile_size)) - ; Jv.of_int (orig_y + (y * tile_size)) - |] - in - () + C2d.draw_image context tile_img + ~x:(float_of_int (orig_x + (x * tile_size))) + ~y:(float_of_int (orig_y + (y * tile_size))) done done; - let (_ : Jv.t) = - Jv.call context "drawImage" - [| papy_bottom; Jv.of_int (width / 2); Jv.of_int (height / 2) |] - in - () + C2d.draw_image context papy_bottom + ~x:(float_of_int (width / 2)) + ~y:(float_of_int (height / 2)) -let () = - let (_ : Jv.t) = - Jv.call window "addEventListener" - [| Jv.of_string "load"; Jv.repr draw_map |] - in - () - -let kb_handler e = +let kb_handler ev = let x, y = !Map.player_pos in let x, y = - match Jv.to_string @@ Jv.get e "key" with + match ev |> Ev.as_type |> Ev.Keyboard.key |> Jstr.to_string with | "z" -> (x, y - 1) | "q" -> (x - 1, y) | "s" -> (x, y + 1) @@ -112,16 +100,19 @@ let kb_handler e = Map.player_pos := (x, y); draw_map () -let bind_keys () = - Jv.call window "addEventListener" - [| Jv.of_string "keydown"; Jv.repr kb_handler |] - let () = - let (_ : Jv.t) = - Jv.call window "addEventListener" - [| Jv.of_string "load"; Jv.repr bind_keys |] + let on_window_load f = + ignore @@ Ev.listen Ev.load (fun _ev -> f ()) (Window.as_target G.window) in - () + let bind_keys () = + ignore + @@ Ev.listen Ev.keydown + (fun ev -> kb_handler ev) + (Window.as_target G.window) + in + on_window_load init_bg; + on_window_load draw_map; + on_window_load bind_keys (* let draw_background () = diff --git a/src/login.ml b/src/login.ml index d6a83b8..3316620 100644 --- a/src/login.ml +++ b/src/login.ml @@ -7,7 +7,9 @@ let get request = let title = "Pellest|Login" in let login = let submit = button ~a:[ a_id "submit_login" ] [ txt "submit" ] in - let login = input ~a:[ a_id "login"; a_name "login"; a_input_type `Text ] () in + 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 From 5bbfd54efbfd7340214d498735006b7d4cc417c6 Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 18:46:29 +0100 Subject: [PATCH 11/81] better keyboard --- src/island_client.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 02f5cd6..7ba151a 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -86,11 +86,11 @@ let draw_map () = let kb_handler ev = let x, y = !Map.player_pos in let x, y = - match ev |> Ev.as_type |> Ev.Keyboard.key |> Jstr.to_string with - | "z" -> (x, y - 1) - | "q" -> (x - 1, y) - | "s" -> (x, y + 1) - | "d" -> (x + 1, y) + match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + | "KeyW" | "ArrowUp" -> (x, y - 1) + | "KeyA" | "ArrowLeft" -> (x - 1, y) + | "KeyS" | "ArrowDown" -> (x, y + 1) + | "KeyD" | "ArrowRight" -> (x + 1, y) | _s -> (x, y) in let x = max 0 x in From 4b2e90f737714be01951314a2eee84e71d1c20aa Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 22:14:13 +0100 Subject: [PATCH 12/81] remove js ppx --- src/dune | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/dune b/src/dune index 2a1d301..86fc201 100644 --- a/src/dune +++ b/src/dune @@ -31,8 +31,7 @@ tyxml tyxml.functor uri - uuidm - yojson) + uuidm) (preprocess (pps lwt_ppx))) @@ -50,6 +49,4 @@ (name island_client) (modules island_client) (libraries js_of_ocaml brr) - (modes js) - (preprocess - (pps js_of_ocaml-ppx))) + (modes js)) From de904f86cc62d421d2cfdd9902d60ac19b339d29 Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 23:14:11 +0100 Subject: [PATCH 13/81] use request_animation_frame --- src/island_client.ml | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 7ba151a..2f7ebc9 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -61,7 +61,7 @@ let papy_bottom = C2d.image_src_of_el (get_el "papy_bottom") let water = C2d.image_src_of_el (get_el "water") -let draw_map () = +let draw_map _timestamp = let player_x, player_y = !Map.player_pos in Format.printf "player_x = %d@\nplayer_y = %d@\n" player_x player_y; for x = 0 to tiles_per_w - 1 do @@ -98,11 +98,18 @@ let kb_handler ev = let y = max 0 y in let y = min (Map.height - 1) y in Map.player_pos := (x, y); - draw_map () + let _animation_frame_id = G.request_animation_frame draw_map in + () + +let rec game_loop _timestamp = + (* ... update state ... *) + draw_map (); + ignore @@ G.request_animation_frame game_loop let () = - let on_window_load f = - ignore @@ Ev.listen Ev.load (fun _ev -> f ()) (Window.as_target G.window) + let on_window_load f x = + ignore + @@ Ev.listen Ev.load (fun _ev -> ignore @@ f x) (Window.as_target G.window) in let bind_keys () = ignore @@ -110,9 +117,9 @@ let () = (fun ev -> kb_handler ev) (Window.as_target G.window) in - on_window_load init_bg; - on_window_load draw_map; - on_window_load bind_keys + on_window_load init_bg (); + on_window_load bind_keys (); + on_window_load G.request_animation_frame game_loop (* let draw_background () = From 484203c9275e68fef0fffb791e1beec82f455dbd Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 23:16:36 +0100 Subject: [PATCH 14/81] remove commented code --- src/island_client.ml | 41 ----------------------------------------- 1 file changed, 41 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 2f7ebc9..75a0f91 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -120,44 +120,3 @@ let () = on_window_load init_bg (); on_window_load bind_keys (); on_window_load G.request_animation_frame game_loop - -(* - 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 - () - -let draw_papy () = - let (_ : Jv.t) = - Jv.call context "drawImage" - [| papy_bottom - ; Jv.of_int ((width / 2) - (tile_size / 2)) - ; Jv.of_int ((height / 2) - (tile_size / 2)) - |] - in - () - -let () = - let (_ : Jv.t) = - Jv.call window "addEventListener" - [| Jv.of_string "load"; Jv.repr draw_papy |] - in - () - -*) From 1b89d35dfd5722be168a414a3b04f64902502b22 Mon Sep 17 00:00:00 2001 From: Swrup Date: Thu, 8 Dec 2022 00:07:59 +0100 Subject: [PATCH 15/81] fix dune :^) --- src/dune | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/dune b/src/dune index 86fc201..5d3e288 100644 --- a/src/dune +++ b/src/dune @@ -35,6 +35,12 @@ (preprocess (pps lwt_ppx))) +(executable + (name island_client) + (modules island_client) + (libraries js_of_ocaml brr) + (modes js)) + (rule (target content.ml) (deps @@ -44,9 +50,3 @@ (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)) From b89202dfb0a46cddb2ef9ba4497f58f1f5a87526 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Thu, 8 Dec 2022 02:09:23 +0100 Subject: [PATCH 16/81] fix rendering, fix the way we use request_animation_frame --- src/island_client.ml | 62 +++++++++++++++++++++++++------------------- 1 file changed, 36 insertions(+), 26 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 75a0f91..35bc73a 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -1,3 +1,13 @@ +open Brr +open Brr_canvas + +module G = struct + include Brr.G + + let request_animation_frame f = + (ignore : int -> unit) @@ Brr.G.request_animation_frame f +end + let () = Random.self_init () module Map = struct @@ -20,9 +30,6 @@ module Map = struct let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black end -open Brr -open Brr_canvas - let get_el id = match Document.find_el_by_id G.document (Jstr.of_string id) with | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) @@ -30,9 +37,9 @@ let get_el id = let tile_size = 40 -let width = 835 +let width = 875 -let height = 635 +let height = 675 let canvas = let el = get_el "canvas" in @@ -40,7 +47,7 @@ let canvas = let context = C2d.get_context canvas -let init_bg () = +let init () = Canvas.set_w canvas width; Canvas.set_h canvas height; C2d.set_fill_style context (C2d.color (Jstr.v "#FF1188")); @@ -80,8 +87,8 @@ let draw_map _timestamp = done done; C2d.draw_image context papy_bottom - ~x:(float_of_int (width / 2)) - ~y:(float_of_int (height / 2)) + ~x:(float_of_int (width - tile_size) /. 2.) + ~y:((float_of_int height /. 2.) -. float_of_int tile_size) let kb_handler ev = let x, y = !Map.player_pos in @@ -97,26 +104,29 @@ let kb_handler ev = let x = min (Map.width - 1) x in let y = max 0 y in let y = min (Map.height - 1) y in - Map.player_pos := (x, y); - let _animation_frame_id = G.request_animation_frame draw_map in - () + Map.player_pos := (x, y) -let rec game_loop _timestamp = - (* ... update state ... *) +let rec game_loop state _timestamp = draw_map (); - ignore @@ G.request_animation_frame game_loop + let new_state = state in + G.request_animation_frame (game_loop new_state) + +let on_window_load f x = + (ignore : Ev.listener -> unit) + @@ Ev.listen Ev.load + (fun (_ev : Ev.Type.void Ev.t) -> f x) + (Window.as_target G.window) + +let bind_keys () = + (ignore : Ev.listener -> unit) + @@ Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + +(* type will change later !*) +let initial_state = () let () = - let on_window_load f x = - ignore - @@ Ev.listen Ev.load (fun _ev -> ignore @@ f x) (Window.as_target G.window) - in - let bind_keys () = - ignore - @@ Ev.listen Ev.keydown - (fun ev -> kb_handler ev) - (Window.as_target G.window) - in - on_window_load init_bg (); + on_window_load init (); on_window_load bind_keys (); - on_window_load G.request_animation_frame game_loop + on_window_load + (fun () -> G.request_animation_frame (game_loop initial_state)) + () From 0aded75cb78d54708ccc8c4cf2e0736d39e17864 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Thu, 8 Dec 2022 02:14:31 +0100 Subject: [PATCH 17/81] clean code --- src/island.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/island.ml b/src/island.ml index a6b2ad8..0631163 100644 --- a/src/island.ml +++ b/src/island.ml @@ -16,14 +16,9 @@ let get request = ~a:[ a_id "canvas" ] [ txt "please update your browser or enable javascript" ] in - let img_grass = mk_img "grass" in - let img_papy_bottom = mk_img "papy_bottom" in - let img_water = mk_img "water" in + let images = List.map mk_img [ "grass"; "papy_bottom"; "water" ] in - let page = - div ~a:[ a_class [ "centered" ] ] - @@ [ canvas; img_grass; img_papy_bottom; img_water ] - in + let page = div ~a:[ a_class [ "centered" ] ] @@ (canvas :: images) in let js = script From ddeba99f2e79ffc669af931d152d793dd89d13a5 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Thu, 8 Dec 2022 02:20:03 +0100 Subject: [PATCH 18/81] optim --- src/island_client.ml | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 35bc73a..75f0bf6 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -94,16 +94,12 @@ let kb_handler ev = let x, y = !Map.player_pos in let x, y = match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> (x, y - 1) - | "KeyA" | "ArrowLeft" -> (x - 1, y) - | "KeyS" | "ArrowDown" -> (x, y + 1) - | "KeyD" | "ArrowRight" -> (x + 1, y) + | "KeyW" | "ArrowUp" -> (x, max 0 (y - 1)) + | "KeyA" | "ArrowLeft" -> (max 0 (x - 1), y) + | "KeyS" | "ArrowDown" -> (x, min (Map.height - 1) y + 1) + | "KeyD" | "ArrowRight" -> (min (Map.width - 1) x + 1, y) | _s -> (x, y) in - let x = max 0 x in - let x = min (Map.width - 1) x in - let y = max 0 y in - let y = min (Map.height - 1) y in Map.player_pos := (x, y) let rec game_loop state _timestamp = From 365c558f35f5baf996324d2e3574af9223d334ee Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Thu, 8 Dec 2022 03:08:49 +0100 Subject: [PATCH 19/81] make sure there's an odd number of tiles --- src/island_client.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 75f0bf6..7f7a884 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -54,9 +54,13 @@ let init () = C2d.fill_rect context ~x:0. ~y:0. ~w:(float_of_int width) ~h:(float_of_int height) -let tiles_per_w = width / tile_size +let tiles_per_w = + let n = width / tile_size in + if n mod 2 = 0 then n - 1 else n -let tiles_per_h = height / tile_size +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 From 549aa39e099c7a58a5894e84aac06a30266c6e8d Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Thu, 8 Dec 2022 04:08:27 +0100 Subject: [PATCH 20/81] implement player dir, clean code --- .../img/{papy_bottom.png => papy_down.png} | Bin src/content/assets/img/papy_up.png | Bin 0 -> 838 bytes src/island.ml | 5 +- src/island_client.ml | 133 ++++++++++-------- 4 files changed, 82 insertions(+), 56 deletions(-) rename src/content/assets/img/{papy_bottom.png => papy_down.png} (100%) create mode 100644 src/content/assets/img/papy_up.png diff --git a/src/content/assets/img/papy_bottom.png b/src/content/assets/img/papy_down.png similarity index 100% rename from src/content/assets/img/papy_bottom.png rename to src/content/assets/img/papy_down.png diff --git a/src/content/assets/img/papy_up.png b/src/content/assets/img/papy_up.png new file mode 100644 index 0000000000000000000000000000000000000000..61698e46a67dd5f8337b4cbf3b6a6b966ff4a8c9 GIT binary patch literal 838 zcmeAS@N?(olHy`uVBq!ia0y~yV9;P-UFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciwk zz$k={8vlDQ;P$IEc(%KAO=p<0+y3GitNyoy)s)!qx^+%g;B@13`FyikMM72J?0;)p zi!bS({v``a6Pg4k&x^T{Fhyb3{~W&`HXU!)CGTiI;-r4ni0^B2;VR?$4Q^*kk8i(! zEu_|T!HgBRHL`SGFJdd6_g$Z1O}mPY&)p|iZ@Ahg>KAD~_Pw=i!JYOME3fgWZB~1G zR^E8SL6hI7idLR}d$yTZO?}?dZ%8vQ?07& zOLF&jyB0aVSA4rm#%%wQ+2$QOg{Ax%>5I0o;zsTH_ z*kj+nY$=&=Ba8RC+D|j{zCZii89UcrEtHH&j*K$(U0yjcCc7qOa)pWf$(AS;2POnc cQ2)Rx_09d(2lK#81_lNOPgg&ebxsLQ00NAIaR2}S literal 0 HcmV?d00001 diff --git a/src/island.ml b/src/island.ml index 0631163..eab4678 100644 --- a/src/island.ml +++ b/src/island.ml @@ -16,7 +16,10 @@ let get request = ~a:[ a_id "canvas" ] [ txt "please update your browser or enable javascript" ] in - let images = List.map mk_img [ "grass"; "papy_bottom"; "water" ] in + let images = + List.map mk_img + [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] + in let page = div ~a:[ a_class [ "centered" ] ] @@ (canvas :: images) in diff --git a/src/island_client.ml b/src/island_client.ml index 7f7a884..e1d6af9 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -10,6 +10,12 @@ end let () = Random.self_init () +type dir = + | Left + | Right + | Down + | Up + module Map = struct type background = | Grass @@ -22,6 +28,8 @@ module Map = struct let player_pos = ref (20, 3) + let player_dir = ref Down + let m = Array.init width (fun _x -> Array.init height (fun _y -> @@ -47,13 +55,6 @@ let canvas = let context = C2d.get_context canvas -let init () = - 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) - let tiles_per_w = let n = width / tile_size in if n mod 2 = 0 then n - 1 else n @@ -68,65 +69,87 @@ let orig_y = (height - (tiles_per_h * tile_size)) / 2 let grass = C2d.image_src_of_el (get_el "grass") -let papy_bottom = C2d.image_src_of_el (get_el "papy_bottom") +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 draw_map _timestamp = - let player_x, player_y = !Map.player_pos in - Format.printf "player_x = %d@\nplayer_y = %d@\n" player_x player_y; - for x = 0 to tiles_per_w - 1 do - let mapx = x + player_x - (tiles_per_w / 2) in - for y = 0 to tiles_per_h - 1 do - let mapy = y + player_y - (tiles_per_h / 2) in - let tile_img = - match Map.get_tile_kind ~x:mapx ~y:mapy with - | Grass -> grass - | Water -> water - | Black -> water - in - C2d.draw_image context tile_img - ~x:(float_of_int (orig_x + (x * tile_size))) - ~y:(float_of_int (orig_y + (y * tile_size))) - done - done; - C2d.draw_image context papy_bottom - ~x:(float_of_int (width - tile_size) /. 2.) - ~y:((float_of_int height /. 2.) -. float_of_int tile_size) +let draw_map = + 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 + fun () -> + let player_x, player_y = !Map.player_pos in + for x = 0 to tiles_per_w - 1 do + let map_x = x + player_x - (tiles_per_w / 2) in + let tile_x = float_of_int ((x * tile_size) + orig_x) in + for y = 0 to tiles_per_h - 1 do + let map_y = y + player_y - (tiles_per_h / 2) in + let tile_y = float_of_int ((y * tile_size) + orig_y) in + let tile_img = + match Map.get_tile_kind ~x:map_x ~y:map_y with + | Grass -> grass + | Water -> water + | Black -> water + in + C2d.draw_image context tile_img ~x:tile_x ~y:tile_y + done + done; + let papy = + match !Map.player_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 move dir = + if !Map.player_dir = dir then begin + let x, y = !Map.player_pos in + let x, y = + match dir with + | Left -> (x - 1, y) + | Right -> (x + 1, y) + | Down -> (x, y + 1) + | Up -> (x, y - 1) + in + match Map.get_tile_kind ~x ~y with + | Black | Water -> () + | Grass -> Map.player_pos := (x, y) + end + else Map.player_dir := dir let kb_handler ev = - let x, y = !Map.player_pos in - let x, y = - match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> (x, max 0 (y - 1)) - | "KeyA" | "ArrowLeft" -> (max 0 (x - 1), y) - | "KeyS" | "ArrowDown" -> (x, min (Map.height - 1) y + 1) - | "KeyD" | "ArrowRight" -> (min (Map.width - 1) x + 1, y) - | _s -> (x, y) - in - Map.player_pos := (x, y) + match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + | "KeyW" | "ArrowUp" -> move Up + | "KeyA" | "ArrowLeft" -> move Left + | "KeyS" | "ArrowDown" -> move Down + | "KeyD" | "ArrowRight" -> move Right + | _s -> () let rec game_loop state _timestamp = draw_map (); let new_state = state in G.request_animation_frame (game_loop new_state) -let on_window_load f x = - (ignore : Ev.listener -> unit) - @@ Ev.listen Ev.load - (fun (_ev : Ev.Type.void Ev.t) -> f x) - (Window.as_target G.window) - -let bind_keys () = - (ignore : Ev.listener -> unit) - @@ Ev.listen Ev.keydown kb_handler (Window.as_target G.window) - -(* type will change later !*) +(* type will change later ! *) let initial_state = () let () = - on_window_load init (); - on_window_load bind_keys (); - on_window_load - (fun () -> G.request_animation_frame (game_loop initial_state)) - () + (* 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); + (* bind keys *) + let _e : Ev.listener = + Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + in + (* start game *) + G.request_animation_frame (game_loop initial_state) From 91cff202f6a9438bd0ee9a654f86c878c480dc75 Mon Sep 17 00:00:00 2001 From: Swrup Date: Sun, 11 Dec 2022 18:58:56 +0100 Subject: [PATCH 21/81] wip: state server side; websocket --- src/app.ml | 8 +++--- src/common.ml | 0 src/dune | 13 +++++++--- src/island_client.ml | 60 +++++++++++++++++--------------------------- src/map.ml | 27 ++++++++++++++++++++ src/network.ml | 5 ++++ src/pellest.ml | 2 ++ src/state.ml | 17 +++++++++++++ src/user.ml | 11 ++++++++ src/ws.ml | 27 ++++++++++++++++++++ src/ws_client.ml | 43 +++++++++++++++++++++++++++++++ 11 files changed, 169 insertions(+), 44 deletions(-) create mode 100644 src/common.ml create mode 100644 src/map.ml create mode 100644 src/network.ml create mode 100644 src/state.ml create mode 100644 src/ws.ml create mode 100644 src/ws_client.ml diff --git a/src/app.ml b/src/app.ml index 9c3c619..543afc7 100644 --- a/src/app.ml +++ b/src/app.ml @@ -78,10 +78,6 @@ let log = let () = Dream.log "log: %b" log -let random_state = Random.State.make_self_init () - -let () = Random.set_state random_state - let about = let default_about = "Pellest is great !" in match Scfg.Query.get_dir "about" config with @@ -90,3 +86,7 @@ let about = match Scfg.Query.get_param 0 about with | Error e -> failwith e | Ok about -> about ) + +let random_state = Random.State.make_self_init () + +let () = Random.set_state random_state diff --git a/src/common.ml b/src/common.ml new file mode 100644 index 0000000..e69de29 diff --git a/src/dune b/src/dune index 5d3e288..c5a5f3a 100644 --- a/src/dune +++ b/src/dune @@ -14,7 +14,8 @@ syntax template tyx_util - user) + user + ws) (libraries bos caqti @@ -23,6 +24,7 @@ directories dream emile + shared fpath lambdasoup lwt @@ -37,10 +39,15 @@ (executable (name island_client) - (modules island_client) - (libraries js_of_ocaml brr) + (modules island_client ws_client) + (libraries js_of_ocaml brr shared) (modes js)) +(library + (name shared) + (modules map network state) + (libraries)) + (rule (target content.ml) (deps diff --git a/src/island_client.ml b/src/island_client.ml index e1d6af9..2fcc70f 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -1,5 +1,7 @@ open Brr +open Brr_io open Brr_canvas +open Shared module G = struct include Brr.G @@ -8,36 +10,6 @@ module G = struct (ignore : int -> unit) @@ Brr.G.request_animation_frame f end -let () = Random.self_init () - -type dir = - | Left - | Right - | Down - | Up - -module Map = struct - type background = - | Grass - | Water - | Black - - let width = 1000 - - let height = 1000 - - let player_pos = ref (20, 3) - - let player_dir = ref Down - - let m = - Array.init width (fun _x -> - Array.init height (fun _y -> - if Random.int 1000 <= 42 then Water else Grass ) ) - - let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black -end - let get_el id = match Document.find_el_by_id G.document (Jstr.of_string id) with | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) @@ -79,6 +51,11 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") +let map = + (* TODO receive map / state *) + (* dummy map; should ask for map to server *) + ref (Map.init ()) + let draw_map = 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 @@ -91,7 +68,7 @@ let draw_map = let map_y = y + player_y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = - match Map.get_tile_kind ~x:map_x ~y:map_y with + match Map.get_tile_kind ~x:map_x ~y:map_y !map with | Grass -> grass | Water -> water | Black -> water @@ -118,7 +95,7 @@ let move dir = | Down -> (x, y + 1) | Up -> (x, y - 1) in - match Map.get_tile_kind ~x ~y with + match Map.get_tile_kind ~x ~y !map with | Black | Water -> () | Grass -> Map.player_pos := (x, y) end @@ -130,6 +107,7 @@ let kb_handler ev = | "KeyA" | "ArrowLeft" -> move Left | "KeyS" | "ArrowDown" -> move Down | "KeyD" | "ArrowRight" -> move Right + | "KeyM" -> Ws_client.send State.Meditate | _s -> () let rec game_loop state _timestamp = @@ -137,9 +115,6 @@ let rec game_loop state _timestamp = let new_state = state in G.request_animation_frame (game_loop new_state) -(* type will change later ! *) -let initial_state = () - let () = (* init canvas *) Canvas.set_w canvas width; @@ -151,5 +126,16 @@ let () = let _e : Ev.listener = Ev.listen Ev.keydown kb_handler (Window.as_target G.window) in - (* start game *) - G.request_animation_frame (game_loop initial_state) + + (* get state from server*) + let initial_state_fut = Ev.next Message.Ev.message Ws_client.ws_target in + + Fut.await initial_state_fut (fun msg -> + let initial_state = Ws_client.to_server_msg msg in + let state_ref = ref initial_state in + (* attach message listener to update state *) + Ws_client.on_update_state_message (fun received -> + state_ref := received; + Format.printf "YOUR MANA IS: %d@." !state_ref.mana ); + (* start game *) + G.request_animation_frame (game_loop state_ref) ) diff --git a/src/map.ml b/src/map.ml new file mode 100644 index 0000000..ffcc2b6 --- /dev/null +++ b/src/map.ml @@ -0,0 +1,27 @@ +type dir = + | Left + | Right + | Down + | Up + +type background = + | Grass + | Water + | Black + +type t = background array array + +let width = 1000 + +let height = 1000 + +let player_pos = ref (20, 3) + +let player_dir = ref Down + +let init () = + Array.init width (fun _x -> + Array.init height (fun _y -> + if Random.int 1000 <= 42 then Water else Grass ) ) + +let get_tile_kind ~x ~y map = try map.(x).(y) with Invalid_argument _ -> Black diff --git a/src/network.ml b/src/network.ml new file mode 100644 index 0000000..aecc640 --- /dev/null +++ b/src/network.ml @@ -0,0 +1,5 @@ +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 diff --git a/src/pellest.ml b/src/pellest.ml index 3d1d478..92b30e6 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -6,6 +6,8 @@ let () = [ 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 diff --git a/src/state.ml b/src/state.ml new file mode 100644 index 0000000..fa434c8 --- /dev/null +++ b/src/state.ml @@ -0,0 +1,17 @@ +type t = + { map : Map.t + ; mutable mana : int + } + +let init () = { map = Map.init (); mana = 0 } + +type action = Meditate + +(* TODO do not send whole state *) +let handle_action state action = + match action with + | Meditate -> + if state.mana < 99 then ( + state.mana <- succ state.mana; + Ok state ) + else Error "maximum mana" diff --git a/src/user.ml b/src/user.ml index 2b2b354..a3dfe83 100644 --- a/src/user.ml +++ b/src/user.ml @@ -223,3 +223,14 @@ let assert_logged request = let assert_not_logged request = if is_logged_in request then Error (`Forbidden, "you shoudn'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 -> Ok (Shared.State.init ()) diff --git a/src/ws.ml b/src/ws.ml new file mode 100644 index 0000000..b551e89 --- /dev/null +++ b/src/ws.ml @@ -0,0 +1,27 @@ +open Lwt.Syntax +open Shared + +let handle_client request client = + match Dream.session "user_id" request with + | None -> Dream.log "User does not exists" |> Lwt.return + | Some user_id -> + (* TODO catch marshal failure *) + + (* send user island state *) + let state = + match User.get_state user_id with + | Error _e -> assert false + | Ok state -> state + in + let* () = Dream.send ~text_or_binary:`Text client (Network.marshal state) in + + let rec loop () = + match%lwt Dream.receive client with + | None -> Dream.close_websocket client + | Some s -> + let action : State.action = Network.unmarshal s in + let state_res = State.handle_action state action in + let* () = Dream.send client (Network.marshal state_res) in + loop () + in + loop () diff --git a/src/ws_client.ml b/src/ws_client.ml new file mode 100644 index 0000000..ab612ef --- /dev/null +++ b/src/ws_client.ml @@ -0,0 +1,43 @@ +open Brr +open Brr_io +open Shared + +let ws = + Format.printf "create websocket@\n"; + let ws_url = + (* TODO fix hostname *) + Jstr.of_string "ws://localhost:3696/island/ws" + in + Websocket.create ws_url + +let ws_target = Websocket.as_target ws + +let on_event ws_event log_msg f = + let (_ : Ev.listener) = + Ev.listen ws_event + (fun ev -> + Format.printf "%s@\n" log_msg; + f ev ) + ws_target + in + () + +let to_server_msg ev = + Format.printf "to_server_msg@."; + let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in + let state_res : (State.t, string) result = Network.unmarshal data in + Format.printf "un-marshaled message from server yay ~ @\n"; + match state_res with + | Error e -> failwith (Format.sprintf "action resulted in error: %s" e) + | Ok state -> state + +let on_update_state_message f = + on_event Message.Ev.message "Websocket reveived message!" (fun ev -> + f (to_server_msg ev) ) + +let send msg = + Format.printf "send msg on websocket ~~ @\n"; + let s = Jstr.of_string (Network.marshal msg) in + Websocket.send_string ws s; + Format.printf "send action on websocket ~~ DONE @\n"; + () From 753a50bf859df96438d4331b8feae1ba7105d45c Mon Sep 17 00:00:00 2001 From: Swrup Date: Thu, 15 Dec 2022 19:59:42 +0100 Subject: [PATCH 22/81] clean map --- src/island_client.ml | 42 +++++++++++----------------------------- src/map.ml | 46 +++++++++++++++++++++++++++++++------------- src/ws.ml | 3 ++- 3 files changed, 46 insertions(+), 45 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 2fcc70f..8142813 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -51,16 +51,11 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") -let map = - (* TODO receive map / state *) - (* dummy map; should ask for map to server *) - ref (Map.init ()) - let draw_map = 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 - fun () -> - let player_x, player_y = !Map.player_pos in + fun map -> + let player_x, player_y = map.Map.player_pos in for x = 0 to tiles_per_w - 1 do let map_x = x + player_x - (tiles_per_w / 2) in let tile_x = float_of_int ((x * tile_size) + orig_x) in @@ -68,7 +63,7 @@ let draw_map = let map_y = y + player_y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = - match Map.get_tile_kind ~x:map_x ~y:map_y !map with + match Map.get_tile_kind ~x:map_x ~y:map_y map with | Grass -> grass | Water -> water | Black -> water @@ -77,7 +72,7 @@ let draw_map = done done; let papy = - match !Map.player_dir with + match map.Map.player_dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -85,23 +80,8 @@ let draw_map = in C2d.draw_image context papy ~x:papy_x ~y:papy_y -let move dir = - if !Map.player_dir = dir then begin - let x, y = !Map.player_pos in - let x, y = - match dir with - | Left -> (x - 1, y) - | Right -> (x + 1, y) - | Down -> (x, y + 1) - | Up -> (x, y - 1) - in - match Map.get_tile_kind ~x ~y !map with - | Black | Water -> () - | Grass -> Map.player_pos := (x, y) - end - else Map.player_dir := dir - -let kb_handler ev = +let kb_handler state ev = + let move = Map.move !state.State.map in match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with | "KeyW" | "ArrowUp" -> move Up | "KeyA" | "ArrowLeft" -> move Left @@ -111,7 +91,7 @@ let kb_handler ev = | _s -> () let rec game_loop state _timestamp = - draw_map (); + draw_map !state.State.map; let new_state = state in G.request_animation_frame (game_loop new_state) @@ -122,10 +102,6 @@ let () = 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); - (* bind keys *) - let _e : Ev.listener = - Ev.listen Ev.keydown kb_handler (Window.as_target G.window) - in (* get state from server*) let initial_state_fut = Ev.next Message.Ev.message Ws_client.ws_target in @@ -133,6 +109,10 @@ let () = Fut.await initial_state_fut (fun msg -> let initial_state = Ws_client.to_server_msg msg in let state_ref = ref initial_state in + (* bind keys *) + let _e : Ev.listener = + Ev.listen Ev.keydown (kb_handler state_ref) (Window.as_target G.window) + in (* attach message listener to update state *) Ws_client.on_update_state_message (fun received -> state_ref := received; diff --git a/src/map.ml b/src/map.ml index ffcc2b6..36160e9 100644 --- a/src/map.ml +++ b/src/map.ml @@ -9,19 +9,39 @@ type background = | Water | Black -type t = background array array - -let width = 1000 - -let height = 1000 - -let player_pos = ref (20, 3) - -let player_dir = ref Down +type t = + { tiles : background array array + ; mutable player_pos : int * int + ; mutable player_dir : dir + ; width : int + ; height : int + } let init () = - Array.init width (fun _x -> - Array.init height (fun _y -> - if Random.int 1000 <= 42 then Water else Grass ) ) + let width = 1000 in + let height = 1000 in + let tiles = + Array.init width (fun _x -> + Array.init height (fun _y -> + if Random.int 1000 <= 42 then Water else Grass ) ) + in + { tiles; player_pos = (20, 3); player_dir = Down; width; height } -let get_tile_kind ~x ~y map = try map.(x).(y) with Invalid_argument _ -> Black +let get_tile_kind ~x ~y map = + try map.tiles.(x).(y) with Invalid_argument _ -> Black + +let move map dir = + if map.player_dir = dir then begin + let x, y = map.player_pos in + let x, y = + match 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 -> () + | Grass -> map.player_pos <- (x, y) + end + else map.player_dir <- dir diff --git a/src/ws.ml b/src/ws.ml index b551e89..d4a377c 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -6,7 +6,7 @@ let handle_client request client = | None -> Dream.log "User does not exists" |> Lwt.return | Some user_id -> (* TODO catch marshal failure *) - + Dream.log " SEND USER ISLAND"; (* send user island state *) let state = match User.get_state user_id with @@ -14,6 +14,7 @@ let handle_client request client = | Ok state -> state in let* () = Dream.send ~text_or_binary:`Text client (Network.marshal state) in + Dream.log " SENDED USER ISLAND"; let rec loop () = match%lwt Dream.receive client with From 86489c5394f02041ac73156c4d6cc03d24616819 Mon Sep 17 00:00:00 2001 From: Swrup Date: Mon, 26 Dec 2022 01:12:16 +0100 Subject: [PATCH 23/81] rm common.ml --- src/common.ml | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 src/common.ml diff --git a/src/common.ml b/src/common.ml deleted file mode 100644 index e69de29..0000000 From caffcbb527ffd6aff9aeafac23b34ddc8f23ff62 Mon Sep 17 00:00:00 2001 From: Swrup Date: Mon, 26 Dec 2022 02:06:13 +0100 Subject: [PATCH 24/81] do not send whole state on action --- src/island_client.ml | 92 ++++++++++++++++++++++++++++++-------------- src/map.ml | 25 ++++++------ src/network.ml | 6 +++ src/state.ml | 36 ++++++++++++----- src/ws.ml | 34 +++++++++++----- src/ws_client.ml | 8 ++-- 6 files changed, 135 insertions(+), 66 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 8142813..37aaccd 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -51,11 +51,12 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") -let draw_map = +let draw = 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 - fun map -> - let player_x, player_y = map.Map.player_pos in + fun state -> + let open State in + let player_x, player_y, player_dir = state.player_pos in for x = 0 to tiles_per_w - 1 do let map_x = x + player_x - (tiles_per_w / 2) in let tile_x = float_of_int ((x * tile_size) + orig_x) in @@ -63,7 +64,7 @@ let draw_map = let map_y = y + player_y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = - match Map.get_tile_kind ~x:map_x ~y:map_y map with + match Map.get_tile_kind ~x:map_x ~y:map_y state.map with | Grass -> grass | Water -> water | Black -> water @@ -72,7 +73,7 @@ let draw_map = done done; let papy = - match map.Map.player_dir with + match player_dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -80,19 +81,43 @@ let draw_map = in C2d.draw_image context papy ~x:papy_x ~y:papy_y -let kb_handler state ev = - let move = Map.move !state.State.map in - match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> move Up - | "KeyA" | "ArrowLeft" -> move Left - | "KeyS" | "ArrowDown" -> move Down - | "KeyD" | "ArrowRight" -> move Right - | "KeyM" -> Ws_client.send State.Meditate - | _s -> () +(* 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 action = + match State.check_action state action with + | Error e -> Format.printf "Invalid action: %s@\n" e + | Ok _ -> Ws_client.send (Network.Action_msg action) + +let kb_handler ev = + let open State in + let act = + match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + | "KeyW" | "ArrowUp" -> Move Up + | "KeyA" | "ArrowLeft" -> Move Left + | "KeyS" | "ArrowDown" -> Move Down + | "KeyD" | "ArrowRight" -> Move Right + | "KeyM" -> Meditate + | _s -> Do_nothing + in + Queue.add act input_queue let rec game_loop state _timestamp = - draw_map !state.State.map; - let new_state = state in + draw state; + let new_state = + (* TODO repesct order of action *) + (* apply to_apply_queue *) + let state = Queue.fold State.perform_action state to_apply_queue in + (* TODO can this bug because of concurrency? *) + Queue.clear to_apply_queue; + (* send input action to server *) + Queue.iter (send_action state) input_queue; + Queue.clear input_queue; + state + in G.request_animation_frame (game_loop new_state) let () = @@ -106,16 +131,27 @@ let () = (* 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 *) + Format.printf "received Full_state message@\n" + | Update_result res -> ( + match res with + | Error e -> Format.printf "received update result error: %s" e + | Ok action' -> Queue.add action' to_apply_queue ) ); + (* bind keys *) + let _e : Ev.listener = + Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + in + Fut.await initial_state_fut (fun msg -> - let initial_state = Ws_client.to_server_msg msg in - let state_ref = ref initial_state in - (* bind keys *) - let _e : Ev.listener = - Ev.listen Ev.keydown (kb_handler state_ref) (Window.as_target G.window) - in - (* attach message listener to update state *) - Ws_client.on_update_state_message (fun received -> - state_ref := received; - Format.printf "YOUR MANA IS: %d@." !state_ref.mana ); - (* start game *) - G.request_animation_frame (game_loop state_ref) ) + match Ws_client.to_server_msg msg with + | Update_result _res_msg -> + failwith + "invalid first server message received; received Update expected \ + Full_state" + | Full_state state -> + (* start game *) + G.request_animation_frame (game_loop state) ) diff --git a/src/map.ml b/src/map.ml index 36160e9..4860914 100644 --- a/src/map.ml +++ b/src/map.ml @@ -9,10 +9,10 @@ type background = | Water | Black +type position = int * int * dir + type t = { tiles : background array array - ; mutable player_pos : int * int - ; mutable player_dir : dir ; width : int ; height : int } @@ -25,23 +25,22 @@ let init () = Array.init height (fun _y -> if Random.int 1000 <= 42 then Water else Grass ) ) in - { tiles; player_pos = (20, 3); player_dir = Down; width; height } + { tiles; width; height } let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black -let move map dir = - if map.player_dir = dir then begin - let x, y = map.player_pos in - let x, y = +let check_move map entity_pos dir = + let x, y, current_dir = entity_pos in + let x, y = + if current_dir <> dir then (x, y) + else match 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 -> () - | Grass -> map.player_pos <- (x, y) - end - else map.player_dir <- dir + in + match get_tile_kind ~x ~y map with + | Black | Water -> Error "invalid terrain" + | Grass -> Ok (x, y, dir) diff --git a/src/network.ml b/src/network.ml index aecc640..729b569 100644 --- a/src/network.ml +++ b/src/network.ml @@ -3,3 +3,9 @@ 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', string) result + +type client_message = Action_msg of State.action diff --git a/src/state.ml b/src/state.ml index fa434c8..69f86f6 100644 --- a/src/state.ml +++ b/src/state.ml @@ -1,17 +1,33 @@ type t = { map : Map.t - ; mutable mana : int + ; mana : int + ; player_pos : Map.position } -let init () = { map = Map.init (); mana = 0 } +let init () = { map = Map.init (); mana = 0; player_pos = (20, 3, Down) } -type action = Meditate +type action = + | Meditate + (* TODO some action do not needs to be checked by server *) + | Move of Map.dir + | Do_nothing -(* TODO do not send whole state *) -let handle_action state action = - match action with +(* type for result of action send to the client by the server *) +type action' = + | Add_mana of int + | Set_player_position of Map.position + | Look_at_the_sky + +let check_action state = function | Meditate -> - if state.mana < 99 then ( - state.mana <- succ state.mana; - Ok state ) - else Error "maximum mana" + 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) ) + | Do_nothing -> Ok Look_at_the_sky + +let perform_action state = function + | Add_mana n -> { state with mana = state.mana + n } + | Set_player_position player_pos -> { state with player_pos } + | Look_at_the_sky -> state diff --git a/src/ws.ml b/src/ws.ml index d4a377c..78f7a29 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -6,23 +6,37 @@ let handle_client request client = | None -> Dream.log "User does not exists" |> Lwt.return | Some user_id -> (* TODO catch marshal failure *) - Dream.log " SEND USER ISLAND"; - (* send user island state *) let state = match User.get_state user_id with | Error _e -> assert false | Ok state -> state in - let* () = Dream.send ~text_or_binary:`Text client (Network.marshal state) in - Dream.log " SENDED USER ISLAND"; + let state_msg = Network.Full_state state in - let rec loop () = + (* send user island state *) + let* () = + Dream.send ~text_or_binary:`Text client (Network.marshal state_msg) + in + + let rec loop state = match%lwt Dream.receive client with | None -> Dream.close_websocket client | Some s -> - let action : State.action = Network.unmarshal s in - let state_res = State.handle_action state action in - let* () = Dream.send client (Network.marshal state_res) in - loop () + let (Network.Action_msg action : Network.client_message) = + Network.unmarshal s + in + let res, state = + match State.check_action state action with + | Error _e as error -> (error, state) + | Ok action' -> + (* update server state *) + let state = State.perform_action state action' in + User.set_state user_id state; + (Ok action', state) + in + let* () = + Dream.send client (Network.marshal (Network.Update_result res)) + in + loop state in - loop () + loop state diff --git a/src/ws_client.ml b/src/ws_client.ml index ab612ef..8f7102b 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -25,17 +25,15 @@ let on_event ws_event log_msg f = let to_server_msg ev = Format.printf "to_server_msg@."; let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in - let state_res : (State.t, string) result = Network.unmarshal data in + let server_msg : Network.server_message = Network.unmarshal data in Format.printf "un-marshaled message from server yay ~ @\n"; - match state_res with - | Error e -> failwith (Format.sprintf "action resulted in error: %s" e) - | Ok state -> state + server_msg let on_update_state_message f = on_event Message.Ev.message "Websocket reveived message!" (fun ev -> f (to_server_msg ev) ) -let send msg = +let send (msg : Network.client_message) = Format.printf "send msg on websocket ~~ @\n"; let s = Jstr.of_string (Network.marshal msg) in Websocket.send_string ws s; From cdd46850bfa1f232dadfb6d9c478174834f6d039 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 3 Jan 2023 23:53:05 +0100 Subject: [PATCH 25/81] stop using a hardcoded websocket address in ws_client --- src/ws_client.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/ws_client.ml b/src/ws_client.ml index 8f7102b..41649a0 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -5,8 +5,14 @@ open Shared let ws = Format.printf "create websocket@\n"; let ws_url = - (* TODO fix hostname *) - Jstr.of_string "ws://localhost:3696/island/ws" + 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 + Jstr.of_string @@ Format.sprintf "ws://%s%s/island/ws" host port in Websocket.create ws_url From b074eac54f88876df8a1615e54c0f0d70242ed29 Mon Sep 17 00:00:00 2001 From: Swrup Date: Sat, 7 Jan 2023 23:15:03 +0100 Subject: [PATCH 26/81] add auto_state_update client & server --- src/island_client.ml | 15 +++++++++++++-- src/pellest.ml | 22 ++++++++++++++++++++++ src/state.ml | 9 +++++++++ src/ws.ml | 17 +++++++++++------ 4 files changed, 55 insertions(+), 8 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 37aaccd..5e430e0 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -105,7 +105,9 @@ let kb_handler ev = in Queue.add act input_queue -let rec game_loop state _timestamp = +let last_auto_state_update = ref 0. + +let rec game_loop state timestamp = draw state; let new_state = (* TODO repesct order of action *) @@ -116,7 +118,16 @@ let rec game_loop state _timestamp = (* send input action to server *) Queue.iter (send_action state) input_queue; Queue.clear input_queue; - state + + (* auto_update *) + if + timestamp -. !last_auto_state_update + >= float_of_int @@ (State.auto_state_update_rate * 1000) + then ( + Format.printf "MANA: %d@." state.mana; + last_auto_state_update := timestamp; + State.auto_update state ) + else state in G.request_animation_frame (game_loop new_state) diff --git a/src/pellest.ml b/src/pellest.ml index 92b30e6..7356070 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -1,3 +1,25 @@ +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 update_offline_user_state () = + (* TODO *) + () + +let update_online_user_state () = + Hashtbl.filter_map_inplace + (fun _user_id state -> Some (Shared.State.auto_update state)) + User.state_ht + +let () = + regularly_call_fun update_online_user_state + (float_of_int Shared.State.auto_state_update_rate); + regularly_call_fun update_offline_user_state + (float_of_int Shared.State.auto_state_update_rate) + let () = let logger = if App.log then Dream.logger else Fun.id in Dream.run ~port:App.port @@ logger @@ Dream.memory_sessions diff --git a/src/state.ml b/src/state.ml index 69f86f6..4b3564d 100644 --- a/src/state.ml +++ b/src/state.ml @@ -31,3 +31,12 @@ let perform_action state = function | Add_mana n -> { state with mana = state.mana + n } | Set_player_position player_pos -> { state with player_pos } | Look_at_the_sky -> state + +let auto_update state = + match check_action state Meditate with + | Error _e -> state + | Ok action' -> + let state = perform_action state action' in + state + +let auto_state_update_rate = 5 (* in secs *) diff --git a/src/ws.ml b/src/ws.ml index 78f7a29..b94646c 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -18,25 +18,30 @@ let handle_client request client = Dream.send ~text_or_binary:`Text client (Network.marshal state_msg) in - let rec loop state = + let rec loop () = match%lwt Dream.receive client with | None -> Dream.close_websocket client | Some s -> + let state = + match User.get_state user_id with + | Error _e -> assert false + | Ok state -> state + in let (Network.Action_msg action : Network.client_message) = Network.unmarshal s in - let res, state = + let res = match State.check_action state action with - | Error _e as error -> (error, state) + | Error _e as error -> error | Ok action' -> (* update server state *) let state = State.perform_action state action' in User.set_state user_id state; - (Ok action', state) + Ok action' in let* () = Dream.send client (Network.marshal (Network.Update_result res)) in - loop state + loop () in - loop state + loop () From 51129ecb2ed2f59e8aa54fa8add55cd5e36cab40 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Sun, 8 Jan 2023 01:02:20 +0100 Subject: [PATCH 27/81] add mana icon --- src/content/assets/img/mana.png | Bin 0 -> 3785 bytes src/content/assets/img/mana.xcf | Bin 0 -> 5950 bytes 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 src/content/assets/img/mana.png create mode 100644 src/content/assets/img/mana.xcf diff --git a/src/content/assets/img/mana.png b/src/content/assets/img/mana.png new file mode 100644 index 0000000000000000000000000000000000000000..34214c0f8cf510c746ea51bbdbd3626436074908 GIT binary patch literal 3785 zcmeAS@N?(olHy`uVBq!ia0y~yV9)|#4mJh`hNFj1Ml&!lHfK6J2Y5O=D-;yvr)B1( zGB9XNtet4zl5wGTEYC0g6|+)>_Tj^M!wwiHfFPUsLwM zgY%EBYVO{=j&EI)!Vl(0uO2OVp`?0mx=7TKiiaQV&h38w;a+XSg;j=UUwJdl%A0+& z#OsWB*wG8xOdQMt0@G)vp79J~+xNB9|87V*=e(!)zo+xAa_wehoM>^9=d#*8g?Tr( z@Sgj9Brt4Z=%eCCoRjrD{+uX1`q=zj>U7q5lBUHsD<5fWjChy0v_10Zm5$||$*YzH z@0;*F;_05Fk*iH3p3nQ!I&smyO=n7@l0A|Iy(cI*IWmV{NlF*PO)kD_-V#vJA&trnk!;*T`G@{bu2?V-Byn z9-q&+dHxdf-BE8iByO?kt=m0o6MM`%24(-YoKx#WmZ(ngI`CVvHkeUjA1m9nJv&R! z75-v)k`Xpj`oRN%j_I1!cc0&VcyH(5+m~nF=NI)YYE+)OlZkc5JVH>& z=jNiE1KY*_SN~_U=h%=KEy5D4q_K91>dxK8^XI)g)zk5~eU;?8X_IO+6)u*ZTxV7K z=t$=YBhPrIjXgE_|E-Td3|yrc@F1{rg^P%iR*=>rDK8bprCu}FTwx9hdfgbszb4H3 zK;-)O_7%tEtGC&|<9CSn+h>3A{_Hso=`L#@PW4eva(1H*TQS;e7`4t{ndB&+q-^--vSkU@(jPvwe+kwnjCD@bMIP-JZJpZ zcZXl>3v<(*=_)vNil^r3BdWYXOnYb9a%Y5{ij)lB&U1Kf*4^7_$u@7;&1PHo_2tFtS9^3qaFb@fbXYDr(#$+EO% zcI08XzLj6Ew0|s{!`FIt+k{sh!pDzqmv8yc`Q?M-jK7>Y6}oHJzo>Pc-M8rL;!D4e z-3fnKtFl=nb)!%4GQ~u%fLTEzOFcqUPZ_0Nnz5np3Y)fi^4jQShi6^WYX9pn&)-8> zUERFiXMMj^td|*hg(5GfhiP)W0nwRYFeAuWIkl8M9xD|NPtk z|FK2!qc?9})q3*1Z{6MgJ0M!xQf8Z-ue$T>zALu^Th=QTNldxolfd^?xmttqY(nsY z{PVMew#68W9Sc@9>h*|jZ40Q`vTe(rt@8Zg;rI9dUG4w>r^)7ze|}yqcaneSTq>WD zyVflCwTbNNt;*l`o$E=Q+UeuwxuJC}t4=?|4>1$3z1#Q4%$^(}Ib}-flL<4M=c-rD zOEb58Vt)DlxA^+XqZhx)&J@;xdFy0eT7o;9ilad1DIKI`uJCl2njm^GSKHAvm)zx3ma#Ba|TZQFjmc=xP5 zCT5PZZPapp2Yrvtdh*-0yqs~ZFYAYvahBHFG^I&FLe|1ok_%N`*{=xg^bk6Gvo-R} znY1QO?av#H48Mplo;=99Tjac)k9E6TM7DO`I{QbTZW_)M){oyOy{B6C4*Rmqvsd~u za<#vQ?g&4vk-DxeO>IMqW5i7dUWso3!bU06(k7iP7E+nWs4249Mu+)m^1X9YBj(*$ z&$562^molg>km{Fl>VG__L*{3{tkcU6P*#4Z(Zhi&-`-QX13=?Hnynk@INBjvY_;m zQ1rS5}?Z)HMqi58(Z?kOVe&su9Ue>~ZuT_6GR3Ci$^m|3wuj(m= zJbT0W+D-Sa&Bzsgr)|VFGi*vmWpR<8Oe}|-keAoQv}7mIvOEKcJud|s-4drwQS4Pz zojrLycLPn{pO}2IRTB;XouDEgNj!d0%fJ|hRreoA8pA*bB2EtJ>3E!Tve1CM( z%+}9Kb9vcz%SWr%`>|KaXXIY3mhS$Y@Q$_B_7;~4YodxLhxaLkqN!7SomgKVsGYre zpW3#$&TBn%#MCz&(D7Yzra7nc=A-9aI!vx7jI<91Oo{&XwB>J}_j|(!aRuuae-CX7 zKfNKOA;qBGdr4R3w%LXkCxl(MR1Xs6IkU;&V8W3AgBijrIbRz~8bwPmY{ zsL0aP9Ust0Ug-x4+#st|tiE_nEyq&zVS5+4l zZCq1wDko8Oww9{)@4vHNJ}{pAa4JVP$L!TT6J&H9)}Cw2Qw{L-@(mF)Yi~N`u+cP4 zIbh~?_XB;$Y`>_S-B{3Lkkz3m(EZWffkn_WbMB+a%gar**Y4P3BiGSzCZuI5hf%t& zWVflHf9ai7Cmz|%tQXuQsFA=L5^D4k%BGgQ4)K;Fi^WmStqF7ii&OFm|*_4?xEvu!xwO^99e z%%40HSYK?)m|!)Hcax(q`>~*^^pjoIw<~$?;l%m3zOR{FcIUY5arNoUr8g3{nP2(9p}9&h z)N7N@8M|4f-fL91m2GL6ujwe;D|?lBS>eSclW!%~@weOBmA0)suVbgOv-nqR`W@D7 z**DfbyzF9U(&e9Ye_7#uwRPW5=Koh^>$6g5y|PqX zx8GD|Pv|MXBYzu>WFJJDiyqh8wI%z8=k`y^?skE7{~Gkx9l2`0^6$TgFB;cp-uZ0G zvnK5O4BLb<@k`Bjwz~!fhUk{5MDHotD6%wp=BddG_!5^XI7{p+@ncL@_ndK{tnpp> zlh1tizvSM`srujbXH{U`9`*W9%qMJ@oqu?Gd&HuJ#ja189*cfRd+_4Lq_^KBzpsA0 z@LI69Z2B{WRKuOBhSh3~y!V;Hte$z^Z)rPt_R#d87sa*mO{@CeF|Ctbw>#&lSX8hH zll2+-3%?q!?pO0(n3I1}ujkpaaDh5cXrOK+tcI%c>c&n z)tY+Wf4@`qd(FP0y3UHTs^)C@33-)&e;n;Dck%ghPa^!h#@7>& zGUlr}DEi;?jDmdQJ*H!)r}OWr-Tm~ak ze|U%6N2yo3Q+Dn;zqRgX$pyuC&&wXH{GYcu_tM8lCQ{p9cZNT!Y5XC%{7+AK@d^3- z?^kZ`DgR&3VE0h?U*D7Y7SG>*SJr>qF?my(Yia^-WTWV@J2w_Hp88!LGfPu9z9`GV z#ASY?&<-`e_fS3P&? zgj#cy8(XOhYp=rLkZJ#Q9D+~p^84&{L}sS&%aTcZWp|ul-)DL2GwVTr$%>=v_g{TF zpY<2Zw=zqKgOgT=elY+3Vbi*bI5V5mDXoEP1H2E)#dAfw*?s+`G(jPw;#}39>7UaI z>a5G^jvf)8^Qr56Me2u}^ACJkzFl2%&lBNuKP8?|J}fxjs37lHW{=EzH#e7!by zc^{{3a269(?R+Cs^>~A+-mk{hr5~cD);FC0*>=C+``v>7>l^hF;+ga{YYzGUXgRn1 z)+eUtmQ(xRJ*?T9B&&UG^^#f7UYK`;Dtau7-DIB^b8+YP#_K+NmVU5|UiVW!?&3d# z!hi7&{~2`VY<${de9rP2d&oZj0+$U>d!Dnrc0R;$Vn*AcdB+-$&6~Kru;NKR8IGcYt{U|?X-f?^PR8Uq7^AOiyfBO?O?gD?XF1Bdf81_lsjU|aehu_iYAvvT6%JRPJWSs2AI+55uFaSeCO-(M1BrMW~3SbD5 zt|%@@OwPft%)={+QgsV*67xVRK;Z_W*`Q(fpMilv5yZA{00}d2fY_kG zXJBC9gt9>rN=R%OBsLckTLFp9jl||bV)G)g`9X0DG8~H8p>iPeRiSKO|L1?de*FfE{r&s< zFVml&zkmJx_50s{ra%1ufBpLX^Vjb`%)c4`eEj|A_pd*{|NQ>*>-+C--@dT_|NiIy z|KI=r{r>)&?GMv$=0E>`GyP%w`RnhmzrX)~WCc0&KhwXzzkd8>`t$!U?;pnBKY#xI z{pZi$H!T1E|7QOG{rCT0fB*dX`|mH)AI87`{`_YC^X2cK-(XAr{QdKf<^TV`%>O_B z`}^bX@4x^4{{8p&&+lKqng1~U{rme5*g}XoKmYyy^Xt!_zs&#s|K<9_3^L%)@4pZ^ z#@~#;82|kH`;X}_*mWTLe*b3v!}R<2&p$uEeqsOr^UrUPpZ+laW%|PmQuLSQ57TeP zpMQV-{lohI*}vbQ!20 z0fjv4-#`EUfUNxT=PxMGe*OIQ^XEU7|3ChM!~fS`ravtI82^Hz;xE&`FMt1mLgm-* zpFe;6W%>W+@9$qAgFtqHJ^lC3-+wHBfByRmR>k!5->O_f(aCU|5*Ni0I7fk<*%PVe*OB!{Gah3 z6FBPr{r$!CkMZySf2{vm{(b|+^v_?vfBpQ%^8e%C-@ktS`3s7iKmY#z`OEg7`R~7f zf0;q?@$2U|=KsI{{r&}tnxB7vgTsaml(0bZpz!(44078q#y|f-kp~KyzyDbN|NI9s z@Xs&i-@kwU`1#{2Ge`tv&2Q#EKmYy*dHo;Lf9AiRK_U1X6gWSBe*eMp|JR>iAiJ3U z{QdjyAM@Y;f0+Kh|NZCBk3WC^{QUas*YEG&etiGS^8XVkyng)x#oq6~fB&)n{rBT9 z)9-ITKr#0H=eMt4K}vr91epd7%D?~E{(kuR3zQ8&qQ8Is`1S=9T)%((`t=(WBcSm3 z_wNt$-@m_q{$~F5_s_3COuzp8{Qlz~>;IpBe*OIY^YUm z57Y1OKY#!D{q5iX{~wtD|N8zD;`U#^{`~s$?>Ez*kH0}K_zSY(_n%+C|8e~P`R~V1 zkUN-u|NQg&=kGtie>4C3^844XAHTl;{Q2w0_wP*q|1$jl!uk+IDdZo@$LJMpFe+m`~8RMKN|zf|9{`UGyP=x{_n?kmY-jL zeE;?R`;Q;r|9t(!^q+%)`Tw_nKfxM*eE-J$1EloF@1Nhl|Mwf_TuK$0(|M|`FUxeZR2f_c`3|#-;f};BCr}yt(zkc=d_1ib^KmGV2 z`v2>nAKyN|d;R?BqlfpI?)|uX|KZb@Z$5k%{QvCFk8dB}ynOQD-kqD*uU)x(>C)xP zS8v^W`10*nzW-1D{P_I-#gqGYZeG7~`Qn9hXHTCxb@J5dbC+&Cdi{mx|D!+OKE8hX z;LeR}S1(_@aQ@tx(sPN_x_III+0&;^ z96xsW(1HDX_wGA<`pT0}9RKhA{`&U$!`nBmUb%en;`wuD&zwGa;@FWx2lnpSwR8K9 zoqLYn`M~!7&hM{ppFOw*as|j4XF!UMA3c0%|K43Ywr$?9e#5#gSKqPxzxDh3`{(y> zUcG$r(&a0c&!0JS>ePu7$BrC6xPQ;CZCf_1+jsuJ%B}a`F#Z4V`}@b|_iunab@}$Q z$Jfp+|zFAcbd6pSkep-RlQeu3W!y`Ra`uSI(V2vUmHYbt@Oo zpFLytqRp3{e0}}s+Qsu{&zw1R^3?eox31s3^X9{?>v!+nxpC#pk=v0)?$h1d4c`C(hrv|K#=O??0G+G5);u z{p;%ow{D)_yK?T7p4OW3;>s!4&mP{tci+DK2M(RMbnC&>w_m>h{K@od|IZ)a-aoo| z?ZUp5vnO^mRutzJcU?PmV9&1IyZ7upaO~2ZhtJ-91r=R?e*gUW?ft`Rm(J~7F|)6& zrZg`ttMpp)!mDy4sDz_v8|>kJuxCG{?f6XTQ+Ulym`y^ zy(g|cc=G(+=WpLZ<;d5M&u*VTvVFz$uKM!a_%MHGzpKZ0Zdkv5-G+^ucO1HK_tBH* zZ$Euy`u6hc$Cvl7oZPi$c29jtZgRA*i?Q1EV>{L}t!7+%YyIY3$FAIc@aW0Qw;w)! zc=z)D#bdiy&+KfdDNT*=cQI5~cyMax+LcVp8yKZmu3Ecky7?%%%q;K{RRPw!tj zy6?o^8FgJNmsSPYnW`&tJUhK>&C(@{7cX75V)e#dC$8MMe&x#5oA>TrKe_YN%X=H^ z*IYQaB+|w}ONrydmHq1%FI+Hx{(=QdR<7T1{+vB&RMg4&5BLC4jwshVE^82`_3(&ws&`5#-u&_x_pdvROJ}{ zzdgHc>Fnv#rc9Z>W%t^7i&n1PuwmWmrSncdJ6v8?mJ||Sm=|QBuPVyG@c+%FL#yXZ zo!H+yVg9PQQ>MPLGd|j`VkTwlPUs_JkuJd~5sF|>Aa_3;mlj7dmHOiW0OkBbfs@N##sGB?yz<6?No zCm^qGU}f**?&TX492y=T78)Gn=jG<)V4@JUow#lXzY!O_{(-OJmD$&1nb zhohZ^iGik^4nMWjBz`?=8 z!1bT;&->p$z}3X7moHwys)<+7YU0VGhxhK@y?5vSgQqWEzyAiRCVqbV@aDyn2X}AZ zxPJBWrHdCYUAlr?O}u;g*h@x z)~#K&V&&#*&}!n@{hL=Ht^wCJ`}XeMxntXw%^TLPS+!!>l0}Qa)x^!;-#Jh*ZB!nrf2P8>gT3grIX zyS8uLylMT~)vH!4TeNWg(%CZ>?78{!|L<>aAKkig9#n@NJ9_2f!F^Dx*RNf@V(H>V z^XJZ)Ic@6fRYxH8#Fg`)O7rNELx&IT*|l@q*3BC?tXaKs+0sP|=FOcoed^>%)8}ux z^!V%Rhu1EgISH*?ckkT3ZTohZUlz=rJ!9JBiT%C()0XT6)e{%bfc$)L|GquDc5DNM z-rChGS1f^AJgL98yS=?<#+nna9$r0r0umD-KQnD^VB*=ZcJ<0-OBT+bGi%1w$rJm! zJ6fBYTl*Fses=f5$)kr3?%%r`WaOp|>({Scvu5?mr3>cFoIYh@e@|z7OH*A+qZ7sxNhy5H5)c>+qP-VqFGZXP3Y_HY-_HssVFb2YF~Zt(uqS512=C1 z`DN9*t$X(G-?Meq+$sG%U9HUxwbkV%g#{&bi*KDfx_{5^?c26&-neefs+B8NZQ672 z$dN;PHZGjh-QLnzS5r}1RFIvSSv>LjnL~SaZr{3PwN>Rs`8k=XNy$0w*G}%=xorz5q9F-l`Ify$jvqg`ck9v#Ep=5DB?Wm|=}GZ1 z(MeTTj_=*RdE@%Et5+^xvUuVAxr;XJK5+2hzTF!abk$Xr6&GY@rp8Byg#?A?UpcmG z^M-Y6RxMw)WZ}Fyvu4g+v3b{?J-fE7oZ4JjT9}uanivxq;_vP0A93mEj*XC@UNCR= z%;{67%~`%-%jS(MXLVE+=4GWN#Ycq(`Z(L!TDe_2wtd~Imp0tGB1Uxvr)tJvlx+ z#Lvsw#!N?9gn{9~sqL$mf-RmhslTtQt);1& z6y}10FFGu!xX|8IHzAyzmErFDhetLnm_B(zZ&zn)YeRKKX;FT5W=djgSg?{p}ncLs=PQqCnF^x+|x!|Scrk?|Hmu)S59fI zD$GiX3~;s3;Hzh}V`yNQ2yXsfJa^{gvBO7?96WOTuV~@ ziwp8@-MDrclnaj@JaXdXnafvh-MM%7{=Hk*uAVxwef`q86Pg?9s>(}>@^iATU%qhm z^ogT~kDWYq@!FjS&tJWH|Ka`ncW<6Qx^wyHj`j1Vv{#fB7v|<RL=G5^chmIUS zd*#lP*B?QR8|Ghketi4#;nls%M>j6$ZvZ9Pw3LLir%oI>wExhl3%8!U`Sktg?>|g` z8UHcv@UAHMzi^OyVI(?7qyzkhsb z=i>I_l*G8`h$9F0?>TVd(*2iTe*R_t$N8V>-^)KgKR>^Baa(&%bYxh_fqgso9=&+) z<>y~a|G56M{(JfN*Y}^lKA&w%3k?d`y<^Y8Gq+xT{`K!4*MIJR@BaV$wx=lG*L(Z! z{l~99`~34SSeWVmhdJi!-Fg4>?>~?z&wq}8pMQP2zPdVO-fB*Z({GaI`?|-&`jDNp= zd$7GF@WA=!-~NEQ)BpJXv;X___vfp_Q=|4@e*NR`zyJSP{_+23`}ghduXh*bgdMu^ z_9y#40kFWIkCzt*9lQPR7yCcK|E&MM{r&Uh*2>spH{T-(+*}@c@CJ&&vatQv-y&3e zzOf{D+r>9OA!dC2`}^aSSpi$lJpb{R9c=H{zdzrf?6X^W_~F;zFp(cG4)s{i-F553 zFAkVDzTe+gqSLkd+-rzF#(zxzKmYst_3FF~ow|hwAAb4G`HvSgk^$=Ye>u|aC6?2@ z=KPxwkgfJPr+Qg7FnSc_$p&f0tb^Ka&VjQ_d+G5&u78an~wKi8&4>4=3UH7`5; z;@h9Upg|R`e@y?`|GoeFYD0;&7(-xOY1gJ}Z@&Ni%lGg9f7XADf8YLjcceQ?hk?P@ zD?ESto*Qp|{QWERkMZxz-(Q~}oSLB{#=v0j;E+%@W#_He-~asm%m0t@?~k9KpB|r= zVJ*hS@I%L|WZA{%pMNs_<^IR`_xqn8A0C0FI2gWzq>kTz_w6V1U)Fz2f4}|t`Q`PE zgYz=HbhsG4=y;V(-F@-V`>#KK|6%?6< Date: Sun, 8 Jan 2023 04:10:15 +0100 Subject: [PATCH 28/81] add topbar with mana, fix bug where newly created state was not stored in the hashtbl :angry:, clean code --- src/dune | 2 +- src/island.ml | 22 ++++++++++---- src/island_client.ml | 69 +++++++++++++++++++++++++------------------- src/log.ml | 9 ++++++ src/map.ml | 49 ++++++++++++++++++++++--------- src/pellest.ml | 4 +-- src/state.ml | 21 ++++++++++++-- src/time.ml | 27 +++++++++++++++++ src/user.ml | 5 +++- src/ws.ml | 37 ++++++++++++------------ src/ws_client.ml | 21 +++----------- 11 files changed, 177 insertions(+), 89 deletions(-) create mode 100644 src/log.ml create mode 100644 src/time.ml diff --git a/src/dune b/src/dune index c5a5f3a..db008b0 100644 --- a/src/dune +++ b/src/dune @@ -45,7 +45,7 @@ (library (name shared) - (modules map network state) + (modules log map network state time) (libraries)) (rule diff --git a/src/island.ml b/src/island.ml index eab4678..411d570 100644 --- a/src/island.ml +++ b/src/island.ml @@ -1,27 +1,39 @@ open Tyxml.Html open Syntax -let mk_img name = +let mk_img hidden name = + let a = [ a_id name ] in img ~src:(Format.sprintf "/assets/img/%s.png" name) ~alt:name - ~a:[ a_hidden (); a_id 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 + div ~a:[ a_class [ "centered" ] ] @@ [ mana_img; mana_lvl ] + in + let canvas = canvas ~a:[ a_id "canvas" ] [ txt "please update your browser or enable javascript" ] in - let images = - List.map mk_img + + let canvas_images = + List.map (mk_img true) [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] in - let page = div ~a:[ a_class [ "centered" ] ] @@ (canvas :: images) in + let page = + div ~a:[ a_class [ "centered" ] ] @@ (topbar :: canvas :: canvas_images) + in let js = script diff --git a/src/island_client.ml b/src/island_client.ml index 5e430e0..d75855d 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -12,7 +12,7 @@ end let get_el id = match Document.find_el_by_id G.document (Jstr.of_string id) with - | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) + | None -> Log.err "could not find element with id `%s`" id | Some el -> el let tile_size = 40 @@ -51,17 +51,16 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") -let draw = +let draw_canvas = 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 fun state -> let open State in - let player_x, player_y, player_dir = state.player_pos in for x = 0 to tiles_per_w - 1 do - let map_x = x + player_x - (tiles_per_w / 2) in + let map_x = x + state.player_pos.x - (tiles_per_w / 2) in let tile_x = float_of_int ((x * tile_size) + orig_x) in for y = 0 to tiles_per_h - 1 do - let map_y = y + player_y - (tiles_per_h / 2) in + let map_y = y + state.player_pos.y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = match Map.get_tile_kind ~x:map_x ~y:map_y state.map with @@ -73,7 +72,7 @@ let draw = done done; let papy = - match player_dir with + match state.player_pos.dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -81,6 +80,11 @@ let draw = in C2d.draw_image context papy ~x:papy_x ~y:papy_y +let draw_topbar state = + 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) + (* queue for action to be done *) let input_queue = Queue.create () @@ -89,8 +93,13 @@ let to_apply_queue : State.action' Queue.t = Queue.create () let send_action state action = match State.check_action state action with - | Error e -> Format.printf "Invalid action: %s@\n" e - | Ok _ -> Ws_client.send (Network.Action_msg action) + | Error e -> + (* TODO: display this in the window *) + Log.debug "invalid action: %s@\n" e + | Ok Look_at_the_sky -> () + | Ok _ -> + Log.debug "sending action %a to server@\n" State.pp_action action; + Ws_client.send (Network.Action_msg action) let kb_handler ev = let open State in @@ -105,31 +114,31 @@ let kb_handler ev = in Queue.add act input_queue -let last_auto_state_update = ref 0. +let render state = + draw_canvas state; + draw_topbar state -let rec game_loop state timestamp = - draw state; - let new_state = - (* TODO repesct order of action *) - (* apply to_apply_queue *) +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 + let state = + (* apply queue of actions *) let state = Queue.fold State.perform_action state to_apply_queue in - (* TODO can this bug because of concurrency? *) Queue.clear to_apply_queue; (* send input action to server *) Queue.iter (send_action state) input_queue; Queue.clear input_queue; - - (* auto_update *) - if - timestamp -. !last_auto_state_update - >= float_of_int @@ (State.auto_state_update_rate * 1000) - then ( - Format.printf "MANA: %d@." state.mana; - last_auto_state_update := timestamp; - State.auto_update state ) - else state + (* state auto update *) + if should_auto_update then State.auto_update state else state in - G.request_animation_frame (game_loop new_state) + G.request_animation_frame (game_loop state last_auto_update) let () = (* init canvas *) @@ -147,10 +156,10 @@ let () = match server_msg with | Full_state _state -> (* TODO reset state to received state *) - Format.printf "received Full_state message@\n" + Log.debug "received `Full_state` message@\n" | Update_result res -> ( match res with - | Error e -> Format.printf "received update result error: %s" e + | Error e -> Log.debug "received update result error: %s@\n" e | Ok action' -> Queue.add action' to_apply_queue ) ); (* bind keys *) let _e : Ev.listener = @@ -160,9 +169,9 @@ let () = Fut.await initial_state_fut (fun msg -> match Ws_client.to_server_msg msg with | Update_result _res_msg -> - failwith + Log.err "invalid first server message received; received Update expected \ Full_state" | Full_state state -> (* start game *) - G.request_animation_frame (game_loop state) ) + G.request_animation_frame (game_loop state 0.) ) diff --git a/src/log.ml b/src/log.ml new file mode 100644 index 0000000..12308c3 --- /dev/null +++ b/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 diff --git a/src/map.ml b/src/map.ml index 4860914..516d7a6 100644 --- a/src/map.ml +++ b/src/map.ml @@ -9,7 +9,30 @@ type background = | Water | Black -type position = int * int * dir +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" + 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 @@ -18,8 +41,8 @@ type t = } let init () = - let width = 1000 in - let height = 1000 in + let width = 100 in + let height = 90 in let tiles = Array.init width (fun _x -> Array.init height (fun _y -> @@ -30,17 +53,17 @@ let init () = let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black -let check_move map entity_pos dir = - let x, y, current_dir = entity_pos in - let x, y = - if current_dir <> dir then (x, y) - else - match dir with +let check_move map ({ x; y; dir } as pos) movement_dir = + if dir <> movement_dir then Ok { pos with dir = movement_dir } + else + 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 -> Error "invalid terrain" - | Grass -> Ok (x, y, dir) + 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 -> Ok { pos with x; y } diff --git a/src/pellest.ml b/src/pellest.ml index 7356070..97ce928 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -16,9 +16,9 @@ let update_online_user_state () = let () = regularly_call_fun update_online_user_state - (float_of_int Shared.State.auto_state_update_rate); + (Shared.Time.s_to_float Shared.State.auto_update_rate); regularly_call_fun update_offline_user_state - (float_of_int Shared.State.auto_state_update_rate) + (Shared.Time.s_to_float Shared.State.auto_update_rate) let () = let logger = if App.log then Dream.logger else Fun.id in diff --git a/src/state.ml b/src/state.ml index 4b3564d..7ef6b1d 100644 --- a/src/state.ml +++ b/src/state.ml @@ -4,7 +4,8 @@ type t = ; player_pos : Map.position } -let init () = { map = Map.init (); mana = 0; player_pos = (20, 3, Down) } +let init () = + { map = Map.init (); mana = 0; player_pos = { x = 0; y = 0; dir = Down } } type action = | Meditate @@ -18,6 +19,17 @@ type action' = | Set_player_position of Map.position | Look_at_the_sky +let pp_action fmt = function + | Meditate -> Format.pp_print_string fmt "Meditate" + | Move dir -> Format.fprintf fmt "Move %a" Map.pp_dir dir + | Do_nothing -> Format.pp_print_string fmt "Do_nothing" + +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 + | Look_at_the_sky -> Format.pp_print_string fmt "Look_at_the_sky" + let check_action state = function | Meditate -> if state.mana < 99 then Ok (Add_mana 1) else Error "maximum mana" @@ -39,4 +51,9 @@ let auto_update state = let state = perform_action state action' in state -let auto_state_update_rate = 5 (* in secs *) +let auto_update_rate = Time.mk_s 1 + +let pp fmt { mana; player_pos; map } = + let bg = Map.get_tile_kind ~x:player_pos.x ~y:player_pos.y map in + Format.fprintf fmt "mana = %d; player_pos = %a; %a" mana Map.pp_position + player_pos Map.pp_background bg diff --git a/src/time.ml b/src/time.ml new file mode 100644 index 0000000..c96655d --- /dev/null +++ b/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 ) diff --git a/src/user.ml b/src/user.ml index a3dfe83..e0e9517 100644 --- a/src/user.ml +++ b/src/user.ml @@ -233,4 +233,7 @@ 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 -> Ok (Shared.State.init ()) + | None -> + let state = Shared.State.init () in + Hashtbl.replace state_ht user_id state; + Ok state diff --git a/src/ws.ml b/src/ws.ml index b94646c..827aef9 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -1,40 +1,41 @@ 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 "user_id" request with | None -> Dream.log "User does not exists" |> Lwt.return | Some user_id -> - (* TODO catch marshal failure *) - let state = - match User.get_state user_id with - | Error _e -> assert false - | Ok state -> state - in - let state_msg = Network.Full_state state in - - (* send user island state *) + (* 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 state_msg) + Dream.send ~text_or_binary:`Text client + (Network.marshal (Network.Full_state state)) in let rec loop () = match%lwt Dream.receive client with - | None -> Dream.close_websocket client + | None -> + (* TODO: backup everything to database *) + Dream.close_websocket client | Some s -> - let state = - match User.get_state user_id with - | Error _e -> assert false - | Ok state -> state - in + 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 _e as error -> error + | Error msg as e -> + Dream.log "check_action error: %s" msg; + e | Ok action' -> - (* update server state *) + Dream.log "check_action ok: %a" State.pp_action' action'; let state = State.perform_action state action' in User.set_state user_id state; Ok action' diff --git a/src/ws_client.ml b/src/ws_client.ml index 41649a0..f34b86a 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -3,7 +3,6 @@ open Brr_io open Shared let ws = - Format.printf "create websocket@\n"; let ws_url = let location = Window.location G.window in let host = Uri.host location |> Jstr.to_string in @@ -18,30 +17,18 @@ let ws = let ws_target = Websocket.as_target ws -let on_event ws_event log_msg f = - let (_ : Ev.listener) = - Ev.listen ws_event - (fun ev -> - Format.printf "%s@\n" log_msg; - f ev ) - ws_target - in +let on_event ws_event f = + let (_ : Ev.listener) = Ev.listen ws_event f ws_target in () let to_server_msg ev = - Format.printf "to_server_msg@."; let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in let server_msg : Network.server_message = Network.unmarshal data in - Format.printf "un-marshaled message from server yay ~ @\n"; server_msg let on_update_state_message f = - on_event Message.Ev.message "Websocket reveived message!" (fun ev -> - f (to_server_msg ev) ) + on_event Message.Ev.message (fun ev -> f (to_server_msg ev)) let send (msg : Network.client_message) = - Format.printf "send msg on websocket ~~ @\n"; let s = Jstr.of_string (Network.marshal msg) in - Websocket.send_string ws s; - Format.printf "send action on websocket ~~ DONE @\n"; - () + Websocket.send_string ws s From f6ca37167640bde0f2a192e5b18473b2bed538a3 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Sun, 8 Jan 2023 04:22:28 +0100 Subject: [PATCH 29/81] do not call regularly_call_fun twice as second call will overwrite the first one... --- src/pellest.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/pellest.ml b/src/pellest.ml index 97ce928..9ee23fa 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -14,10 +14,12 @@ let update_online_user_state () = (fun _user_id state -> Some (Shared.State.auto_update state)) User.state_ht +let to_repeat () = + update_online_user_state (); + update_offline_user_state () + let () = - regularly_call_fun update_online_user_state - (Shared.Time.s_to_float Shared.State.auto_update_rate); - regularly_call_fun update_offline_user_state + regularly_call_fun to_repeat (Shared.Time.s_to_float Shared.State.auto_update_rate) let () = From 3f4c1b063e04eca850146c35f4241851dc68b6cb Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Mon, 9 Jan 2023 02:40:40 +0100 Subject: [PATCH 30/81] fix medidate key --- src/island_client.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index d75855d..43f02cd 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -103,14 +103,17 @@ let send_action state action = let kb_handler ev = let open State in + let ev = Ev.as_type ev in let act = - match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + match Ev.Keyboard.code ev |> Jstr.to_string with | "KeyW" | "ArrowUp" -> Move Up | "KeyA" | "ArrowLeft" -> Move Left | "KeyS" | "ArrowDown" -> Move Down | "KeyD" | "ArrowRight" -> Move Right - | "KeyM" -> Meditate - | _s -> Do_nothing + | _code -> ( + match Ev.Keyboard.key ev |> Jstr.to_string with + | "m" -> Meditate + | _key -> Do_nothing ) in Queue.add act input_queue From 078b679bc2603ed445a52eb2686be2c793ab7e59 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Mon, 9 Jan 2023 03:37:01 +0100 Subject: [PATCH 31/81] implement redirection when user should be logged in/logged out --- src/login.ml | 12 +++++++++--- src/logout.ml | 12 ++++++++++-- src/syntax.ml | 18 ++++++++++++++---- src/user.ml | 14 ++++++++++++-- 4 files changed, 45 insertions(+), 11 deletions(-) diff --git a/src/login.ml b/src/login.ml index 3316620..3993ba2 100644 --- a/src/login.ml +++ b/src/login.ml @@ -5,6 +5,13 @@ 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 login = let submit = button ~a:[ a_id "submit_login" ] [ txt "submit" ] in let login = @@ -13,8 +20,7 @@ let get request = let password = input ~a:[ a_id "password"; a_name "password"; a_input_type `Password ] () in - div - [ make_form request ~action:"/login" ~items:[ login; password; submit ] ] + div [ make_form request ~action ~items:[ login; password; submit ] ] in let text = div [ txt "login ~!" ] in let page = div [ text; login ] in @@ -32,5 +38,5 @@ let post request = in Dream.respond ~status:`See_Other ~headers:[ ("Location", url) ] - "Logged in: Happy geo-posting!" + "Logged in: Happy pellesting!" | _form -> Template.err (`Bad_Request, "invalid form") diff --git a/src/logout.ml b/src/logout.ml index 94a273d..9beaf53 100644 --- a/src/logout.ml +++ b/src/logout.ml @@ -4,5 +4,13 @@ let get request = 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 - Template.render ~title ~scripts:[] page + + 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!" diff --git a/src/syntax.ml b/src/syntax.ml index 74f5f57..8b3cc40 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -1,6 +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 ( let** ) o f = match o with Error e -> Template.err e | Ok v -> f v +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 diff --git a/src/user.ml b/src/user.ml index e0e9517..56aa4ba 100644 --- a/src/user.ml +++ b/src/user.ml @@ -218,10 +218,20 @@ let public_profile user_id = let assert_logged request = if is_logged_in request then Ok () - else Error (`Forbidden, "you should be logged in") + 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 Error (`Forbidden, "you shoudn't be logged in") + 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 *) From 0fcd97044513cc967b78a488f566735b7bf1a294 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 10 Jan 2023 04:39:58 +0100 Subject: [PATCH 32/81] add medidate button --- src/island.ml | 25 +++++++++++++++++-------- src/island_client.ml | 15 +++++++++++++-- 2 files changed, 30 insertions(+), 10 deletions(-) diff --git a/src/island.ml b/src/island.ml index 411d570..50fdccc 100644 --- a/src/island.ml +++ b/src/island.ml @@ -17,24 +17,33 @@ let get request = let topbar = let mana_img = mk_img false "mana" in let mana_lvl = span ~a:[ a_id "mana_lvl" ] [ txt "0" ] in - div ~a:[ a_class [ "centered" ] ] @@ [ mana_img; mana_lvl ] + div ~a:[ a_class [ "centered" ] ] [ mana_img; mana_lvl ] in let canvas = - canvas - ~a:[ a_id "canvas" ] - [ txt "please update your browser or enable javascript" ] + div + ~a:[ a_class [ "centered" ] ] + [ canvas + ~a:[ a_id "canvas" ] + [ txt "please update your browser or enable javascript" ] + ] in let canvas_images = - List.map (mk_img true) - [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] + div + @@ List.map (mk_img true) + [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] in - let page = - div ~a:[ a_class [ "centered" ] ] @@ (topbar :: canvas :: canvas_images) + let bottombar = + let medidate_button = + button ~a:[ a_id "medidate_button" ] [ txt "Medidate" ] + in + div ~a:[ a_class [ "centered" ] ] [ medidate_button ] in + let page = div [ topbar; canvas; bottombar; canvas_images ] in + let js = script ~a: diff --git a/src/island_client.ml b/src/island_client.ml index 43f02cd..8497116 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -101,7 +101,7 @@ let send_action state action = Log.debug "sending action %a to server@\n" State.pp_action action; Ws_client.send (Network.Action_msg action) -let kb_handler ev = +let keydown_handler ev = let open State in let ev = Ev.as_type ev in let act = @@ -164,9 +164,20 @@ let () = match res with | Error e -> Log.debug "received update result error: %s@\n" e | Ok action' -> Queue.add action' to_apply_queue ) ); + (* bind keys *) let _e : Ev.listener = - Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + Ev.listen Ev.keydown keydown_handler (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 Fut.await initial_state_fut (fun msg -> From b0d466ac08ffba7f8b07a3e35daffef5387f6b29 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Tue, 10 Jan 2023 05:07:07 +0100 Subject: [PATCH 33/81] use wss instead of ws when not on localhost --- src/ws_client.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ws_client.ml b/src/ws_client.ml index f34b86a..05179c8 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -11,7 +11,8 @@ let ws = ~some:(fun port -> Format.sprintf ":%d" port) (Uri.port location) in - Jstr.of_string @@ Format.sprintf "ws://%s%s/island/ws" host port + 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 From 2945e7d478ed5775be64534e660a2eb5d14c3d2d Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Thu, 12 Jan 2023 04:19:40 +0100 Subject: [PATCH 34/81] better keyboard handling --- src/island_client.ml | 99 +++++++++++++++++++++++++++++++++++++------- 1 file changed, 84 insertions(+), 15 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 8497116..33ef546 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -101,21 +101,82 @@ let send_action state action = Log.debug "sending action %a to server@\n" State.pp_action action; Ws_client.send (Network.Action_msg action) -let keydown_handler ev = +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" |]; + (* 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 - let ev = Ev.as_type ev in - let act = - match Ev.Keyboard.code ev |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> Move Up - | "KeyA" | "ArrowLeft" -> Move Left - | "KeyS" | "ArrowDown" -> Move Down - | "KeyD" | "ArrowRight" -> Move Right - | _code -> ( - match Ev.Keyboard.key ev |> Jstr.to_string with - | "m" -> Meditate - | _key -> Do_nothing ) - in - Queue.add act input_queue + 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 Up + | "KeyA" | "ArrowLeft" -> Move Left + | "KeyS" | "ArrowDown" -> Move Down + | "KeyD" | "ArrowRight" -> Move Right + | "m" -> Meditate + | _ -> + (* 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; @@ -131,6 +192,7 @@ let rec game_loop state last_auto_update timestamp = 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 @@ -167,7 +229,14 @@ let () = (* bind keys *) let _e : Ev.listener = - Ev.listen Ev.keydown keydown_handler (Window.as_target G.window) + 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 *) From feebcd3841e382303ef17ae695108e525fce28fc Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Sun, 15 Jan 2023 00:48:47 +0100 Subject: [PATCH 35/81] implement grid offset --- src/island_client.ml | 61 +++++++++++++++++++--------- src/map.ml | 26 ++++++------ src/network.ml | 2 +- src/state.ml | 97 ++++++++++++++++++++++++++++++++++++-------- src/ws.ml | 8 +++- 5 files changed, 141 insertions(+), 53 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 33ef546..e0dfb72 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -52,16 +52,27 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") 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 - for x = 0 to tiles_per_w - 1 do - let map_x = x + state.player_pos.x - (tiles_per_w / 2) in - let tile_x = float_of_int ((x * tile_size) + orig_x) in - for y = 0 to tiles_per_h - 1 do - let map_y = y + state.player_pos.y - (tiles_per_h / 2) in - let tile_y = float_of_int ((y * tile_size) + orig_y) 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 @@ -91,15 +102,24 @@ 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 action = - match State.check_action state action with - | Error e -> - (* TODO: display this in the window *) - Log.debug "invalid action: %s@\n" e - | Ok Look_at_the_sky -> () - | Ok _ -> - Log.debug "sending action %a to server@\n" State.pp_action action; - Ws_client.send (Network.Action_msg action) +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 *) + | Meditate 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, @@ -165,10 +185,10 @@ let apply_last_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 Up - | "KeyA" | "ArrowLeft" -> Move Left - | "KeyS" | "ArrowDown" -> Move Down - | "KeyD" | "ArrowRight" -> Move Right + | "KeyW" | "ArrowUp" -> Move_offset Up + | "KeyA" | "ArrowLeft" -> Move_offset Left + | "KeyS" | "ArrowDown" -> Move_offset Down + | "KeyD" | "ArrowRight" -> Move_offset Right | "m" -> Meditate | _ -> (* if this happen, it means we're adding @@ -225,7 +245,8 @@ let () = | Update_result res -> ( match res with | Error e -> Log.debug "received update result error: %s@\n" e - | Ok action' -> Queue.add action' to_apply_queue ) ); + | Ok actions -> + List.iter (fun action -> Queue.add action to_apply_queue) actions ) ); (* bind keys *) let _e : Ev.listener = diff --git a/src/map.ml b/src/map.ml index 516d7a6..6bffeae 100644 --- a/src/map.ml +++ b/src/map.ml @@ -53,17 +53,15 @@ let init () = let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black -let check_move map ({ x; y; dir } as pos) movement_dir = - if dir <> movement_dir then Ok { pos with dir = movement_dir } - else - 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 -> Ok { pos with x; y } +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 -> Ok { pos with x; y } diff --git a/src/network.ml b/src/network.ml index 729b569..83cd67f 100644 --- a/src/network.ml +++ b/src/network.ml @@ -6,6 +6,6 @@ let unmarshal o = type server_message = | Full_state of State.t - | Update_result of (State.action', string) result + | Update_result of (State.action' list, string) result type client_message = Action_msg of State.action diff --git a/src/state.ml b/src/state.ml index 7ef6b1d..9b2ca6f 100644 --- a/src/state.ml +++ b/src/state.ml @@ -1,59 +1,124 @@ +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 ; player_pos : Map.position + ; offset_x : float + ; offset_y : float } let init () = - { map = Map.init (); mana = 0; player_pos = { x = 0; y = 0; dir = Down } } + { map = Map.init () + ; mana = 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 - | Do_nothing (* type for result of action send to the client by the server *) type action' = | Add_mana of int | Set_player_position of Map.position - | Look_at_the_sky + | Set_offset of float * float 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 - | Do_nothing -> Format.pp_print_string fmt "Do_nothing" 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 - | Look_at_the_sky -> Format.pp_print_string fmt "Look_at_the_sky" + | Set_offset (x, y) -> Format.fprintf fmt "Set_offset (%f, %f)" x y -let check_action state = function +let rec check_action state = function | Meditate -> - if state.mana < 99 then Ok (Add_mana 1) else Error "maximum mana" + 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) ) - | Do_nothing -> Ok Look_at_the_sky + | 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 let perform_action state = function | Add_mana n -> { state with mana = state.mana + n } | Set_player_position player_pos -> { state with player_pos } - | Look_at_the_sky -> state + | Set_offset (offset_x, offset_y) -> { state with offset_x; offset_y } let auto_update state = match check_action state Meditate with | Error _e -> state - | Ok action' -> - let state = perform_action state action' in - state + | Ok actions -> List.fold_left perform_action state actions let auto_update_rate = Time.mk_s 1 -let pp fmt { mana; player_pos; map } = +let pp fmt { mana; 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; player_pos = %a; %a" mana Map.pp_position - player_pos Map.pp_background bg + Format.fprintf fmt + "mana = %d; player_pos = %a; %a; offset_x = %f; offset_y = %f" mana + Map.pp_position player_pos Map.pp_background bg offset_x offset_y diff --git a/src/ws.ml b/src/ws.ml index 827aef9..3d832f8 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -35,8 +35,12 @@ let handle_client request client = Dream.log "check_action error: %s" msg; e | Ok action' -> - Dream.log "check_action ok: %a" State.pp_action' action'; - let state = State.perform_action state action' in + 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 From acb23420817dd9efaa91fc425f6506a92d9a97eb Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Sun, 15 Jan 2023 02:23:14 +0100 Subject: [PATCH 36/81] implement wheat ! --- src/island.ml | 20 +++++++++++++++++--- src/island_client.ml | 27 +++++++++++++++++++++++---- src/map.ml | 22 ++++++++++++++++++++-- src/state.ml | 44 ++++++++++++++++++++++++++++++++++++++------ 4 files changed, 98 insertions(+), 15 deletions(-) diff --git a/src/island.ml b/src/island.ml index 50fdccc..ad37b85 100644 --- a/src/island.ml +++ b/src/island.ml @@ -17,7 +17,11 @@ let get request = let topbar = let mana_img = mk_img false "mana" in let mana_lvl = span ~a:[ a_id "mana_lvl" ] [ txt "0" ] in - div ~a:[ a_class [ "centered" ] ] [ mana_img; mana_lvl ] + 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 = @@ -32,14 +36,24 @@ let get request = let canvas_images = div @@ List.map (mk_img true) - [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] + [ "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 - div ~a:[ a_class [ "centered" ] ] [ medidate_button ] + 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 diff --git a/src/island_client.ml b/src/island_client.ml index e0dfb72..1f25a64 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -51,6 +51,8 @@ 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 @@ -78,6 +80,7 @@ let draw_canvas = | Grass -> grass | Water -> water | Black -> water + | Wheat -> wheat in C2d.draw_image context tile_img ~x:tile_x ~y:tile_y done @@ -92,9 +95,13 @@ let draw_canvas = 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) + (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 () @@ -104,15 +111,17 @@ 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 + (* + | (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 *) - | Meditate as action -> ( + | (State.Move_offset _ | Move _ | Meditate | Plant_wheat) as action -> ( match State.check_action state action with | Error e -> (* TODO: display this in the window *) @@ -160,7 +169,7 @@ let keypress_handler = ; "KeyW" |]; let keys = Hashtbl.create 512 in - Array.iter (fun key -> Hashtbl.add keys key ()) [| "m" |]; + 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. *) @@ -190,6 +199,7 @@ let apply_last_key () = | "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` @@ -270,6 +280,15 @@ let () = 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 -> diff --git a/src/map.ml b/src/map.ml index 6bffeae..ea9c498 100644 --- a/src/map.ml +++ b/src/map.ml @@ -8,6 +8,7 @@ type background = | Grass | Water | Black + | Wheat let pp_dir fmt dir = let s = @@ -21,7 +22,11 @@ let pp_dir fmt dir = let pp_background fmt b = let s = - match b with Grass -> "Grass" | Water -> "Water" | Black -> "Black" + match b with + | Grass -> "Grass" + | Water -> "Water" + | Black -> "Black" + | Wheat -> "Wheat" in Format.pp_print_string fmt s @@ -53,6 +58,19 @@ let init () = 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 @@ -64,4 +82,4 @@ let check_move map ({ x; y; _ } as pos) movement_dir = match get_tile_kind ~x ~y map with | (Black | Water) as bg -> Error (Format.asprintf "can't move on %a" pp_background bg) - | Grass -> Ok { pos with x; y } + | Grass | Wheat -> Ok { pos with x; y } diff --git a/src/state.ml b/src/state.ml index 9b2ca6f..cc8af84 100644 --- a/src/state.ml +++ b/src/state.ml @@ -40,6 +40,7 @@ end type t = { map : Map.t ; mana : int + ; wheat : int ; player_pos : Map.position ; offset_x : float ; offset_y : float @@ -48,6 +49,7 @@ type t = let init () = { map = Map.init () ; mana = 0 + ; wheat = 0 ; player_pos = { x = 0; y = 0; dir = Down } ; offset_x = 0. ; offset_y = 0. @@ -58,23 +60,30 @@ type action = (* 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 -> @@ -104,21 +113,44 @@ let rec check_action state = function | 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 = - match check_action state Meditate with - | Error _e -> state - | Ok actions -> List.fold_left perform_action state actions + 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; player_pos; map; offset_x; offset_y } = +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; player_pos = %a; %a; offset_x = %f; offset_y = %f" mana - Map.pp_position player_pos Map.pp_background bg offset_x offset_y + "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 From 8955d9d73f58319fe4808c44ed40c51ea03aaaa3 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Mon, 20 Jan 2025 04:13:36 +0100 Subject: [PATCH 37/81] add CI --- .gitea/workflows/build.yaml | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 .gitea/workflows/build.yaml diff --git a/.gitea/workflows/build.yaml b/.gitea/workflows/build.yaml new file mode 100644 index 0000000..eaff5b6 --- /dev/null +++ b/.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) From e9954bf54e2d09c61e735fd31405db31ff0f7fe2 Mon Sep 17 00:00:00 2001 From: Swrup Date: Fri, 2 May 2025 19:55:00 +0200 Subject: [PATCH 38/81] fmt --- .ocamlformat | 2 +- src/map.ml | 3 +-- src/user.ml | 3 +-- 3 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index c54116a..eb9f4e0 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.24.1 +version=0.27.0 assignment-operator=end-line break-cases=fit break-fun-decl=wrap diff --git a/src/map.ml b/src/map.ml index ea9c498..ecca65e 100644 --- a/src/map.ml +++ b/src/map.ml @@ -64,8 +64,7 @@ let count_wheat map = let count' = Array.fold_left (fun count -> function - | Wheat -> succ count - | Black | Grass | Water -> count ) + | Wheat -> succ count | Black | Grass | Water -> count ) 0 a in count + count' ) diff --git a/src/user.ml b/src/user.ml index 56aa4ba..8c3ed39 100644 --- a/src/user.ml +++ b/src/user.ml @@ -154,8 +154,7 @@ let list () = Ok (Format.asprintf "
    %a
" (Format.pp_print_list (fun fmt -> function - | s -> Format.fprintf fmt {|
  • %s
    • |} s s ) - ) + | s -> Format.fprintf fmt {|
  • %s
    • |} s s )) users ) let get_nick_unsafe request = Option.get @@ Dream.session "nick" request From 0027a047c63dce1a2de6a6d11d6f5b2d73500558 Mon Sep 17 00:00:00 2001 From: Swrup Date: Fri, 2 May 2025 20:02:04 +0200 Subject: [PATCH 39/81] fix libraries changes --- src/app.ml | 22 +++++++++++++--------- src/db.ml | 13 +++++++------ src/dune | 3 ++- src/island.ml | 4 ++-- src/user.ml | 31 ++++++++++++++++--------------- src/ws.ml | 2 +- 6 files changed, 41 insertions(+), 34 deletions(-) diff --git a/src/app.ml b/src/app.ml index 543afc7..2936611 100644 --- a/src/app.ml +++ b/src/app.ml @@ -19,12 +19,13 @@ 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 [] + 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; + Dream.log "config file: %s" filename_str; match Scfg.Parse.from_file filename with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok config -> config end @@ -33,7 +34,7 @@ let open_registration = | 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 -> @@ -46,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 @@ -62,7 +63,10 @@ let hostname = match Scfg.Query.get_dir "hostname" config with | 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,7 +75,7 @@ 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" ) @@ -84,7 +88,7 @@ let about = | None -> default_about | Some about -> ( match Scfg.Query.get_param 0 about with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok about -> about ) let random_state = Random.State.make_self_init () diff --git a/src/db.ml b/src/db.ml index 6295420..ca88f29 100644 --- a/src/db.ml +++ b/src/db.ml @@ -3,15 +3,16 @@ 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) diff --git a/src/dune b/src/dune index db008b0..b35e495 100644 --- a/src/dune +++ b/src/dune @@ -33,7 +33,8 @@ tyxml tyxml.functor uri - uuidm) + uuidm + unix) (preprocess (pps lwt_ppx))) diff --git a/src/island.ml b/src/island.ml index ad37b85..013bfac 100644 --- a/src/island.ml +++ b/src/island.ml @@ -61,8 +61,8 @@ let get request = let js = script ~a: - [ a_mime_type "text/javascript" - ; a_src "/assets/js/island_client.js" + [ (*a_mime_type "text/javascript" ; *) + a_src "/assets/js/island_client.js" ; a_defer () ] (txt "") diff --git a/src/user.ml b/src/user.ml index 8c3ed39..1ada3bd 100644 --- a/src/user.ml +++ b/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,10 +101,12 @@ 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 (`Forbidden, "YOU ARE BANISHED") else Error (`Forbidden, "wrong password") @@ -157,12 +158,12 @@ let list () = | s -> Format.fprintf fmt {|
  • %s
    • |} s s )) users ) -let get_nick_unsafe request = Option.get @@ Dream.session "nick" request +let get_nick_unsafe request = Option.get @@ Dream.session_field request "nick" -let is_logged_in request = Option.is_some @@ Dream.session "nick" request +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 diff --git a/src/ws.ml b/src/ws.ml index 3d832f8..ee2cf30 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -7,7 +7,7 @@ let get_state_unsafe user_id = | Ok state -> state let handle_client request client = - match Dream.session "user_id" request with + 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 *) From 87ba0e9d264df765340b3970f4dcbb1ec4b2a502 Mon Sep 17 00:00:00 2001 From: Swrup Date: Fri, 2 May 2025 21:54:06 +0200 Subject: [PATCH 40/81] dream sql_sessions --- src/db.ml | 20 ++++++++++++++++---- src/pellest.ml | 3 ++- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/src/db.ml b/src/db.ml index ca88f29..deac35d 100644 --- a/src/db.ml +++ b/src/db.ml @@ -17,12 +17,24 @@ 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 = diff --git a/src/pellest.ml b/src/pellest.ml index 9ee23fa..19a5c9e 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -24,7 +24,8 @@ let () = let () = let logger = if App.log then Dream.logger else Fun.id in - Dream.run ~port:App.port @@ 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/**" Asset.get From 4bd924d65fa6973bfcbc4afeaac65209210ce2e1 Mon Sep 17 00:00:00 2001 From: pena Date: Mon, 5 Dec 2022 22:35:38 +0100 Subject: [PATCH 41/81] update .ocamlformat --- .ocamlformat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.ocamlformat b/.ocamlformat index f81fbf5..c54116a 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.23.0 +version=0.24.1 assignment-operator=end-line break-cases=fit break-fun-decl=wrap From 5ec03d06c20f624cb33f0c7da4a14654a300f100 Mon Sep 17 00:00:00 2001 From: pena Date: Mon, 5 Dec 2022 22:44:30 +0100 Subject: [PATCH 42/81] do not force file to exist --- src/app.ml | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/src/app.ml b/src/app.ml index d213823..9c3c619 100644 --- a/src/app.ml +++ b/src/app.ml @@ -20,14 +20,13 @@ let 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 + if not @@ Sys.file_exists filename then [] + else begin + Dream.log "config file: %s" filename; + match Scfg.Parse.from_file filename with + | Error e -> failwith e + | Ok config -> config + end let open_registration = match Scfg.Query.get_dir "open_registration" config with @@ -59,8 +58,9 @@ 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) @@ -78,17 +78,15 @@ let log = 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 random_state = Random.State.make_self_init () let () = Random.set_state random_state let about = - (* TODO read from about.txt *) - "This is pellest" + 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 e -> failwith e + | Ok about -> about ) From ee626ccd61d197cdc6583ea75c90f219421b9963 Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 6 Dec 2022 00:12:14 +0100 Subject: [PATCH 43/81] clean code --- src/asset.ml | 10 + src/content/assets/css/leaflet.css | 640 ---------------------- src/content/assets/img/layers-2x.png | Bin 1259 -> 0 bytes src/content/assets/img/layers.png | Bin 696 -> 0 bytes src/content/assets/img/marker-icon-2x.png | Bin 2464 -> 0 bytes src/content/assets/img/marker-icon.png | Bin 1466 -> 0 bytes src/content/assets/img/marker-shadow.png | Bin 618 -> 0 bytes src/content/assets/js/dune | 8 - src/db.ml | 5 +- src/dune | 4 +- src/home.ml | 14 +- src/js/client.ml | 0 src/js/dune | 10 - src/js/geo.ml | 97 ---- src/js/leaflet/leaflet.js | 6 - src/js/utils.ml | 14 - src/login.ml | 22 +- src/pellest.ml | 53 +- src/register.ml | 17 +- src/syntax.ml | 8 +- src/template.ml | 24 +- src/tyx_util.ml | 7 +- src/user.ml | 20 +- src/util.ml | 34 -- 24 files changed, 99 insertions(+), 894 deletions(-) create mode 100644 src/asset.ml delete mode 100644 src/content/assets/css/leaflet.css delete mode 100644 src/content/assets/img/layers-2x.png delete mode 100644 src/content/assets/img/layers.png delete mode 100644 src/content/assets/img/marker-icon-2x.png delete mode 100644 src/content/assets/img/marker-icon.png delete mode 100644 src/content/assets/img/marker-shadow.png delete mode 100644 src/content/assets/js/dune delete mode 100644 src/js/client.ml delete mode 100644 src/js/dune delete mode 100644 src/js/geo.ml delete mode 100644 src/js/leaflet/leaflet.js delete mode 100644 src/js/utils.ml diff --git a/src/asset.ml b/src/asset.ml new file mode 100644 index 0000000..f02f0d6 --- /dev/null +++ b/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 "" diff --git a/src/content/assets/css/leaflet.css b/src/content/assets/css/leaflet.css deleted file mode 100644 index 3385b5e..0000000 --- a/src/content/assets/css/leaflet.css +++ /dev/null @@ -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; - } diff --git a/src/content/assets/img/layers-2x.png b/src/content/assets/img/layers-2x.png deleted file mode 100644 index 200c333dca9652ac4cba004d609e5af4eee168c1..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1259 zcmeAS@N?(olHy`uVBq!ia0y~yU@!q;4i*LmhWx_I2@DJ@n><|{Ln;`Pe)y|cT4BSrpMM7AKE|dn|XR+k!t#k(tv`Q zFW(sEd!8~#>$+9`f9l__#fF!KZ}B_rzo8eC{r}xGzO@x)!A}C+%Y(`<1s-2^LiGH- zNefThzU1_3Qe}!q>B&sRiQ8E#H9j`Wp1zeElOM1<_xPqG{7q&i{}sRA|NWDBa`yhi zf4~1}Z!&l?D{`K~v~Df`g0pk31-#L={QUP&^~BTfPt276eJZ4F#OLLkrWm<1w?G}$K(_Zg>&?>%7rSDWy?-oPVGDw+3f6ddKzommMznMtmE1m^mE;|X)^@3r5^M>q%(7WwwkhRUVZzX zFui*B_UL;{ERE{7ySzCa{A5c-^`03^s-Cnw)fD`#!?J7Jk{=GMTBd1ws=RS{H7RMA z+lH2N3m&&zxMt!%-Q)BVRe@_$r#$1#RlV@>f}~i)v%B7(D}^uiKE0`=J9&~rL}git za^vjh=XaOCc>eeO>kuD~_nyZSSrR*HoRZ?^jT=9HS|#-C z#I0=$9oqx1b}%c7@V%LR;e=gTTa&Q*O*Q|E%7{caZdK)_+ZJf zZ?&H!g%0t3zQ`e9eahh1=NZBi3YOTd+htU}IKfpW%e~b`fYbPb(yyJ0eX|!$;Jmtc zpGlI(Uq{=OPOf@MjvXyZfAUxkxkT|?T2R1T7_4W$NpIDXdncV=-Og(5O3XcC)5tQ> zz+Ah^=e$i`pnF#TudS&IcRlWTsKE8W$-*hoo%u=2$;`|LE*k2wcM@{W?B28Hj1!|( z?&`3_D`smL6xn7gD*L#dPAd}*D+qeymA_@1k^7b7fk)o?9(Qdv5?I?{*Qdo6H_a$Z zWx4ILe&t;!1-}-TBu7TxOI@rh@5%8t*~M7);;#tq)bxD@K>`uh2LySGU20__qc2Mz zz5e8&(8Q{b_nT$qIxJK3ZwNANm$G;z+!`QW&+ygqZIXsCQ=*b?Q`wxE@t%9{h$R(y z`}7A0eZ8=B>r+-n=MV*-1+Ej;cKH>13)vbyyUbGSW~KP1V^g_>mQb1#clPCv9d}vs ze&jIq>z1(p^?bgvyl$yv;Vr)mizp0?3uUtD~sA1FSi+%x^t@XE}h@-tYzk9 zqoeJq#fQ#h%zQM#GO;LXnVpKdkC%5qo68}Ws3tQNA+-xadlV-caB*y5$@NebP0l+XkKIZj$K diff --git a/src/content/assets/img/layers.png b/src/content/assets/img/layers.png deleted file mode 100644 index 1a72e5784b2b456eac5d7670738db80697af3377..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 696 zcmeAS@N?(olHy`uVBq!ia0y~yV2}b~4i*Lm24?3LR|W>AdQTU}kP61$5aS9JMv;5A zx9={r3D-Qo$}jd-@Kme(q}h{gk8N9f^YEHSI?4X$wi&*^XXUqVf93n@6)G0|HB0O+ z{oGRd;!&;aKiPjre@~N1y8by_{oP(ApF5A&Z+bmlV3plXXQ4Q^(0Q+y~?G3 z!a`R6-Bzb}>nxoMS3g;|c>CL9(`O!9VDQ7}^1l9i({>+QJ4%7S^9P-Qtwc)jUmWjVlF-6H4cVyjqg@ zMm}=+(G^1+f9k%t3*NyNhGDITISixbZs=XtX?<#@#To^} zllR&yC7Q0b2+Ufee$_3@VyDHEwjITj6hhx>ORdzOd~VN~YpdKO9dmD=@;Ir&?!Ka0 ze9@!>sms1^+w^n(%oWF3dR*t__&0jzGw-8qqez~?-<4~x zU6bljyRxA4^qUU`2YDx)`}y=x*@+KtSBac>;qcY?zuAd~x7`1fA4n|jeLTA^%I{0R z&%u&I8&&`GCa_jieR-P2?K98qLyM^QzxM~_RzHi!*UqnACyylIHN^Rj+B6T>B0g6wD2rb>45pm~>lr(g1)bIG-PU&x&EkqfVSO*&yS z;hbgfS=;Jm?$a(hPCjqmxW%!3m-FO{289cX=kK>@-tIN=m|6E(zuA|q`_Fk#J#X4| z*0y{tG5mYrJM&be(p=rT6IlmmfW5UU2Hz<2n7J+mwrr-TRF?&V zs_)#7Uw`VB9X@~mmHni1?h{YB&A71m;5DZS7tY*$5wYNs%e3=LkK8nDKjS{>tX=Pg zt!M9fH?R8l@Bi^z&p&_vW!`i4?dR`v_g=Q2d_K5+tzXB6px$jMQ@2gtej$F@_2e0Q z9Xb!V_n&Z^e9@s{ZR~{2!982zCT(|`dj84V&nBH`ww%75u>873@7dlh=bfjXH|{(W z7d!Ji0|SF|NswPKgN%7_eosI1qqlQh)VQ0z2_?Q_-+JKUU7huPe~$OxD4((Q%=1rn z?q4@-&3bU7TsbLBvg!I5S2dYWD;2#S7ZU|h_he3U@wtzOHt*icIpHmL zy?Ai&|Ch$MFYn&^pnlOR%aGe&>)tMux+?e~{z}Q!-sv)H?Z4&ghKAqWlXPcq>ejrS z$BVzazm`65urEF{ge%(WbpDLf>%-W3W7Q8Z-diaxRrFdX{@IL*dsFs5{QGXyqWOP4-1PE)zwr(UqLCNG@BDShIb@BbQOH~rvz6x(1rM{&)h zCI2^1ie0}woOhbaNv}DX8hPC_CNKHouloIxr(aOX;V(s%tEQ{y7mEGo6BjSNdm(Vs z!BXu_x9&`h);d4=?!Ti)lNFxZ-a1{#+&m+>>+vSZ{Dx(nJA39omT)(Wd}d*OchY}> zS=Wlr9G}5lbce-J`;++A6P>4z=5$@YRO0(?M@{jf7aF}sW!InoesgvD`S0uR{y+7c zJM*Z^%fdw#&#l*lSVe4|v9FI;Blz0)M}eM4}1S7y|fO|lGIHmwo6)ysN) z@`Y2E&hx0QzQ6Ic0N5mtVH?#oTPjdTv<|H^U?6ohXl5NmKFtfVaU1XGt93HWL;;RCz(~i-B@2 ztMZwa3;7ji`<>cuYUsWYyyfT~aW>~)Ttdp0haa*^A7`rEIn48j^>mNb9mZLUU;Dgq zb(BBsvZ#Nx_Uel(roBAMoph#Zi{zHxs=z<2V(tqsuD&`oda+X07I6J*oa%H2;&Oq~}6b8UMv1o^cHB zw@!+h7H6D zE$XK?O<(fKWT9kaoQA9NCob2O4UaD6IrQb)Yuwtmc1m82EZ4gF#as5z)n(u0^CphP zQoO8O{?ujuQ*uXBbiS=f+M{6qXZNIC-#wKX9$WmgkWlOGG%UQt>8v8C#bLHj^{?#p zq^}Oqw=ccclsgm}$Rb#}qSsU0T>Y|%q3Of?gq$MZT@r_@Zu{PyecS50-wK8AYV-e2 zfB!+nf3KYzTfhAMRX%I(>aI5GIrFb~>*ZDV4V`!wuLxajKX3Ps*sJFZ{dk2L|LmL? zzat=TpVAF?U;l!InHzU3j`scCuEl+urt8mrgm91(dc6j+tP z6A`%Mx>-aj?~J8<#TLO+mYPp{qlT&iN z&a1S3<*O-TZj{@!u_4N6X2lKeSu#n_P@}6L{b6Jl@&cjG~%U8!&Dx}z( zrMAAcayuD$-&lEawocKa4aqJsJ&X3~rhP8ov`9`;z3BX#j-a~m>C=zc{$M|Ob;m?a ziOFe4?k@Rq<_XD> zB4=;4Zhd?AM&|77+xND~`rPKZmAu(>+oP1++ovkt{rkN7+x4_tFaL!ukK6nGo$YfQ z^*v9n8!cmLEqlSVG%sR-0gvk$*DRbW z{m-p)*DZrjd!y_xaa_#o*4U(@uKo4!Pp!ij7T!1}%l>}rjh7!Q-(N81zW?~clRw*E z{?k)GYWmiy#bRlmL;oJl&J$aiudgm)F0-iHas2Qk`y1cI?%sa8bcrAT(b;!%I<0P9 z{GTy@w!r#Jyj6z3I9)}Su6`_XYb*QXS!FV5bHD9z{itSs)R*aqqTRyE=Ymg+ZNB$v zHnpZ&)$hNave^Ci{e>)>+mm|UX)=F2arlas*Y!VZ^`gp;W=x!PmHFb<*?e}lzMCE0 zvRk9d-y7$jUC*^W@geu4@I-OlYNyz3uMQ~hJ@ZAvR^;ZhPs}lPSAO%o7BSQa zbpPGC@q~NNuAHs@aeMx#hPkYYE#J1MVCVaHeA;*K{uFcFvg=QSSx&=`UA`hqVtqd? zdYU5{zPVBEP0{7r*yQI8{Cgfe_xwDKZM9d}j|Vzyjy`R7nLK@io8wY#kL`E7Jf<68x9vugLJO(0z-KZ&Qdg!24aAb07_69#wwGGo2xYnJYN`~G6Y z{f5WJTvyi~d3Pw}=hJ5XJrB~|HdTa{+%+rHYo0wvW<#>j?DETdO_@vH{3w)qU%ji; z_NZx&{M3G{ii77TKhyiAxALr4;M%-PCKi?|B^8>h(u}9Bzu_-jd+e)R*D9HVSAKyF zecrkG`QJvbip||uzVh)2I2K)AknA*Z-`f1(ke>{yQhV!uK44yNk^b+!z|FQq$H>U% z4;rj)&CipZ6`-=U+SoNLchL;9^D}-vc+R=`7mwnv#>0hg<$|tQStOh|DXSMGs-QM%v9#OT6aOo!0u!OS>mk{4v*^-gU{kUv-=DI!X3RTGs59 zrms7aq`qxvdDNrlbwOV>GmT$cCUm!OcDu!Xn-2~CQ?8YY{CTrg$>;Sw`KWyp56!-# zvTn<7$3qHR4xXKK)bzH)nQ1H9&39e2*J8I>_;hw(^Yq=jSu~fmADQ`g-w!kW*($3f zq`R`zS+DL4=#y?Q`_N(ZtLBi%<=QzX-b%(U=MFlvzxDbXmD0JBS)OidXsr40A^42_ zgQZVg7!FDwD~idOcvfy#ai6Y&gUYVfn=F;xwLJ0PR(xmSKH_ux;D=dz-;~^0xZPL! z1ozroz7KYO?cK)hC-BfMm|Z;L!tIi4FB=3m3Vm8)$!*y6sqlWqio>o2PxU5+TD=Tg zTYBn%ncKVvzMt<;x^8t&I-EsdU*;9>P2#^cg&*=|96!BiOWgcbr%qb!*P729?QZ?6 zRrA<$=6|mncDLWmyzk*RUeFH>vO3!Qi?h`T=KR)_2Cros(q` zrr!L0L#TAiV);U2p+@gxZ`B_y65O@-44>dO5ph1@TNmwv1>fy$%wBo$+&WgT#8pop z)W1KvrsG3JiO}O;u{)0M6cpu=b+0}4U()?P(=nGF;+fwCy{@FkvLxKGX3gAtJaCcS qX{9?EN|FMnBE=+YEB(x$$D3}plVUPRyu-l2z~JfX=d#Wzp$P!`FXGq$ diff --git a/src/content/assets/img/marker-shadow.png b/src/content/assets/img/marker-shadow.png deleted file mode 100644 index 9fd2979532a19a15b824ce763c76e04a8dafadfb..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 618 zcmeAS@N?(olHy`uVBq!ia0y~yV9*3%4i*Lm2ByptwG0eQhMq2tAr*{oFSYhPb`W5> zz-9dRf4!`+aT{;(+DlW`OuKvh(cD`Fe?o50tvmGJPyYYkI}^-Pj=%i->5t$_?z+Eg z<0t)EHE)aXMy2F{nEjj_T;IYwdK?Rnnaqjf{1)D-;#kNmzt4GE;O+QxK@S+5(^AaU z7N=aDb)V1U?7Vn^%sUpxJr3q=Te918=e*elN$zhlHIzdXC1oeM8Mbg5Nj2o3WOPw+ zpMOwu*&gweJLb*OS~P7Ar@rLmS*ayg8lq+dZ0+?Zm6nX!yo^w|MJ60@P{_ADQggak&v`^0oPSK8g z6Zm$gzJVJ145{rKZ=dn?y=(KrV#&L&JR6VjWuMu>*SMBLWeLMd-$OHax6Mdiqt~NQ zs^Y#(?6|a*=efdFwcBoGHo3%{*nZNbWKCU{!`kM%S>CBD4~8GC3UcaXD%fwav8F%f z=oGOgmCmZ50aHZd{ 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 diff --git a/src/dune b/src/dune index 8352fbb..ce55c43 100644 --- a/src/dune +++ b/src/dune @@ -2,6 +2,7 @@ (name pellest) (modules app + asset content pellest util @@ -37,8 +38,7 @@ (rule (target content.ml) (deps - (source_tree content) - (file content/assets/js/client.js)) + (source_tree content)) (action (with-stdout-to %{null} diff --git a/src/home.ml b/src/home.ml index 2b03752..5a0c562 100644 --- a/src/home.ml +++ b/src/home.ml @@ -1,11 +1,9 @@ open Tyxml.Html -let f _request = - let page_title = "Pellest is the best game ever!" in +let get _request = + let 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" ] ] - 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 + 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 page = div [ about; login_link; register_link ] in + Template.render ~title ~scripts:[] page diff --git a/src/js/client.ml b/src/js/client.ml deleted file mode 100644 index e69de29..0000000 diff --git a/src/js/dune b/src/js/dune deleted file mode 100644 index c404ab0..0000000 --- a/src/js/dune +++ /dev/null @@ -1,10 +0,0 @@ -(executable - (name client) - (modules client) - (libraries brr utils) - (modes js)) - -(library - (name utils) - (modules utils) - (libraries brr)) diff --git a/src/js/geo.ml b/src/js/geo.ml deleted file mode 100644 index 476d102..0000000 --- a/src/js/geo.ml +++ /dev/null @@ -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 diff --git a/src/js/leaflet/leaflet.js b/src/js/leaflet/leaflet.js deleted file mode 100644 index 21f499c..0000000 --- a/src/js/leaflet/leaflet.js +++ /dev/null @@ -1,6 +0,0 @@ -/* @preserve - * Leaflet 1.7.1, a JS library for interactive maps. http://leafletjs.com - * (c) 2010-2019 Vladimir Agafonkin, (c) 2010-2011 CloudMade - */ -!function(t,i){"object"==typeof exports&&"undefined"!=typeof module?i(exports):"function"==typeof define&&define.amd?define(["exports"],i):i(t.L={})}(this,function(t){"use strict";function h(t){for(var i,e,n=1,o=arguments.length;n=this.min.x&&e.x<=this.max.x&&i.y>=this.min.y&&e.y<=this.max.y},intersects:function(t){t=O(t);var i=this.min,e=this.max,n=t.min,o=t.max,s=o.x>=i.x&&n.x<=e.x,r=o.y>=i.y&&n.y<=e.y;return s&&r},overlaps:function(t){t=O(t);var i=this.min,e=this.max,n=t.min,o=t.max,s=o.x>i.x&&n.xi.y&&n.y=n.lat&&e.lat<=o.lat&&i.lng>=n.lng&&e.lng<=o.lng},intersects:function(t){t=N(t);var i=this._southWest,e=this._northEast,n=t.getSouthWest(),o=t.getNorthEast(),s=o.lat>=i.lat&&n.lat<=e.lat,r=o.lng>=i.lng&&n.lng<=e.lng;return s&&r},overlaps:function(t){t=N(t);var i=this._southWest,e=this._northEast,n=t.getSouthWest(),o=t.getNorthEast(),s=o.lat>i.lat&&n.lati.lng&&n.lng';var i=t.firstChild;return i.style.behavior="url(#default#VML)",i&&"object"==typeof i.adj}catch(t){return!1}}();function kt(t){return 0<=navigator.userAgent.toLowerCase().indexOf(t)}var Bt={ie:tt,ielt9:it,edge:et,webkit:nt,android:ot,android23:st,androidStock:at,opera:ht,chrome:ut,gecko:lt,safari:ct,phantom:_t,opera12:dt,win:pt,ie3d:mt,webkit3d:ft,gecko3d:gt,any3d:vt,mobile:yt,mobileWebkit:xt,mobileWebkit3d:wt,msPointer:Pt,pointer:Lt,touch:bt,mobileOpera:Tt,mobileGecko:Mt,retina:zt,passiveEvents:Ct,canvas:St,svg:Zt,vml:Et},At=Pt?"MSPointerDown":"pointerdown",It=Pt?"MSPointerMove":"pointermove",Ot=Pt?"MSPointerUp":"pointerup",Rt=Pt?"MSPointerCancel":"pointercancel",Nt={},Dt=!1;function jt(t,i,e,n){function o(t){Ut(t,r)}var s,r,a,h,u,l,c,_;function d(t){t.pointerType===(t.MSPOINTER_TYPE_MOUSE||"mouse")&&0===t.buttons||Ut(t,h)}return"touchstart"===i?(u=t,l=e,c=n,_=p(function(t){t.MSPOINTER_TYPE_TOUCH&&t.pointerType===t.MSPOINTER_TYPE_TOUCH&&Ri(t),Ut(t,l)}),u["_leaflet_touchstart"+c]=_,u.addEventListener(At,_,!1),Dt||(document.addEventListener(At,Wt,!0),document.addEventListener(It,Ht,!0),document.addEventListener(Ot,Ft,!0),document.addEventListener(Rt,Ft,!0),Dt=!0)):"touchmove"===i?(h=e,(a=t)["_leaflet_touchmove"+n]=d,a.addEventListener(It,d,!1)):"touchend"===i&&(r=e,(s=t)["_leaflet_touchend"+n]=o,s.addEventListener(Ot,o,!1),s.addEventListener(Rt,o,!1)),this}function Wt(t){Nt[t.pointerId]=t}function Ht(t){Nt[t.pointerId]&&(Nt[t.pointerId]=t)}function Ft(t){delete Nt[t.pointerId]}function Ut(t,i){for(var e in t.touches=[],Nt)t.touches.push(Nt[e]);t.changedTouches=[t],i(t)}var Vt=Pt?"MSPointerDown":Lt?"pointerdown":"touchstart",qt=Pt?"MSPointerUp":Lt?"pointerup":"touchend",Gt="_leaflet_";var Kt,Yt,Xt,Jt,$t,Qt,ti=fi(["transform","webkitTransform","OTransform","MozTransform","msTransform"]),ii=fi(["webkitTransition","transition","OTransition","MozTransition","msTransition"]),ei="webkitTransition"===ii||"OTransition"===ii?ii+"End":"transitionend";function ni(t){return"string"==typeof t?document.getElementById(t):t}function oi(t,i){var e,n=t.style[i]||t.currentStyle&&t.currentStyle[i];return n&&"auto"!==n||!document.defaultView||(n=(e=document.defaultView.getComputedStyle(t,null))?e[i]:null),"auto"===n?null:n}function si(t,i,e){var n=document.createElement(t);return n.className=i||"",e&&e.appendChild(n),n}function ri(t){var i=t.parentNode;i&&i.removeChild(t)}function ai(t){for(;t.firstChild;)t.removeChild(t.firstChild)}function hi(t){var i=t.parentNode;i&&i.lastChild!==t&&i.appendChild(t)}function ui(t){var i=t.parentNode;i&&i.firstChild!==t&&i.insertBefore(t,i.firstChild)}function li(t,i){if(void 0!==t.classList)return t.classList.contains(i);var e=pi(t);return 0this.options.maxZoom)?this.setZoom(t):this},panInsideBounds:function(t,i){this._enforcingBounds=!0;var e=this.getCenter(),n=this._limitCenter(e,this._zoom,N(t));return e.equals(n)||this.panTo(n,i),this._enforcingBounds=!1,this},panInside:function(t,i){var e,n,o=A((i=i||{}).paddingTopLeft||i.padding||[0,0]),s=A(i.paddingBottomRight||i.padding||[0,0]),r=this.getCenter(),a=this.project(r),h=this.project(t),u=this.getPixelBounds(),l=u.getSize().divideBy(2),c=O([u.min.add(o),u.max.subtract(s)]);return c.contains(h)||(this._enforcingBounds=!0,e=a.subtract(h),n=A(h.x+e.x,h.y+e.y),(h.xc.max.x)&&(n.x=a.x-e.x,0c.max.y)&&(n.y=a.y-e.y,0=this.options.transform3DLimit&&this._resetView(this.getCenter(),this.getZoom())},_findEventTargets:function(t,i){for(var e,n=[],o="mouseout"===i||"mouseover"===i,s=t.target||t.srcElement,r=!1;s;){if((e=this._targets[m(s)])&&("click"===i||"preclick"===i)&&!t._simulated&&this._draggableMoved(e)){r=!0;break}if(e&&e.listens(i,!0)){if(o&&!Vi(s,t))break;if(n.push(e),o)break}if(s===this._container)break;s=s.parentNode}return n.length||r||o||!Vi(s,t)||(n=[this]),n},_handleDOMEvent:function(t){var i;this._loaded&&!Ui(t)&&("mousedown"!==(i=t.type)&&"keypress"!==i&&"keyup"!==i&&"keydown"!==i||Pi(t.target||t.srcElement),this._fireDOMEvent(t,i))},_mouseEvents:["click","dblclick","mouseover","mouseout","contextmenu"],_fireDOMEvent:function(t,i,e){var n;if("click"===t.type&&((n=h({},t)).type="preclick",this._fireDOMEvent(n,n.type,e)),!t._stopped&&(e=(e||[]).concat(this._findEventTargets(t,i))).length){var o=e[0];"contextmenu"===i&&o.listens(i,!0)&&Ri(t);var s,r={originalEvent:t};"keypress"!==t.type&&"keydown"!==t.type&&"keyup"!==t.type&&(s=o.getLatLng&&(!o._radius||o._radius<=10),r.containerPoint=s?this.latLngToContainerPoint(o.getLatLng()):this.mouseEventToContainerPoint(t),r.layerPoint=this.containerPointToLayerPoint(r.containerPoint),r.latlng=s?o.getLatLng():this.layerPointToLatLng(r.layerPoint));for(var a=0;athis.options.zoomAnimationThreshold)return!1;var n=this.getZoomScale(i),o=this._getCenterOffset(t)._divideBy(1-1/n);return!(!0!==e.animate&&!this.getSize().contains(o))&&(M(function(){this._moveStart(!0,!1)._animateZoom(t,i,!0)},this),!0)},_animateZoom:function(t,i,e,n){this._mapPane&&(e&&(this._animatingZoom=!0,this._animateToCenter=t,this._animateToZoom=i,ci(this._mapPane,"leaflet-zoom-anim")),this.fire("zoomanim",{center:t,zoom:i,noUpdate:n}),setTimeout(p(this._onZoomTransitionEnd,this),250))},_onZoomTransitionEnd:function(){this._animatingZoom&&(this._mapPane&&_i(this._mapPane,"leaflet-zoom-anim"),this._animatingZoom=!1,this._move(this._animateToCenter,this._animateToZoom),M(function(){this._moveEnd(!0)},this))}});function Yi(t){return new Xi(t)}var Xi=S.extend({options:{position:"topright"},initialize:function(t){c(this,t)},getPosition:function(){return this.options.position},setPosition:function(t){var i=this._map;return i&&i.removeControl(this),this.options.position=t,i&&i.addControl(this),this},getContainer:function(){return this._container},addTo:function(t){this.remove(),this._map=t;var i=this._container=this.onAdd(t),e=this.getPosition(),n=t._controlCorners[e];return ci(i,"leaflet-control"),-1!==e.indexOf("bottom")?n.insertBefore(i,n.firstChild):n.appendChild(i),this._map.on("unload",this.remove,this),this},remove:function(){return this._map&&(ri(this._container),this.onRemove&&this.onRemove(this._map),this._map.off("unload",this.remove,this),this._map=null),this},_refocusOnMap:function(t){this._map&&t&&0",n=document.createElement("div");return n.innerHTML=e,n.firstChild},_addItem:function(t){var i,e=document.createElement("label"),n=this._map.hasLayer(t.layer);t.overlay?((i=document.createElement("input")).type="checkbox",i.className="leaflet-control-layers-selector",i.defaultChecked=n):i=this._createRadioElement("leaflet-base-layers_"+m(this),n),this._layerControlInputs.push(i),i.layerId=m(t.layer),zi(i,"click",this._onInputClick,this);var o=document.createElement("span");o.innerHTML=" "+t.name;var s=document.createElement("div");return e.appendChild(s),s.appendChild(i),s.appendChild(o),(t.overlay?this._overlaysList:this._baseLayersList).appendChild(e),this._checkDisabledLayers(),e},_onInputClick:function(){var t,i,e=this._layerControlInputs,n=[],o=[];this._handlingClick=!0;for(var s=e.length-1;0<=s;s--)t=e[s],i=this._getLayer(t.layerId).layer,t.checked?n.push(i):t.checked||o.push(i);for(s=0;si.options.maxZoom},_expandIfNotCollapsed:function(){return this._map&&!this.options.collapsed&&this.expand(),this},_expand:function(){return this.expand()},_collapse:function(){return this.collapse()}}),$i=Xi.extend({options:{position:"topleft",zoomInText:"+",zoomInTitle:"Zoom in",zoomOutText:"−",zoomOutTitle:"Zoom out"},onAdd:function(t){var i="leaflet-control-zoom",e=si("div",i+" leaflet-bar"),n=this.options;return this._zoomInButton=this._createButton(n.zoomInText,n.zoomInTitle,i+"-in",e,this._zoomIn),this._zoomOutButton=this._createButton(n.zoomOutText,n.zoomOutTitle,i+"-out",e,this._zoomOut),this._updateDisabled(),t.on("zoomend zoomlevelschange",this._updateDisabled,this),e},onRemove:function(t){t.off("zoomend zoomlevelschange",this._updateDisabled,this)},disable:function(){return this._disabled=!0,this._updateDisabled(),this},enable:function(){return this._disabled=!1,this._updateDisabled(),this},_zoomIn:function(t){!this._disabled&&this._map._zoomthis._map.getMinZoom()&&this._map.zoomOut(this._map.options.zoomDelta*(t.shiftKey?3:1))},_createButton:function(t,i,e,n,o){var s=si("a",e,n);return s.innerHTML=t,s.href="#",s.title=i,s.setAttribute("role","button"),s.setAttribute("aria-label",i),Oi(s),zi(s,"click",Ni),zi(s,"click",o,this),zi(s,"click",this._refocusOnMap,this),s},_updateDisabled:function(){var t=this._map,i="leaflet-disabled";_i(this._zoomInButton,i),_i(this._zoomOutButton,i),!this._disabled&&t._zoom!==t.getMinZoom()||ci(this._zoomOutButton,i),!this._disabled&&t._zoom!==t.getMaxZoom()||ci(this._zoomInButton,i)}});Ki.mergeOptions({zoomControl:!0}),Ki.addInitHook(function(){this.options.zoomControl&&(this.zoomControl=new $i,this.addControl(this.zoomControl))});var Qi=Xi.extend({options:{position:"bottomleft",maxWidth:100,metric:!0,imperial:!0},onAdd:function(t){var i="leaflet-control-scale",e=si("div",i),n=this.options;return this._addScales(n,i+"-line",e),t.on(n.updateWhenIdle?"moveend":"move",this._update,this),t.whenReady(this._update,this),e},onRemove:function(t){t.off(this.options.updateWhenIdle?"moveend":"move",this._update,this)},_addScales:function(t,i,e){t.metric&&(this._mScale=si("div",i,e)),t.imperial&&(this._iScale=si("div",i,e))},_update:function(){var t=this._map,i=t.getSize().y/2,e=t.distance(t.containerPointToLatLng([0,i]),t.containerPointToLatLng([this.options.maxWidth,i]));this._updateScales(e)},_updateScales:function(t){this.options.metric&&t&&this._updateMetric(t),this.options.imperial&&t&&this._updateImperial(t)},_updateMetric:function(t){var i=this._getRoundNum(t),e=i<1e3?i+" m":i/1e3+" km";this._updateScale(this._mScale,e,i/t)},_updateImperial:function(t){var i,e,n,o=3.2808399*t;5280Leaflet'},initialize:function(t){c(this,t),this._attributions={}},onAdd:function(t){for(var i in(t.attributionControl=this)._container=si("div","leaflet-control-attribution"),Oi(this._container),t._layers)t._layers[i].getAttribution&&this.addAttribution(t._layers[i].getAttribution());return this._update(),this._container},setPrefix:function(t){return this.options.prefix=t,this._update(),this},addAttribution:function(t){return t&&(this._attributions[t]||(this._attributions[t]=0),this._attributions[t]++,this._update()),this},removeAttribution:function(t){return t&&this._attributions[t]&&(this._attributions[t]--,this._update()),this},_update:function(){if(this._map){var t=[];for(var i in this._attributions)this._attributions[i]&&t.push(i);var e=[];this.options.prefix&&e.push(this.options.prefix),t.length&&e.push(t.join(", ")),this._container.innerHTML=e.join(" | ")}}});Ki.mergeOptions({attributionControl:!0}),Ki.addInitHook(function(){this.options.attributionControl&&(new te).addTo(this)});Xi.Layers=Ji,Xi.Zoom=$i,Xi.Scale=Qi,Xi.Attribution=te,Yi.layers=function(t,i,e){return new Ji(t,i,e)},Yi.zoom=function(t){return new $i(t)},Yi.scale=function(t){return new Qi(t)},Yi.attribution=function(t){return new te(t)};var ie=S.extend({initialize:function(t){this._map=t},enable:function(){return this._enabled||(this._enabled=!0,this.addHooks()),this},disable:function(){return this._enabled&&(this._enabled=!1,this.removeHooks()),this},enabled:function(){return!!this._enabled}});ie.addTo=function(t,i){return t.addHandler(i,this),this};var ee,ne={Events:Z},oe=bt?"touchstart mousedown":"mousedown",se={mousedown:"mouseup",touchstart:"touchend",pointerdown:"touchend",MSPointerDown:"touchend"},re={mousedown:"mousemove",touchstart:"touchmove",pointerdown:"touchmove",MSPointerDown:"touchmove"},ae=E.extend({options:{clickTolerance:3},initialize:function(t,i,e,n){c(this,n),this._element=t,this._dragStartTarget=i||t,this._preventOutline=e},enable:function(){this._enabled||(zi(this._dragStartTarget,oe,this._onDown,this),this._enabled=!0)},disable:function(){this._enabled&&(ae._dragging===this&&this.finishDrag(),Si(this._dragStartTarget,oe,this._onDown,this),this._enabled=!1,this._moved=!1)},_onDown:function(t){var i,e;!t._simulated&&this._enabled&&(this._moved=!1,li(this._element,"leaflet-zoom-anim")||ae._dragging||t.shiftKey||1!==t.which&&1!==t.button&&!t.touches||((ae._dragging=this)._preventOutline&&Pi(this._element),xi(),Xt(),this._moving||(this.fire("down"),i=t.touches?t.touches[0]:t,e=bi(this._element),this._startPoint=new k(i.clientX,i.clientY),this._parentScale=Ti(e),zi(document,re[t.type],this._onMove,this),zi(document,se[t.type],this._onUp,this))))},_onMove:function(t){var i,e;!t._simulated&&this._enabled&&(t.touches&&1i&&(e.push(t[n]),o=n);oi.max.x&&(e|=2),t.yi.max.y&&(e|=8),e}function de(t,i,e,n){var o,s=i.x,r=i.y,a=e.x-s,h=e.y-r,u=a*a+h*h;return 0this._layersMaxZoom&&this.setZoom(this._layersMaxZoom),void 0===this.options.minZoom&&this._layersMinZoom&&this.getZoom()t.y!=n.y>t.y&&t.x<(n.x-e.x)*(t.y-e.y)/(n.y-e.y)+e.x&&(u=!u);return u||Oe.prototype._containsPoint.call(this,t,!0)}});var Ne=Ce.extend({initialize:function(t,i){c(this,i),this._layers={},t&&this.addData(t)},addData:function(t){var i,e,n,o=g(t)?t:t.features;if(o){for(i=0,e=o.length;iu.x&&(l=s.x+n-u.x+h.x),s.x-l-a.x<0&&(l=s.x-a.x),s.y+e+h.y>u.y&&(c=s.y+e-u.y+h.y),s.y-c-a.y<0&&(c=s.y-a.y),(l||c)&&t.fire("autopanstart").panBy([l,c]))},_onCloseButtonClick:function(t){this._close(),Ni(t)},_getAnchor:function(){return A(this._source&&this._source._getPopupAnchor?this._source._getPopupAnchor():[0,0])}});Ki.mergeOptions({closePopupOnClick:!0}),Ki.include({openPopup:function(t,i,e){return t instanceof tn||(t=new tn(e).setContent(t)),i&&t.setLatLng(i),this.hasLayer(t)?this:(this._popup&&this._popup.options.autoClose&&this.closePopup(),this._popup=t,this.addLayer(t))},closePopup:function(t){return t&&t!==this._popup||(t=this._popup,this._popup=null),t&&this.removeLayer(t),this}}),Me.include({bindPopup:function(t,i){return t instanceof tn?(c(t,i),(this._popup=t)._source=this):(this._popup&&!i||(this._popup=new tn(i,this)),this._popup.setContent(t)),this._popupHandlersAdded||(this.on({click:this._openPopup,keypress:this._onKeyPress,remove:this.closePopup,move:this._movePopup}),this._popupHandlersAdded=!0),this},unbindPopup:function(){return this._popup&&(this.off({click:this._openPopup,keypress:this._onKeyPress,remove:this.closePopup,move:this._movePopup}),this._popupHandlersAdded=!1,this._popup=null),this},openPopup:function(t,i){return this._popup&&this._map&&(i=this._popup._prepareOpen(this,t,i),this._map.openPopup(this._popup,i)),this},closePopup:function(){return this._popup&&this._popup._close(),this},togglePopup:function(t){return this._popup&&(this._popup._map?this.closePopup():this.openPopup(t)),this},isPopupOpen:function(){return!!this._popup&&this._popup.isOpen()},setPopupContent:function(t){return this._popup&&this._popup.setContent(t),this},getPopup:function(){return this._popup},_openPopup:function(t){var i=t.layer||t.target;this._popup&&this._map&&(Ni(t),i instanceof Be?this.openPopup(t.layer||t.target,t.latlng):this._map.hasLayer(this._popup)&&this._popup._source===i?this.closePopup():this.openPopup(i,t.latlng))},_movePopup:function(t){this._popup.setLatLng(t.latlng)},_onKeyPress:function(t){13===t.originalEvent.keyCode&&this._openPopup(t)}});var en=Qe.extend({options:{pane:"tooltipPane",offset:[0,0],direction:"auto",permanent:!1,sticky:!1,interactive:!1,opacity:.9},onAdd:function(t){Qe.prototype.onAdd.call(this,t),this.setOpacity(this.options.opacity),t.fire("tooltipopen",{tooltip:this}),this._source&&this._source.fire("tooltipopen",{tooltip:this},!0)},onRemove:function(t){Qe.prototype.onRemove.call(this,t),t.fire("tooltipclose",{tooltip:this}),this._source&&this._source.fire("tooltipclose",{tooltip:this},!0)},getEvents:function(){var t=Qe.prototype.getEvents.call(this);return bt&&!this.options.permanent&&(t.preclick=this._close),t},_close:function(){this._map&&this._map.closeTooltip(this)},_initLayout:function(){var t="leaflet-tooltip "+(this.options.className||"")+" leaflet-zoom-"+(this._zoomAnimated?"animated":"hide");this._contentNode=this._container=si("div",t)},_updateLayout:function(){},_adjustPan:function(){},_setPosition:function(t){var i,e=this._map,n=this._container,o=e.latLngToContainerPoint(e.getCenter()),s=e.layerPointToContainerPoint(t),r=this.options.direction,a=n.offsetWidth,h=n.offsetHeight,u=A(this.options.offset),l=this._getAnchor(),c="top"===r?(i=a/2,h):"bottom"===r?(i=a/2,0):(i="center"===r?a/2:"right"===r?0:"left"===r?a:s.xthis.options.maxZoom||nthis.options.maxZoom||void 0!==this.options.minZoom&&oe.max.x)||!i.wrapLat&&(t.ye.max.y))return!1}if(!this.options.bounds)return!0;var n=this._tileCoordsToBounds(t);return N(this.options.bounds).overlaps(n)},_keyToBounds:function(t){return this._tileCoordsToBounds(this._keyToTileCoords(t))},_tileCoordsToNwSe:function(t){var i=this._map,e=this.getTileSize(),n=t.scaleBy(e),o=n.add(e);return[i.unproject(n,t.z),i.unproject(o,t.z)]},_tileCoordsToBounds:function(t){var i=this._tileCoordsToNwSe(t),e=new R(i[0],i[1]);return this.options.noWrap||(e=this._map.wrapLatLngBounds(e)),e},_tileCoordsToKey:function(t){return t.x+":"+t.y+":"+t.z},_keyToTileCoords:function(t){var i=t.split(":"),e=new k(+i[0],+i[1]);return e.z=+i[2],e},_removeTile:function(t){var i=this._tiles[t];i&&(ri(i.el),delete this._tiles[t],this.fire("tileunload",{tile:i.el,coords:this._keyToTileCoords(t)}))},_initTile:function(t){ci(t,"leaflet-tile");var i=this.getTileSize();t.style.width=i.x+"px",t.style.height=i.y+"px",t.onselectstart=a,t.onmousemove=a,it&&this.options.opacity<1&&mi(t,this.options.opacity),ot&&!st&&(t.style.WebkitBackfaceVisibility="hidden")},_addTile:function(t,i){var e=this._getTilePos(t),n=this._tileCoordsToKey(t),o=this.createTile(this._wrapCoords(t),p(this._tileReady,this,t));this._initTile(o),this.createTile.length<2&&M(p(this._tileReady,this,t,null,o)),vi(o,e),this._tiles[n]={el:o,coords:t,current:!0},i.appendChild(o),this.fire("tileloadstart",{tile:o,coords:t})},_tileReady:function(t,i,e){i&&this.fire("tileerror",{error:i,tile:e,coords:t});var n=this._tileCoordsToKey(t);(e=this._tiles[n])&&(e.loaded=+new Date,this._map._fadeAnimated?(mi(e.el,0),z(this._fadeFrame),this._fadeFrame=M(this._updateOpacity,this)):(e.active=!0,this._pruneTiles()),i||(ci(e.el,"leaflet-tile-loaded"),this.fire("tileload",{tile:e.el,coords:t})),this._noTilesToLoad()&&(this._loading=!1,this.fire("load"),it||!this._map._fadeAnimated?M(this._pruneTiles,this):setTimeout(p(this._pruneTiles,this),250)))},_getTilePos:function(t){return t.scaleBy(this.getTileSize()).subtract(this._level.origin)},_wrapCoords:function(t){var i=new k(this._wrapX?o(t.x,this._wrapX):t.x,this._wrapY?o(t.y,this._wrapY):t.y);return i.z=t.z,i},_pxBoundsToTileRange:function(t){var i=this.getTileSize();return new I(t.min.unscaleBy(i).floor(),t.max.unscaleBy(i).ceil().subtract([1,1]))},_noTilesToLoad:function(){for(var t in this._tiles)if(!this._tiles[t].loaded)return!1;return!0}});var sn=on.extend({options:{minZoom:0,maxZoom:18,subdomains:"abc",errorTileUrl:"",zoomOffset:0,tms:!1,zoomReverse:!1,detectRetina:!1,crossOrigin:!1},initialize:function(t,i){this._url=t,(i=c(this,i)).detectRetina&&zt&&0')}}catch(t){return function(t){return document.createElement("<"+t+' xmlns="urn:schemas-microsoft.com:vml" class="lvml">')}}}(),_n={_initContainer:function(){this._container=si("div","leaflet-vml-container")},_update:function(){this._map._animatingZoom||(hn.prototype._update.call(this),this.fire("update"))},_initPath:function(t){var i=t._container=cn("shape");ci(i,"leaflet-vml-shape "+(this.options.className||"")),i.coordsize="1 1",t._path=cn("path"),i.appendChild(t._path),this._updateStyle(t),this._layers[m(t)]=t},_addPath:function(t){var i=t._container;this._container.appendChild(i),t.options.interactive&&t.addInteractiveTarget(i)},_removePath:function(t){var i=t._container;ri(i),t.removeInteractiveTarget(i),delete this._layers[m(t)]},_updateStyle:function(t){var i=t._stroke,e=t._fill,n=t.options,o=t._container;o.stroked=!!n.stroke,o.filled=!!n.fill,n.stroke?(i=i||(t._stroke=cn("stroke")),o.appendChild(i),i.weight=n.weight+"px",i.color=n.color,i.opacity=n.opacity,n.dashArray?i.dashStyle=g(n.dashArray)?n.dashArray.join(" "):n.dashArray.replace(/( *, *)/g," "):i.dashStyle="",i.endcap=n.lineCap.replace("butt","flat"),i.joinstyle=n.lineJoin):i&&(o.removeChild(i),t._stroke=null),n.fill?(e=e||(t._fill=cn("fill")),o.appendChild(e),e.color=n.fillColor||n.color,e.opacity=n.fillOpacity):e&&(o.removeChild(e),t._fill=null)},_updateCircle:function(t){var i=t._point.round(),e=Math.round(t._radius),n=Math.round(t._radiusY||e);this._setPath(t,t._empty()?"M0 0":"AL "+i.x+","+i.y+" "+e+","+n+" 0,23592600")},_setPath:function(t,i){t._path.v=i},_bringToFront:function(t){hi(t._container)},_bringToBack:function(t){ui(t._container)}},dn=Et?cn:J,pn=hn.extend({getEvents:function(){var t=hn.prototype.getEvents.call(this);return t.zoomstart=this._onZoomStart,t},_initContainer:function(){this._container=dn("svg"),this._container.setAttribute("pointer-events","none"),this._rootGroup=dn("g"),this._container.appendChild(this._rootGroup)},_destroyContainer:function(){ri(this._container),Si(this._container),delete this._container,delete this._rootGroup,delete this._svgSize},_onZoomStart:function(){this._update()},_update:function(){var t,i,e;this._map._animatingZoom&&this._bounds||(hn.prototype._update.call(this),i=(t=this._bounds).getSize(),e=this._container,this._svgSize&&this._svgSize.equals(i)||(this._svgSize=i,e.setAttribute("width",i.x),e.setAttribute("height",i.y)),vi(e,t.min),e.setAttribute("viewBox",[t.min.x,t.min.y,i.x,i.y].join(" ")),this.fire("update"))},_initPath:function(t){var i=t._path=dn("path");t.options.className&&ci(i,t.options.className),t.options.interactive&&ci(i,"leaflet-interactive"),this._updateStyle(t),this._layers[m(t)]=t},_addPath:function(t){this._rootGroup||this._initContainer(),this._rootGroup.appendChild(t._path),t.addInteractiveTarget(t._path)},_removePath:function(t){ri(t._path),t.removeInteractiveTarget(t._path),delete this._layers[m(t)]},_updatePath:function(t){t._project(),t._update()},_updateStyle:function(t){var i=t._path,e=t.options;i&&(e.stroke?(i.setAttribute("stroke",e.color),i.setAttribute("stroke-opacity",e.opacity),i.setAttribute("stroke-width",e.weight),i.setAttribute("stroke-linecap",e.lineCap),i.setAttribute("stroke-linejoin",e.lineJoin),e.dashArray?i.setAttribute("stroke-dasharray",e.dashArray):i.removeAttribute("stroke-dasharray"),e.dashOffset?i.setAttribute("stroke-dashoffset",e.dashOffset):i.removeAttribute("stroke-dashoffset")):i.setAttribute("stroke","none"),e.fill?(i.setAttribute("fill",e.fillColor||e.color),i.setAttribute("fill-opacity",e.fillOpacity),i.setAttribute("fill-rule",e.fillRule||"evenodd")):i.setAttribute("fill","none"))},_updatePoly:function(t,i){this._setPath(t,$(t._parts,i))},_updateCircle:function(t){var i=t._point,e=Math.max(Math.round(t._radius),1),n="a"+e+","+(Math.max(Math.round(t._radiusY),1)||e)+" 0 1,0 ",o=t._empty()?"M0 0":"M"+(i.x-e)+","+i.y+n+2*e+",0 "+n+2*-e+",0 ";this._setPath(t,o)},_setPath:function(t,i){t._path.setAttribute("d",i)},_bringToFront:function(t){hi(t._path)},_bringToBack:function(t){ui(t._path)}});function mn(t){return Zt||Et?new pn(t):null}Et&&pn.include(_n),Ki.include({getRenderer:function(t){var i=(i=t.options.renderer||this._getPaneRenderer(t.options.pane)||this.options.renderer||this._renderer)||(this._renderer=this._createRenderer());return this.hasLayer(i)||this.addLayer(i),i},_getPaneRenderer:function(t){if("overlayPane"===t||void 0===t)return!1;var i=this._paneRenderers[t];return void 0===i&&(i=this._createRenderer({pane:t}),this._paneRenderers[t]=i),i},_createRenderer:function(t){return this.options.preferCanvas&&ln(t)||mn(t)}});var fn=Re.extend({initialize:function(t,i){Re.prototype.initialize.call(this,this._boundsToLatLngs(t),i)},setBounds:function(t){return this.setLatLngs(this._boundsToLatLngs(t))},_boundsToLatLngs:function(t){return[(t=N(t)).getSouthWest(),t.getNorthWest(),t.getNorthEast(),t.getSouthEast()]}});pn.create=dn,pn.pointsToPath=$,Ne.geometryToLayer=De,Ne.coordsToLatLng=We,Ne.coordsToLatLngs=He,Ne.latLngToCoords=Fe,Ne.latLngsToCoords=Ue,Ne.getFeature=Ve,Ne.asFeature=qe,Ki.mergeOptions({boxZoom:!0});var gn=ie.extend({initialize:function(t){this._map=t,this._container=t._container,this._pane=t._panes.overlayPane,this._resetStateTimeout=0,t.on("unload",this._destroy,this)},addHooks:function(){zi(this._container,"mousedown",this._onMouseDown,this)},removeHooks:function(){Si(this._container,"mousedown",this._onMouseDown,this)},moved:function(){return this._moved},_destroy:function(){ri(this._pane),delete this._pane},_resetState:function(){this._resetStateTimeout=0,this._moved=!1},_clearDeferredResetState:function(){0!==this._resetStateTimeout&&(clearTimeout(this._resetStateTimeout),this._resetStateTimeout=0)},_onMouseDown:function(t){if(!t.shiftKey||1!==t.which&&1!==t.button)return!1;this._clearDeferredResetState(),this._resetState(),Xt(),xi(),this._startPoint=this._map.mouseEventToContainerPoint(t),zi(document,{contextmenu:Ni,mousemove:this._onMouseMove,mouseup:this._onMouseUp,keydown:this._onKeyDown},this)},_onMouseMove:function(t){this._moved||(this._moved=!0,this._box=si("div","leaflet-zoom-box",this._container),ci(this._container,"leaflet-crosshair"),this._map.fire("boxzoomstart")),this._point=this._map.mouseEventToContainerPoint(t);var i=new I(this._point,this._startPoint),e=i.getSize();vi(this._box,i.min),this._box.style.width=e.x+"px",this._box.style.height=e.y+"px"},_finish:function(){this._moved&&(ri(this._box),_i(this._container,"leaflet-crosshair")),Jt(),wi(),Si(document,{contextmenu:Ni,mousemove:this._onMouseMove,mouseup:this._onMouseUp,keydown:this._onKeyDown},this)},_onMouseUp:function(t){var i;1!==t.which&&1!==t.button||(this._finish(),this._moved&&(this._clearDeferredResetState(),this._resetStateTimeout=setTimeout(p(this._resetState,this),0),i=new R(this._map.containerPointToLatLng(this._startPoint),this._map.containerPointToLatLng(this._point)),this._map.fitBounds(i).fire("boxzoomend",{boxZoomBounds:i})))},_onKeyDown:function(t){27===t.keyCode&&this._finish()}});Ki.addInitHook("addHandler","boxZoom",gn),Ki.mergeOptions({doubleClickZoom:!0});var vn=ie.extend({addHooks:function(){this._map.on("dblclick",this._onDoubleClick,this)},removeHooks:function(){this._map.off("dblclick",this._onDoubleClick,this)},_onDoubleClick:function(t){var i=this._map,e=i.getZoom(),n=i.options.zoomDelta,o=t.originalEvent.shiftKey?e-n:e+n;"center"===i.options.doubleClickZoom?i.setZoom(o):i.setZoomAround(t.containerPoint,o)}});Ki.addInitHook("addHandler","doubleClickZoom",vn),Ki.mergeOptions({dragging:!0,inertia:!st,inertiaDeceleration:3400,inertiaMaxSpeed:1/0,easeLinearity:.2,worldCopyJump:!1,maxBoundsViscosity:0});var yn=ie.extend({addHooks:function(){var t;this._draggable||(t=this._map,this._draggable=new ae(t._mapPane,t._container),this._draggable.on({dragstart:this._onDragStart,drag:this._onDrag,dragend:this._onDragEnd},this),this._draggable.on("predrag",this._onPreDragLimit,this),t.options.worldCopyJump&&(this._draggable.on("predrag",this._onPreDragWrap,this),t.on("zoomend",this._onZoomEnd,this),t.whenReady(this._onZoomEnd,this))),ci(this._map._container,"leaflet-grab leaflet-touch-drag"),this._draggable.enable(),this._positions=[],this._times=[]},removeHooks:function(){_i(this._map._container,"leaflet-grab"),_i(this._map._container,"leaflet-touch-drag"),this._draggable.disable()},moved:function(){return this._draggable&&this._draggable._moved},moving:function(){return this._draggable&&this._draggable._moving},_onDragStart:function(){var t,i=this._map;i._stop(),this._map.options.maxBounds&&this._map.options.maxBoundsViscosity?(t=N(this._map.options.maxBounds),this._offsetLimit=O(this._map.latLngToContainerPoint(t.getNorthWest()).multiplyBy(-1),this._map.latLngToContainerPoint(t.getSouthEast()).multiplyBy(-1).add(this._map.getSize())),this._viscosity=Math.min(1,Math.max(0,this._map.options.maxBoundsViscosity))):this._offsetLimit=null,i.fire("movestart").fire("dragstart"),i.options.inertia&&(this._positions=[],this._times=[])},_onDrag:function(t){var i,e;this._map.options.inertia&&(i=this._lastTime=+new Date,e=this._lastPos=this._draggable._absPos||this._draggable._newPos,this._positions.push(e),this._times.push(i),this._prunePositions(i)),this._map.fire("move",t).fire("drag",t)},_prunePositions:function(t){for(;1i.max.x&&(t.x=this._viscousLimit(t.x,i.max.x)),t.y>i.max.y&&(t.y=this._viscousLimit(t.y,i.max.y)),this._draggable._newPos=this._draggable._startPos.add(t))},_onPreDragWrap:function(){var t=this._worldWidth,i=Math.round(t/2),e=this._initialWorldOffset,n=this._draggable._newPos.x,o=(n-i+e)%t+i-e,s=(n+i+e)%t-i-e,r=Math.abs(o+e)i.getMaxZoom()&&1 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 diff --git a/src/login.ml b/src/login.ml index 2d594b1..da927b2 100644 --- a/src/login.ml +++ b/src/login.ml @@ -1,9 +1,8 @@ open Tyxml.Html open Tyx_util -let f request = - (* todo page titles? *) - let page_title = "Pellest|Login" in +let get request = + let title = "Pellest|Login" in let login = let submit = button ~a:[ a_id "submit_login" ] [ txt "submit" ] in let login = make_input_text "login" in @@ -13,4 +12,19 @@ let f request = 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 open Syntax 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 geo-posting!" + | _form -> Template.err (`Bad_Request, "invalid form") diff --git a/src/pellest.ml b/src/pellest.ml index f2ba14a..0c45150 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -1,52 +1,13 @@ -open Util - -let home_get request = Home.f request |> Dream.html - -let register_get request = Register.f request |> Dream.html - -let login_get request = Login.f request |> Dream.html - -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 () = 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) + Dream.run ~port:App.port ~error_handler:(Dream.error_template Template.error) @@ logger @@ Dream.memory_sessions @@ 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 "/login" Login.get + ; post "/login" Login.post + ; get "/register" Register.get + ; post "/register" Register.post ] diff --git a/src/register.ml b/src/register.ml index f629fc0..08da6a6 100644 --- a/src/register.ml +++ b/src/register.ml @@ -1,9 +1,8 @@ open Tyxml.Html open Tyx_util -let f request = - (* todo page titles? *) - let page_title = "Pellest|Register" in +let get request = + 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 @@ -16,4 +15,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 open Syntax 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") diff --git a/src/syntax.ml b/src/syntax.ml index 62a0617..74f5f57 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -3,10 +3,4 @@ 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 +let ( let** ) o f = match o with Error e -> Template.err e | Ok v -> f v diff --git a/src/template.ml b/src/template.ml index 5ca3080..23e5266 100644 --- a/src/template.ml +++ b/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,26 @@ 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) + +let error _error _debug_info suggested_response = + let status = Dream.status suggested_response in + let code = Dream.status_to_int status in + let reason = Dream.status_to_string status in + + Dream.set_header suggested_response "Content-Type" Dream.text_html; + + let content = Html.txt @@ Format.sprintf "%d: %s" code reason in + let body = generic ~page_title:"Error" ~scripts:[] content in + + Dream.set_body suggested_response body; + Lwt.return suggested_response diff --git a/src/tyx_util.ml b/src/tyx_util.ml index e516b4b..0d71f9d 100644 --- a/src/tyx_util.ml +++ b/src/tyx_util.ml @@ -1,7 +1,12 @@ open Tyxml.Html +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_input_text id = input ~a:[ a_id id; a_name id; a_input_type `Text ] () 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) diff --git a/src/user.ml b/src/user.ml index 1944b05..357c6b0 100644 --- a/src/user.ml +++ b/src/user.ml @@ -107,8 +107,8 @@ let login ~login ~password request = let* nick = get_nick user_id in let _unit_lwt = Dream.put_session "nick" nick request 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 +120,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,13 +141,13 @@ 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 @@ -174,20 +174,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 diff --git a/src/util.ml b/src/util.ml index 36c635c..e69de29 100644 --- a/src/util.ml +++ b/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 From 9142651ec0265fafff4d2769cc0c2213e2165e39 Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 6 Dec 2022 00:25:40 +0100 Subject: [PATCH 44/81] upload tiles --- src/content/assets/img/favicon.png | Bin 0 -> 1859 bytes src/content/assets/img/grass.png | Bin 0 -> 4889 bytes src/content/assets/img/papy_bottom.png | Bin 0 -> 855 bytes src/content/assets/img/papy_left.png | Bin 0 -> 1303 bytes src/content/assets/img/papy_right.png | Bin 0 -> 857 bytes src/content/assets/img/papy_top.png | Bin 0 -> 838 bytes src/content/assets/img/tree0.png | Bin 0 -> 941 bytes src/content/assets/img/tree1.png | Bin 0 -> 865 bytes src/content/assets/img/water.png | Bin 0 -> 1523 bytes src/content/assets/img/wheat.png | Bin 0 -> 671 bytes 10 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 src/content/assets/img/favicon.png create mode 100644 src/content/assets/img/grass.png create mode 100644 src/content/assets/img/papy_bottom.png create mode 100644 src/content/assets/img/papy_left.png create mode 100644 src/content/assets/img/papy_right.png create mode 100644 src/content/assets/img/papy_top.png create mode 100644 src/content/assets/img/tree0.png create mode 100644 src/content/assets/img/tree1.png create mode 100644 src/content/assets/img/water.png create mode 100644 src/content/assets/img/wheat.png diff --git a/src/content/assets/img/favicon.png b/src/content/assets/img/favicon.png new file mode 100644 index 0000000000000000000000000000000000000000..418307c56ca8c8eccda6535ff9db4743fef30285 GIT binary patch literal 1859 zcmeAS@N?(olHy`uVBq!ia0y~yV9)?z4mJh`hMs>rav2yHTQZ%U13aCb6$*;-(=u~X z85lGs)=sqbIP4&EH2!jzlBlb7hXu<@KQR|qnWbH>8v<@|t+kpF^NZD2YLbY!`@yXb z9vn})dhlpuID5FGz#oRflA@rJi9-LUi$oo%D7e#K{#~y8J;TDdv{jNb7(&h(P1?9( z#>sVEbJueyHPrPi@K0JM=dZi$q2<1J4zS-JYD^n(Wi650XZb{*fn`&RYu?>?LN%O|=OEpRWfe9geXz?S6g?!xdN1Q+aG zKAC}mfwRCPvY3HEPZ@+6E0)@qF)%Q&mw5WRvOnWt5f(8B@VT^;fq~V*)5S3);_%*? z^%+x2Wsb+6SG;^RYMw`d(&N5k$99QM>D&C~O}pDdPEq5)b+SB5Qr;MutDTzK(U!Sj zZnNZ?f0B+OuJs*X-Dh76GmAZU)?yoHQTEF3$5T#j+w<&I<@e+BURLJretvHD{QvKM z*4fQ}|GUzD{`>ErAMnUgL+}sxQ$#7o0zP8c@@moIWJbCEi0yiQkvA2SpPx&95+u?YvU=64Sv<~K`sSisU$up97Pa$9G;ueX zr){{uC}2hW)2GXLoL8;dwajCQmH7iHsdJ~^nuP`>t=hLQ`s`U&<5vgO8Z|pOKc!vC z%+m{~t=;bB<+JndGAXHZY5Z$eo?M<#5TU@zq@0y=$7c0Ak?Oro`mDlD=Fh*}y|E** z@j!QV4zBn z?)KXu3I>xHcl0uGYNbU~$A4I!(3xA`c%b7>p7BqvqB~KxPj&C!cpKo1R85|L0+`{9$YW@3j4STrQ`SO z&bP4J7w&3$a7?@XO`hxP>Bolop{h(vpItMVUBGAKD*OuyrPNJ6KhGkXW^H zr^^0%Bjy7Ah&Q%#8_z~J&2DPXz5V0wX}-bDd|&!QFq_$YCg*D_ zx2wnH&pCK7l`m;y>yDUMvzZlg5zI0tHoTa_@{O6%ai*^F^wr%FISZQ?DmEWFWH!5c zFZ&#$1-9KxFO454Z8$%zEHP2q+4&gLvEz#N`wz2KuWn3lNZ+h;_rK^H)_nptc?W)4 z@_zbkEg|oJO66s${fEtr_V-->{uaHE{Bx5k9~YOx#1G38-)lbD+0#^$CYJj1#)6d* z^J0ZK?O9nZG_-^kFV4RF;~x7Qvj^?Fa}{|kPKNNDuf5>remy8eg_d0AwHkl^o+UzdM5_w?zqri1tMuQ#Wrws*Mkva#I?_Ip>E6Q&z^>{0%;yF21H zFf=qamMscwUbKk0{7hO%Xld`cbE;Ravn literal 0 HcmV?d00001 diff --git a/src/content/assets/img/grass.png b/src/content/assets/img/grass.png new file mode 100644 index 0000000000000000000000000000000000000000..31641ec2c4d4bb816a3e778883c0e0ef10a94d1f GIT binary patch literal 4889 zcmeAS@N?(olHy`uVBq!ia0y~yV9)?z4mJh`hMs>rav2yHTQZ%U13aCb6$*;-(=u~X z85lGs)=sqbIP4&EH2!jzlBlb7hXu<@KQR|qnWbH>8v<@|t+kpF^NZD2YLbY!`@yXb z9vn})dhlpuID5FGz#oRflA@rJi9-LUi$oo%D7e#K{#~y8J;TDdv{jNb7(&h(P1?9( z#>sVEbJueyHPrPi@K0JM=dZi$q2<1J4zS-JYD^n(Wi650XZb{*fn`&RYu?>?LN%O|=OEpRWfe9geXz?S6g?!xdN1Q+aG zKAC}mfwRCPvY3HEPZ@+6E0)@qF)%Q&mw5WRvOnWt5z-U2SKhRNfk9Br)5S3);;`y< z&&{#N6K{O1FQ0!oeb@7I`3I^GFnbCpaC9koOf2&8Ej-n?I%s9rTi2j_R^2tcDHBWW zoXS>)tlH$cbB$NXMz1MrJeGI{D={#!D4sbm`(1UpMe_HTmm{Bi*R4zXGhe@A@A8KV zhwMXld}S)!xI8PX>@4fK)#55Y#XMi!%<($%kHJ_+V&9yDjf?+GZFcUKZ*%DUr*Q1v z+J^})C48UKTz<(Z;COWS+E3YSYS;kC(+)@VA$2=iPWtq2NUC@_o@4?Kj@gQrN|@Ok03|!8z+c zVZEz`p5*yYSi=0oE7(l*liddXx(x@r3?Bw9E>FHO{Yt;i?0o4zNscCb7sSg~ykL||?KS-B*V!keBlcJ47{An~r)C$IO4Q$0JZGD?R`b-XTiZH*_Z6idel$Pq z#8IiwwvHtWJlL9Ey;N*|y?cW|kKL?`&sg6+7Rn6MUC6nDU-h79|E|YaK*T?*?ITNgOTqmBbzWtYlNX9t@p;ae__wg{we8!dO%LPTA}e>L2c+=*owfY; z9Rr&kKD$z1%1N5=e!6S<^&*>Wb&m3d+l&`&)U=Gw{G6mG@n99x-#)juf6m_1-Osxy z`{jxbGtGNkPdvLew3$pb@#VaK{Y15(o#B<%q*-SdZp@Ke&#_*8$={ww_a?nsEgEID ztD3hcRkF@v`K?t4o*&t}u&*lQ^+t8xi5EIb8~)!ql=@=Z!QWD)QVZ)Btf*N!^74YTVoW;RsT7*?3J9nXUmf1vx;SnUWh)u zAJ$WDJmr^i`RRP~8#btDvZO+TQ&bB{(q5PH~cjsL_EHrU@N!Y^WoV|9*HeDT$ z1fM8g{b=arQZiThhUk{<+>5epkH-2dF}b9@oZRuDHSuSH=RWhrJNBk*+uZ$km%7b| zE$y~h$2UZ-KNxnw>&dnG&p)hHsZ>^%NKLt|c{itZefXE-nql6r-1(|K7u?_L5MZtK zyDM?_Cd-@%d)p&-zU>e#+2*{JFWuzgeAOGjnI~}z*4Ztv+s?9eX{F{#zGpiYIp-^# zQqR7kvFOhhwOw3!f|FuyEC2o{ve5a-vJ)Kl?zOGAin$roqM*(kWUjD##Y=O>B6Wq> zXE}ABMdojNk-`0UuHZM;7oIJ$dJ?ZSBWFz7x4k!V{-NniTXO@Z2X*b%Kk?6G`9#T& zzTSIF`*zO}s+pl&;%;8&Ij>jaok+`1hOY&^)scy7om=x;wl8|$_;-owpM~y!!WMj& z`Kon*UH9CY%wG+TcONnN?>4DWG>re=ahxKN1EA=9aW(iGi?_qbI<9~7OB93zt z+!@dET-l|1*K>n^)+S}&c*l~phwCOQ)|`Ivmhke(u)qQkk zvHmfU;?pmVO-Ng~ac<)GPkg^FF>LJgJSl)}#cR3Uwr=x9Pb3~n+v%X^n5%jt zsrSyyiSxNb(}}$y-{$D;n1|RTpB9+H_*Q%SN`W$u8rUC zudgiJ+P-|+xx5u^eFr~tzP-uz`{RryUzY4!Xd!xJ@|;gMHD7(rJtisgw(HlONAJRp z*w1`WcQYt=d&QD-<*;wbv2V6xkez%_e&g5t^^4w> zw3u(pl#4ErxP1SmWvS`A*T$F1pNEt>?wfo;R{GAWgg?((QUwy^9jnZi?cU`QbK0}X z@>816%un7t$v@L7Lj_K>R75|l3txOs zBGE5uxKQ%QU|~@G6_V({YtzvrCd!^Ph`iZ_j7N2wlu@j-K8!_2Ao( zmPNcS&Tg^6onqtQrLbznN>FS(3Kz^@mVr zt!Fd*t-gGoQ>3{$B~^@-A2D(C1lMf9q08*N-!Xzc0?X_3ej-+gr&a zD;L#H4-4$2ngyJAOY@^l+}Ej9Jh7<1s%RkG=UNcJrM`ZNkjIyLFrVl;o>! zF?*Lh)7V$h#%cB=wco2==3ZC5jpDg>o%(-FPZjTVz4)dqQEkCd=-O|&#`D|u74B?p ztdAxtZx9l$xHOrg^r&zN=dmd}rapi3I{3-4$?`o9wkXbFpTgWJ%ep4)_y-G@QyuHH zKIXIiI6UiR$?U6+o(Z-_=Q$TKYW+92-hQLxMz-m%+YE)K3-zOq*!p|6?obzOp0=#b z?<$W=*XrOqc`e`Deu$h}u+VawOPn%0m-$AX%~Muw-f?Whos|=k`|C9_i=4lmmiWfK z%9oeD?O5e6GZh2guazBKj{A5%e3wf3c+2qb>Iwh0OW(tse3{9*>RSrEe|Z_~SoKoK-Cp>|U!g$tBW7y*I3Mv{*?QoqYLL~L z8-e~Te`5~3opODXp`h*T^HP&G9In@1Syk{`R_X8j@IP;S0^H`+YN%Tr#;UX%O%u7k&N^z}|AO29|6Z2(h&A!T(zfJdHUF@+>5KR+o3YWwsxzkTi2b|=@75LYo2wYP z>qK9%Iml-!6ZvM*!DtSB%Rd=SE*JjqI~w=$!&=8XuLIUQ&C>19@p|$?o!umm+3m6p zYh+2|uX5Fw{KrfBdH-Dr*3sT%o_t3~>85vKp@R+U_e8Jlv6t*NzbJF~u<-ex{dR8q zW*WX&u5wv6M>OF7-o~g4J>9AsTuQ3mwdbE z&~?Vt&<)?i!!3WypXXfPudt@T-~7Z!nM~FzVjtt0{+2n0mz{`6Hg*k({AJGc>%Qj~ zpM-beKVlN}w3qyfZ+pUfT;;yndhb`a+kgB|yWs6R<9SJ)>;KED%T{Fsch@X3EbPx~ zQ+Yh6>b&4S+eM3A7YD97>=Sipfs2%PS?26Nk7r~o;;=hWFq`$+UY=CpO%KKXZE&2V zWbOOSuO*VR>3ee9eff#zieCSJUtIfbb?}_76<4|%xnGu7{o1Iy*W&PWK1uB_LCVXR zDo-D@fvXA4dUe!4!Ip0#}`x@x?TkMI4QuM_+tv_Tn{_j(iZ8>4vXnRZGrJ)aN zkk+fis=Lm8Om;Mwb4e!8qns_|k>%0ac8je(|F5dPk>@d*cW%Y|Z#gV3C)*atHLMSu zu5x#c+D*9$KI$*xIm1p*%G$B4JYl`Yqxm_;KRgsqO?vmd?N>KP@kZq{I#o7me6AX-$4iQ3|H|(Fp6d3# zeaFT_^74mjAMLT z33rE@;KzScKD8=xm`*k9Nax-Bz1_suYo*qrTGxt;3G!BtX3u(7=p0n>XU*XmY~>=G zDnAGnE^M#p6BEoWYU2+&^2I){GP?Q`KU+>8_Yt8lTMq9tb^U*zsoYaJw!KbmDfd`k7(EPbhV^TEd(W-gNFW=mH*yKtdwRLWurKBt^j1<%u2^3Q$n zWeIH6^iumBu5pVsufXm5k%<$9eX5r1uvFPM@xs0}7q2TV@>Z;}NHp2H!@#9SSt|A8 zYpLkD7vkj==4tKS)ciOS0c@G`h3Pee~oFcKonQX|-Y|%Rh$&ZBnKZ z0rJyK_S+w^Y)?D$bMNmHw?$u_=Jd2xDlLAM&bBn)W&4+7hj|5-rdddAd>1yQpC?PX z;~x85u3wv{+^qgR2dG+2`G;T$<{_ypi#&+Vm>cwp4Y3j#YZca%Ey?B#D%D}PH{zM=@ z*RM+dYrGosx3@f=FpD=yaG_N1nW#&#XJ4I}(8GM{xb~y{chq(~&Uig5<@Ccznwu($ z4n6uazhKWdF`W6>|6feAPd%I@m?#^(aiQU_|LuR) zYJRMAQ0M8*cqykbX`B1r?2S7e_t+`j?tYPbFk#MSt2o2oKbRWjC+rnp`2RuSu?yWD zDOD4{t>!ZPmGY*2e)^8tnn&$*B=_4d5V4&&Y0dQX1;&fAZGQ#&7zA87o_$4WdHvad zx~K`qoF~P0UKKpL*|_BS%k#DuZ!4EPxN)NE-f@=ddHYs)l=%G4?w9dgR4=!|#zy(a vR<&DPoc~;1K5j1la#bYK^3Ji({~6k!a9I_GS)?#9Ffe$!`njxgN@xNA_((=D literal 0 HcmV?d00001 diff --git a/src/content/assets/img/papy_bottom.png b/src/content/assets/img/papy_bottom.png new file mode 100644 index 0000000000000000000000000000000000000000..2a1eb0c94e1f01f249c7f1a36a453f7478706704 GIT binary patch literal 855 zcmeAS@N?(olHy`uVBq!ia0y~yV9;P-UFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciOEZSM8Cnnpv_#X37`Lw&)>*MmQQ%>do=U=y-n8>3q zq`-)de#A5FJ+m}CVP6!xuS;)3-RuoZ>f)n5-u`GZ!+Q>kr@?fGynhV30dM>J&t{uB zUbZTnCAHz;wxDQ_ry&!LERSH&mRO~BWB1vGdxOQL#8)pin_={A-TO>~=_#LV(pdev zeT(H})-H>j_5AC?lk)GUdH#JAJtwBIeYK+I-8FmF<*v0dC%d)&6?^R|Wc6NE+*qhm zde&xn{!C}b(x+ZoTHBg#=`4x;$YrJs8B!It@r0LmD}B?b@v@TDjl-->elG#x3ac8eqgeR_gZVx z<~e`&CwXDiII r4z724p?EPP>-upUl;HcJ)2Myf%uVBo+Ro<;3=9mOu6{1-oD!MFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciV9 zv}A6)K2f1!$H8Snd-N6v9`NvW*|_jPy{*UvbK4-+rDgkUvakQ&eBjbdjRheqeajZb zJ&DO-+Z&g9=44J-=3%x)H7un6<28xIVvW(w1JWN z*y+dbEf4UhEYDf)d~mXRs8(0f_SJhV{?FT)VGlmm_%VpBh>(nn zI$9Pi@a^|fzQ~(*D*wpI*KVG$&zZ}E!|GSjr1<*G5@*%wj@Pe6RUGav<|~;iB3$^Y zi@C9xRXI*K{DWh;wjuMA>zDti?$N2JJr?9~(J3|ElU1DS2;0lN%kRsVmsCzYwE6hn z?dQ#p9p81g>L*XbOPxHowaXQvycPy5c(q41c=cURrBEMBk6V*MBv!Fn%=61!8(?we z!`aJwc)HI@_NbK!+veFEU6EwbYbVd!rR6l$H#*m2>Q?n7WDA64?=4PX z*)enR{VDrDS8~6wKGM5OWy0RwEQwI}zD?d(1O3;)tK{TwDxUc(j{{C3j$1xy!< zYTC>n%wR0wxn%XNQFHgT<;pwO-(!1jqH<-U^@r8d?;OgPJ-(cOk^1Ak@_i@&PI@L& zxlG*nGh@k7u7?~(sX>kZ6rDeR$m+V6ZLn14R@mXLhsEuCZ~gvosP4+Gy&~5Wg&WFr z^ERtjpHAkyFK?jWVgGBok8p$7tHTfP|5cbbKdSC-s_AAohKIRF&ihy{Yh%cd{pa^- z!lRPMd!_}gKfCHbQy~AU2CW5LE0|!^0a@)2?3MCwJo8eUjxaDVFnGH9xvXFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciKPA7hJ8 z>o&}e&nvq*>1fWRUQ6}>&Zsjp=bAQ#G{=7I5^>T_o0nF=V0(F|pJB%==SL5Hn?&5_ zZ;!CaF;L(2|JJ{@ntGi>6?SKrs=N=5dQ&vPbD8iLq1V4$ImPa64BYR<+FgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciwk zz$k={8vlDQ;P$IEc(%KAO=p<0+y3GitNyoy)s)!qx^+%g;B@13`FyikMM72J?0;)p zi!bS({v``a6Pg4k&x^T{Fhyb3{~W&`HXU!)CGTiI;-r4ni0^B2;VR?$4Q^*kk8i(! zEu_|T!HgBRHL`SGFJdd6_g$Z1O}mPY&)p|iZ@Ahg>KAD~_Pw=i!JYOME3fgWZB~1G zR^E8SL6hI7idLR}d$yTZO?}?dZ%8vQ?07& zOLF&jyB0aVSA4rm#%%wQ+2$QOg{Ax%>5I0o;zsTH_ z*kj+nY$=&=Ba8RC+D|j{zCZii89UcrEtHH&j*K$(U0yjcCc7qOa)pWf$(AS;2POnc cQ2)Rx_09d(2lK#81_lNOPgg&ebxsLQ00NAIaR2}S literal 0 HcmV?d00001 diff --git a/src/content/assets/img/tree0.png b/src/content/assets/img/tree0.png new file mode 100644 index 0000000000000000000000000000000000000000..0ff700414396d9397c4156a16e207cce9c1f82ec GIT binary patch literal 941 zcmeAS@N?(olHy`uVBq!ia0y~yV9;P-UFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ci4%}ex-G4a_v{r8s z)51%Z&#aRxo@tq}cm9>Mvs>kSA01M)>3-~gJMzOCFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciFMKHPQ;o{RjhO`p7|p7t-`wZN8I)FUvK)}^93}&_Ec8b+aO$=da^>%wm~PR#Z!BM#5wLv z#*o963c3xN_w$!bx$Au;p+0i1|K3Cf1+$l#A|Mr?E7mrL@IG(6B4u(oQqi;_&w_i2 zhyjlu_fGLWXD1Zwv`%*p$o^EJb-zJv;}N!Okvlv(Iai%F{JhCJZRc@Y(X%mAnEtJ0 zQ*C%yFw5;BgLv~~r*n*YeCmx$j`47-OBy!my_rav2yHTQZ%U13aCb6$*;-(=u~X z85lGs)=sqbIP4&EH2!jzlBlb7hXu<@KQR|qnWbH>8v<@|t+kpF^NZD2YLbY!`@yXb z9vn})dhlpuID5FGz#oRflA@rJi9-LUi$oo%D7e#K{#~y8J;TDdv{jNb7(&h(P1?9( z#>sVEbJueyHPrPi@K0JM=dZi$q2<1J4zS-JYD^n(Wi650XZb{*fn`&RYu?>?LN%O|=OEpRWfe9geXz?S6g?!xdN1Q+aG zKAC}mfwRCPvY3HEPZ@+6E0)@qF)%Q&mw5WRvOnWt5i-%UV_oRaz`*>$)5S3);_%jp zx07xe@Jz{J-SK)$|HbzA$zK(#9AtLaFWID1=CLC?%_zkwXYJRGQPK7Pe%)K zP7rF$lKxyXnSFKhjJqFHly2Ui@A~90W7mH18FyTsJShJavoNB(pp-%U!=*>xkN)pA z2xFKiJLhL{m6LBSx5K_J<{t%*uQtwQoUrrbkNpR8eyQ-6R|~A)-0_ETedvdnic>as zKJLGeFFaA3VOH6f)p-+-obL9Ik#SM6ch_{Z|H zu<-Wv+cD-1&nAmJ+V~{Smf`G^zKI<6%Z~EAG-{S@ofF0o(P;T;R>Xl-a~S3vde1af z=Dvw}!__*4S*t#*-XQTuUnc2H^9*LeYdrIgocXJ!lz+ifNT6EeIO87Cg?e&_xVR7A zv9&xP{4AlxWCHhAnY?DfvS*g92Aj*7WP-vMH(7R_=>J`_pYe>p$VsV(Y%@B0!ZfDL z)S7y5Z|8|}!OH#be{SoXzeTyf%4lU7hq$v;+$@F~k=P|YcW-Y!8Cnl0%WHmK zHp6y~(;k0}88l4H`deQFe41RGW2~|8)Se%@7m5vIRwM zZ}{92O@+7?pAC6ceaWnKvy;Voy);&>O-}iuuP**diK{u+pSUeF;b5Z1_jHEfhkc6- z89KDo%J&?13YW7ii&5EVIBVs_>wWA&%Rfm!$!4@vzmnPVBzD*RjkhP*r3q|2{Xm0R zHBvw2L_c>&hs!+YQe#G~qhak&>q`00JyE^4KW#>i;$hLKmHezU3kGaxqX^HpHRW$D;I0F zI%{)pJ<1~(CCcsA?l|#=yG9QScg7Y)At7$j14Y{pFgLnPF`W{f&&Q$p%we~sNs{cW zAO`uJzt|Q%dR)l=XTyomov9a2Em`b#txs=C(BX{qi~@%Pv;X?KoVB#H%DCd!J;~4g j#FhhJTplr+|7Y!7bEV8%{^S(~1_lOCS3j3^P6rav2yH^D>>C12U7785lGsmQFmY z?Gh+)te#C!nR`l#VYgy;;G&e3foaW0C7xy%zc-YBb#BMqYIWajr;a&AcJ!`q{ok;5 z)6ywQs*yjLYjT&owp}Nc`RvZQ+IrjPHu>*s^;*<)rk1~UQ;h#GCq+qa=G@u+CN{#$ z=J6%D@IJjY`SN4URqOhrvr6{9yuNqU{na~WO~16RX_ni=#8m5f8+;BQS(ToBPb4qg zGTHNogT=EG4Tq*jnKRd2n#23Uck^VgK1Yx5Jt_Y;{A>?Bcar-%r~Buyz`y4f?^l_l zcgDy2?WDWC-ji4gm1c-U9y_!+KFiT)^&9CQAAL6}$*Jbg7V5Lu^yG-N@K%l3%R$DA zmOtI7@$%09=P%RR*qYxxw76pb>t8m%NzUQx)85z1{rY!Z@QU4m%7t&@C(d!Z=Xzf& z`(kZIZ2RTzO=<5A++-`cce^e5kH^+c&NF%T%yBp^vnAH~veSgC?=6p)Pl%cvU&6Y( z`hxcNXz~4wKCd%$cV;!@GcYi47I;J!Gcf2WgD_*oQu{In28QdNE{-7)?#X}tPkU&8 zSb@#we0;ZIg8>hZncZatKAR1f-DEv7d3b*bq{w{PDUmK>pdBn_9dhw}Q_P-*8 Date: Tue, 6 Dec 2022 00:25:44 +0100 Subject: [PATCH 45/81] update style --- src/content/assets/css/style.css | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/content/assets/css/style.css b/src/content/assets/css/style.css index ac08288..7d7808b 100644 --- a/src/content/assets/css/style.css +++ b/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; } From 238e6fba7557e454927b3f2706136621915cced8 Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 6 Dec 2022 01:00:39 +0100 Subject: [PATCH 46/81] clean code --- src/dune | 2 +- src/home.ml | 10 ++++++++-- src/login.ml | 10 +++++++--- src/logout.ml | 8 ++++++++ src/pellest.ml | 4 ++-- src/register.ml | 14 ++++++++++---- src/template.ml | 13 ------------- src/tyx_util.ml | 2 -- src/user.ml | 10 ++++++++++ src/util.ml | 0 10 files changed, 46 insertions(+), 27 deletions(-) create mode 100644 src/logout.ml delete mode 100644 src/util.ml diff --git a/src/dune b/src/dune index ce55c43..ba4e8db 100644 --- a/src/dune +++ b/src/dune @@ -5,11 +5,11 @@ asset content pellest - util template home register login + logout user syntax db diff --git a/src/home.ml b/src/home.ml index 5a0c562..741aea4 100644 --- a/src/home.ml +++ b/src/home.ml @@ -1,9 +1,15 @@ open Tyxml.Html -let get _request = +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 page = div [ about; login_link; register_link ] 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 ] + in Template.render ~title ~scripts:[] page diff --git a/src/login.ml b/src/login.ml index da927b2..d6a83b8 100644 --- a/src/login.ml +++ b/src/login.ml @@ -1,12 +1,16 @@ open Tyxml.Html open Tyx_util +open Syntax let get request = + let** () = User.assert_not_logged request in let 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 + 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:"/login" ~items:[ login; password; submit ] ] in @@ -15,7 +19,7 @@ let get request = Template.render ~title ~scripts:[] page let post request = - let open Syntax in + 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 diff --git a/src/logout.ml b/src/logout.ml new file mode 100644 index 0000000..97a8a30 --- /dev/null +++ b/src/logout.ml @@ -0,0 +1,8 @@ +open Syntax + +let get request = + let** () = User.asserd_logged request in + let title = "Logout" in + let%lwt () = Dream.invalidate_session request in + let page = Tyxml.Html.txt "logged out" in + Template.render ~title ~scripts:[] page diff --git a/src/pellest.ml b/src/pellest.ml index 0c45150..b40e123 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -1,13 +1,13 @@ let () = let logger = if App.log then Dream.logger else Fun.id in - Dream.run ~port:App.port ~error_handler:(Dream.error_template Template.error) - @@ logger @@ Dream.memory_sessions + Dream.run ~port:App.port @@ logger @@ Dream.memory_sessions @@ Dream.router Dream. [ get "/assets/**" Asset.get ; get "/" Home.get ; get "/login" Login.get ; post "/login" Login.post + ; get "logout" Logout.get ; get "/register" Register.get ; post "/register" Register.post ] diff --git a/src/register.ml b/src/register.ml index 08da6a6..700cb89 100644 --- a/src/register.ml +++ b/src/register.ml @@ -1,13 +1,19 @@ open Tyxml.Html open Tyx_util +open Syntax 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 ] @@ -18,7 +24,7 @@ let get request = Template.render ~title ~scripts:[] page let post request = - let open Syntax in + 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 diff --git a/src/template.ml b/src/template.ml index 23e5266..fa99a35 100644 --- a/src/template.ml +++ b/src/template.ml @@ -20,16 +20,3 @@ let render ~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) - -let error _error _debug_info suggested_response = - let status = Dream.status suggested_response in - let code = Dream.status_to_int status in - let reason = Dream.status_to_string status in - - Dream.set_header suggested_response "Content-Type" Dream.text_html; - - let content = Html.txt @@ Format.sprintf "%d: %s" code reason in - let body = generic ~page_title:"Error" ~scripts:[] content in - - Dream.set_body suggested_response body; - Lwt.return suggested_response diff --git a/src/tyx_util.ml b/src/tyx_util.ml index 0d71f9d..5a27465 100644 --- a/src/tyx_util.ml +++ b/src/tyx_util.ml @@ -5,8 +5,6 @@ let csrf_tag request = let token = Dream.csrf_token request in input ~a:[ a_name "dream.csrf"; a_input_type `Hidden; a_value token ] () -let make_input_text id = input ~a:[ a_id id; a_name id; a_input_type `Text ] () - let make_form request ~action ~items = (* TODO labels ...? *) form ~a:[ a_action action; a_method `Post ] (csrf_tag request :: items) diff --git a/src/user.ml b/src/user.ml index 357c6b0..752f6bd 100644 --- a/src/user.ml +++ b/src/user.ml @@ -158,6 +158,8 @@ let list () = ) users ) +let is_logged_in request = Option.is_some @@ Dream.session "nick" request + let profile request = match Dream.session "nick" request with | None -> "not logged in" @@ -211,3 +213,11 @@ let public_profile user_id = user.nick user.nick in Ok user_info + +let asserd_logged request = + if is_logged_in request then Ok () + else Error (`Forbidden, "you should be logged in") + +let assert_not_logged request = + if is_logged_in request then Error (`Forbidden, "you shoudn't be logged in") + else Ok () diff --git a/src/util.ml b/src/util.ml deleted file mode 100644 index e69de29..0000000 From 00c9c587c72aa56a04b76cc4f2a2d313a727ea2d Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 6 Dec 2022 02:31:33 +0100 Subject: [PATCH 47/81] get display to work --- src/content/assets/css/style.css | 4 +++ src/content/assets/js/dune | 8 +++++ src/dune | 28 ++++++++++------ src/home.ml | 24 ++++++++------ src/island.ml | 29 +++++++++++++++++ src/island_client.ml | 55 ++++++++++++++++++++++++++++++++ src/logout.ml | 2 +- src/pellest.ml | 1 + src/user.ml | 4 ++- 9 files changed, 135 insertions(+), 20 deletions(-) create mode 100644 src/content/assets/js/dune create mode 100644 src/island.ml create mode 100644 src/island_client.ml 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") From 7cb03b87799c6ea796f6d0dfc86f7c73534c2fec Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 6 Dec 2022 03:08:30 +0100 Subject: [PATCH 48/81] draw canvas from a map --- src/island.ml | 19 +++++++--- src/island_client.ml | 89 ++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 100 insertions(+), 8 deletions(-) diff --git a/src/island.ml b/src/island.ml index aee8cd7..a6b2ad8 100644 --- a/src/island.ml +++ b/src/island.ml @@ -1,6 +1,13 @@ open Tyxml.Html open Syntax +let mk_img name = + img + ~src:(Format.sprintf "/assets/img/%s.png" name) + ~alt:name + ~a:[ a_hidden (); a_id name ] + () + let get request = let** () = User.assert_logged request in let title = "Your island" in @@ -9,12 +16,14 @@ let get request = ~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" ] - () + let img_grass = mk_img "grass" in + let img_papy_bottom = mk_img "papy_bottom" in + let img_water = mk_img "water" in + + let page = + div ~a:[ a_class [ "centered" ] ] + @@ [ canvas; img_grass; img_papy_bottom; img_water ] in - let page = div ~a:[ a_class [ "centered" ] ] @@ [ canvas; img_grass ] in let js = script diff --git a/src/island_client.ml b/src/island_client.ml index a4226cc..187b2dd 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -1,3 +1,23 @@ +module Map = struct + type background = + | Grass + | Water + | Black + + let width = 1000 + + let height = 1000 + + let player_pos = ref (500, 500) + + let m = + Array.init width (fun _x -> + Array.init height (fun _y -> + if Random.int 1000 = 42 then Water else Grass ) ) + + let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black +end + let tile_size = 40 let width = 835 @@ -33,19 +53,63 @@ let orig_y = (height - (tiles_per_h * tile_size)) / 2 let grass = Jv.get Jv.global "grass" -let draw_background () = +let papy_bottom = Jv.get Jv.global "papy_bottom" + +let water = Jv.get Jv.global "water" + +let draw_map () = + let player_x, player_y = !Map.player_pos in + Format.printf "player_x = %d@\nplayer_y = %d@\n" player_x player_y; for x = 0 to tiles_per_w - 1 do + let mapx = x + player_x - (tiles_per_w / 2) in for y = 0 to tiles_per_h - 1 do + let mapy = y + player_y - (tiles_per_h / 2) in + let img = + match Map.get_tile_kind ~x:mapx ~y:mapy with + | Grass -> grass + | Water -> water + | Black -> water + in let (_ : Jv.t) = Jv.call context "drawImage" - [| grass + [| img ; Jv.of_int (orig_x + (x * tile_size)) ; Jv.of_int (orig_y + (y * tile_size)) |] in () done - done + done; + let (_ : Jv.t) = + Jv.call context "drawImage" + [| papy_bottom + ; Jv.of_int ((width / 2) - (tile_size / 2)) + ; Jv.of_int ((height / 2) - (tile_size / 2)) + |] + in + () + +let () = + let (_ : Jv.t) = + Jv.call window "addEventListener" + [| Jv.of_string "load"; Jv.repr draw_map |] + in + () + +(* + 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) = @@ -53,3 +117,22 @@ let () = [| Jv.of_string "load"; Jv.repr draw_background |] in () + +let draw_papy () = + let (_ : Jv.t) = + Jv.call context "drawImage" + [| papy_bottom + ; Jv.of_int ((width / 2) - (tile_size / 2)) + ; Jv.of_int ((height / 2) - (tile_size / 2)) + |] + in + () + +let () = + let (_ : Jv.t) = + Jv.call window "addEventListener" + [| Jv.of_string "load"; Jv.repr draw_papy |] + in + () + +*) From 6357674db8bc8893c76a49de39714ae620dab608 Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 6 Dec 2022 03:30:16 +0100 Subject: [PATCH 49/81] add basic movements --- src/island_client.ml | 39 +++++++++++++++++++++++++++++++++------ 1 file changed, 33 insertions(+), 6 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 187b2dd..1eb731c 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -1,3 +1,5 @@ +let () = Random.self_init () + module Map = struct type background = | Grass @@ -8,12 +10,12 @@ module Map = struct let height = 1000 - let player_pos = ref (500, 500) + let player_pos = ref (20, 3) let m = Array.init width (fun _x -> Array.init height (fun _y -> - if Random.int 1000 = 42 then Water else Grass ) ) + if Random.int 1000 <= 42 then Water else Grass ) ) let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black end @@ -82,10 +84,7 @@ let draw_map () = done; let (_ : Jv.t) = Jv.call context "drawImage" - [| papy_bottom - ; Jv.of_int ((width / 2) - (tile_size / 2)) - ; Jv.of_int ((height / 2) - (tile_size / 2)) - |] + [| papy_bottom; Jv.of_int (width / 2); Jv.of_int (height / 2) |] in () @@ -96,6 +95,34 @@ let () = in () +let kb_handler e = + let x, y = !Map.player_pos in + let x, y = + match Jv.to_string @@ Jv.get e "key" with + | "z" -> (x, y - 1) + | "q" -> (x - 1, y) + | "s" -> (x, y + 1) + | "d" -> (x + 1, y) + | _s -> (x, y) + in + let x = max 0 x in + let x = min (Map.width - 1) x in + let y = max 0 y in + let y = min (Map.height - 1) y in + Map.player_pos := (x, y); + draw_map () + +let bind_keys () = + Jv.call window "addEventListener" + [| Jv.of_string "keydown"; Jv.repr kb_handler |] + +let () = + let (_ : Jv.t) = + Jv.call window "addEventListener" + [| Jv.of_string "load"; Jv.repr bind_keys |] + in + () + (* let draw_background () = for x = 0 to tiles_per_w - 1 do From 8f61881fe8e5c0d08a813963cb83f548e0d1d281 Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 00:10:41 +0100 Subject: [PATCH 50/81] Brrrr --- src/island_client.ml | 89 ++++++++++++++++++++------------------------ src/login.ml | 4 +- 2 files changed, 43 insertions(+), 50 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 1eb731c..02f5cd6 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -20,30 +20,32 @@ module Map = struct let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black end +open Brr +open Brr_canvas + +let get_el id = + match Document.find_el_by_id G.document (Jstr.of_string id) with + | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) + | Some el -> el + let tile_size = 40 let width = 835 let height = 635 -let canvas = Jv.get Jv.global "canvas" +let canvas = + let el = get_el "canvas" in + Canvas.of_el el -let context = Jv.call canvas "getContext" [| Jv.of_string "2d" |] +let context = C2d.get_context canvas 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 - () + 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) let tiles_per_w = width / tile_size @@ -53,11 +55,11 @@ 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 grass = C2d.image_src_of_el (get_el "grass") -let papy_bottom = Jv.get Jv.global "papy_bottom" +let papy_bottom = C2d.image_src_of_el (get_el "papy_bottom") -let water = Jv.get Jv.global "water" +let water = C2d.image_src_of_el (get_el "water") let draw_map () = let player_x, player_y = !Map.player_pos in @@ -66,39 +68,25 @@ let draw_map () = let mapx = x + player_x - (tiles_per_w / 2) in for y = 0 to tiles_per_h - 1 do let mapy = y + player_y - (tiles_per_h / 2) in - let img = + let tile_img = match Map.get_tile_kind ~x:mapx ~y:mapy with | Grass -> grass | Water -> water | Black -> water in - let (_ : Jv.t) = - Jv.call context "drawImage" - [| img - ; Jv.of_int (orig_x + (x * tile_size)) - ; Jv.of_int (orig_y + (y * tile_size)) - |] - in - () + C2d.draw_image context tile_img + ~x:(float_of_int (orig_x + (x * tile_size))) + ~y:(float_of_int (orig_y + (y * tile_size))) done done; - let (_ : Jv.t) = - Jv.call context "drawImage" - [| papy_bottom; Jv.of_int (width / 2); Jv.of_int (height / 2) |] - in - () + C2d.draw_image context papy_bottom + ~x:(float_of_int (width / 2)) + ~y:(float_of_int (height / 2)) -let () = - let (_ : Jv.t) = - Jv.call window "addEventListener" - [| Jv.of_string "load"; Jv.repr draw_map |] - in - () - -let kb_handler e = +let kb_handler ev = let x, y = !Map.player_pos in let x, y = - match Jv.to_string @@ Jv.get e "key" with + match ev |> Ev.as_type |> Ev.Keyboard.key |> Jstr.to_string with | "z" -> (x, y - 1) | "q" -> (x - 1, y) | "s" -> (x, y + 1) @@ -112,16 +100,19 @@ let kb_handler e = Map.player_pos := (x, y); draw_map () -let bind_keys () = - Jv.call window "addEventListener" - [| Jv.of_string "keydown"; Jv.repr kb_handler |] - let () = - let (_ : Jv.t) = - Jv.call window "addEventListener" - [| Jv.of_string "load"; Jv.repr bind_keys |] + let on_window_load f = + ignore @@ Ev.listen Ev.load (fun _ev -> f ()) (Window.as_target G.window) in - () + let bind_keys () = + ignore + @@ Ev.listen Ev.keydown + (fun ev -> kb_handler ev) + (Window.as_target G.window) + in + on_window_load init_bg; + on_window_load draw_map; + on_window_load bind_keys (* let draw_background () = diff --git a/src/login.ml b/src/login.ml index d6a83b8..3316620 100644 --- a/src/login.ml +++ b/src/login.ml @@ -7,7 +7,9 @@ let get request = let title = "Pellest|Login" in let login = let submit = button ~a:[ a_id "submit_login" ] [ txt "submit" ] in - let login = input ~a:[ a_id "login"; a_name "login"; a_input_type `Text ] () in + 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 From 13f017b5266a8b9d5fb5d6e28dc6e901929b7428 Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 18:46:29 +0100 Subject: [PATCH 51/81] better keyboard --- src/island_client.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 02f5cd6..7ba151a 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -86,11 +86,11 @@ let draw_map () = let kb_handler ev = let x, y = !Map.player_pos in let x, y = - match ev |> Ev.as_type |> Ev.Keyboard.key |> Jstr.to_string with - | "z" -> (x, y - 1) - | "q" -> (x - 1, y) - | "s" -> (x, y + 1) - | "d" -> (x + 1, y) + match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + | "KeyW" | "ArrowUp" -> (x, y - 1) + | "KeyA" | "ArrowLeft" -> (x - 1, y) + | "KeyS" | "ArrowDown" -> (x, y + 1) + | "KeyD" | "ArrowRight" -> (x + 1, y) | _s -> (x, y) in let x = max 0 x in From a3093dc0c8fa706e6924e1e79bb1f269eaa82573 Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 22:14:13 +0100 Subject: [PATCH 52/81] remove js ppx --- src/dune | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/dune b/src/dune index 2a1d301..86fc201 100644 --- a/src/dune +++ b/src/dune @@ -31,8 +31,7 @@ tyxml tyxml.functor uri - uuidm - yojson) + uuidm) (preprocess (pps lwt_ppx))) @@ -50,6 +49,4 @@ (name island_client) (modules island_client) (libraries js_of_ocaml brr) - (modes js) - (preprocess - (pps js_of_ocaml-ppx))) + (modes js)) From 9ad4d485a3a70fa0695106e88a93cb86f5b40e18 Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 23:14:11 +0100 Subject: [PATCH 53/81] use request_animation_frame --- src/island_client.ml | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 7ba151a..2f7ebc9 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -61,7 +61,7 @@ let papy_bottom = C2d.image_src_of_el (get_el "papy_bottom") let water = C2d.image_src_of_el (get_el "water") -let draw_map () = +let draw_map _timestamp = let player_x, player_y = !Map.player_pos in Format.printf "player_x = %d@\nplayer_y = %d@\n" player_x player_y; for x = 0 to tiles_per_w - 1 do @@ -98,11 +98,18 @@ let kb_handler ev = let y = max 0 y in let y = min (Map.height - 1) y in Map.player_pos := (x, y); - draw_map () + let _animation_frame_id = G.request_animation_frame draw_map in + () + +let rec game_loop _timestamp = + (* ... update state ... *) + draw_map (); + ignore @@ G.request_animation_frame game_loop let () = - let on_window_load f = - ignore @@ Ev.listen Ev.load (fun _ev -> f ()) (Window.as_target G.window) + let on_window_load f x = + ignore + @@ Ev.listen Ev.load (fun _ev -> ignore @@ f x) (Window.as_target G.window) in let bind_keys () = ignore @@ -110,9 +117,9 @@ let () = (fun ev -> kb_handler ev) (Window.as_target G.window) in - on_window_load init_bg; - on_window_load draw_map; - on_window_load bind_keys + on_window_load init_bg (); + on_window_load bind_keys (); + on_window_load G.request_animation_frame game_loop (* let draw_background () = From 40e873168f187bac1fdc174900a133f0a9e9865d Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 7 Dec 2022 23:16:36 +0100 Subject: [PATCH 54/81] remove commented code --- src/island_client.ml | 41 ----------------------------------------- 1 file changed, 41 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 2f7ebc9..75a0f91 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -120,44 +120,3 @@ let () = on_window_load init_bg (); on_window_load bind_keys (); on_window_load G.request_animation_frame game_loop - -(* - 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 - () - -let draw_papy () = - let (_ : Jv.t) = - Jv.call context "drawImage" - [| papy_bottom - ; Jv.of_int ((width / 2) - (tile_size / 2)) - ; Jv.of_int ((height / 2) - (tile_size / 2)) - |] - in - () - -let () = - let (_ : Jv.t) = - Jv.call window "addEventListener" - [| Jv.of_string "load"; Jv.repr draw_papy |] - in - () - -*) From e6aab5f780e0d5239dddcd02bcb2c31d19cccced Mon Sep 17 00:00:00 2001 From: Swrup Date: Thu, 8 Dec 2022 00:07:59 +0100 Subject: [PATCH 55/81] fix dune :^) --- src/dune | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/dune b/src/dune index 86fc201..5d3e288 100644 --- a/src/dune +++ b/src/dune @@ -35,6 +35,12 @@ (preprocess (pps lwt_ppx))) +(executable + (name island_client) + (modules island_client) + (libraries js_of_ocaml brr) + (modes js)) + (rule (target content.ml) (deps @@ -44,9 +50,3 @@ (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)) From 3db8c7f11f380e71a7afd44923b936521b20aa27 Mon Sep 17 00:00:00 2001 From: pena Date: Thu, 8 Dec 2022 02:09:23 +0100 Subject: [PATCH 56/81] fix rendering, fix the way we use request_animation_frame --- src/island_client.ml | 62 +++++++++++++++++++++++++------------------- 1 file changed, 36 insertions(+), 26 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 75a0f91..35bc73a 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -1,3 +1,13 @@ +open Brr +open Brr_canvas + +module G = struct + include Brr.G + + let request_animation_frame f = + (ignore : int -> unit) @@ Brr.G.request_animation_frame f +end + let () = Random.self_init () module Map = struct @@ -20,9 +30,6 @@ module Map = struct let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black end -open Brr -open Brr_canvas - let get_el id = match Document.find_el_by_id G.document (Jstr.of_string id) with | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) @@ -30,9 +37,9 @@ let get_el id = let tile_size = 40 -let width = 835 +let width = 875 -let height = 635 +let height = 675 let canvas = let el = get_el "canvas" in @@ -40,7 +47,7 @@ let canvas = let context = C2d.get_context canvas -let init_bg () = +let init () = Canvas.set_w canvas width; Canvas.set_h canvas height; C2d.set_fill_style context (C2d.color (Jstr.v "#FF1188")); @@ -80,8 +87,8 @@ let draw_map _timestamp = done done; C2d.draw_image context papy_bottom - ~x:(float_of_int (width / 2)) - ~y:(float_of_int (height / 2)) + ~x:(float_of_int (width - tile_size) /. 2.) + ~y:((float_of_int height /. 2.) -. float_of_int tile_size) let kb_handler ev = let x, y = !Map.player_pos in @@ -97,26 +104,29 @@ let kb_handler ev = let x = min (Map.width - 1) x in let y = max 0 y in let y = min (Map.height - 1) y in - Map.player_pos := (x, y); - let _animation_frame_id = G.request_animation_frame draw_map in - () + Map.player_pos := (x, y) -let rec game_loop _timestamp = - (* ... update state ... *) +let rec game_loop state _timestamp = draw_map (); - ignore @@ G.request_animation_frame game_loop + let new_state = state in + G.request_animation_frame (game_loop new_state) + +let on_window_load f x = + (ignore : Ev.listener -> unit) + @@ Ev.listen Ev.load + (fun (_ev : Ev.Type.void Ev.t) -> f x) + (Window.as_target G.window) + +let bind_keys () = + (ignore : Ev.listener -> unit) + @@ Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + +(* type will change later !*) +let initial_state = () let () = - let on_window_load f x = - ignore - @@ Ev.listen Ev.load (fun _ev -> ignore @@ f x) (Window.as_target G.window) - in - let bind_keys () = - ignore - @@ Ev.listen Ev.keydown - (fun ev -> kb_handler ev) - (Window.as_target G.window) - in - on_window_load init_bg (); + on_window_load init (); on_window_load bind_keys (); - on_window_load G.request_animation_frame game_loop + on_window_load + (fun () -> G.request_animation_frame (game_loop initial_state)) + () From 161273e33b25b45d21da01490d13ba952efa4ba6 Mon Sep 17 00:00:00 2001 From: pena Date: Thu, 8 Dec 2022 02:14:31 +0100 Subject: [PATCH 57/81] clean code --- src/island.ml | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/island.ml b/src/island.ml index a6b2ad8..0631163 100644 --- a/src/island.ml +++ b/src/island.ml @@ -16,14 +16,9 @@ let get request = ~a:[ a_id "canvas" ] [ txt "please update your browser or enable javascript" ] in - let img_grass = mk_img "grass" in - let img_papy_bottom = mk_img "papy_bottom" in - let img_water = mk_img "water" in + let images = List.map mk_img [ "grass"; "papy_bottom"; "water" ] in - let page = - div ~a:[ a_class [ "centered" ] ] - @@ [ canvas; img_grass; img_papy_bottom; img_water ] - in + let page = div ~a:[ a_class [ "centered" ] ] @@ (canvas :: images) in let js = script From 009a6e8ad5d2f8570b7f1cbad3cc12cd306884ae Mon Sep 17 00:00:00 2001 From: pena Date: Thu, 8 Dec 2022 02:20:03 +0100 Subject: [PATCH 58/81] optim --- src/island_client.ml | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 35bc73a..75f0bf6 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -94,16 +94,12 @@ let kb_handler ev = let x, y = !Map.player_pos in let x, y = match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> (x, y - 1) - | "KeyA" | "ArrowLeft" -> (x - 1, y) - | "KeyS" | "ArrowDown" -> (x, y + 1) - | "KeyD" | "ArrowRight" -> (x + 1, y) + | "KeyW" | "ArrowUp" -> (x, max 0 (y - 1)) + | "KeyA" | "ArrowLeft" -> (max 0 (x - 1), y) + | "KeyS" | "ArrowDown" -> (x, min (Map.height - 1) y + 1) + | "KeyD" | "ArrowRight" -> (min (Map.width - 1) x + 1, y) | _s -> (x, y) in - let x = max 0 x in - let x = min (Map.width - 1) x in - let y = max 0 y in - let y = min (Map.height - 1) y in Map.player_pos := (x, y) let rec game_loop state _timestamp = From 7686a096cfc2031d117a4353c896a9cf10cb2f89 Mon Sep 17 00:00:00 2001 From: pena Date: Thu, 8 Dec 2022 03:08:49 +0100 Subject: [PATCH 59/81] make sure there's an odd number of tiles --- src/island_client.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 75f0bf6..7f7a884 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -54,9 +54,13 @@ let init () = C2d.fill_rect context ~x:0. ~y:0. ~w:(float_of_int width) ~h:(float_of_int height) -let tiles_per_w = width / tile_size +let tiles_per_w = + let n = width / tile_size in + if n mod 2 = 0 then n - 1 else n -let tiles_per_h = height / tile_size +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 From 3c6a373dc9d6d54e09db1f94c5bcbd918aef666e Mon Sep 17 00:00:00 2001 From: pena Date: Thu, 8 Dec 2022 04:08:27 +0100 Subject: [PATCH 60/81] implement player dir, clean code --- .../img/{papy_bottom.png => papy_down.png} | Bin src/content/assets/img/papy_up.png | Bin 0 -> 838 bytes src/island.ml | 5 +- src/island_client.ml | 133 ++++++++++-------- 4 files changed, 82 insertions(+), 56 deletions(-) rename src/content/assets/img/{papy_bottom.png => papy_down.png} (100%) create mode 100644 src/content/assets/img/papy_up.png diff --git a/src/content/assets/img/papy_bottom.png b/src/content/assets/img/papy_down.png similarity index 100% rename from src/content/assets/img/papy_bottom.png rename to src/content/assets/img/papy_down.png diff --git a/src/content/assets/img/papy_up.png b/src/content/assets/img/papy_up.png new file mode 100644 index 0000000000000000000000000000000000000000..61698e46a67dd5f8337b4cbf3b6a6b966ff4a8c9 GIT binary patch literal 838 zcmeAS@N?(olHy`uVBq!ia0y~yV9;P-UFgYknVihPpfRy@ z;#qB%K#61ZY=X+%Q&J4O6}tl$rK}80Yd$LRG`sk{q5P|JJMLDi`))gR%qg;?cYW*s zhP9iPPEk^g{K;ICyX3X)I;qTOch1$;+dj9+e_yNDqNX#o{I#26{D(OyN^&#j&h9s{ z5neWrFUf`X>8;6^A8W2!*B_l#viIfny{qo8-Z5+XrFBiS+#V*TTF=|ybNI-r^z3^g zdEu7Ho&-XFf3CwuiddVKFm`M=?3d+527+}}CfKZgbWJ-2wj z${f8jKHhI9-R<&~ed=o!$j@v!g z`&!u-YcpcoFL!TBdw1X_TgkoKZOMN;wr+Bs$+KsU!)ciwk zz$k={8vlDQ;P$IEc(%KAO=p<0+y3GitNyoy)s)!qx^+%g;B@13`FyikMM72J?0;)p zi!bS({v``a6Pg4k&x^T{Fhyb3{~W&`HXU!)CGTiI;-r4ni0^B2;VR?$4Q^*kk8i(! zEu_|T!HgBRHL`SGFJdd6_g$Z1O}mPY&)p|iZ@Ahg>KAD~_Pw=i!JYOME3fgWZB~1G zR^E8SL6hI7idLR}d$yTZO?}?dZ%8vQ?07& zOLF&jyB0aVSA4rm#%%wQ+2$QOg{Ax%>5I0o;zsTH_ z*kj+nY$=&=Ba8RC+D|j{zCZii89UcrEtHH&j*K$(U0yjcCc7qOa)pWf$(AS;2POnc cQ2)Rx_09d(2lK#81_lNOPgg&ebxsLQ00NAIaR2}S literal 0 HcmV?d00001 diff --git a/src/island.ml b/src/island.ml index 0631163..eab4678 100644 --- a/src/island.ml +++ b/src/island.ml @@ -16,7 +16,10 @@ let get request = ~a:[ a_id "canvas" ] [ txt "please update your browser or enable javascript" ] in - let images = List.map mk_img [ "grass"; "papy_bottom"; "water" ] in + let images = + List.map mk_img + [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] + in let page = div ~a:[ a_class [ "centered" ] ] @@ (canvas :: images) in diff --git a/src/island_client.ml b/src/island_client.ml index 7f7a884..e1d6af9 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -10,6 +10,12 @@ end let () = Random.self_init () +type dir = + | Left + | Right + | Down + | Up + module Map = struct type background = | Grass @@ -22,6 +28,8 @@ module Map = struct let player_pos = ref (20, 3) + let player_dir = ref Down + let m = Array.init width (fun _x -> Array.init height (fun _y -> @@ -47,13 +55,6 @@ let canvas = let context = C2d.get_context canvas -let init () = - 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) - let tiles_per_w = let n = width / tile_size in if n mod 2 = 0 then n - 1 else n @@ -68,65 +69,87 @@ let orig_y = (height - (tiles_per_h * tile_size)) / 2 let grass = C2d.image_src_of_el (get_el "grass") -let papy_bottom = C2d.image_src_of_el (get_el "papy_bottom") +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 draw_map _timestamp = - let player_x, player_y = !Map.player_pos in - Format.printf "player_x = %d@\nplayer_y = %d@\n" player_x player_y; - for x = 0 to tiles_per_w - 1 do - let mapx = x + player_x - (tiles_per_w / 2) in - for y = 0 to tiles_per_h - 1 do - let mapy = y + player_y - (tiles_per_h / 2) in - let tile_img = - match Map.get_tile_kind ~x:mapx ~y:mapy with - | Grass -> grass - | Water -> water - | Black -> water - in - C2d.draw_image context tile_img - ~x:(float_of_int (orig_x + (x * tile_size))) - ~y:(float_of_int (orig_y + (y * tile_size))) - done - done; - C2d.draw_image context papy_bottom - ~x:(float_of_int (width - tile_size) /. 2.) - ~y:((float_of_int height /. 2.) -. float_of_int tile_size) +let draw_map = + 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 + fun () -> + let player_x, player_y = !Map.player_pos in + for x = 0 to tiles_per_w - 1 do + let map_x = x + player_x - (tiles_per_w / 2) in + let tile_x = float_of_int ((x * tile_size) + orig_x) in + for y = 0 to tiles_per_h - 1 do + let map_y = y + player_y - (tiles_per_h / 2) in + let tile_y = float_of_int ((y * tile_size) + orig_y) in + let tile_img = + match Map.get_tile_kind ~x:map_x ~y:map_y with + | Grass -> grass + | Water -> water + | Black -> water + in + C2d.draw_image context tile_img ~x:tile_x ~y:tile_y + done + done; + let papy = + match !Map.player_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 move dir = + if !Map.player_dir = dir then begin + let x, y = !Map.player_pos in + let x, y = + match dir with + | Left -> (x - 1, y) + | Right -> (x + 1, y) + | Down -> (x, y + 1) + | Up -> (x, y - 1) + in + match Map.get_tile_kind ~x ~y with + | Black | Water -> () + | Grass -> Map.player_pos := (x, y) + end + else Map.player_dir := dir let kb_handler ev = - let x, y = !Map.player_pos in - let x, y = - match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> (x, max 0 (y - 1)) - | "KeyA" | "ArrowLeft" -> (max 0 (x - 1), y) - | "KeyS" | "ArrowDown" -> (x, min (Map.height - 1) y + 1) - | "KeyD" | "ArrowRight" -> (min (Map.width - 1) x + 1, y) - | _s -> (x, y) - in - Map.player_pos := (x, y) + match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + | "KeyW" | "ArrowUp" -> move Up + | "KeyA" | "ArrowLeft" -> move Left + | "KeyS" | "ArrowDown" -> move Down + | "KeyD" | "ArrowRight" -> move Right + | _s -> () let rec game_loop state _timestamp = draw_map (); let new_state = state in G.request_animation_frame (game_loop new_state) -let on_window_load f x = - (ignore : Ev.listener -> unit) - @@ Ev.listen Ev.load - (fun (_ev : Ev.Type.void Ev.t) -> f x) - (Window.as_target G.window) - -let bind_keys () = - (ignore : Ev.listener -> unit) - @@ Ev.listen Ev.keydown kb_handler (Window.as_target G.window) - -(* type will change later !*) +(* type will change later ! *) let initial_state = () let () = - on_window_load init (); - on_window_load bind_keys (); - on_window_load - (fun () -> G.request_animation_frame (game_loop initial_state)) - () + (* 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); + (* bind keys *) + let _e : Ev.listener = + Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + in + (* start game *) + G.request_animation_frame (game_loop initial_state) From 5f1d29bda3dabe353ef3ba99c078ccaeaa6b2ba5 Mon Sep 17 00:00:00 2001 From: Swrup Date: Sun, 11 Dec 2022 18:58:56 +0100 Subject: [PATCH 61/81] wip: state server side; websocket --- src/app.ml | 8 +++--- src/common.ml | 0 src/dune | 13 +++++++--- src/island_client.ml | 60 +++++++++++++++++--------------------------- src/map.ml | 27 ++++++++++++++++++++ src/network.ml | 5 ++++ src/pellest.ml | 2 ++ src/state.ml | 17 +++++++++++++ src/user.ml | 11 ++++++++ src/ws.ml | 27 ++++++++++++++++++++ src/ws_client.ml | 43 +++++++++++++++++++++++++++++++ 11 files changed, 169 insertions(+), 44 deletions(-) create mode 100644 src/common.ml create mode 100644 src/map.ml create mode 100644 src/network.ml create mode 100644 src/state.ml create mode 100644 src/ws.ml create mode 100644 src/ws_client.ml diff --git a/src/app.ml b/src/app.ml index 9c3c619..543afc7 100644 --- a/src/app.ml +++ b/src/app.ml @@ -78,10 +78,6 @@ let log = let () = Dream.log "log: %b" log -let random_state = Random.State.make_self_init () - -let () = Random.set_state random_state - let about = let default_about = "Pellest is great !" in match Scfg.Query.get_dir "about" config with @@ -90,3 +86,7 @@ let about = match Scfg.Query.get_param 0 about with | Error e -> failwith e | Ok about -> about ) + +let random_state = Random.State.make_self_init () + +let () = Random.set_state random_state diff --git a/src/common.ml b/src/common.ml new file mode 100644 index 0000000..e69de29 diff --git a/src/dune b/src/dune index 5d3e288..c5a5f3a 100644 --- a/src/dune +++ b/src/dune @@ -14,7 +14,8 @@ syntax template tyx_util - user) + user + ws) (libraries bos caqti @@ -23,6 +24,7 @@ directories dream emile + shared fpath lambdasoup lwt @@ -37,10 +39,15 @@ (executable (name island_client) - (modules island_client) - (libraries js_of_ocaml brr) + (modules island_client ws_client) + (libraries js_of_ocaml brr shared) (modes js)) +(library + (name shared) + (modules map network state) + (libraries)) + (rule (target content.ml) (deps diff --git a/src/island_client.ml b/src/island_client.ml index e1d6af9..2fcc70f 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -1,5 +1,7 @@ open Brr +open Brr_io open Brr_canvas +open Shared module G = struct include Brr.G @@ -8,36 +10,6 @@ module G = struct (ignore : int -> unit) @@ Brr.G.request_animation_frame f end -let () = Random.self_init () - -type dir = - | Left - | Right - | Down - | Up - -module Map = struct - type background = - | Grass - | Water - | Black - - let width = 1000 - - let height = 1000 - - let player_pos = ref (20, 3) - - let player_dir = ref Down - - let m = - Array.init width (fun _x -> - Array.init height (fun _y -> - if Random.int 1000 <= 42 then Water else Grass ) ) - - let get_tile_kind ~x ~y = try m.(x).(y) with Invalid_argument _ -> Black -end - let get_el id = match Document.find_el_by_id G.document (Jstr.of_string id) with | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) @@ -79,6 +51,11 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") +let map = + (* TODO receive map / state *) + (* dummy map; should ask for map to server *) + ref (Map.init ()) + let draw_map = 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 @@ -91,7 +68,7 @@ let draw_map = let map_y = y + player_y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = - match Map.get_tile_kind ~x:map_x ~y:map_y with + match Map.get_tile_kind ~x:map_x ~y:map_y !map with | Grass -> grass | Water -> water | Black -> water @@ -118,7 +95,7 @@ let move dir = | Down -> (x, y + 1) | Up -> (x, y - 1) in - match Map.get_tile_kind ~x ~y with + match Map.get_tile_kind ~x ~y !map with | Black | Water -> () | Grass -> Map.player_pos := (x, y) end @@ -130,6 +107,7 @@ let kb_handler ev = | "KeyA" | "ArrowLeft" -> move Left | "KeyS" | "ArrowDown" -> move Down | "KeyD" | "ArrowRight" -> move Right + | "KeyM" -> Ws_client.send State.Meditate | _s -> () let rec game_loop state _timestamp = @@ -137,9 +115,6 @@ let rec game_loop state _timestamp = let new_state = state in G.request_animation_frame (game_loop new_state) -(* type will change later ! *) -let initial_state = () - let () = (* init canvas *) Canvas.set_w canvas width; @@ -151,5 +126,16 @@ let () = let _e : Ev.listener = Ev.listen Ev.keydown kb_handler (Window.as_target G.window) in - (* start game *) - G.request_animation_frame (game_loop initial_state) + + (* get state from server*) + let initial_state_fut = Ev.next Message.Ev.message Ws_client.ws_target in + + Fut.await initial_state_fut (fun msg -> + let initial_state = Ws_client.to_server_msg msg in + let state_ref = ref initial_state in + (* attach message listener to update state *) + Ws_client.on_update_state_message (fun received -> + state_ref := received; + Format.printf "YOUR MANA IS: %d@." !state_ref.mana ); + (* start game *) + G.request_animation_frame (game_loop state_ref) ) diff --git a/src/map.ml b/src/map.ml new file mode 100644 index 0000000..ffcc2b6 --- /dev/null +++ b/src/map.ml @@ -0,0 +1,27 @@ +type dir = + | Left + | Right + | Down + | Up + +type background = + | Grass + | Water + | Black + +type t = background array array + +let width = 1000 + +let height = 1000 + +let player_pos = ref (20, 3) + +let player_dir = ref Down + +let init () = + Array.init width (fun _x -> + Array.init height (fun _y -> + if Random.int 1000 <= 42 then Water else Grass ) ) + +let get_tile_kind ~x ~y map = try map.(x).(y) with Invalid_argument _ -> Black diff --git a/src/network.ml b/src/network.ml new file mode 100644 index 0000000..aecc640 --- /dev/null +++ b/src/network.ml @@ -0,0 +1,5 @@ +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 diff --git a/src/pellest.ml b/src/pellest.ml index 3d1d478..92b30e6 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -6,6 +6,8 @@ let () = [ 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 diff --git a/src/state.ml b/src/state.ml new file mode 100644 index 0000000..fa434c8 --- /dev/null +++ b/src/state.ml @@ -0,0 +1,17 @@ +type t = + { map : Map.t + ; mutable mana : int + } + +let init () = { map = Map.init (); mana = 0 } + +type action = Meditate + +(* TODO do not send whole state *) +let handle_action state action = + match action with + | Meditate -> + if state.mana < 99 then ( + state.mana <- succ state.mana; + Ok state ) + else Error "maximum mana" diff --git a/src/user.ml b/src/user.ml index 2b2b354..a3dfe83 100644 --- a/src/user.ml +++ b/src/user.ml @@ -223,3 +223,14 @@ let assert_logged request = let assert_not_logged request = if is_logged_in request then Error (`Forbidden, "you shoudn'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 -> Ok (Shared.State.init ()) diff --git a/src/ws.ml b/src/ws.ml new file mode 100644 index 0000000..b551e89 --- /dev/null +++ b/src/ws.ml @@ -0,0 +1,27 @@ +open Lwt.Syntax +open Shared + +let handle_client request client = + match Dream.session "user_id" request with + | None -> Dream.log "User does not exists" |> Lwt.return + | Some user_id -> + (* TODO catch marshal failure *) + + (* send user island state *) + let state = + match User.get_state user_id with + | Error _e -> assert false + | Ok state -> state + in + let* () = Dream.send ~text_or_binary:`Text client (Network.marshal state) in + + let rec loop () = + match%lwt Dream.receive client with + | None -> Dream.close_websocket client + | Some s -> + let action : State.action = Network.unmarshal s in + let state_res = State.handle_action state action in + let* () = Dream.send client (Network.marshal state_res) in + loop () + in + loop () diff --git a/src/ws_client.ml b/src/ws_client.ml new file mode 100644 index 0000000..ab612ef --- /dev/null +++ b/src/ws_client.ml @@ -0,0 +1,43 @@ +open Brr +open Brr_io +open Shared + +let ws = + Format.printf "create websocket@\n"; + let ws_url = + (* TODO fix hostname *) + Jstr.of_string "ws://localhost:3696/island/ws" + in + Websocket.create ws_url + +let ws_target = Websocket.as_target ws + +let on_event ws_event log_msg f = + let (_ : Ev.listener) = + Ev.listen ws_event + (fun ev -> + Format.printf "%s@\n" log_msg; + f ev ) + ws_target + in + () + +let to_server_msg ev = + Format.printf "to_server_msg@."; + let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in + let state_res : (State.t, string) result = Network.unmarshal data in + Format.printf "un-marshaled message from server yay ~ @\n"; + match state_res with + | Error e -> failwith (Format.sprintf "action resulted in error: %s" e) + | Ok state -> state + +let on_update_state_message f = + on_event Message.Ev.message "Websocket reveived message!" (fun ev -> + f (to_server_msg ev) ) + +let send msg = + Format.printf "send msg on websocket ~~ @\n"; + let s = Jstr.of_string (Network.marshal msg) in + Websocket.send_string ws s; + Format.printf "send action on websocket ~~ DONE @\n"; + () From aebafe30f348923170402ceb270419cc63e41dbf Mon Sep 17 00:00:00 2001 From: Swrup Date: Thu, 15 Dec 2022 19:59:42 +0100 Subject: [PATCH 62/81] clean map --- src/island_client.ml | 42 +++++++++++----------------------------- src/map.ml | 46 +++++++++++++++++++++++++++++++------------- src/ws.ml | 3 ++- 3 files changed, 46 insertions(+), 45 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 2fcc70f..8142813 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -51,16 +51,11 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") -let map = - (* TODO receive map / state *) - (* dummy map; should ask for map to server *) - ref (Map.init ()) - let draw_map = 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 - fun () -> - let player_x, player_y = !Map.player_pos in + fun map -> + let player_x, player_y = map.Map.player_pos in for x = 0 to tiles_per_w - 1 do let map_x = x + player_x - (tiles_per_w / 2) in let tile_x = float_of_int ((x * tile_size) + orig_x) in @@ -68,7 +63,7 @@ let draw_map = let map_y = y + player_y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = - match Map.get_tile_kind ~x:map_x ~y:map_y !map with + match Map.get_tile_kind ~x:map_x ~y:map_y map with | Grass -> grass | Water -> water | Black -> water @@ -77,7 +72,7 @@ let draw_map = done done; let papy = - match !Map.player_dir with + match map.Map.player_dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -85,23 +80,8 @@ let draw_map = in C2d.draw_image context papy ~x:papy_x ~y:papy_y -let move dir = - if !Map.player_dir = dir then begin - let x, y = !Map.player_pos in - let x, y = - match dir with - | Left -> (x - 1, y) - | Right -> (x + 1, y) - | Down -> (x, y + 1) - | Up -> (x, y - 1) - in - match Map.get_tile_kind ~x ~y !map with - | Black | Water -> () - | Grass -> Map.player_pos := (x, y) - end - else Map.player_dir := dir - -let kb_handler ev = +let kb_handler state ev = + let move = Map.move !state.State.map in match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with | "KeyW" | "ArrowUp" -> move Up | "KeyA" | "ArrowLeft" -> move Left @@ -111,7 +91,7 @@ let kb_handler ev = | _s -> () let rec game_loop state _timestamp = - draw_map (); + draw_map !state.State.map; let new_state = state in G.request_animation_frame (game_loop new_state) @@ -122,10 +102,6 @@ let () = 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); - (* bind keys *) - let _e : Ev.listener = - Ev.listen Ev.keydown kb_handler (Window.as_target G.window) - in (* get state from server*) let initial_state_fut = Ev.next Message.Ev.message Ws_client.ws_target in @@ -133,6 +109,10 @@ let () = Fut.await initial_state_fut (fun msg -> let initial_state = Ws_client.to_server_msg msg in let state_ref = ref initial_state in + (* bind keys *) + let _e : Ev.listener = + Ev.listen Ev.keydown (kb_handler state_ref) (Window.as_target G.window) + in (* attach message listener to update state *) Ws_client.on_update_state_message (fun received -> state_ref := received; diff --git a/src/map.ml b/src/map.ml index ffcc2b6..36160e9 100644 --- a/src/map.ml +++ b/src/map.ml @@ -9,19 +9,39 @@ type background = | Water | Black -type t = background array array - -let width = 1000 - -let height = 1000 - -let player_pos = ref (20, 3) - -let player_dir = ref Down +type t = + { tiles : background array array + ; mutable player_pos : int * int + ; mutable player_dir : dir + ; width : int + ; height : int + } let init () = - Array.init width (fun _x -> - Array.init height (fun _y -> - if Random.int 1000 <= 42 then Water else Grass ) ) + let width = 1000 in + let height = 1000 in + let tiles = + Array.init width (fun _x -> + Array.init height (fun _y -> + if Random.int 1000 <= 42 then Water else Grass ) ) + in + { tiles; player_pos = (20, 3); player_dir = Down; width; height } -let get_tile_kind ~x ~y map = try map.(x).(y) with Invalid_argument _ -> Black +let get_tile_kind ~x ~y map = + try map.tiles.(x).(y) with Invalid_argument _ -> Black + +let move map dir = + if map.player_dir = dir then begin + let x, y = map.player_pos in + let x, y = + match 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 -> () + | Grass -> map.player_pos <- (x, y) + end + else map.player_dir <- dir diff --git a/src/ws.ml b/src/ws.ml index b551e89..d4a377c 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -6,7 +6,7 @@ let handle_client request client = | None -> Dream.log "User does not exists" |> Lwt.return | Some user_id -> (* TODO catch marshal failure *) - + Dream.log " SEND USER ISLAND"; (* send user island state *) let state = match User.get_state user_id with @@ -14,6 +14,7 @@ let handle_client request client = | Ok state -> state in let* () = Dream.send ~text_or_binary:`Text client (Network.marshal state) in + Dream.log " SENDED USER ISLAND"; let rec loop () = match%lwt Dream.receive client with From 1cb4f07c0a2bedb3965e99a863e230331a1e8fb8 Mon Sep 17 00:00:00 2001 From: Swrup Date: Mon, 26 Dec 2022 01:12:16 +0100 Subject: [PATCH 63/81] rm common.ml --- src/common.ml | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 src/common.ml diff --git a/src/common.ml b/src/common.ml deleted file mode 100644 index e69de29..0000000 From cafba236106cdf5112ad2e0328bcd819fc25f19b Mon Sep 17 00:00:00 2001 From: Swrup Date: Mon, 26 Dec 2022 02:06:13 +0100 Subject: [PATCH 64/81] do not send whole state on action --- src/island_client.ml | 92 ++++++++++++++++++++++++++++++-------------- src/map.ml | 25 ++++++------ src/network.ml | 6 +++ src/state.ml | 36 ++++++++++++----- src/ws.ml | 34 +++++++++++----- src/ws_client.ml | 8 ++-- 6 files changed, 135 insertions(+), 66 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 8142813..37aaccd 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -51,11 +51,12 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") -let draw_map = +let draw = 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 - fun map -> - let player_x, player_y = map.Map.player_pos in + fun state -> + let open State in + let player_x, player_y, player_dir = state.player_pos in for x = 0 to tiles_per_w - 1 do let map_x = x + player_x - (tiles_per_w / 2) in let tile_x = float_of_int ((x * tile_size) + orig_x) in @@ -63,7 +64,7 @@ let draw_map = let map_y = y + player_y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = - match Map.get_tile_kind ~x:map_x ~y:map_y map with + match Map.get_tile_kind ~x:map_x ~y:map_y state.map with | Grass -> grass | Water -> water | Black -> water @@ -72,7 +73,7 @@ let draw_map = done done; let papy = - match map.Map.player_dir with + match player_dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -80,19 +81,43 @@ let draw_map = in C2d.draw_image context papy ~x:papy_x ~y:papy_y -let kb_handler state ev = - let move = Map.move !state.State.map in - match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> move Up - | "KeyA" | "ArrowLeft" -> move Left - | "KeyS" | "ArrowDown" -> move Down - | "KeyD" | "ArrowRight" -> move Right - | "KeyM" -> Ws_client.send State.Meditate - | _s -> () +(* 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 action = + match State.check_action state action with + | Error e -> Format.printf "Invalid action: %s@\n" e + | Ok _ -> Ws_client.send (Network.Action_msg action) + +let kb_handler ev = + let open State in + let act = + match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + | "KeyW" | "ArrowUp" -> Move Up + | "KeyA" | "ArrowLeft" -> Move Left + | "KeyS" | "ArrowDown" -> Move Down + | "KeyD" | "ArrowRight" -> Move Right + | "KeyM" -> Meditate + | _s -> Do_nothing + in + Queue.add act input_queue let rec game_loop state _timestamp = - draw_map !state.State.map; - let new_state = state in + draw state; + let new_state = + (* TODO repesct order of action *) + (* apply to_apply_queue *) + let state = Queue.fold State.perform_action state to_apply_queue in + (* TODO can this bug because of concurrency? *) + Queue.clear to_apply_queue; + (* send input action to server *) + Queue.iter (send_action state) input_queue; + Queue.clear input_queue; + state + in G.request_animation_frame (game_loop new_state) let () = @@ -106,16 +131,27 @@ let () = (* 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 *) + Format.printf "received Full_state message@\n" + | Update_result res -> ( + match res with + | Error e -> Format.printf "received update result error: %s" e + | Ok action' -> Queue.add action' to_apply_queue ) ); + (* bind keys *) + let _e : Ev.listener = + Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + in + Fut.await initial_state_fut (fun msg -> - let initial_state = Ws_client.to_server_msg msg in - let state_ref = ref initial_state in - (* bind keys *) - let _e : Ev.listener = - Ev.listen Ev.keydown (kb_handler state_ref) (Window.as_target G.window) - in - (* attach message listener to update state *) - Ws_client.on_update_state_message (fun received -> - state_ref := received; - Format.printf "YOUR MANA IS: %d@." !state_ref.mana ); - (* start game *) - G.request_animation_frame (game_loop state_ref) ) + match Ws_client.to_server_msg msg with + | Update_result _res_msg -> + failwith + "invalid first server message received; received Update expected \ + Full_state" + | Full_state state -> + (* start game *) + G.request_animation_frame (game_loop state) ) diff --git a/src/map.ml b/src/map.ml index 36160e9..4860914 100644 --- a/src/map.ml +++ b/src/map.ml @@ -9,10 +9,10 @@ type background = | Water | Black +type position = int * int * dir + type t = { tiles : background array array - ; mutable player_pos : int * int - ; mutable player_dir : dir ; width : int ; height : int } @@ -25,23 +25,22 @@ let init () = Array.init height (fun _y -> if Random.int 1000 <= 42 then Water else Grass ) ) in - { tiles; player_pos = (20, 3); player_dir = Down; width; height } + { tiles; width; height } let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black -let move map dir = - if map.player_dir = dir then begin - let x, y = map.player_pos in - let x, y = +let check_move map entity_pos dir = + let x, y, current_dir = entity_pos in + let x, y = + if current_dir <> dir then (x, y) + else match 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 -> () - | Grass -> map.player_pos <- (x, y) - end - else map.player_dir <- dir + in + match get_tile_kind ~x ~y map with + | Black | Water -> Error "invalid terrain" + | Grass -> Ok (x, y, dir) diff --git a/src/network.ml b/src/network.ml index aecc640..729b569 100644 --- a/src/network.ml +++ b/src/network.ml @@ -3,3 +3,9 @@ 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', string) result + +type client_message = Action_msg of State.action diff --git a/src/state.ml b/src/state.ml index fa434c8..69f86f6 100644 --- a/src/state.ml +++ b/src/state.ml @@ -1,17 +1,33 @@ type t = { map : Map.t - ; mutable mana : int + ; mana : int + ; player_pos : Map.position } -let init () = { map = Map.init (); mana = 0 } +let init () = { map = Map.init (); mana = 0; player_pos = (20, 3, Down) } -type action = Meditate +type action = + | Meditate + (* TODO some action do not needs to be checked by server *) + | Move of Map.dir + | Do_nothing -(* TODO do not send whole state *) -let handle_action state action = - match action with +(* type for result of action send to the client by the server *) +type action' = + | Add_mana of int + | Set_player_position of Map.position + | Look_at_the_sky + +let check_action state = function | Meditate -> - if state.mana < 99 then ( - state.mana <- succ state.mana; - Ok state ) - else Error "maximum mana" + 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) ) + | Do_nothing -> Ok Look_at_the_sky + +let perform_action state = function + | Add_mana n -> { state with mana = state.mana + n } + | Set_player_position player_pos -> { state with player_pos } + | Look_at_the_sky -> state diff --git a/src/ws.ml b/src/ws.ml index d4a377c..78f7a29 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -6,23 +6,37 @@ let handle_client request client = | None -> Dream.log "User does not exists" |> Lwt.return | Some user_id -> (* TODO catch marshal failure *) - Dream.log " SEND USER ISLAND"; - (* send user island state *) let state = match User.get_state user_id with | Error _e -> assert false | Ok state -> state in - let* () = Dream.send ~text_or_binary:`Text client (Network.marshal state) in - Dream.log " SENDED USER ISLAND"; + let state_msg = Network.Full_state state in - let rec loop () = + (* send user island state *) + let* () = + Dream.send ~text_or_binary:`Text client (Network.marshal state_msg) + in + + let rec loop state = match%lwt Dream.receive client with | None -> Dream.close_websocket client | Some s -> - let action : State.action = Network.unmarshal s in - let state_res = State.handle_action state action in - let* () = Dream.send client (Network.marshal state_res) in - loop () + let (Network.Action_msg action : Network.client_message) = + Network.unmarshal s + in + let res, state = + match State.check_action state action with + | Error _e as error -> (error, state) + | Ok action' -> + (* update server state *) + let state = State.perform_action state action' in + User.set_state user_id state; + (Ok action', state) + in + let* () = + Dream.send client (Network.marshal (Network.Update_result res)) + in + loop state in - loop () + loop state diff --git a/src/ws_client.ml b/src/ws_client.ml index ab612ef..8f7102b 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -25,17 +25,15 @@ let on_event ws_event log_msg f = let to_server_msg ev = Format.printf "to_server_msg@."; let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in - let state_res : (State.t, string) result = Network.unmarshal data in + let server_msg : Network.server_message = Network.unmarshal data in Format.printf "un-marshaled message from server yay ~ @\n"; - match state_res with - | Error e -> failwith (Format.sprintf "action resulted in error: %s" e) - | Ok state -> state + server_msg let on_update_state_message f = on_event Message.Ev.message "Websocket reveived message!" (fun ev -> f (to_server_msg ev) ) -let send msg = +let send (msg : Network.client_message) = Format.printf "send msg on websocket ~~ @\n"; let s = Jstr.of_string (Network.marshal msg) in Websocket.send_string ws s; From 461d648ac99d0fd38430c9ef7c165c6e7478e97f Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 3 Jan 2023 23:53:05 +0100 Subject: [PATCH 65/81] stop using a hardcoded websocket address in ws_client --- src/ws_client.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/ws_client.ml b/src/ws_client.ml index 8f7102b..41649a0 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -5,8 +5,14 @@ open Shared let ws = Format.printf "create websocket@\n"; let ws_url = - (* TODO fix hostname *) - Jstr.of_string "ws://localhost:3696/island/ws" + 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 + Jstr.of_string @@ Format.sprintf "ws://%s%s/island/ws" host port in Websocket.create ws_url From 1850c5459d1d7726b20a655fe91ef3ddcb2d59d3 Mon Sep 17 00:00:00 2001 From: Swrup Date: Sat, 7 Jan 2023 23:15:03 +0100 Subject: [PATCH 66/81] add auto_state_update client & server --- src/island_client.ml | 15 +++++++++++++-- src/pellest.ml | 22 ++++++++++++++++++++++ src/state.ml | 9 +++++++++ src/ws.ml | 17 +++++++++++------ 4 files changed, 55 insertions(+), 8 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 37aaccd..5e430e0 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -105,7 +105,9 @@ let kb_handler ev = in Queue.add act input_queue -let rec game_loop state _timestamp = +let last_auto_state_update = ref 0. + +let rec game_loop state timestamp = draw state; let new_state = (* TODO repesct order of action *) @@ -116,7 +118,16 @@ let rec game_loop state _timestamp = (* send input action to server *) Queue.iter (send_action state) input_queue; Queue.clear input_queue; - state + + (* auto_update *) + if + timestamp -. !last_auto_state_update + >= float_of_int @@ (State.auto_state_update_rate * 1000) + then ( + Format.printf "MANA: %d@." state.mana; + last_auto_state_update := timestamp; + State.auto_update state ) + else state in G.request_animation_frame (game_loop new_state) diff --git a/src/pellest.ml b/src/pellest.ml index 92b30e6..7356070 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -1,3 +1,25 @@ +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 update_offline_user_state () = + (* TODO *) + () + +let update_online_user_state () = + Hashtbl.filter_map_inplace + (fun _user_id state -> Some (Shared.State.auto_update state)) + User.state_ht + +let () = + regularly_call_fun update_online_user_state + (float_of_int Shared.State.auto_state_update_rate); + regularly_call_fun update_offline_user_state + (float_of_int Shared.State.auto_state_update_rate) + let () = let logger = if App.log then Dream.logger else Fun.id in Dream.run ~port:App.port @@ logger @@ Dream.memory_sessions diff --git a/src/state.ml b/src/state.ml index 69f86f6..4b3564d 100644 --- a/src/state.ml +++ b/src/state.ml @@ -31,3 +31,12 @@ let perform_action state = function | Add_mana n -> { state with mana = state.mana + n } | Set_player_position player_pos -> { state with player_pos } | Look_at_the_sky -> state + +let auto_update state = + match check_action state Meditate with + | Error _e -> state + | Ok action' -> + let state = perform_action state action' in + state + +let auto_state_update_rate = 5 (* in secs *) diff --git a/src/ws.ml b/src/ws.ml index 78f7a29..b94646c 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -18,25 +18,30 @@ let handle_client request client = Dream.send ~text_or_binary:`Text client (Network.marshal state_msg) in - let rec loop state = + let rec loop () = match%lwt Dream.receive client with | None -> Dream.close_websocket client | Some s -> + let state = + match User.get_state user_id with + | Error _e -> assert false + | Ok state -> state + in let (Network.Action_msg action : Network.client_message) = Network.unmarshal s in - let res, state = + let res = match State.check_action state action with - | Error _e as error -> (error, state) + | Error _e as error -> error | Ok action' -> (* update server state *) let state = State.perform_action state action' in User.set_state user_id state; - (Ok action', state) + Ok action' in let* () = Dream.send client (Network.marshal (Network.Update_result res)) in - loop state + loop () in - loop state + loop () From 15d42e503847b2c8598489ce58529d028c472c4f Mon Sep 17 00:00:00 2001 From: pena Date: Sun, 8 Jan 2023 01:02:20 +0100 Subject: [PATCH 67/81] add mana icon --- src/content/assets/img/mana.png | Bin 0 -> 3785 bytes src/content/assets/img/mana.xcf | Bin 0 -> 5950 bytes 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100644 src/content/assets/img/mana.png create mode 100644 src/content/assets/img/mana.xcf diff --git a/src/content/assets/img/mana.png b/src/content/assets/img/mana.png new file mode 100644 index 0000000000000000000000000000000000000000..34214c0f8cf510c746ea51bbdbd3626436074908 GIT binary patch literal 3785 zcmeAS@N?(olHy`uVBq!ia0y~yV9)|#4mJh`hNFj1Ml&!lHfK6J2Y5O=D-;yvr)B1( zGB9XNtet4zl5wGTEYC0g6|+)>_Tj^M!wwiHfFPUsLwM zgY%EBYVO{=j&EI)!Vl(0uO2OVp`?0mx=7TKiiaQV&h38w;a+XSg;j=UUwJdl%A0+& z#OsWB*wG8xOdQMt0@G)vp79J~+xNB9|87V*=e(!)zo+xAa_wehoM>^9=d#*8g?Tr( z@Sgj9Brt4Z=%eCCoRjrD{+uX1`q=zj>U7q5lBUHsD<5fWjChy0v_10Zm5$||$*YzH z@0;*F;_05Fk*iH3p3nQ!I&smyO=n7@l0A|Iy(cI*IWmV{NlF*PO)kD_-V#vJA&trnk!;*T`G@{bu2?V-Byn z9-q&+dHxdf-BE8iByO?kt=m0o6MM`%24(-YoKx#WmZ(ngI`CVvHkeUjA1m9nJv&R! z75-v)k`Xpj`oRN%j_I1!cc0&VcyH(5+m~nF=NI)YYE+)OlZkc5JVH>& z=jNiE1KY*_SN~_U=h%=KEy5D4q_K91>dxK8^XI)g)zk5~eU;?8X_IO+6)u*ZTxV7K z=t$=YBhPrIjXgE_|E-Td3|yrc@F1{rg^P%iR*=>rDK8bprCu}FTwx9hdfgbszb4H3 zK;-)O_7%tEtGC&|<9CSn+h>3A{_Hso=`L#@PW4eva(1H*TQS;e7`4t{ndB&+q-^--vSkU@(jPvwe+kwnjCD@bMIP-JZJpZ zcZXl>3v<(*=_)vNil^r3BdWYXOnYb9a%Y5{ij)lB&U1Kf*4^7_$u@7;&1PHo_2tFtS9^3qaFb@fbXYDr(#$+EO% zcI08XzLj6Ew0|s{!`FIt+k{sh!pDzqmv8yc`Q?M-jK7>Y6}oHJzo>Pc-M8rL;!D4e z-3fnKtFl=nb)!%4GQ~u%fLTEzOFcqUPZ_0Nnz5np3Y)fi^4jQShi6^WYX9pn&)-8> zUERFiXMMj^td|*hg(5GfhiP)W0nwRYFeAuWIkl8M9xD|NPtk z|FK2!qc?9})q3*1Z{6MgJ0M!xQf8Z-ue$T>zALu^Th=QTNldxolfd^?xmttqY(nsY z{PVMew#68W9Sc@9>h*|jZ40Q`vTe(rt@8Zg;rI9dUG4w>r^)7ze|}yqcaneSTq>WD zyVflCwTbNNt;*l`o$E=Q+UeuwxuJC}t4=?|4>1$3z1#Q4%$^(}Ib}-flL<4M=c-rD zOEb58Vt)DlxA^+XqZhx)&J@;xdFy0eT7o;9ilad1DIKI`uJCl2njm^GSKHAvm)zx3ma#Ba|TZQFjmc=xP5 zCT5PZZPapp2Yrvtdh*-0yqs~ZFYAYvahBHFG^I&FLe|1ok_%N`*{=xg^bk6Gvo-R} znY1QO?av#H48Mplo;=99Tjac)k9E6TM7DO`I{QbTZW_)M){oyOy{B6C4*Rmqvsd~u za<#vQ?g&4vk-DxeO>IMqW5i7dUWso3!bU06(k7iP7E+nWs4249Mu+)m^1X9YBj(*$ z&$562^molg>km{Fl>VG__L*{3{tkcU6P*#4Z(Zhi&-`-QX13=?Hnynk@INBjvY_;m zQ1rS5}?Z)HMqi58(Z?kOVe&su9Ue>~ZuT_6GR3Ci$^m|3wuj(m= zJbT0W+D-Sa&Bzsgr)|VFGi*vmWpR<8Oe}|-keAoQv}7mIvOEKcJud|s-4drwQS4Pz zojrLycLPn{pO}2IRTB;XouDEgNj!d0%fJ|hRreoA8pA*bB2EtJ>3E!Tve1CM( z%+}9Kb9vcz%SWr%`>|KaXXIY3mhS$Y@Q$_B_7;~4YodxLhxaLkqN!7SomgKVsGYre zpW3#$&TBn%#MCz&(D7Yzra7nc=A-9aI!vx7jI<91Oo{&XwB>J}_j|(!aRuuae-CX7 zKfNKOA;qBGdr4R3w%LXkCxl(MR1Xs6IkU;&V8W3AgBijrIbRz~8bwPmY{ zsL0aP9Ust0Ug-x4+#st|tiE_nEyq&zVS5+4l zZCq1wDko8Oww9{)@4vHNJ}{pAa4JVP$L!TT6J&H9)}Cw2Qw{L-@(mF)Yi~N`u+cP4 zIbh~?_XB;$Y`>_S-B{3Lkkz3m(EZWffkn_WbMB+a%gar**Y4P3BiGSzCZuI5hf%t& zWVflHf9ai7Cmz|%tQXuQsFA=L5^D4k%BGgQ4)K;Fi^WmStqF7ii&OFm|*_4?xEvu!xwO^99e z%%40HSYK?)m|!)Hcax(q`>~*^^pjoIw<~$?;l%m3zOR{FcIUY5arNoUr8g3{nP2(9p}9&h z)N7N@8M|4f-fL91m2GL6ujwe;D|?lBS>eSclW!%~@weOBmA0)suVbgOv-nqR`W@D7 z**DfbyzF9U(&e9Ye_7#uwRPW5=Koh^>$6g5y|PqX zx8GD|Pv|MXBYzu>WFJJDiyqh8wI%z8=k`y^?skE7{~Gkx9l2`0^6$TgFB;cp-uZ0G zvnK5O4BLb<@k`Bjwz~!fhUk{5MDHotD6%wp=BddG_!5^XI7{p+@ncL@_ndK{tnpp> zlh1tizvSM`srujbXH{U`9`*W9%qMJ@oqu?Gd&HuJ#ja189*cfRd+_4Lq_^KBzpsA0 z@LI69Z2B{WRKuOBhSh3~y!V;Hte$z^Z)rPt_R#d87sa*mO{@CeF|Ctbw>#&lSX8hH zll2+-3%?q!?pO0(n3I1}ujkpaaDh5cXrOK+tcI%c>c&n z)tY+Wf4@`qd(FP0y3UHTs^)C@33-)&e;n;Dck%ghPa^!h#@7>& zGUlr}DEi;?jDmdQJ*H!)r}OWr-Tm~ak ze|U%6N2yo3Q+Dn;zqRgX$pyuC&&wXH{GYcu_tM8lCQ{p9cZNT!Y5XC%{7+AK@d^3- z?^kZ`DgR&3VE0h?U*D7Y7SG>*SJr>qF?my(Yia^-WTWV@J2w_Hp88!LGfPu9z9`GV z#ASY?&<-`e_fS3P&? zgj#cy8(XOhYp=rLkZJ#Q9D+~p^84&{L}sS&%aTcZWp|ul-)DL2GwVTr$%>=v_g{TF zpY<2Zw=zqKgOgT=elY+3Vbi*bI5V5mDXoEP1H2E)#dAfw*?s+`G(jPw;#}39>7UaI z>a5G^jvf)8^Qr56Me2u}^ACJkzFl2%&lBNuKP8?|J}fxjs37lHW{=EzH#e7!by zc^{{3a269(?R+Cs^>~A+-mk{hr5~cD);FC0*>=C+``v>7>l^hF;+ga{YYzGUXgRn1 z)+eUtmQ(xRJ*?T9B&&UG^^#f7UYK`;Dtau7-DIB^b8+YP#_K+NmVU5|UiVW!?&3d# z!hi7&{~2`VY<${de9rP2d&oZj0+$U>d!Dnrc0R;$Vn*AcdB+-$&6~Kru;NKR8IGcYt{U|?X-f?^PR8Uq7^AOiyfBO?O?gD?XF1Bdf81_lsjU|aehu_iYAvvT6%JRPJWSs2AI+55uFaSeCO-(M1BrMW~3SbD5 zt|%@@OwPft%)={+QgsV*67xVRK;Z_W*`Q(fpMilv5yZA{00}d2fY_kG zXJBC9gt9>rN=R%OBsLckTLFp9jl||bV)G)g`9X0DG8~H8p>iPeRiSKO|L1?de*FfE{r&s< zFVml&zkmJx_50s{ra%1ufBpLX^Vjb`%)c4`eEj|A_pd*{|NQ>*>-+C--@dT_|NiIy z|KI=r{r>)&?GMv$=0E>`GyP%w`RnhmzrX)~WCc0&KhwXzzkd8>`t$!U?;pnBKY#xI z{pZi$H!T1E|7QOG{rCT0fB*dX`|mH)AI87`{`_YC^X2cK-(XAr{QdKf<^TV`%>O_B z`}^bX@4x^4{{8p&&+lKqng1~U{rme5*g}XoKmYyy^Xt!_zs&#s|K<9_3^L%)@4pZ^ z#@~#;82|kH`;X}_*mWTLe*b3v!}R<2&p$uEeqsOr^UrUPpZ+laW%|PmQuLSQ57TeP zpMQV-{lohI*}vbQ!20 z0fjv4-#`EUfUNxT=PxMGe*OIQ^XEU7|3ChM!~fS`ravtI82^Hz;xE&`FMt1mLgm-* zpFe;6W%>W+@9$qAgFtqHJ^lC3-+wHBfByRmR>k!5->O_f(aCU|5*Ni0I7fk<*%PVe*OB!{Gah3 z6FBPr{r$!CkMZySf2{vm{(b|+^v_?vfBpQ%^8e%C-@ktS`3s7iKmY#z`OEg7`R~7f zf0;q?@$2U|=KsI{{r&}tnxB7vgTsaml(0bZpz!(44078q#y|f-kp~KyzyDbN|NI9s z@Xs&i-@kwU`1#{2Ge`tv&2Q#EKmYy*dHo;Lf9AiRK_U1X6gWSBe*eMp|JR>iAiJ3U z{QdjyAM@Y;f0+Kh|NZCBk3WC^{QUas*YEG&etiGS^8XVkyng)x#oq6~fB&)n{rBT9 z)9-ITKr#0H=eMt4K}vr91epd7%D?~E{(kuR3zQ8&qQ8Is`1S=9T)%((`t=(WBcSm3 z_wNt$-@m_q{$~F5_s_3COuzp8{Qlz~>;IpBe*OIY^YUm z57Y1OKY#!D{q5iX{~wtD|N8zD;`U#^{`~s$?>Ez*kH0}K_zSY(_n%+C|8e~P`R~V1 zkUN-u|NQg&=kGtie>4C3^844XAHTl;{Q2w0_wP*q|1$jl!uk+IDdZo@$LJMpFe+m`~8RMKN|zf|9{`UGyP=x{_n?kmY-jL zeE;?R`;Q;r|9t(!^q+%)`Tw_nKfxM*eE-J$1EloF@1Nhl|Mwf_TuK$0(|M|`FUxeZR2f_c`3|#-;f};BCr}yt(zkc=d_1ib^KmGV2 z`v2>nAKyN|d;R?BqlfpI?)|uX|KZb@Z$5k%{QvCFk8dB}ynOQD-kqD*uU)x(>C)xP zS8v^W`10*nzW-1D{P_I-#gqGYZeG7~`Qn9hXHTCxb@J5dbC+&Cdi{mx|D!+OKE8hX z;LeR}S1(_@aQ@tx(sPN_x_III+0&;^ z96xsW(1HDX_wGA<`pT0}9RKhA{`&U$!`nBmUb%en;`wuD&zwGa;@FWx2lnpSwR8K9 zoqLYn`M~!7&hM{ppFOw*as|j4XF!UMA3c0%|K43Ywr$?9e#5#gSKqPxzxDh3`{(y> zUcG$r(&a0c&!0JS>ePu7$BrC6xPQ;CZCf_1+jsuJ%B}a`F#Z4V`}@b|_iunab@}$Q z$Jfp+|zFAcbd6pSkep-RlQeu3W!y`Ra`uSI(V2vUmHYbt@Oo zpFLytqRp3{e0}}s+Qsu{&zw1R^3?eox31s3^X9{?>v!+nxpC#pk=v0)?$h1d4c`C(hrv|K#=O??0G+G5);u z{p;%ow{D)_yK?T7p4OW3;>s!4&mP{tci+DK2M(RMbnC&>w_m>h{K@od|IZ)a-aoo| z?ZUp5vnO^mRutzJcU?PmV9&1IyZ7upaO~2ZhtJ-91r=R?e*gUW?ft`Rm(J~7F|)6& zrZg`ttMpp)!mDy4sDz_v8|>kJuxCG{?f6XTQ+Ulym`y^ zy(g|cc=G(+=WpLZ<;d5M&u*VTvVFz$uKM!a_%MHGzpKZ0Zdkv5-G+^ucO1HK_tBH* zZ$Euy`u6hc$Cvl7oZPi$c29jtZgRA*i?Q1EV>{L}t!7+%YyIY3$FAIc@aW0Qw;w)! zc=z)D#bdiy&+KfdDNT*=cQI5~cyMax+LcVp8yKZmu3Ecky7?%%%q;K{RRPw!tj zy6?o^8FgJNmsSPYnW`&tJUhK>&C(@{7cX75V)e#dC$8MMe&x#5oA>TrKe_YN%X=H^ z*IYQaB+|w}ONrydmHq1%FI+Hx{(=QdR<7T1{+vB&RMg4&5BLC4jwshVE^82`_3(&ws&`5#-u&_x_pdvROJ}{ zzdgHc>Fnv#rc9Z>W%t^7i&n1PuwmWmrSncdJ6v8?mJ||Sm=|QBuPVyG@c+%FL#yXZ zo!H+yVg9PQQ>MPLGd|j`VkTwlPUs_JkuJd~5sF|>Aa_3;mlj7dmHOiW0OkBbfs@N##sGB?yz<6?No zCm^qGU}f**?&TX492y=T78)Gn=jG<)V4@JUow#lXzY!O_{(-OJmD$&1nb zhohZ^iGik^4nMWjBz`?=8 z!1bT;&->p$z}3X7moHwys)<+7YU0VGhxhK@y?5vSgQqWEzyAiRCVqbV@aDyn2X}AZ zxPJBWrHdCYUAlr?O}u;g*h@x z)~#K&V&&#*&}!n@{hL=Ht^wCJ`}XeMxntXw%^TLPS+!!>l0}Qa)x^!;-#Jh*ZB!nrf2P8>gT3grIX zyS8uLylMT~)vH!4TeNWg(%CZ>?78{!|L<>aAKkig9#n@NJ9_2f!F^Dx*RNf@V(H>V z^XJZ)Ic@6fRYxH8#Fg`)O7rNELx&IT*|l@q*3BC?tXaKs+0sP|=FOcoed^>%)8}ux z^!V%Rhu1EgISH*?ckkT3ZTohZUlz=rJ!9JBiT%C()0XT6)e{%bfc$)L|GquDc5DNM z-rChGS1f^AJgL98yS=?<#+nna9$r0r0umD-KQnD^VB*=ZcJ<0-OBT+bGi%1w$rJm! zJ6fBYTl*Fses=f5$)kr3?%%r`WaOp|>({Scvu5?mr3>cFoIYh@e@|z7OH*A+qZ7sxNhy5H5)c>+qP-VqFGZXP3Y_HY-_HssVFb2YF~Zt(uqS512=C1 z`DN9*t$X(G-?Meq+$sG%U9HUxwbkV%g#{&bi*KDfx_{5^?c26&-neefs+B8NZQ672 z$dN;PHZGjh-QLnzS5r}1RFIvSSv>LjnL~SaZr{3PwN>Rs`8k=XNy$0w*G}%=xorz5q9F-l`Ify$jvqg`ck9v#Ep=5DB?Wm|=}GZ1 z(MeTTj_=*RdE@%Et5+^xvUuVAxr;XJK5+2hzTF!abk$Xr6&GY@rp8Byg#?A?UpcmG z^M-Y6RxMw)WZ}Fyvu4g+v3b{?J-fE7oZ4JjT9}uanivxq;_vP0A93mEj*XC@UNCR= z%;{67%~`%-%jS(MXLVE+=4GWN#Ycq(`Z(L!TDe_2wtd~Imp0tGB1Uxvr)tJvlx+ z#Lvsw#!N?9gn{9~sqL$mf-RmhslTtQt);1& z6y}10FFGu!xX|8IHzAyzmErFDhetLnm_B(zZ&zn)YeRKKX;FT5W=djgSg?{p}ncLs=PQqCnF^x+|x!|Scrk?|Hmu)S59fI zD$GiX3~;s3;Hzh}V`yNQ2yXsfJa^{gvBO7?96WOTuV~@ ziwp8@-MDrclnaj@JaXdXnafvh-MM%7{=Hk*uAVxwef`q86Pg?9s>(}>@^iATU%qhm z^ogT~kDWYq@!FjS&tJWH|Ka`ncW<6Qx^wyHj`j1Vv{#fB7v|<RL=G5^chmIUS zd*#lP*B?QR8|Ghketi4#;nls%M>j6$ZvZ9Pw3LLir%oI>wExhl3%8!U`Sktg?>|g` z8UHcv@UAHMzi^OyVI(?7qyzkhsb z=i>I_l*G8`h$9F0?>TVd(*2iTe*R_t$N8V>-^)KgKR>^Baa(&%bYxh_fqgso9=&+) z<>y~a|G56M{(JfN*Y}^lKA&w%3k?d`y<^Y8Gq+xT{`K!4*MIJR@BaV$wx=lG*L(Z! z{l~99`~34SSeWVmhdJi!-Fg4>?>~?z&wq}8pMQP2zPdVO-fB*Z({GaI`?|-&`jDNp= zd$7GF@WA=!-~NEQ)BpJXv;X___vfp_Q=|4@e*NR`zyJSP{_+23`}ghduXh*bgdMu^ z_9y#40kFWIkCzt*9lQPR7yCcK|E&MM{r&Uh*2>spH{T-(+*}@c@CJ&&vatQv-y&3e zzOf{D+r>9OA!dC2`}^aSSpi$lJpb{R9c=H{zdzrf?6X^W_~F;zFp(cG4)s{i-F553 zFAkVDzTe+gqSLkd+-rzF#(zxzKmYst_3FF~ow|hwAAb4G`HvSgk^$=Ye>u|aC6?2@ z=KPxwkgfJPr+Qg7FnSc_$p&f0tb^Ka&VjQ_d+G5&u78an~wKi8&4>4=3UH7`5; z;@h9Upg|R`e@y?`|GoeFYD0;&7(-xOY1gJ}Z@&Ni%lGg9f7XADf8YLjcceQ?hk?P@ zD?ESto*Qp|{QWERkMZxz-(Q~}oSLB{#=v0j;E+%@W#_He-~asm%m0t@?~k9KpB|r= zVJ*hS@I%L|WZA{%pMNs_<^IR`_xqn8A0C0FI2gWzq>kTz_w6V1U)Fz2f4}|t`Q`PE zgYz=HbhsG4=y;V(-F@-V`>#KK|6%?6< Date: Sun, 8 Jan 2023 04:10:15 +0100 Subject: [PATCH 68/81] add topbar with mana, fix bug where newly created state was not stored in the hashtbl :angry:, clean code --- src/dune | 2 +- src/island.ml | 22 ++++++++++---- src/island_client.ml | 69 +++++++++++++++++++++++++------------------- src/log.ml | 9 ++++++ src/map.ml | 49 ++++++++++++++++++++++--------- src/pellest.ml | 4 +-- src/state.ml | 21 ++++++++++++-- src/time.ml | 27 +++++++++++++++++ src/user.ml | 5 +++- src/ws.ml | 37 ++++++++++++------------ src/ws_client.ml | 21 +++----------- 11 files changed, 177 insertions(+), 89 deletions(-) create mode 100644 src/log.ml create mode 100644 src/time.ml diff --git a/src/dune b/src/dune index c5a5f3a..db008b0 100644 --- a/src/dune +++ b/src/dune @@ -45,7 +45,7 @@ (library (name shared) - (modules map network state) + (modules log map network state time) (libraries)) (rule diff --git a/src/island.ml b/src/island.ml index eab4678..411d570 100644 --- a/src/island.ml +++ b/src/island.ml @@ -1,27 +1,39 @@ open Tyxml.Html open Syntax -let mk_img name = +let mk_img hidden name = + let a = [ a_id name ] in img ~src:(Format.sprintf "/assets/img/%s.png" name) ~alt:name - ~a:[ a_hidden (); a_id 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 + div ~a:[ a_class [ "centered" ] ] @@ [ mana_img; mana_lvl ] + in + let canvas = canvas ~a:[ a_id "canvas" ] [ txt "please update your browser or enable javascript" ] in - let images = - List.map mk_img + + let canvas_images = + List.map (mk_img true) [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] in - let page = div ~a:[ a_class [ "centered" ] ] @@ (canvas :: images) in + let page = + div ~a:[ a_class [ "centered" ] ] @@ (topbar :: canvas :: canvas_images) + in let js = script diff --git a/src/island_client.ml b/src/island_client.ml index 5e430e0..d75855d 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -12,7 +12,7 @@ end let get_el id = match Document.find_el_by_id G.document (Jstr.of_string id) with - | None -> failwith (Format.sprintf {|Could not find element by id: "%s"|} id) + | None -> Log.err "could not find element with id `%s`" id | Some el -> el let tile_size = 40 @@ -51,17 +51,16 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") -let draw = +let draw_canvas = 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 fun state -> let open State in - let player_x, player_y, player_dir = state.player_pos in for x = 0 to tiles_per_w - 1 do - let map_x = x + player_x - (tiles_per_w / 2) in + let map_x = x + state.player_pos.x - (tiles_per_w / 2) in let tile_x = float_of_int ((x * tile_size) + orig_x) in for y = 0 to tiles_per_h - 1 do - let map_y = y + player_y - (tiles_per_h / 2) in + let map_y = y + state.player_pos.y - (tiles_per_h / 2) in let tile_y = float_of_int ((y * tile_size) + orig_y) in let tile_img = match Map.get_tile_kind ~x:map_x ~y:map_y state.map with @@ -73,7 +72,7 @@ let draw = done done; let papy = - match player_dir with + match state.player_pos.dir with | Left -> papy_left | Right -> papy_right | Down -> papy_down @@ -81,6 +80,11 @@ let draw = in C2d.draw_image context papy ~x:papy_x ~y:papy_y +let draw_topbar state = + 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) + (* queue for action to be done *) let input_queue = Queue.create () @@ -89,8 +93,13 @@ let to_apply_queue : State.action' Queue.t = Queue.create () let send_action state action = match State.check_action state action with - | Error e -> Format.printf "Invalid action: %s@\n" e - | Ok _ -> Ws_client.send (Network.Action_msg action) + | Error e -> + (* TODO: display this in the window *) + Log.debug "invalid action: %s@\n" e + | Ok Look_at_the_sky -> () + | Ok _ -> + Log.debug "sending action %a to server@\n" State.pp_action action; + Ws_client.send (Network.Action_msg action) let kb_handler ev = let open State in @@ -105,31 +114,31 @@ let kb_handler ev = in Queue.add act input_queue -let last_auto_state_update = ref 0. +let render state = + draw_canvas state; + draw_topbar state -let rec game_loop state timestamp = - draw state; - let new_state = - (* TODO repesct order of action *) - (* apply to_apply_queue *) +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 + let state = + (* apply queue of actions *) let state = Queue.fold State.perform_action state to_apply_queue in - (* TODO can this bug because of concurrency? *) Queue.clear to_apply_queue; (* send input action to server *) Queue.iter (send_action state) input_queue; Queue.clear input_queue; - - (* auto_update *) - if - timestamp -. !last_auto_state_update - >= float_of_int @@ (State.auto_state_update_rate * 1000) - then ( - Format.printf "MANA: %d@." state.mana; - last_auto_state_update := timestamp; - State.auto_update state ) - else state + (* state auto update *) + if should_auto_update then State.auto_update state else state in - G.request_animation_frame (game_loop new_state) + G.request_animation_frame (game_loop state last_auto_update) let () = (* init canvas *) @@ -147,10 +156,10 @@ let () = match server_msg with | Full_state _state -> (* TODO reset state to received state *) - Format.printf "received Full_state message@\n" + Log.debug "received `Full_state` message@\n" | Update_result res -> ( match res with - | Error e -> Format.printf "received update result error: %s" e + | Error e -> Log.debug "received update result error: %s@\n" e | Ok action' -> Queue.add action' to_apply_queue ) ); (* bind keys *) let _e : Ev.listener = @@ -160,9 +169,9 @@ let () = Fut.await initial_state_fut (fun msg -> match Ws_client.to_server_msg msg with | Update_result _res_msg -> - failwith + Log.err "invalid first server message received; received Update expected \ Full_state" | Full_state state -> (* start game *) - G.request_animation_frame (game_loop state) ) + G.request_animation_frame (game_loop state 0.) ) diff --git a/src/log.ml b/src/log.ml new file mode 100644 index 0000000..12308c3 --- /dev/null +++ b/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 diff --git a/src/map.ml b/src/map.ml index 4860914..516d7a6 100644 --- a/src/map.ml +++ b/src/map.ml @@ -9,7 +9,30 @@ type background = | Water | Black -type position = int * int * dir +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" + 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 @@ -18,8 +41,8 @@ type t = } let init () = - let width = 1000 in - let height = 1000 in + let width = 100 in + let height = 90 in let tiles = Array.init width (fun _x -> Array.init height (fun _y -> @@ -30,17 +53,17 @@ let init () = let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black -let check_move map entity_pos dir = - let x, y, current_dir = entity_pos in - let x, y = - if current_dir <> dir then (x, y) - else - match dir with +let check_move map ({ x; y; dir } as pos) movement_dir = + if dir <> movement_dir then Ok { pos with dir = movement_dir } + else + 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 -> Error "invalid terrain" - | Grass -> Ok (x, y, dir) + 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 -> Ok { pos with x; y } diff --git a/src/pellest.ml b/src/pellest.ml index 7356070..97ce928 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -16,9 +16,9 @@ let update_online_user_state () = let () = regularly_call_fun update_online_user_state - (float_of_int Shared.State.auto_state_update_rate); + (Shared.Time.s_to_float Shared.State.auto_update_rate); regularly_call_fun update_offline_user_state - (float_of_int Shared.State.auto_state_update_rate) + (Shared.Time.s_to_float Shared.State.auto_update_rate) let () = let logger = if App.log then Dream.logger else Fun.id in diff --git a/src/state.ml b/src/state.ml index 4b3564d..7ef6b1d 100644 --- a/src/state.ml +++ b/src/state.ml @@ -4,7 +4,8 @@ type t = ; player_pos : Map.position } -let init () = { map = Map.init (); mana = 0; player_pos = (20, 3, Down) } +let init () = + { map = Map.init (); mana = 0; player_pos = { x = 0; y = 0; dir = Down } } type action = | Meditate @@ -18,6 +19,17 @@ type action' = | Set_player_position of Map.position | Look_at_the_sky +let pp_action fmt = function + | Meditate -> Format.pp_print_string fmt "Meditate" + | Move dir -> Format.fprintf fmt "Move %a" Map.pp_dir dir + | Do_nothing -> Format.pp_print_string fmt "Do_nothing" + +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 + | Look_at_the_sky -> Format.pp_print_string fmt "Look_at_the_sky" + let check_action state = function | Meditate -> if state.mana < 99 then Ok (Add_mana 1) else Error "maximum mana" @@ -39,4 +51,9 @@ let auto_update state = let state = perform_action state action' in state -let auto_state_update_rate = 5 (* in secs *) +let auto_update_rate = Time.mk_s 1 + +let pp fmt { mana; player_pos; map } = + let bg = Map.get_tile_kind ~x:player_pos.x ~y:player_pos.y map in + Format.fprintf fmt "mana = %d; player_pos = %a; %a" mana Map.pp_position + player_pos Map.pp_background bg diff --git a/src/time.ml b/src/time.ml new file mode 100644 index 0000000..c96655d --- /dev/null +++ b/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 ) diff --git a/src/user.ml b/src/user.ml index a3dfe83..e0e9517 100644 --- a/src/user.ml +++ b/src/user.ml @@ -233,4 +233,7 @@ 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 -> Ok (Shared.State.init ()) + | None -> + let state = Shared.State.init () in + Hashtbl.replace state_ht user_id state; + Ok state diff --git a/src/ws.ml b/src/ws.ml index b94646c..827aef9 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -1,40 +1,41 @@ 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 "user_id" request with | None -> Dream.log "User does not exists" |> Lwt.return | Some user_id -> - (* TODO catch marshal failure *) - let state = - match User.get_state user_id with - | Error _e -> assert false - | Ok state -> state - in - let state_msg = Network.Full_state state in - - (* send user island state *) + (* 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 state_msg) + Dream.send ~text_or_binary:`Text client + (Network.marshal (Network.Full_state state)) in let rec loop () = match%lwt Dream.receive client with - | None -> Dream.close_websocket client + | None -> + (* TODO: backup everything to database *) + Dream.close_websocket client | Some s -> - let state = - match User.get_state user_id with - | Error _e -> assert false - | Ok state -> state - in + 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 _e as error -> error + | Error msg as e -> + Dream.log "check_action error: %s" msg; + e | Ok action' -> - (* update server state *) + Dream.log "check_action ok: %a" State.pp_action' action'; let state = State.perform_action state action' in User.set_state user_id state; Ok action' diff --git a/src/ws_client.ml b/src/ws_client.ml index 41649a0..f34b86a 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -3,7 +3,6 @@ open Brr_io open Shared let ws = - Format.printf "create websocket@\n"; let ws_url = let location = Window.location G.window in let host = Uri.host location |> Jstr.to_string in @@ -18,30 +17,18 @@ let ws = let ws_target = Websocket.as_target ws -let on_event ws_event log_msg f = - let (_ : Ev.listener) = - Ev.listen ws_event - (fun ev -> - Format.printf "%s@\n" log_msg; - f ev ) - ws_target - in +let on_event ws_event f = + let (_ : Ev.listener) = Ev.listen ws_event f ws_target in () let to_server_msg ev = - Format.printf "to_server_msg@."; let data = Message.Ev.data (Ev.as_type ev) |> Jstr.to_string in let server_msg : Network.server_message = Network.unmarshal data in - Format.printf "un-marshaled message from server yay ~ @\n"; server_msg let on_update_state_message f = - on_event Message.Ev.message "Websocket reveived message!" (fun ev -> - f (to_server_msg ev) ) + on_event Message.Ev.message (fun ev -> f (to_server_msg ev)) let send (msg : Network.client_message) = - Format.printf "send msg on websocket ~~ @\n"; let s = Jstr.of_string (Network.marshal msg) in - Websocket.send_string ws s; - Format.printf "send action on websocket ~~ DONE @\n"; - () + Websocket.send_string ws s From 1d71c9f09be7382f9bca1fd41375b505303f8b2c Mon Sep 17 00:00:00 2001 From: pena Date: Sun, 8 Jan 2023 04:22:28 +0100 Subject: [PATCH 69/81] do not call regularly_call_fun twice as second call will overwrite the first one... --- src/pellest.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/pellest.ml b/src/pellest.ml index 97ce928..9ee23fa 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -14,10 +14,12 @@ let update_online_user_state () = (fun _user_id state -> Some (Shared.State.auto_update state)) User.state_ht +let to_repeat () = + update_online_user_state (); + update_offline_user_state () + let () = - regularly_call_fun update_online_user_state - (Shared.Time.s_to_float Shared.State.auto_update_rate); - regularly_call_fun update_offline_user_state + regularly_call_fun to_repeat (Shared.Time.s_to_float Shared.State.auto_update_rate) let () = From f8468df4726d8e06e7ade444af16715dabd6623f Mon Sep 17 00:00:00 2001 From: pena Date: Mon, 9 Jan 2023 02:40:40 +0100 Subject: [PATCH 70/81] fix medidate key --- src/island_client.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index d75855d..43f02cd 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -103,14 +103,17 @@ let send_action state action = let kb_handler ev = let open State in + let ev = Ev.as_type ev in let act = - match ev |> Ev.as_type |> Ev.Keyboard.code |> Jstr.to_string with + match Ev.Keyboard.code ev |> Jstr.to_string with | "KeyW" | "ArrowUp" -> Move Up | "KeyA" | "ArrowLeft" -> Move Left | "KeyS" | "ArrowDown" -> Move Down | "KeyD" | "ArrowRight" -> Move Right - | "KeyM" -> Meditate - | _s -> Do_nothing + | _code -> ( + match Ev.Keyboard.key ev |> Jstr.to_string with + | "m" -> Meditate + | _key -> Do_nothing ) in Queue.add act input_queue From d778e05931dbd0dbbadf3ed27372d161339a00a1 Mon Sep 17 00:00:00 2001 From: pena Date: Mon, 9 Jan 2023 03:37:01 +0100 Subject: [PATCH 71/81] implement redirection when user should be logged in/logged out --- src/login.ml | 12 +++++++++--- src/logout.ml | 12 ++++++++++-- src/syntax.ml | 18 ++++++++++++++---- src/user.ml | 14 ++++++++++++-- 4 files changed, 45 insertions(+), 11 deletions(-) diff --git a/src/login.ml b/src/login.ml index 3316620..3993ba2 100644 --- a/src/login.ml +++ b/src/login.ml @@ -5,6 +5,13 @@ 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 login = let submit = button ~a:[ a_id "submit_login" ] [ txt "submit" ] in let login = @@ -13,8 +20,7 @@ let get request = let password = input ~a:[ a_id "password"; a_name "password"; a_input_type `Password ] () in - div - [ make_form request ~action:"/login" ~items:[ login; password; submit ] ] + div [ make_form request ~action ~items:[ login; password; submit ] ] in let text = div [ txt "login ~!" ] in let page = div [ text; login ] in @@ -32,5 +38,5 @@ let post request = in Dream.respond ~status:`See_Other ~headers:[ ("Location", url) ] - "Logged in: Happy geo-posting!" + "Logged in: Happy pellesting!" | _form -> Template.err (`Bad_Request, "invalid form") diff --git a/src/logout.ml b/src/logout.ml index 94a273d..9beaf53 100644 --- a/src/logout.ml +++ b/src/logout.ml @@ -4,5 +4,13 @@ let get request = 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 - Template.render ~title ~scripts:[] page + + 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!" diff --git a/src/syntax.ml b/src/syntax.ml index 74f5f57..8b3cc40 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -1,6 +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 ( let** ) o f = match o with Error e -> Template.err e | Ok v -> f v +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 diff --git a/src/user.ml b/src/user.ml index e0e9517..56aa4ba 100644 --- a/src/user.ml +++ b/src/user.ml @@ -218,10 +218,20 @@ let public_profile user_id = let assert_logged request = if is_logged_in request then Ok () - else Error (`Forbidden, "you should be logged in") + 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 Error (`Forbidden, "you shoudn't be logged in") + 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 *) From 1f632f65cb4b31e6448e1cc165c30cb82730cd0a Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 10 Jan 2023 04:39:58 +0100 Subject: [PATCH 72/81] add medidate button --- src/island.ml | 25 +++++++++++++++++-------- src/island_client.ml | 15 +++++++++++++-- 2 files changed, 30 insertions(+), 10 deletions(-) diff --git a/src/island.ml b/src/island.ml index 411d570..50fdccc 100644 --- a/src/island.ml +++ b/src/island.ml @@ -17,24 +17,33 @@ let get request = let topbar = let mana_img = mk_img false "mana" in let mana_lvl = span ~a:[ a_id "mana_lvl" ] [ txt "0" ] in - div ~a:[ a_class [ "centered" ] ] @@ [ mana_img; mana_lvl ] + div ~a:[ a_class [ "centered" ] ] [ mana_img; mana_lvl ] in let canvas = - canvas - ~a:[ a_id "canvas" ] - [ txt "please update your browser or enable javascript" ] + div + ~a:[ a_class [ "centered" ] ] + [ canvas + ~a:[ a_id "canvas" ] + [ txt "please update your browser or enable javascript" ] + ] in let canvas_images = - List.map (mk_img true) - [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] + div + @@ List.map (mk_img true) + [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] in - let page = - div ~a:[ a_class [ "centered" ] ] @@ (topbar :: canvas :: canvas_images) + let bottombar = + let medidate_button = + button ~a:[ a_id "medidate_button" ] [ txt "Medidate" ] + in + div ~a:[ a_class [ "centered" ] ] [ medidate_button ] in + let page = div [ topbar; canvas; bottombar; canvas_images ] in + let js = script ~a: diff --git a/src/island_client.ml b/src/island_client.ml index 43f02cd..8497116 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -101,7 +101,7 @@ let send_action state action = Log.debug "sending action %a to server@\n" State.pp_action action; Ws_client.send (Network.Action_msg action) -let kb_handler ev = +let keydown_handler ev = let open State in let ev = Ev.as_type ev in let act = @@ -164,9 +164,20 @@ let () = match res with | Error e -> Log.debug "received update result error: %s@\n" e | Ok action' -> Queue.add action' to_apply_queue ) ); + (* bind keys *) let _e : Ev.listener = - Ev.listen Ev.keydown kb_handler (Window.as_target G.window) + Ev.listen Ev.keydown keydown_handler (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 Fut.await initial_state_fut (fun msg -> From 498d187d766a180a16e07f0e49247f8c1d5b1925 Mon Sep 17 00:00:00 2001 From: pena Date: Tue, 10 Jan 2023 05:07:07 +0100 Subject: [PATCH 73/81] use wss instead of ws when not on localhost --- src/ws_client.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ws_client.ml b/src/ws_client.ml index f34b86a..05179c8 100644 --- a/src/ws_client.ml +++ b/src/ws_client.ml @@ -11,7 +11,8 @@ let ws = ~some:(fun port -> Format.sprintf ":%d" port) (Uri.port location) in - Jstr.of_string @@ Format.sprintf "ws://%s%s/island/ws" host port + 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 From 03933d3fd4019a6e78aef641b994a4f482666898 Mon Sep 17 00:00:00 2001 From: pena Date: Thu, 12 Jan 2023 04:19:40 +0100 Subject: [PATCH 74/81] better keyboard handling --- src/island_client.ml | 99 +++++++++++++++++++++++++++++++++++++------- 1 file changed, 84 insertions(+), 15 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 8497116..33ef546 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -101,21 +101,82 @@ let send_action state action = Log.debug "sending action %a to server@\n" State.pp_action action; Ws_client.send (Network.Action_msg action) -let keydown_handler ev = +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" |]; + (* 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 - let ev = Ev.as_type ev in - let act = - match Ev.Keyboard.code ev |> Jstr.to_string with - | "KeyW" | "ArrowUp" -> Move Up - | "KeyA" | "ArrowLeft" -> Move Left - | "KeyS" | "ArrowDown" -> Move Down - | "KeyD" | "ArrowRight" -> Move Right - | _code -> ( - match Ev.Keyboard.key ev |> Jstr.to_string with - | "m" -> Meditate - | _key -> Do_nothing ) - in - Queue.add act input_queue + 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 Up + | "KeyA" | "ArrowLeft" -> Move Left + | "KeyS" | "ArrowDown" -> Move Down + | "KeyD" | "ArrowRight" -> Move Right + | "m" -> Meditate + | _ -> + (* 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; @@ -131,6 +192,7 @@ let rec game_loop state last_auto_update timestamp = 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 @@ -167,7 +229,14 @@ let () = (* bind keys *) let _e : Ev.listener = - Ev.listen Ev.keydown keydown_handler (Window.as_target G.window) + 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 *) From 8e2faf3b21e439ab459d3742e280ec7a03c9e4cc Mon Sep 17 00:00:00 2001 From: pena Date: Sun, 15 Jan 2023 00:48:47 +0100 Subject: [PATCH 75/81] implement grid offset --- src/island_client.ml | 61 +++++++++++++++++++--------- src/map.ml | 26 ++++++------ src/network.ml | 2 +- src/state.ml | 97 ++++++++++++++++++++++++++++++++++++-------- src/ws.ml | 8 +++- 5 files changed, 141 insertions(+), 53 deletions(-) diff --git a/src/island_client.ml b/src/island_client.ml index 33ef546..e0dfb72 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -52,16 +52,27 @@ let papy_up = C2d.image_src_of_el (get_el "papy_up") let water = C2d.image_src_of_el (get_el "water") 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 - for x = 0 to tiles_per_w - 1 do - let map_x = x + state.player_pos.x - (tiles_per_w / 2) in - let tile_x = float_of_int ((x * tile_size) + orig_x) in - for y = 0 to tiles_per_h - 1 do - let map_y = y + state.player_pos.y - (tiles_per_h / 2) in - let tile_y = float_of_int ((y * tile_size) + orig_y) 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 @@ -91,15 +102,24 @@ 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 action = - match State.check_action state action with - | Error e -> - (* TODO: display this in the window *) - Log.debug "invalid action: %s@\n" e - | Ok Look_at_the_sky -> () - | Ok _ -> - Log.debug "sending action %a to server@\n" State.pp_action action; - Ws_client.send (Network.Action_msg action) +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 *) + | Meditate 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, @@ -165,10 +185,10 @@ let apply_last_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 Up - | "KeyA" | "ArrowLeft" -> Move Left - | "KeyS" | "ArrowDown" -> Move Down - | "KeyD" | "ArrowRight" -> Move Right + | "KeyW" | "ArrowUp" -> Move_offset Up + | "KeyA" | "ArrowLeft" -> Move_offset Left + | "KeyS" | "ArrowDown" -> Move_offset Down + | "KeyD" | "ArrowRight" -> Move_offset Right | "m" -> Meditate | _ -> (* if this happen, it means we're adding @@ -225,7 +245,8 @@ let () = | Update_result res -> ( match res with | Error e -> Log.debug "received update result error: %s@\n" e - | Ok action' -> Queue.add action' to_apply_queue ) ); + | Ok actions -> + List.iter (fun action -> Queue.add action to_apply_queue) actions ) ); (* bind keys *) let _e : Ev.listener = diff --git a/src/map.ml b/src/map.ml index 516d7a6..6bffeae 100644 --- a/src/map.ml +++ b/src/map.ml @@ -53,17 +53,15 @@ let init () = let get_tile_kind ~x ~y map = try map.tiles.(x).(y) with Invalid_argument _ -> Black -let check_move map ({ x; y; dir } as pos) movement_dir = - if dir <> movement_dir then Ok { pos with dir = movement_dir } - else - 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 -> Ok { pos with x; y } +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 -> Ok { pos with x; y } diff --git a/src/network.ml b/src/network.ml index 729b569..83cd67f 100644 --- a/src/network.ml +++ b/src/network.ml @@ -6,6 +6,6 @@ let unmarshal o = type server_message = | Full_state of State.t - | Update_result of (State.action', string) result + | Update_result of (State.action' list, string) result type client_message = Action_msg of State.action diff --git a/src/state.ml b/src/state.ml index 7ef6b1d..9b2ca6f 100644 --- a/src/state.ml +++ b/src/state.ml @@ -1,59 +1,124 @@ +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 ; player_pos : Map.position + ; offset_x : float + ; offset_y : float } let init () = - { map = Map.init (); mana = 0; player_pos = { x = 0; y = 0; dir = Down } } + { map = Map.init () + ; mana = 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 - | Do_nothing (* type for result of action send to the client by the server *) type action' = | Add_mana of int | Set_player_position of Map.position - | Look_at_the_sky + | Set_offset of float * float 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 - | Do_nothing -> Format.pp_print_string fmt "Do_nothing" 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 - | Look_at_the_sky -> Format.pp_print_string fmt "Look_at_the_sky" + | Set_offset (x, y) -> Format.fprintf fmt "Set_offset (%f, %f)" x y -let check_action state = function +let rec check_action state = function | Meditate -> - if state.mana < 99 then Ok (Add_mana 1) else Error "maximum mana" + 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) ) - | Do_nothing -> Ok Look_at_the_sky + | 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 let perform_action state = function | Add_mana n -> { state with mana = state.mana + n } | Set_player_position player_pos -> { state with player_pos } - | Look_at_the_sky -> state + | Set_offset (offset_x, offset_y) -> { state with offset_x; offset_y } let auto_update state = match check_action state Meditate with | Error _e -> state - | Ok action' -> - let state = perform_action state action' in - state + | Ok actions -> List.fold_left perform_action state actions let auto_update_rate = Time.mk_s 1 -let pp fmt { mana; player_pos; map } = +let pp fmt { mana; 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; player_pos = %a; %a" mana Map.pp_position - player_pos Map.pp_background bg + Format.fprintf fmt + "mana = %d; player_pos = %a; %a; offset_x = %f; offset_y = %f" mana + Map.pp_position player_pos Map.pp_background bg offset_x offset_y diff --git a/src/ws.ml b/src/ws.ml index 827aef9..3d832f8 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -35,8 +35,12 @@ let handle_client request client = Dream.log "check_action error: %s" msg; e | Ok action' -> - Dream.log "check_action ok: %a" State.pp_action' action'; - let state = State.perform_action state action' in + 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 From d90aa54bcfbb9a4f4fea9b8a99327364401980f0 Mon Sep 17 00:00:00 2001 From: pena Date: Sun, 15 Jan 2023 02:23:14 +0100 Subject: [PATCH 76/81] implement wheat ! --- src/island.ml | 20 +++++++++++++++++--- src/island_client.ml | 27 +++++++++++++++++++++++---- src/map.ml | 22 ++++++++++++++++++++-- src/state.ml | 44 ++++++++++++++++++++++++++++++++++++++------ 4 files changed, 98 insertions(+), 15 deletions(-) diff --git a/src/island.ml b/src/island.ml index 50fdccc..ad37b85 100644 --- a/src/island.ml +++ b/src/island.ml @@ -17,7 +17,11 @@ let get request = let topbar = let mana_img = mk_img false "mana" in let mana_lvl = span ~a:[ a_id "mana_lvl" ] [ txt "0" ] in - div ~a:[ a_class [ "centered" ] ] [ mana_img; mana_lvl ] + 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 = @@ -32,14 +36,24 @@ let get request = let canvas_images = div @@ List.map (mk_img true) - [ "grass"; "papy_left"; "papy_right"; "papy_down"; "papy_up"; "water" ] + [ "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 - div ~a:[ a_class [ "centered" ] ] [ medidate_button ] + 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 diff --git a/src/island_client.ml b/src/island_client.ml index e0dfb72..1f25a64 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -51,6 +51,8 @@ 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 @@ -78,6 +80,7 @@ let draw_canvas = | Grass -> grass | Water -> water | Black -> water + | Wheat -> wheat in C2d.draw_image context tile_img ~x:tile_x ~y:tile_y done @@ -92,9 +95,13 @@ let draw_canvas = 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) + (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 () @@ -104,15 +111,17 @@ 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 + (* + | (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 *) - | Meditate as action -> ( + | (State.Move_offset _ | Move _ | Meditate | Plant_wheat) as action -> ( match State.check_action state action with | Error e -> (* TODO: display this in the window *) @@ -160,7 +169,7 @@ let keypress_handler = ; "KeyW" |]; let keys = Hashtbl.create 512 in - Array.iter (fun key -> Hashtbl.add keys key ()) [| "m" |]; + 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. *) @@ -190,6 +199,7 @@ let apply_last_key () = | "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` @@ -270,6 +280,15 @@ let () = 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 -> diff --git a/src/map.ml b/src/map.ml index 6bffeae..ea9c498 100644 --- a/src/map.ml +++ b/src/map.ml @@ -8,6 +8,7 @@ type background = | Grass | Water | Black + | Wheat let pp_dir fmt dir = let s = @@ -21,7 +22,11 @@ let pp_dir fmt dir = let pp_background fmt b = let s = - match b with Grass -> "Grass" | Water -> "Water" | Black -> "Black" + match b with + | Grass -> "Grass" + | Water -> "Water" + | Black -> "Black" + | Wheat -> "Wheat" in Format.pp_print_string fmt s @@ -53,6 +58,19 @@ let init () = 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 @@ -64,4 +82,4 @@ let check_move map ({ x; y; _ } as pos) movement_dir = match get_tile_kind ~x ~y map with | (Black | Water) as bg -> Error (Format.asprintf "can't move on %a" pp_background bg) - | Grass -> Ok { pos with x; y } + | Grass | Wheat -> Ok { pos with x; y } diff --git a/src/state.ml b/src/state.ml index 9b2ca6f..cc8af84 100644 --- a/src/state.ml +++ b/src/state.ml @@ -40,6 +40,7 @@ end type t = { map : Map.t ; mana : int + ; wheat : int ; player_pos : Map.position ; offset_x : float ; offset_y : float @@ -48,6 +49,7 @@ type t = let init () = { map = Map.init () ; mana = 0 + ; wheat = 0 ; player_pos = { x = 0; y = 0; dir = Down } ; offset_x = 0. ; offset_y = 0. @@ -58,23 +60,30 @@ type action = (* 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 -> @@ -104,21 +113,44 @@ let rec check_action state = function | 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 = - match check_action state Meditate with - | Error _e -> state - | Ok actions -> List.fold_left perform_action state actions + 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; player_pos; map; offset_x; offset_y } = +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; player_pos = %a; %a; offset_x = %f; offset_y = %f" mana - Map.pp_position player_pos Map.pp_background bg offset_x offset_y + "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 From a37c5d3ca89d5efaefaf7c36b040f5e77a7ca941 Mon Sep 17 00:00:00 2001 From: pena Date: Mon, 20 Jan 2025 04:13:36 +0100 Subject: [PATCH 77/81] add CI --- .gitea/workflows/build.yaml | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 .gitea/workflows/build.yaml diff --git a/.gitea/workflows/build.yaml b/.gitea/workflows/build.yaml new file mode 100644 index 0000000..27485d5 --- /dev/null +++ b/.gitea/workflows/build.yaml @@ -0,0 +1,34 @@ +name: build +run-name: build +on: [push] + +jobs: + build: + runs-on: ubuntu-latest + container: + image: pena/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) From ec90cda06602d683503343594b48dc1c633837fc Mon Sep 17 00:00:00 2001 From: Swrup Date: Fri, 2 May 2025 19:55:00 +0200 Subject: [PATCH 78/81] fmt --- .ocamlformat | 2 +- src/map.ml | 3 +-- src/user.ml | 3 +-- 3 files changed, 3 insertions(+), 5 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index c54116a..eb9f4e0 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.24.1 +version=0.27.0 assignment-operator=end-line break-cases=fit break-fun-decl=wrap diff --git a/src/map.ml b/src/map.ml index ea9c498..ecca65e 100644 --- a/src/map.ml +++ b/src/map.ml @@ -64,8 +64,7 @@ let count_wheat map = let count' = Array.fold_left (fun count -> function - | Wheat -> succ count - | Black | Grass | Water -> count ) + | Wheat -> succ count | Black | Grass | Water -> count ) 0 a in count + count' ) diff --git a/src/user.ml b/src/user.ml index 56aa4ba..8c3ed39 100644 --- a/src/user.ml +++ b/src/user.ml @@ -154,8 +154,7 @@ let list () = Ok (Format.asprintf "
      %a
    " (Format.pp_print_list (fun fmt -> function - | s -> Format.fprintf fmt {|
  • %s
    • |} s s ) - ) + | s -> Format.fprintf fmt {|
  • %s
    • |} s s )) users ) let get_nick_unsafe request = Option.get @@ Dream.session "nick" request From 4bb063e4eb953f99a84b94e54a4108f9cc2b38b0 Mon Sep 17 00:00:00 2001 From: Swrup Date: Fri, 2 May 2025 20:02:04 +0200 Subject: [PATCH 79/81] fix libraries changes --- src/app.ml | 22 +++++++++++++--------- src/db.ml | 13 +++++++------ src/dune | 3 ++- src/island.ml | 4 ++-- src/user.ml | 31 ++++++++++++++++--------------- src/ws.ml | 2 +- 6 files changed, 41 insertions(+), 34 deletions(-) diff --git a/src/app.ml b/src/app.ml index 543afc7..2936611 100644 --- a/src/app.ml +++ b/src/app.ml @@ -19,12 +19,13 @@ 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 [] + 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; + Dream.log "config file: %s" filename_str; match Scfg.Parse.from_file filename with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok config -> config end @@ -33,7 +34,7 @@ let open_registration = | 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 -> @@ -46,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 @@ -62,7 +63,10 @@ let hostname = match Scfg.Query.get_dir "hostname" config with | 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,7 +75,7 @@ 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" ) @@ -84,7 +88,7 @@ let about = | None -> default_about | Some about -> ( match Scfg.Query.get_param 0 about with - | Error e -> failwith e + | Error (`Msg e) -> failwith e | Ok about -> about ) let random_state = Random.State.make_self_init () diff --git a/src/db.ml b/src/db.ml index 6295420..ca88f29 100644 --- a/src/db.ml +++ b/src/db.ml @@ -3,15 +3,16 @@ 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) diff --git a/src/dune b/src/dune index db008b0..b35e495 100644 --- a/src/dune +++ b/src/dune @@ -33,7 +33,8 @@ tyxml tyxml.functor uri - uuidm) + uuidm + unix) (preprocess (pps lwt_ppx))) diff --git a/src/island.ml b/src/island.ml index ad37b85..013bfac 100644 --- a/src/island.ml +++ b/src/island.ml @@ -61,8 +61,8 @@ let get request = let js = script ~a: - [ a_mime_type "text/javascript" - ; a_src "/assets/js/island_client.js" + [ (*a_mime_type "text/javascript" ; *) + a_src "/assets/js/island_client.js" ; a_defer () ] (txt "") diff --git a/src/user.ml b/src/user.ml index 8c3ed39..1ada3bd 100644 --- a/src/user.ml +++ b/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,10 +101,12 @@ 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 (`Forbidden, "YOU ARE BANISHED") else Error (`Forbidden, "wrong password") @@ -157,12 +158,12 @@ let list () = | s -> Format.fprintf fmt {|
  • %s
    • |} s s )) users ) -let get_nick_unsafe request = Option.get @@ Dream.session "nick" request +let get_nick_unsafe request = Option.get @@ Dream.session_field request "nick" -let is_logged_in request = Option.is_some @@ Dream.session "nick" request +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 diff --git a/src/ws.ml b/src/ws.ml index 3d832f8..ee2cf30 100644 --- a/src/ws.ml +++ b/src/ws.ml @@ -7,7 +7,7 @@ let get_state_unsafe user_id = | Ok state -> state let handle_client request client = - match Dream.session "user_id" request with + 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 *) From 321530d9d63e554a1c92ceddb8f8fd3f2f7a9004 Mon Sep 17 00:00:00 2001 From: Swrup Date: Fri, 2 May 2025 21:54:06 +0200 Subject: [PATCH 80/81] dream sql_sessions --- src/db.ml | 20 ++++++++++++++++---- src/pellest.ml | 3 ++- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/src/db.ml b/src/db.ml index ca88f29..deac35d 100644 --- a/src/db.ml +++ b/src/db.ml @@ -17,12 +17,24 @@ 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 = diff --git a/src/pellest.ml b/src/pellest.ml index 9ee23fa..19a5c9e 100644 --- a/src/pellest.ml +++ b/src/pellest.ml @@ -24,7 +24,8 @@ let () = let () = let logger = if App.log then Dream.logger else Fun.id in - Dream.run ~port:App.port @@ 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/**" Asset.get From e133e576bf78e6c69a1af83ee66d7ed282abae7b Mon Sep 17 00:00:00 2001 From: Swrup Date: Thu, 19 Mar 2026 20:14:17 +0100 Subject: [PATCH 81/81] fmt+deps --- .ocamlformat | 2 +- dune-project | 40 ++++++++++++++++++++++++---------------- pellest.opam | 27 +++++++++++++++++++++------ src/dune | 3 ++- src/island_client.ml | 28 ++++++++++++++-------------- src/state.ml | 15 +++++++-------- 6 files changed, 69 insertions(+), 46 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index eb9f4e0..6f010c4 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.27.0 +version=0.28.1 assignment-operator=end-line break-cases=fit break-fun-decl=wrap diff --git a/dune-project b/dune-project index 1c009d1..fecf61a 100644 --- a/dune-project +++ b/dune-project @@ -1,23 +1,15 @@ (lang dune 2.9) - -(implicit_transitive_deps false) - (name pellest) +(implicit_transitive_deps false) +(generate_opam_files true) -(authors "swrup") - -(maintainers "swrup@protonmail.com") +(authors "swrup@protonmail.com" "pena ") +(maintainers "swrup@protonmail.com" "pena ") (source - (uri TODO/pellest)) - -(homepage TODO/pellest) - -(bug_reports TODO/pellest) - -(documentation TODO/pellest) - -(generate_opam_files true) + (uri git+https://forge.kumikode.org/swrup/pellest.git)) +(homepage https://forge.kumikode.org/swrup/pellest) +(bug_reports https://forge.kumikode.org/swrup/pellest/issues) (package (name pellest) @@ -28,4 +20,20 @@ (pellest TODO TODO TODO TODO)) (depends (ocaml - (>= 4.08)))) + (>= 4.08)) + bos + brr + caqti + caqti-driver-sqlite3 + directories + dream + emile + fpath + lambdasoup + lwt + lwt_ppx + safepass + scfg + tyxml + uri + uuidm)) diff --git a/pellest.opam b/pellest.opam index 72709f3..140446e 100644 --- a/pellest.opam +++ b/pellest.opam @@ -2,15 +2,30 @@ opam-version: "2.0" synopsis: "OCaml library/executable to TODO" description: "pellest is an OCaml library/executable to TODO." -maintainer: ["swrup@protonmail.com"] -authors: ["swrup"] +maintainer: ["swrup@protonmail.com" "pena "] +authors: ["swrup@protonmail.com" "pena "] tags: ["pellest" "TODO" "TODO" "TODO" "TODO"] -homepage: "TODO/pellest" -doc: "TODO/pellest" -bug-reports: "TODO/pellest" +homepage: "https://forge.kumikode.org/swrup/pellest" +bug-reports: "https://forge.kumikode.org/swrup/pellest/issues" depends: [ "dune" {>= "2.9"} "ocaml" {>= "4.08"} + "bos" + "brr" + "caqti" + "caqti-driver-sqlite3" + "directories" + "dream" + "emile" + "fpath" + "lambdasoup" + "lwt" + "lwt_ppx" + "safepass" + "scfg" + "tyxml" + "uri" + "uuidm" "odoc" {with-doc} ] build: [ @@ -29,4 +44,4 @@ build: [ ] ["dune" "install" "-p" name "--create-install-files" name] ] -dev-repo: "TODO/pellest" +dev-repo: "git+https://forge.kumikode.org/swrup/pellest.git" diff --git a/src/dune b/src/dune index b35e495..c94d765 100644 --- a/src/dune +++ b/src/dune @@ -17,6 +17,8 @@ user ws) (libraries + shared + ; bos caqti caqti.blocking @@ -24,7 +26,6 @@ directories dream emile - shared fpath lambdasoup lwt diff --git a/src/island_client.ml b/src/island_client.ml index 1f25a64..cb9345d 100644 --- a/src/island_client.ml +++ b/src/island_client.ml @@ -191,22 +191,22 @@ 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 + 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 ) + assert false + in + Queue.add act input_queue ) let render state = draw_canvas state; diff --git a/src/state.ml b/src/state.ml index cc8af84..bb1cd38 100644 --- a/src/state.ml +++ b/src/state.ml @@ -104,14 +104,13 @@ let rec check_action state = function ; 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 + 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