File: disk.ml

package info (click to toggle)
marionnet 0.90.6+bzr508-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 9,532 kB
  • sloc: ml: 18,130; sh: 5,384; xml: 1,152; makefile: 1,003; ansic: 275
file content (636 lines) | stat: -rw-r--r-- 25,320 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
(* This file is part of marionnet
   Copyright (C) 2010  Jean-Vincent Loddo
   Copyright (C) 2010  Université Paris 13

   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <http://www.gnu.org/licenses/>. *)

open Gettext

(* `epithet' is almost a phantom type (almost because it is not abstract): *)
type 'a epithet = string
type variant = string
type filename = string
type dirname = string
type realpath = string

let string_of_epithet_kind =
  function
  | `distrib -> "distribution"
  | `variant -> "variant"
  | `kernel  -> "kernel"
  | _ -> assert false

class terminal_manager () =
 let hostxserver_name = "X HOST" in
 let xnest_name       = "X NEST" in
 let nox_name         = "No X" in
 object (self)
   method get_choice_list =
     [ hostxserver_name; xnest_name; nox_name ]

   method get_default = hostxserver_name
   method is_valid_choice x = List.mem x self#get_choice_list
   method is_hostxserver = ((=)hostxserver_name)
   method is_xnest       = ((=)xnest_name)
   method is_nox         = ((=)nox_name)
 end

(** Some name filters (predicates on strings): *)
module Filter = struct

 let ending_with_dot_relay =
   StrExtra.First.matchingp (Str.regexp "[.]relay\\($\\|[._-][a-zA-Z0-9._-]*[~]?$\\)")

 let ending_with_dot_conf =
   StrExtra.First.matchingp (Str.regexp "[.]conf[~]?$")

 let exclude_names_ending_with_dot_conf_or_dot_relay x =
    not ((ending_with_dot_conf x) || (ending_with_dot_relay x))

end (* Filter *)

 (** Read the given directory searching for names like [~prefix ^ "xxxxx"];
     return the list of epithets ["xxxxx"]. *)
(* let read_epithet_list ?(name_filter=fun _ -> true) ~prefix ~dir () = *)
let read_epithet_list ?(name_filter=Filter.exclude_names_ending_with_dot_conf_or_dot_relay) ~prefix ~dir () =
  let prefix_length = String.length prefix in
  let remove_prefix s = String.sub s prefix_length ((String.length s) - prefix_length) in
  let name_filter file_name =
    (name_filter file_name) &&
    ((String.length file_name) > prefix_length) &&
    ((String.sub file_name 0 prefix_length) = prefix)
  in
  let xs =
    SysExtra.readdir_as_list
       ~only_not_directories:()
       ~name_filter
       ~name_converter:remove_prefix
       dir in
  Log.printf1 ~v:2 "Searching in %s:\n" dir;
  List.iter (fun x -> Log.printf2 ~v:2 " - found %s%s\n" prefix x) xs;
  xs


let machine_prefix = "machine-"
let router_prefix  = "router-"
let kernel_prefix  = "linux-"

let root_filesystem_searching_list = [
   Initialization.Path.filesystems;
   ]

let user_filesystem_searching_list = [
   Initialization.Path.user_filesystems;
   ]

(* In the order of priority: *)
let kernel_searching_list = [
   Initialization.Path.user_kernels;
   Initialization.Path.kernels;
   ]

module String_map = MapExtra.String_map

(* For a given choice the last binding with a directory will wins building the mapping.
   So we reverse the searching list: *)
let make_epithet_to_dir_mapping ~kind ?realpath ~prefix ~directory_searching_list () =
  Log.printf2 "Searching for a (%s) prefix: \"%s\"\n" (string_of_epithet_kind kind) prefix;
  let normalize_dir = match realpath with
   | None    -> (fun x -> Some x)
   | Some () -> (fun x -> UnixExtra.realpath x)
  in
  let searching_list = List.rev directory_searching_list in
  let xss =
     List.map
       (fun dir ->
          let epithet_list = read_epithet_list ~prefix ~dir () in
          List.map (fun x -> (x, (normalize_dir dir))) epithet_list
        )
        searching_list
  in
  let yss = List.flatten xss in
  let yss = List.filter (fun (e,d)->d<>None) yss in
  let yss = List.map (function (e, Some dir)->(e,dir) | _ -> assert false) yss in
  (List.iter (function (e,d) -> Log.printf2 "* %s -> %s\n" e d) yss);
  String_map.of_list yss


(** epithet -> (variant list) * dir *)
let make_epithet_to_variant_list_and_dir_mapping ~prefix ~epithet_to_dir_mapping =
    String_map.mapi
      (fun epithet dir ->
        let dir = Printf.sprintf "%s/%s%s_variants" dir prefix epithet in
        ((read_epithet_list ~prefix:"" ~dir), dir)
      )
      epithet_to_dir_mapping


class type ['a] epithet_manager_object =
  object
    (* Constructor's arguments: *)
    method directory_searching_list : dirname list
    method prefix : string (* "machine-", "router-", "kernel-", "" (nothing for variants) *)
    (* Public interface: *)
    method get_epithet_list    : 'a epithet list
    method get_default_epithet : 'a epithet option
    method epithet_exists      : 'a epithet -> bool
    method realpath_of_epithet : 'a epithet -> realpath
    method resolve_epithet_symlink : 'a epithet -> 'a epithet
    (* Morally private methods: *)
    method epithets_of_filename : ?no_symlinks:unit -> filename -> ('a epithet) list
    method epithets_sharing_the_same_realpath_of : ?no_symlinks:unit -> ('a epithet) -> ('a epithet) list
    method filename_of_epithet : ('a epithet) -> filename
    method realpath_exists : string -> bool
    method filter : ('a epithet -> bool) -> unit
  end


class ['a] epithet_manager
  : ?default_epithet:('a epithet) ->
    ?filter:('a epithet->bool) ->
    kind: [> `distrib | `kernel | `variant ] ->
    directory_searching_list:string list ->
    prefix:string ->
    unit -> ['a] epithet_manager_object
  =
  fun
  ?(default_epithet="default")
  ?filter
  ~kind
  ~directory_searching_list
  ~prefix (* "machine-", "router-", "linux-", "" (for variants), ... *)
  ()
  ->
  let epithet_to_dir_mapping =
    make_epithet_to_dir_mapping ~kind ~realpath:() ~prefix ~directory_searching_list ()
  in
  (* Filter the list if required with the optional parameter `filter': *)
  let epithet_to_dir_mapping =
    match filter with
    | None   -> epithet_to_dir_mapping
    | Some f -> String_map.filter (fun epth _dir -> f epth) epithet_to_dir_mapping
  in
  object (self)

  (* The version stored in the object is the destructive (non-persistent)
     version of the same mapping: *)
  val mutable epithet_to_dir_mapping = epithet_to_dir_mapping

  (* Destructive filter application: *)
  method filter f =
    epithet_to_dir_mapping <- String_map.filter (fun epth _dir -> f epth) (epithet_to_dir_mapping)

  method directory_searching_list = directory_searching_list
  method prefix = prefix

  method get_epithet_list : 'a epithet list =
    String_map.domain epithet_to_dir_mapping

  method epithet_exists (epithet:'a epithet) : bool =
    String_map.mem epithet epithet_to_dir_mapping

  method (*private*) filename_of_epithet (epithet:'a epithet) =
    let dir = String_map.find epithet epithet_to_dir_mapping in
    (Printf.sprintf "%s/%s%s" dir prefix epithet)

  method realpath_of_epithet (epithet:'a epithet) : realpath =
    let filename = (self#filename_of_epithet epithet) in
    match (UnixExtra.realpath filename) with
    | Some x -> x
    | None   -> filename

  method (*private*) epithets_of_filename ?no_symlinks (filename:string) : ('a epithet) list =
    let realpath = Option.extract (UnixExtra.realpath filename) in
    let pred = match no_symlinks with
     | None    -> (fun e -> (self#realpath_of_epithet e) = realpath)
     | Some () ->
       (fun e ->
          (not (UnixExtra.is_symlink (self#filename_of_epithet e))) &&
          ((self#realpath_of_epithet e) = realpath))
    in
    (List.filter pred self#get_epithet_list)

  (* [machine-]default -> [machine-]debian-51426 *)
  method resolve_epithet_symlink (epithet:'a epithet) : 'a epithet =
   let filename = self#filename_of_epithet epithet in
   match UnixExtra.is_symlink filename with
   | false -> epithet
   | true  ->
      (match (self#epithets_of_filename ~no_symlinks:() filename) with
      | []            -> epithet
      | epithet'::_   -> epithet' (* we get the first *)
      )

  method epithets_sharing_the_same_realpath_of ?(no_symlinks:unit option) (epithet:'a epithet) : ('a epithet) list =
   let filename = self#filename_of_epithet epithet in
   self#epithets_of_filename ?no_symlinks filename

  method realpath_exists filename =
    let xs = List.map (self#filename_of_epithet) self#get_epithet_list in
    List.mem filename xs

  (* When a machine is created, we call this method to set a default epithet.*)
  method get_default_epithet : 'a epithet option =
    if self#epithet_exists default_epithet then (Some default_epithet) else
    let xs = self#get_epithet_list in
    match xs with
    | []   -> None
    | x::_ -> Some x (* We get the first as default... *)

end (* class epithet_manager *)

let get_and_parse_SUPPORTED_KERNELS (t : Configuration_files.t) : string -> (unit, string option) Either.t =
  let x = Configuration_files.get_string_list_variable "SUPPORTED_KERNELS" t in
  let brackets = (Str.regexp "^\\[\\(.*\\)\\]$") in
  let slashes  = (Str.regexp "^/\\(.*\\)/$") in
  let extract result =
    let (_,_,groups) = Option.extract result in
    List.hd groups
  in
  let rec loop acc = function
  | [] -> (List.rev acc)
  | x::xs when (StrExtra.First.matchingp brackets x) ->
      let brackets_content = extract (StrExtra.First.matching brackets x) in
      loop ((`Brackets brackets_content)::acc) xs
  | x::xs when (StrExtra.First.matchingp slashes x) ->
      let slashes_content = extract (StrExtra.First.matching slashes x) in
      loop ((`Slashes slashes_content)::acc) xs
  | x::xs ->
      loop ((`AString x)::acc) xs
  in
  let token_list : ([`Brackets of string | `Slashes of string | `AString of string] list) option =
    Option.map (loop []) x
  in
  let rec collapse_AString acc = function
  | [] -> List.rev acc
  | (`AString x)::(`AString y)::zs -> collapse_AString acc ((`AString (String.concat " " [x;y]))::zs)
  | x::ys -> collapse_AString (x::acc) ys
  in
  let token_list = Option.map (collapse_AString []) token_list in
  let rec parse acc = function
  | [] -> List.rev acc
  | (`Brackets x)::(`AString y)::zs -> parse (((`kernel_epithet x), Some y)::acc) zs
  | (`Brackets x)::zs               -> parse (((`kernel_epithet x), None)::acc) zs
  | (`Slashes x)::(`AString y)::zs  -> parse (((`kernel_regexpr (Str.regexp x)), Some y)::acc) zs
  | (`Slashes x)::zs                -> parse (((`kernel_regexpr (Str.regexp x)), None)::acc) zs
  | (`AString x)::_ ->
      let msg = Printf.sprintf "Parsing variable SUPPORTED_KERNELS: unexpected string `%s'" x in
      failwith msg
  in
  let parsing_result
    : ([> `kernel_epithet of string | `kernel_regexpr of Str.regexp ] * string option) list option
    = Option.map (parse []) token_list
  in
  let parsing_result_as_predicate_list : ((string -> bool) * string option) list option =
    let epithet_predicate_of = function
    | `kernel_epithet x -> ((=)x)
    | `kernel_regexpr r -> (StrExtra.First.matchingp r)
    in
    Option.map (List.map (fun (k,so) -> ((epithet_predicate_of k),so))) parsing_result
  in
  function epithet ->
    match parsing_result_as_predicate_list with
    | None -> Either.Right (None)  (* The epithet is ok, without special console options *)
    | Some pred_so_list ->
        begin
          match (ListExtra.search (fun (pred,so) -> pred epithet) pred_so_list) with
          | None -> Either.Left () (* The epithet will be not accepted *)
          | Some (_,options) -> Either.Right (options) (* The epithet is ok, may be with options *)
        end
  (* end of get_and_parse_SUPPORTED_KERNELS() *)

class virtual_machine_installations
  ?(user_filesystem_searching_list = user_filesystem_searching_list)
  ?(root_filesystem_searching_list = root_filesystem_searching_list)
  ?(kernel_searching_list=kernel_searching_list)
  ?(kernel_prefix = kernel_prefix)
  ?(kernel_default_epithet:[`kernel] epithet option)
  ?(filesystem_default_epithet:[`distrib] epithet option)
  ~prefix (* "machine-", "router-", ... *)
  () =
  (* The actual filesystem searching list is the merge of user (prioritary)
     and root lists: *)
  let filesystem_searching_list =
    List.append user_filesystem_searching_list root_filesystem_searching_list
  in
  (* The manager of all filesystem epithets: *)
  let filesystems : [`distrib] epithet_manager =
    new epithet_manager
        ~filter:Filter.exclude_names_ending_with_dot_conf_or_dot_relay
        ~kind:`distrib
	~prefix
	~directory_searching_list:filesystem_searching_list
	?default_epithet:filesystem_default_epithet
	()
  in
  (* The manager of all kernel epithets: *)
  let kernels : [`kernel] epithet_manager =
    new epithet_manager
        ~filter:Filter.exclude_names_ending_with_dot_conf_or_dot_relay
        ~kind:`kernel
        ~prefix:kernel_prefix
        ~directory_searching_list:kernel_searching_list
        ?default_epithet:kernel_default_epithet
        ()
  in
  (* The kit of managers (one per filesystem epithet) for variant epithets.
     This mapping is created from `filesystems#get_epithet_list' *)
  let filesystem_variants_mapping =
   let epithet_manager_of filesystem_epithet : [`variant] epithet_manager =
    begin
     let directory_searching_list_of e =
        List.map
          (fun dir -> Printf.sprintf "%s/%s%s_variants" dir prefix e)
          filesystem_searching_list
     in
     let directory_searching_list =
       let epithets = filesystems#epithets_sharing_the_same_realpath_of filesystem_epithet in
       let epithets = ListExtra.lift_to_the_top_positions ((=)filesystem_epithet) epithets in
       List.flatten (List.map directory_searching_list_of epithets)
     in
     new epithet_manager
        ~kind:`variant
        ~prefix:""
        ~directory_searching_list
       ()
    end
   in
   let assoc_list :  ([`distrib] epithet * [`variant] epithet_manager) list =
     List.map (fun e -> (e,epithet_manager_of e)) filesystems#get_epithet_list
   in
   String_map.of_list assoc_list
  in
  (* Now we build the mapping filesystem-epithet -> Configuration_files.t option *)
  let filesystem_config_mapping =
    let mill =
      fun filesystem_epithet ->
	let filename = filesystems#filename_of_epithet (filesystem_epithet) in
	let config_file = Printf.sprintf "%s.conf" (filename) in
	let result =
	  match Sys.file_exists (config_file) with
	  | false -> None
	  | true  ->
	      let () = Log.printf1 "configuration file found for \"%s\"\n" filesystem_epithet in
	      let config =
		Configuration_files.make
		  ~dont_read_environment:()
		  ~file_names:[config_file]
		  ~variables:[ "MD5SUM"; "AUTHOR"; "DATE"; "MTIME"; "SUPPORTED_KERNELS"; "X11_SUPPORT";
		               "MEMORY_MIN_SIZE"; "MEMORY_SUGGESTED_SIZE"; "MULTIPLE_CONSOLES_SUPPORT"; 
		               "RC_RELAY_SUPPORT"; "BINARY_LIST"; ]
		  ()
	      in
	      Some (config)
	in
	result
    (* end mill () *)
    in
    String_map.of_list (List.map (fun e -> (e, mill e)) filesystems#get_epithet_list)
  in
  (* Now we build the mapping filesystem-epithet -> marionnet_relay-script list *)
  let filesystem_relay_script_mapping =
    let mill =
      fun filesystem_epithet ->
	let filename = filesystems#filename_of_epithet (filesystem_epithet) in
	let dot_relay_file = Printf.sprintf "%s.relay" (filename) in
	let result =
	  match Sys.file_exists (dot_relay_file) with
	  | false -> None
	  | true  ->
	      let () = Log.printf1 "relay script found for \"%s\"\n" filesystem_epithet in
	      Some (dot_relay_file)
	in
	result
    (* end mill () *)
    in
    String_map.of_list (List.map (fun e -> (e, mill e)) filesystems#get_epithet_list)
  in
  (* Now the mapping filesystem-epithet -> [(kernel1, console-options1); (kernel2, console-options2);...] option *)
  let filesystem_kernels_mapping =
    let mill =
      fun filesystem_epithet ->
        let config = String_map.find (filesystem_epithet) (filesystem_config_mapping) in
        Option.bind config
          (fun config_t ->
             try
               let filter : [`kernel] epithet -> (unit, string option) Either.t =
                  get_and_parse_SUPPORTED_KERNELS config_t
               in
               let ks = kernels#get_epithet_list in
               let ks = List.map (fun k -> (k, filter k)) ks in
               let ks = List.filter (fun (k,r) -> r <> Either.Left ()) ks in
               let ks = List.map (fun (k,r) -> (k, Either.extract r)) ks in
               let () =
                 Log.printf2 "Selected kernels for \"%s\": [%s]\n"
                   filesystem_epithet
                   (String.concat " " (List.map fst ks))
               in
               (Some ks)
             with Failure msg ->
                 let () = Log.printf2 "%s => \"%s\" config file ignored!\n" msg filesystem_epithet in
                 None)
    in
    String_map.of_list (List.map (fun e -> (e, mill e)) filesystems#get_epithet_list)
  in
  (* The manager for terminal (X support): *)
  let terminal_manager =
    new terminal_manager ()
  in
  object (self)
  method filesystem_searching_list = filesystem_searching_list
  method kernel_searching_list = kernel_searching_list
  method kernel_prefix = kernel_prefix
  method prefix = prefix

  method filesystems = filesystems
  method kernels = kernels

  method variants_of filesystem_epithet =
    String_map.find (filesystem_epithet) (filesystem_variants_mapping)

  method relay_script_of filesystem_epithet =
    String_map.find (filesystem_epithet) (filesystem_relay_script_mapping)

  (* Here, if we replace the first two lines of the following definition by:
    ---
    method supported_kernels_of (filesystem_epithet:[`distrib] epithet) : ([`kernel] epithet * (string option)) list =
    ---
    we obtain an error message about the method's type:
    [ `distrib ] epithet -> ('c epithet * string option) list where 'c is unbound *)
  method supported_kernels_of : [`distrib] epithet -> ([`kernel] epithet * (string option)) list =
    fun filesystem_epithet ->
      match String_map.find (filesystem_epithet) (filesystem_kernels_mapping) with
      | None    -> List.map (fun k -> (k,None)) kernels#get_epithet_list
      | Some ks -> ks

  (* Do not propose any filesystems which haven't at least one compatible installed kernel: *)
  initializer
    filesystems#filter
      (fun e -> (self#supported_kernels_of e)<>[])

  method get_kernel_console_arguments : [`distrib] epithet -> [`kernel] epithet -> string option =
    fun filesystem_epithet kernel_epithet ->
      try
        let ks = self#supported_kernels_of (filesystem_epithet) in
        List.assoc (kernel_epithet) ks
      with Not_found ->
        let () =
          Log.printf2
            "Disk.virtual_machine_installations#get_kernel_console_arguments: couple (%s,%s) unknown!\n"
            (filesystem_epithet) (kernel_epithet)
        in None

  (** Terminal choices to handle uml machines.
      The list doesn't depend on the choosen distribution (in this version): *)
  method terminal_manager_of (_: [`distrib] epithet) = terminal_manager

  method root_export_dirname epithet =
    let root_dir = List.hd root_filesystem_searching_list in
    (Printf.sprintf "%s/%s%s_variants" root_dir prefix epithet)

  method user_export_dirname epithet =
    let user_dir = List.hd user_filesystem_searching_list in
    (Printf.sprintf "%s/%s%s_variants" user_dir prefix epithet)

  method multiple_consoles_supported_by epithet =
    let config = String_map.find (epithet) (filesystem_config_mapping) in
    if config = None then false else (* continue: *)
    let x = Configuration_files.get_bool_variable "MULTIPLE_CONSOLES_SUPPORT" (Option.extract config) in
    (x = Some true)

  (* The relevant configuration variable here is RC_RELAY_SUPPORT. However, if the .conf file doesn't 
     contain a binding for such variable, we consider the binding MULTIPLE_CONSOLES_SUPPORT=true 
     as an equivalent condition. *)
  method marionnet_relay_supported_by (epithet) =
    let config = String_map.find (epithet) (filesystem_config_mapping) in
    if config = None then false else (* continue: *)
    let config = (Option.extract config) in
    match Configuration_files.get_bool_variable "RC_RELAY_SUPPORT" config with
    | Some answer -> answer
    | None ->
        (* If there's not a binding for RC_RELAY_SUPPORT, we look at MULTIPLE_CONSOLES_SUPPORT: *)
        let x = Configuration_files.get_bool_variable "MULTIPLE_CONSOLES_SUPPORT" config in
        (x = Some true)

  method memory_min_size_of epithet =
    let config = String_map.find (epithet) (filesystem_config_mapping) in
    Option.bind config (Configuration_files.get_int_variable "MEMORY_MIN_SIZE")

  method memory_suggested_size_of epithet =
    let config = String_map.find (epithet) (filesystem_config_mapping) in
    Option.bind config (Configuration_files.get_int_variable "MEMORY_SUGGESTED_SIZE")

  method check_filesystems_MTIME_consistency () =
    let check =
      fun filesystem_epithet ->
        let config = String_map.find (filesystem_epithet) (filesystem_config_mapping) in
        if config = None then () else (* continue: *)
        let mtime = Configuration_files.get_int_variable "MTIME" (Option.extract config) in
        Option.iter
          (fun expected_mtime ->
             let realpath = filesystems#realpath_of_epithet (filesystem_epithet) in
             let actual_mtime =
               int_of_float ((Unix.stat realpath).Unix.st_mtime)
             in
             if actual_mtime = expected_mtime then () else (* warning: *)
	     let title = (s_ "Modification time (MTIME) inconsistency") in
	     let message =
	       Printf.sprintf
		 (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.")
 		 (prefix) (filesystem_epithet) (actual_mtime) (expected_mtime) (expected_mtime) (realpath)
	     in
             Simple_dialogs.warning title message ())
          mtime
    in
    List.iter (check) filesystems#get_epithet_list

end

let find_router_installations
  ?(user_filesystem_searching_list = user_filesystem_searching_list)
  ?(root_filesystem_searching_list = root_filesystem_searching_list)
  ?(kernel_searching_list=kernel_searching_list)
  ?(kernel_prefix = kernel_prefix)
  ?(kernel_default_epithet=Initialization.router_kernel_default_epithet)
  ?(filesystem_default_epithet=Initialization.router_filesystem_default_epithet)
  ?(lifetime=60.) (* seconds *)
  () =
     Lazy_perishable.create 
       (fun () -> new virtual_machine_installations
         ~prefix:"router-"
         ~kernel_default_epithet
         ~filesystem_default_epithet
         ())
       lifetime

let get_router_installations = find_router_installations ()
       
let find_machine_installations
  ?(user_filesystem_searching_list = user_filesystem_searching_list)
  ?(root_filesystem_searching_list = root_filesystem_searching_list)
  ?(kernel_searching_list=kernel_searching_list)
  ?(kernel_prefix = kernel_prefix)
  ?(kernel_default_epithet=Initialization.machine_kernel_default_epithet)
  ?(filesystem_default_epithet=Initialization.machine_filesystem_default_epithet)
  ?(lifetime=60.) (* seconds *)
  () =
     Lazy_perishable.create 
       (fun () -> new virtual_machine_installations
	 ~prefix:"machine-"
	 ~kernel_default_epithet
 	 ~filesystem_default_epithet
	 ())
       lifetime

let get_machine_installations = find_machine_installations ()
       
let vm_installations_and_epithet_of_prefixed_filesystem prefixed_filesystem =
 try
  let p = String.index prefixed_filesystem '-' in
  let prefix = String.sub prefixed_filesystem 0 (p+1) in
  let epithet = String.sub prefixed_filesystem (p+1) ((String.length prefixed_filesystem)-(p+1)) in
  let vm_installations =
    (match prefix with
     | "machine-" -> Lazy_perishable.force (get_machine_installations)
     | "router-"  -> Lazy_perishable.force (get_router_installations)
     | _ -> (assert false)
     )
  in
  (vm_installations, epithet)
 with _ -> failwith (Printf.sprintf "vm_installations_and_epithet_of_prefixed_filesystem: %s" prefixed_filesystem)

let user_export_dirname_of_prefixed_filesystem prefixed_filesystem =
  let (vm_installations, epithet) =
    vm_installations_and_epithet_of_prefixed_filesystem prefixed_filesystem
  in
  vm_installations#user_export_dirname epithet

let root_export_dirname_of_prefixed_filesystem prefixed_filesystem =
  let (vm_installations, epithet) =
    vm_installations_and_epithet_of_prefixed_filesystem prefixed_filesystem
  in
  vm_installations#root_export_dirname epithet


module Make_and_check_installations (Unit:sig end) = struct

  let machines = Lazy_perishable.force (get_machine_installations)
  let routers  = Lazy_perishable.force (get_router_installations)

  let () = begin
    machines#check_filesystems_MTIME_consistency ();
    routers#check_filesystems_MTIME_consistency ();
    end

end (* Make_and_check_installations *)