open Alcotest open Types open Syntax open Util module Test_comment = struct let f () = let open Comment in let result = Alcotest.result string string in let bool_result = Alcotest.result bool string in let check_id s = (check result) "to_string(of_string(s))=id" (Ok s) (match of_string s with Ok v -> Ok (to_string v) | Error e -> Error e) in let check_eq expected s = (check bool_result) "eq" (Ok true) (match of_string s with Error e -> Error e | Ok v -> Ok (expected = v)) in let l = [ ("cc sava?", [ Line [ Txt "cc sava?" ] ]) ; ("cc\n\n sava?", [ Line [ Txt "cc" ]; Line []; Line [ Txt " sava?" ] ]) ; (">cc sava?", [ Line_quote [ Txt "cc sava?" ] ]) ; (">cc sava\n?", [ Line_quote [ Txt "cc sava" ]; Line [ Txt "?" ] ]) ; ("cc >>13 sava?", [ Line [ Txt "cc "; Id 13; Txt " sava?" ] ]) ; (">cc >>13 sava?", [ Line_quote [ Txt "cc "; Id 13; Txt " sava?" ] ]) ; (">>13 cc sava?", [ Line [ Id 13; Txt " cc sava?" ] ]) ; (">>13\n cc sava?", [ Line [ Id 13 ]; Line [ Txt " cc sava?" ] ]) ; (">>>13\n cc sava?", [ Line_quote [ Id 13 ]; Line [ Txt " cc sava?" ] ]) ; ( ">>>>13\n cc sava?" , [ Line_quote [ Txt ">"; Id 13 ]; Line [ Txt " cc sava?" ] ] ) ; (">>13 >cc sava?", [ Line [ Id 13; Txt " >cc sava?" ] ]) ; ( ">>>>13\n cc sava?" , [ Line_quote [ Txt ">"; Id 13 ]; Line [ Txt " cc sava?" ] ] ) ] in List.iter (fun (s, _) -> check_id s) l; List.iter (fun (s, expected) -> check_eq expected s) l; () end module Test_json_data = struct let err () = let err_result = Alcotest.result err string in let check e = (check err_result) "read(write(o))=id" (Ok e) (Json_data.Write.err e |> Json_data.Read.err) in let l = Err. [ Internal (Db "a") ; Internal (Conan "a") ; Bad_form ; Forbidden ; Unauthorized_login "a" ] in List.iter check l end module Test_user = struct let email = "user_1@test.com" let nick = "user_1" let password = "hunter2" let bio = "hello im user_1 ~~" let make () = (check unit_result) "is ok" (Ok ()) (let* () = User.register ~email ~nick ~password in Ok () ); () let login () = (check unit_result) "is ok" (Ok ()) (let* _ : User_private.t = User.login ~login:email ~password in Ok () ); (check unit_result) "is ok" (Ok ()) (let* _ : User_private.t = User.login ~login:nick ~password in Ok () ); () let get_id () = let* u = User.login ~login:email ~password in Ok u.user_id let get_user () = (check unit_result) "is ok" (Ok ()) (let* id = get_id () in let* _ : user = User.get_user id in let* _ : User_private.t = User.get_user_private id in Ok () ); () let get_image () = (check unit_result) "is ok" (Ok ()) (let* id = get_id () in let* _image_data : string = User.get_image_data id in Ok () ); () let update () = let email_2 = "user_2@test.com" in let nick_2 = "user_2" in let password_2 = "xXhunter2Xx" in (check unit_result) "is ok" (Ok ()) (let* id = get_id () in let* () = User.update_email id email_2 in let* () = User.update_nick id nick_2 in let* () = User.update_password id password_2 in let* () = User.update_bio id bio in let* () = (* should not accept change to already taken value *) assert_error (User.update_email id email_2) in (* revert changes *) let* () = User.update_email id email in let* () = User.update_nick id nick in let* () = User.update_password id password in Ok () ); () let delete () = (check unit_result) "is ok" (Ok ()) (let* id = get_id () in let* () = User.delete_avatar id in let* () = User.delete_user id in let* () = assert_error (User.get_user id) in let* () = assert_error (User.login ~login:email ~password) in Ok () ); () end module Test_post = struct let post_count = ref 0 let subject = "first thread" let mk_comment = fun () -> incr post_count; let s = Fmt.str "comment nb %d ^^ ~~!" !post_count in s let assert_post_not_found id = match Post.get_post id with | Ok _ -> error "post found" | Error e -> assert_true (e = Not_found_post id) let assert_post_image_found id = let* _ : string = Post.get_thumbnail_data id in let* _ : string = Post.get_image_data id in Ok () let assert_post_image_not_found id = match assert_post_image_found id with | Ok _ -> error "post image found" | Error e -> assert_true (e = Not_found_image id) let get_first_thread () = let* catalog = Post.get_catalog () in match catalog with [] -> error "empty catalog" | hd :: _ -> Ok hd let empty_catalog () = (check unit_result) "is ok" (Ok ()) (let* catalog = Post.get_catalog () in assert_true (List.is_empty catalog) ); () let make_thread () = (check unit_result) "is ok" (Ok ()) (let* user_id = Test_user.get_id () in let* user = User.get_user user_id in let lat, lng = (12.0, -13.0) in let comment = mk_comment () in let image_data = None in let* thread = Post.make_thread ~comment ~image_data ~subject ~lat ~lng user in let post_id = thread.op.id in let date = thread.op.date in let* expected_comment = Comment.of_string comment |> Result.map_error (fun s -> Err.Unprocessable (Fmt.str "comment: %s" s) ) in let expected_op = { id = post_id ; parent_t_id = post_id ; date ; poster_id = user_id ; poster_nick = Test_user.nick ; comment = expected_comment ; image_info = None ; backlinks = [] } in let expected_thread = Thread_w_reply. { op = expected_op ; subject ; lat ; lng ; bump_status = Alive 0 ; reply_count = 0 ; reply_l = [ expected_op ] } in assert_true (expected_thread = thread) ); () let make_reply () = (check unit_result) "is ok" (Ok ()) (let* user_id = Test_user.get_id () in let* user = User.get_user user_id in let* parent_thread = get_first_thread () in let comment = mk_comment () in let image_data = None in let* post = Post.make_post ~comment ~image_data ~parent_thread user in let* expected_comment = Comment.of_string comment |> Result.map_error (fun s -> Err.Unprocessable (Fmt.str "comment: %s" s) ) in let expected_post = { id = post.id ; parent_t_id = parent_thread.op.id ; date = post.date ; poster_id = user_id ; poster_nick = Test_user.nick ; comment = expected_comment ; image_info = None ; backlinks = [] } in let* () = assert_true (expected_post = post) in let* parent_thread_updated = Post.get_thread parent_thread.op.id in let* () = assert_true @@ (!post_count = 2) in let* () = assert_true ({ parent_thread with reply_count = 1 } = parent_thread_updated) in Ok () ); () let make_reply_with_image () = let f img = let mime, name, alt, data = img in let image_data = Some (Some name, alt, data) in let* user_id = Test_user.get_id () in let* user = User.get_user user_id in let* parent_thread = get_first_thread () in let comment = mk_comment () in let* post = Post.make_post ~comment ~image_data ~parent_thread user in let* expected_comment = Comment.of_string comment |> Result.map_error (fun s -> Err.Unprocessable (Fmt.str "comment: %s" s) ) in (* image read/write to file for thumbnail creation + strip exif change image data thumbnail dimension can be <> than image dimension *) let post_image_info = Option.get post.image_info in let expected_image_info = { md5 = post_image_info.md5 ; mime ; w = 1 ; h = 1 ; thumb_w = post_image_info.thumb_w ; thumb_h = post_image_info.thumb_h ; name ; alt } in let expected_post = { id = post.id ; parent_t_id = parent_thread.op.id ; date = post.date ; poster_id = user_id ; poster_nick = Test_user.nick ; comment = expected_comment ; image_info = Some expected_image_info ; backlinks = [] } in Fmt.epr "expected --@.%s@." (Json_data.Write.post expected_post); Fmt.epr "got --@.%s@." (Json_data.Write.post post); let* () = assert_true (expected_post = post) in Ok () in (check unit_result) "is ok" (Ok ()) (let* () = assert_true (Array.length imgs = 4) in let* () = array_iter f imgs in Ok () ); () let no_exif () = let get_img id = Post.get_image_data id in let get_img_name id = let* info = Post.get_image_info id in Ok info.name in (check unit_result) "is ok" (Ok ()) ((* post with fff.png *) let id1 = 3 in (* post with fff.exif.png *) let id2 = 6 in let* img1 = get_img id1 in let* img2 = get_img id2 in let* img1_name = get_img_name id1 in let* img2_name = get_img_name id2 in let* () = assert_true (img1_name = "fff.png") in let* () = assert_true (img2_name = "fff.exif.png") in let* () = assert_true (let regex = Re.Posix.compile_pat "exif" in Re.exec_opt regex img2 |> Option.is_none ) in let* () = assert_true (img1 = img2) in Ok () ) let gets () = (check unit_result) "is ok" (Ok ()) (let* thread = get_first_thread () in let* thread_w_reply = Post.get_thread_w_reply thread.op.id in let thread' = Util.thread_w_reply_to_simple thread_w_reply in let* () = assert_true (thread = thread') in let count = !post_count in let* () = assert_true @@ (count = 6) in (* TODO remove op from thread's replies *) (* - 1 because op does not count as a reply *) let* () = assert_true @@ (thread.reply_count = count - 1) in (* but not here because its in the replies list of thread *) let* () = assert_true @@ (List.length thread_w_reply.reply_l = count) in (* !! post id start at 1 *) let* () = assert_error @@ Post.get_post 0 in (* get all posts an compare them to thread replies *) let id_l = List.init count (fun i -> i + 1) in let* post_l = list_map Post.get_post id_l in let* () = assert_true (thread_w_reply.reply_l = post_l) in (* check image data *) (* first 2 post don't have image *) let* () = assert_post_image_not_found 1 in let* () = assert_post_image_not_found 2 in (* last 4 post have images *) let* () = assert_post_image_found 3 in let* () = assert_post_image_found 4 in let* () = assert_post_image_found 5 in let* () = assert_post_image_found 6 in Ok () ); () let post_delete id = let* user_id = Test_user.get_id () in let* user = User.get_user user_id in let* () = Post.delete ~user id in Ok () let delete_reply () = (check unit_result) "is ok" (Ok ()) ((* delete last post *) let* () = post_delete !post_count in let count = !post_count - 1 in let* () = assert_post_not_found !post_count in let* () = assert_post_image_not_found !post_count in let* thread = get_first_thread () in let* Thread_w_reply. { op; subject; lat; lng; bump_status; reply_count; reply_l } = Post.get_thread_w_reply thread.op.id in let thread' = { op; subject; lat; lng; bump_status; reply_count } in let* () = assert_true (thread = thread') in let id_l = List.init count (fun i -> i + 1) in let* post_l = list_map Post.get_post id_l in let* () = assert_true (reply_l = post_l) in Ok () ); () let delete_thread () = (check unit_result) "is ok" (Ok ()) ((* delete first thread *) let* t_info = get_first_thread () in let* () = post_delete t_info.op.id in let* () = assert_error @@ get_first_thread () in (* check all posts are deleted *) let id_l = List.init !post_count (fun i -> i + 1) in let* () = list_iter (fun id -> assert_post_not_found id) id_l in let* () = list_iter (fun id -> assert_post_image_not_found id) id_l in Ok () ); () end let () = run "Tests" [ ("Comment read & write", [ test_case "comment" `Quick Test_comment.f ]) ; ("Json data read & write", [ test_case "err" `Quick Test_json_data.err ]) ; (* !! order of tests on database is important *) ( "User" , Test_user. [ test_case "make" `Quick make ; test_case "login" `Quick login ; test_case "get" `Quick get_user ; test_case "get_image" `Quick get_image ; test_case "update" `Quick update ; test_case "delete" `Quick delete ; test_case "re make user_1" `Quick make ] ) ; ( "Post" , Test_post. [ test_case "empty catalog" `Quick empty_catalog ; test_case "make thread" `Quick make_thread ; test_case "make reply" `Quick make_reply ; test_case "make reply with image" `Quick make_reply_with_image ; test_case "gets" `Quick gets ; test_case "no exif" `Quick no_exif ; test_case "delete reply" `Quick delete_reply ; test_case "delete thread" `Quick delete_thread ] ) ]