negotiate.ml (2867B)
1 (* Unison file synchronizer: src/negotiate.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 let (>>=) = Lwt.bind 19 20 let debug = Util.debug "features" 21 22 let debugFeatures name features = 23 debug (fun () -> 24 Util.msg "%s:\n" name; 25 Safelist.iter (fun n -> Util.msg " - %s\n" n) features) 26 27 let getCommonFeaturesLocal (root, features) = 28 Features.resetEnabled (); 29 let supportedFeatures = Features.all () in 30 debugFeatures "Supported features" supportedFeatures; 31 debugFeatures "Received features for feature negotiation" features; 32 let common = Features.inter features supportedFeatures in 33 debugFeatures "Selected common features" common; 34 try 35 let () = Features.validate common in 36 let () = Features.setEnabled common in 37 Lwt.return common 38 with 39 | e -> Lwt.fail e 40 41 let m = Umarshal.(list string) 42 43 let negotiateFeaturesRpcName = "negotiateFeatures" 44 let getCommonFeaturesRemote = 45 Remote.registerRootCmd negotiateFeaturesRpcName m m getCommonFeaturesLocal 46 47 let getCommonFeaturesOnRoot features = function 48 | (Common.Local, _) -> Lwt.return features 49 | root -> getCommonFeaturesRemote root features 50 51 let commonFeatures root fts = 52 getCommonFeaturesOnRoot fts root >>= fun common -> 53 let rn = "Common features for root " ^ Common.root2string root in 54 debugFeatures rn common; 55 try 56 let () = Features.validate common in 57 Lwt.return common 58 with 59 | e -> Lwt.fail e 60 61 let allRootsSupportFeatures roots = 62 let aux k r = 63 let supp = Remote.commandAvailable r negotiateFeaturesRpcName in 64 k >>= fun k' -> 65 supp >>= fun supp' -> 66 Lwt.return (k' && supp') 67 in 68 Safelist.fold_left aux (Lwt.return true) roots 69 70 let features roots = 71 Features.resetEnabled (); 72 let supportedFeatures = Features.all () in 73 debugFeatures "Supported features" supportedFeatures; 74 allRootsSupportFeatures roots >>= (fun supported -> 75 if not supported then begin 76 debug (fun () -> Util.msg "The server does not support \"features\".\n"); 77 Lwt.return (Features.empty) 78 end else 79 Safelist.fold_left (fun fts r -> fts >>= commonFeatures r) 80 (Lwt.return supportedFeatures) roots 81 ) >>= fun common -> 82 debugFeatures "Enabled features" common; 83 Lwt.return (Features.setEnabled common) 84