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