aboutsummaryrefslogtreecommitdiff
path: root/src/property/disk.lisp
blob: af1e7e6d4cdb6dec7a0f617b19e67fb23b52d8d2 (plain)
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
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
;;; Consfigurator -- Lisp declarative configuration management system

;;; Copyright (C) 2021  Sean Whitton <spwhitton@spwhitton.name>

;;; This file 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 3, or (at your option)
;;; any later version.

;;; This file 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/>.

(in-package :consfigurator.property.disk)
(named-readtables:in-readtable :consfigurator)

;;; All Linux-specific for now, so properties using these data types and
;;; functions should declare a hostattrs requirement (os:required 'os:linux).

;;;; Volumes

(defclass volume ()
  ((volume-label
    :type string :initarg :volume-label :accessor volume-label
    :documentation "The name or label of the volume.
Can only be recorded in or on the volume itself for certain subclasses.  For
example, mostly meaningless for a Linux swap partition.")
   (volume-contents
    :type volume :initarg :volume-contents :accessor volume-contents)
;;    (volume-depth
;;     :initarg :volume-depth
;;     :accessor volume-depth
;;     :type integer
;;     :documentation
;;     "Number representing the degree to which this volume is nested within other
;; volumes.  All volumes with a lower value for VOLUME-DEPTH should be opened
;; before any attempt to open this volume is made.

;; For example, an LVM volume group needs a VOLUME-DEPTH strictly greater than
;; the VOLUME-DEPTH of all its physical volumes.")
   (volume-size
    :initarg :volume-size :accessor volume-size
    :documentation "The size of the volume, in whole mebibytes (MiB).
The special value :REMAINING means all remaining free space in the volume
containing this one.

If a larger size is required to accommodate the VOLUME-CONTENTS of the volume
plus any metadata (e.g. partition tables), this value will be ignored.")
   (volume-bootloaders
    :type list :initarg :boots-with :accessor volume-bootloaders
    :documentation
    "List or list of lists specifying bootloaders to be installed to this volume.
The first element of each list is a symbol identifying the type of bootloader,
and the remaining elements are a plist of keyword arguments to be passed to
the implementation of INSTALLER:INSTALL-BOOTLOADER for that bootloader type.

Typically only the top level PHYSICAL-DISK of a host's volumes will have this
slot bound."))
  (:documentation
   "Something which contains filesystems and/or other volumes."))

(define-simple-print-object volume)

(defgeneric copy-volume-and-contents
    (volume &rest initialisations &key &allow-other-keys)
  (:documentation
   "Make a fresh copy of VOLUME, shallowly, except for the VOLUME-CONTENTS of
volume, which is recursively copied.  Keyword arguments may be used to
subsequently replace the copied values of some slots.")
  (:method ((volume volume) &rest initialisations &key &allow-other-keys)
    (let* ((class (class-of volume))
           (copy (allocate-instance class))
           (contents-bound-p (slot-boundp volume 'volume-contents))
           (contents (and contents-bound-p (volume-contents volume))))
      (dolist (slot-name (delete 'volume-contents
                                 (mapcar #'closer-mop:slot-definition-name
                                         (closer-mop:class-slots class))))
        (when (slot-boundp volume slot-name)
          (setf (slot-value copy slot-name) (slot-value volume slot-name))))
      (when contents-bound-p
        (setf (volume-contents copy)
              (if (listp contents)
                  (mapcar #'copy-volume-and-contents contents)
                  (copy-volume-and-contents contents))))
      (apply #'reinitialize-instance copy initialisations))))

(defgeneric subvolumes-of-type (type volume)
  (:documentation
   "Recursively examine VOLUME and its VOLUME-CONTENTS and return a list of all
volumes encountered whose type is a subtype of TYPE.
Returns as a second value a corresponding list of the immediate parents of
each returned volume.")
  (:method ((type symbol) (volume volume))
    (labels ((walk (volume parent &aux (second-arg (list volume)))
               (multiple-value-bind (contents contents-parents)
                   (and (slot-boundp volume 'volume-contents)
                        (multiple-value-mapcan
                         #'walk (ensure-cons (volume-contents volume))
                         (rplacd second-arg second-arg)))
                 (if (subtypep (type-of volume) type)
                     (values (cons volume contents)
                             (cons parent contents-parents))
                     (values contents contents-parents)))))
      (walk volume nil))))

(defgeneric all-subvolumes (volume)
  (:documentation
   "Recursively examine VOLUME and its VOLUME-CONTENTS and return a list of all
volumes encountered.")
  (:method ((volume volume))
    (subvolumes-of-type 'volume volume)))

(defgeneric volume-contents-minimum-size (volume)
  (:documentation
   "Return the minimum size required to accommodate the VOLUME-CONTENTS of VOLUME.")
  (:method ((volume volume))
    (if (slot-boundp volume 'volume-contents)
        (reduce #'+ (mapcar #'volume-minimum-size
                            (ensure-cons (volume-contents volume))))
        0)))

(defgeneric volume-minimum-size (volume)
  (:documentation
   "Return the VOLUME-SIZE of the volume or the minimum size required to
accommodate its contents, whichever is larger.")
  (:method ((volume volume))
    (let ((volume-minimum-size
            (cond ((not (slot-boundp volume 'volume-size))
                   0)
                  ((eql (volume-size volume) :remaining)
                   1)
                  ((numberp (volume-size volume))
                   (volume-size volume))
                  (t
                   (simple-program-error "Invalid volume size ~A"
                                         (volume-size volume))))))
      (max volume-minimum-size
           (volume-contents-minimum-size volume)))))

(defclass top-level-volume (volume) ()
  (:documentation
   "A volume which never appears as the VOLUME-CONTENTS of another volume."))

(defgeneric create-volume (volume file)
  (:documentation
   "Create VOLUME.  FILE is a pathname at or on which to create VOLUME, for types
of VOLUME where that makes sense, and explicitly nil otherwise.
Return values, if any, should be ignored."))

(defgeneric volume-required-data (volume)
  (:documentation
   "Return (IDEN1 . IDEN2) pairs for each item of prerequisite data opening
and/or creating the volume requires.")
  (:method ((volume volume))
    "Default implementation: nothing required."
    nil))

(defun require-volumes-data (volumes)
  "Call REQUIRE-DATA on each item of prerequisite data requires for opening
and/or creating each of VOLUMES.

Called by property :HOSTATTRS subroutines."
  (dolist (pair (mapcan #'volume-required-data
                        (mapcan #'all-subvolumes volumes)))
    (require-data (car pair) (cdr pair))))


;;;; Opened volumes

(defgeneric open-volume (volume file)
  (:documentation "Renders contents of VOLUME directly accessible.
FILE is something in the filesystem which serves as a means of accessing
VOLUME, for types of VOLUME where that makes sense, and explicitly nil
otherwise.

Returns as a first value a fresh instance of OPENED-VOLUME corresponding to
VOLUME.  In this case, it is legitimate to subsequently call OPEN-VOLUME on
the VOLUME-CONTENTS of VOLUME.

If opening this kind of volume results in opening its VOLUME-CONTENTS too,
also return as a second value a list of fresh OPENED-VOLUME values
corresponding to the VOLUME-CONTENTS of VOLUME.  In this case, the caller
should not attempt to call OPEN-VOLUME on the VOLUME-CONTENTS of VOLUME."))

(defgeneric close-volume (volume)
  (:documentation
   "Inverse of OPEN-VOLUME: `kpartx -d`, `cryptsetup luksClose`, etc.
Return values, if any, should be ignored.")
  (:method ((volume volume))
    "Default implementation: assume there is nothing to close."
    (values)))

(defclass opened-volume (volume)
  ((device-file
    :type pathname
    :initarg :device-file
    :accessor device-file
    :documentation "File under /dev giving access to the opened volume."))
  (:documentation
   "A VOLUME object which has been made directly accessible as a block device."))

(defmethod open-volume ((volume opened-volume) file)
  (copy-volume-and-contents volume))

(defgeneric make-opened-volume (volume device-file)
  (:documentation
   "Where there is a class which is a subclass of both the class of VOLUME and
OPENED-VOLUME, make a fresh instance of that class copying all slots from
VOLUME, and setting the DEVICE-FILE slot to DEVICE-FILE."))

(defmacro defclass-opened-volume
    (name (subclass-of-volume &rest other-superclasses)
     &key (device-file-type 'pathname))
  "Define a subclass of SUBCLASS-OF-VOLUME and OPENED-VOLUME called NAME, and an
appropriate implementation of MAKE-OPENED-VOLUME for NAME.
SUBCLASS-OF-VOLUME should be a symbol naming a subclass of VOLUME."
  `(progn
     (defclass ,name (,subclass-of-volume ,@other-superclasses opened-volume) ()
       (:documentation
        ,(format
          nil
          "Instance of ~A which has been made directly accessible as a block device."
          name)))
     (defmethod make-opened-volume
         ((volume ,subclass-of-volume) (device-file ,device-file-type))
       ,(format nil "Make instance of ~A from instance of ~A."
                name subclass-of-volume)
       (let ((old-class (find-class ',subclass-of-volume)))
         (closer-mop:ensure-finalized old-class)
         (let ((new (allocate-instance (find-class ',name))))
           (dolist (slot-name (mapcar #'closer-mop:slot-definition-name
                                      (closer-mop:class-slots old-class)))
             (when (slot-boundp volume slot-name)
               (setf (slot-value new slot-name)
                     (slot-value volume slot-name))))
           (setf (slot-value new 'device-file) device-file)
           (reinitialize-instance new))))))

(defclass physical-disk (top-level-volume opened-volume) ()
  (:documentation
   "A physical disk drive attached to the machine, which always has a
corresponding block device in /dev available to access it.  Should be used for
whole disks, not partitions (e.g. /dev/sda, not /dev/sda1)."))


;;;; Disk images

(defclass disk-image (volume)
  ((image-file :initarg :image-file :accessor image-file)))


;;;; Raw disk images

(defclass raw-disk-image (disk-image) ()
  (:documentation
   "A raw disk image, customarily given an extension of .img, suitable for
directly writing out with dd(1)."))

(defclass-opened-volume opened-raw-disk-image (raw-disk-image))

;; kpartx(1) can operate directly upon raw disk images, and will also make the
;; whole disk image accessible as a loop device whose name we can infer from
;; the kpartx(1) output (from partitions at /dev/mapper/loopNpM we can infer
;; that /dev/loopN is the whole disk).  So we could examine the type of
;; (volume-contents volume), and if we find it's PARTITIONED-VOLUME, we could
;; skip executing losetup(1), and just call (open-volume (volume-contents
;; volume) file) and convert the return values into something appropriate for
;; us to return.  But for simplicity and composability, just make the whole
;; disk image accessible at this step of the recursion.
(defmethod open-volume ((volume raw-disk-image) (file null))
  (make-opened-volume
   volume
   (ensure-pathname
    (stripln (run "losetup" "--show" "-f" (image-file volume))))))

(defmethod close-volume ((volume opened-raw-disk-image))
  (mrun "losetup" "-d" (device-file volume)))

(defmethod create-volume ((volume raw-disk-image) (file null))
  "Ensure that a raw disk image exists.  Will overwrite only regular files."
  (let ((file (image-file volume)))
    (when (remote-test "-L" file "-o" "-e" file "-a" "!" "-f" file)
      (failed-change "~A already exists and is not a regular file." file))
    ;; Here, following Propellor, we want to ensure that the disk image size
    ;; is a multiple of 4096 bytes, so that the size is aligned to the common
    ;; sector sizes of both 512 and 4096.  But since we currently only support
    ;; volume sizes in whole mebibytes, we know it's already aligned.
    (file:does-not-exist file)
    (mrun
     "fallocate" "-l" (format nil "~DM" (volume-minimum-size volume)) file)))


;;;; Partitioned block devices and their partitions

;;; No support for MSDOS partition tables.

(defclass partitioned-volume (volume)
  ((volume-contents
    :type list
    :documentation "A list of partitions."))
  (:documentation "A device with a GPT partition table and partitions."))

(defclass-opened-volume opened-partitioned-volume (partitioned-volume))

(defclass partition (volume)
  ((partition-typecode
    :initform #x8300 :initarg :partition-typecode :accessor partition-typecode
    :documentation
    "The type code for the partition; see the --typecode option to sgdisk(1).
Either a two-byte hexadecimal number, or a string specifying the GUID.

On GNU/Linux systems, you typically only need to set this to a non-default
value in the case of EFI system partitions, for which case use #xEF00.")
   (partition-bootable
    :initform nil :initarg :partition-bootable :accessor partition-bootable
    :documentation "Whether the legacy BIOS bootable attribute is set.")
   (partition-start-sector
    :type integer
    :initform 0
    :initarg :partition-start-sector
    :accessor partition-start-sector
    :documentation "The sector at which the partition should start.
The default value of 0 means the next free sector.")
   (partition-sectors
    :type integer
    :initarg :partition-sectors
    :accessor partition-sectors
    :documentation "The size of the partition in sectors."))
  (:documentation "A GPT partition."))

(defclass-opened-volume opened-partition (partition))

(defmethod volume-contents-minimum-size ((volume partitioned-volume))
  "Add two mebibytes for the GPT metadata."
  (+ 2 (call-next-method)))

(defmethod open-volume ((volume partitioned-volume) (file pathname))
  (let ((loopdevs (mapcar
                   (lambda (line)
                     (destructuring-bind (add map loopdev &rest ignore)
                         (split-string line)
                       (declare (ignore ignore))
                       (unless (and (string= add "add") (string= map "map"))
                         (failed-change
                          "Unexpected kpartx output ~A" line))
                       (ensure-pathname (strcat "/dev/mapper/" loopdev))))
                   (runlines "kpartx" "-avs" file))))
    (unless (= (length loopdevs) (length (volume-contents volume)))
      (mrun "kpartx" "-d" file)
      (failed-change
       "kpartx(1) returned ~A loop devices, but volume has ~A partitions."
       (length loopdevs) (length (volume-contents volume))))
    (values
     (make-opened-volume volume file)
     (loop for partition in (volume-contents volume) and loopdev in loopdevs
           collect (make-opened-volume partition loopdev)))))

(defmethod close-volume ((volume opened-partitioned-volume))
  (mrun "kpartx" "-dv" (device-file volume)))

(defmethod create-volume ((volume partitioned-volume) (file pathname))
  (with-slots (volume-contents) volume
    (mrun :inform "sgdisk" "--zap-all" file)
    (mrun :inform "sgdisk"
          ;; Turn off partition alignment when specific start sectors have
          ;; been specified, so that we can be sure they will be respected.
          ;;
          ;; Given this approach, if specify start sector for one partition,
          ;; probably want to specify for all partitions to ensure alignment.
          (and (loop for partition in volume-contents
                       thereis (plusp (partition-start-sector partition)))
               "--set-alignment=1")
          (loop for partition in volume-contents
                for code = (partition-typecode partition)
                when (and (slot-boundp partition 'volume-size)
                          (slot-boundp partition 'partition-sectors))
                  do (failed-change
                      "~A has both VOLUME-SIZE and PARTITION-SECTORS bound."
                      partition)
                collect (strcat
                         "--new=0:"
                         (format nil "~D" (partition-start-sector partition))
                         ":"
                         (cond
                           ((slot-boundp partition 'partition-sectors)
                            (format nil "~D"
                                    (+ (partition-start-sector partition)
                                       (1- (partition-sectors partition)))))
                           ((and (slot-boundp partition 'volume-size)
                                 (eql (volume-size partition) :remaining))
                            "0")
                           (t
                            (format nil "+~DM"
                                    (volume-minimum-size partition)))))
                collect (strcat "--typecode=0:"
                                (etypecase code
                                  (string code)
                                  (integer (format nil "~X" code))))
                when (partition-bootable partition)
                  collect "--attributes=0:set:2")
          file)))


;;;; LVM

(defclass lvm-physical-volume (volume)
  ((lvm-volume-group
    :type string
    :initarg :volume-group
    :initform
    (simple-program-error "LVM physical volume must have volume group.")
    :accessor lvm-volume-group
    :documentation
    "The name of the LVM volume group to which this volume belongs.")

   ;; pvcreate(8) options
   (data-alignment
    :type string
    :initarg :data-alignment
    :accessor data-alignment
    :documentation "Value for the --dataalignment argument to pvcreate(8).")

   ;; vgcreate(8) options
   (physical-extent-size
    :type string
    :initarg :physical-extent-size
    :accessor physical-extent-size
    :documentation "Value for the --dataalignment argument to vgcreate(8).
Should be the same for all PVs in this VG.")
   (alloc
    :type string
    :initarg :alloc
    :accessor alloc
    :documentation "Value for the --alloc argument to vgcreate(8).
Should be the same for all PVs in this VG."))

  (:documentation "An LVM physical volume.
We do not specify what logical volumes it contains."))

(defclass-opened-volume opened-lvm-physical-volume (lvm-physical-volume))

(defmethod open-volume ((volume lvm-physical-volume) (file pathname))
  (make-opened-volume volume file))

(defmethod create-volume ((volume lvm-physical-volume) (file pathname))
  (mrun :inform "pvcreate"
        (and (slot-boundp volume 'data-alignment)
             `("--dataalignment" ,(data-alignment volume)))
        file)
  (if (memstr= (lvm-volume-group volume) (all-lvm-volume-groups))
      (mrun :inform "vgextend" (lvm-volume-group volume) file)
      (mrun :inform "vgcreate" "--systemid" ""
            (and (slot-boundp volume 'physical-extent-size)
                 `("--physicalextentsize" ,(physical-extent-size volume)))
            (and (slot-boundp volume 'alloc)
                 `("--alloc" ,(alloc volume)))
            (lvm-volume-group volume) file)))

(defun all-lvm-volume-groups ()
  (mapcar (curry #'string-trim " ")
          (runlines "vgs" "--no-headings" "-ovg_name")))

(defclass lvm-logical-volume (top-level-volume)
  ((volume-label
    :initform (simple-program-error "LVs must have names.")
    :documentation "The name of the LV, often starting with \"lv_\".")
   (lvm-volume-group
    :type string
    :initarg :volume-group
    :initform
    (simple-program-error "LVM logical volumes must have a volume group.")
    :accessor lvm-volume-group
    :documentation
    "The name of the LVM volume group to which this volume belongs.")))

(defclass-opened-volume activated-lvm-logical-volume (lvm-logical-volume))

(defmethod volume-contents-minimum-size ((volume lvm-logical-volume))
  "LVs cannot be of zero size."
  (max 1 (call-next-method)))

(defmethod open-volume ((volume lvm-logical-volume) (file null))
  (with-slots (volume-label lvm-volume-group) volume
    (mrun "lvchange" "-ay" (strcat lvm-volume-group "/" volume-label))
    ;; lvm(8) says not to use the /dev/mapper names, but rather /dev/vg/lv
    (make-opened-volume
     volume (merge-pathnames volume-label
                             (ensure-directory-pathname
                              (merge-pathnames lvm-volume-group #P"/dev/"))))))

(defmethod close-volume ((volume activated-lvm-logical-volume))
  (mrun "lvchange" "-an"
        (strcat (lvm-volume-group volume) "/" (volume-label volume))))

(defmethod create-volume ((volume lvm-logical-volume) (file null))
  (with-slots (volume-label lvm-volume-group) volume
    ;; Check that the VG exists.
    (unless (memstr= lvm-volume-group (all-lvm-volume-groups))
      (failed-change "Looks like no PVs for VG ~A?" lvm-volume-group))
    ;; Create the LV.
    (mrun :inform "lvcreate" "-Wn"
          (if (and (slot-boundp volume 'volume-size)
                   (eql (volume-size volume) :remaining))
              '("-l" "100%FREE")
              `("-L" ,(format nil "~DM" (volume-minimum-size volume))))
          lvm-volume-group "-n" volume-label)))

(defprop host-lvm-logical-volumes-exist :lisp ()
  (:desc "Host LVM logical volumes all exist")
  (:hostattrs (os:required 'os:linux))
  (:apply
   (assert-remote-euid-root)
   (let* ((existing-lvs
            (loop for (lv vg) in (mapcar #'words (cdr (runlines "lvs")))
                  collect (cons lv vg)))
          (to-create
            ;; LVs are TOP-LEVEL-VOLUMEs.
            (loop for volume in (get-hostattrs :volumes)
                  when (subtypep (class-of volume) 'lvm-logical-volume)
                    unless (member (cons (volume-label volume)
                                         (lvm-volume-group volume))
                                   existing-lvs :test #'equal)
                      collect volume))
          (to-mount
            (loop for volume in to-create
                  nconc (loop for volume
                                in (subvolumes-of-type 'filesystem volume)
                              when (slot-boundp volume 'mount-point)
                                collect volume))))
     (if to-create
         (prog2
             (ignoring-hostattrs
              (consfigurator.property.fstab:has-entries-for-volumes to-create))
             (create-volumes-and-contents to-create)
           (dolist (volume to-create)
             (open-volume volume nil))
           (dolist (volume to-mount)
             (consfigurator.property.mount:mounted
              :target (mount-point volume))))
         :no-change))))


;;;; Filesystems

(defparameter *mount-below* #P"/"
  "Prefix for all filesystem mount points.  Bound by functions to request that
filesystems be mounted relative to a different filesystem root, e.g. under a
chroot.")

(defclass filesystem (volume)
  ((mount-point :type pathname :initarg :mount-point :accessor mount-point)
   (mount-options
    :type list :initform nil :initarg :mount-options :accessor mount-options)
   (extra-space
    :type integer :initform 0 :initarg :extra-space :accessor extra-space
    :documentation
    "When creating the filesystem to accommodate a directory tree whose size is
already known, add this many whole mebibytes of extra free space where
possible.  Ignored if VOLUME-SIZE is also bound."))
  (:documentation
   "A block device containing a filesystem, which can be mounted."))

(defclass-opened-volume mounted-filesystem (filesystem))

(defmethod open-volume ((volume filesystem) (file pathname))
  (let* ((mount-point (chroot-pathname (mount-point volume) *mount-below*))
         (opened-volume (make-opened-volume volume file)))
    (setf (mount-point opened-volume) mount-point)
    (file:directory-exists mount-point)
    (mrun "mount" file mount-point)
    opened-volume))

(defmethod close-volume ((volume mounted-filesystem))
  (mrun "umount" (device-file volume)))

(defclass ext4-filesystem (filesystem)
  ((mount-options :initform '("relatime"))))

(defclass-opened-volume
    mounted-ext4-filesystem (ext4-filesystem mounted-filesystem))

(defmethod create-volume ((volume ext4-filesystem) (file pathname))
  (mrun :inform
        "mkfs.ext4" file (and (slot-boundp volume 'volume-label)
                              `("-L" ,(volume-label volume)))))

(defclass fat32-filesystem (filesystem) ())

(defclass-opened-volume
    mounted-fat32-filesystem (fat32-filesystem mounted-filesystem))

(defmethod create-volume ((volume fat32-filesystem) (file pathname))
  (mrun :inform
        "mkdosfs" "-F" "32" (and (slot-boundp volume 'volume-label)
                                 `("-n" ,(volume-label volume)))
        file))


;;;; Other volumes which can be made accessible as block devices

(defclass luks-container (volume)
  ((luks-passphrase-iden1
    :type string :initform "--luks-passphrase" :initarg :luks-passphrase-iden1)
   (luks-type
    :type string :initform "luks" :initarg :luks-type :accessor luks-type
    :documentation
    "The value of the --type parameter to cryptsetup luksFormat.
Note that GRUB2 older than 2.06 cannot open the default LUKS2 format, so
specify \"luks1\" if this is needed.")
   (cryptsetup-options
    :type list :initform nil :initarg :cryptsetup-options
    :documentation
    "Extra arguments to pass to cryptsetup(8) when creating the volume, such as
'--cipher'.  Use the LUKS-TYPE slot for '--type'.")
   (crypttab-options
    :type list :initform '("luks" "discard" "initramfs")
    :initarg :crypttab-options :accessor crypttab-options)
   (crypttab-keyfile :initarg :crypttab-keyfile :accessor crypttab-keyfile)))

(defclass-opened-volume opened-luks-container (luks-container))

(defmethod volume-required-data ((volume luks-container))
  (with-slots (luks-passphrase-iden1 volume-label) volume
    (list (cons luks-passphrase-iden1 volume-label))))

(defmethod open-volume ((volume luks-container) (file pathname))
  (with-slots (luks-passphrase-iden1 volume-label) volume
    (unless (and (stringp volume-label) (plusp (length volume-label)))
      (failed-change "LUKS volume has invalid VOLUME-LABEL."))
    (mrun "cryptsetup" "-d" "-" "luksOpen" file volume-label
          :input (get-data-string luks-passphrase-iden1 volume-label))
    (make-opened-volume volume
                        (merge-pathnames volume-label #P"/dev/mapper/"))))

(defmethod create-volume ((volume luks-container) (file pathname))
  (with-slots
        (luks-passphrase-iden1 volume-label luks-type cryptsetup-options)
      volume
    (mrun :inform
          :input (get-data-string luks-passphrase-iden1 (volume-label volume))
          "cryptsetup" "--type" luks-type
          (and (member luks-type '("luks" "luks2") :test #'string=)
               `("--label" ,volume-label))
          cryptsetup-options
          "luksFormat" file "-")))

(defmethod close-volume ((volume opened-luks-container))
  (mrun "cryptsetup" "luksClose" (device-file volume)))

(defclass linux-swap (volume) ())

(defmethod create-volume ((volume linux-swap) (file pathname))
  (mrun "mkswap" file))


;;;; Recursive operations

(defmacro with-mount-below (form)
  "Avoid establishing any binding for *MOUNT-BELOW* when the caller did not
explicitly request one."
  `(if mount-below-supplied-p
       (let ((*mount-below* mount-below)) ,form)
       ,form))

(defun open-volumes-and-contents
    (volumes &key (mount-below nil mount-below-supplied-p))
  "Where each of VOLUMES is a VOLUME which may be opened by calling OPEN-VOLUME
with NIL as the second argument, recursively open each of VOLUMES and any
contents thereof, and return a list of the volumes that were opened, in the
order in which they should be closed, and as a second value, a corresponding
list of the immediate parents of each opened volume.  MOUNT-BELOW specifies a
pathname to prefix to mount points when opening FILESYSTEM volumes.

Also return as third and fourth values a list of volumes encountered that were
already open and a corresponding list of their immediate parents.

Calling this function can be useful for testing at the REPL, but code should
normally use WITH-OPEN-VOLUMES or WITH-OPENED-VOLUMES.

If an error is signalled while the attempt to open volumes is in progress, a
single attempt will be made to close all volumes opened up to that point."
  (let
      (opened-volumes opened-parents already-open already-parents filesystems)
    (handler-case
        (labels
            ((open-volume-and-contents (volume file parent)
               ;; Postpone filesystems until the end so that we can sort
               ;; them before mounting, to avoid unintended shadowing.
               (if (subtypep (type-of volume) 'filesystem)
                   (push (list parent volume file) filesystems)
                   (multiple-value-bind (opened opened-contents)
                       (open-volume volume file)
                     (let ((opened-contents-parents
                             (make-list (length opened-contents)
                                        :initial-element volume)))
                       ;; Don't queue for closure volumes which were already
                       ;; open before we began.
                       (if (subtypep (class-of volume) 'opened-volume)
                           (setq opened-volumes
                                 (append opened-contents opened-volumes)
                                 opened-parents
                                 (nconc opened-contents-parents
                                        opened-parents)
                                 already-open
                                 (cons volume already-open)
                                 already-parents
                                 (cons parent already-parents))
                           (setq opened-volumes
                                 (append opened-contents
                                         (cons opened opened-volumes))
                                 opened-parents
                                 (nconc opened-contents-parents
                                        (cons parent opened-parents)))))
                     (dolist (opened-volume (or opened-contents `(,opened)))
                       (when (slot-boundp opened-volume 'volume-contents)
                         (open-volume-and-contents
                          (volume-contents opened-volume)
                          (device-file opened-volume)
                          opened-volume)))))))
          (mapc (rcurry #'open-volume-and-contents nil nil) volumes)
          ;; Note that filesystems never have any VOLUME-CONTENTS to open.
          (with-mount-below
              (dolist (filesystem
                       (nreverse
                        (sort filesystems #'subpathp
                              :key (compose #'ensure-directory-pathname
                                            #'mount-point
                                            #'cadr))))
                (push (pop filesystem) opened-parents)
                (push (apply #'open-volume filesystem) opened-volumes)))
          (values opened-volumes opened-parents already-open already-parents))
      (serious-condition (condition)
        (unwind-protect (mapc #'close-volume opened-volumes)
          (error condition))))))

(defmacro with-open-volumes ((volumes
                              &key
                                (mount-below nil mount-below-supplied-p)
                                opened-volumes)
                             &body forms)
  "Where each of VOLUMES is a VOLUME which may be opened by calling OPEN-VOLUME
with NIL as the second argument, recursively open each of VOLUMES and any
contents thereof, execute forms, and close all volumes that were opened.

MOUNT-BELOW specifies a pathname to prefix to mount points when opening
FILESYSTEM volumes.  OPENED-VOLUMES specifies a symbol to which a list of all
volumes that were opened will be bound, which can be used to do things like
populate /etc/fstab and /etc/crypttab.  Do not modify this list."
  (let ((opened-volumes (or opened-volumes (gensym))))
    `(let ((,opened-volumes (open-volumes-and-contents
                             ,volumes
                             ,@(and mount-below-supplied-p
                                    `(:mount-below ,mount-below)))))
       (unwind-protect (progn ,@forms)
         (mrun "sync")
         (mapc #'close-volume ,opened-volumes)))))

(defmacro with-opened-volumes
    ((volumes &key (mount-below nil mount-below-supplied-p) leave-open)
     &body propapps)
  "Macro property combinator.  Where each of VOLUMES is a VOLUME which may be
opened by calling OPEN-VOLUME with NIL as the second argument, recursively
open each of VOLUMES and any contents thereof, apply PROPAPPS, and, unless
LEAVE-OPEN, close all volumes that were opened.

MOUNT-BELOW specifies a pathname to prefix to mount points when opening
FILESYSTEM volumes.  During the application of PROPAPPS, all
'DISK:OPENED-VOLUMES and 'DISK:OPENED-VOLUME-PARENTS connattrs are replaced
with lists of the volumes that were opened/already open and corresponding
immediate parent volumes."
  `(with-opened-volumes*
     ',volumes
     ,(if (cdr propapps) `(eseqprops ,@propapps) (car propapps))
     ,@(and mount-below-supplied-p `(:mount-below ,mount-below))
     :leave-open ,leave-open))

(define-function-property-combinator with-opened-volumes*
    (volumes propapp &key (mount-below nil mount-below-supplied-p) leave-open)
  (:retprop
   :type (propapp-type propapp)
   :hostattrs (lambda-ignoring-args
                (require-volumes-data volumes)
                (propapp-attrs propapp))
   :apply
   (lambda-ignoring-args
     (multiple-value-bind
           (opened-volumes opened-parents already-open already-parents)
         (apply #'open-volumes-and-contents
                `(,volumes ,@(and mount-below-supplied-p
                                  `(:mount-below ,mount-below))))
       (with-connattrs
           ('opened-volumes (append opened-volumes already-open)
            'opened-volume-parents (append opened-parents already-parents))
         (unwind-protect (apply-propapp propapp)
           (mrun "sync")
           (unless leave-open (mapc #'close-volume opened-volumes))))))
   :args (cdr propapp)))

(defun create-volumes-and-contents (volumes &optional files)
  "Where each of VOLUMES is a VOLUME which may be created by calling
CREATE-VOLUME with the corresponding entry of FILES, or NIL, as a second
argument, recursively create each of VOLUMES and any contents thereof.
**THIS FUNCTION UNCONDITIONALLY FORMATS DISKS, POTENTIALLY DESTROYING DATA.**"
  (let (opened-volumes)
    (labels
        ((create-volume-and-contents
             (volume file
              &aux
                (already-opened (subtypep (class-of volume) 'opened-volume)))
           (unless already-opened
             (create-volume volume file))
           (when (slot-boundp volume 'volume-contents)
             (multiple-value-bind (opened opened-contents)
                 (open-volume volume file)
               (setq opened-volumes
                     (append opened-contents
                             ;; Don't queue for closure volumes which were
                             ;; already open before we began.
                             (if already-opened
                                 opened-volumes
                                 (cons opened opened-volumes))))
               (if opened-contents
                   (dolist (opened-volume opened-contents)
                     (when (slot-boundp opened-volume 'volume-contents)
                       (create-volume-and-contents
                        (volume-contents opened-volume)
                        (device-file opened-volume))))
                   (create-volume-and-contents
                    (volume-contents opened) (device-file opened)))))))
      (unwind-protect
           (mapc #'create-volume-and-contents
                 volumes (loop repeat (length volumes) collect (pop files)))
        (mrun "sync")
        (mapc #'close-volume opened-volumes)))))


;;;; Properties

(defmacro has-volumes (&rest volume-specifications)
  "Specify non-removable volumes normally accessible to the kernel on this host.

The order of the list of volumes is significant: it is the order in which
attempts to open all of the volumes should be made.  So, for example, any LVM
volume groups should occur later in the list than the partitions containing
the LVM physical volumes corresponding to those volume groups."
  `(has-volumes* (volumes ,@volume-specifications)))

(defprop has-volumes* :posix (volumes)
  (:desc "Has specified volumes.")
  (:hostattrs
   (os:required 'os:linux)
   (push-hostattrs :volumes volumes)))

;; TODO This should probably be in another package, and exported from there.
(defproplist caches-cleaned :posix ()
  "Clean all caches we know how to clean in preparation for image creation."
  (:desc "Caches cleaned")
  (file:data-cache-purged)
  (os:typecase
    (debianlike (apt:cache-cleaned))))

(defprop %raw-image-created :lisp (volumes &key chroot rebuild)
  (:desc (declare (ignore volumes chroot rebuild))
         #?"Created raw disk image & other volumes")
  (:hostattrs
   (require-volumes-data volumes)
   ;; We require GNU du(1).
   (os:required 'os:linux))
  (:check
   (declare (ignore chroot))
   (and
    (not rebuild)
    (file-exists-p
     (image-file
      (find-if (rcurry #'subtypep 'raw-disk-image) volumes :key #'type-of)))))
  (:apply
   (declare (ignore rebuild))
   (multiple-value-bind (mount-points volumes)
       ;; Find all mount points, and make modifiable copies of volumes
       ;; containing filesystems without VOLUME-SIZE, which we'll set.
       (loop for volume in volumes
             for filesystems
               = (delete-if-not (rcurry #'slot-boundp 'mount-point)
                                (subvolumes-of-type 'filesystem volume))
             nconc (mapcar #'mount-point filesystems) into mount-points
             if (loop for filesystem in filesystems
                        thereis (not (slot-boundp filesystem 'volume-size)))
               collect (copy-volume-and-contents volume) into volumes
             else collect volume into volumes
             finally (return (values mount-points volumes)))
     ;; Do the VOLUME-SIZE updates.  For now we make the assumption that a
     ;; copy of the files made by rsync will fit in a disk of 1.1 times the
     ;; size of however much space the files are taking up on whatever
     ;; filesystem underlies the chroot.  An alternative would be to find the
     ;; actual size of each file's data and round it up to the block size of
     ;; FILESYSTEM, which could be stored in a slot.  Since some filesystems
     ;; are able to store more than one file per block, we would probably want
     ;; a method on filesystem types to compute the expected size the file
     ;; will take up, call that on each file, and sum.
     (dolist (filesystem
              (mapcan (curry #'subvolumes-of-type 'filesystem) volumes))
       (when (and (slot-boundp filesystem 'mount-point)
                  (not (slot-boundp filesystem 'volume-size)))
         (let ((dir (mount-point filesystem)))
           (setf (volume-size filesystem)
                 (+ (ceiling
                     (* 1.1
                        (parse-integer
                         (car
                          (split-string
                           (run "du" "-msx" (chroot-pathname dir chroot)
                                (loop for mount-point in mount-points
                                      unless (eql mount-point dir)
                                        collect (strcat "--exclude="
                                                        (unix-namestring
                                                         (chroot-pathname
                                                          mount-point chroot))
                                                        "/*"))))))))
                    (extra-space filesystem))))))
     ;; Finally, create the volumes.
     (create-volumes-and-contents volumes))))

(defun image-chroot (image-pathname)
  (ensure-directory-pathname
   (strcat (unix-namestring image-pathname) ".chroot")))

(defun host-volumes-just-one-physical-disk (host fun)
  (loop
    with found
    for volume in (get-hostattrs :volumes (preprocess-host host))
    for physical-disk-p = (subtypep (type-of volume) 'physical-disk)
    if (and physical-disk-p (not found) (slot-boundp volume 'volume-contents))
      do (setq found t)
      and collect (aprog1 (copy-volume-and-contents volume) (funcall fun it))
    else unless physical-disk-p
           collect volume
    finally
       (unless found
         (inapplicable-property
          "Volumes list for host has no DISK:PHYSICAL-DISK with contents."))))

(defpropspec raw-image-built-for :lisp
    (options host image-pathname &key rebuild)
  "Build a raw disk image for HOST at IMAGE-PATHNAME.
The image corresponds to the first DISK:PHYSICAL-DISK entry in the host's
volumes, as specified using DISK:HAS-VOLUMES; there must be at least one such
entry.  Other DISK:PHYSICAL-DISK entries will be ignored, so ensure that none
of the properties of the host will write to areas of the filesystem where
filesystems stored on other physical disks would normally be mounted.

OPTIONS will be passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see.

In most cases you will need to ensure that HOST has properties which do at
least the following:

  - declare the host's OS

  - install a kernel

  - install the binaries/packages needed to install the host's bootloader to
    its volumes (usually with INSTALLER:BOOTLOADER-BINARIES-INSTALLED).

Unless REBUILD, the image will not be repartitioned even if the specification
of the host's volumes changes, although the contents of the image's
filesystems will be incrementally updated when other properties change."
  (:desc #?"Built image for ${(get-hostname host)} @ ${image-pathname}")
  (let ((chroot (image-chroot image-pathname))
        (volumes (host-volumes-just-one-physical-disk
                  host (lambda (volume)
                         (change-class volume 'raw-disk-image)
                         (setf (image-file volume) image-pathname)))))
    `(on-change (eseqprops
                 ,(propapp (chroot:os-bootstrapped-for. options chroot host
                             (caches-cleaned)))
                 (%raw-image-created
                  ,volumes :chroot ,chroot :rebuild ,rebuild))
       (consfigurator.property.installer:chroot-installed-to-volumes-for
        ,host ,chroot ,volumes))))

(defprop %squashfsed :posix (chroot image &optional (compression "xz"))
  (:apply
   (file:does-not-exist image)
   (with-remote-temporary-file (excludes)
     (write-remote-file
      excludes (format nil "~@{~&~A~}" "/boot" "/proc" "/dev" "/sys" "/run"))
     (run :inform "nice" "mksquashfs" chroot image
          "-no-progress" "-comp" compression "-ef" excludes))))

;; Based on live-wrapper, and some help from this guide:
;;     <https://willhaley.com/blog/custom-debian-live-environment/>
(defpropspec debian-live-iso-built :lisp (options image-pathname properties)
  "Build a Debian Live hybrid ISO at IMAGE-PATHNAME for a host with properties
PROPERTIES, which should specify, at a minimum, the operating system for the
live system.  OPTIONS is a plist of keyword parameters:

  - :CHROOT-OPTIONS -- passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see.

Currently only BIOS boot is implemented."
  (:desc #?"Debian Live ISO built @ ${image-pathname}")
  (destructuring-bind
      (&key chroot-options
       &aux (chroot (image-chroot image-pathname))
         (iso-root (ensure-directory-pathname
                    (strcat (unix-namestring image-pathname) ".cd")))
         (isolinux (merge-pathnames "isolinux/" iso-root))
         (squashfs (merge-pathnames "live/filesystem.squashfs" iso-root))
         (host (make-host
                :hostattrs '(:hostname ("debian"))
                :propspec
                (append-propspecs
                 properties
                 (make-propspec
                  :propspec
                  '(eseqprops
                    (apt:installed "initramfs-tools" "linux-image-amd64"
                     "live-boot" "task-laptop" "libnss-myhostname"
                     "syslinux-common" "isolinux")
                    (caches-cleaned))))))
         (host-arch (os:debian-architecture (get-hostattrs-car :os host))))
      options
    (unless (member host-arch '(:amd64))
      (inapplicable-property
       "Architecture ~A of live host not supported." host-arch))
    `(eseqprops
      (apt:installed "squashfs-tools" "xorriso")
      (file:directory-exists ,isolinux)
      (file:containing-directory-exists ,squashfs)
      (on-change (chroot:os-bootstrapped-for ,chroot-options ,chroot ,host)

        (%squashfsed ,chroot ,squashfs)

        ;; Copy the chroot's versions of bootloader binaries.
        (file:is-copy-of ,(merge-pathnames "isolinux.bin" isolinux)
                         ,(chroot-pathname "/usr/lib/ISOLINUX/isolinux.bin"
                                           chroot))
        ,@(loop for basename in '("ldlinux" "libcom32" "vesamenu" "libutil"
                                  "libutil" "libmenu" "libgpl" "hdt")
                for file = (strcat basename ".c32")
                collect
                `(file:is-copy-of
                  ,(merge-pathnames file isolinux)
                  ,(chroot-pathname
                    (merge-pathnames file "/usr/lib/syslinux/modules/bios/")
                    chroot)))

        ;; Copy the targets of the symlinks in the root of the chroot.
        (file:is-copy-of ,(merge-pathnames "live/vmlinuz" iso-root)
                         ,(merge-pathnames "vmlinuz" chroot))
        (file:is-copy-of ,(merge-pathnames "live/initrd.img" iso-root)
                         ,(merge-pathnames "initrd.img" chroot))

        (file:exists-with-content ,(merge-pathnames "isolinux.cfg" isolinux)
          ("UI vesamenu.c32"
           ""
           "MENU TITLE Live Boot Menu"
           "DEFAULT linux"
           "TIMEOUT 600"
           "MENU RESOLUTION 640 480"
           ""
           "LABEL linux"
           "  MENU LABEL Debian Live [BIOS/ISOLINUX]"
           "  MENU DEFAULT"
           "  KERNEL /live/vmlinuz"
           "  APPEND initrd=/live/initrd.img boot=live"
           ""
           "LABEL linux"
           "  MENU LABEL Debian Live [BIOS/ISOLINUX] (nomodeset)"
           "  MENU DEFAULT"
           "  KERNEL /live/vmlinuz"
           "  APPEND initrd=/live/initrd.img boot=live nomodeset"))

        (cmd:single
         :inform
         "xorriso" "-as" "mkisofs" "-iso-level" "3" "-o" ,image-pathname
         "-full-iso9660-filenames" "-volid" "DEBIAN_LIVE"
         "-isohybrid-mbr" ,(chroot-pathname "/usr/lib/ISOLINUX/isohdpfx.bin"
                                            chroot)

         "-eltorito-boot" "isolinux/isolinux.bin"
         "-no-emul-boot" "-boot-load-size" "4" "-boot-info-table"
         "--eltorito-catalog" "isolinux/isolinux.cat"

         ,iso-root)))))

(defprop host-volumes-created :lisp ()
  "Recursively create the volumes as specified by DISK:HAS-VOLUMES.
**THIS PROPERTY UNCONDITIONALLY FORMATS DISKS, POTENTIALLY DESTROYING DATA,
  EACH TIME IT IS APPLIED.**

Do not apply in DEFHOST.  Apply with DEPLOY-THESE/HOSTDEPLOY-THESE."
  (:desc "Host volumes created")
  (:apply (create-volumes-and-contents (get-hostattrs :volumes))))

;; TODO Possibly we want (a version of) this to not fail, but just do nothing,
;; if the relevant volume groups etc. are inactive?
(defproplist host-logical-volumes-exist :lisp ()
  "Create missing logical volumes, like LVM logical volumes and BTRFS
subvolumes, as specified by DISK:HAS-VOLUMES.  Does not delete or overwrite
anything, aside from editing /etc/fstab in some cases.  Intended to make it
easy to add new logical volumes by just editing the volumes specification.

For logical volumes containing instances of FILESYSTEM with a specified
MOUNT-POINT, ensure there's an /etc/fstab entry and try to mount.

Currently only handling of LVM logical volumes is implemented."
  (:desc "Host logical volumes all exist")
  (host-lvm-logical-volumes-exist))


;;;; Utilities

(defun parse-volume-size (volume-size-specification)
  (if (stringp volume-size-specification)
      (multiple-value-bind (match groups)
          (re:scan-to-strings #?/\A([0-9]+)([MGT])?\z/ volume-size-specification)
        (unless match
          (simple-program-error
           "~A is not a valid volume size." volume-size-specification))
        (* (parse-integer (elt groups 0))
           (eswitch ((elt groups 1) :test #'string=)
             ("M" 1)
             ("G" 1024)
             ("T" 1048576))))
      volume-size-specification))

(defmacro volumes (&body volume-specifications)
  "Return a list of instances of VOLUME, one for each element of
VOLUME-SPECIFICATIONS.  Each of VOLUME-SPECIFICATIONS is an (unquoted) list of
the form (TYPE &REST INITARGS).

TYPE is a symbol naming the volume type to be initialised.  If the symbol does
not name a subclass of VOLUME, it will be replaced with a symbol of the same
name in the DISK package; this allows type names to be used unqualified.

INITARGS is an even-length plist, possibly with a final additional element,
which is either another volume specification or an (unquoted) list of volume
specifications.  This becomes the VOLUME-CONTENTS of the VOLUME.

The following keys in INITARGS are handled specially:

    - :VOLUME-SIZE -- may be a string like \"100M\", \"2G\", \"1T\" which will
      be converted into a whole number of mebibytes.  \"M\", \"G\", and \"T\"
      are currently supported.

Example usage:

  (volumes
    (physical-disk
     (partitioned-volume
      ((partition
        :partition-typecode #xef00
        (fat32-filesystem
         :volume-size \"512M\"
         :mount-point #P\"/boot/efi\"))
       (partition
        (luks-container
         (lvm-physical-volume
          :volume-group \"vg_laptop\"))))))
    (lvm-logical-volume
       :volume-group \"vg_laptop\"
       :volume-label \"lv_laptop_root\"
       (ext4-filesystem :mount-point #P\"/\")))"
  (labels
      ((parse (spec)
         (unless (listp spec)
           (simple-program-error "~A is not a list." spec))
         (let* ((contentsp (not (evenp (length (cdr spec)))))
                (initargs
                  (if contentsp (butlast (cdr spec)) (cdr spec)))
                (contents (and contentsp (lastcar (cdr spec)))))
           (when (loop for key on initargs by #'cddr
                         thereis (and (eql (car key) :volume-size)))
             (setf (getf initargs :volume-size)
                   `(parse-volume-size ,(getf initargs :volume-size))))
           (when (and contents (not (listp contents)))
             (simple-program-error "~A is not a list." contents))
           `(make-instance
             ',(let ((class (find-class (car spec) nil)))
                 (if (and class (subtypep (class-name class) 'volume))
                     (car spec)
                     (intern (symbol-name (car spec))
                             (find-package :consfigurator.property.disk))))
             ,@initargs
             ,@(and contentsp
                    `(:volume-contents
                      ,(if (listp (car contents))
                           `(list ,@(mapcar #'parse contents))
                           (parse contents))))))))
    `(list ,@(mapcar #'parse volume-specifications))))