features.ml (2636B)
1 (* Unison file synchronizer: src/features.ml *) 2 (* Copyright 2021, Tõivo Leedjärv 3 4 This program is free software: you can redistribute it and/or modify 5 it under the terms of the GNU General Public License as published by 6 the Free Software Foundation, either version 3 of the License, or 7 (at your option) any later version. 8 9 This program is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 GNU General Public License for more details. 13 14 You should have received a copy of the GNU General Public License 15 along with this program. If not, see <http://www.gnu.org/licenses/>. 16 *) 17 18 type id = string 19 20 type t = { mutable enabled : bool; 21 arcFormatChange : bool; 22 validator : (id list -> bool -> string option) option } 23 24 let allFeatures = Hashtbl.create 8 25 let allNames = ref [] 26 27 let all () = !allNames 28 29 let mem = List.mem 30 31 let empty = [] 32 33 let changingArchiveFormat () = 34 let enabledArch name t accu = 35 if t.enabled && t.arcFormatChange then name :: accu else accu 36 in 37 Hashtbl.fold enabledArch allFeatures [] 38 39 let inter a b = List.filter (fun name -> mem name a) b 40 41 let getEnabled () = 42 let enabled name t accu = if t.enabled then name :: accu else accu in 43 Hashtbl.fold enabled allFeatures [] 44 45 let setEnabled features = 46 Hashtbl.iter (fun name t -> t.enabled <- mem name features) allFeatures 47 48 let resetEnabled () = setEnabled empty 49 50 (***************) 51 52 let validate features = 53 let aux name t = 54 let failed = match t.validator with 55 | Some fn -> fn features (mem name features) 56 | None -> None 57 in 58 match failed with 59 | None -> () 60 | Some e -> 61 raise (Util.Fatal 62 ("Client and server are incompatible. Setting up feature \"" 63 ^ name ^ "\" failed with error\n\"" ^ e ^ "\".\n\n" 64 ^ "It may be possible to rectify this by changing the user " 65 ^ "preferences.\nUltimately, it may require upgrading either " 66 ^ "the server or the client.")) 67 in 68 Hashtbl.iter aux allFeatures 69 70 let validateEnabled () = validate (getEnabled ()) 71 72 (***************) 73 74 let enabled feature = feature.enabled 75 76 let dummy = { enabled = false; arcFormatChange = false; validator = None } 77 78 let register name ?(arcFormatChange = false) validatefn = 79 if Hashtbl.mem allFeatures name then 80 raise (Util.Fatal ("Feature " ^ name ^ " registered twice")); 81 let v = { enabled = false; arcFormatChange; validator = validatefn } in 82 Hashtbl.add allFeatures name v; 83 allNames := name :: !allNames; 84 v 85