1
(* This file is part of marionnet
2
Copyright (C) 2010 Jean-Vincent Loddo
3
Copyright (C) 2010 Université Paris 13
5
This program is free software: you can redistribute it and/or modify
6
it under the terms of the GNU General Public License as published by
7
the Free Software Foundation, either version 2 of the License, or
8
(at your option) any later version.
10
This program is distributed in the hope that it will be useful,
11
but WITHOUT ANY WARRANTY; without even the implied warranty of
12
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13
GNU General Public License for more details.
15
You should have received a copy of the GNU General Public License
16
along with this program. If not, see <http://www.gnu.org/licenses/>. *)
20
(* `epithet' is almost a phantom type (almost because it is not abstract): *)
21
type 'a epithet = string
23
type filename = string
25
type realpath = string
27
let string_of_epithet_kind =
29
| `distrib -> "distribution"
30
| `variant -> "variant"
34
class terminal_manager () =
35
let hostxserver_name = "X HOST" in
36
let xnest_name = "X NEST" in
37
let nox_name = "No X" in
39
method get_choice_list =
40
[ hostxserver_name; xnest_name; nox_name ]
42
method get_default = hostxserver_name
43
method is_valid_choice x = List.mem x self#get_choice_list
44
method is_hostxserver = ((=)hostxserver_name)
45
method is_xnest = ((=)xnest_name)
46
method is_nox = ((=)nox_name)
49
(** Read the given directory searching for names like [~prefix ^ "xxxxx"];
50
return the list of epithets ["xxxxx"]. *)
51
let read_epithet_list ~prefix ~dir =
52
let prefix_length = String.length prefix in
53
let remove_prefix s = String.sub s prefix_length ((String.length s) - prefix_length) in
54
let name_filter file_name =
55
((String.length file_name) > prefix_length) &&
56
((String.sub file_name 0 prefix_length) = prefix)
59
SysExtra.readdir_as_list
60
~only_not_directories:()
62
~name_converter:remove_prefix
64
Log.printf ~v:2 "Searching in %s:\n" dir;
65
List.iter (fun x -> Log.printf ~v:2 " - found %s%s\n" prefix x) xs;
69
let machine_prefix = "machine-"
70
let router_prefix = "router-"
71
let kernel_prefix = "linux-"
73
let root_filesystem_searching_list = [
74
Initialization.Path.filesystems;
77
let user_filesystem_searching_list = [
78
Initialization.Path.user_filesystems;
81
(* In the order of priority: *)
82
let kernel_searching_list = [
83
Initialization.Path.user_kernels;
84
Initialization.Path.kernels;
87
module String_map = MapExtra.String_map
89
(* For a given choice the last binding with a directory will wins building the mapping.
90
So we reverse the searching list: *)
91
let make_epithet_to_dir_mapping ~kind ?realpath ~prefix ~directory_searching_list () =
92
Log.printf "Searching for a (%s) prefix: \"%s\"\n" (string_of_epithet_kind kind) prefix;
93
let normalize_dir = match realpath with
94
| None -> (fun x -> Some x)
95
| Some () -> (fun x -> UnixExtra.realpath x)
97
let searching_list = List.rev directory_searching_list in
101
let epithet_list = read_epithet_list ~prefix ~dir in
102
List.map (fun x -> (x, (normalize_dir dir))) epithet_list
106
let yss = List.flatten xss in
107
let yss = List.filter (fun (e,d)->d<>None) yss in
108
let yss = List.map (function (e, Some dir)->(e,dir) | _ -> assert false) yss in
109
(List.iter (function (e,d) -> Log.printf "* %s -> %s\n" e d) yss);
110
String_map.of_list yss
113
(** epithet -> (variant list) * dir *)
114
let make_epithet_to_variant_list_and_dir_mapping ~prefix ~epithet_to_dir_mapping =
117
let dir = Printf.sprintf "%s/%s%s_variants" dir prefix epithet in
118
((read_epithet_list ~prefix:"" ~dir), dir)
120
epithet_to_dir_mapping
123
class type ['a] epithet_manager_object =
125
(* Constructor's arguments: *)
126
method directory_searching_list : dirname list
127
method prefix : string (* "machine-", "router-", "kernel-", "" (nothing for variants) *)
128
(* Public interface: *)
129
method get_epithet_list : 'a epithet list
130
method get_default_epithet : 'a epithet option
131
method epithet_exists : 'a epithet -> bool
132
method realpath_of_epithet : 'a epithet -> realpath
133
method resolve_epithet_symlink : 'a epithet -> 'a epithet
134
(* Morally private methods: *)
135
method epithets_of_filename : ?no_symlinks:unit -> filename -> ('a epithet) list
136
method epithets_sharing_the_same_realpath_of : ?no_symlinks:unit -> ('a epithet) -> ('a epithet) list
137
method filename_of_epithet : ('a epithet) -> filename
138
method realpath_exists : string -> bool
139
method filter : ('a epithet -> bool) -> unit
143
class ['a] epithet_manager
144
: ?default_epithet:('a epithet) ->
145
?filter:('a epithet->bool) ->
146
kind: [> `distrib | `kernel | `variant ] ->
147
directory_searching_list:string list ->
149
unit -> ['a] epithet_manager_object
152
?(default_epithet="default")
155
~directory_searching_list
156
~prefix (* "machine-", "router-", "linux-", "" (for variants), ... *)
159
let epithet_to_dir_mapping =
160
make_epithet_to_dir_mapping ~kind ~realpath:() ~prefix ~directory_searching_list ()
162
(* Filter the list if required with the optional parameter `filter': *)
163
let epithet_to_dir_mapping =
165
| None -> epithet_to_dir_mapping
166
| Some f -> String_map.filter (fun epth _dir -> f epth) epithet_to_dir_mapping
170
(* The version stored in the object is the destructive (non-persistent)
171
version of the same mapping: *)
172
val mutable epithet_to_dir_mapping = epithet_to_dir_mapping
174
(* Destructive filter application: *)
176
epithet_to_dir_mapping <- String_map.filter (fun epth _dir -> f epth) (epithet_to_dir_mapping)
178
method directory_searching_list = directory_searching_list
179
method prefix = prefix
181
method get_epithet_list : 'a epithet list =
182
String_map.domain epithet_to_dir_mapping
184
method epithet_exists (epithet:'a epithet) : bool =
185
String_map.mem epithet epithet_to_dir_mapping
187
method (*private*) filename_of_epithet (epithet:'a epithet) =
188
let dir = String_map.find epithet epithet_to_dir_mapping in
189
(Printf.sprintf "%s/%s%s" dir prefix epithet)
191
method realpath_of_epithet (epithet:'a epithet) : realpath =
192
let filename = (self#filename_of_epithet epithet) in
193
match (UnixExtra.realpath filename) with
197
method (*private*) epithets_of_filename ?no_symlinks (filename:string) : ('a epithet) list =
198
let realpath = Option.extract (UnixExtra.realpath filename) in
199
let pred = match no_symlinks with
200
| None -> (fun e -> (self#realpath_of_epithet e) = realpath)
203
(not (UnixExtra.is_symlink (self#filename_of_epithet e))) &&
204
((self#realpath_of_epithet e) = realpath))
206
(List.filter pred self#get_epithet_list)
208
(* [machine-]default -> [machine-]debian-51426 *)
209
method resolve_epithet_symlink (epithet:'a epithet) : 'a epithet =
210
let filename = self#filename_of_epithet epithet in
211
match UnixExtra.is_symlink filename with
214
(match (self#epithets_of_filename ~no_symlinks:() filename) with
216
| epithet'::_ -> epithet' (* we get the first *)
219
method epithets_sharing_the_same_realpath_of ?(no_symlinks:unit option) (epithet:'a epithet) : ('a epithet) list =
220
let filename = self#filename_of_epithet epithet in
221
self#epithets_of_filename ?no_symlinks filename
223
method realpath_exists filename =
224
let xs = List.map (self#filename_of_epithet) self#get_epithet_list in
227
(* When a machine is created, we call this method to set a default epithet.*)
228
method get_default_epithet : 'a epithet option =
229
if self#epithet_exists default_epithet then (Some default_epithet) else
230
let xs = self#get_epithet_list in
233
| x::_ -> Some x (* We get the first as default... *)
235
end (* class epithet_manager *)
237
let get_and_parse_SUPPORTED_KERNELS (t : Configuration_files.t) : string -> (unit, string option) Either.t =
238
let x = Configuration_files.get_string_list_variable "SUPPORTED_KERNELS" t in
239
let brackets = (Str.regexp "^\\[\\(.*\\)\\]$") in
240
let slashes = (Str.regexp "^/\\(.*\\)/$") in
242
let (_,_,groups) = Option.extract result in
245
let rec loop acc = function
246
| [] -> (List.rev acc)
247
| x::xs when (StrExtra.First.matchingp brackets x) ->
248
let brackets_content = extract (StrExtra.First.matching brackets x) in
249
loop ((`Brackets brackets_content)::acc) xs
250
| x::xs when (StrExtra.First.matchingp slashes x) ->
251
let slashes_content = extract (StrExtra.First.matching slashes x) in
252
loop ((`Slashes slashes_content)::acc) xs
254
loop ((`AString x)::acc) xs
256
let token_list : ([`Brackets of string | `Slashes of string | `AString of string] list) option =
257
Option.map (loop []) x
259
let rec collapse_AString acc = function
261
| (`AString x)::(`AString y)::zs -> collapse_AString acc ((`AString (String.concat " " [x;y]))::zs)
262
| x::ys -> collapse_AString (x::acc) ys
264
let token_list = Option.map (collapse_AString []) token_list in
265
let rec parse acc = function
267
| (`Brackets x)::(`AString y)::zs -> parse (((`kernel_epithet x), Some y)::acc) zs
268
| (`Brackets x)::zs -> parse (((`kernel_epithet x), None)::acc) zs
269
| (`Slashes x)::(`AString y)::zs -> parse (((`kernel_regexpr (Str.regexp x)), Some y)::acc) zs
270
| (`Slashes x)::zs -> parse (((`kernel_regexpr (Str.regexp x)), None)::acc) zs
272
let msg = Printf.sprintf "Parsing variable SUPPORTED_KERNELS: unexpected string `%s'" x in
276
: ([> `kernel_epithet of string | `kernel_regexpr of Str.regexp ] * string option) list option
277
= Option.map (parse []) token_list
279
let parsing_result_as_predicate_list : ((string -> bool) * string option) list option =
280
let epithet_predicate_of = function
281
| `kernel_epithet x -> ((=)x)
282
| `kernel_regexpr r -> (StrExtra.First.matchingp r)
284
Option.map (List.map (fun (k,so) -> ((epithet_predicate_of k),so))) parsing_result
287
match parsing_result_as_predicate_list with
288
| None -> Either.Right (None) (* The epithet is ok, without special console options *)
289
| Some pred_so_list ->
291
match (ListExtra.search (fun (pred,so) -> pred epithet) pred_so_list) with
292
| None -> Either.Left () (* The epithet will be not accepted *)
293
| Some (_,options) -> Either.Right (options) (* The epithet is ok, may be with options *)
295
(* end of get_and_parse_SUPPORTED_KERNELS() *)
297
class virtual_machine_installations
298
?(user_filesystem_searching_list = user_filesystem_searching_list)
299
?(root_filesystem_searching_list = root_filesystem_searching_list)
300
?(kernel_searching_list=kernel_searching_list)
301
?(kernel_prefix = kernel_prefix)
302
?(kernel_default_epithet:[`kernel] epithet option)
303
?(filesystem_default_epithet:[`distrib] epithet option)
304
~prefix (* "machine-", "router-", ... *)
306
(* The actual filesystem searching list is the merge of user (prioritary)
308
let filesystem_searching_list =
309
List.append user_filesystem_searching_list root_filesystem_searching_list
311
let filter_exclude_names_ending_with_dot_conf x =
312
not (StrExtra.First.matchingp (Str.regexp "[.]conf[~]?$") x)
314
(* The manager of all filesystem epithets: *)
315
let filesystems : [`distrib] epithet_manager =
317
~filter:filter_exclude_names_ending_with_dot_conf
320
~directory_searching_list:filesystem_searching_list
321
?default_epithet:filesystem_default_epithet
324
(* The manager of all kernel epithets: *)
325
let kernels : [`kernel] epithet_manager =
327
~filter:filter_exclude_names_ending_with_dot_conf
329
~prefix:kernel_prefix
330
~directory_searching_list:kernel_searching_list
331
?default_epithet:kernel_default_epithet
334
(* The kit of managers (one per filesystem epithet) for variant epithets.
335
This mapping is created from `filesystems#get_epithet_list' *)
336
let filesystem_variants_mapping =
337
let epithet_manager_of filesystem_epithet : [`variant] epithet_manager =
339
let directory_searching_list_of e =
341
(fun dir -> Printf.sprintf "%s/%s%s_variants" dir prefix e)
342
filesystem_searching_list
344
let directory_searching_list =
345
let epithets = filesystems#epithets_sharing_the_same_realpath_of filesystem_epithet in
346
let epithets = ListExtra.lift_to_the_top_positions ((=)filesystem_epithet) epithets in
347
List.flatten (List.map directory_searching_list_of epithets)
352
~directory_searching_list
356
let assoc_list : ([`distrib] epithet * [`variant] epithet_manager) list =
357
List.map (fun e -> (e,epithet_manager_of e)) filesystems#get_epithet_list
359
String_map.of_list assoc_list
361
(* Now we build the mapping filesystem-epithet -> Configuration_files.t option *)
362
let filesystem_config_mapping =
364
fun filesystem_epithet ->
365
let filename = filesystems#filename_of_epithet (filesystem_epithet) in
366
let config_file = Printf.sprintf "%s.conf" (filename) in
368
match Sys.file_exists (config_file) with
371
let () = Log.printf "configuration file found for \"%s\"\n" filesystem_epithet in
373
Configuration_files.make
374
~dont_read_environment:()
375
~file_names:[config_file]
376
~variables:[ "MD5SUM"; "AUTHOR"; "DATE"; "MTIME"; "SUPPORTED_KERNELS"; "X11_SUPPORT"; ]
384
String_map.of_list (List.map (fun e -> (e, mill e)) filesystems#get_epithet_list)
386
(* Now the mapping filesystem-epithet -> [(kernel1, console-options1); (kernel2, console-options2);...] option *)
387
let filesystem_kernels_mapping =
389
fun filesystem_epithet ->
390
let config = String_map.find (filesystem_epithet) (filesystem_config_mapping) in
394
let filter : [`kernel] epithet -> (unit, string option) Either.t =
395
get_and_parse_SUPPORTED_KERNELS config_t
397
let ks = kernels#get_epithet_list in
398
let ks = List.map (fun k -> (k, filter k)) ks in
399
let ks = List.filter (fun (k,r) -> r <> Either.Left ()) ks in
400
let ks = List.map (fun (k,r) -> (k, Either.extract r)) ks in
402
Log.printf "Selected kernels for \"%s\": [%s]\n"
404
(String.concat " " (List.map fst ks))
408
let () = Log.printf "%s => \"%s\" config file ignored!\n" msg filesystem_epithet in
411
String_map.of_list (List.map (fun e -> (e, mill e)) filesystems#get_epithet_list)
413
(* The manager for terminal (X support): *)
414
let terminal_manager =
415
new terminal_manager ()
418
method filesystem_searching_list = filesystem_searching_list
419
method kernel_searching_list = kernel_searching_list
420
method kernel_prefix = kernel_prefix
421
method prefix = prefix
423
method filesystems = filesystems
424
method kernels = kernels
426
method variants_of filesystem_epithet =
427
String_map.find (filesystem_epithet) (filesystem_variants_mapping)
429
(* Here, if we replace the first two lines of the following definition by:
431
method supported_kernels_of (filesystem_epithet:[`distrib] epithet) : ([`kernel] epithet * (string option)) list =
433
we obtain an error message about the method's type:
434
[ `distrib ] epithet -> ('c epithet * string option) list where 'c is unbound *)
435
method supported_kernels_of : [`distrib] epithet -> ([`kernel] epithet * (string option)) list =
436
fun filesystem_epithet ->
437
match String_map.find (filesystem_epithet) (filesystem_kernels_mapping) with
438
| None -> List.map (fun k -> (k,None)) kernels#get_epithet_list
441
(* Do not propose any filesystems which haven't at least one compatible installed kernel: *)
444
(fun e -> (self#supported_kernels_of e)<>[])
446
method get_kernel_console_arguments : [`distrib] epithet -> [`kernel] epithet -> string option =
447
fun filesystem_epithet kernel_epithet ->
449
let ks = self#supported_kernels_of (filesystem_epithet) in
450
List.assoc (kernel_epithet) ks
454
"Disk.virtual_machine_installations#get_kernel_console_arguments: couple (%s,%s) unknown!\n"
455
(filesystem_epithet) (kernel_epithet)
458
(** Terminal choices to handle uml machines.
459
The list doesn't depend on the choosen distribution (in this version): *)
460
method terminal_manager_of (_: [`distrib] epithet) = terminal_manager
462
method root_export_dirname epithet =
463
let root_dir = List.hd root_filesystem_searching_list in
464
(Printf.sprintf "%s/%s%s_variants" root_dir prefix epithet)
466
method user_export_dirname epithet =
467
let user_dir = List.hd user_filesystem_searching_list in
468
(Printf.sprintf "%s/%s%s_variants" user_dir prefix epithet)
470
method check_filesystems_MTIME_consistency () =
472
fun filesystem_epithet ->
473
let config = String_map.find (filesystem_epithet) (filesystem_config_mapping) in
474
if config = None then () else (* continue: *)
475
let mtime = Configuration_files.get_int_variable "MTIME" (Option.extract config) in
477
(fun expected_mtime ->
478
let realpath = filesystems#realpath_of_epithet (filesystem_epithet) in
480
int_of_float ((Unix.stat realpath).Unix.st_mtime)
482
if actual_mtime = expected_mtime then () else (* warning: *)
483
let title = (s_ "Modification time (MTIME) inconsistency") in
486
(f_ "The filesystem `%s%s' has the mtime %d, but the expected value was %d.\nPlease run the command:\n\n<tt><small>sudo touch -d @%d %s</small></tt>\n\nin order to fix this inconsistency. Otherwise, machines or routers with this filesystem defined in a project created elsewhere can not be restarted.")
487
(prefix) (filesystem_epithet) (actual_mtime) (expected_mtime) (expected_mtime) (realpath)
489
Simple_dialogs.warning title message ())
492
List.iter (check) filesystems#get_epithet_list
496
let get_router_installations
497
?(user_filesystem_searching_list = user_filesystem_searching_list)
498
?(root_filesystem_searching_list = root_filesystem_searching_list)
499
?(kernel_searching_list=kernel_searching_list)
500
?(kernel_prefix = kernel_prefix)
501
?(kernel_default_epithet=Initialization.router_kernel_default_epithet)
502
?(filesystem_default_epithet=Initialization.router_filesystem_default_epithet)
504
new virtual_machine_installations
506
~kernel_default_epithet
507
~filesystem_default_epithet
510
let get_machine_installations
511
?(user_filesystem_searching_list = user_filesystem_searching_list)
512
?(root_filesystem_searching_list = root_filesystem_searching_list)
513
?(kernel_searching_list=kernel_searching_list)
514
?(kernel_prefix = kernel_prefix)
515
?(kernel_default_epithet=Initialization.machine_kernel_default_epithet)
516
?(filesystem_default_epithet=Initialization.machine_filesystem_default_epithet)
518
new virtual_machine_installations
520
~kernel_default_epithet
521
~filesystem_default_epithet
524
let vm_installations_and_epithet_of_prefixed_filesystem prefixed_filesystem =
526
let p = String.index prefixed_filesystem '-' in
527
let prefix = String.sub prefixed_filesystem 0 (p+1) in
528
let epithet = String.sub prefixed_filesystem (p+1) ((String.length prefixed_filesystem)-(p+1)) in
529
let vm_installations =
531
| "machine-" -> get_machine_installations ()
532
| "router-" -> get_router_installations ()
533
| _ -> (assert false)
536
(vm_installations, epithet)
537
with _ -> failwith (Printf.sprintf "vm_installations_and_epithet_of_prefixed_filesystem: %s" prefixed_filesystem)
539
let user_export_dirname_of_prefixed_filesystem prefixed_filesystem =
540
let (vm_installations, epithet) =
541
vm_installations_and_epithet_of_prefixed_filesystem prefixed_filesystem
543
vm_installations#user_export_dirname epithet
545
let root_export_dirname_of_prefixed_filesystem prefixed_filesystem =
546
let (vm_installations, epithet) =
547
vm_installations_and_epithet_of_prefixed_filesystem prefixed_filesystem
549
vm_installations#root_export_dirname epithet
552
module Make_and_check_installations (Unit:sig end) = struct
554
let machines = get_machine_installations ()
555
let routers = get_router_installations ()
558
machines#check_filesystems_MTIME_consistency ();
559
routers#check_filesystems_MTIME_consistency ();
562
end (* Make_and_check_installations *)
added
removed
disk.ml
