file-systems.scm 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (gnu system file-systems)
  19. #:use-module (ice-9 match)
  20. #:use-module (rnrs bytevectors)
  21. #:use-module (srfi srfi-1)
  22. #:use-module (srfi srfi-9)
  23. #:use-module (srfi srfi-9 gnu)
  24. #:use-module (guix records)
  25. #:use-module (gnu system uuid)
  26. #:re-export (uuid ;backward compatibility
  27. string->uuid
  28. uuid->string)
  29. #:export (file-system
  30. file-system?
  31. file-system-device
  32. file-system-title ;deprecated
  33. file-system-mount-point
  34. file-system-type
  35. file-system-needed-for-boot?
  36. file-system-flags
  37. file-system-options
  38. file-system-mount?
  39. file-system-check?
  40. file-system-create-mount-point?
  41. file-system-dependencies
  42. file-system-location
  43. file-system-type-predicate
  44. file-system-label
  45. file-system-label?
  46. file-system-label->string
  47. file-system->spec
  48. spec->file-system
  49. specification->file-system-mapping
  50. %pseudo-file-system-types
  51. %fuse-control-file-system
  52. %binary-format-file-system
  53. %shared-memory-file-system
  54. %pseudo-terminal-file-system
  55. %tty-gid
  56. %immutable-store
  57. %control-groups
  58. %elogind-file-systems
  59. %base-file-systems
  60. %container-file-systems
  61. <file-system-mapping>
  62. file-system-mapping
  63. file-system-mapping?
  64. file-system-mapping-source
  65. file-system-mapping-target
  66. file-system-mapping-writable?
  67. file-system-mapping->bind-mount
  68. %store-mapping
  69. %network-configuration-files
  70. %network-file-mappings))
  71. ;;; Commentary:
  72. ;;;
  73. ;;; Declaring file systems to be mounted.
  74. ;;;
  75. ;;; Note: this file system is used both in the Shepherd and on the "host
  76. ;;; side", so it must not include (gnu packages …) modules.
  77. ;;;
  78. ;;; Code:
  79. ;; File system declaration.
  80. (define-record-type* <file-system> %file-system
  81. make-file-system
  82. file-system?
  83. (device file-system-device) ; string | <uuid> | <file-system-label>
  84. (mount-point file-system-mount-point) ; string
  85. (type file-system-type) ; string
  86. (flags file-system-flags ; list of symbols
  87. (default '()))
  88. (options file-system-options ; string or #f
  89. (default #f))
  90. (mount? file-system-mount? ; Boolean
  91. (default #t))
  92. (needed-for-boot? %file-system-needed-for-boot? ; Boolean
  93. (default #f))
  94. (check? file-system-check? ; Boolean
  95. (default #t))
  96. (create-mount-point? file-system-create-mount-point? ; Boolean
  97. (default #f))
  98. (dependencies file-system-dependencies ; list of <file-system>
  99. (default '())) ; or <mapped-device>
  100. (location file-system-location
  101. (default (current-source-location))
  102. (innate)))
  103. ;; A file system label for use in the 'device' field.
  104. (define-record-type <file-system-label>
  105. (file-system-label label)
  106. file-system-label?
  107. (label file-system-label->string))
  108. (set-record-type-printer! <file-system-label>
  109. (lambda (obj port)
  110. (format port "#<file-system-label ~s>"
  111. (file-system-label->string obj))))
  112. (define-syntax report-deprecation
  113. (lambda (s)
  114. "Report the use of the now-deprecated 'title' field."
  115. (syntax-case s ()
  116. ((_ field)
  117. (let* ((source (syntax-source #'field))
  118. (file (and source (assq-ref source 'filename)))
  119. (line (and source
  120. (and=> (assq-ref source 'line) 1+)))
  121. (column (and source (assq-ref source 'column))))
  122. (format (current-error-port)
  123. "~a:~a:~a: warning: 'title' field is deprecated~%"
  124. file line column)
  125. #t)))))
  126. ;; Helper for 'process-file-system-declaration'.
  127. (define-syntax device-expression
  128. (syntax-rules (quote label uuid device)
  129. ((_ (quote label) dev)
  130. (file-system-label dev))
  131. ((_ (quote uuid) dev)
  132. (if (uuid? dev) dev (uuid dev)))
  133. ((_ (quote device) dev)
  134. dev)
  135. ((_ title dev)
  136. (case title
  137. ((label) (file-system-label dev))
  138. ((uuid) (uuid dev))
  139. (else dev)))))
  140. ;; Helper to interpret the now-deprecated 'title' field. Detect forms like
  141. ;; (title 'label), remove them, and adjust the 'device' field accordingly.
  142. ;; TODO: Remove this once 'title' has been deprecated long enough.
  143. (define-syntax process-file-system-declaration
  144. (syntax-rules (device title)
  145. ((_ () (rest ...) #f #f) ;no 'title' and no 'device' field
  146. (%file-system rest ...))
  147. ((_ () (rest ...) dev #f) ;no 'title' field
  148. (%file-system rest ... (device dev)))
  149. ((_ () (rest ...) dev titl) ;got a 'title' field
  150. (%file-system rest ...
  151. (device (device-expression titl dev))))
  152. ((_ ((title titl) rest ...) (previous ...) dev _)
  153. (begin
  154. (report-deprecation (title titl))
  155. (process-file-system-declaration (rest ...)
  156. (previous ...)
  157. dev titl)))
  158. ((_ ((device dev) rest ...) (previous ...) _ titl)
  159. (process-file-system-declaration (rest ...)
  160. (previous ...)
  161. dev titl))
  162. ((_ (field rest ...) (previous ...) dev titl)
  163. (process-file-system-declaration (rest ...)
  164. (previous ... field)
  165. dev titl))))
  166. (define-syntax-rule (file-system fields ...)
  167. (process-file-system-declaration (fields ...) () #f #f))
  168. (define (file-system-title fs) ;deprecated
  169. (match (file-system-device fs)
  170. ((? file-system-label?) 'label)
  171. ((? uuid?) 'uuid)
  172. ((? string?) 'device)))
  173. ;; Note: This module is used both on the build side and on the host side.
  174. ;; Arrange not to pull (guix store) and (guix config) because the latter
  175. ;; differs from user to user.
  176. (define (%store-prefix)
  177. "Return the store prefix."
  178. ;; Note: If we have (guix store database) in the search path and we do *not*
  179. ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
  180. ;; with one sub-module.
  181. (cond ((and=> (resolve-module '(guix store) #:ensure #f)
  182. (lambda (store)
  183. (module-variable store '%store-prefix)))
  184. =>
  185. (lambda (variable)
  186. ((variable-ref variable))))
  187. ((getenv "NIX_STORE")
  188. => identity)
  189. (else
  190. "/gnu/store")))
  191. (define %not-slash
  192. (char-set-complement (char-set #\/)))
  193. (define (file-prefix? file1 file2)
  194. "Return #t if FILE1 denotes the name of a file that is a parent of FILE2,
  195. where both FILE1 and FILE2 are absolute file name. For example:
  196. (file-prefix? \"/gnu\" \"/gnu/store\")
  197. => #t
  198. (file-prefix? \"/gn\" \"/gnu/store\")
  199. => #f
  200. "
  201. (and (string-prefix? "/" file1)
  202. (string-prefix? "/" file2)
  203. (let loop ((file1 (string-tokenize file1 %not-slash))
  204. (file2 (string-tokenize file2 %not-slash)))
  205. (match file1
  206. (()
  207. #t)
  208. ((head1 tail1 ...)
  209. (match file2
  210. ((head2 tail2 ...)
  211. (and (string=? head1 head2) (loop tail1 tail2)))
  212. (()
  213. #f)))))))
  214. (define (file-system-needed-for-boot? fs)
  215. "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
  216. store--e.g., if FS is the root file system."
  217. (or (%file-system-needed-for-boot? fs)
  218. (and (file-prefix? (file-system-mount-point fs) (%store-prefix))
  219. (not (memq 'bind-mount (file-system-flags fs))))))
  220. (define (file-system->spec fs)
  221. "Return a list corresponding to file-system FS that can be passed to the
  222. initrd code."
  223. (match fs
  224. (($ <file-system> device mount-point type flags options _ _ check?)
  225. (list (cond ((uuid? device)
  226. `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
  227. ((file-system-label? device)
  228. `(file-system-label ,(file-system-label->string device)))
  229. (else device))
  230. mount-point type flags options check?))))
  231. (define (spec->file-system sexp)
  232. "Deserialize SEXP, a list, to the corresponding <file-system> object."
  233. (match sexp
  234. ((device mount-point type flags options check?)
  235. (file-system
  236. (device (match device
  237. (('uuid (? symbol? type) (? bytevector? bv))
  238. (bytevector->uuid bv type))
  239. (('file-system-label (? string? label))
  240. (file-system-label label))
  241. (_
  242. device)))
  243. (mount-point mount-point) (type type)
  244. (flags flags) (options options)
  245. (check? check?)))))
  246. (define (specification->file-system-mapping spec writable?)
  247. "Read the SPEC and return the corresponding <file-system-mapping>. SPEC is
  248. a string of the form \"SOURCE\" or \"SOURCE=TARGET\". The former specifies
  249. that SOURCE from the host should be mounted at SOURCE in the other system.
  250. The latter format specifies that SOURCE from the host should be mounted at
  251. TARGET in the other system."
  252. (let ((index (string-index spec #\=)))
  253. (if index
  254. (file-system-mapping
  255. (source (substring spec 0 index))
  256. (target (substring spec (+ 1 index)))
  257. (writable? writable?))
  258. (file-system-mapping
  259. (source spec)
  260. (target spec)
  261. (writable? writable?)))))
  262. ;;;
  263. ;;; Common file systems.
  264. ;;;
  265. (define %pseudo-file-system-types
  266. ;; List of know pseudo file system types. This is used when validating file
  267. ;; system definitions.
  268. '("binfmt_misc" "cgroup" "debugfs" "devpts" "devtmpfs" "efivarfs" "fusectl"
  269. "hugetlbfs" "overlay" "proc" "securityfs" "sysfs" "tmpfs"))
  270. (define %fuse-control-file-system
  271. ;; Control file system for Linux' file systems in user-space (FUSE).
  272. (file-system
  273. (device "fusectl")
  274. (mount-point "/sys/fs/fuse/connections")
  275. (type "fusectl")
  276. (check? #f)))
  277. (define %binary-format-file-system
  278. ;; Support for arbitrary executable binary format.
  279. (file-system
  280. (device "binfmt_misc")
  281. (mount-point "/proc/sys/fs/binfmt_misc")
  282. (type "binfmt_misc")
  283. (check? #f)))
  284. (define %tty-gid
  285. ;; ID of the 'tty' group. Allocate it statically to make it easy to refer
  286. ;; to it from here and from the 'tty' group definitions.
  287. 996)
  288. (define %pseudo-terminal-file-system
  289. ;; The pseudo-terminal file system. It needs to be mounted so that
  290. ;; statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) expects (and
  291. ;; thus openpty(3) and its users, such as xterm.)
  292. (file-system
  293. (device "none")
  294. (mount-point "/dev/pts")
  295. (type "devpts")
  296. (check? #f)
  297. (needed-for-boot? #f)
  298. (create-mount-point? #t)
  299. (options (string-append "gid=" (number->string %tty-gid) ",mode=620"))))
  300. (define %shared-memory-file-system
  301. ;; Shared memory.
  302. (file-system
  303. (device "tmpfs")
  304. (mount-point "/dev/shm")
  305. (type "tmpfs")
  306. (check? #f)
  307. (flags '(no-suid no-dev))
  308. (options "size=50%") ;TODO: make size configurable
  309. (create-mount-point? #t)))
  310. (define %immutable-store
  311. ;; Read-only store to avoid users or daemons accidentally modifying it.
  312. ;; 'guix-daemon' has provisions to remount it read-write in its own name
  313. ;; space.
  314. (file-system
  315. (device (%store-prefix))
  316. (mount-point (%store-prefix))
  317. (type "none")
  318. (check? #f)
  319. (flags '(read-only bind-mount))))
  320. (define %control-groups
  321. (let ((parent (file-system
  322. (device "cgroup")
  323. (mount-point "/sys/fs/cgroup")
  324. (type "tmpfs")
  325. (check? #f))))
  326. (cons parent
  327. (map (lambda (subsystem)
  328. (file-system
  329. (device "cgroup")
  330. (mount-point (string-append "/sys/fs/cgroup/" subsystem))
  331. (type "cgroup")
  332. (check? #f)
  333. (options subsystem)
  334. (create-mount-point? #t)
  335. ;; This must be mounted after, and unmounted before the
  336. ;; parent directory.
  337. (dependencies (list parent))))
  338. '("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
  339. "blkio" "perf_event")))))
  340. (define %elogind-file-systems
  341. ;; We don't use systemd, but these file systems are needed for elogind,
  342. ;; which was extracted from systemd.
  343. (append
  344. (list (file-system
  345. (device "none")
  346. (mount-point "/run/systemd")
  347. (type "tmpfs")
  348. (check? #f)
  349. (flags '(no-suid no-dev no-exec))
  350. (options "mode=0755")
  351. (create-mount-point? #t))
  352. (file-system
  353. (device "none")
  354. (mount-point "/run/user")
  355. (type "tmpfs")
  356. (check? #f)
  357. (flags '(no-suid no-dev no-exec))
  358. (options "mode=0755")
  359. (create-mount-point? #t))
  360. ;; Elogind uses cgroups to organize processes, allowing it to map PIDs
  361. ;; to sessions. Elogind's cgroup hierarchy isn't associated with any
  362. ;; resource controller ("subsystem").
  363. (file-system
  364. (device "cgroup")
  365. (mount-point "/sys/fs/cgroup/elogind")
  366. (type "cgroup")
  367. (check? #f)
  368. (options "none,name=elogind")
  369. (create-mount-point? #t)
  370. (dependencies (list (car %control-groups)))))
  371. %control-groups))
  372. (define %base-file-systems
  373. ;; List of basic file systems to be mounted. Note that /proc and /sys are
  374. ;; currently mounted by the initrd.
  375. (list %pseudo-terminal-file-system
  376. %shared-memory-file-system
  377. %immutable-store))
  378. ;; File systems for Linux containers differ from %base-file-systems in that
  379. ;; they impose additional restrictions such as no-exec or need different
  380. ;; options to function properly.
  381. ;;
  382. ;; The file system flags and options conform to the libcontainer
  383. ;; specification:
  384. ;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem
  385. (define %container-file-systems
  386. (list
  387. ;; Pseudo-terminal file system.
  388. (file-system
  389. (device "none")
  390. (mount-point "/dev/pts")
  391. (type "devpts")
  392. (flags '(no-exec no-suid))
  393. (needed-for-boot? #t)
  394. (create-mount-point? #t)
  395. (check? #f)
  396. (options "newinstance,ptmxmode=0666,mode=620"))
  397. ;; Shared memory file system.
  398. (file-system
  399. (device "tmpfs")
  400. (mount-point "/dev/shm")
  401. (type "tmpfs")
  402. (flags '(no-exec no-suid no-dev))
  403. (options "mode=1777,size=65536k")
  404. (needed-for-boot? #t)
  405. (create-mount-point? #t)
  406. (check? #f))
  407. ;; Message queue file system.
  408. (file-system
  409. (device "mqueue")
  410. (mount-point "/dev/mqueue")
  411. (type "mqueue")
  412. (flags '(no-exec no-suid no-dev))
  413. (needed-for-boot? #t)
  414. (create-mount-point? #t)
  415. (check? #f))))
  416. ;;;
  417. ;;; Shared file systems, for VMs/containers.
  418. ;;;
  419. ;; Mapping of host file system SOURCE to mount point TARGET in the guest.
  420. (define-record-type* <file-system-mapping> file-system-mapping
  421. make-file-system-mapping
  422. file-system-mapping?
  423. (source file-system-mapping-source) ;string
  424. (target file-system-mapping-target) ;string
  425. (writable? file-system-mapping-writable? ;Boolean
  426. (default #f)))
  427. (define (file-system-mapping->bind-mount mapping)
  428. "Return a file system that realizes MAPPING, a <file-system-mapping>, using
  429. a bind mount."
  430. (match mapping
  431. (($ <file-system-mapping> source target writable?)
  432. (file-system
  433. (mount-point target)
  434. (device source)
  435. (type "none")
  436. (flags (if writable?
  437. '(bind-mount)
  438. '(bind-mount read-only)))
  439. (check? #f)
  440. (create-mount-point? #t)))))
  441. (define %store-mapping
  442. ;; Mapping of the host's store into the guest.
  443. (file-system-mapping
  444. (source (%store-prefix))
  445. (target (%store-prefix))
  446. (writable? #f)))
  447. (define %network-configuration-files
  448. ;; List of essential network configuration files.
  449. '("/etc/resolv.conf"
  450. "/etc/nsswitch.conf"
  451. "/etc/services"
  452. "/etc/hosts"))
  453. (define %network-file-mappings
  454. ;; List of file mappings for essential network files.
  455. (filter-map (lambda (file)
  456. (file-system-mapping
  457. (source file)
  458. (target file)
  459. ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a
  460. ;; symlink to a file in a tmpfs which, for an unknown reason,
  461. ;; cannot be bind mounted read-only within the container.
  462. (writable? (string=? file "/etc/resolv.conf"))))
  463. %network-configuration-files))
  464. (define (file-system-type-predicate type)
  465. "Return a predicate that, when passed a file system, returns #t if that file
  466. system has the given TYPE."
  467. (lambda (fs)
  468. (string=? (file-system-type fs) type)))
  469. ;;; file-systems.scm ends here