From d647486ad8e25bd6a5ec8721386ed972120ada1a Mon Sep 17 00:00:00 2001 From: Swrup Date: Wed, 22 Dec 2021 11:27:53 +0100 Subject: [PATCH] cleanup user.ml, add plant.ml --- src/db.ml | 10 ++ src/dune | 2 + src/permap.ml | 8 +- src/plant.ml | 234 ++++++++++++++++++++++++++++++++++++++ src/user.ml | 233 +------------------------------------ src/user_profile.eml.html | 2 +- 6 files changed, 255 insertions(+), 234 deletions(-) create mode 100644 src/plant.ml diff --git a/src/db.ml b/src/db.ml index 47806d7..29d42b0 100644 --- a/src/db.ml +++ b/src/db.ml @@ -9,5 +9,15 @@ let () = let db = Filename.concat db_root "permap.db" +let random_state = Random.State.make_self_init () + let with_db ?mode ?mutex ?cache ?vfs ?timeout f = Sqlite3_utils.with_db ?mode ?mutex ?cache ?vfs ?timeout db f + +module Db = +( val Caqti_blocking.connect (Uri.of_string ("sqlite3://" ^ db)) + |> Caqti_blocking.or_fail ) + +(* TODO do image validation: length and MIME types with conan*) +(* TODO do the same for text input: check length, forbidden chars and have a forbidden words filter*) +let is_valid_image _content = true diff --git a/src/dune b/src/dune index dea9cf7..bf32499 100644 --- a/src/dune +++ b/src/dune @@ -1,6 +1,8 @@ (executable (public_name permap) (modules + plant + db app content db diff --git a/src/permap.ml b/src/permap.ml index cf59c60..f25323a 100644 --- a/src/permap.ml +++ b/src/permap.ml @@ -134,7 +134,7 @@ let avatar_image request = let plant_image request = let plant_id = Dream.param "plant_id" request in let nb = int_of_string (Dream.param "nb" request) in - let image = User.get_plant_image plant_id nb in + let image = Plant.get_plant_image plant_id nb in match image with | Ok (Some image) -> Dream.respond ~headers:[ ("Content-Type", "image") ] image @@ -176,7 +176,7 @@ let add_plant_post request = | _, None -> render_unsafe "Invalide coordinate" request | Some lat, Some lng -> let res = - match User.add_plant (lat, lng) tags files nick with + match Plant.add_plant (lat, lng) tags files nick with | Ok () -> "Your plant was uploaded!" | Error e -> e in @@ -193,12 +193,12 @@ let add_plant_post request = Dream.empty `Bad_Request ) let markers request = - let marker_list = User.marker_list () in + let marker_list = Plant.marker_list () in match marker_list with | Ok marker_list -> let json = {| [ |} - ^ String.concat "," (List.map User.marker_to_geojson marker_list) + ^ String.concat "," (List.map Plant.marker_to_geojson marker_list) ^ "]" in Dream.respond ~headers:[ ("Content-Type", "application/json") ] json diff --git a/src/plant.ml b/src/plant.ml new file mode 100644 index 0000000..4652ff0 --- /dev/null +++ b/src/plant.ml @@ -0,0 +1,234 @@ +open Db + +module Q = struct + let create_plant_user_table = + Caqti_request.exec Caqti_type.unit + "CREATE TABLE IF NOT EXISTS plant_user (plant_id TEXT, nick TEXT, \ + PRIMARY KEY(plant_id), FOREIGN KEY(nick) REFERENCES user(nick));" + + let create_plant_image_table = + Caqti_request.exec Caqti_type.unit + "CREATE TABLE IF NOT EXISTS plant_image ( plant_id TEXT, image TEXT,id \ + INTEGER, FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));" + + let create_plant_tag_table = + Caqti_request.exec Caqti_type.unit + "CREATE TABLE IF NOT EXISTS plant_tag (plant_id TEXT, tag TEXT, FOREIGN \ + KEY(plant_id) REFERENCES plant_user(plant_id));" + + let create_plant_gps_table = + Caqti_request.exec Caqti_type.unit + "CREATE TABLE IF NOT EXISTS plant_gps (plant_id TEXT, lat FLOAT,lng \ + FLOAT, FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));" + + let upload_plant_id = + Caqti_request.exec + Caqti_type.(tup2 string string) + "INSERT INTO plant_user VALUES (?,?);" + + let upload_plant_tag = + Caqti_request.exec + Caqti_type.(tup2 string string) + "INSERT INTO plant_tag VALUES (?,?);" + + let upload_plant_gps = + Caqti_request.exec + Caqti_type.(tup3 string float float) + "INSERT INTO plant_gps VALUES (?,?,?);" + + let upload_plant_image = + Caqti_request.exec + Caqti_type.(tup3 string string int) + "INSERT INTO plant_image VALUES (?,?,?);" + + let get_user_plants = + Caqti_request.collect Caqti_type.string Caqti_type.string + "SELECT plant_id FROM plant_user WHERE nick=?;" + + let list_plant_ids = + Caqti_request.collect Caqti_type.unit Caqti_type.string + "SELECT plant_id FROM plant_user;" + + let count_plant_image = + Caqti_request.find_opt Caqti_type.string Caqti_type.int + "SELECT COUNT(*) FROM plant_image WHERE plant_id=?;" + + let get_plant_image = + Caqti_request.find_opt + Caqti_type.(tup2 string int) + Caqti_type.string + "SELECT image FROM plant_image WHERE plant_id=? AND id=?;" + + let get_plant_tags = + Caqti_request.collect Caqti_type.string Caqti_type.string + "SELECT tag FROM plant_tag WHERE plant_id=?;" + + let get_plant_gps = + Caqti_request.find_opt Caqti_type.string + Caqti_type.(tup2 float float) + "SELECT lat, lng FROM plant_gps WHERE plant_id=?;" +end + +let () = + let tables = + [ Q.create_plant_user_table + ; Q.create_plant_image_table + ; Q.create_plant_tag_table + ; Q.create_plant_gps_table + ] + in + if + List.exists Result.is_error + (List.map (fun query -> Db.exec query ()) tables) + then + Dream.warning (fun log -> log "can't create table") + +let view_plant plant_id = + let count = Db.find_opt Q.count_plant_image plant_id in + match count with + | Ok count -> ( + match count with + | Some count -> ( + let gps = + match Db.find_opt Q.get_plant_gps plant_id with + | Ok (Some (lat, lng)) -> + Float.to_string lat ^ " " ^ Float.to_string lng + | Ok None -> "" + | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) + in + let images = + String.concat "\n" + (List.map + (Format.sprintf + {|
    • |} + plant_id ) + (List.init count (fun i -> i)) ) + in + let tags = + Db.fold Q.get_plant_tags (fun tag acc -> tag :: acc) plant_id [] + in + match tags with + | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) + | Ok tags -> + let tags = String.concat " " tags in + (* TODO add link to gps/map too *) + images ^ tags ^ gps ) + | None -> "db error" ) + | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) + +let marker_list () = + let plant_id_list = + Db.fold Q.list_plant_ids (fun plant_id acc -> plant_id :: acc) () [] + in + match plant_id_list with + | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + | Ok plant_id_list -> + let markers_res = + List.map + (fun plant_id -> + match Db.find_opt Q.get_plant_gps plant_id with + | Ok (Some (lat, lng)) -> + let content = view_plant plant_id in + Ok (lat, lng, content) + | Ok None -> Error "latlng not found" + | Error e -> + Error (Format.sprintf "db error: %s" (Caqti_error.show e)) ) + plant_id_list + in + let markers = + List.map + (fun res -> + match res with + | Ok res -> res + | Error _ -> assert false ) + (List.filter Result.is_ok markers_res) + in + Ok markers + +let marker_to_geojson marker = + match marker with + | lat, lng, content -> + Format.sprintf + {| +{ + "type": "Feature", + "geometry": { + "type": "Point", + "coordinates": [%s,%s] + }, + "properties": { + "content": "%s" + } +} +|} + (*TODO escape in content ?? *) + (* geojson use lng lat, and not lat lng*) + (Float.to_string lng) + (Float.to_string lat) (String.escaped content) + +let view_user_plant_list nick = + let plant_id_list = + Db.fold Q.get_user_plants (fun plant_id acc -> plant_id :: acc) nick [] + in + match plant_id_list with + | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) + | Ok plant_id_list -> + let plants = List.map view_plant plant_id_list in + String.concat "\n" plants + +let get_plant_image plant_id nb = + let res = Db.find_opt Q.get_plant_image (plant_id, nb) in + match res with + | Ok content -> ( + match content with + | Some content -> Ok (Some content) + | None -> Error "Image not found" ) + | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + +let add_plant (lat, lng) tags files nick = + let tags_len = String.length tags in + if tags_len > 1000 then + Error "tags too long" + else + let tag_list = Str.split (Str.regexp " +") tags in + (* id for plant*) + let ok_list = List.map (fun (_, content) -> is_valid_image content) files in + let valid_files = List.for_all (fun valid -> valid) ok_list in + if not valid_files then + Error "Invalid image" + else + (* add plant to db *) + let plant_id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in + (* add to plant_id <-> user*) + let res_plant = Db.exec Q.upload_plant_id (plant_id, nick) in + match res_plant with + | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + | Ok _ -> ( + (* add to plant_id <-> gps table*) + (*TODO check if valid latlng *) + let res_gps = Db.exec Q.upload_plant_gps (plant_id, lat, lng) in + match res_gps with + | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + | Ok _ -> ( + (* add to plant_id <-> tag table*) + let res_tags = + List.map + (fun tag -> Db.exec Q.upload_plant_tag (plant_id, tag)) + tag_list + in + if List.exists Result.is_error res_tags then + Error (Format.sprintf "db error") + else + (* add to plant_id <-> image*) + let res_images = + List.find_opt Result.is_error + (List.mapi + (fun nb (_, content) -> + Db.exec Q.upload_plant_image (plant_id, content, nb) ) + files ) + in + match res_images with + | Some (Error e) -> + Error (Format.sprintf "db error: %s" (Caqti_error.show e)) + | Some (Ok _) -> assert false + | None -> Ok () ) ) diff --git a/src/user.ml b/src/user.ml index dd137b4..6ff0cd5 100644 --- a/src/user.ml +++ b/src/user.ml @@ -1,3 +1,5 @@ +open Db + type t = { nick : string ; password : string @@ -17,21 +19,6 @@ module Q = struct "CREATE TABLE IF NOT EXISTS plant_user (plant_id TEXT, nick TEXT, \ PRIMARY KEY(plant_id), FOREIGN KEY(nick) REFERENCES user(nick));" - let create_plant_image_table = - Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS plant_image ( plant_id TEXT, image TEXT,id \ - INTEGER, FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));" - - let create_plant_tag_table = - Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS plant_tag (plant_id TEXT, tag TEXT, FOREIGN \ - KEY(plant_id) REFERENCES plant_user(plant_id));" - - let create_plant_gps_table = - Caqti_request.exec Caqti_type.unit - "CREATE TABLE IF NOT EXISTS plant_gps (plant_id TEXT, lat FLOAT,lng \ - FLOAT, FOREIGN KEY(plant_id) REFERENCES plant_user(plant_id));" - let get_password = Caqti_request.find_opt Caqti_type.string Caqti_type.string "SELECT password FROM user WHERE nick=?;" @@ -73,70 +60,10 @@ module Q = struct Caqti_request.exec Caqti_type.(tup2 string string) "UPDATE user SET avatar=? WHERE nick=?;" - - let upload_plant_id = - Caqti_request.exec - Caqti_type.(tup2 string string) - "INSERT INTO plant_user VALUES (?,?);" - - let upload_plant_tag = - Caqti_request.exec - Caqti_type.(tup2 string string) - "INSERT INTO plant_tag VALUES (?,?);" - - let upload_plant_gps = - Caqti_request.exec - Caqti_type.(tup3 string float float) - "INSERT INTO plant_gps VALUES (?,?,?);" - - let upload_plant_image = - Caqti_request.exec - Caqti_type.(tup3 string string int) - "INSERT INTO plant_image VALUES (?,?,?);" - - let get_user_plants = - Caqti_request.collect Caqti_type.string Caqti_type.string - "SELECT plant_id FROM plant_user WHERE nick=?;" - - let list_plant_ids = - Caqti_request.collect Caqti_type.unit Caqti_type.string - "SELECT plant_id FROM plant_user;" - - let count_plant_image = - Caqti_request.find_opt Caqti_type.string Caqti_type.int - "SELECT COUNT(*) FROM plant_image WHERE plant_id=?;" - - let get_plant_image = - Caqti_request.find_opt - Caqti_type.(tup2 string int) - Caqti_type.string - "SELECT image FROM plant_image WHERE plant_id=? AND id=?;" - - let get_tags = - Caqti_request.collect Caqti_type.string Caqti_type.string - "SELECT tag FROM plant_tag WHERE plant_id=?;" - - let get_plant_gps = - Caqti_request.find_opt Caqti_type.string - Caqti_type.(tup2 float float) - "SELECT lat, lng FROM plant_gps WHERE plant_id=?;" end -module Db = -( val Caqti_blocking.connect (Uri.of_string (Filename.concat "sqlite3://" Db.db)) - |> Caqti_blocking.or_fail ) - -let random_state = Random.State.make_self_init () - let () = - let tables = - [ Q.create_user_table - ; Q.create_plant_user_table - ; Q.create_plant_image_table - ; Q.create_plant_tag_table - ; Q.create_plant_gps_table - ] - in + let tables = [ Q.create_user_table ] in if List.exists Result.is_error (List.map (fun query -> Db.exec query ()) tables) @@ -204,97 +131,6 @@ let register ~email ~nick ~password = | None -> Error "db error" ) | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) -let view_plant plant_id = - let count = Db.find_opt Q.count_plant_image plant_id in - match count with - | Ok count -> ( - match count with - | Some count -> ( - let gps = - match Db.find_opt Q.get_plant_gps plant_id with - | Ok (Some (lat, lng)) -> - Float.to_string lat ^ " " ^ Float.to_string lng - | Ok None -> "" - | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) - in - let images = - String.concat "\n" - (List.map - (Format.sprintf - {|
    • |} - plant_id ) - (List.init count (fun i -> i)) ) - in - let tags = Db.fold Q.get_tags (fun tag acc -> tag :: acc) plant_id [] in - match tags with - | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) - | Ok tags -> - let tags = String.concat " " tags in - (* TODO add link to gps/map too *) - images ^ tags ^ gps ) - | None -> "db error" ) - | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) - -let marker_list () = - let plant_id_list = - Db.fold Q.list_plant_ids (fun plant_id acc -> plant_id :: acc) () [] - in - match plant_id_list with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok plant_id_list -> - let markers_res = - List.map - (fun plant_id -> - match Db.find_opt Q.get_plant_gps plant_id with - | Ok (Some (lat, lng)) -> - let content = view_plant plant_id in - Ok (lat, lng, content) - | Ok None -> Error "latlng not found" - | Error e -> - Error (Format.sprintf "db error: %s" (Caqti_error.show e)) ) - plant_id_list - in - let markers = - List.map - (fun res -> - match res with - | Ok res -> res - | Error _ -> assert false ) - (List.filter Result.is_ok markers_res) - in - Ok markers - -let marker_to_geojson marker = - match marker with - | lat, lng, content -> - Format.sprintf - {| -{ - "type": "Feature", - "geometry": { - "type": "Point", - "coordinates": [%s,%s] - }, - "properties": { - "content": "%s" - } -} -|} - (*TODO escape in content ?? *) - (* geojson use lng lat, and not lat lng*) - (Float.to_string lng) - (Float.to_string lat) (String.escaped content) - -let view_user_plant_list nick = - let plant_id_list = - Db.fold Q.get_user_plants (fun plant_id acc -> plant_id :: acc) nick [] - in - match plant_id_list with - | Error e -> Format.sprintf "db error: %s" (Caqti_error.show e) - | Ok plant_id_list -> - let plants = List.map view_plant plant_id_list in - String.concat "\n" plants - let list () = let users = Db.fold Q.list_nicks (fun nick acc -> nick :: acc) () [] in match users with @@ -313,7 +149,7 @@ let public_profile request = | Ok user -> ( match user with | Some (nick, password, email, (bio, _)) -> - let plants = view_user_plant_list nick in + let plants = Plant.view_user_plant_list nick in let user_info = Format.sprintf {|nick = `%s`; password = `%s`; email = `%s`; bio = '%s'; @@ -362,15 +198,6 @@ let get_avatar nick = | None -> Error "db error:" ) | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) -let get_plant_image plant_id nb = - let res = Db.find_opt Q.get_plant_image (plant_id, nb) in - match res with - | Ok content -> ( - match content with - | Some content -> Ok (Some content) - | None -> Error "Image not found" ) - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - let upload_avatar files nick = match files with | [] -> Error "No file provided" @@ -384,55 +211,3 @@ let upload_avatar files nick = | Ok _ -> Ok () | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) ) | _files -> Error "More than one file provided" - -(* TODO do image validation: length and MIME types with conan*) -(* TODO do the same for text input: check length, forbidden chars and have a forbidden words filter*) -let is_valid_image _content = true - -let add_plant (lat, lng) tags files nick = - let tags_len = String.length tags in - if tags_len > 1000 then - Error "tags too long" - else - let tag_list = Str.split (Str.regexp " +") tags in - (* id for plant*) - let ok_list = List.map (fun (_, content) -> is_valid_image content) files in - let valid_files = List.for_all (fun valid -> valid) ok_list in - if not valid_files then - Error "Invalid image" - else - (* add plant to db *) - let plant_id = Uuidm.to_string (Uuidm.v4_gen random_state ()) in - (* add to plant_id <-> user*) - let res_plant = Db.exec Q.upload_plant_id (plant_id, nick) in - match res_plant with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok _ -> ( - (* add to plant_id <-> gps table*) - (*TODO check if valid latlng *) - let res_gps = Db.exec Q.upload_plant_gps (plant_id, lat, lng) in - match res_gps with - | Error e -> Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Ok _ -> ( - (* add to plant_id <-> tag table*) - let res_tags = - List.map - (fun tag -> Db.exec Q.upload_plant_tag (plant_id, tag)) - tag_list - in - if List.exists Result.is_error res_tags then - Error (Format.sprintf "db error") - else - (* add to plant_id <-> image*) - let res_images = - List.find_opt Result.is_error - (List.mapi - (fun nb (_, content) -> - Db.exec Q.upload_plant_image (plant_id, content, nb) ) - files ) - in - match res_images with - | Some (Error e) -> - Error (Format.sprintf "db error: %s" (Caqti_error.show e)) - | Some (Ok _) -> assert false - | None -> Ok () ) ) diff --git a/src/user_profile.eml.html b/src/user_profile.eml.html index 8277188..2e3f6bf 100644 --- a/src/user_profile.eml.html +++ b/src/user_profile.eml.html @@ -14,4 +14,4 @@ let f nick bio request = - <%s! User.view_user_plant_list nick %> + <%s! Plant.view_user_plant_list nick %>