clean code

This commit is contained in:
zapashcanon 2022-12-06 00:12:14 +01:00
parent 97864116bb
commit 20f18bcd76
Signed by untrusted user who does not match committer: zapashcanon
GPG Key ID: 8981C3C62D1D28F1
24 changed files with 99 additions and 894 deletions

10
src/asset.ml Normal file
View File

@ -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 ""

View File

@ -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;
}

Binary file not shown.

Before

Width:  |  Height:  |  Size: 1.2 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 696 B

Binary file not shown.

Before

Width:  |  Height:  |  Size: 2.4 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 1.4 KiB

Binary file not shown.

Before

Width:  |  Height:  |  Size: 618 B

View File

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

View File

@ -36,7 +36,10 @@ let () =
exit 1
let unwrap_err = function
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Error e ->
Error
( `Internal_Server_Error
, Format.sprintf "db error: %s" (Caqti_error.show e) )
| Ok _ as ok -> ok
let exec q v = Db.exec q v |> unwrap_err

View File

@ -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}

View File

@ -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

View File

View File

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

View File

@ -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

File diff suppressed because one or more lines are too long

View File

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

View File

@ -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")

View File

@ -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
]

View File

@ -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")

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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