swrup/geochan
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

fmt

Browse source
This commit is contained in:
zapashcanon 2022-02-18 02:40:04 +01:00
parent abb70caabd
commit 47753368e3
No known key found for this signature in database
GPG key ID: 8981C3C62D1D28F1
7 changed files with 41 additions and 127 deletions
Download patch file Download diff file Expand all files Collapse all files

23
.ocamlformat
View file

@ -1,51 +1,34 @@
version=0.20.1
align-cases=false
align-constructors-decl=false
align-variants-decl=false
assignment-operator=end-line
break-before-in=fit-or-vertical
break-cases=all
break-collection-expressions=fit-or-vertical
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
break-string-literals=auto
break-struct=force
cases-exp-indent=2
cases-matching-exp-indent=normal
disambiguate-non-breaking-match=false
doc-comments=before
doc-comments-padding=2
doc-comments-tag-only=default
dock-collection-brackets=false
exp-grouping=preserve
extension-indent=2
field-space=loose
function-indent=2
function-indent-nested=never
if-then-else=k-r
indent-after-in=0
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-indent=2
let-binding-spacing=compact
let-module=compact
margin=80
match-indent=0
match-indent-nested=never
max-indent=68
module-item-spacing=sparse
nested-match=wrap
ocp-indent-compat=false
parens-ite=false
parens-tuple=always
parens-tuple-patterns=multi-line-only
parse-docstrings=true
sequence-blank-line=preserve-one
sequence-style=terminator
@ -54,8 +37,6 @@ space-around-arrays=true
space-around-lists=true
space-around-records=true
space-around-variants=true
stritem-extension-indent=0
type-decl=sparse
type-decl-indent=2
wrap-comments=false
wrap-fun-args=true

30
src/babillard.ml
View file

@ -212,8 +212,7 @@ let () =
if
List.exists Result.is_error
(List.map (fun query -> Db.exec query ()) tables)
then
Dream.error (fun log -> log "can't create table")
then Dream.error (fun log -> log "can't create table")
let parse_image image =
match image with
@ -230,12 +229,9 @@ let parse_image image =
in
match image with
| _, image_content, alt ->
if not (is_valid_image image_content) then
Error "invalid image"
else if String.length alt > 1000 then
Error "Image description too long"
else
Ok (Some image) )
if not (is_valid_image image_content) then Error "invalid image"
else if String.length alt > 1000 then Error "Image description too long"
else Ok (Some image) )
(*TODO switch to markdown !*)
(* insert html into the comment, and keep tracks of citations :
@ -255,8 +251,7 @@ let parse_comment comment =
| Some _ ->
let new_w = Format.sprintf {|<a href="#%s">%s</a>|} sub_w w in
(new_w, Some sub_w)
else
(w, None)
else (w, None)
in
let handle_line l =
let trim_w = String.trim l in
@ -366,16 +361,13 @@ let build_reply ~comment ?image ~tags ?parent_id nick =
let id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in
(* parent_id is None if this reply is supposed to be a new thread *)
let parent_id = Option.value parent_id ~default:id in
if Option.is_none (Uuidm.of_string parent_id) then
Error "invalid thread id"
else if String.length comment > 10000 then
Error "invalid comment"
if Option.is_none (Uuidm.of_string parent_id) then Error "invalid thread id"
else if String.length comment > 10000 then Error "invalid comment"
else
match parse_image image with
| Error e -> Error e
| Ok image ->
if String.length tags > 1000 then
Error "invalid tags"
if String.length tags > 1000 then Error "invalid tags"
else
(* TODO latlng validation? *)
let tag_list = Str.split (Str.regexp " +") tags in
@ -399,10 +391,8 @@ let build_op ~comment ?image ~tags ~subject ~lat ~lng nick =
let subject = Dream.html_escape subject in
(* TODO latlng validation? *)
let is_valid_latlng = true in
if not is_valid_latlng then
Error "Invalid coordinate"
else if String.length subject > 600 then
Error "Invalid subject"
if not is_valid_latlng then Error "Invalid coordinate"
else if String.length subject > 600 then Error "Invalid subject"
else
let thread_data = { subject; lng; lat } in
let* reply =

5
src/bindings.ml
View file

@ -11,7 +11,4 @@ let ( let^ ) o f =
| Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e))
| Ok x -> f x
let ( let* ) o f =
match o with
| Error e -> Error e
| Ok x -> f x
let ( let* ) o f = match o with Error e -> Error e | Ok x -> f x

12
src/js/js_map.ml
View file

@ -65,16 +65,12 @@ module Leaflet = struct
match
Brr_io.Storage.set_item storage (Jstr.of_string "lat") (Jv.to_jstr lat)
with
| (exception Jv.Error _)
| Error _ ->
failwith "can't set latlng storage"
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () -> (
match
Brr_io.Storage.set_item storage (Jstr.of_string "lng") (Jv.to_jstr lng)
with
| (exception Jv.Error _)
| Error _ ->
failwith "can't set latlng storage"
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () -> () )
let on_zoomend _event =
@ -83,9 +79,7 @@ module Leaflet = struct
match
Brr_io.Storage.set_item storage (Jstr.of_string "zoom") (Jv.to_jstr zoom)
with
| (exception Jv.Error _)
| Error _ ->
failwith "can't set latlng storage"
| (exception Jv.Error _) | Error _ -> failwith "can't set latlng storage"
| Ok () -> ()
let () =

9
src/js/js_pretty_post.ml
View file

@ -9,9 +9,7 @@ let of_string = function
| "postImageBig" -> Some Big
| _ -> None
let to_string = function
| Small -> "postImage"
| Big -> "postImageBig"
let to_string = function Small -> "postImage" | Big -> "postImageBig"
(*change postImage class to make it bigger/smaller on click*)
let image_click post_image event =
@ -22,10 +20,7 @@ let image_click post_image event =
let new_class =
match of_string current_class with
| Some image_size ->
to_string
( match image_size with
| Big -> Small
| Small -> Big )
to_string (match image_size with Big -> Small | Small -> Big)
| None -> failwith "invalid image class name"
in
ignore

62
src/permap.ml
View file

@ -3,14 +3,11 @@ let get_title content =
try
let soup = content |> parse in
soup $ "h1" |> R.leaf_text
with
| Failure _e -> "Permap"
with Failure _e -> "Permap"
let render ?title content request =
let title =
match title with
| None -> get_title content
| Some title -> title
match title with None -> get_title content | Some title -> title
in
Dream.html
@@ Template.render_unsafe ~title:(Dream.html_escape title)
@ -19,9 +16,7 @@ let render ?title content request =
let render_unsafe ?title content request =
let title =
match title with
| None -> get_title content
| Some title -> title
match title with None -> get_title content | Some title -> title
in
Dream.html @@ Template.render_unsafe ~title ~content request
@ -45,13 +40,8 @@ let register_post request =
match%lwt Dream.form request with
| `Ok [ ("email", email); ("nick", nick); ("password", password) ] ->
render_unsafe (Register.f ~nick ~email ~password request) request
| `Ok _
| `Many_tokens _
| `Missing_token _
| `Invalid_token _
| `Wrong_session _
| `Expired _
| `Wrong_content_type ->
| `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Expired _ | `Wrong_content_type ->
assert false
let login_get request = render_unsafe (Login.f request) request
@ -79,11 +69,7 @@ let profile_get request =
match Dream.session "nick" request with
| None -> render_unsafe "Not logged in" request
| Some nick ->
let bio =
match User.get_bio nick with
| Ok bio -> bio
| Error e -> e
in
let bio = match User.get_bio nick with Ok bio -> bio | Error e -> e in
render_unsafe (User_profile.f nick bio request) request
let profile_post request =
@ -98,13 +84,8 @@ let profile_post request =
~headers:[ ("Location", "/profile") ]
"Your bio was updated!"
| Error e -> render_unsafe e request )
| `Ok _
| `Many_tokens _
| `Missing_token _
| `Invalid_token _
| `Wrong_session _
| `Expired _
| `Wrong_content_type -> (
| `Ok _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Expired _ | `Wrong_content_type -> (
match%lwt Dream.multipart request with
| `Ok [ ("file", file) ] -> (
match User.upload_avatar file nick with
@ -114,12 +95,8 @@ let profile_post request =
"Your avatar was updated!"
| Error e -> render_unsafe e request )
| `Ok _ -> Dream.empty `Bad_Request
| `Expired _
| `Many_tokens _
| `Missing_token _
| `Invalid_token _
| `Wrong_session _
| `Wrong_content_type ->
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request ) )
let avatar_image request =
@ -128,8 +105,7 @@ let avatar_image request =
match avatar with
| Ok (Some avatar) ->
Dream.respond ~headers:[ ("Content-Type", "image") ] avatar
| Ok None
| Error _ -> (
| Ok None | Error _ -> (
match Content.read "/assets/img/default_avatar.png" with
| None -> Dream.empty `Not_Found
| Some avatar -> Dream.respond ~headers:[ ("Content-Type", "image") ] avatar
@ -187,12 +163,8 @@ let newthread_post request =
"Your thread was posted!"
| Error e -> render_unsafe e request ) )
| `Ok _ -> Dream.empty `Bad_Request
| `Expired _
| `Many_tokens _
| `Missing_token _
| `Invalid_token _
| `Wrong_session _
| `Wrong_content_type ->
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
let thread_get request =
@ -240,12 +212,8 @@ let reply_post request =
"Your reply was posted!"
| Error e -> render_unsafe e request )
| `Ok _ -> Dream.empty `Bad_Request
| `Expired _
| `Many_tokens _
| `Missing_token _
| `Invalid_token _
| `Wrong_session _
| `Wrong_content_type ->
| `Expired _ | `Many_tokens _ | `Missing_token _ | `Invalid_token _
| `Wrong_session _ | `Wrong_content_type ->
Dream.empty `Bad_Request )
let redirect_to_babillard _request =

27
src/user.ml
View file

@ -68,8 +68,7 @@ let () =
if
List.exists Result.is_error
(List.map (fun query -> Db.exec query ()) tables)
then
Dream.error (fun log -> log "can't create table")
then Dream.error (fun log -> log "can't create table")
let login ~nick ~password request =
let^? good_password = Db.find_opt Q.get_password nick in
@ -79,8 +78,7 @@ let login ~nick ~password request =
Dream.put_session "nick" nick request
in
Ok ()
else
Error "wrong password"
else Error "wrong password"
let register ~email ~nick ~password =
(* TODO: remove bad characters (e.g. delthas) *)
@ -91,9 +89,7 @@ let register ~email ~nick ~password =
in
let valid_email =
match Emile.of_string email with
| Ok _ -> true
| Error _ -> false
match Emile.of_string email with Ok _ -> true | Error _ -> false
in
let valid_password =
@ -105,15 +101,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 "Something is wrong"
else
let^? nb = Db.find_opt Q.is_already_user (nick, email) in
if nb = 0 then
let^ () = Db.exec Q.inser_new_user (nick, password, email, ("", "")) in
Ok ()
else
Error "nick or email already exists"
else Error "nick or email already exists"
let list () =
let^ users = Db.collect_list Q.list_nicks () in
@ -153,8 +147,7 @@ let profile request =
let update_bio bio nick =
let bio = Dream.html_escape bio in
let valid = String.length bio < 10000 in
if not valid then
Error "Not biologic"
if not valid then Error "Not biologic"
else
let^ () = Db.exec Q.update_bio (bio, nick) in
Ok ()
@ -165,17 +158,13 @@ let get_bio nick =
let get_avatar nick =
let^? avatar = Db.find_opt Q.get_avatar nick in
if String.length avatar = 0 then
Ok None
else
Ok (Some avatar)
if String.length avatar = 0 then Ok None else Ok (Some avatar)
let upload_avatar files nick =
match files with
| [] -> Error "No file provided"
| [ (_, content) ] ->
if not (is_valid_image content) then
Error "Invalid image"
if not (is_valid_image content) then Error "Invalid image"
else
let^ () = Db.exec Q.upload_avatar (content, nick) in
Ok ()