b
This commit is contained in:
commit
6fd066773f
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
||||
_build
|
42
.ocamlformat
Normal file
42
.ocamlformat
Normal file
@ -0,0 +1,42 @@
|
||||
version=0.23.0
|
||||
assignment-operator=end-line
|
||||
break-cases=fit
|
||||
break-fun-decl=wrap
|
||||
break-fun-sig=wrap
|
||||
break-infix=wrap
|
||||
break-infix-before-func=false
|
||||
break-separators=before
|
||||
break-sequences=true
|
||||
cases-exp-indent=2
|
||||
cases-matching-exp-indent=normal
|
||||
doc-comments=before
|
||||
doc-comments-padding=2
|
||||
doc-comments-tag-only=default
|
||||
dock-collection-brackets=false
|
||||
exp-grouping=preserve
|
||||
field-space=loose
|
||||
if-then-else=compact
|
||||
indicate-multiline-delimiters=space
|
||||
indicate-nested-or-patterns=unsafe-no
|
||||
infix-precedence=indent
|
||||
leading-nested-match-parens=false
|
||||
let-and=sparse
|
||||
let-binding-spacing=compact
|
||||
let-module=compact
|
||||
margin=80
|
||||
max-indent=68
|
||||
module-item-spacing=sparse
|
||||
ocp-indent-compat=false
|
||||
parens-ite=false
|
||||
parens-tuple=always
|
||||
parse-docstrings=true
|
||||
sequence-blank-line=preserve-one
|
||||
sequence-style=terminator
|
||||
single-case=compact
|
||||
space-around-arrays=true
|
||||
space-around-lists=true
|
||||
space-around-records=true
|
||||
space-around-variants=true
|
||||
type-decl=sparse
|
||||
wrap-comments=false
|
||||
wrap-fun-args=true
|
1
CHANGES.md
Normal file
1
CHANGES.md
Normal file
@ -0,0 +1 @@
|
||||
## unreleased
|
40
README.md
Normal file
40
README.md
Normal file
@ -0,0 +1,40 @@
|
||||
# pellest
|
||||
|
||||
[pellest] is an [OCaml] executable/library to TODO.
|
||||
|
||||
## Installation
|
||||
|
||||
`pellest` can be installed with [opam]:
|
||||
|
||||
```sh
|
||||
opam install pellest
|
||||
```
|
||||
|
||||
If you don't have `opam`, you can install it following the [how to install opam] guide.
|
||||
|
||||
If you can't or don't want to use `opam`, consult the [opam file] for build instructions.
|
||||
|
||||
## Quickstart
|
||||
|
||||
```ocaml
|
||||
let () = Format.printf "TODO@."
|
||||
```
|
||||
|
||||
For more, have a look at the [example] folder, at the [documentation] or at the [test suite].
|
||||
|
||||
## About
|
||||
|
||||
- [LICENSE]
|
||||
- [CHANGELOG]
|
||||
|
||||
[CHANGELOG]: ./CHANGES.md
|
||||
[example]: ./example
|
||||
[LICENSE]: ./LICENSE.md
|
||||
[opam file]: ./pellest.opam
|
||||
[test suite]: ./test
|
||||
|
||||
[documentation]: TODO/pellest
|
||||
[how to install opam]: https://opam.ocaml.org/doc/Install.html
|
||||
[OCaml]: https://ocaml.org
|
||||
[opam]: https://opam.ocaml.org/
|
||||
[pellest]: TODO/pellest
|
17
doc/index.mld
Normal file
17
doc/index.mld
Normal file
@ -0,0 +1,17 @@
|
||||
{0 pellest}
|
||||
|
||||
{{:https://TODO/pellest} pellest} is an {{:https://ocaml.org} OCaml} library/executable to TODO.
|
||||
|
||||
{1:api API}
|
||||
|
||||
{!modules:
|
||||
Pellest
|
||||
}
|
||||
|
||||
{1:private_api Private API}
|
||||
|
||||
You shouldn't have to use any of these modules, they're used internally only.
|
||||
|
||||
{!modules:
|
||||
TODO
|
||||
}
|
31
dune-project
Normal file
31
dune-project
Normal file
@ -0,0 +1,31 @@
|
||||
(lang dune 2.9)
|
||||
|
||||
(implicit_transitive_deps false)
|
||||
|
||||
(name pellest)
|
||||
|
||||
(authors "swrup")
|
||||
|
||||
(maintainers "swrup@protonmail.com")
|
||||
|
||||
(source
|
||||
(uri TODO/pellest))
|
||||
|
||||
(homepage TODO/pellest)
|
||||
|
||||
(bug_reports TODO/pellest)
|
||||
|
||||
(documentation TODO/pellest)
|
||||
|
||||
(generate_opam_files true)
|
||||
|
||||
(package
|
||||
(name pellest)
|
||||
(synopsis "OCaml library/executable to TODO")
|
||||
(description
|
||||
"pellest is an OCaml library/executable to TODO.")
|
||||
(tags
|
||||
(pellest TODO TODO TODO TODO))
|
||||
(depends
|
||||
(ocaml
|
||||
(>= 4.08))))
|
3
example/dune
Normal file
3
example/dune
Normal file
@ -0,0 +1,3 @@
|
||||
(executable
|
||||
(name main)
|
||||
(modules main))
|
1
example/main.ml
Normal file
1
example/main.ml
Normal file
@ -0,0 +1 @@
|
||||
let () = Format.printf "TODO@."
|
32
pellest.opam
Normal file
32
pellest.opam
Normal file
@ -0,0 +1,32 @@
|
||||
# This file is generated by dune, edit dune-project instead
|
||||
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"]
|
||||
tags: ["pellest" "TODO" "TODO" "TODO" "TODO"]
|
||||
homepage: "TODO/pellest"
|
||||
doc: "TODO/pellest"
|
||||
bug-reports: "TODO/pellest"
|
||||
depends: [
|
||||
"dune" {>= "2.9"}
|
||||
"ocaml" {>= "4.08"}
|
||||
"odoc" {with-doc}
|
||||
]
|
||||
build: [
|
||||
["dune" "subst"] {dev}
|
||||
[
|
||||
"dune"
|
||||
"build"
|
||||
"-p"
|
||||
name
|
||||
"-j"
|
||||
jobs
|
||||
"--promote-install-files=false"
|
||||
"@install"
|
||||
"@runtest" {with-test}
|
||||
"@doc" {with-doc}
|
||||
]
|
||||
["dune" "install" "-p" name "--create-install-files" name]
|
||||
]
|
||||
dev-repo: "TODO/pellest"
|
94
src/app.ml
Normal file
94
src/app.ml
Normal file
@ -0,0 +1,94 @@
|
||||
module App_id = struct
|
||||
let qualifier = "org"
|
||||
|
||||
let organization = "pellest"
|
||||
|
||||
let application = "pellest"
|
||||
end
|
||||
|
||||
module Project_dirs = Directories.Project_dirs (App_id)
|
||||
|
||||
let data_dir =
|
||||
match Project_dirs.data_dir with
|
||||
| None -> failwith "can't compute data directory"
|
||||
| Some data_dir -> data_dir
|
||||
|
||||
let config_dir =
|
||||
match Project_dirs.config_dir with
|
||||
| None -> failwith "can't compute configuration directory"
|
||||
| Some config_dir -> config_dir
|
||||
|
||||
let config =
|
||||
let filename = Filename.concat config_dir "config.scfg" in
|
||||
if not @@ Sys.file_exists filename then
|
||||
failwith
|
||||
@@ Format.sprintf "configuration file `%s` does not exist, please create it"
|
||||
filename;
|
||||
Dream.log "config file: %s" filename;
|
||||
match Scfg.Parse.from_file filename with
|
||||
| Error e -> failwith e
|
||||
| Ok config -> config
|
||||
|
||||
let open_registration =
|
||||
match Scfg.Query.get_dir "open_registration" config with
|
||||
| None -> true
|
||||
| Some open_registration -> (
|
||||
match Scfg.Query.get_param 0 open_registration with
|
||||
| Error e -> failwith e
|
||||
| Ok "true" -> true
|
||||
| Ok "false" -> false
|
||||
| Ok _unknown ->
|
||||
failwith "invalid `open_registration` value in configuration file" )
|
||||
|
||||
let () = Dream.log "open_registration: %b" open_registration
|
||||
|
||||
let port =
|
||||
match Scfg.Query.get_dir "port" config with
|
||||
| None -> 8080
|
||||
| Some port -> (
|
||||
match Scfg.Query.get_param 0 port with
|
||||
| Error e -> failwith e
|
||||
| Ok n -> (
|
||||
try
|
||||
let n = int_of_string n in
|
||||
if n < 0 then raise (Invalid_argument "negative port number");
|
||||
n
|
||||
with Invalid_argument _msg ->
|
||||
failwith "invalid `port` value in configuration file" ) )
|
||||
|
||||
let () = Dream.log "port: %d" port
|
||||
|
||||
let hostname =
|
||||
match Scfg.Query.get_dir "hostname" config with
|
||||
| None -> Format.sprintf "localhost:%d" port
|
||||
| Some hostname ->
|
||||
Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 hostname)
|
||||
|
||||
let () = Dream.log "hostname: %s" hostname
|
||||
|
||||
let log =
|
||||
match Scfg.Query.get_dir "log" config with
|
||||
| None -> true
|
||||
| Some log -> (
|
||||
match Scfg.Query.get_param 0 log with
|
||||
| Error e -> failwith e
|
||||
| Ok "true" -> true
|
||||
| Ok "false" -> false
|
||||
| Ok _unknown -> failwith "invalid `log` value in configuration file" )
|
||||
|
||||
let () = Dream.log "log: %b" log
|
||||
|
||||
let get_dirs name =
|
||||
let dirs = Scfg.Query.get_dirs name config in
|
||||
List.map
|
||||
(fun dir ->
|
||||
Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 dir) )
|
||||
dirs
|
||||
|
||||
let random_state = Random.State.make_self_init ()
|
||||
|
||||
let () = Random.set_state random_state
|
||||
|
||||
let about =
|
||||
(* TODO read from about.txt *)
|
||||
"This is pellest"
|
640
src/content/assets/css/leaflet.css
Normal file
640
src/content/assets/css/leaflet.css
Normal file
@ -0,0 +1,640 @@
|
||||
/* 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;
|
||||
}
|
21
src/content/assets/css/style.css
Normal file
21
src/content/assets/css/style.css
Normal file
@ -0,0 +1,21 @@
|
||||
html {
|
||||
height: 100%;
|
||||
}
|
||||
|
||||
body {
|
||||
height: 100%;
|
||||
padding-top: 0rem;
|
||||
color: #5a5a5a;
|
||||
background-color: #e8eaf6;
|
||||
line-height: 1.6;
|
||||
font-size: 18px;
|
||||
}
|
||||
|
||||
#page-title {
|
||||
text-align: center;
|
||||
}
|
||||
|
||||
main {
|
||||
height: 100%;
|
||||
width: 100%;
|
||||
}
|
BIN
src/content/assets/img/layers-2x.png
Normal file
BIN
src/content/assets/img/layers-2x.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 1.2 KiB |
BIN
src/content/assets/img/layers.png
Normal file
BIN
src/content/assets/img/layers.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 696 B |
BIN
src/content/assets/img/marker-icon-2x.png
Normal file
BIN
src/content/assets/img/marker-icon-2x.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 2.4 KiB |
BIN
src/content/assets/img/marker-icon.png
Normal file
BIN
src/content/assets/img/marker-icon.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 1.4 KiB |
BIN
src/content/assets/img/marker-shadow.png
Normal file
BIN
src/content/assets/img/marker-shadow.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 618 B |
8
src/content/assets/js/dune
Normal file
8
src/content/assets/js/dune
Normal file
@ -0,0 +1,8 @@
|
||||
(rule
|
||||
(target client.js)
|
||||
(deps
|
||||
(file ../../../js/client.bc.js))
|
||||
(action
|
||||
(with-stdout-to
|
||||
%{target}
|
||||
(cat ../../../js/client.bc.js))))
|
48
src/db.ml
Normal file
48
src/db.ml
Normal file
@ -0,0 +1,48 @@
|
||||
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
|
||||
| Error (`Msg _) ->
|
||||
Dream.warning (fun log -> log "error when creating %s" db_root)
|
||||
|
||||
let db = Filename.concat db_root (App.App_id.application ^ ".db")
|
||||
|
||||
let db_uri = Format.sprintf "sqlite3://%s" db
|
||||
|
||||
module Db =
|
||||
(val Caqti_blocking.connect (Uri.of_string db_uri) |> Caqti_blocking.or_fail)
|
||||
|
||||
let () =
|
||||
let set_foreign_keys_on =
|
||||
Caqti_type.(unit ->. unit) "PRAGMA foreign_keys = ON"
|
||||
in
|
||||
if Result.is_error (Db.exec set_foreign_keys_on ()) then
|
||||
Dream.error (fun log -> log "can't set foreign_keys on")
|
||||
|
||||
let () =
|
||||
let query =
|
||||
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)"
|
||||
in
|
||||
match Db.exec query () with
|
||||
| Ok () -> ()
|
||||
| Error _e ->
|
||||
Format.eprintf "db error@\n";
|
||||
exit 1
|
||||
|
||||
let unwrap_err = function
|
||||
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
|
||||
| Ok _ as ok -> ok
|
||||
|
||||
let exec q v = Db.exec q v |> unwrap_err
|
||||
|
||||
let find q v = Db.find q v |> unwrap_err
|
||||
|
||||
let find_opt q v = Db.find_opt q v |> unwrap_err
|
||||
|
||||
let collect_list q v = Db.collect_list q v |> unwrap_err
|
45
src/dune
Normal file
45
src/dune
Normal file
@ -0,0 +1,45 @@
|
||||
(executable
|
||||
(name pellest)
|
||||
(modules
|
||||
app
|
||||
content
|
||||
pellest
|
||||
util
|
||||
template
|
||||
home
|
||||
register
|
||||
login
|
||||
user
|
||||
syntax
|
||||
db
|
||||
tyx_util)
|
||||
(libraries
|
||||
uuidm
|
||||
bos
|
||||
caqti
|
||||
caqti.blocking
|
||||
caqti-driver-sqlite3
|
||||
directories
|
||||
dream
|
||||
emile
|
||||
fpath
|
||||
lambdasoup
|
||||
lwt
|
||||
safepass
|
||||
scfg
|
||||
uri
|
||||
tyxml
|
||||
tyxml.functor
|
||||
yojson)
|
||||
(preprocess
|
||||
(pps lwt_ppx)))
|
||||
|
||||
(rule
|
||||
(target content.ml)
|
||||
(deps
|
||||
(source_tree content)
|
||||
(file content/assets/js/client.js))
|
||||
(action
|
||||
(with-stdout-to
|
||||
%{null}
|
||||
(run ocaml-crunch -m plain content -o %{target}))))
|
11
src/home.ml
Normal file
11
src/home.ml
Normal file
@ -0,0 +1,11 @@
|
||||
open Tyxml.Html
|
||||
|
||||
let f _request =
|
||||
let page_title = "Pellest is the best game ever!" in
|
||||
let about = div [ txt App.about ] in
|
||||
let link_to_register =
|
||||
div [ a ~a:[ a_href "/register" ] [ txt "Register" ] ]
|
||||
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
|
0
src/js/client.ml
Normal file
0
src/js/client.ml
Normal file
10
src/js/dune
Normal file
10
src/js/dune
Normal file
@ -0,0 +1,10 @@
|
||||
(executable
|
||||
(name client)
|
||||
(modules client)
|
||||
(libraries brr utils)
|
||||
(modes js))
|
||||
|
||||
(library
|
||||
(name utils)
|
||||
(modules utils)
|
||||
(libraries brr))
|
97
src/js/geo.ml
Normal file
97
src/js/geo.ml
Normal file
@ -0,0 +1,97 @@
|
||||
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
|
6
src/js/leaflet/leaflet.js
Normal file
6
src/js/leaflet/leaflet.js
Normal file
File diff suppressed because one or more lines are too long
14
src/js/utils.ml
Normal file
14
src/js/utils.ml
Normal file
@ -0,0 +1,14 @@
|
||||
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
|
16
src/login.ml
Normal file
16
src/login.ml
Normal file
@ -0,0 +1,16 @@
|
||||
open Tyxml.Html
|
||||
open Tyx_util
|
||||
|
||||
let f request =
|
||||
(* todo page titles? *)
|
||||
let page_title = "Pellest|Login" in
|
||||
let login =
|
||||
let submit = button ~a:[ a_id "submit_login" ] [ txt "submit" ] in
|
||||
let login = make_input_text "login" in
|
||||
let password = make_input_text "password" in
|
||||
div
|
||||
[ make_form request ~action:"/login" ~items:[ login; password; submit ] ]
|
||||
in
|
||||
let text = div [ txt "login ~!" ] in
|
||||
let page = div [ text; login ] in
|
||||
Template.render ~page_title ~scripts:[] page
|
52
src/pellest.ml
Normal file
52
src/pellest.ml
Normal file
@ -0,0 +1,52 @@
|
||||
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)
|
||||
@@ 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
|
||||
]
|
19
src/register.ml
Normal file
19
src/register.ml
Normal file
@ -0,0 +1,19 @@
|
||||
open Tyxml.Html
|
||||
open Tyx_util
|
||||
|
||||
let f request =
|
||||
(* todo page titles? *)
|
||||
let page_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
|
||||
div
|
||||
[ make_form request ~action:"/register"
|
||||
~items:[ nick; password; email; submit ]
|
||||
]
|
||||
in
|
||||
let text = div [ txt "register a new pellestian ~!" ] in
|
||||
let page = div [ text; register ] in
|
||||
Template.render ~page_title ~scripts:[] page
|
12
src/syntax.ml
Normal file
12
src/syntax.ml
Normal file
@ -0,0 +1,12 @@
|
||||
(* let bindings for early return when encountering an error *)
|
||||
(* see https://ocaml.org/releases/4.13/htmlman/bindingops.html *)
|
||||
|
||||
let ( let* ) o f = Result.fold ~ok:f ~error:Result.error o
|
||||
|
||||
let unwrap_list f ids =
|
||||
let l = List.map f ids in
|
||||
let res = List.find_opt Result.is_error l in
|
||||
match res with
|
||||
| None -> Ok (List.map Result.get_ok l)
|
||||
| Some (Ok _) -> assert false
|
||||
| Some (Error _e as error) -> error
|
15
src/template.ml
Normal file
15
src/template.ml
Normal file
@ -0,0 +1,15 @@
|
||||
open Tyxml
|
||||
|
||||
let render ~page_title ~scripts content =
|
||||
let open Html in
|
||||
let head =
|
||||
head
|
||||
(title (txt page_title))
|
||||
( [ link ~rel:[ `Icon ] ~href:"/assets/img/favicon.png" ()
|
||||
; link ~rel:[ `Stylesheet ] ~href:"/assets/css/style.css" ()
|
||||
]
|
||||
@ scripts )
|
||||
in
|
||||
let body = body [ main [ content ] ] in
|
||||
let page = html head body in
|
||||
Format.asprintf "%a@." (pp ~indent:true ()) page
|
7
src/tyx_util.ml
Normal file
7
src/tyx_util.ml
Normal file
@ -0,0 +1,7 @@
|
||||
open Tyxml.Html
|
||||
|
||||
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)
|
213
src/user.ml
Normal file
213
src/user.ml
Normal file
@ -0,0 +1,213 @@
|
||||
open Syntax
|
||||
open Caqti_request.Infix
|
||||
open Caqti_type
|
||||
|
||||
type t =
|
||||
{ user_id : string
|
||||
; nick : string
|
||||
; password : string
|
||||
; email : string
|
||||
}
|
||||
|
||||
let () =
|
||||
let tables =
|
||||
[| (unit ->. unit)
|
||||
"CREATE TABLE IF NOT EXISTS user (user_id TEXT, nick TEXT, password \
|
||||
TEXT, email TEXT, PRIMARY KEY(user_id))"
|
||||
; (unit ->. unit)
|
||||
"CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT)"
|
||||
|]
|
||||
in
|
||||
if
|
||||
Array.exists Result.is_error
|
||||
(Array.map (fun query -> Db.exec query ()) tables)
|
||||
then Dream.error (fun log -> log "can't create user tables")
|
||||
|
||||
module Q = struct
|
||||
let get_user_id_from_email =
|
||||
Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE email=?"
|
||||
|
||||
let get_password =
|
||||
Db.find @@ (string ->! string) "SELECT password FROM user WHERE user_id=?"
|
||||
|
||||
let is_already_user =
|
||||
Db.find
|
||||
@@ (tup2 string string ->! int)
|
||||
"SELECT EXISTS(SELECT 1 FROM user WHERE nick=? OR email=?)"
|
||||
|
||||
let upload_user =
|
||||
Db.exec
|
||||
@@ (tup4 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)
|
||||
"SELECT * FROM user WHERE user_id=?"
|
||||
|
||||
let update_bio =
|
||||
Db.exec
|
||||
@@ (tup2 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=?"
|
||||
|
||||
let update_email =
|
||||
Db.exec
|
||||
@@ (tup2 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=?"
|
||||
|
||||
let get_email =
|
||||
Db.find @@ (string ->! string) "SELECT email FROM user WHERE user_id=?"
|
||||
|
||||
let delete_user =
|
||||
Db.exec @@ (string ->. unit) "DELETE FROM user WHERE user_id=?"
|
||||
|
||||
let upload_banished =
|
||||
Db.exec @@ (tup2 string string ->. unit) "INSERT INTO banished VALUES (?,?)"
|
||||
|
||||
let get_banished =
|
||||
Db.find
|
||||
@@ (tup2 string string ->! tup2 string string)
|
||||
"SELECT * FROM banished WHERE nick=? OR email=?"
|
||||
end
|
||||
|
||||
let get_nick =
|
||||
Db.find @@ (string ->! string) "SELECT nick FROM user WHERE user_id=?"
|
||||
|
||||
let get_id_from_nick =
|
||||
Db.find @@ (string ->! string) "SELECT user_id FROM user WHERE nick=?"
|
||||
|
||||
let exist id = Result.is_ok (Q.get_user id)
|
||||
|
||||
let exist_nick nick = Result.is_ok (get_id_from_nick nick)
|
||||
|
||||
let exist_email email = Result.is_ok (Q.get_user_id_from_email email)
|
||||
|
||||
let get_user user_id =
|
||||
let* user_id, nick, password, email = Q.get_user user_id in
|
||||
Ok { user_id; nick; password; email }
|
||||
|
||||
let is_banished login = Result.is_ok (Q.get_banished (login, login))
|
||||
|
||||
let login ~login ~password request =
|
||||
let login = String.trim login in
|
||||
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
|
||||
let _unit_lwt = Dream.invalidate_session request in
|
||||
let _unit_lwt = Dream.put_session "user_id" user_id request in
|
||||
let* nick = get_nick user_id in
|
||||
let _unit_lwt = Dream.put_session "nick" nick request in
|
||||
Ok ()
|
||||