From e2b11323ca48786271394cfcc1d2c7a3e928a102 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 1 Mar 2023 09:50:19 +0100 Subject: [PATCH 01/29] Initial test of Sys.is_directory --- src/sys/stm_tests.ml | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 72ae3b807..910b4884f 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -7,6 +7,7 @@ struct type cmd = | File_exists of path + | Is_directory of path | Mkdir of path * string | Rmdir of path * string | Readdir of path @@ -83,6 +84,7 @@ struct QCheck.make ~print:show_cmd Gen.(oneof [ map (fun path -> File_exists path) (path_gen s); + map (fun path -> Is_directory path) (path_gen s); map (fun (path,new_dir_name) -> Mkdir (path, new_dir_name)) (pair_gen s); map (fun (path,delete_dir_name) -> Rmdir (path, delete_dir_name)) (pair_gen s); map (fun path -> Readdir path) (path_gen s); @@ -180,6 +182,7 @@ struct if mem_model fs (path @ [new_dir_name]) then fs else mkdir_model fs path new_dir_name + | Is_directory _path -> fs | Rmdir (path,delete_dir_name) -> if mem_model fs (path @ [delete_dir_name]) then rmdir_model fs path delete_dir_name @@ -212,6 +215,7 @@ struct let run c _file_name = match c with | File_exists path -> Res (bool, Sys.file_exists (p path)) + | Is_directory path -> Res (result bool exn, protect Sys.is_directory (p path)) | Mkdir (path, new_dir_name) -> Res (result unit exn, protect (Sys.mkdir ((p path) / new_dir_name)) 0o755) | Rmdir (path, delete_dir_name) -> @@ -228,9 +232,25 @@ struct | None -> false | Some target_fs -> fs_is_a_dir target_fs + let rec path_prefixes path = match path with + | [] -> [] + | [_] -> [] + | n::ns -> [n]::(List.map (fun p -> n::p) (path_prefixes ns)) + let postcond c (fs: filesys) res = match c, res with | File_exists path, Res ((Bool,_),b) -> b = mem_model fs path + | Is_directory path, Res ((Result (Bool,Exn),_),res) -> + (match res with + | Ok b -> + (match find_opt_model fs path with + | Some (Directory _) -> b = true + | Some File -> b = false + | None -> false) + | Error (Sys_error s) -> + (s = (p path) ^ ": No such file or directory" && find_opt_model fs path = None) || + (s = p path ^ ": Not a directory" && List.exists (fun pref -> Some File = find_opt_model fs pref) (path_prefixes path)) + | _ -> false) | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [new_dir_name]) in (match res with From 570223963b7447d79eb64acb4c87c9dabd350b42 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 1 Mar 2023 13:00:35 +0100 Subject: [PATCH 02/29] Add Sys.remove --- src/sys/stm_tests.ml | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 910b4884f..e2feba8b9 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -8,6 +8,7 @@ struct type cmd = | File_exists of path | Is_directory of path + | Remove of path * string | Mkdir of path * string | Rmdir of path * string | Readdir of path @@ -85,6 +86,7 @@ struct Gen.(oneof [ map (fun path -> File_exists path) (path_gen s); map (fun path -> Is_directory path) (path_gen s); + map (fun (path,new_dir_name) -> Remove (path, new_dir_name)) (pair_gen s); map (fun (path,new_dir_name) -> Mkdir (path, new_dir_name)) (pair_gen s); map (fun (path,delete_dir_name) -> Rmdir (path, delete_dir_name)) (pair_gen s); map (fun path -> Readdir path) (path_gen s); @@ -111,6 +113,35 @@ struct let mem_model fs path = find_opt_model fs path <> None + let rec remove_model fs path file_name = + match fs with + | File -> fs + | Directory d -> + (match path with + | [] -> + (match Map_names.find_opt file_name d.fs_map with + | None + | Some (Directory _) -> fs + | Some File -> Directory { fs_map = Map_names.remove file_name d.fs_map } + ) + | dir::dirs -> + Directory + { fs_map = Map_names.update dir (function + | None -> None + | Some File -> Some File + | Some (Directory _ as d') -> Some (remove_model d' dirs file_name)) d.fs_map + } + (* + (match Map_names.find_opt dir d.fs_map with + | None + | Some File -> fs + | Some (Directory _ as d') -> + let fs' = remove_model d' dirs file_name in + Directory { fs_map = Map_names.update dir d.fs_map } + ) +*) + ) + let rec mkdir_model fs path new_dir_name = match fs with | File -> fs @@ -182,6 +213,7 @@ struct if mem_model fs (path @ [new_dir_name]) then fs else mkdir_model fs path new_dir_name + | Remove (path, file_name) -> remove_model fs path file_name | Is_directory _path -> fs | Rmdir (path,delete_dir_name) -> if mem_model fs (path @ [delete_dir_name]) @@ -216,6 +248,7 @@ struct match c with | File_exists path -> Res (bool, Sys.file_exists (p path)) | Is_directory path -> Res (result bool exn, protect Sys.is_directory (p path)) + | Remove (path, file_name) -> Res (result unit exn, protect Sys.remove ((p path) / file_name)) | Mkdir (path, new_dir_name) -> Res (result unit exn, protect (Sys.mkdir ((p path) / new_dir_name)) 0o755) | Rmdir (path, delete_dir_name) -> @@ -251,6 +284,16 @@ struct (s = (p path) ^ ": No such file or directory" && find_opt_model fs path = None) || (s = p path ^ ": Not a directory" && List.exists (fun pref -> Some File = find_opt_model fs pref) (path_prefixes path)) | _ -> false) + | Remove (path, file_name), Res ((Result (Unit,Exn),_), res) -> + let complete_path = (path @ [file_name]) in + (match res with + | Ok () -> mem_model fs complete_path && path_is_a_dir fs path && not (path_is_a_dir fs complete_path) + | Error (Sys_error s) -> + (s = (p complete_path) ^ ": No such file or directory" && find_opt_model fs complete_path = None) || + (s = (p complete_path) ^ ": Is a directory" && path_is_a_dir fs complete_path) || + (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs path)) + | Error _ -> false + ) | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [new_dir_name]) in (match res with From 45a894aad9d6fe4e54da72407d47fdde5b6c6e66 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 1 Mar 2023 23:21:55 +0100 Subject: [PATCH 03/29] add Sys.rename and refactor a bit --- src/sys/stm_tests.ml | 167 +++++++++++++++++++++++-------------------- 1 file changed, 90 insertions(+), 77 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index e2feba8b9..c8a3ddc4c 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -9,6 +9,7 @@ struct | File_exists of path | Is_directory of path | Remove of path * string + | Rename of path * path | Mkdir of path * string | Rmdir of path * string | Readdir of path @@ -87,6 +88,7 @@ struct map (fun path -> File_exists path) (path_gen s); map (fun path -> Is_directory path) (path_gen s); map (fun (path,new_dir_name) -> Remove (path, new_dir_name)) (pair_gen s); + map2 (fun old_path new_path -> Rename (old_path, new_path)) (path_gen s) (path_gen s); map (fun (path,new_dir_name) -> Mkdir (path, new_dir_name)) (pair_gen s); map (fun (path,delete_dir_name) -> Rmdir (path, delete_dir_name)) (pair_gen s); map (fun path -> Readdir path) (path_gen s); @@ -113,6 +115,35 @@ struct let mem_model fs path = find_opt_model fs path <> None + let path_is_a_dir fs path = + match find_opt_model fs path with + | None + | Some File -> false + | Some (Directory _) -> true + + let path_is_a_file fs path = + match find_opt_model fs path with + | None + | Some (Directory _) -> false + | Some File -> true + + let rec path_prefixes path = match path with + | [] -> [] + | [_] -> [] + | n::ns -> [n]::(List.map (fun p -> n::p) (path_prefixes ns)) + + let separate_path path = + match List.rev path with + | [] -> None + | name::rev_path -> Some (List.rev rev_path, name) + + let rec is_true_prefix path1 path2 = match path1, path2 with + | [], [] -> false + | [], _::_ -> true + | _::_, [] -> false + | n1::p1, n2::p2 -> n1=n2 && is_true_prefix p1 p2 + + (* generic removal function *) let rec remove_model fs path file_name = match fs with | File -> fs @@ -121,46 +152,14 @@ struct | [] -> (match Map_names.find_opt file_name d.fs_map with | None - | Some (Directory _) -> fs - | Some File -> Directory { fs_map = Map_names.remove file_name d.fs_map } - ) + | Some _ -> Directory { fs_map = Map_names.remove file_name d.fs_map }) | dir::dirs -> Directory { fs_map = Map_names.update dir (function | None -> None | Some File -> Some File | Some (Directory _ as d') -> Some (remove_model d' dirs file_name)) d.fs_map - } - (* - (match Map_names.find_opt dir d.fs_map with - | None - | Some File -> fs - | Some (Directory _ as d') -> - let fs' = remove_model d' dirs file_name in - Directory { fs_map = Map_names.update dir d.fs_map } - ) -*) - ) - - let rec mkdir_model fs path new_dir_name = - match fs with - | File -> fs - | Directory d -> - (match path with - | [] -> - let new_dir = Directory {fs_map = Map_names.empty} in - Directory {fs_map = Map_names.add new_dir_name new_dir d.fs_map} - | next_in_path :: tl_path -> - (match Map_names.find_opt next_in_path d.fs_map with - | None -> fs - | Some sub_fs -> - let nfs = mkdir_model sub_fs tl_path new_dir_name in - if nfs = sub_fs - then fs - else - let new_map = Map_names.remove next_in_path d.fs_map in - let new_map = Map_names.add next_in_path nfs new_map in - Directory {fs_map = new_map})) + }) let readdir_model fs path = match find_opt_model fs path with @@ -170,60 +169,70 @@ struct | File -> None | Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map [])) - let rec rmdir_model fs path delete_dir_name = + (* generic insertion function *) + let rec insert_model fs path new_file_name sub_tree = match fs with | File -> fs | Directory d -> (match path with | [] -> - (match Map_names.find_opt delete_dir_name d.fs_map with - | Some (Directory target) when Map_names.is_empty target.fs_map -> - Directory {fs_map = Map_names.remove delete_dir_name d.fs_map} - | None | Some File | Some (Directory _) -> fs) + Directory {fs_map = Map_names.add new_file_name sub_tree d.fs_map} | next_in_path :: tl_path -> (match Map_names.find_opt next_in_path d.fs_map with | None -> fs | Some sub_fs -> - let nfs = rmdir_model sub_fs tl_path delete_dir_name in - if nfs = sub_fs - then fs - else Directory {fs_map = (update_map_name d.fs_map next_in_path nfs)})) - - let rec mkfile_model fs path new_file_name = - match fs with - | File -> fs - | Directory d -> - (match path with - | [] -> - let new_file = File in - Directory {fs_map = Map_names.add new_file_name new_file d.fs_map} - | next_in_path :: tl_path -> - (match Map_names.find_opt next_in_path d.fs_map with - | None -> fs - | Some sub_fs -> - let nfs = mkfile_model sub_fs tl_path new_file_name in + let nfs = insert_model sub_fs tl_path new_file_name sub_tree in if nfs = sub_fs then fs else Directory {fs_map = update_map_name d.fs_map next_in_path nfs})) + let rename_model fs old_path new_path = + match separate_path old_path, separate_path new_path with + | None, _ + | _, None -> fs + | Some (old_path_pref, old_name), Some (new_path_pref, new_name) -> + (match find_opt_model fs new_path_pref with + | None + | Some File -> fs + | Some (Directory _) -> + (match find_opt_model fs old_path with + | None -> fs + | Some sub_fs -> + let fs' = remove_model fs old_path_pref old_name in + insert_model fs' new_path_pref new_name sub_fs)) + let next_state c fs = match c with | File_exists _path -> fs | Mkdir (path, new_dir_name) -> if mem_model fs (path @ [new_dir_name]) then fs - else mkdir_model fs path new_dir_name - | Remove (path, file_name) -> remove_model fs path file_name + else insert_model fs path new_dir_name (Directory {fs_map = Map_names.empty}) + | Remove (path, file_name) -> + if find_opt_model fs (path @ [file_name]) = Some File + then remove_model fs path file_name + else fs + | Rename (old_path, new_path) -> + if is_true_prefix old_path new_path + then fs + else + (match find_opt_model fs old_path with + | None -> fs + | Some File -> + if (not (mem_model fs new_path) || path_is_a_file fs new_path) then rename_model fs old_path new_path else fs + | Some (Directory _) -> + if (not (mem_model fs new_path) || readdir_model fs new_path = Some []) then rename_model fs old_path new_path else fs) | Is_directory _path -> fs | Rmdir (path,delete_dir_name) -> - if mem_model fs (path @ [delete_dir_name]) - then rmdir_model fs path delete_dir_name + let complete_path = path @ [delete_dir_name] in + if mem_model fs complete_path && readdir_model fs complete_path = Some [] + then remove_model fs path delete_dir_name else fs | Readdir _path -> fs | Mkfile (path, new_file_name) -> if mem_model fs (path @ [new_file_name]) then fs - else mkfile_model fs path new_file_name + else insert_model fs path new_file_name File let init_sut () = try Sys.mkdir sandbox_root 0o700 @@ -249,6 +258,7 @@ struct | File_exists path -> Res (bool, Sys.file_exists (p path)) | Is_directory path -> Res (result bool exn, protect Sys.is_directory (p path)) | Remove (path, file_name) -> Res (result unit exn, protect Sys.remove ((p path) / file_name)) + | Rename (old_path, new_path) -> Res (result unit exn, protect (Sys.rename (p old_path)) (p new_path)) | Mkdir (path, new_dir_name) -> Res (result unit exn, protect (Sys.mkdir ((p path) / new_dir_name)) 0o755) | Rmdir (path, delete_dir_name) -> @@ -258,18 +268,6 @@ struct | Mkfile (path, new_file_name) -> Res (result unit exn, protect mkfile (p path / new_file_name)) - let fs_is_a_dir fs = match fs with | Directory _ -> true | File -> false - - let path_is_a_dir fs path = - match find_opt_model fs path with - | None -> false - | Some target_fs -> fs_is_a_dir target_fs - - let rec path_prefixes path = match path with - | [] -> [] - | [_] -> [] - | n::ns -> [n]::(List.map (fun p -> n::p) (path_prefixes ns)) - let postcond c (fs: filesys) res = match c, res with | File_exists path, Res ((Bool,_),b) -> b = mem_model fs path @@ -281,19 +279,34 @@ struct | Some File -> b = false | None -> false) | Error (Sys_error s) -> - (s = (p path) ^ ": No such file or directory" && find_opt_model fs path = None) || - (s = p path ^ ": Not a directory" && List.exists (fun pref -> Some File = find_opt_model fs pref) (path_prefixes path)) + (s = (p path) ^ ": No such file or directory" && not (mem_model fs path)) || + (s = p path ^ ": Not a directory" && List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes path)) | _ -> false) | Remove (path, file_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [file_name]) in (match res with | Ok () -> mem_model fs complete_path && path_is_a_dir fs path && not (path_is_a_dir fs complete_path) | Error (Sys_error s) -> - (s = (p complete_path) ^ ": No such file or directory" && find_opt_model fs complete_path = None) || + (s = (p complete_path) ^ ": No such file or directory" && not (mem_model fs complete_path)) || (s = (p complete_path) ^ ": Is a directory" && path_is_a_dir fs complete_path) || (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs path)) | Error _ -> false ) + | Rename (old_path, new_path), Res ((Result (Unit,Exn),_), res) -> + (match res with + | Ok () -> mem_model fs old_path + | Error (Sys_error s) -> + (s = "No such file or directory" && + not (mem_model fs old_path) || List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path)) || + (s = "Invalid argument" && is_true_prefix old_path new_path) || + (s = "Not a directory" && + List.exists (path_is_a_file fs) (path_prefixes old_path) || + List.exists (path_is_a_file fs) (path_prefixes new_path) || + path_is_a_dir fs old_path && mem_model fs new_path && not (path_is_a_dir fs new_path)) || + (s = "Is a directory" && path_is_a_dir fs new_path) || + (s = "Directory not empty" && + is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (readdir_model fs new_path = Some []))) + | Error _ -> false) | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [new_dir_name]) in (match res with From afd24b4edf3323c28078899deb4926674f72ccfb Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 2 Mar 2023 08:16:50 +0100 Subject: [PATCH 04/29] Fix Sys.remove on directory on macOS --- src/sys/stm_tests.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index c8a3ddc4c..75cad02da 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -289,6 +289,7 @@ struct | Error (Sys_error s) -> (s = (p complete_path) ^ ": No such file or directory" && not (mem_model fs complete_path)) || (s = (p complete_path) ^ ": Is a directory" && path_is_a_dir fs complete_path) || + (s = (p complete_path) ^ ": Operation not permitted" && path_is_a_dir fs complete_path) || (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs path)) | Error _ -> false ) From ce461e354d679c274990b945f425b4c4bd2f1283 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 2 Mar 2023 08:20:59 +0100 Subject: [PATCH 05/29] Fix Sys.remove on directory on Windows --- src/sys/stm_tests.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 75cad02da..4ab418e6b 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -288,8 +288,9 @@ struct | Ok () -> mem_model fs complete_path && path_is_a_dir fs path && not (path_is_a_dir fs complete_path) | Error (Sys_error s) -> (s = (p complete_path) ^ ": No such file or directory" && not (mem_model fs complete_path)) || - (s = (p complete_path) ^ ": Is a directory" && path_is_a_dir fs complete_path) || - (s = (p complete_path) ^ ": Operation not permitted" && path_is_a_dir fs complete_path) || + (s = (p complete_path) ^ ": Is a directory" && path_is_a_dir fs complete_path) || (*Linux*) + (s = (p complete_path) ^ ": Operation not permitted" && path_is_a_dir fs complete_path) || (*macOS*) + (s = (p complete_path) ^ ": Permission denied" && path_is_a_dir fs complete_path) || (*Win*) (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs path)) | Error _ -> false ) From 142a99e7e786a83f4c749b2f2cf6f531e8ce1722 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 12:05:30 +0200 Subject: [PATCH 06/29] Collect _model functions in a Model module --- src/sys/stm_tests.ml | 229 ++++++++++++++++++++++--------------------- 1 file changed, 116 insertions(+), 113 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 4ab418e6b..8ec05a0b3 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -99,30 +99,96 @@ struct let init_state = Directory {fs_map = Map_names.empty} - let rec find_opt_model fs path = - match fs with - | File -> - if path = [] - then Some fs - else None - | Directory d -> - (match path with - | [] -> Some (Directory d) - | hd :: tl -> - (match Map_names.find_opt hd d.fs_map with - | None -> None - | Some fs -> find_opt_model fs tl)) - - let mem_model fs path = find_opt_model fs path <> None + module Model = + struct + let rec find_opt fs path = + match fs with + | File -> + if path = [] + then Some fs + else None + | Directory d -> + (match path with + | [] -> Some (Directory d) + | hd :: tl -> + (match Map_names.find_opt hd d.fs_map with + | None -> None + | Some fs -> find_opt fs tl)) + + let mem fs path = find_opt fs path <> None + + (* generic removal function *) + let rec remove fs path file_name = + match fs with + | File -> fs + | Directory d -> + (match path with + | [] -> + (match Map_names.find_opt file_name d.fs_map with + | None + | Some _ -> Directory { fs_map = Map_names.remove file_name d.fs_map }) + | dir::dirs -> + Directory + { fs_map = Map_names.update dir (function + | None -> None + | Some File -> Some File + | Some (Directory _ as d') -> Some (remove d' dirs file_name)) d.fs_map + }) + + let readdir fs path = + match find_opt fs path with + | None -> None + | Some fs -> + (match fs with + | File -> None + | Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map [])) + + (* generic insertion function *) + let rec insert fs path new_file_name sub_tree = + match fs with + | File -> fs + | Directory d -> + (match path with + | [] -> + Directory {fs_map = Map_names.add new_file_name sub_tree d.fs_map} + | next_in_path :: tl_path -> + (match Map_names.find_opt next_in_path d.fs_map with + | None -> fs + | Some sub_fs -> + let nfs = insert sub_fs tl_path new_file_name sub_tree in + if nfs = sub_fs + then fs + else Directory {fs_map = update_map_name d.fs_map next_in_path nfs})) + + let separate_path path = + match List.rev path with + | [] -> None + | name::rev_path -> Some (List.rev rev_path, name) + + let rename fs old_path new_path = + match separate_path old_path, separate_path new_path with + | None, _ + | _, None -> fs + | Some (old_path_pref, old_name), Some (new_path_pref, new_name) -> + (match find_opt fs new_path_pref with + | None + | Some File -> fs + | Some (Directory _) -> + (match find_opt fs old_path with + | None -> fs + | Some sub_fs -> + let fs' = remove fs old_path_pref old_name in + insert fs' new_path_pref new_name sub_fs)) + end let path_is_a_dir fs path = - match find_opt_model fs path with + match Model.find_opt fs path with | None | Some File -> false | Some (Directory _) -> true let path_is_a_file fs path = - match find_opt_model fs path with + match Model.find_opt fs path with | None | Some (Directory _) -> false | Some File -> true @@ -132,107 +198,44 @@ struct | [_] -> [] | n::ns -> [n]::(List.map (fun p -> n::p) (path_prefixes ns)) - let separate_path path = - match List.rev path with - | [] -> None - | name::rev_path -> Some (List.rev rev_path, name) - let rec is_true_prefix path1 path2 = match path1, path2 with | [], [] -> false | [], _::_ -> true | _::_, [] -> false | n1::p1, n2::p2 -> n1=n2 && is_true_prefix p1 p2 - (* generic removal function *) - let rec remove_model fs path file_name = - match fs with - | File -> fs - | Directory d -> - (match path with - | [] -> - (match Map_names.find_opt file_name d.fs_map with - | None - | Some _ -> Directory { fs_map = Map_names.remove file_name d.fs_map }) - | dir::dirs -> - Directory - { fs_map = Map_names.update dir (function - | None -> None - | Some File -> Some File - | Some (Directory _ as d') -> Some (remove_model d' dirs file_name)) d.fs_map - }) - - let readdir_model fs path = - match find_opt_model fs path with - | None -> None - | Some fs -> - (match fs with - | File -> None - | Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map [])) - - (* generic insertion function *) - let rec insert_model fs path new_file_name sub_tree = - match fs with - | File -> fs - | Directory d -> - (match path with - | [] -> - Directory {fs_map = Map_names.add new_file_name sub_tree d.fs_map} - | next_in_path :: tl_path -> - (match Map_names.find_opt next_in_path d.fs_map with - | None -> fs - | Some sub_fs -> - let nfs = insert_model sub_fs tl_path new_file_name sub_tree in - if nfs = sub_fs - then fs - else Directory {fs_map = update_map_name d.fs_map next_in_path nfs})) - - let rename_model fs old_path new_path = - match separate_path old_path, separate_path new_path with - | None, _ - | _, None -> fs - | Some (old_path_pref, old_name), Some (new_path_pref, new_name) -> - (match find_opt_model fs new_path_pref with - | None - | Some File -> fs - | Some (Directory _) -> - (match find_opt_model fs old_path with - | None -> fs - | Some sub_fs -> - let fs' = remove_model fs old_path_pref old_name in - insert_model fs' new_path_pref new_name sub_fs)) - let next_state c fs = match c with | File_exists _path -> fs | Mkdir (path, new_dir_name) -> - if mem_model fs (path @ [new_dir_name]) + if Model.mem fs (path @ [new_dir_name]) then fs - else insert_model fs path new_dir_name (Directory {fs_map = Map_names.empty}) + else Model.insert fs path new_dir_name (Directory {fs_map = Map_names.empty}) | Remove (path, file_name) -> - if find_opt_model fs (path @ [file_name]) = Some File - then remove_model fs path file_name + if Model.find_opt fs (path @ [file_name]) = Some File + then Model.remove fs path file_name else fs | Rename (old_path, new_path) -> if is_true_prefix old_path new_path then fs else - (match find_opt_model fs old_path with + (match Model.find_opt fs old_path with | None -> fs | Some File -> - if (not (mem_model fs new_path) || path_is_a_file fs new_path) then rename_model fs old_path new_path else fs + if (not (Model.mem fs new_path) || path_is_a_file fs new_path) then Model.rename fs old_path new_path else fs | Some (Directory _) -> - if (not (mem_model fs new_path) || readdir_model fs new_path = Some []) then rename_model fs old_path new_path else fs) + if (not (Model.mem fs new_path) || Model.readdir fs new_path = Some []) then Model.rename fs old_path new_path else fs) | Is_directory _path -> fs | Rmdir (path,delete_dir_name) -> let complete_path = path @ [delete_dir_name] in - if mem_model fs complete_path && readdir_model fs complete_path = Some [] - then remove_model fs path delete_dir_name + if Model.mem fs complete_path && Model.readdir fs complete_path = Some [] + then Model.remove fs path delete_dir_name else fs | Readdir _path -> fs | Mkfile (path, new_file_name) -> - if mem_model fs (path @ [new_file_name]) + if Model.mem fs (path @ [new_file_name]) then fs - else insert_model fs path new_file_name File + else Model.insert fs path new_file_name File let init_sut () = try Sys.mkdir sandbox_root 0o700 @@ -270,24 +273,24 @@ struct let postcond c (fs: filesys) res = match c, res with - | File_exists path, Res ((Bool,_),b) -> b = mem_model fs path + | File_exists path, Res ((Bool,_),b) -> b = Model.mem fs path | Is_directory path, Res ((Result (Bool,Exn),_),res) -> (match res with | Ok b -> - (match find_opt_model fs path with + (match Model.find_opt fs path with | Some (Directory _) -> b = true | Some File -> b = false | None -> false) | Error (Sys_error s) -> - (s = (p path) ^ ": No such file or directory" && not (mem_model fs path)) || + (s = (p path) ^ ": No such file or directory" && not (Model.mem fs path)) || (s = p path ^ ": Not a directory" && List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes path)) | _ -> false) | Remove (path, file_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [file_name]) in (match res with - | Ok () -> mem_model fs complete_path && path_is_a_dir fs path && not (path_is_a_dir fs complete_path) + | Ok () -> Model.mem fs complete_path && path_is_a_dir fs path && not (path_is_a_dir fs complete_path) | Error (Sys_error s) -> - (s = (p complete_path) ^ ": No such file or directory" && not (mem_model fs complete_path)) || + (s = (p complete_path) ^ ": No such file or directory" && not (Model.mem fs complete_path)) || (s = (p complete_path) ^ ": Is a directory" && path_is_a_dir fs complete_path) || (*Linux*) (s = (p complete_path) ^ ": Operation not permitted" && path_is_a_dir fs complete_path) || (*macOS*) (s = (p complete_path) ^ ": Permission denied" && path_is_a_dir fs complete_path) || (*Win*) @@ -296,18 +299,18 @@ struct ) | Rename (old_path, new_path), Res ((Result (Unit,Exn),_), res) -> (match res with - | Ok () -> mem_model fs old_path + | Ok () -> Model.mem fs old_path | Error (Sys_error s) -> (s = "No such file or directory" && - not (mem_model fs old_path) || List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path)) || + not (Model.mem fs old_path) || List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path)) || (s = "Invalid argument" && is_true_prefix old_path new_path) || (s = "Not a directory" && List.exists (path_is_a_file fs) (path_prefixes old_path) || List.exists (path_is_a_file fs) (path_prefixes new_path) || - path_is_a_dir fs old_path && mem_model fs new_path && not (path_is_a_dir fs new_path)) || + path_is_a_dir fs old_path && Model.mem fs new_path && not (path_is_a_dir fs new_path)) || (s = "Is a directory" && path_is_a_dir fs new_path) || (s = "Directory not empty" && - is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (readdir_model fs new_path = Some []))) + is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (Model.readdir fs new_path = Some []))) | Error _ -> false) | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [new_dir_name]) in @@ -316,14 +319,14 @@ struct (match err with | Sys_error s -> (s = (p complete_path) ^ ": Permission denied") || - (s = (p complete_path) ^ ": File exists" && mem_model fs complete_path) || + (s = (p complete_path) ^ ": File exists" && Model.mem fs complete_path) || ((s = (p complete_path) ^ ": No such file or directory" - || s = (p complete_path) ^ ": Invalid argument") && not (mem_model fs path)) || + || s = (p complete_path) ^ ": Invalid argument") && not (Model.mem fs path)) || if Sys.win32 && not (path_is_a_dir fs complete_path) then s = (p complete_path) ^ ": No such file or directory" else s = (p complete_path) ^ ": Not a directory" | _ -> false) - | Ok () -> mem_model fs path && path_is_a_dir fs path && not (mem_model fs complete_path)) + | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs complete_path)) | Rmdir (path, delete_dir_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [delete_dir_name]) in (match res with @@ -331,32 +334,32 @@ struct (match err with | Sys_error s -> (s = (p complete_path) ^ ": Permission denied") || - (s = (p complete_path) ^ ": Directory not empty" && not (readdir_model fs complete_path = Some [])) || - (s = (p complete_path) ^ ": No such file or directory" && not (mem_model fs complete_path)) || + (s = (p complete_path) ^ ": Directory not empty" && not (Model.readdir fs complete_path = Some [])) || + (s = (p complete_path) ^ ": No such file or directory" && not (Model.mem fs complete_path)) || if Sys.win32 && not (path_is_a_dir fs complete_path) (* if not a directory *) then s = (p complete_path) ^ ": Invalid argument" else s = (p complete_path) ^ ": Not a directory" | _ -> false) | Ok () -> - mem_model fs complete_path && path_is_a_dir fs complete_path && readdir_model fs complete_path = Some []) + Model.mem fs complete_path && path_is_a_dir fs complete_path && Model.readdir fs complete_path = Some []) | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with | Error err -> (match err with | Sys_error s -> (s = (p path) ^ ": Permission denied") || - (s = (p path) ^ ": No such file or directory" && not (mem_model fs path)) || + (s = (p path) ^ ": No such file or directory" && not (Model.mem fs path)) || if Sys.win32 && not (path_is_a_dir fs path) (* if not a directory *) then s = (p path) ^ ": Invalid argument" else s = (p path) ^ ": Not a directory" | _ -> false) | Ok array_of_subdir -> (* Temporary work around for mingW, see https://github.com/ocaml/ocaml/issues/11829 *) - if Sys.win32 && not (mem_model fs path) + if Sys.win32 && not (Model.mem fs path) then array_of_subdir = [||] else - (mem_model fs path && path_is_a_dir fs path && - (match readdir_model fs path with + (Model.mem fs path && path_is_a_dir fs path && + (match Model.readdir fs path with | None -> false | Some l -> List.sort String.compare l @@ -384,11 +387,11 @@ struct | Error err -> ( match err with | Sys_error s -> - (mem_model fs complete_path && match_msgs s msgs_already_exists) - || (not (mem_model fs path) && match_msgs s msgs_non_existent_dir) + (Model.mem fs complete_path && match_msgs s msgs_already_exists) + || (not (Model.mem fs path) && match_msgs s msgs_non_existent_dir) || (not (path_is_a_dir fs path) && match_msg s msg_path_not_dir) | _ -> false) - | Ok () -> path_is_a_dir fs path && not (mem_model fs complete_path)) + | Ok () -> path_is_a_dir fs path && not (Model.mem fs complete_path)) | _,_ -> false end From dad279c895e24eefab589c5ab71b75dbb92b2a5b Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 12:09:02 +0200 Subject: [PATCH 07/29] Add new pp_cmd cases --- src/sys/stm_tests.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 8ec05a0b3..57f8153fc 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -20,6 +20,9 @@ struct let pp_path = pp_list pp_string in match x with | File_exists x -> cst1 pp_path "File_exists" par fmt x + | Is_directory x -> cst1 pp_path "Is_directory" par fmt x + | Remove (x, y) -> cst2 pp_path pp_string "Remove" par fmt x y + | Rename (x, y) -> cst2 pp_path pp_path "Rename" par fmt x y | Mkdir (x, y) -> cst2 pp_path pp_string "Mkdir" par fmt x y | Rmdir (x, y) -> cst2 pp_path pp_string "Rmdir" par fmt x y | Readdir x -> cst1 pp_path "Readdir" par fmt x From 602b4b4da1de0a2a6dadefbbd3ace72778e19ccb Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 12:25:18 +0200 Subject: [PATCH 08/29] Factor out path_is_an_empty_dir --- src/sys/stm_tests.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 57f8153fc..dbb8ac5cd 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -190,6 +190,9 @@ struct | Some File -> false | Some (Directory _) -> true + let path_is_an_empty_dir fs path = + Model.readdir fs path = Some [] + let path_is_a_file fs path = match Model.find_opt fs path with | None @@ -227,11 +230,11 @@ struct | Some File -> if (not (Model.mem fs new_path) || path_is_a_file fs new_path) then Model.rename fs old_path new_path else fs | Some (Directory _) -> - if (not (Model.mem fs new_path) || Model.readdir fs new_path = Some []) then Model.rename fs old_path new_path else fs) + if (not (Model.mem fs new_path) || path_is_an_empty_dir fs new_path) then Model.rename fs old_path new_path else fs) | Is_directory _path -> fs | Rmdir (path,delete_dir_name) -> let complete_path = path @ [delete_dir_name] in - if Model.mem fs complete_path && Model.readdir fs complete_path = Some [] + if Model.mem fs complete_path && path_is_an_empty_dir fs complete_path then Model.remove fs path delete_dir_name else fs | Readdir _path -> fs @@ -313,7 +316,7 @@ struct path_is_a_dir fs old_path && Model.mem fs new_path && not (path_is_a_dir fs new_path)) || (s = "Is a directory" && path_is_a_dir fs new_path) || (s = "Directory not empty" && - is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (Model.readdir fs new_path = Some []))) + is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (path_is_an_empty_dir fs new_path))) | Error _ -> false) | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [new_dir_name]) in @@ -337,14 +340,14 @@ struct (match err with | Sys_error s -> (s = (p complete_path) ^ ": Permission denied") || - (s = (p complete_path) ^ ": Directory not empty" && not (Model.readdir fs complete_path = Some [])) || + (s = (p complete_path) ^ ": Directory not empty" && not (path_is_an_empty_dir fs complete_path)) || (s = (p complete_path) ^ ": No such file or directory" && not (Model.mem fs complete_path)) || if Sys.win32 && not (path_is_a_dir fs complete_path) (* if not a directory *) then s = (p complete_path) ^ ": Invalid argument" else s = (p complete_path) ^ ": Not a directory" | _ -> false) | Ok () -> - Model.mem fs complete_path && path_is_a_dir fs complete_path && Model.readdir fs complete_path = Some []) + Model.mem fs complete_path && path_is_a_dir fs complete_path && path_is_an_empty_dir fs complete_path) | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with | Error err -> From e0b0339315f75ec541d0017c23debe43ccc2ca70 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 12:32:57 +0200 Subject: [PATCH 09/29] Move Model module up front --- src/sys/stm_tests.ml | 181 ++++++++++++++++++++++--------------------- 1 file changed, 91 insertions(+), 90 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index dbb8ac5cd..81afe74d7 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -1,8 +1,99 @@ open QCheck open STM +module Model = +struct + module Map_names = Map.Make (String) + + type filesys = + | Directory of {fs_map: filesys Map_names.t} + | File + + let rec find_opt fs path = + match fs with + | File -> + if path = [] + then Some fs + else None + | Directory d -> + (match path with + | [] -> Some (Directory d) + | hd :: tl -> + (match Map_names.find_opt hd d.fs_map with + | None -> None + | Some fs -> find_opt fs tl)) + + let mem fs path = find_opt fs path <> None + + (* generic removal function *) + let rec remove fs path file_name = + match fs with + | File -> fs + | Directory d -> + (match path with + | [] -> + (match Map_names.find_opt file_name d.fs_map with + | None + | Some _ -> Directory { fs_map = Map_names.remove file_name d.fs_map }) + | dir::dirs -> + Directory + { fs_map = Map_names.update dir (function + | None -> None + | Some File -> Some File + | Some (Directory _ as d') -> Some (remove d' dirs file_name)) d.fs_map + }) + + let readdir fs path = + match find_opt fs path with + | None -> None + | Some fs -> + (match fs with + | File -> None + | Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map [])) + + let update_map_name map_name k v = Map_names.update k (fun _ -> Some v) map_name + + (* generic insertion function *) + let rec insert fs path new_file_name sub_tree = + match fs with + | File -> fs + | Directory d -> + (match path with + | [] -> + Directory {fs_map = Map_names.add new_file_name sub_tree d.fs_map} + | next_in_path :: tl_path -> + (match Map_names.find_opt next_in_path d.fs_map with + | None -> fs + | Some sub_fs -> + let nfs = insert sub_fs tl_path new_file_name sub_tree in + if nfs = sub_fs + then fs + else Directory {fs_map = update_map_name d.fs_map next_in_path nfs})) + + let separate_path path = + match List.rev path with + | [] -> None + | name::rev_path -> Some (List.rev rev_path, name) + + let rename fs old_path new_path = + match separate_path old_path, separate_path new_path with + | None, _ + | _, None -> fs + | Some (old_path_pref, old_name), Some (new_path_pref, new_name) -> + (match find_opt fs new_path_pref with + | None + | Some File -> fs + | Some (Directory _) -> + (match find_opt fs old_path with + | None -> fs + | Some sub_fs -> + let fs' = remove fs old_path_pref old_name in + insert fs' new_path_pref new_name sub_fs)) +end + module SConf = struct + include Model type path = string list type cmd = @@ -30,20 +121,12 @@ struct let show_cmd = Util.Pp.to_show pp_cmd - module Map_names = Map.Make (String) - - type filesys = - | Directory of {fs_map: filesys Map_names.t} - | File - type state = filesys type sut = unit let (/) = Filename.concat - let update_map_name map_name k v = Map_names.update k (fun _ -> Some v) map_name - (* var gen_existing_path : filesys -> path Gen.t *) let rec gen_existing_path fs = match fs with @@ -102,88 +185,6 @@ struct let init_state = Directory {fs_map = Map_names.empty} - module Model = - struct - let rec find_opt fs path = - match fs with - | File -> - if path = [] - then Some fs - else None - | Directory d -> - (match path with - | [] -> Some (Directory d) - | hd :: tl -> - (match Map_names.find_opt hd d.fs_map with - | None -> None - | Some fs -> find_opt fs tl)) - - let mem fs path = find_opt fs path <> None - - (* generic removal function *) - let rec remove fs path file_name = - match fs with - | File -> fs - | Directory d -> - (match path with - | [] -> - (match Map_names.find_opt file_name d.fs_map with - | None - | Some _ -> Directory { fs_map = Map_names.remove file_name d.fs_map }) - | dir::dirs -> - Directory - { fs_map = Map_names.update dir (function - | None -> None - | Some File -> Some File - | Some (Directory _ as d') -> Some (remove d' dirs file_name)) d.fs_map - }) - - let readdir fs path = - match find_opt fs path with - | None -> None - | Some fs -> - (match fs with - | File -> None - | Directory d -> Some (Map_names.fold (fun k _ l -> k::l) d.fs_map [])) - - (* generic insertion function *) - let rec insert fs path new_file_name sub_tree = - match fs with - | File -> fs - | Directory d -> - (match path with - | [] -> - Directory {fs_map = Map_names.add new_file_name sub_tree d.fs_map} - | next_in_path :: tl_path -> - (match Map_names.find_opt next_in_path d.fs_map with - | None -> fs - | Some sub_fs -> - let nfs = insert sub_fs tl_path new_file_name sub_tree in - if nfs = sub_fs - then fs - else Directory {fs_map = update_map_name d.fs_map next_in_path nfs})) - - let separate_path path = - match List.rev path with - | [] -> None - | name::rev_path -> Some (List.rev rev_path, name) - - let rename fs old_path new_path = - match separate_path old_path, separate_path new_path with - | None, _ - | _, None -> fs - | Some (old_path_pref, old_name), Some (new_path_pref, new_name) -> - (match find_opt fs new_path_pref with - | None - | Some File -> fs - | Some (Directory _) -> - (match find_opt fs old_path with - | None -> fs - | Some sub_fs -> - let fs' = remove fs old_path_pref old_name in - insert fs' new_path_pref new_name sub_fs)) - end - let path_is_a_dir fs path = match Model.find_opt fs path with | None From 927bcf823468171aac65cdd7ed84a4f08e0b1ec5 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 12:43:00 +0200 Subject: [PATCH 10/29] Factor out empty_dir --- src/sys/stm_tests.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 81afe74d7..172b5ab29 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -9,6 +9,8 @@ struct | Directory of {fs_map: filesys Map_names.t} | File + let empty_dir = Directory {fs_map = Map_names.empty} + let rec find_opt fs path = match fs with | File -> @@ -183,7 +185,7 @@ struct let sandbox_root = "_sandbox" - let init_state = Directory {fs_map = Map_names.empty} + let init_state = Model.empty_dir let path_is_a_dir fs path = match Model.find_opt fs path with @@ -217,7 +219,7 @@ struct | Mkdir (path, new_dir_name) -> if Model.mem fs (path @ [new_dir_name]) then fs - else Model.insert fs path new_dir_name (Directory {fs_map = Map_names.empty}) + else Model.insert fs path new_dir_name Model.empty_dir | Remove (path, file_name) -> if Model.find_opt fs (path @ [file_name]) = Some File then Model.remove fs path file_name From 4e3ca44dc3555f0539b45bbc176a88031bdb9029 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 13:05:41 +0200 Subject: [PATCH 11/29] Factor out match_err --- src/sys/stm_tests.ml | 49 ++++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 172b5ab29..a1d7d9993 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -280,6 +280,8 @@ struct | Mkfile (path, new_file_name) -> Res (result unit exn, protect mkfile (p path / new_file_name)) + let match_err err path msg = err = (p path) ^ ": " ^ msg + let postcond c (fs: filesys) res = match c, res with | File_exists path, Res ((Bool,_),b) -> b = Model.mem fs path @@ -291,19 +293,19 @@ struct | Some File -> b = false | None -> false) | Error (Sys_error s) -> - (s = (p path) ^ ": No such file or directory" && not (Model.mem fs path)) || - (s = p path ^ ": Not a directory" && List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes path)) + (match_err s path "No such file or directory" && not (Model.mem fs path)) || + (match_err s path "Not a directory" && List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes path)) | _ -> false) | Remove (path, file_name), Res ((Result (Unit,Exn),_), res) -> let complete_path = (path @ [file_name]) in (match res with | Ok () -> Model.mem fs complete_path && path_is_a_dir fs path && not (path_is_a_dir fs complete_path) | Error (Sys_error s) -> - (s = (p complete_path) ^ ": No such file or directory" && not (Model.mem fs complete_path)) || - (s = (p complete_path) ^ ": Is a directory" && path_is_a_dir fs complete_path) || (*Linux*) - (s = (p complete_path) ^ ": Operation not permitted" && path_is_a_dir fs complete_path) || (*macOS*) - (s = (p complete_path) ^ ": Permission denied" && path_is_a_dir fs complete_path) || (*Win*) - (s = (p complete_path) ^ ": Not a directory" && not (path_is_a_dir fs path)) + (match_err s complete_path "No such file or directory" && not (Model.mem fs complete_path)) || + (match_err s complete_path "Is a directory" && path_is_a_dir fs complete_path) || (*Linux*) + (match_err s complete_path "Operation not permitted" && path_is_a_dir fs complete_path) || (*macOS*) + (match_err s complete_path "Permission denied" && path_is_a_dir fs complete_path) || (*Win*) + (match_err s complete_path "Not a directory" && not (path_is_a_dir fs path)) | Error _ -> false ) | Rename (old_path, new_path), Res ((Result (Unit,Exn),_), res) -> @@ -327,13 +329,13 @@ struct | Error err -> (match err with | Sys_error s -> - (s = (p complete_path) ^ ": Permission denied") || - (s = (p complete_path) ^ ": File exists" && Model.mem fs complete_path) || - ((s = (p complete_path) ^ ": No such file or directory" - || s = (p complete_path) ^ ": Invalid argument") && not (Model.mem fs path)) || + (match_err s complete_path "Permission denied") || + (match_err s complete_path "File exists" && Model.mem fs complete_path) || + ((match_err s complete_path "No such file or directory" + || match_err s complete_path "Invalid argument") && not (Model.mem fs path)) || if Sys.win32 && not (path_is_a_dir fs complete_path) - then s = (p complete_path) ^ ": No such file or directory" - else s = (p complete_path) ^ ": Not a directory" + then match_err s complete_path "No such file or directory" + else match_err s complete_path "Not a directory" | _ -> false) | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs complete_path)) | Rmdir (path, delete_dir_name), Res ((Result (Unit,Exn),_), res) -> @@ -342,12 +344,12 @@ struct | Error err -> (match err with | Sys_error s -> - (s = (p complete_path) ^ ": Permission denied") || - (s = (p complete_path) ^ ": Directory not empty" && not (path_is_an_empty_dir fs complete_path)) || - (s = (p complete_path) ^ ": No such file or directory" && not (Model.mem fs complete_path)) || + (match_err s complete_path "Permission denied") || + (match_err s complete_path "Directory not empty" && not (path_is_an_empty_dir fs complete_path)) || + (match_err s complete_path "No such file or directory" && not (Model.mem fs complete_path)) || if Sys.win32 && not (path_is_a_dir fs complete_path) (* if not a directory *) - then s = (p complete_path) ^ ": Invalid argument" - else s = (p complete_path) ^ ": Not a directory" + then match_err s complete_path "Invalid argument" + else match_err s complete_path "Not a directory" | _ -> false) | Ok () -> Model.mem fs complete_path && path_is_a_dir fs complete_path && path_is_an_empty_dir fs complete_path) @@ -356,11 +358,11 @@ struct | Error err -> (match err with | Sys_error s -> - (s = (p path) ^ ": Permission denied") || - (s = (p path) ^ ": No such file or directory" && not (Model.mem fs path)) || + (match_err s path "Permission denied") || + (match_err s path "No such file or directory" && not (Model.mem fs path)) || if Sys.win32 && not (path_is_a_dir fs path) (* if not a directory *) - then s = (p path) ^ ": Invalid argument" - else s = (p path) ^ ": Not a directory" + then match_err s path "Invalid argument" + else match_err s path "Not a directory" | _ -> false) | Ok array_of_subdir -> (* Temporary work around for mingW, see https://github.com/ocaml/ocaml/issues/11829 *) @@ -375,8 +377,7 @@ struct = List.sort String.compare (Array.to_list array_of_subdir)))) | Mkfile (path, new_file_name), Res ((Result (Unit,Exn),_),res) -> ( let complete_path = path @ [ new_file_name ] in - let concatenated_path = p complete_path in - let match_msg err msg = err = concatenated_path ^ ": " ^ msg in + let match_msg err msg = match_err err complete_path msg in let match_msgs err = List.exists (match_msg err) in let msgs_already_exists = ["File exists"; "Permission denied"] (* Permission denied: seen (sometimes?) on Windows *) From 6a1a817c98782f59078eeb1672a9777e18536f09 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 13:50:42 +0200 Subject: [PATCH 12/29] Make error msg matching cases more uniform --- src/sys/stm_tests.ml | 103 +++++++++++++++++++------------------------ 1 file changed, 45 insertions(+), 58 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index a1d7d9993..a8ec960b7 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -280,7 +280,8 @@ struct | Mkfile (path, new_file_name) -> Res (result unit exn, protect mkfile (p path / new_file_name)) - let match_err err path msg = err = (p path) ^ ": " ^ msg + let match_msg err path msg = err = (p path) ^ ": " ^ msg + let match_msgs err path msgs = List.exists (match_msg err path) msgs let postcond c (fs: filesys) res = match c, res with @@ -293,19 +294,20 @@ struct | Some File -> b = false | None -> false) | Error (Sys_error s) -> - (match_err s path "No such file or directory" && not (Model.mem fs path)) || - (match_err s path "Not a directory" && List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes path)) + (match_msg s path "No such file or directory" && not (Model.mem fs path)) || + (match_msg s path "Not a directory" && + List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes path)) | _ -> false) | Remove (path, file_name), Res ((Result (Unit,Exn),_), res) -> - let complete_path = (path @ [file_name]) in + let full_path = (path @ [file_name]) in (match res with - | Ok () -> Model.mem fs complete_path && path_is_a_dir fs path && not (path_is_a_dir fs complete_path) + | Ok () -> Model.mem fs full_path && path_is_a_dir fs path && not (path_is_a_dir fs full_path) | Error (Sys_error s) -> - (match_err s complete_path "No such file or directory" && not (Model.mem fs complete_path)) || - (match_err s complete_path "Is a directory" && path_is_a_dir fs complete_path) || (*Linux*) - (match_err s complete_path "Operation not permitted" && path_is_a_dir fs complete_path) || (*macOS*) - (match_err s complete_path "Permission denied" && path_is_a_dir fs complete_path) || (*Win*) - (match_err s complete_path "Not a directory" && not (path_is_a_dir fs path)) + (match_msg s full_path "No such file or directory" && not (Model.mem fs full_path)) || + (match_msgs s full_path ["Is a directory"; (*Linux*) + "Operation not permitted"; (*macOS*) + "Permission denied"(*Win*)] && path_is_a_dir fs full_path) || + (match_msg s full_path "Not a directory" && not (path_is_a_dir fs path)) | Error _ -> false ) | Rename (old_path, new_path), Res ((Result (Unit,Exn),_), res) -> @@ -324,45 +326,42 @@ struct is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (path_is_an_empty_dir fs new_path))) | Error _ -> false) | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> - let complete_path = (path @ [new_dir_name]) in + let full_path = (path @ [new_dir_name]) in (match res with | Error err -> (match err with | Sys_error s -> - (match_err s complete_path "Permission denied") || - (match_err s complete_path "File exists" && Model.mem fs complete_path) || - ((match_err s complete_path "No such file or directory" - || match_err s complete_path "Invalid argument") && not (Model.mem fs path)) || - if Sys.win32 && not (path_is_a_dir fs complete_path) - then match_err s complete_path "No such file or directory" - else match_err s complete_path "Not a directory" + (match_msg s full_path "Permission denied") || + (match_msg s full_path "File exists" && Model.mem fs full_path) || + (match_msgs s full_path ["No such file or directory"; + "Invalid argument"] && not (Model.mem fs path)) || + (match_msgs s full_path ["Not a directory"; + "No such file or directory"(*win32*)] && not (path_is_a_dir fs full_path)) | _ -> false) - | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs complete_path)) + | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs full_path)) | Rmdir (path, delete_dir_name), Res ((Result (Unit,Exn),_), res) -> - let complete_path = (path @ [delete_dir_name]) in + let full_path = (path @ [delete_dir_name]) in (match res with | Error err -> (match err with | Sys_error s -> - (match_err s complete_path "Permission denied") || - (match_err s complete_path "Directory not empty" && not (path_is_an_empty_dir fs complete_path)) || - (match_err s complete_path "No such file or directory" && not (Model.mem fs complete_path)) || - if Sys.win32 && not (path_is_a_dir fs complete_path) (* if not a directory *) - then match_err s complete_path "Invalid argument" - else match_err s complete_path "Not a directory" + (match_msg s full_path "Permission denied") || + (match_msg s full_path "Directory not empty" && not (path_is_an_empty_dir fs full_path)) || + (match_msg s full_path "No such file or directory" && not (Model.mem fs full_path)) || + (match_msgs s full_path ["Not a directory"; + "Invalid argument"(*win32*)] && not (path_is_a_dir fs full_path)) | _ -> false) | Ok () -> - Model.mem fs complete_path && path_is_a_dir fs complete_path && path_is_an_empty_dir fs complete_path) + Model.mem fs full_path && path_is_a_dir fs full_path && path_is_an_empty_dir fs full_path) | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with | Error err -> (match err with | Sys_error s -> - (match_err s path "Permission denied") || - (match_err s path "No such file or directory" && not (Model.mem fs path)) || - if Sys.win32 && not (path_is_a_dir fs path) (* if not a directory *) - then match_err s path "Invalid argument" - else match_err s path "Not a directory" + (match_msg s path "Permission denied") || + (match_msg s path "No such file or directory" && not (Model.mem fs path)) || + (match_msgs s path ["Not a directory"; + "Invalid argument"(*win32*)] && not (path_is_a_dir fs path)) | _ -> false) | Ok array_of_subdir -> (* Temporary work around for mingW, see https://github.com/ocaml/ocaml/issues/11829 *) @@ -370,38 +369,26 @@ struct then array_of_subdir = [||] else (Model.mem fs path && path_is_a_dir fs path && - (match Model.readdir fs path with - | None -> false - | Some l -> - List.sort String.compare l - = List.sort String.compare (Array.to_list array_of_subdir)))) + (match Model.readdir fs path with + | None -> false + | Some l -> + List.sort String.compare l + = List.sort String.compare (Array.to_list array_of_subdir)))) | Mkfile (path, new_file_name), Res ((Result (Unit,Exn),_),res) -> ( - let complete_path = path @ [ new_file_name ] in - let match_msg err msg = match_err err complete_path msg in - let match_msgs err = List.exists (match_msg err) in - let msgs_already_exists = ["File exists"; "Permission denied"] - (* Permission denied: seen (sometimes?) on Windows *) - and msgs_non_existent_dir = ["No such file or directory"; - "Invalid argument"; - "Permission denied"] - (* Invalid argument: seen on macOS - Permission denied: seen on Windows *) - and msg_path_not_dir = - match Sys.os_type with - | "Cygwin" - | "Unix" -> "Not a directory" - | "Win32" -> "No such file or directory" - | v -> failwith ("Sys tests not working with " ^ v) - in + let full_path = path @ [ new_file_name ] in match res with | Error err -> ( match err with | Sys_error s -> - (Model.mem fs complete_path && match_msgs s msgs_already_exists) - || (not (Model.mem fs path) && match_msgs s msgs_non_existent_dir) - || (not (path_is_a_dir fs path) && match_msg s msg_path_not_dir) + (match_msgs s full_path ["File exists"; + "Permission denied"] && Model.mem fs full_path) || + (match_msgs s full_path ["No such file or directory"; + "Invalid argument"; + "Permission denied"] && not (Model.mem fs path)) || + (match_msgs s full_path ["Not a directory"; + "No such file or directory"] && not (path_is_a_dir fs path)) | _ -> false) - | Ok () -> path_is_a_dir fs path && not (Model.mem fs complete_path)) + | Ok () -> path_is_a_dir fs path && not (Model.mem fs full_path)) | _,_ -> false end From bfa385938384c8bab97df4bc544ddbd3282b3c55 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 14:00:59 +0200 Subject: [PATCH 13/29] More uniformity: short Ok first, match on Error (Sys_error s) --- src/sys/stm_tests.ml | 105 ++++++++++++++++++++----------------------- 1 file changed, 49 insertions(+), 56 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index a8ec960b7..1ccb23d2b 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -285,7 +285,8 @@ struct let postcond c (fs: filesys) res = match c, res with - | File_exists path, Res ((Bool,_),b) -> b = Model.mem fs path + | File_exists path, Res ((Bool,_),b) -> + b = Model.mem fs path | Is_directory path, Res ((Result (Bool,Exn),_),res) -> (match res with | Ok b -> @@ -328,67 +329,59 @@ struct | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> let full_path = (path @ [new_dir_name]) in (match res with - | Error err -> - (match err with - | Sys_error s -> - (match_msg s full_path "Permission denied") || - (match_msg s full_path "File exists" && Model.mem fs full_path) || - (match_msgs s full_path ["No such file or directory"; - "Invalid argument"] && not (Model.mem fs path)) || - (match_msgs s full_path ["Not a directory"; - "No such file or directory"(*win32*)] && not (path_is_a_dir fs full_path)) - | _ -> false) - | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs full_path)) + | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs full_path) + | Error (Sys_error s) -> + (match_msg s full_path "Permission denied") || + (match_msg s full_path "File exists" && Model.mem fs full_path) || + (match_msgs s full_path ["No such file or directory"; + "Invalid argument"] && not (Model.mem fs path)) || + (match_msgs s full_path ["Not a directory"; + "No such file or directory"(*win32*)] && not (path_is_a_dir fs full_path)) + | Error _ -> false) | Rmdir (path, delete_dir_name), Res ((Result (Unit,Exn),_), res) -> let full_path = (path @ [delete_dir_name]) in (match res with - | Error err -> - (match err with - | Sys_error s -> - (match_msg s full_path "Permission denied") || - (match_msg s full_path "Directory not empty" && not (path_is_an_empty_dir fs full_path)) || - (match_msg s full_path "No such file or directory" && not (Model.mem fs full_path)) || - (match_msgs s full_path ["Not a directory"; - "Invalid argument"(*win32*)] && not (path_is_a_dir fs full_path)) - | _ -> false) - | Ok () -> - Model.mem fs full_path && path_is_a_dir fs full_path && path_is_an_empty_dir fs full_path) + | Ok () -> + Model.mem fs full_path && path_is_a_dir fs full_path && path_is_an_empty_dir fs full_path + | Error (Sys_error s) -> + (match_msg s full_path "Permission denied") || + (match_msg s full_path "Directory not empty" && not (path_is_an_empty_dir fs full_path)) || + (match_msg s full_path "No such file or directory" && not (Model.mem fs full_path)) || + (match_msgs s full_path ["Not a directory"; + "Invalid argument"(*win32*)] && not (path_is_a_dir fs full_path)) + | Error _ -> false) | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with - | Error err -> - (match err with - | Sys_error s -> - (match_msg s path "Permission denied") || - (match_msg s path "No such file or directory" && not (Model.mem fs path)) || - (match_msgs s path ["Not a directory"; - "Invalid argument"(*win32*)] && not (path_is_a_dir fs path)) - | _ -> false) - | Ok array_of_subdir -> - (* Temporary work around for mingW, see https://github.com/ocaml/ocaml/issues/11829 *) - if Sys.win32 && not (Model.mem fs path) - then array_of_subdir = [||] - else - (Model.mem fs path && path_is_a_dir fs path && - (match Model.readdir fs path with - | None -> false - | Some l -> - List.sort String.compare l - = List.sort String.compare (Array.to_list array_of_subdir)))) - | Mkfile (path, new_file_name), Res ((Result (Unit,Exn),_),res) -> ( + | Ok array_of_subdir -> + (* Temporary work around for mingW, see https://github.com/ocaml/ocaml/issues/11829 *) + if Sys.win32 && not (Model.mem fs path) + then array_of_subdir = [||] + else + (Model.mem fs path && path_is_a_dir fs path && + (match Model.readdir fs path with + | None -> false + | Some l -> + List.sort String.compare l + = List.sort String.compare (Array.to_list array_of_subdir))) + | Error (Sys_error s) -> + (match_msg s path "Permission denied") || + (match_msg s path "No such file or directory" && not (Model.mem fs path)) || + (match_msgs s path ["Not a directory"; + "Invalid argument"(*win32*)] && not (path_is_a_dir fs path)) + | Error _ -> false) + | Mkfile (path, new_file_name), Res ((Result (Unit,Exn),_),res) -> let full_path = path @ [ new_file_name ] in - match res with - | Error err -> ( - match err with - | Sys_error s -> - (match_msgs s full_path ["File exists"; - "Permission denied"] && Model.mem fs full_path) || - (match_msgs s full_path ["No such file or directory"; - "Invalid argument"; - "Permission denied"] && not (Model.mem fs path)) || - (match_msgs s full_path ["Not a directory"; - "No such file or directory"] && not (path_is_a_dir fs path)) - | _ -> false) - | Ok () -> path_is_a_dir fs path && not (Model.mem fs full_path)) + (match res with + | Ok () -> path_is_a_dir fs path && not (Model.mem fs full_path) + | Error (Sys_error s) -> + (match_msgs s full_path ["File exists"; + "Permission denied"] && Model.mem fs full_path) || + (match_msgs s full_path ["No such file or directory"; + "Invalid argument"; + "Permission denied"] && not (Model.mem fs path)) || + (match_msgs s full_path ["Not a directory"; + "No such file or directory"] && not (path_is_a_dir fs path)) + | Error _ -> false) | _,_ -> false end From e417404cfb63d6501af224afa850da8bb342de0e Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 15:36:39 +0200 Subject: [PATCH 14/29] Add workarounds for buggy MingW Sys.rename behaviour --- src/sys/stm_tests.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 1ccb23d2b..162f7e043 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -233,7 +233,11 @@ struct | Some File -> if (not (Model.mem fs new_path) || path_is_a_file fs new_path) then Model.rename fs old_path new_path else fs | Some (Directory _) -> - if (not (Model.mem fs new_path) || path_is_an_empty_dir fs new_path) then Model.rename fs old_path new_path else fs) + (* temporary workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) + if Sys.win32 && path_is_an_empty_dir fs new_path then fs else + (* temporary workaround for dir-to-file https://github.com/ocaml/ocaml/issues/12073 *) + if (Sys.win32 && path_is_an_empty_dir fs new_path) || + (not (Model.mem fs new_path) || path_is_an_empty_dir fs new_path) then Model.rename fs old_path new_path else fs) | Is_directory _path -> fs | Rmdir (path,delete_dir_name) -> let complete_path = path @ [delete_dir_name] in @@ -313,8 +317,10 @@ struct ) | Rename (old_path, new_path), Res ((Result (Unit,Exn),_), res) -> (match res with - | Ok () -> Model.mem fs old_path + | Ok () -> Model.mem fs old_path (* permits dir-to-file MingW success https://github.com/ocaml/ocaml/issues/12073 *) | Error (Sys_error s) -> + (* temporary workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) + (s = "Permission denied" && Sys.win32 && path_is_a_dir fs old_path && path_is_an_empty_dir fs new_path) || (s = "No such file or directory" && not (Model.mem fs old_path) || List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path)) || (s = "Invalid argument" && is_true_prefix old_path new_path) || From b8ab7736519ca4c91d33a9ba1a3bbd2d33baaa08 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 16:12:03 +0200 Subject: [PATCH 15/29] patch dir-to-file on MingW --- src/sys/stm_tests.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 162f7e043..3bb678663 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -236,8 +236,14 @@ struct (* temporary workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) if Sys.win32 && path_is_an_empty_dir fs new_path then fs else (* temporary workaround for dir-to-file https://github.com/ocaml/ocaml/issues/12073 *) - if (Sys.win32 && path_is_an_empty_dir fs new_path) || - (not (Model.mem fs new_path) || path_is_an_empty_dir fs new_path) then Model.rename fs old_path new_path else fs) + if (Sys.win32 && path_is_file fs new_path) then + (match Model.separate_path new_path in + | None -> fs + | Some (new_path_pref, new_name) -> + let fs = remove fs new_path_pref new_name in + Model.rename fs old_path new_path) + else + if (not (Model.mem fs new_path) || path_is_an_empty_dir fs new_path) then Model.rename fs old_path new_path else fs) | Is_directory _path -> fs | Rmdir (path,delete_dir_name) -> let complete_path = path @ [delete_dir_name] in From 5ed0cb0b2adeeaf3a3d83d93ed96ca8443abf6cb Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 16:21:02 +0200 Subject: [PATCH 16/29] patch file-to-dir Permission denied error on MingW --- src/sys/stm_tests.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 3bb678663..e7b51667d 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -236,8 +236,8 @@ struct (* temporary workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) if Sys.win32 && path_is_an_empty_dir fs new_path then fs else (* temporary workaround for dir-to-file https://github.com/ocaml/ocaml/issues/12073 *) - if (Sys.win32 && path_is_file fs new_path) then - (match Model.separate_path new_path in + if (Sys.win32 && path_is_a_file fs new_path) then + (match Model.separate_path new_path with | None -> fs | Some (new_path_pref, new_name) -> let fs = remove fs new_path_pref new_name in @@ -334,7 +334,7 @@ struct List.exists (path_is_a_file fs) (path_prefixes old_path) || List.exists (path_is_a_file fs) (path_prefixes new_path) || path_is_a_dir fs old_path && Model.mem fs new_path && not (path_is_a_dir fs new_path)) || - (s = "Is a directory" && path_is_a_dir fs new_path) || + ((s = "Is a directory" || s = "Permission denied") && path_is_a_dir fs new_path) || (s = "Directory not empty" && is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (path_is_an_empty_dir fs new_path))) | Error _ -> false) From 5a5b40107c53d957aa4a0b52d09c44a829a1f7f6 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 16:34:17 +0200 Subject: [PATCH 17/29] patch dir-to-dir Sys.rename MingW regression --- src/sys/stm_tests.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index e7b51667d..9e1f94e24 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -327,6 +327,8 @@ struct | Error (Sys_error s) -> (* temporary workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) (s = "Permission denied" && Sys.win32 && path_is_a_dir fs old_path && path_is_an_empty_dir fs new_path) || + (* temporary workaround for identity regression renaming under MingW *) + (s = "No such file or directory" && Sys.win32 && old_path = new_path && path_is_an_empty_dir fs new_path) || (s = "No such file or directory" && not (Model.mem fs old_path) || List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path)) || (s = "Invalid argument" && is_true_prefix old_path new_path) || From 2ee78d9629e0f4e2ab0bd9d7bcb6f447f4e35204 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 16:46:49 +0200 Subject: [PATCH 18/29] Another different Sys.rename error message --- src/sys/stm_tests.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 9e1f94e24..75d64933e 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -331,12 +331,12 @@ struct (s = "No such file or directory" && Sys.win32 && old_path = new_path && path_is_an_empty_dir fs new_path) || (s = "No such file or directory" && not (Model.mem fs old_path) || List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path)) || - (s = "Invalid argument" && is_true_prefix old_path new_path) || + ((s = "Invalid argument" || s = "Permission denied"(*Win32*)) && is_true_prefix old_path new_path) || (s = "Not a directory" && List.exists (path_is_a_file fs) (path_prefixes old_path) || List.exists (path_is_a_file fs) (path_prefixes new_path) || path_is_a_dir fs old_path && Model.mem fs new_path && not (path_is_a_dir fs new_path)) || - ((s = "Is a directory" || s = "Permission denied") && path_is_a_dir fs new_path) || + ((s = "Is a directory" || s = "Permission denied"(*Win32*)) && path_is_a_dir fs new_path) || (s = "Directory not empty" && is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (path_is_an_empty_dir fs new_path))) | Error _ -> false) From b8798c3672ec132966b180741bb4efed057988c1 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 24 May 2023 17:06:22 +0200 Subject: [PATCH 19/29] Remove unused Permission-denied cases --- src/sys/stm_tests.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 75d64933e..4fae9b0af 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -345,7 +345,6 @@ struct (match res with | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs full_path) | Error (Sys_error s) -> - (match_msg s full_path "Permission denied") || (match_msg s full_path "File exists" && Model.mem fs full_path) || (match_msgs s full_path ["No such file or directory"; "Invalid argument"] && not (Model.mem fs path)) || @@ -358,7 +357,6 @@ struct | Ok () -> Model.mem fs full_path && path_is_a_dir fs full_path && path_is_an_empty_dir fs full_path | Error (Sys_error s) -> - (match_msg s full_path "Permission denied") || (match_msg s full_path "Directory not empty" && not (path_is_an_empty_dir fs full_path)) || (match_msg s full_path "No such file or directory" && not (Model.mem fs full_path)) || (match_msgs s full_path ["Not a directory"; @@ -378,7 +376,6 @@ struct List.sort String.compare l = List.sort String.compare (Array.to_list array_of_subdir))) | Error (Sys_error s) -> - (match_msg s path "Permission denied") || (match_msg s path "No such file or directory" && not (Model.mem fs path)) || (match_msgs s path ["Not a directory"; "Invalid argument"(*win32*)] && not (path_is_a_dir fs path)) From 6a568710e41984596f3a6f9a2514dfcbc3544e8f Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Fri, 19 Apr 2024 14:52:22 +0200 Subject: [PATCH 20/29] Remove reverse-engineering of error-message conditions --- src/sys/stm_tests.ml | 81 +++++++++++++++----------------------------- 1 file changed, 28 insertions(+), 53 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 4fae9b0af..67560138c 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -290,9 +290,6 @@ struct | Mkfile (path, new_file_name) -> Res (result unit exn, protect mkfile (p path / new_file_name)) - let match_msg err path msg = err = (p path) ^ ": " ^ msg - let match_msgs err path msgs = List.exists (match_msg err path) msgs - let postcond c (fs: filesys) res = match c, res with | File_exists path, Res ((Bool,_),b) -> @@ -304,63 +301,49 @@ struct | Some (Directory _) -> b = true | Some File -> b = false | None -> false) - | Error (Sys_error s) -> - (match_msg s path "No such file or directory" && not (Model.mem fs path)) || - (match_msg s path "Not a directory" && - List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes path)) + | Error (Sys_error _) -> not (Model.mem fs path) | _ -> false) | Remove (path, file_name), Res ((Result (Unit,Exn),_), res) -> - let full_path = (path @ [file_name]) in + let full_path = path @ [file_name] in (match res with | Ok () -> Model.mem fs full_path && path_is_a_dir fs path && not (path_is_a_dir fs full_path) - | Error (Sys_error s) -> - (match_msg s full_path "No such file or directory" && not (Model.mem fs full_path)) || - (match_msgs s full_path ["Is a directory"; (*Linux*) - "Operation not permitted"; (*macOS*) - "Permission denied"(*Win*)] && path_is_a_dir fs full_path) || - (match_msg s full_path "Not a directory" && not (path_is_a_dir fs path)) + | Error (Sys_error _) -> + (not (Model.mem fs full_path)) || path_is_a_dir fs full_path || not (path_is_a_dir fs path) | Error _ -> false ) | Rename (old_path, new_path), Res ((Result (Unit,Exn),_), res) -> (match res with | Ok () -> Model.mem fs old_path (* permits dir-to-file MingW success https://github.com/ocaml/ocaml/issues/12073 *) - | Error (Sys_error s) -> + | Error (Sys_error _) -> (* temporary workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) - (s = "Permission denied" && Sys.win32 && path_is_a_dir fs old_path && path_is_an_empty_dir fs new_path) || + (Sys.win32 && path_is_a_dir fs old_path && path_is_an_empty_dir fs new_path) || (* temporary workaround for identity regression renaming under MingW *) - (s = "No such file or directory" && Sys.win32 && old_path = new_path && path_is_an_empty_dir fs new_path) || - (s = "No such file or directory" && - not (Model.mem fs old_path) || List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path)) || - ((s = "Invalid argument" || s = "Permission denied"(*Win32*)) && is_true_prefix old_path new_path) || - (s = "Not a directory" && - List.exists (path_is_a_file fs) (path_prefixes old_path) || - List.exists (path_is_a_file fs) (path_prefixes new_path) || - path_is_a_dir fs old_path && Model.mem fs new_path && not (path_is_a_dir fs new_path)) || - ((s = "Is a directory" || s = "Permission denied"(*Win32*)) && path_is_a_dir fs new_path) || - (s = "Directory not empty" && - is_true_prefix new_path old_path || (path_is_a_dir fs new_path && not (path_is_an_empty_dir fs new_path))) + (Sys.win32 && old_path = new_path && path_is_an_empty_dir fs new_path) || + (* general conditions *) + (not (Model.mem fs old_path)) || + is_true_prefix old_path new_path || (* parent-to-child *) + is_true_prefix new_path old_path || (* child-to-parent *) + (path_is_a_file fs old_path && path_is_a_dir fs new_path) || (* file-to-dir *) + (path_is_a_dir fs old_path && path_is_a_file fs new_path) || (* dir-to-file *) + (path_is_a_dir fs new_path && not (path_is_an_empty_dir fs new_path)) || (* to-non-empty-dir *) + List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path) (* malformed-target-path *) | Error _ -> false) | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> - let full_path = (path @ [new_dir_name]) in + let full_path = path @ [new_dir_name] in (match res with | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs full_path) - | Error (Sys_error s) -> - (match_msg s full_path "File exists" && Model.mem fs full_path) || - (match_msgs s full_path ["No such file or directory"; - "Invalid argument"] && not (Model.mem fs path)) || - (match_msgs s full_path ["Not a directory"; - "No such file or directory"(*win32*)] && not (path_is_a_dir fs full_path)) + | Error (Sys_error _) -> + Model.mem fs full_path || (not (Model.mem fs path)) || not (path_is_a_dir fs full_path) | Error _ -> false) | Rmdir (path, delete_dir_name), Res ((Result (Unit,Exn),_), res) -> - let full_path = (path @ [delete_dir_name]) in + let full_path = path @ [delete_dir_name] in (match res with | Ok () -> Model.mem fs full_path && path_is_a_dir fs full_path && path_is_an_empty_dir fs full_path - | Error (Sys_error s) -> - (match_msg s full_path "Directory not empty" && not (path_is_an_empty_dir fs full_path)) || - (match_msg s full_path "No such file or directory" && not (Model.mem fs full_path)) || - (match_msgs s full_path ["Not a directory"; - "Invalid argument"(*win32*)] && not (path_is_a_dir fs full_path)) + | Error (Sys_error _) -> + (not (Model.mem fs full_path)) || + (not (path_is_a_dir fs full_path)) || + (not (path_is_an_empty_dir fs full_path)) | Error _ -> false) | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with @@ -375,23 +358,15 @@ struct | Some l -> List.sort String.compare l = List.sort String.compare (Array.to_list array_of_subdir))) - | Error (Sys_error s) -> - (match_msg s path "No such file or directory" && not (Model.mem fs path)) || - (match_msgs s path ["Not a directory"; - "Invalid argument"(*win32*)] && not (path_is_a_dir fs path)) + | Error (Sys_error _) -> + (not (Model.mem fs path)) || (not (path_is_a_dir fs path)) | Error _ -> false) | Mkfile (path, new_file_name), Res ((Result (Unit,Exn),_),res) -> - let full_path = path @ [ new_file_name ] in + let full_path = path @ [new_file_name] in (match res with | Ok () -> path_is_a_dir fs path && not (Model.mem fs full_path) - | Error (Sys_error s) -> - (match_msgs s full_path ["File exists"; - "Permission denied"] && Model.mem fs full_path) || - (match_msgs s full_path ["No such file or directory"; - "Invalid argument"; - "Permission denied"] && not (Model.mem fs path)) || - (match_msgs s full_path ["Not a directory"; - "No such file or directory"] && not (path_is_a_dir fs path)) + | Error (Sys_error _) -> + Model.mem fs full_path || (not (Model.mem fs path)) || (not (path_is_a_dir fs path)) | Error _ -> false) | _,_ -> false end From 69f1545eca3db1ef4f5b19bc152ba2dc6f91c1e0 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Mon, 22 Apr 2024 13:52:59 +0200 Subject: [PATCH 21/29] Add and clean-up existing workarounds for MSVC/MinGW Sys issues --- src/sys/stm_tests.ml | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 67560138c..64b7ef39f 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -213,6 +213,8 @@ struct | _::_, [] -> false | n1::p1, n2::p2 -> n1=n2 && is_true_prefix p1 p2 + let ocaml_version = Sys.(ocaml_release.major,ocaml_release.minor) + let next_state c fs = match c with | File_exists _path -> fs @@ -226,17 +228,24 @@ struct else fs | Rename (old_path, new_path) -> if is_true_prefix old_path new_path - then fs + then (* workaround for parent-to-empty-child-dir *) + (if Sys.win32 && ocaml_version >= (5,1) && path_is_an_empty_dir fs new_path + then + (match Model.separate_path new_path with + | None -> fs + | Some (new_path_pref, new_name) -> + remove fs new_path_pref new_name) + else fs) else (match Model.find_opt fs old_path with | None -> fs | Some File -> if (not (Model.mem fs new_path) || path_is_a_file fs new_path) then Model.rename fs old_path new_path else fs | Some (Directory _) -> - (* temporary workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) - if Sys.win32 && path_is_an_empty_dir fs new_path then fs else - (* temporary workaround for dir-to-file https://github.com/ocaml/ocaml/issues/12073 *) - if (Sys.win32 && path_is_a_file fs new_path) then + (* workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) + if Sys.win32 && ocaml_version <= (5,0) && path_is_an_empty_dir fs new_path then fs else + (* workaround for dir-to-file https://github.com/ocaml/ocaml/issues/12073 *) + if Sys.win32 && ocaml_version <= (5,0) && path_is_a_file fs new_path then (match Model.separate_path new_path with | None -> fs | Some (new_path_pref, new_name) -> @@ -315,10 +324,10 @@ struct (match res with | Ok () -> Model.mem fs old_path (* permits dir-to-file MingW success https://github.com/ocaml/ocaml/issues/12073 *) | Error (Sys_error _) -> - (* temporary workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) - (Sys.win32 && path_is_a_dir fs old_path && path_is_an_empty_dir fs new_path) || - (* temporary workaround for identity regression renaming under MingW *) - (Sys.win32 && old_path = new_path && path_is_an_empty_dir fs new_path) || + (* workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) + (Sys.win32 && ocaml_version <= (5,0) && path_is_a_dir fs old_path && path_is_an_empty_dir fs new_path) || + (* workaround for identity regression renaming under MingW *) + (Sys.win32 && ocaml_version <= (5,0) && old_path = new_path && path_is_an_empty_dir fs new_path) || (* general conditions *) (not (Model.mem fs old_path)) || is_true_prefix old_path new_path || (* parent-to-child *) @@ -348,8 +357,8 @@ struct | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with | Ok array_of_subdir -> - (* Temporary work around for mingW, see https://github.com/ocaml/ocaml/issues/11829 *) - if Sys.win32 && not (Model.mem fs path) + (* workaround for non-existing readdir on MinGW https://github.com/ocaml/ocaml/issues/11829 *) + if Sys.win32 && ocaml_version <= (5,0) && not (Model.mem fs path) then array_of_subdir = [||] else (Model.mem fs path && path_is_a_dir fs path && From 6a839b520b72d64755cfacad2c8755e5bfdf8bad Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 15 May 2025 19:48:14 +0200 Subject: [PATCH 22/29] Remove attempt to test for sequential consistency - positively or negatively --- src/sys/stm_tests.ml | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 64b7ef39f..414d761cb 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -380,22 +380,11 @@ struct | _,_ -> false end -let run_cmd cmd = - let ic = Unix.open_process_in cmd in - let os = In_channel.input_line ic in - ignore (Unix.close_process_in ic); - os - -let uname_os () = run_cmd "uname -s" - module Sys_seq = STM_sequential.Make(SConf) module Sys_dom = STM_domain.Make(SConf) -;; -QCheck_base_runner.run_tests_main [ - Sys_seq.agree_test ~count:1000 ~name:"STM Sys test sequential"; - if Sys.unix && uname_os () = Some "Linux" - then Sys_dom.agree_test_par ~count:200 ~name:"STM Sys test parallel" - else Sys_dom.neg_agree_test_par ~count:2500 ~name:"STM Sys test parallel"; - Sys_dom.stress_test_par ~count:1000 ~name:"STM Sys stress test parallel"; +let _ = + QCheck_base_runner.run_tests_main [ + Sys_seq.agree_test ~count:1000 ~name:"STM Sys test sequential"; + Sys_dom.stress_test_par ~count:1000 ~name:"STM Sys stress test parallel"; ] From 4541585db1d550ac41c67bd44d585d85c0fef95d Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 15 May 2025 19:50:37 +0200 Subject: [PATCH 23/29] Fully qualify Model usages --- src/sys/stm_tests.ml | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 414d761cb..7d9120290 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -95,7 +95,6 @@ end module SConf = struct - include Model type path = string list type cmd = @@ -123,7 +122,7 @@ struct let show_cmd = Util.Pp.to_show pp_cmd - type state = filesys + type state = Model.filesys type sut = unit @@ -132,9 +131,9 @@ struct (* var gen_existing_path : filesys -> path Gen.t *) let rec gen_existing_path fs = match fs with - | File -> Gen.return [] - | Directory d -> - (match Map_names.bindings d.fs_map with + | Model.File -> Gen.return [] + | Model.Directory d -> + (match Model.Map_names.bindings d.fs_map with | [] -> Gen.return [] | bindings -> Gen.(oneofl bindings >>= fun (n, sub_fs) -> Gen.oneof [ @@ -145,9 +144,9 @@ struct (* var gen_existing_pair : filesys -> (path * string) option Gen.t *) let rec gen_existing_pair fs = match fs with - | File -> Gen.return None (*failwith "no sandbox directory"*) - | Directory d -> - (match Map_names.bindings d.fs_map with + | Model.File -> Gen.return None (*failwith "no sandbox directory"*) + | Model.Directory d -> + (match Model.Map_names.bindings d.fs_map with | [] -> Gen.return None | bindings -> Gen.(oneofl bindings >>= fun (n, sub_fs) -> @@ -234,7 +233,7 @@ struct (match Model.separate_path new_path with | None -> fs | Some (new_path_pref, new_name) -> - remove fs new_path_pref new_name) + Model.remove fs new_path_pref new_name) else fs) else (match Model.find_opt fs old_path with @@ -249,7 +248,7 @@ struct (match Model.separate_path new_path with | None -> fs | Some (new_path_pref, new_name) -> - let fs = remove fs new_path_pref new_name in + let fs = Model.remove fs new_path_pref new_name in Model.rename fs old_path new_path) else if (not (Model.mem fs new_path) || path_is_an_empty_dir fs new_path) then Model.rename fs old_path new_path else fs) @@ -299,7 +298,7 @@ struct | Mkfile (path, new_file_name) -> Res (result unit exn, protect mkfile (p path / new_file_name)) - let postcond c (fs: filesys) res = + let postcond c (fs: Model.filesys) res = match c, res with | File_exists path, Res ((Bool,_),b) -> b = Model.mem fs path From 6f30f1060cc7209bfcc17cfe08ce6fb66d3b3c29 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 15 May 2025 20:11:28 +0200 Subject: [PATCH 24/29] Focus on src/sys/stm_tests.exe, run 5 times --- dune | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/dune b/dune index 23c9304ff..b23414518 100644 --- a/dune +++ b/dune @@ -36,8 +36,8 @@ (name ci) (package multicoretests) (deps - (alias_rec %{env:DUNE_CI_ALIAS=testsuite}))) - ; (alias_rec focusedtest))) + ; (alias_rec %{env:DUNE_CI_ALIAS=testsuite}) + (alias_rec focusedtest))) ; @focusedtest ; repeat a single test a couple of times @@ -48,7 +48,7 @@ ; To change the test to repeat, change the source of the `copy`: (rule - (copy src/io/lin_tests_domain.exe focusedtest.exe)) + (copy src/sys/stm_tests.exe focusedtest.exe)) (rule (alias focusedtest) @@ -61,7 +61,7 @@ (write-file hoped "") (write-file failed-runs "") (bash - "for i in `seq 20`; do echo Starting $i-th run; if ! ./focusedtest.exe -v ; then echo $i >> failed-runs; fi; done") + "for i in `seq 5`; do echo Starting $i-th run; if ! ./focusedtest.exe -v ; then echo $i >> failed-runs; fi; done") ; edit the previous line to focus on a particular seed (diff failed-runs hoped))))) @@ -76,6 +76,6 @@ (write-file hoped "") (write-file failed-runs "") (run cmd /q /c - "for %G in (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20) do (echo Starting %G-th run && focusedtest.exe -v || echo %G >> failed-runs)") + "for %G in (1,2,3,4,5) do (echo Starting %G-th run && focusedtest.exe -v || echo %G >> failed-runs)") ; edit the previous line to focus on a particular seed (diff failed-runs hoped))))) From 46b7b81d1685727af795bce864252c49feef26bb Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Thu, 15 May 2025 21:02:28 +0200 Subject: [PATCH 25/29] Remove workarounds and add a note about it --- src/sys/stm_tests.ml | 50 ++++++++++++++------------------------------ 1 file changed, 16 insertions(+), 34 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 7d9120290..e57971094 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -212,8 +212,15 @@ struct | _::_, [] -> false | n1::p1, n2::p2 -> n1=n2 && is_true_prefix p1 p2 - let ocaml_version = Sys.(ocaml_release.major,ocaml_release.minor) - + (* Note: This model-based test has previously found a number of issues under MinGW/MSVC: + - non-existing readdir on MinGW https://github.com/ocaml/ocaml/issues/11829 (5.1) + - rename dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 (5.1) + - rename dir-to-file https://github.com/ocaml/ocaml/issues/12073 (5.1) + - rename empty-dir to itself (regression) https://github.com/ocaml/ocaml/issues/12317 (5.1) + - rename parent-to-empty-child-dir https://github.com/ocaml/ocaml/pull/13166 (5.3) + These issues have since been fixed and the test workarounds have therefore been removed again. + As a result this test may fail on MinGW/MSVC with OCaml 5.0-5.2. + *) let next_state c fs = match c with | File_exists _path -> fs @@ -227,30 +234,13 @@ struct else fs | Rename (old_path, new_path) -> if is_true_prefix old_path new_path - then (* workaround for parent-to-empty-child-dir *) - (if Sys.win32 && ocaml_version >= (5,1) && path_is_an_empty_dir fs new_path - then - (match Model.separate_path new_path with - | None -> fs - | Some (new_path_pref, new_name) -> - Model.remove fs new_path_pref new_name) - else fs) + then fs else (match Model.find_opt fs old_path with | None -> fs | Some File -> if (not (Model.mem fs new_path) || path_is_a_file fs new_path) then Model.rename fs old_path new_path else fs | Some (Directory _) -> - (* workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) - if Sys.win32 && ocaml_version <= (5,0) && path_is_an_empty_dir fs new_path then fs else - (* workaround for dir-to-file https://github.com/ocaml/ocaml/issues/12073 *) - if Sys.win32 && ocaml_version <= (5,0) && path_is_a_file fs new_path then - (match Model.separate_path new_path with - | None -> fs - | Some (new_path_pref, new_name) -> - let fs = Model.remove fs new_path_pref new_name in - Model.rename fs old_path new_path) - else if (not (Model.mem fs new_path) || path_is_an_empty_dir fs new_path) then Model.rename fs old_path new_path else fs) | Is_directory _path -> fs | Rmdir (path,delete_dir_name) -> @@ -323,10 +313,6 @@ struct (match res with | Ok () -> Model.mem fs old_path (* permits dir-to-file MingW success https://github.com/ocaml/ocaml/issues/12073 *) | Error (Sys_error _) -> - (* workaround for dir-to-empty-target-dir https://github.com/ocaml/ocaml/issues/12073 *) - (Sys.win32 && ocaml_version <= (5,0) && path_is_a_dir fs old_path && path_is_an_empty_dir fs new_path) || - (* workaround for identity regression renaming under MingW *) - (Sys.win32 && ocaml_version <= (5,0) && old_path = new_path && path_is_an_empty_dir fs new_path) || (* general conditions *) (not (Model.mem fs old_path)) || is_true_prefix old_path new_path || (* parent-to-child *) @@ -356,16 +342,12 @@ struct | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with | Ok array_of_subdir -> - (* workaround for non-existing readdir on MinGW https://github.com/ocaml/ocaml/issues/11829 *) - if Sys.win32 && ocaml_version <= (5,0) && not (Model.mem fs path) - then array_of_subdir = [||] - else - (Model.mem fs path && path_is_a_dir fs path && - (match Model.readdir fs path with - | None -> false - | Some l -> - List.sort String.compare l - = List.sort String.compare (Array.to_list array_of_subdir))) + Model.mem fs path && path_is_a_dir fs path && + (match Model.readdir fs path with + | None -> false + | Some l -> + List.sort String.compare l + = List.sort String.compare (Array.to_list array_of_subdir)) | Error (Sys_error _) -> (not (Model.mem fs path)) || (not (path_is_a_dir fs path)) | Error _ -> false) From d9f67c0b90dd3382c1e5554007261bfb4eff113b Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Mon, 19 May 2025 12:35:10 +0200 Subject: [PATCH 26/29] Refactor path_is_a_file and path_is_a_dir into Model --- src/sys/stm_tests.ml | 54 ++++++++++++++++++++++---------------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index e57971094..32b3c5199 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -91,6 +91,18 @@ struct | Some sub_fs -> let fs' = remove fs old_path_pref old_name in insert fs' new_path_pref new_name sub_fs)) + + let path_is_a_file fs path = + match find_opt fs path with + | None + | Some (Directory _) -> false + | Some File -> true + + let path_is_a_dir fs path = + match find_opt fs path with + | None + | Some File -> false + | Some (Directory _) -> true end module SConf = @@ -186,21 +198,9 @@ struct let init_state = Model.empty_dir - let path_is_a_dir fs path = - match Model.find_opt fs path with - | None - | Some File -> false - | Some (Directory _) -> true - let path_is_an_empty_dir fs path = Model.readdir fs path = Some [] - let path_is_a_file fs path = - match Model.find_opt fs path with - | None - | Some (Directory _) -> false - | Some File -> true - let rec path_prefixes path = match path with | [] -> [] | [_] -> [] @@ -239,7 +239,7 @@ struct (match Model.find_opt fs old_path with | None -> fs | Some File -> - if (not (Model.mem fs new_path) || path_is_a_file fs new_path) then Model.rename fs old_path new_path else fs + if (not (Model.mem fs new_path) || Model.path_is_a_file fs new_path) then Model.rename fs old_path new_path else fs | Some (Directory _) -> if (not (Model.mem fs new_path) || path_is_an_empty_dir fs new_path) then Model.rename fs old_path new_path else fs) | Is_directory _path -> fs @@ -304,9 +304,9 @@ struct | Remove (path, file_name), Res ((Result (Unit,Exn),_), res) -> let full_path = path @ [file_name] in (match res with - | Ok () -> Model.mem fs full_path && path_is_a_dir fs path && not (path_is_a_dir fs full_path) + | Ok () -> Model.mem fs full_path && Model.path_is_a_dir fs path && not (Model.path_is_a_dir fs full_path) | Error (Sys_error _) -> - (not (Model.mem fs full_path)) || path_is_a_dir fs full_path || not (path_is_a_dir fs path) + (not (Model.mem fs full_path)) || Model.path_is_a_dir fs full_path || not (Model.path_is_a_dir fs path) | Error _ -> false ) | Rename (old_path, new_path), Res ((Result (Unit,Exn),_), res) -> @@ -317,46 +317,46 @@ struct (not (Model.mem fs old_path)) || is_true_prefix old_path new_path || (* parent-to-child *) is_true_prefix new_path old_path || (* child-to-parent *) - (path_is_a_file fs old_path && path_is_a_dir fs new_path) || (* file-to-dir *) - (path_is_a_dir fs old_path && path_is_a_file fs new_path) || (* dir-to-file *) - (path_is_a_dir fs new_path && not (path_is_an_empty_dir fs new_path)) || (* to-non-empty-dir *) - List.exists (fun pref -> not (path_is_a_dir fs pref)) (path_prefixes new_path) (* malformed-target-path *) + (Model.path_is_a_file fs old_path && Model.path_is_a_dir fs new_path) || (* file-to-dir *) + (Model.path_is_a_dir fs old_path && Model.path_is_a_file fs new_path) || (* dir-to-file *) + (Model.path_is_a_dir fs new_path && not (path_is_an_empty_dir fs new_path)) || (* to-non-empty-dir *) + List.exists (fun pref -> not (Model.path_is_a_dir fs pref)) (path_prefixes new_path) (* malformed-target-path *) | Error _ -> false) | Mkdir (path, new_dir_name), Res ((Result (Unit,Exn),_), res) -> let full_path = path @ [new_dir_name] in (match res with - | Ok () -> Model.mem fs path && path_is_a_dir fs path && not (Model.mem fs full_path) + | Ok () -> Model.mem fs path && Model.path_is_a_dir fs path && not (Model.mem fs full_path) | Error (Sys_error _) -> - Model.mem fs full_path || (not (Model.mem fs path)) || not (path_is_a_dir fs full_path) + Model.mem fs full_path || (not (Model.mem fs path)) || not (Model.path_is_a_dir fs full_path) | Error _ -> false) | Rmdir (path, delete_dir_name), Res ((Result (Unit,Exn),_), res) -> let full_path = path @ [delete_dir_name] in (match res with | Ok () -> - Model.mem fs full_path && path_is_a_dir fs full_path && path_is_an_empty_dir fs full_path + Model.mem fs full_path && Model.path_is_a_dir fs full_path && path_is_an_empty_dir fs full_path | Error (Sys_error _) -> (not (Model.mem fs full_path)) || - (not (path_is_a_dir fs full_path)) || + (not (Model.path_is_a_dir fs full_path)) || (not (path_is_an_empty_dir fs full_path)) | Error _ -> false) | Readdir path, Res ((Result (Array String,Exn),_), res) -> (match res with | Ok array_of_subdir -> - Model.mem fs path && path_is_a_dir fs path && + Model.mem fs path && Model.path_is_a_dir fs path && (match Model.readdir fs path with | None -> false | Some l -> List.sort String.compare l = List.sort String.compare (Array.to_list array_of_subdir)) | Error (Sys_error _) -> - (not (Model.mem fs path)) || (not (path_is_a_dir fs path)) + (not (Model.mem fs path)) || (not (Model.path_is_a_dir fs path)) | Error _ -> false) | Mkfile (path, new_file_name), Res ((Result (Unit,Exn),_),res) -> let full_path = path @ [new_file_name] in (match res with - | Ok () -> path_is_a_dir fs path && not (Model.mem fs full_path) + | Ok () -> Model.path_is_a_dir fs path && not (Model.mem fs full_path) | Error (Sys_error _) -> - Model.mem fs full_path || (not (Model.mem fs path)) || (not (path_is_a_dir fs path)) + Model.mem fs full_path || (not (Model.mem fs path)) || (not (Model.path_is_a_dir fs path)) | Error _ -> false) | _,_ -> false end From 77d7365a29de9973d8fcea016e5ac60d93449cf2 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Mon, 19 May 2025 12:37:12 +0200 Subject: [PATCH 27/29] Rework generator based on stats --- src/sys/stm_tests.ml | 93 ++++++++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 47 deletions(-) diff --git a/src/sys/stm_tests.ml b/src/sys/stm_tests.ml index 32b3c5199..5e85f1348 100644 --- a/src/sys/stm_tests.ml +++ b/src/sys/stm_tests.ml @@ -140,58 +140,57 @@ struct let (/) = Filename.concat - (* var gen_existing_path : filesys -> path Gen.t *) - let rec gen_existing_path fs = + (* var existing_contents : filesys -> path list * path list *) + let rec existing_contents fs : path list * path list = match fs with - | Model.File -> Gen.return [] + | Model.File -> [[]],[] | Model.Directory d -> - (match Model.Map_names.bindings d.fs_map with - | [] -> Gen.return [] - | bindings -> Gen.(oneofl bindings >>= fun (n, sub_fs) -> - Gen.oneof [ - Gen.return [n]; - Gen.map (fun l -> n::l) (gen_existing_path sub_fs)] - ) - ) - - (* var gen_existing_pair : filesys -> (path * string) option Gen.t *) - let rec gen_existing_pair fs = match fs with - | Model.File -> Gen.return None (*failwith "no sandbox directory"*) - | Model.Directory d -> - (match Model.Map_names.bindings d.fs_map with - | [] -> Gen.return None - | bindings -> - Gen.(oneofl bindings >>= fun (n, sub_fs) -> - oneof [ - return (Some ([],n)); - map (function None -> Some ([],n) - | Some (path,name) -> Some (n::path,name)) (gen_existing_pair sub_fs)] - ) - ) - - let name_gen = Gen.oneofl ["aaa" ; "bbb" ; "ccc" ; "ddd" ; "eee"] - let path_gen s = Gen.(oneof [gen_existing_path s; list_size (int_bound 5) name_gen]) (* can be empty *) - let pair_gen s = - let fresh_pair_gen = Gen.(pair (list_size (int_bound 5) name_gen)) name_gen in - Gen.(oneof [ - fresh_pair_gen; - (gen_existing_pair s >>= function None -> fresh_pair_gen - | Some (p,_) -> map (fun n -> (p,n)) name_gen); - (gen_existing_pair s >>= function None -> fresh_pair_gen - | Some (p,n) -> return (p,n)); - ]) + let bindings = Model.Map_names.bindings d.fs_map in + let files, dirs = List.partition (fun p -> snd p = Model.File) bindings in + let sub_res = + List.map (fun (n,sub_fs) -> + let sub_files, sub_dirs = existing_contents sub_fs in + List.map (fun l -> n::l) sub_files, + List.map (fun l -> n::l) sub_dirs) dirs in + let files = List.map (fun (n,_) -> [n]) files in + List.concat (files :: List.map fst sub_res), + []::List.concat (List.map snd sub_res) + + let name_gen = Gen.oneofl ["aaa" ; "bbb" ; "ccc" ; "ddd" ; "eee"; "fff"; "ggg"; "hhh"; "iii"] let arb_cmd s = + let files, dirs = existing_contents s in + let gen_file = Gen.oneofl files in + let gen_file_sep = Gen.oneofl (List.filter_map Model.separate_path files) in + let gen_dir = Gen.oneofl dirs in + let gen_dir_sep = Gen.oneofl (List.filter_map Model.separate_path dirs) in + let gen_arb_path = Gen.(list_size (int_bound 5) name_gen) in + let gen_arb_path_sep = Gen.(pair (list_size (int_bound 4) name_gen) name_gen) in QCheck.make ~print:show_cmd - Gen.(oneof [ - map (fun path -> File_exists path) (path_gen s); - map (fun path -> Is_directory path) (path_gen s); - map (fun (path,new_dir_name) -> Remove (path, new_dir_name)) (pair_gen s); - map2 (fun old_path new_path -> Rename (old_path, new_path)) (path_gen s) (path_gen s); - map (fun (path,new_dir_name) -> Mkdir (path, new_dir_name)) (pair_gen s); - map (fun (path,delete_dir_name) -> Rmdir (path, delete_dir_name)) (pair_gen s); - map (fun path -> Readdir path) (path_gen s); - map (fun (path,new_file_name) -> Mkfile (path, new_file_name)) (pair_gen s); + Gen.( + if files = [] + then + oneof [ + map2 (fun path new_file_name -> Mkfile (path, new_file_name)) gen_dir name_gen; + map2 (fun path new_dir_name -> Mkdir (path, new_dir_name)) gen_dir name_gen; + ] + else + frequency [ + 1,map (fun path -> File_exists path) (frequency [8,gen_file; 1,gen_dir; 1,gen_arb_path]); + 1,map (fun path -> Is_directory path) (frequency [1,gen_file; 8,gen_dir; 1,gen_arb_path]); + 1,map (fun (path,file_name) -> Remove (path, file_name)) (if List.length dirs > 1 + then frequency [8,gen_file_sep; 1,gen_dir_sep; 1,gen_arb_path_sep] + else frequency [1,gen_file_sep; 1,gen_arb_path_sep]); + 1,map (fun (old_path,new_path) -> Rename (old_path, new_path)) (frequency [5,(pair gen_file gen_arb_path); + 5,(pair gen_dir gen_arb_path); + 1,(pair gen_arb_path gen_arb_path); + ]); + 3,map2 (fun path new_dir_name -> Mkdir (path, new_dir_name)) (frequency [1,gen_file; 8,gen_dir; 1,gen_arb_path]) name_gen; + 1,map (fun (path,dir_name) -> Rmdir (path, dir_name)) (if List.length dirs > 1 + then frequency [1,gen_file_sep; 8,gen_dir_sep; 1,gen_arb_path_sep] + else gen_arb_path_sep); + 1,map (fun path -> Readdir path) (frequency [1,gen_file; 8,gen_dir; 1,gen_arb_path]); + 3,map2 (fun path new_file_name -> Mkfile (path, new_file_name)) gen_dir name_gen; ]) let sandbox_root = "_sandbox" From 33b5d1fab69c57649cd647e0533d0b37ca690942 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Wed, 21 May 2025 15:52:53 +0200 Subject: [PATCH 28/29] REMOVE ME: rm gh-pages and opam workflows --- .github/workflows/gh-pages.yml | 42 --------------------------- .github/workflows/opam.yml | 52 ---------------------------------- 2 files changed, 94 deletions(-) delete mode 100644 .github/workflows/gh-pages.yml delete mode 100644 .github/workflows/opam.yml diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml deleted file mode 100644 index 2156be2f8..000000000 --- a/.github/workflows/gh-pages.yml +++ /dev/null @@ -1,42 +0,0 @@ -name: github pages - -on: - push: - branches: - - main # Set a branch name to trigger deployment - -jobs: - deploy: - runs-on: ubuntu-latest - steps: - - name: Checkout code - uses: actions/checkout@v4 - - - name: Cache opam - id: cache-opam - uses: actions/cache@v4 - with: - path: ~/.opam - key: opam-ubuntu-latest-5.0.0 - - - uses: avsm/setup-ocaml@v3 - with: - ocaml-compiler: 'ocaml-base-compiler.5.0.0' - default: https://github.com/ocaml/opam-repository.git - - - name: Pin packages - run: opam pin -n . - - - name: Install dependencies - run: opam install -d . --deps-only - - - name: Build - run: opam exec -- dune build @doc - - - name: Deploy - uses: peaceiris/actions-gh-pages@v4 - with: - github_token: ${{ secrets.GITHUB_TOKEN }} - publish_dir: ./_build/default/_doc/_html/ - destination_dir: dev - enable_jekyll: true diff --git a/.github/workflows/opam.yml b/.github/workflows/opam.yml deleted file mode 100644 index 37728bc31..000000000 --- a/.github/workflows/opam.yml +++ /dev/null @@ -1,52 +0,0 @@ -name: OPAM installation - -concurrency: - group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }} - cancel-in-progress: true - -on: - pull_request: - push: - branches: - - main - workflow_dispatch: - -jobs: - build-and-test: - env: - QCHECK_MSG_INTERVAL: '60' - - strategy: - fail-fast: false - matrix: - ocaml-compiler: - - 4.12.x - - 4.13.x - - 4.14.x - - 5.0.0 - - 5.1.0 - - 5.2.0 - - 5.3.0 - - ocaml-variants.5.4.0+trunk - - runs-on: ubuntu-latest - - steps: - - name: Checkout code - uses: actions/checkout@v4 - - - name: Install OCaml compiler - uses: ocaml/setup-ocaml@v3 - with: - ocaml-compiler: ${{ matrix.ocaml-compiler }} - - - name: Test installation of the OPAM packages - run: | - opam install --with-test ./qcheck-multicoretests-util.opam ./qcheck-lin.opam ./qcheck-stm.opam - - - name: Show configuration - run: | - opam exec -- ocamlc -config - opam config list - opam exec -- dune printenv - opam list --columns=name,installed-version,repository,synopsis-or-target From 6782a89a16e0bfd665a7286f957769707bd3a338 Mon Sep 17 00:00:00 2001 From: Jan Midtgaard Date: Fri, 23 May 2025 11:51:46 +0200 Subject: [PATCH 29/29] REMOVE ME: trigger workflow on push --- .github/workflows/cygwin-530-trunk.yml | 2 -- .github/workflows/cygwin-540-trunk.yml | 2 -- .github/workflows/cygwin-550-trunk.yml | 2 -- .github/workflows/linux-530-trunk-32bit.yml | 2 -- .github/workflows/linux-530-trunk-arm64.yml | 2 -- .github/workflows/linux-530-trunk-bytecode.yml | 2 -- .github/workflows/linux-530-trunk-debug.yml | 2 -- .github/workflows/linux-530-trunk-fp.yml | 2 -- .github/workflows/linux-530-trunk-musl.yml | 2 -- .github/workflows/linux-530-trunk.yml | 2 -- .github/workflows/linux-540-trunk-32bit.yml | 2 -- .github/workflows/linux-540-trunk-arm64.yml | 2 -- .github/workflows/linux-540-trunk-bytecode.yml | 2 -- .github/workflows/linux-540-trunk-debug.yml | 2 -- .github/workflows/linux-540-trunk-fp.yml | 2 -- .github/workflows/linux-540-trunk-musl.yml | 2 -- .github/workflows/linux-540-trunk.yml | 2 -- .github/workflows/linux-550-trunk-32bit.yml | 2 -- .github/workflows/linux-550-trunk-arm64.yml | 2 -- .github/workflows/linux-550-trunk-bytecode.yml | 2 -- .github/workflows/linux-550-trunk-debug.yml | 2 -- .github/workflows/linux-550-trunk-fp.yml | 2 -- .github/workflows/linux-550-trunk-musl.yml | 2 -- .github/workflows/linux-550-trunk.yml | 2 -- .github/workflows/macosx-arm64-530-trunk.yml | 2 -- .github/workflows/macosx-arm64-540-trunk.yml | 2 -- .github/workflows/macosx-arm64-550-trunk.yml | 2 -- .github/workflows/macosx-intel-530-trunk.yml | 2 -- .github/workflows/macosx-intel-540-trunk.yml | 2 -- .github/workflows/macosx-intel-550-trunk.yml | 2 -- .github/workflows/mingw-530-trunk-bytecode.yml | 2 -- .github/workflows/mingw-530-trunk.yml | 2 -- .github/workflows/mingw-540-trunk-bytecode.yml | 2 -- .github/workflows/mingw-540-trunk.yml | 2 -- .github/workflows/mingw-550-trunk-bytecode.yml | 2 -- .github/workflows/mingw-550-trunk.yml | 2 -- .github/workflows/msvc-530-trunk-bytecode.yml | 2 -- .github/workflows/msvc-530-trunk.yml | 2 -- .github/workflows/msvc-540-trunk-bytecode.yml | 2 -- .github/workflows/msvc-540-trunk.yml | 2 -- .github/workflows/msvc-550-trunk-bytecode.yml | 2 -- .github/workflows/msvc-550-trunk.yml | 2 -- 42 files changed, 84 deletions(-) diff --git a/.github/workflows/cygwin-530-trunk.yml b/.github/workflows/cygwin-530-trunk.yml index 9d39a3ba0..fd0ef0dd5 100644 --- a/.github/workflows/cygwin-530-trunk.yml +++ b/.github/workflows/cygwin-530-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/cygwin-540-trunk.yml b/.github/workflows/cygwin-540-trunk.yml index 021b36e7b..4c80dcb2d 100644 --- a/.github/workflows/cygwin-540-trunk.yml +++ b/.github/workflows/cygwin-540-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/cygwin-550-trunk.yml b/.github/workflows/cygwin-550-trunk.yml index 93e69c031..a068da025 100644 --- a/.github/workflows/cygwin-550-trunk.yml +++ b/.github/workflows/cygwin-550-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-530-trunk-32bit.yml b/.github/workflows/linux-530-trunk-32bit.yml index b5158862c..0f12e3fd8 100644 --- a/.github/workflows/linux-530-trunk-32bit.yml +++ b/.github/workflows/linux-530-trunk-32bit.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-530-trunk-arm64.yml b/.github/workflows/linux-530-trunk-arm64.yml index 21f97e858..f4f04312b 100644 --- a/.github/workflows/linux-530-trunk-arm64.yml +++ b/.github/workflows/linux-530-trunk-arm64.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-530-trunk-bytecode.yml b/.github/workflows/linux-530-trunk-bytecode.yml index 90c056683..b2281aaf8 100644 --- a/.github/workflows/linux-530-trunk-bytecode.yml +++ b/.github/workflows/linux-530-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-530-trunk-debug.yml b/.github/workflows/linux-530-trunk-debug.yml index 03728baa5..d8f408fda 100644 --- a/.github/workflows/linux-530-trunk-debug.yml +++ b/.github/workflows/linux-530-trunk-debug.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-530-trunk-fp.yml b/.github/workflows/linux-530-trunk-fp.yml index 3faf669c7..c0a8fffd5 100644 --- a/.github/workflows/linux-530-trunk-fp.yml +++ b/.github/workflows/linux-530-trunk-fp.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-530-trunk-musl.yml b/.github/workflows/linux-530-trunk-musl.yml index 43d279c8d..0ef4bf364 100644 --- a/.github/workflows/linux-530-trunk-musl.yml +++ b/.github/workflows/linux-530-trunk-musl.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-530-trunk.yml b/.github/workflows/linux-530-trunk.yml index 26f4820ac..d8fb68a9f 100644 --- a/.github/workflows/linux-530-trunk.yml +++ b/.github/workflows/linux-530-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-540-trunk-32bit.yml b/.github/workflows/linux-540-trunk-32bit.yml index 7830fceb0..da1c8540b 100644 --- a/.github/workflows/linux-540-trunk-32bit.yml +++ b/.github/workflows/linux-540-trunk-32bit.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-540-trunk-arm64.yml b/.github/workflows/linux-540-trunk-arm64.yml index e0d07c8aa..f6a8d5c0f 100644 --- a/.github/workflows/linux-540-trunk-arm64.yml +++ b/.github/workflows/linux-540-trunk-arm64.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-540-trunk-bytecode.yml b/.github/workflows/linux-540-trunk-bytecode.yml index 9c26e89ba..696594ef7 100644 --- a/.github/workflows/linux-540-trunk-bytecode.yml +++ b/.github/workflows/linux-540-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-540-trunk-debug.yml b/.github/workflows/linux-540-trunk-debug.yml index 6d1af659d..5bbc86d4f 100644 --- a/.github/workflows/linux-540-trunk-debug.yml +++ b/.github/workflows/linux-540-trunk-debug.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-540-trunk-fp.yml b/.github/workflows/linux-540-trunk-fp.yml index b02ca4c85..1cfc7f22b 100644 --- a/.github/workflows/linux-540-trunk-fp.yml +++ b/.github/workflows/linux-540-trunk-fp.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-540-trunk-musl.yml b/.github/workflows/linux-540-trunk-musl.yml index fede355de..ddcc661f1 100644 --- a/.github/workflows/linux-540-trunk-musl.yml +++ b/.github/workflows/linux-540-trunk-musl.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-540-trunk.yml b/.github/workflows/linux-540-trunk.yml index 355fb56c0..0228f6dbb 100644 --- a/.github/workflows/linux-540-trunk.yml +++ b/.github/workflows/linux-540-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-550-trunk-32bit.yml b/.github/workflows/linux-550-trunk-32bit.yml index 1606c1a44..aefd5dd79 100644 --- a/.github/workflows/linux-550-trunk-32bit.yml +++ b/.github/workflows/linux-550-trunk-32bit.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-550-trunk-arm64.yml b/.github/workflows/linux-550-trunk-arm64.yml index 7e3318c93..fd128fa25 100644 --- a/.github/workflows/linux-550-trunk-arm64.yml +++ b/.github/workflows/linux-550-trunk-arm64.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-550-trunk-bytecode.yml b/.github/workflows/linux-550-trunk-bytecode.yml index e7acbaab6..590ddaff7 100644 --- a/.github/workflows/linux-550-trunk-bytecode.yml +++ b/.github/workflows/linux-550-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-550-trunk-debug.yml b/.github/workflows/linux-550-trunk-debug.yml index dad6be936..72089560b 100644 --- a/.github/workflows/linux-550-trunk-debug.yml +++ b/.github/workflows/linux-550-trunk-debug.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-550-trunk-fp.yml b/.github/workflows/linux-550-trunk-fp.yml index af52b1a72..38d0165fe 100644 --- a/.github/workflows/linux-550-trunk-fp.yml +++ b/.github/workflows/linux-550-trunk-fp.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-550-trunk-musl.yml b/.github/workflows/linux-550-trunk-musl.yml index 3476c96fd..f7b89346a 100644 --- a/.github/workflows/linux-550-trunk-musl.yml +++ b/.github/workflows/linux-550-trunk-musl.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/linux-550-trunk.yml b/.github/workflows/linux-550-trunk.yml index 6e86621cd..e4dec40f3 100644 --- a/.github/workflows/linux-550-trunk.yml +++ b/.github/workflows/linux-550-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/macosx-arm64-530-trunk.yml b/.github/workflows/macosx-arm64-530-trunk.yml index 86f466f01..cb69cf0c6 100644 --- a/.github/workflows/macosx-arm64-530-trunk.yml +++ b/.github/workflows/macosx-arm64-530-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/macosx-arm64-540-trunk.yml b/.github/workflows/macosx-arm64-540-trunk.yml index d3c958a47..b9b01c315 100644 --- a/.github/workflows/macosx-arm64-540-trunk.yml +++ b/.github/workflows/macosx-arm64-540-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/macosx-arm64-550-trunk.yml b/.github/workflows/macosx-arm64-550-trunk.yml index f32cc6c87..639bf356c 100644 --- a/.github/workflows/macosx-arm64-550-trunk.yml +++ b/.github/workflows/macosx-arm64-550-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/macosx-intel-530-trunk.yml b/.github/workflows/macosx-intel-530-trunk.yml index 8ae97bb56..01e93ffcd 100644 --- a/.github/workflows/macosx-intel-530-trunk.yml +++ b/.github/workflows/macosx-intel-530-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/macosx-intel-540-trunk.yml b/.github/workflows/macosx-intel-540-trunk.yml index dc1c274dd..9213505ce 100644 --- a/.github/workflows/macosx-intel-540-trunk.yml +++ b/.github/workflows/macosx-intel-540-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/macosx-intel-550-trunk.yml b/.github/workflows/macosx-intel-550-trunk.yml index 4fa11811e..4a8ad2ca8 100644 --- a/.github/workflows/macosx-intel-550-trunk.yml +++ b/.github/workflows/macosx-intel-550-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/mingw-530-trunk-bytecode.yml b/.github/workflows/mingw-530-trunk-bytecode.yml index 753e21ca6..fffa0694a 100644 --- a/.github/workflows/mingw-530-trunk-bytecode.yml +++ b/.github/workflows/mingw-530-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/mingw-530-trunk.yml b/.github/workflows/mingw-530-trunk.yml index bc3e675ff..0153b6741 100644 --- a/.github/workflows/mingw-530-trunk.yml +++ b/.github/workflows/mingw-530-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/mingw-540-trunk-bytecode.yml b/.github/workflows/mingw-540-trunk-bytecode.yml index 283fac45a..0e4d5d804 100644 --- a/.github/workflows/mingw-540-trunk-bytecode.yml +++ b/.github/workflows/mingw-540-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/mingw-540-trunk.yml b/.github/workflows/mingw-540-trunk.yml index e4df53a15..65b3d69e9 100644 --- a/.github/workflows/mingw-540-trunk.yml +++ b/.github/workflows/mingw-540-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/mingw-550-trunk-bytecode.yml b/.github/workflows/mingw-550-trunk-bytecode.yml index bbcb09899..9249bffcd 100644 --- a/.github/workflows/mingw-550-trunk-bytecode.yml +++ b/.github/workflows/mingw-550-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/mingw-550-trunk.yml b/.github/workflows/mingw-550-trunk.yml index 0e4fe3ee1..81dabbe23 100644 --- a/.github/workflows/mingw-550-trunk.yml +++ b/.github/workflows/mingw-550-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/msvc-530-trunk-bytecode.yml b/.github/workflows/msvc-530-trunk-bytecode.yml index e0d57dc27..62fddcb18 100644 --- a/.github/workflows/msvc-530-trunk-bytecode.yml +++ b/.github/workflows/msvc-530-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/msvc-530-trunk.yml b/.github/workflows/msvc-530-trunk.yml index c599ee866..aecd19f93 100644 --- a/.github/workflows/msvc-530-trunk.yml +++ b/.github/workflows/msvc-530-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '22 2 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/msvc-540-trunk-bytecode.yml b/.github/workflows/msvc-540-trunk-bytecode.yml index 23535e3e0..043708079 100644 --- a/.github/workflows/msvc-540-trunk-bytecode.yml +++ b/.github/workflows/msvc-540-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/msvc-540-trunk.yml b/.github/workflows/msvc-540-trunk.yml index c190f6240..ce0ad8737 100644 --- a/.github/workflows/msvc-540-trunk.yml +++ b/.github/workflows/msvc-540-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '33 3 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/msvc-550-trunk-bytecode.yml b/.github/workflows/msvc-550-trunk-bytecode.yml index 2e0651853..70b95ab07 100644 --- a/.github/workflows/msvc-550-trunk-bytecode.yml +++ b/.github/workflows/msvc-550-trunk-bytecode.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: diff --git a/.github/workflows/msvc-550-trunk.yml b/.github/workflows/msvc-550-trunk.yml index a8307af86..17baa3b46 100644 --- a/.github/workflows/msvc-550-trunk.yml +++ b/.github/workflows/msvc-550-trunk.yml @@ -6,8 +6,6 @@ on: - cron: '44 4 * * 1' pull_request: push: - branches: - - main workflow_dispatch: jobs: