gnu/system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014 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
  19 (define-module (gnu system)
  20   #:use-module (guix store)
  21   #:use-module (guix monads)
  22   #:use-module (guix gexp)
  23   #:use-module (guix records)
  24   #:use-module (guix packages)
  25   #:use-module (guix derivations)
  26   #:use-module (gnu packages base)
  27   #:use-module (gnu packages bash)
  28   #:use-module (gnu packages admin)
  29   #:use-module (gnu packages linux)
  30   #:use-module (gnu packages package-management)
  31   #:use-module (gnu services)
  32   #:use-module (gnu services dmd)
  33   #:use-module (gnu services base)
  34   #:use-module (gnu system grub)
  35   #:use-module (gnu system shadow)
  36   #:use-module (gnu system linux)
  37   #:use-module (gnu system linux-initrd)
  38   #:use-module (gnu system file-systems)
  39   #:use-module (ice-9 match)
  40   #:use-module (srfi srfi-1)
  41   #:use-module (srfi srfi-26)
  42   #:export (operating-system
  43             operating-system?
  44
  45             operating-system-bootloader
  46             operating-system-services
  47             operating-system-user-services
  48             operating-system-packages
  49             operating-system-host-name
  50             operating-system-kernel
  51             operating-system-initrd
  52             operating-system-users
  53             operating-system-groups
  54             operating-system-issue
  55             operating-system-packages
  56             operating-system-timezone
  57             operating-system-locale
  58             operating-system-file-systems
  59
  60             operating-system-derivation
  61             operating-system-profile
  62             operating-system-grub.cfg))
  63
  64 ;;; Commentary:
  65 ;;;
  66 ;;; This module supports whole-system configuration.
  67 ;;;
  68 ;;; Code:
  69
  70 ;; System-wide configuration.
  71 ;; TODO: Add per-field docstrings/stexi.
  72 (define-record-type* <operating-system> operating-system
  73   make-operating-system
  74   operating-system?
  75   (kernel operating-system-kernel                 ; package
  76           (default linux-libre))
  77   (bootloader operating-system-bootloader)        ; <grub-configuration>
  78
  79   (initrd operating-system-initrd                 ; (list fs) -> M derivation
  80           (default qemu-initrd))
  81
  82   (host-name operating-system-host-name)          ; string
  83
  84   (file-systems operating-system-file-systems     ; list of fs
  85                 (default '()))
  86
  87   (users operating-system-users                   ; list of user accounts
  88          (default '()))
  89   (groups operating-system-groups                 ; list of user groups
  90           (default (list (user-group
  91                           (name "root")
  92                           (id 0)))))
  93
  94   (skeletons operating-system-skeletons           ; list of name/monadic value
  95              (default (default-skeletons)))
  96   (issue operating-system-issue                   ; string
  97          (default %default-issue))
  98
  99   (packages operating-system-packages             ; list of (PACKAGE OUTPUT...)
 100             (default (list coreutils              ; or just PACKAGE
 101                            grep
 102                            sed
 103                            findutils
 104                            guile
 105                            bash
 106                            (@ (gnu packages dmd) dmd)
 107                            guix
 108                            tzdata)))
 109
 110   (timezone operating-system-timezone)            ; string
 111   (locale   operating-system-locale)              ; string
 112
 113   (services operating-system-user-services        ; list of monadic services
 114             (default %base-services))
 115
 116   (pam-services operating-system-pam-services     ; list of PAM services
 117                 (default (base-pam-services)))
 118   (setuid-programs operating-system-setuid-programs
 119                    (default %setuid-programs))    ; list of string-valued gexps
 120
 121   (sudoers operating-system-sudoers               ; /etc/sudoers contents
 122            (default %sudoers-specification)))
 123
 124 \f
 125 ;;;
 126 ;;; Derivation.
 127 ;;;
 128
 129 (define* (union inputs
 130                 #:key (guile (%guile-for-build)) (system (%current-system))
 131                 (name "union"))
 132   "Return a derivation that builds the union of INPUTS.  INPUTS is a list of
 133 input tuples."
 134   (define builder
 135     #~(begin
 136         (use-modules (guix build union))
 137
 138         (define inputs '#$inputs)
 139
 140         (setvbuf (current-output-port) _IOLBF)
 141         (setvbuf (current-error-port) _IOLBF)
 142
 143         (format #t "building union `~a' with ~a packages...~%"
 144                 #$output (length inputs))
 145         (union-build #$output inputs)))
 146
 147   (gexp->derivation name builder
 148                     #:system system
 149                     #:modules '((guix build union))
 150                     #:guile-for-build guile
 151                     #:local-build? #t))
 152
 153 (define* (file-union name files)
 154   "Return a derivation that builds a directory containing all of FILES.  Each
 155 item in FILES must be a list where the first element is the file name to use
 156 in the new directory, and the second element is a gexp denoting the target
 157 file."
 158   (define builder
 159     #~(begin
 160         (mkdir #$output)
 161         (chdir #$output)
 162         #$@(map (match-lambda
 163                  ((target source)
 164                   #~(symlink #$source #$target)))
 165                 files)))
 166
 167   (gexp->derivation name builder))
 168
 169 \f
 170 ;;;
 171 ;;; Services.
 172 ;;;
 173
 174 (define (other-file-system-services os)
 175   "Return file system services for the file systems of OS that are not marked
 176 as 'needed-for-boot'."
 177   (define file-systems
 178     (remove (lambda (fs)
 179               (or (file-system-needed-for-boot? fs)
 180                   (string=? "/" (file-system-mount-point fs))))
 181             (operating-system-file-systems os)))
 182
 183   (sequence %store-monad
 184             (map (match-lambda
 185                   (($ <file-system> device title target type flags opts
 186                                     #f check?)
 187                    (file-system-service device target type
 188                                         #:title title
 189                                         #:check? check?
 190                                         #:options opts)))
 191                  file-systems)))
 192
 193 (define (essential-services os)
 194   "Return the list of essential services for OS.  These are special services
 195 that implement part of what's declared in OS are responsible for low-level
 196 bookkeeping."
 197   (mlet* %store-monad ((root-fs   (root-file-system-service))
 198                        (other-fs  (other-file-system-services os))
 199                        (procs     (user-processes-service
 200                                    (map (compose first service-provision)
 201                                         other-fs)))
 202                        (host-name (host-name-service
 203                                    (operating-system-host-name os))))
 204     (return (cons* host-name procs root-fs other-fs))))
 205
 206 (define (operating-system-services os)
 207   "Return all the services of OS, including \"internal\" services that do not
 208 explicitly appear in OS."
 209   (mlet %store-monad
 210       ((user      (sequence %store-monad (operating-system-user-services os)))
 211        (essential (essential-services os)))
 212     (return (append essential user))))
 213
 214 \f
 215 ;;;
 216 ;;; /etc.
 217 ;;;
 218
 219 (define %default-issue
 220   ;; Default contents for /etc/issue.
 221   "
 222 This is the GNU system.  Welcome.\n")
 223
 224 (define* (etc-directory #:key
 225                         (locale "C") (timezone "Europe/Paris")
 226                         (issue "Hello!\n")
 227                         (skeletons '())
 228                         (pam-services '())
 229                         (profile "/run/current-system/profile")
 230                         (sudoers ""))
 231   "Return a derivation that builds the static part of the /etc directory."
 232   (mlet* %store-monad
 233       ((pam.d      (pam-services->directory pam-services))
 234        (sudoers    (text-file "sudoers" sudoers))
 235        (login.defs (text-file "login.defs" "# Empty for now.\n"))
 236        (shells     (text-file "shells"            ; used by xterm and others
 237                               "\
 238 /bin/sh
 239 /run/current-system/profile/bin/sh
 240 /run/current-system/profile/bin/bash\n"))
 241        (issue      (text-file "issue" issue))
 242
 243        ;; TODO: Generate bashrc from packages' search-paths.
 244        (bashrc    (text-file* "bashrc"  "
 245 export PS1='\\u@\\h\\$ '
 246
 247 export LC_ALL=\"" locale "\"
 248 export TZ=\"" timezone "\"
 249 export TZDIR=\"" tzdata "/share/zoneinfo\"
 250
 251 export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin
 252 export PATH=/run/setuid-programs:/run/current-system/profile/sbin:$PATH
 253 export CPATH=$HOME/.guix-profile/include:" profile "/include
 254 export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
 255 alias ls='ls -p --color'
 256 alias ll='ls -l'
 257 "))
 258        (skel      (skeleton-directory skeletons)))
 259     (file-union "etc"
 260                 `(("services" ,#~(string-append #$net-base "/etc/services"))
 261                   ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
 262                   ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
 263                   ("pam.d" ,#~#$pam.d)
 264                   ("login.defs" ,#~#$login.defs)
 265                   ("issue" ,#~#$issue)
 266                   ("skel" ,#~#$skel)
 267                   ("shells" ,#~#$shells)
 268                   ("profile" ,#~#$bashrc)
 269                   ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
 270                                                  #$timezone))
 271                   ("sudoers" ,#~#$sudoers)))))
 272
 273 (define (operating-system-profile os)
 274   "Return a derivation that builds the default profile of OS."
 275   ;; TODO: Replace with a real profile with a manifest.
 276   (union (operating-system-packages os)
 277          #:name "default-profile"))
 278
 279 (define %root-account
 280   ;; Default root account.
 281   (user-account
 282    (name "root")
 283    (password "")
 284    (uid 0) (group "root")
 285    (comment "System administrator")
 286    (home-directory "/root")))
 287
 288 (define (operating-system-accounts os)
 289   "Return the user accounts for OS, including an obligatory 'root' account."
 290   (define users
 291     ;; Make sure there's a root account.
 292     (if (find (lambda (user)
 293                 (and=> (user-account-uid user) zero?))
 294               (operating-system-users os))
 295         (operating-system-users os)
 296         (cons %root-account (operating-system-users os))))
 297
 298   (mlet %store-monad ((services (operating-system-services os)))
 299     (return (append users
 300                     (append-map service-user-accounts services)))))
 301
 302 (define (operating-system-etc-directory os)
 303   "Return that static part of the /etc directory of OS."
 304   (mlet* %store-monad
 305       ((services     (operating-system-services os))
 306        (pam-services ->
 307                      ;; Services known to PAM.
 308                      (delete-duplicates
 309                       (append (operating-system-pam-services os)
 310                               (append-map service-pam-services services))))
 311        (profile-drv (operating-system-profile os))
 312        (skeletons   (operating-system-skeletons os)))
 313    (etc-directory #:pam-services pam-services
 314                   #:skeletons skeletons
 315                   #:issue (operating-system-issue os)
 316                   #:locale (operating-system-locale os)
 317                   #:timezone (operating-system-timezone os)
 318                   #:sudoers (operating-system-sudoers os)
 319                   #:profile profile-drv)))
 320
 321 (define %setuid-programs
 322   ;; Default set of setuid-root programs.
 323   (let ((shadow (@ (gnu packages admin) shadow)))
 324     (list #~(string-append #$shadow "/bin/passwd")
 325           #~(string-append #$shadow "/bin/su")
 326           #~(string-append #$inetutils "/bin/ping")
 327           #~(string-append #$sudo "/bin/sudo")
 328           #~(string-append #$fuse "/bin/fusermount"))))
 329
 330 (define %sudoers-specification
 331   ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
 332   ;; group can do anything.  See
 333   ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
 334   ;; TODO: Add a declarative API.
 335   "root ALL=(ALL) ALL
 336 %wheel ALL=(ALL) ALL\n")
 337
 338 (define (user-group->gexp group)
 339   "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
 340 'active-groups'."
 341   #~(list #$(user-group-name group)
 342           #$(user-group-password group)
 343           #$(user-group-id group)))
 344
 345 (define (user-account->gexp account)
 346   "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
 347 'activate-users'."
 348   #~`(#$(user-account-name account)
 349       #$(user-account-uid account)
 350       #$(user-account-group account)
 351       #$(user-account-supplementary-groups account)
 352       #$(user-account-comment account)
 353       #$(user-account-home-directory account)
 354       ,#$(user-account-shell account)             ; this one is a gexp
 355       #$(user-account-password account)))
 356
 357 (define (operating-system-activation-script os)
 358   "Return the activation script for OS---i.e., the code that \"activates\" the
 359 stateful part of OS, including user accounts and groups, special directories,
 360 etc."
 361   (define %modules
 362     '((guix build activation)
 363       (guix build utils)
 364       (guix build linux-initrd)))
 365
 366   (define (service-activations services)
 367     ;; Return the activation scripts for SERVICES.
 368     (let ((gexps (filter-map service-activate services)))
 369       (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>)
 370                                   gexps))))
 371
 372   (mlet* %store-monad ((services (operating-system-services os))
 373                        (actions  (service-activations services))
 374                        (etc      (operating-system-etc-directory os))
 375                        (modules  (imported-modules %modules))
 376                        (compiled (compiled-modules %modules))
 377                        (accounts (operating-system-accounts os)))
 378     (define setuid-progs
 379       (operating-system-setuid-programs os))
 380
 381     (define user-specs
 382       (map user-account->gexp accounts))
 383
 384     (define groups
 385       (append (operating-system-groups os)
 386               (append-map service-user-groups services)))
 387
 388     (define group-specs
 389       (map user-group->gexp groups))
 390
 391     (gexp->file "boot"
 392                 #~(begin
 393                     (eval-when (expand load eval)
 394                       ;; Make sure 'use-modules' below succeeds.
 395                       (set! %load-path (cons #$modules %load-path))
 396                       (set! %load-compiled-path
 397                             (cons #$compiled %load-compiled-path)))
 398
 399                     (use-modules (guix build activation))
 400
 401                     ;; Populate /etc.
 402                     (activate-etc #$etc)
 403
 404                     ;; Add users and user groups.
 405                     (setenv "PATH"
 406                             (string-append #$(@ (gnu packages admin) shadow)
 407                                            "/sbin"))
 408                     (activate-users+groups (list #$@user-specs)
 409                                            (list #$@group-specs))
 410
 411                     ;; Activate setuid programs.
 412                     (activate-setuid-programs (list #$@setuid-progs))
 413
 414                     ;; Run the services' activation snippets.
 415                     ;; TODO: Use 'load-compiled'.
 416                     (for-each primitive-load '#$actions)
 417
 418                     ;; Set up /run/current-system.
 419                     (activate-current-system)))))
 420
 421 (define (operating-system-boot-script os)
 422   "Return the boot script for OS---i.e., the code started by the initrd once
 423 we're running in the final root."
 424   (mlet* %store-monad ((services (operating-system-services os))
 425                        (activate (operating-system-activation-script os))
 426                        (dmd-conf (dmd-configuration-file services)))
 427     (gexp->file "boot"
 428                 #~(begin
 429                     ;; Activate the system.
 430                     ;; TODO: Use 'load-compiled'.
 431                     (primitive-load #$activate)
 432
 433                     ;; Keep track of the booted system.
 434                     (false-if-exception (delete-file "/run/booted-system"))
 435                     (symlink (readlink "/run/current-system")
 436                              "/run/booted-system")
 437
 438                     ;; Close any remaining open file descriptors to be on the
 439                     ;; safe side.  This must be the very last thing we do,
 440                     ;; because Guile has internal FDs such as 'sleep_pipe'
 441                     ;; that need to be alive.
 442                     (let loop ((fd 3))
 443                       (when (< fd 1024)
 444                         (false-if-exception (close-fdes fd))
 445                         (loop (+ 1 fd))))
 446
 447                     ;; Start dmd.
 448                     (execl (string-append #$dmd "/bin/dmd")
 449                            "dmd" "--config" #$dmd-conf)))))
 450
 451 (define (operating-system-root-file-system os)
 452   "Return the root file system of OS."
 453   (find (match-lambda
 454          (($ <file-system> _ _ "/") #t)
 455          (_ #f))
 456         (operating-system-file-systems os)))
 457
 458 (define (operating-system-initrd-file os)
 459   "Return a gexp denoting the initrd file of OS."
 460   (define boot-file-systems
 461     (filter (match-lambda
 462              (($ <file-system> device title "/")
 463               #t)
 464              (($ <file-system> device title mount-point type flags
 465                                options boot?)
 466               boot?))
 467             (operating-system-file-systems os)))
 468
 469   (mlet %store-monad
 470       ((initrd ((operating-system-initrd os) boot-file-systems)))
 471     (return #~(string-append #$initrd "/initrd"))))
 472
 473 (define (operating-system-grub.cfg os)
 474   "Return the GRUB configuration file for OS."
 475   (mlet* %store-monad
 476       ((system      (operating-system-derivation os))
 477        (root-fs ->  (operating-system-root-file-system os))
 478        (kernel ->   (operating-system-kernel os))
 479        (entries ->  (list (menu-entry
 480                            (label (string-append
 481                                    "GNU system with "
 482                                    (package-full-name kernel)
 483                                    " (technology preview)"))
 484                            (linux kernel)
 485                            (linux-arguments
 486                             (list (string-append "--root="
 487                                                  (file-system-device root-fs))
 488                                   #~(string-append "--system=" #$system)
 489                                   #~(string-append "--load=" #$system
 490                                                    "/boot")))
 491                            (initrd #~(string-append #$system "/initrd"))))))
 492     (grub-configuration-file (operating-system-bootloader os) entries)))
 493
 494 (define (operating-system-derivation os)
 495   "Return a derivation that builds OS."
 496   (mlet* %store-monad
 497       ((profile     (operating-system-profile os))
 498        (etc         (operating-system-etc-directory os))
 499        (boot        (operating-system-boot-script os))
 500        (kernel  ->  (operating-system-kernel os))
 501        (initrd      (operating-system-initrd-file os)))
 502     (file-union "system"
 503                 `(("boot" ,#~#$boot)
 504                   ("kernel" ,#~#$kernel)
 505                   ("initrd" ,initrd)
 506                   ("profile" ,#~#$profile)
 507                   ("etc" ,#~#$etc)))))
 508
 509 ;;; system.scm ends here