guix/build/syscalls.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   4 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   5 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
   7 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
   8 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   9 ;;;
  10 ;;; This file is part of GNU Guix.
  11 ;;;
  12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  13 ;;; under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 3 of the License, or (at
  15 ;;; your option) any later version.
  16 ;;;
  17 ;;; GNU Guix is distributed in the hope that it will be useful, but
  18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 (define-module (guix build syscalls)
  26   #:use-module (system foreign)
  27   #:use-module (system base target)
  28   #:use-module (rnrs bytevectors)
  29   #:autoload   (ice-9 binary-ports) (get-bytevector-n)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-9)
  32   #:use-module (srfi srfi-9 gnu)
  33   #:use-module (srfi srfi-11)
  34   #:use-module (srfi srfi-19)
  35   #:use-module (srfi srfi-26)
  36   #:use-module (ice-9 rdelim)
  37   #:use-module (ice-9 regex)
  38   #:use-module (ice-9 match)
  39   #:use-module (ice-9 ftw)
  40   #:export (MS_RDONLY
  41             MS_NOSUID
  42             MS_NODEV
  43             MS_NOEXEC
  44             MS_REMOUNT
  45             MS_NOATIME
  46             MS_BIND
  47             MS_MOVE
  48             MS_STRICTATIME
  49             MS_LAZYTIME
  50             MNT_FORCE
  51             MNT_DETACH
  52             MNT_EXPIRE
  53             UMOUNT_NOFOLLOW
  54
  55             restart-on-EINTR
  56             mount-points
  57             swapon
  58             swapoff
  59
  60             file-system?
  61             file-system-type
  62             file-system-block-size
  63             file-system-block-count
  64             file-system-blocks-free
  65             file-system-blocks-available
  66             file-system-file-count
  67             file-system-free-file-nodes
  68             file-system-identifier
  69             file-system-maximum-name-length
  70             file-system-fragment-size
  71             file-system-mount-flags
  72             statfs
  73             free-disk-space
  74             device-in-use?
  75             add-to-entropy-count
  76
  77             processes
  78             mkdtemp!
  79             fdatasync
  80             pivot-root
  81             scandir*
  82             getxattr
  83             setxattr
  84
  85             fcntl-flock
  86             lock-file
  87             unlock-file
  88             with-file-lock
  89             with-file-lock/no-wait
  90
  91             set-thread-name
  92             thread-name
  93
  94             CLONE_CHILD_CLEARTID
  95             CLONE_CHILD_SETTID
  96             CLONE_NEWNS
  97             CLONE_NEWUTS
  98             CLONE_NEWIPC
  99             CLONE_NEWUSER
 100             CLONE_NEWPID
 101             CLONE_NEWNET
 102             clone
 103             setns
 104
 105             PF_PACKET
 106             AF_PACKET
 107             all-network-interface-names
 108             network-interface-names
 109             network-interface-netmask
 110             network-interface-running?
 111             loopback-network-interface?
 112             arp-network-interface?
 113             network-interface-address
 114             set-network-interface-netmask
 115             set-network-interface-up
 116             configure-network-interface
 117             add-network-route/gateway
 118             delete-network-route
 119
 120             interface?
 121             interface-name
 122             interface-flags
 123             interface-address
 124             interface-netmask
 125             interface-broadcast-address
 126             network-interfaces
 127
 128             termios?
 129             termios-input-flags
 130             termios-output-flags
 131             termios-control-flags
 132             termios-local-flags
 133             termios-line-discipline
 134             termios-control-chars
 135             termios-input-speed
 136             termios-output-speed
 137             local-flags
 138             input-flags
 139             tcsetattr-action
 140             tcgetattr
 141             tcsetattr
 142
 143             window-size?
 144             window-size-rows
 145             window-size-columns
 146             window-size-x-pixels
 147             window-size-y-pixels
 148             terminal-window-size
 149             terminal-columns
 150             terminal-rows
 151
 152             utmpx?
 153             utmpx-login-type
 154             utmpx-pid
 155             utmpx-line
 156             utmpx-id
 157             utmpx-user
 158             utmpx-host
 159             utmpx-termination-status
 160             utmpx-exit-status
 161             utmpx-session-id
 162             utmpx-time
 163             utmpx-address
 164             login-type
 165             utmpx-entries
 166             (read-utmpx-from-port . read-utmpx)))
 167
 168 ;;; Commentary:
 169 ;;;
 170 ;;; This module provides bindings to libc's syscall wrappers.  It uses the
 171 ;;; FFI, and thus requires a dynamically-linked Guile.
 172 ;;;
 173 ;;; Some syscalls are already defined in statically-linked Guile by applying
 174 ;;; 'guile-linux-syscalls.patch'.
 175 ;;;
 176 ;;; Visibility of syscall's symbols shared between this module and static Guile
 177 ;;; is a bit delicate. It is handled by 'define-as-needed' macro.
 178 ;;;
 179 ;;; This macro is used to export symbols in dynamic Guile context, and to
 180 ;;; re-export them in static Guile context.
 181 ;;;
 182 ;;; This way, even if they don't appear in #:export list, it is safe to use
 183 ;;; syscalls from this module in static or dynamic Guile context.
 184 ;;;
 185 ;;; Code:
 186
 187 \f
 188 ;;;
 189 ;;; Packed structures.
 190 ;;;
 191
 192 (define-syntax sizeof*
 193   ;; XXX: This duplicates 'compile-time-value'.
 194   (syntax-rules (int128 array)
 195     ((_ int128)
 196      16)
 197     ((_ (array type n))
 198      (* (sizeof* type) n))
 199     ((_ type)
 200      (let-syntax ((v (lambda (s)
 201                        ;; When compiling natively, call 'sizeof' at expansion
 202                        ;; time; otherwise, emit code to call it at run time.
 203                        (syntax-case s ()
 204                          (_
 205                           (if (= (target-word-size)
 206                                  (with-target %host-type target-word-size))
 207                               (sizeof type)
 208                               #'(sizeof type)))))))
 209        v))))
 210
 211 (define-syntax alignof*
 212   ;; XXX: This duplicates 'compile-time-value'.
 213   (syntax-rules (int128 array)
 214     ((_ int128)
 215      16)
 216     ((_ (array type n))
 217      (alignof* type))
 218     ((_ type)
 219      (let-syntax ((v (lambda (s)
 220                        ;; When compiling natively, call 'sizeof' at expansion
 221                        ;; time; otherwise, emit code to call it at run time.
 222                        (syntax-case s ()
 223                          (_
 224                           (if (= (target-word-size)
 225                                  (with-target %host-type target-word-size))
 226                               (alignof type)
 227                               #'(alignof type)))))))
 228        v))))
 229
 230 (define-syntax align                             ;as found in (system foreign)
 231   (syntax-rules (~)
 232     "Add to OFFSET whatever it takes to get proper alignment for TYPE."
 233     ((_ offset (type ~ endianness))
 234      (align offset type))
 235     ((_ offset type)
 236      (1+ (logior (1- offset) (1- (alignof* type)))))))
 237
 238 (define-syntax type-size
 239   (syntax-rules (~)
 240     ((_ (type ~ order))
 241      (sizeof* type))
 242     ((_ type)
 243      (sizeof* type))))
 244
 245 (define-syntax struct-alignment
 246   (syntax-rules ()
 247     "Compute the alignment for the aggregate made of TYPES at OFFSET.  The
 248 result is the alignment of the \"most strictly aligned component\"."
 249     ((_ offset types ...)
 250      (max (align offset types) ...))))
 251
 252 (define-syntax struct-size
 253   (syntax-rules ()
 254     "Return the size in bytes of the structure made of TYPES."
 255     ((_ offset (types-processed ...))
 256      ;; The SysV ABI P.S. says: "Aggregates (structures and arrays) and unions
 257      ;; assume the alignment of their most strictly aligned component."  As an
 258      ;; example, a struct such as "int32, int16" has size 8, not 6.
 259      (1+ (logior (1- offset)
 260                  (1- (struct-alignment offset types-processed ...)))))
 261     ((_ offset (types-processed ...) type0 types ...)
 262      (struct-size (+ (type-size type0) (align offset type0))
 263                   (type0 types-processed ...)
 264                   types ...))))
 265
 266 (define-syntax write-type
 267   (syntax-rules (~ array *)
 268     ((_ bv offset (type ~ order) value)
 269      (bytevector-uint-set! bv offset value
 270                            (endianness order) (sizeof* type)))
 271     ((_ bv offset (array type n) value)
 272      (let loop ((i 0)
 273                 (value value)
 274                 (o offset))
 275        (unless (= i n)
 276          (match value
 277            ((head . tail)
 278             (write-type bv o type head)
 279             (loop (+ 1 i) tail (+ o (sizeof* type))))))))
 280     ((_ bv offset '* value)
 281      (bytevector-uint-set! bv offset (pointer-address value)
 282                            (native-endianness) (sizeof* '*)))
 283     ((_ bv offset type value)
 284      (bytevector-uint-set! bv offset value
 285                            (native-endianness) (sizeof* type)))))
 286
 287 (define-syntax write-types
 288   (syntax-rules ()
 289     ((_ bv offset () ())
 290      #t)
 291     ((_ bv offset (type0 types ...) (field0 fields ...))
 292      (begin
 293        (write-type bv (align offset type0) type0 field0)
 294        (write-types bv
 295                     (+ (align offset type0) (type-size type0))
 296                     (types ...) (fields ...))))))
 297
 298 (define-syntax read-type
 299   (syntax-rules (~ array quote *)
 300     ((_ bv offset '*)
 301      (make-pointer (bytevector-uint-ref bv offset
 302                                         (native-endianness)
 303                                         (sizeof* '*))))
 304     ((_ bv offset (type ~ order))
 305      (bytevector-uint-ref bv offset
 306                           (endianness order) (sizeof* type)))
 307     ((_ bv offset (array type n))
 308      (unfold (lambda (i) (= i n))
 309              (lambda (i)
 310                (read-type bv (+ offset (* i (sizeof* type))) type))
 311              1+
 312              0))
 313     ((_ bv offset type)
 314      (bytevector-uint-ref bv offset
 315                           (native-endianness) (sizeof* type)))))
 316
 317 (define-syntax read-types
 318   (syntax-rules ()
 319     ((_ return bv offset () (values ...))
 320      (return values ...))
 321     ((_ return bv offset (type0 types ...) (values ...))
 322      (read-types return
 323                  bv
 324                  (+ (align offset type0) (type-size type0))
 325                  (types ...)
 326                  (values ... (read-type bv
 327                                         (align offset type0)
 328                                         type0))))))
 329
 330 (define-syntax define-c-struct-macro
 331   (syntax-rules ()
 332     "Define NAME as a macro that can be queried to get information about the C
 333 struct it represents.  In particular:
 334
 335   (NAME field-offset FIELD)
 336
 337 returns the offset in bytes of FIELD within the C struct represented by NAME."
 338     ((_ name ((fields types) ...))
 339      (define-c-struct-macro name
 340        (fields ...) 0 ()
 341        ((fields types) ...)))
 342     ((_ name (fields ...) offset (clauses ...) ((field type) rest ...))
 343      (define-c-struct-macro name
 344        (fields ...)
 345        (+ (align offset type) (type-size type))
 346        (clauses ... ((_ field-offset field) (align offset type)))
 347        (rest ...)))
 348     ((_ name (fields ...) offset (clauses ...) ())
 349      (define-syntax name
 350        (syntax-rules (field-offset fields ...)
 351          clauses ...)))))
 352
 353 (define-syntax define-c-struct
 354   (syntax-rules ()
 355     "Define SIZE as the size in bytes of the C structure made of FIELDS.  READ
 356 as a deserializer and WRITE! as a serializer for the C structure with the
 357 given TYPES.  READ uses WRAP-FIELDS to return its value."
 358     ((_ name size wrap-fields read write! (fields types) ...)
 359      (begin
 360        (define-c-struct-macro name
 361          ((fields types) ...))
 362        (define size
 363          (struct-size 0 () types ...))
 364        (define (write! bv offset fields ...)
 365          (write-types bv offset (types ...) (fields ...)))
 366        (define* (read bv #:optional (offset 0))
 367          (read-types wrap-fields bv offset (types ...) ()))))))
 368
 369 (define-syntax-rule (c-struct-field-offset type field)
 370   "Return the offset in BYTES of FIELD within TYPE, where TYPE is a C struct
 371 defined with 'define-c-struct' and FIELD is a field identifier.  An
 372 expansion-time error is raised if FIELD does not exist in TYPE."
 373   (type field-offset field))
 374
 375 \f
 376 ;;;
 377 ;;; FFI.
 378 ;;;
 379
 380 (define (call-with-restart-on-EINTR thunk)
 381   (let loop ()
 382     (catch 'system-error
 383       thunk
 384       (lambda args
 385         (if (= (system-error-errno args) EINTR)
 386             (loop)
 387             (apply throw args))))))
 388
 389 (define-syntax-rule (restart-on-EINTR expr)
 390   "Evaluate EXPR and restart upon EINTR.  Return the value of EXPR."
 391   (call-with-restart-on-EINTR (lambda () expr)))
 392
 393 (define (syscall->procedure return-type name argument-types)
 394   "Return a procedure that wraps the C function NAME using the dynamic FFI,
 395 and that returns two values: NAME's return value, and errno.
 396
 397 If an error occurs while creating the binding, defer the error report until
 398 the returned procedure is called."
 399   (catch #t
 400     (lambda ()
 401       (let ((ptr (dynamic-func name (dynamic-link))))
 402         ;; The #:return-errno? facility was introduced in Guile 2.0.12.
 403         (pointer->procedure return-type ptr argument-types
 404                             #:return-errno? #t)))
 405     (lambda args
 406       (lambda _
 407         (throw 'system-error name  "~A" (list (strerror ENOSYS))
 408                (list ENOSYS))))))
 409
 410 (define-syntax define-as-needed
 411   (syntax-rules ()
 412     "Define VARIABLE.  If VARIABLE already exists in (guile) then re-export it,
 413   otherwise export the newly-defined VARIABLE."
 414     ((_ (proc args ...) body ...)
 415      (define-as-needed proc (lambda* (args ...) body ...)))
 416     ((_ variable value)
 417      (if (module-defined? the-scm-module 'variable)
 418          (module-re-export! (current-module) '(variable))
 419          (begin
 420            (module-define! (current-module) 'variable value)
 421            (module-export! (current-module) '(variable)))))))
 422
 423 \f
 424 ;;;
 425 ;;; File systems.
 426 ;;;
 427
 428 (define (augment-mtab source target type options)
 429   "Augment /etc/mtab with information about the given mount point."
 430   (let ((port (open-file "/etc/mtab" "a")))
 431     (format port "~a ~a ~a ~a 0 0~%"
 432             source target type (or options "rw"))
 433     (close-port port)))
 434
 435 (define (read-mtab port)
 436   "Read an mtab-formatted file from PORT, returning a list of tuples."
 437   (let loop ((result '()))
 438     (let ((line (read-line port)))
 439       (if (eof-object? line)
 440           (reverse result)
 441           (loop (cons (string-tokenize line) result))))))
 442
 443 (define (remove-from-mtab target)
 444   "Remove mount point TARGET from /etc/mtab."
 445   (define entries
 446     (remove (match-lambda
 447              ((device mount-point type options freq passno)
 448               (string=? target mount-point))
 449              (_ #f))
 450             (call-with-input-file "/etc/mtab" read-mtab)))
 451
 452   (call-with-output-file "/etc/mtab"
 453     (lambda (port)
 454       (for-each (match-lambda
 455                  ((device mount-point type options freq passno)
 456                   (format port "~a ~a ~a ~a ~a ~a~%"
 457                           device mount-point type options freq passno)))
 458                 entries))))
 459
 460 ;; Linux mount flags, from libc's <sys/mount.h>.
 461 (define MS_RDONLY             1)
 462 (define MS_NOSUID             2)
 463 (define MS_NODEV              4)
 464 (define MS_NOEXEC             8)
 465 (define MS_REMOUNT           32)
 466 (define MS_NOATIME         1024)
 467 (define MS_BIND            4096)
 468 (define MS_MOVE            8192)
 469 (define MS_STRICTATIME 16777216)
 470 (define MS_LAZYTIME    33554432)
 471
 472 (define MNT_FORCE       1)
 473 (define MNT_DETACH      2)
 474 (define MNT_EXPIRE      4)
 475 (define UMOUNT_NOFOLLOW 8)
 476
 477 (define-as-needed (mount source target type
 478                          #:optional (flags 0) options
 479                          #:key (update-mtab? #f))
 480   "Mount device SOURCE on TARGET as a file system TYPE.
 481 Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h>
 482 constants, and OPTIONS may be a string.  When FLAGS contains
 483 MS_REMOUNT, SOURCE and TYPE are ignored.  When UPDATE-MTAB? is true,
 484 update /etc/mtab.  Raise a 'system-error' exception on error."
 485   ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
 486   (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
 487     (let-values (((ret err)
 488                   (proc (if source
 489                             (string->pointer source)
 490                             %null-pointer)
 491                         (string->pointer target)
 492                         (if type
 493                             (string->pointer type)
 494                             %null-pointer)
 495                         flags
 496                         (if options
 497                             (string->pointer options)
 498                             %null-pointer))))
 499       (unless (zero? ret)
 500         (throw 'system-error "mount" "mount ~S on ~S: ~A"
 501                (list source target (strerror err))
 502                (list err)))
 503       (when update-mtab?
 504         (augment-mtab source target type options)))))
 505
 506 (define-as-needed (umount target
 507                           #:optional (flags 0)
 508                           #:key (update-mtab? #f))
 509   "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
 510 constants from <sys/mount.h>."
 511   ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
 512   (let ((proc (syscall->procedure int "umount2" `(* ,int))))
 513     (let-values (((ret err)
 514                   (proc (string->pointer target) flags)))
 515       (unless (zero? ret)
 516         (throw 'system-error "umount" "~S: ~A"
 517                (list target (strerror err))
 518                (list err)))
 519       (when update-mtab?
 520         (remove-from-mtab target)))))
 521
 522 (define (mount-points)
 523   "Return the mounts points for currently mounted file systems."
 524   (call-with-input-file "/proc/mounts"
 525     (lambda (port)
 526       (let loop ((result '()))
 527         (let ((line (read-line port)))
 528           (if (eof-object? line)
 529               (reverse result)
 530               (match (string-tokenize line)
 531                 ((source mount-point _ ...)
 532                  (loop (cons mount-point result))))))))))
 533
 534 (define swapon
 535   (let ((proc (syscall->procedure int "swapon" (list '* int))))
 536     (lambda* (device #:optional (flags 0))
 537       "Use the block special device at DEVICE for swapping."
 538       (let-values (((ret err)
 539                     (proc (string->pointer device) flags)))
 540         (unless (zero? ret)
 541           (throw 'system-error "swapon" "~S: ~A"
 542                  (list device (strerror err))
 543                  (list err)))))))
 544
 545 (define swapoff
 546   (let ((proc (syscall->procedure int "swapoff" '(*))))
 547     (lambda (device)
 548       "Stop using block special device DEVICE for swapping."
 549       (let-values (((ret err) (proc (string->pointer device))))
 550         (unless (zero? ret)
 551           (throw 'system-error "swapoff" "~S: ~A"
 552                  (list device (strerror err))
 553                  (list err)))))))
 554
 555 (define-as-needed RB_AUTOBOOT    #x01234567)
 556 (define-as-needed RB_HALT_SYSTEM #xcdef0123)
 557 (define-as-needed RB_ENABLED_CAD #x89abcdef)
 558 (define-as-needed RB_DISABLE_CAD 0)
 559 (define-as-needed RB_POWER_OFF   #x4321fedc)
 560 (define-as-needed RB_SW_SUSPEND  #xd000fce2)
 561 (define-as-needed RB_KEXEC       #x45584543)
 562
 563 (define-as-needed (reboot #:optional (cmd RB_AUTOBOOT))
 564   (let ((proc (syscall->procedure int "reboot" (list int))))
 565     (let-values (((ret err) (proc cmd)))
 566       (unless (zero? ret)
 567         (throw 'system-error "reboot" "~S: ~A"
 568                (list cmd (strerror err))
 569                (list err))))))
 570
 571 (define-as-needed (load-linux-module data #:optional (options ""))
 572   (let ((proc (syscall->procedure int "init_module"
 573                                   (list '* unsigned-long '*))))
 574     (let-values (((ret err)
 575                   (proc (bytevector->pointer data)
 576                         (bytevector-length data)
 577                         (string->pointer options))))
 578       (unless (zero? ret)
 579         (throw 'system-error "load-linux-module" "~A"
 580                (list (strerror err))
 581                (list err))))))
 582
 583 (define (kernel? pid)
 584   "Return #t if PID designates a \"kernel thread\" rather than a normal
 585 user-land process."
 586   (let ((stat (call-with-input-file (format #f "/proc/~a/stat" pid)
 587                 (compose string-tokenize read-string))))
 588     ;; See proc.txt in Linux's documentation for the list of fields.
 589     (match stat
 590       ((pid tcomm state ppid pgrp sid tty_nr tty_pgrp flags min_flt
 591             cmin_flt maj_flt cmaj_flt utime stime cutime cstime
 592             priority nice num_thread it_real_value start_time
 593             vsize rss rsslim
 594             (= string->number start_code) (= string->number end_code) _ ...)
 595        ;; Got this obscure trick from sysvinit's 'killall5' program.
 596        (and (zero? start_code) (zero? end_code))))))
 597
 598 (define (processes)
 599   "Return the list of live processes."
 600   (sort (filter-map (lambda (file)
 601                       (let ((pid (string->number file)))
 602                         (and pid
 603                              (not (kernel? pid))
 604                              pid)))
 605                     (scandir "/proc"))
 606         <))
 607
 608 (define mkdtemp!
 609   (let ((proc (syscall->procedure '* "mkdtemp" '(*))))
 610     (lambda (tmpl)
 611       "Create a new unique directory in the file system using the template
 612 string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
 613       (let-values (((result err) (proc (string->pointer tmpl))))
 614         (when (null-pointer? result)
 615           (throw 'system-error "mkdtemp!" "~S: ~A"
 616                  (list tmpl (strerror err))
 617                  (list err)))
 618         (pointer->string result)))))
 619
 620 (define fdatasync
 621   (let ((proc (syscall->procedure int "fdatasync" (list int))))
 622     (lambda (port)
 623       "Flush buffered output of PORT, an output file port, and then call
 624 fdatasync(2) on the underlying file descriptor."
 625       (force-output port)
 626       (let*-values (((fd)      (fileno port))
 627                     ((ret err) (proc fd)))
 628         (unless (zero? ret)
 629           (throw 'system-error "fdatasync" "~S: ~A"
 630                  (list fd (strerror err))
 631                  (list err)))))))
 632
 633
 634 (define-record-type <file-system>
 635   (file-system type block-size blocks blocks-free
 636                blocks-available files free-files identifier
 637                name-length fragment-size mount-flags spare)
 638   file-system?
 639   (type              file-system-type)
 640   (block-size        file-system-block-size)
 641   (blocks            file-system-block-count)
 642   (blocks-free       file-system-blocks-free)
 643   (blocks-available  file-system-blocks-available)
 644   (files             file-system-file-count)
 645   (free-files        file-system-free-file-nodes)
 646   (identifier        file-system-identifier)
 647   (name-length       file-system-maximum-name-length)
 648   (fragment-size     file-system-fragment-size)
 649   (mount-flags       file-system-mount-flags)
 650   (spare             file-system--spare))
 651
 652 (define-syntax fsword                             ;fsword_t
 653   (identifier-syntax long))
 654
 655 (define-c-struct %statfs                          ;<bits/statfs.h>
 656   sizeof-statfs                                   ;slightly overestimated
 657   file-system
 658   read-statfs
 659   write-statfs!
 660   (type             fsword)
 661   (block-size       fsword)
 662   (blocks           uint64)
 663   (blocks-free      uint64)
 664   (blocks-available uint64)
 665   (files            uint64)
 666   (free-files       uint64)
 667   (identifier       (array int 2))
 668   (name-length      fsword)
 669   (fragment-size    fsword)
 670   (mount-flags      fsword)
 671   (spare            (array fsword 4)))
 672
 673 (define statfs
 674   (let ((proc (syscall->procedure int "statfs64" '(* *))))
 675     (lambda (file)
 676       "Return a <file-system> data structure describing the file system
 677 mounted at FILE."
 678       (let*-values (((stat)    (make-bytevector sizeof-statfs))
 679                     ((ret err) (proc (string->pointer file)
 680                                      (bytevector->pointer stat))))
 681         (if (zero? ret)
 682             (read-statfs stat)
 683             (throw 'system-error "statfs" "~A: ~A"
 684                    (list file (strerror err))
 685                    (list err)))))))
 686
 687 (define (free-disk-space file)
 688   "Return the free disk space, in bytes, on the file system that hosts FILE."
 689   (let ((fs (statfs file)))
 690     (* (file-system-block-size fs)
 691        (file-system-blocks-available fs))))
 692
 693 ;; Flags for the *at command, notably the 'utime' procedure of libguile.
 694 ;; From <fcntl.h>.
 695 (define-as-needed AT_FDCWD             -100)
 696 (define-as-needed AT_SYMLINK_NOFOLLOW #x100)
 697 (define-as-needed AT_REMOVEDIR        #x200)
 698 (define-as-needed AT_SYMLINK_FOLLOW   #x400)
 699 (define-as-needed AT_NO_AUTOMOUNT     #x800)
 700 (define-as-needed AT_EMPTY_PATH       #x1000)
 701
 702 (define-syntax BLKRRPART                         ;<sys/mount.h>
 703   (identifier-syntax #x125F))
 704
 705 (define* (device-in-use? device)
 706   "Return #t if the block DEVICE is in use, #f otherwise. This is inspired
 707 from fdisk_device_is_used function of util-linux. This is particularly useful
 708 for devices that do not appear in /proc/self/mounts like overlayfs lowerdir
 709 backend device."
 710   (let*-values (((fd)      (open-fdes device O_RDONLY))
 711                 ((ret err) (%ioctl fd BLKRRPART %null-pointer)))
 712     (close-fdes fd)
 713     (cond
 714      ((= ret 0)
 715       #f)
 716      ((= err EBUSY)
 717       #t)
 718      ((= err EINVAL)
 719       ;; We get EINVAL for devices that have the GENHD_FL_NO_PART_SCAN flag
 720       ;; set in the kernel, in particular loopback devices, though we do seem
 721       ;; to get it for SCSI storage (/dev/sr0) on QEMU.
 722       #f)
 723      (else
 724       (throw 'system-error "ioctl" "~A"
 725              (list (strerror err))
 726              (list err))))))
 727
 728 (define getxattr
 729   (let ((proc (syscall->procedure ssize_t "getxattr"
 730                                   `(* * * ,size_t))))
 731     (lambda (file key)
 732       "Get the extended attribute value for KEY on FILE."
 733       (let-values (((size err)
 734                     ;; Get size of VALUE for buffer.
 735                     (proc (string->pointer/utf-8 file)
 736                           (string->pointer key)
 737                           (string->pointer "")
 738                           0)))
 739         (cond ((< size 0) #f)
 740               ((zero? size) "")
 741               ;; Get VALUE in buffer of SIZE.  XXX actual size can race.
 742               (else (let*-values (((buf) (make-bytevector size))
 743                                   ((size err)
 744                                    (proc (string->pointer/utf-8 file)
 745                                          (string->pointer key)
 746                                          (bytevector->pointer buf)
 747                                          size)))
 748                       (if (>= size 0)
 749                           (utf8->string buf)
 750                           (throw 'system-error "getxattr" "~S: ~A"
 751                                  (list file key (strerror err))
 752                                  (list err))))))))))
 753
 754 (define setxattr
 755   (let ((proc (syscall->procedure int "setxattr"
 756                                   `(* * * ,size_t ,int))))
 757     (lambda* (file key value #:optional (flags 0))
 758       "Set extended attribute KEY to VALUE on FILE."
 759       (let*-values (((bv) (string->utf8 value))
 760                     ((ret err)
 761                      (proc (string->pointer/utf-8 file)
 762                            (string->pointer key)
 763                            (bytevector->pointer bv)
 764                            (bytevector-length bv)
 765                            flags)))
 766         (unless (zero? ret)
 767           (throw 'system-error "setxattr" "~S: ~A"
 768                  (list file key value (strerror err))
 769                  (list err)))))))
 770
 771 \f
 772 ;;;
 773 ;;; Random.
 774 ;;;
 775
 776 ;; From <uapi/linux/random.h>.
 777 (define RNDADDTOENTCNT #x40045201)
 778
 779 (define (add-to-entropy-count port-or-fd n)
 780   "Add N to the kernel's entropy count (the value that can be read from
 781 /proc/sys/kernel/random/entropy_avail).  PORT-OR-FD must correspond to
 782 /dev/urandom or /dev/random.  Raise to 'system-error with EPERM when the
 783 caller lacks root privileges."
 784   (let ((fd  (if (port? port-or-fd)
 785                  (fileno port-or-fd)
 786                  port-or-fd))
 787         (box (make-bytevector (sizeof int))))
 788     (bytevector-sint-set! box 0 n (native-endianness)
 789                           (sizeof int))
 790     (let-values (((ret err)
 791                   (%ioctl fd RNDADDTOENTCNT
 792                           (bytevector->pointer box))))
 793       (unless (zero? err)
 794         (throw 'system-error "add-to-entropy-count" "~A"
 795                (list (strerror err))
 796                (list err))))))
 797
 798 \f
 799 ;;;
 800 ;;; Containers.
 801 ;;;
 802
 803 ;; Linux clone flags, from linux/sched.h
 804 (define CLONE_CHILD_CLEARTID #x00200000)
 805 (define CLONE_CHILD_SETTID   #x01000000)
 806 (define CLONE_NEWNS          #x00020000)
 807 (define CLONE_NEWUTS         #x04000000)
 808 (define CLONE_NEWIPC         #x08000000)
 809 (define CLONE_NEWUSER        #x10000000)
 810 (define CLONE_NEWPID         #x20000000)
 811 (define CLONE_NEWNET         #x40000000)
 812
 813 (define %set-automatic-finalization-enabled?!
 814   ;; When using a statically-linked Guile, for instance in the initrd, we
 815   ;; cannot resolve this symbol, but most of the time we don't need it
 816   ;; anyway.  Thus, delay it.
 817   (let ((proc (delay
 818                 (pointer->procedure int
 819                                     (dynamic-func
 820                                      "scm_set_automatic_finalization_enabled"
 821                                      (dynamic-link))
 822                                     (list int)))))
 823     (lambda (enabled?)
 824       "Switch on or off automatic finalization in a separate thread.
 825 Turning finalization off shuts down the finalization thread as a side effect."
 826       (->bool ((force proc) (if enabled? 1 0))))))
 827
 828 (define-syntax-rule (without-automatic-finalization exp)
 829   "Turn off automatic finalization within the dynamic extent of EXP."
 830   (let ((enabled? #t))
 831     (dynamic-wind
 832       (lambda ()
 833         (set! enabled? (%set-automatic-finalization-enabled?! #f)))
 834       (lambda ()
 835         exp)
 836       (lambda ()
 837         (%set-automatic-finalization-enabled?! enabled?)))))
 838
 839 ;; The libc interface to sys_clone is not useful for Scheme programs, so the
 840 ;; low-level system call is wrapped instead.  The 'syscall' function is
 841 ;; declared in <unistd.h> as a variadic function; in practice, it expects 6
 842 ;; pointer-sized arguments, as shown in, e.g., x86_64/syscall.S.
 843 (define clone
 844   (let* ((proc (syscall->procedure int "syscall"
 845                                    (list long                   ;sysno
 846                                          unsigned-long          ;flags
 847                                          '* '* '*
 848                                          '*)))
 849          ;; TODO: Don't do this.
 850          (syscall-id (match (utsname:machine (uname))
 851                        ("i686"   120)
 852                        ("x86_64" 56)
 853                        ("mips64" 5055)
 854                        ("armv7l" 120)
 855                        ("aarch64" 220)
 856                        (_ #f))))
 857     (lambda (flags)
 858       "Create a new child process by duplicating the current parent process.
 859 Unlike the fork system call, clone accepts FLAGS that specify which resources
 860 are shared between the parent and child processes."
 861       (let-values (((ret err)
 862                     ;; Guile 2.2 runs a finalization thread.  'primitive-fork'
 863                     ;; takes care of shutting it down before forking, and we
 864                     ;; must do the same here.  Failing to do that, if the
 865                     ;; child process calls 'primitive-fork', it will hang
 866                     ;; while trying to pthread_join the finalization thread
 867                     ;; since that thread does not exist.
 868                     (without-automatic-finalization
 869                      (proc syscall-id flags
 870                            %null-pointer              ;child stack
 871                            %null-pointer %null-pointer ;ptid & ctid
 872                            %null-pointer))))           ;unused
 873         (if (= ret -1)
 874             (throw 'system-error "clone" "~d: ~A"
 875                    (list flags (strerror err))
 876                    (list err))
 877             ret)))))
 878
 879 (define setns
 880   ;; Some systems may be using an old (pre-2.14) version of glibc where there
 881   ;; is no 'setns' function available.
 882   (false-if-exception
 883    (let ((proc (syscall->procedure int "setns" (list int int))))
 884      (lambda (fdes nstype)
 885        "Reassociate the current process with the namespace specified by FDES, a
 886 file descriptor obtained by opening a /proc/PID/ns/* file.  NSTYPE specifies
 887 which type of namespace the current process may be reassociated with, or 0 if
 888 there is no such limitation."
 889        (let-values (((ret err) (proc fdes nstype)))
 890          (unless (zero? ret)
 891            (throw 'system-error "setns" "~d ~d: ~A"
 892                   (list fdes nstype (strerror err))
 893                   (list err))))))))
 894
 895 (define pivot-root
 896   (let ((proc (syscall->procedure int "pivot_root" (list '* '*))))
 897     (lambda (new-root put-old)
 898       "Change the root file system to NEW-ROOT and move the current root file
 899 system to PUT-OLD."
 900       (let-values (((ret err)
 901                     (proc (string->pointer new-root)
 902                           (string->pointer put-old))))
 903         (unless (zero? ret)
 904           (throw 'system-error "pivot_root" "~S ~S: ~A"
 905                  (list new-root put-old (strerror err))
 906                  (list err)))))))
 907
 908 \f
 909 ;;;
 910 ;;; Opendir & co.
 911 ;;;
 912
 913 (define (file-type->symbol type)
 914   ;; Convert TYPE to symbols like 'stat:type' does.
 915   (cond ((= type DT_REG)  'regular)
 916         ((= type DT_LNK)  'symlink)
 917         ((= type DT_DIR)  'directory)
 918         ((= type DT_FIFO) 'fifo)
 919         ((= type DT_CHR)  'char-special)
 920         ((= type DT_BLK)  'block-special)
 921         ((= type DT_SOCK) 'socket)
 922         (else             'unknown)))
 923
 924 ;; 'struct dirent64' for GNU/Linux.
 925 (define-c-struct %struct-dirent-header/linux
 926   sizeof-dirent-header/linux
 927   (lambda (inode offset length type name)
 928     `((type . ,(file-type->symbol type))
 929       (inode . ,inode)))
 930   read-dirent-header/linux
 931   write-dirent-header!/linux
 932   (inode  int64)
 933   (offset int64)
 934   (length unsigned-short)
 935   (type   uint8)
 936   (name   uint8))                                 ;first byte of 'd_name'
 937
 938 ;; 'struct dirent64' for GNU/Hurd.
 939 (define-c-struct %struct-dirent-header/hurd
 940   sizeof-dirent-header/hurd
 941   (lambda (inode length type name-length name)
 942     `((type . ,(file-type->symbol type))
 943       (inode . ,inode)))
 944   read-dirent-header/hurd
 945   write-dirent-header!/hurd
 946   (inode   int64)
 947   (length  unsigned-short)
 948   (type    uint8)
 949   (namelen uint8)
 950   (name    uint8))
 951
 952 ;; Constants for the 'type' field, from <dirent.h>.
 953 (define DT_UNKNOWN 0)
 954 (define DT_FIFO 1)
 955 (define DT_CHR 2)
 956 (define DT_DIR 4)
 957 (define DT_BLK 6)
 958 (define DT_REG 8)
 959 (define DT_LNK 10)
 960 (define DT_SOCK 12)
 961 (define DT_WHT 14)
 962
 963 (define string->pointer/utf-8
 964   (cut string->pointer <> "UTF-8"))
 965
 966 (define pointer->string/utf-8
 967   (cut pointer->string <> <> "UTF-8"))
 968
 969 (define opendir*
 970   (let ((proc (syscall->procedure '* "opendir" '(*))))
 971     (lambda* (name #:optional (string->pointer string->pointer/utf-8))
 972       (let-values (((ptr err)
 973                     (proc (string->pointer name))))
 974         (if (null-pointer? ptr)
 975             (throw 'system-error "opendir*"
 976                    "~A: ~A" (list name (strerror err))
 977                    (list err))
 978             ptr)))))
 979
 980 (define closedir*
 981   (let ((proc (syscall->procedure int "closedir" '(*))))
 982     (lambda (directory)
 983       (let-values (((ret err)
 984                     (proc directory)))
 985         (unless (zero? ret)
 986           (throw 'system-error "closedir"
 987                  "closedir: ~A" (list (strerror err))
 988                  (list err)))))))
 989
 990 (define (readdir-procedure name-field-offset sizeof-dirent-header
 991                            read-dirent-header)
 992   (let ((proc (syscall->procedure '* "readdir64" '(*))))
 993     (lambda* (directory #:optional (pointer->string pointer->string/utf-8))
 994       (let ((ptr (proc directory)))
 995         (and (not (null-pointer? ptr))
 996              (cons (pointer->string
 997                     (make-pointer (+ (pointer-address ptr) name-field-offset))
 998                     -1)
 999                    (read-dirent-header
1000                     (pointer->bytevector ptr sizeof-dirent-header))))))))
1001
1002 (define readdir*
1003   ;; Decide at run time which one must be used.
1004   (if (string-contains %host-type "linux-gnu")
1005       (readdir-procedure (c-struct-field-offset %struct-dirent-header/linux
1006                                                 name)
1007                          sizeof-dirent-header/linux
1008                          read-dirent-header/linux)
1009       (readdir-procedure (c-struct-field-offset %struct-dirent-header/hurd
1010                                                 name)
1011                          sizeof-dirent-header/hurd
1012                          read-dirent-header/hurd)))
1013
1014 (define* (scandir* name #:optional
1015                    (select? (const #t))
1016                    (entry<? (lambda (entry1 entry2)
1017                               (match entry1
1018                                 ((name1 . _)
1019                                  (match entry2
1020                                    ((name2 . _)
1021                                     (string<? name1 name2)))))))
1022                    #:key
1023                    (string->pointer string->pointer/utf-8)
1024                    (pointer->string pointer->string/utf-8))
1025   "This procedure improves on Guile's 'scandir' procedure in several ways:
1026
1027    1. Systematically encode decode file names using STRING->POINTER and
1028       POINTER->STRING (UTF-8 by default; this works around a defect in Guile 2.0/2.2
1029       where 'scandir' decodes file names according to the current locale, which is
1030       not always desirable.
1031
1032    2. Each entry that is returned has the form (NAME . PROPERTIES).
1033       PROPERTIES is an alist showing additional properties about the entry, as
1034       found in 'struct dirent'.  An entry may look like this:
1035
1036         (\"foo.scm\" (type . regular) (inode . 123456))
1037
1038       Callers must be prepared to deal with the case where 'type' is 'unknown'
1039       since some file systems do not provide that information.
1040
1041    3. Raise to 'system-error' when NAME cannot be opened."
1042   (let ((directory (opendir* name string->pointer)))
1043     (dynamic-wind
1044       (const #t)
1045       (lambda ()
1046         (let loop ((result '()))
1047           (match (readdir* directory pointer->string)
1048             (#f
1049              (sort result entry<?))
1050             (entry
1051              (loop (if (select? entry)
1052                        (cons entry result)
1053                        result))))))
1054       (lambda ()
1055         (closedir* directory)))))
1056
1057 \f
1058 ;;;
1059 ;;; Advisory file locking.
1060 ;;;
1061
1062 (define-c-struct %struct-flock                    ;<fcntl.h>
1063   sizeof-flock
1064   list
1065   read-flock
1066   write-flock!
1067   (type   short)
1068   (whence short)
1069   (start  size_t)
1070   (length size_t)
1071   (pid    int))
1072
1073 (define F_SETLKW
1074   ;; On Linux-based systems, this is usually 7, but not always
1075   ;; (exceptions include SPARC.)  On GNU/Hurd, it's 9.
1076   (cond ((string-contains %host-type "sparc") 9)  ; sparc-*-linux-gnu
1077         ((string-contains %host-type "linux") 7)  ; *-linux-gnu
1078         (else 9)))                                ; *-gnu*
1079
1080 (define F_SETLK
1081   ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
1082   (cond ((string-contains %host-type "sparc") 8)  ; sparc-*-linux-gnu
1083         ((string-contains %host-type "linux") 6)  ; *-linux-gnu
1084         (else 8)))                                ; *-gnu*
1085
1086 (define F_xxLCK
1087   ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
1088   (cond ((string-contains %host-type "sparc") #(1 2 3))    ; sparc-*-linux-gnu
1089         ((string-contains %host-type "hppa")  #(1 2 3))    ; hppa-*-linux-gnu
1090         ((string-contains %host-type "linux") #(0 1 2))    ; *-linux-gnu
1091         (else                                 #(1 2 3))))  ; *-gnu*
1092
1093 (define fcntl-flock
1094   (let ((proc (syscall->procedure int "fcntl" `(,int ,int *))))
1095     (lambda* (fd-or-port operation #:key (wait? #t))
1096       "Perform locking OPERATION on the file beneath FD-OR-PORT.  OPERATION
1097 must be a symbol, one of 'read-lock, 'write-lock, or 'unlock.  When WAIT? is
1098 true, block until the lock is acquired; otherwise, thrown an 'flock-error'
1099 exception if it's already taken."
1100       (define (operation->int op)
1101         (case op
1102           ((read-lock)  (vector-ref F_xxLCK 0))
1103           ((write-lock) (vector-ref F_xxLCK 1))
1104           ((unlock)     (vector-ref F_xxLCK 2))
1105           (else         (error "invalid fcntl-flock operation" op))))
1106
1107       (define fd
1108         (if (port? fd-or-port)
1109             (fileno fd-or-port)
1110             fd-or-port))
1111
1112       (define bv
1113         (make-bytevector sizeof-flock))
1114
1115       (write-flock! bv 0
1116                     (operation->int operation) SEEK_SET
1117                     0 0                           ;whole file
1118                     0)
1119
1120       ;; XXX: 'fcntl' is a vararg function, but here we happily use the
1121       ;; standard ABI; crossing fingers.
1122       (let-values (((ret err)
1123                     (proc fd
1124                           (if wait?
1125                               F_SETLKW            ;lock & wait
1126                               F_SETLK)            ;non-blocking attempt
1127                           (bytevector->pointer bv))))
1128         (unless (zero? ret)
1129           ;; Presumably we got EAGAIN or so.
1130           (throw 'flock-error err))))))
1131
1132 (define* (lock-file file #:key (wait? #t))
1133   "Wait and acquire an exclusive lock on FILE.  Return an open port."
1134   (let ((port (open-file file "w0")))
1135     (fcntl-flock port 'write-lock #:wait? wait?)
1136     port))
1137
1138 (define (unlock-file port)
1139   "Unlock PORT, a port returned by 'lock-file'."
1140   (fcntl-flock port 'unlock)
1141   (close-port port)
1142   #t)
1143
1144 (define (call-with-file-lock file thunk)
1145   (let ((port #f))
1146     (dynamic-wind
1147       (lambda ()
1148         (set! port
1149           (catch 'system-error
1150             (lambda ()
1151               (lock-file file))
1152             (lambda args
1153               ;; When using the statically-linked Guile in the initrd,
1154               ;; 'fcntl-flock' returns ENOSYS unconditionally.  Ignore
1155               ;; that error since we're typically the only process running
1156               ;; at this point.
1157               (if (= ENOSYS (system-error-errno args))
1158                   #f
1159                   (apply throw args))))))
1160       thunk
1161       (lambda ()
1162         (when port
1163           (unlock-file port))))))
1164
1165 (define (call-with-file-lock/no-wait file thunk handler)
1166   (let ((port #f))
1167     (dynamic-wind
1168       (lambda ()
1169         (set! port
1170           (catch #t
1171             (lambda ()
1172               (lock-file file #:wait? #f))
1173             (lambda (key . args)
1174               (match key
1175                 ('flock-error
1176                  (apply handler args)
1177                  ;; No open port to the lock, so return #f.
1178                  #f)
1179                 ('system-error
1180                  ;; When using the statically-linked Guile in the initrd,
1181                  ;; 'fcntl-flock' returns ENOSYS unconditionally.  Ignore
1182                  ;; that error since we're typically the only process running
1183                  ;; at this point.
1184                  (if (= ENOSYS (system-error-errno (cons key args)))
1185                      #f
1186                      (apply throw key args)))
1187                 (_ (apply throw key args)))))))
1188       thunk
1189       (lambda ()
1190         (when port
1191           (unlock-file port))))))
1192
1193 (define-syntax-rule (with-file-lock file exp ...)
1194   "Wait to acquire a lock on FILE and evaluate EXP in that context."
1195   (call-with-file-lock file (lambda () exp ...)))
1196
1197 (define-syntax-rule (with-file-lock/no-wait file handler exp ...)
1198   "Try to acquire a lock on FILE and evaluate EXP in that context.  Execute
1199 handler if the lock is already held by another process."
1200   (call-with-file-lock/no-wait file (lambda () exp ...) handler))
1201
1202 \f
1203 ;;;
1204 ;;; Miscellaneous, aka. 'prctl'.
1205 ;;;
1206
1207 (define %prctl
1208   ;; Should it win the API contest against 'ioctl'?  You tell us!
1209   (syscall->procedure int "prctl"
1210                       (list int unsigned-long unsigned-long
1211                             unsigned-long unsigned-long)))
1212
1213 (define PR_SET_NAME 15)                           ;<linux/prctl.h>
1214 (define PR_GET_NAME 16)
1215
1216 (define %max-thread-name-length
1217   ;; Maximum length in bytes of the process name, including the terminating
1218   ;; zero.
1219   16)
1220
1221 (define (set-thread-name name)
1222   "Set the name of the calling thread to NAME.  NAME is truncated to 15
1223 bytes."
1224   (let ((ptr (string->pointer name)))
1225     (let-values (((ret err)
1226                   (%prctl PR_SET_NAME
1227                           (pointer-address ptr) 0 0 0)))
1228       (unless (zero? ret)
1229         (throw 'set-process-name "set-process-name"
1230                "set-process-name: ~A"
1231                (list (strerror err))
1232                (list err))))))
1233
1234 (define (thread-name)
1235   "Return the name of the calling thread as a string."
1236   (let ((buf (make-bytevector %max-thread-name-length)))
1237     (let-values (((ret err)
1238                   (%prctl PR_GET_NAME
1239                           (pointer-address (bytevector->pointer buf))
1240                           0 0 0)))
1241       (if (zero? ret)
1242           (bytes->string (bytevector->u8-list buf))
1243           (throw 'process-name "process-name"
1244                  "process-name: ~A"
1245                  (list (strerror err))
1246                  (list err))))))
1247
1248 \f
1249 ;;;
1250 ;;; Network interfaces.
1251 ;;;
1252
1253 (define SIOCGIFCONF                               ;from <bits/ioctls.h>
1254                                                   ;     <net/if.h>
1255                                                   ;     <hurd/ioctl.h>
1256   (if (string-contains %host-type "linux")
1257       #x8912                                      ;GNU/Linux
1258       #xf00801a4))                                ;GNU/Hurd
1259 (define SIOCGIFFLAGS
1260   (if (string-contains %host-type "linux")
1261       #x8913                                      ;GNU/Linux
1262       #xc4804191))                                ;GNU/Hurd
1263 (define SIOCSIFFLAGS
1264   (if (string-contains %host-type "linux")
1265       #x8914                                      ;GNU/Linux
1266       #x84804190))                                ;GNU/Hurd
1267 (define SIOCGIFADDR
1268   (if (string-contains %host-type "linux")
1269       #x8915                                      ;GNU/Linux
1270       #xc08401a1))                                ;GNU/Hurd
1271 (define SIOCSIFADDR
1272   (if (string-contains %host-type "linux")
1273       #x8916                                      ;GNU/Linux
1274       #x8084018c))                                ;GNU/Hurd
1275 (define SIOCGIFNETMASK
1276   (if (string-contains %host-type "linux")
1277       #x891b                                      ;GNU/Linux
1278       #xc08401a5))                                ;GNU/Hurd
1279 (define SIOCSIFNETMASK
1280   (if (string-contains %host-type "linux")
1281       #x891c                                      ;GNU/Linux
1282       #x80840196))                                ;GNU/Hurd
1283 (define SIOCADDRT
1284   (if (string-contains %host-type "linux")
1285       #x890B                                      ;GNU/Linux
1286       -1))                                        ;FIXME: GNU/Hurd?
1287 (define SIOCDELRT
1288   (if (string-contains %host-type "linux")
1289       #x890C                                      ;GNU/Linux
1290       -1))                                        ;FIXME: GNU/Hurd?
1291
1292 ;; Flags and constants from <net/if.h>.
1293
1294 (define-as-needed IFF_UP #x1)                     ;Interface is up
1295 (define-as-needed IFF_BROADCAST #x2)              ;Broadcast address valid.
1296 (define-as-needed IFF_LOOPBACK #x8)               ;Is a loopback net.
1297 (define-as-needed IFF_RUNNING #x40)               ;interface RFC2863 OPER_UP
1298 (define-as-needed IFF_NOARP #x80)                 ;ARP disabled or unsupported
1299
1300 (define IF_NAMESIZE 16)                           ;maximum interface name size
1301
1302 (define-c-struct %ifconf-struct
1303   sizeof-ifconf
1304   list
1305   read-ifconf
1306   write-ifconf!
1307   (length  int)                                   ;int ifc_len
1308   (request '*))                                   ;struct ifreq *ifc_ifcu
1309
1310 (define ifreq-struct-size
1311   ;; 'struct ifreq' begins with an array of IF_NAMESIZE bytes containing the
1312   ;; interface name (nul-terminated), followed by a bunch of stuff.  This is
1313   ;; its size in bytes.
1314   (if (= 8 (sizeof '*))
1315       40
1316       32))
1317
1318 (define-c-struct sockaddr-in                      ;<linux/in.h>
1319   sizeof-sockaddrin
1320   (lambda (family port address)
1321     (make-socket-address family address port))
1322   read-sockaddr-in
1323   write-sockaddr-in!
1324   (family    unsigned-short)
1325   (port      (int16 ~ big))
1326   (address   (int32 ~ big)))
1327
1328 (define-c-struct sockaddr-in6                     ;<linux/in6.h>
1329   sizeof-sockaddr-in6
1330   (lambda (family port flowinfo address scopeid)
1331     (make-socket-address family address port flowinfo scopeid))
1332   read-sockaddr-in6
1333   write-sockaddr-in6!
1334   (family    unsigned-short)
1335   (port      (int16 ~ big))
1336   (flowinfo  (int32 ~ big))
1337   (address   (int128 ~ big))
1338   (scopeid   int32))
1339
1340 (define (write-socket-address! sockaddr bv index)
1341   "Write SOCKADDR, a socket address as returned by 'make-socket-address', to
1342 bytevector BV at INDEX."
1343   (let ((family (sockaddr:fam sockaddr)))
1344     (cond ((= family AF_INET)
1345            (write-sockaddr-in! bv index
1346                                family
1347                                (sockaddr:port sockaddr)
1348                                (sockaddr:addr sockaddr)))
1349           ((= family AF_INET6)
1350            (write-sockaddr-in6! bv index
1351                                 family
1352                                 (sockaddr:port sockaddr)
1353                                 (sockaddr:flowinfo sockaddr)
1354                                 (sockaddr:addr sockaddr)
1355                                 (sockaddr:scopeid sockaddr)))
1356           (else
1357            (error "unsupported socket address" sockaddr)))))
1358
1359 (define PF_PACKET 17)                             ;<bits/socket.h>
1360 (define AF_PACKET PF_PACKET)
1361
1362 (define* (read-socket-address bv #:optional (index 0))
1363   "Read a socket address from bytevector BV at INDEX."
1364   (let ((family (bytevector-u16-native-ref bv index)))
1365     (cond ((= family AF_INET)
1366            (read-sockaddr-in bv index))
1367           ((= family AF_INET6)
1368            (read-sockaddr-in6 bv index))
1369           (else
1370            ;; XXX: Unsupported address family, such as AF_PACKET.  Return a
1371            ;; vector such that the vector can at least call 'sockaddr:fam'.
1372            (vector family)))))
1373
1374 (define %ioctl
1375   ;; The most terrible interface, live from Scheme.
1376   (syscall->procedure int "ioctl" (list int unsigned-long '*)))
1377
1378 (define (bytes->string bytes)
1379   "Read BYTES, a list of bytes, and return the null-terminated string decoded
1380 from there, or #f if that would be an empty string."
1381   (match (take-while (negate zero?) bytes)
1382     (()
1383      #f)
1384     (non-zero
1385      (list->string (map integer->char non-zero)))))
1386
1387 (define (bytevector->string-list bv stride len)
1388   "Return the null-terminated strings found in BV every STRIDE bytes.  Read at
1389 most LEN bytes from BV."
1390   (let loop ((bytes  (take (bytevector->u8-list bv)
1391                            (min len (bytevector-length bv))))
1392              (result '()))
1393     (match bytes
1394       (()
1395        (reverse result))
1396       (_
1397        (loop (drop bytes stride)
1398              (cons (bytes->string bytes) result))))))
1399
1400 (define* (network-interface-names #:optional sock)
1401   "Return the names of existing network interfaces.  This is typically limited
1402 to interfaces that are currently up."
1403   (let* ((close? (not sock))
1404          (sock   (or sock (socket SOCK_STREAM AF_INET 0)))
1405          (len    (* ifreq-struct-size 10))
1406          (reqs   (make-bytevector len))
1407          (conf   (make-bytevector sizeof-ifconf)))
1408     (write-ifconf! conf 0
1409                    len (bytevector->pointer reqs))
1410
1411     (let-values (((ret err)
1412                   (%ioctl (fileno sock) SIOCGIFCONF
1413                           (bytevector->pointer conf))))
1414       (when close?
1415         (close-port sock))
1416       (if (zero? ret)
1417           (bytevector->string-list reqs ifreq-struct-size
1418                                    (match (read-ifconf conf)
1419                                      ((len . _) len)))
1420           (throw 'system-error "network-interface-list"
1421                  "network-interface-list: ~A"
1422                  (list (strerror err))
1423                  (list err))))))
1424
1425 (define %interface-line
1426   ;; Regexp matching an interface line in Linux's /proc/net/dev.
1427   (make-regexp "^[[:blank:]]*([[:graph:]]+):.*$"))
1428
1429 (define (all-network-interface-names)
1430   "Return all the names of the registered network interfaces, including those
1431 that are not up."
1432   (call-with-input-file "/proc/net/dev"           ;XXX: Linux-specific
1433     (lambda (port)
1434       (let loop ((interfaces '()))
1435         (let ((line (read-line port)))
1436           (cond ((eof-object? line)
1437                  (reverse interfaces))
1438                 ((regexp-exec %interface-line line)
1439                  =>
1440                  (lambda (match)
1441                    (loop (cons (match:substring match 1) interfaces))))
1442                 (else
1443                  (loop interfaces))))))))
1444
1445 (define-as-needed (network-interface-flags socket name)
1446   "Return a number that is the bit-wise or of 'IFF*' flags for network
1447 interface NAME."
1448   (let ((req (make-bytevector ifreq-struct-size)))
1449     (bytevector-copy! (string->utf8 name) 0 req 0
1450                       (min (string-length name) (- IF_NAMESIZE 1)))
1451     (let-values (((ret err)
1452                   (%ioctl (fileno socket) SIOCGIFFLAGS
1453                           (bytevector->pointer req))))
1454       (if (zero? ret)
1455
1456           ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the
1457           ;; beginning of 'struct ifreq', and it's a short int.
1458           (bytevector-sint-ref req IF_NAMESIZE (native-endianness)
1459                                (sizeof short))
1460
1461           (throw 'system-error "network-interface-flags"
1462                  "network-interface-flags on ~A: ~A"
1463                  (list name (strerror err))
1464                  (list err))))))
1465
1466 (define (loopback-network-interface? name)
1467   "Return true if NAME designates a loopback network interface."
1468   (let* ((sock  (socket SOCK_STREAM AF_INET 0))
1469          (flags (network-interface-flags sock name)))
1470     (close-port sock)
1471     (not (zero? (logand flags IFF_LOOPBACK)))))
1472
1473 (define (network-interface-running? name)
1474   "Return true if NAME designates a running network interface."
1475   (let* ((sock  (socket SOCK_STREAM AF_INET 0))
1476          (flags (network-interface-flags sock name)))
1477     (close-port sock)
1478     (not (zero? (logand flags IFF_RUNNING)))))
1479
1480 (define (arp-network-interface? name)
1481   "Return true if NAME supports the Address Resolution Protocol."
1482   (let* ((sock  (socket SOCK_STREAM AF_INET 0))
1483          (flags (network-interface-flags sock name)))
1484     (close-port sock)
1485     (zero? (logand flags IFF_NOARP))))
1486
1487 (define-as-needed (set-network-interface-flags socket name flags)
1488   "Set the flag of network interface NAME to FLAGS."
1489   (let ((req (make-bytevector ifreq-struct-size)))
1490     (bytevector-copy! (string->utf8 name) 0 req 0
1491                       (min (string-length name) (- IF_NAMESIZE 1)))
1492     ;; Set the 'ifr_flags' field.
1493     (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness)
1494                           (sizeof short))
1495     (let-values (((ret err)
1496                   (%ioctl (fileno socket) SIOCSIFFLAGS
1497                           (bytevector->pointer req))))
1498       (unless (zero? ret)
1499         (throw 'system-error "set-network-interface-flags"
1500                "set-network-interface-flags on ~A: ~A"
1501                (list name (strerror err))
1502                (list err))))))
1503
1504 (define-as-needed (set-network-interface-address socket name sockaddr)
1505   "Set the address of network interface NAME to SOCKADDR."
1506   (let ((req (make-bytevector ifreq-struct-size)))
1507     (bytevector-copy! (string->utf8 name) 0 req 0
1508                       (min (string-length name) (- IF_NAMESIZE 1)))
1509     ;; Set the 'ifr_addr' field.
1510     (write-socket-address! sockaddr req IF_NAMESIZE)
1511     (let-values (((ret err)
1512                   (%ioctl (fileno socket) SIOCSIFADDR
1513                           (bytevector->pointer req))))
1514       (unless (zero? ret)
1515         (throw 'system-error "set-network-interface-address"
1516                "set-network-interface-address on ~A: ~A"
1517                (list name (strerror err))
1518                (list err))))))
1519
1520 (define (set-network-interface-netmask socket name sockaddr)
1521   "Set the network mask of interface NAME to SOCKADDR."
1522   (let ((req (make-bytevector ifreq-struct-size)))
1523     (bytevector-copy! (string->utf8 name) 0 req 0
1524                       (min (string-length name) (- IF_NAMESIZE 1)))
1525     ;; Set the 'ifr_addr' field.
1526     (write-socket-address! sockaddr req IF_NAMESIZE)
1527     (let-values (((ret err)
1528                   (%ioctl (fileno socket) SIOCSIFNETMASK
1529                           (bytevector->pointer req))))
1530       (unless (zero? ret)
1531         (throw 'system-error "set-network-interface-netmask"
1532                "set-network-interface-netmask on ~A: ~A"
1533                (list name (strerror err))
1534                (list err))))))
1535
1536 (define (network-interface-address socket name)
1537   "Return the address of network interface NAME.  The result is an object of
1538 the same type as that returned by 'make-socket-address'."
1539   (let ((req (make-bytevector ifreq-struct-size)))
1540     (bytevector-copy! (string->utf8 name) 0 req 0
1541                       (min (string-length name) (- IF_NAMESIZE 1)))
1542     (let-values (((ret err)
1543                   (%ioctl (fileno socket) SIOCGIFADDR
1544                           (bytevector->pointer req))))
1545       (if (zero? ret)
1546           (read-socket-address req IF_NAMESIZE)
1547           (throw 'system-error "network-interface-address"
1548                  "network-interface-address on ~A: ~A"
1549                  (list name (strerror err))
1550                  (list err))))))
1551
1552 (define (network-interface-netmask socket name)
1553   "Return the netmask of network interface NAME.  The result is an object of
1554 the same type as that returned by 'make-socket-address'."
1555   (let ((req (make-bytevector ifreq-struct-size)))
1556     (bytevector-copy! (string->utf8 name) 0 req 0
1557                       (min (string-length name) (- IF_NAMESIZE 1)))
1558     (let-values (((ret err)
1559                   (%ioctl (fileno socket) SIOCGIFNETMASK
1560                           (bytevector->pointer req))))
1561       (if (zero? ret)
1562           (read-socket-address req IF_NAMESIZE)
1563           (throw 'system-error "network-interface-netmask"
1564                  "network-interface-netmask on ~A: ~A"
1565                  (list name (strerror err))
1566                  (list err))))))
1567
1568 (define* (configure-network-interface name sockaddr flags
1569                                       #:key netmask)
1570   "Configure network interface NAME to use SOCKADDR, an address as returned by
1571 'make-socket-address', and FLAGS, a bitwise-or of IFF_* constants.  If NETMASK
1572 is true, it must be a socket address to use as the network mask."
1573   (let ((sock (socket (sockaddr:fam sockaddr) SOCK_STREAM 0)))
1574     (dynamic-wind
1575       (const #t)
1576       (lambda ()
1577         (set-network-interface-address sock name sockaddr)
1578         (set-network-interface-flags sock name flags)
1579         (when netmask
1580           (set-network-interface-netmask sock name netmask)))
1581       (lambda ()
1582         (close-port sock)))))
1583
1584 (define* (set-network-interface-up name
1585                                    #:key (family AF_INET))
1586   "Turn up the interface NAME."
1587   (let ((sock (socket family SOCK_STREAM 0)))
1588     (dynamic-wind
1589       (const #t)
1590       (lambda ()
1591         (let ((flags (network-interface-flags sock name)))
1592           (set-network-interface-flags sock name
1593                                        (logior flags IFF_UP))))
1594       (lambda ()
1595         (close-port sock)))))
1596
1597 \f
1598 ;;;
1599 ;;; Network routes.
1600 ;;;
1601
1602 (define-c-struct %rtentry                 ;'struct rtentry' from <net/route.h>
1603   sizeof-rtentry
1604   list
1605   read-rtentry
1606   write-rtentry!
1607   (pad1            unsigned-long)
1608   (destination     (array uint8 16))              ;struct sockaddr
1609   (gateway         (array uint8 16))              ;struct sockaddr
1610   (genmask         (array uint8 16))              ;struct sockaddr
1611   (flags           unsigned-short)
1612   (pad2            short)
1613   (pad3            long)
1614   (tos             uint8)
1615   (class           uint8)
1616   (pad4            (array uint8 (if (= 8 (sizeof* '*)) 3 1)))
1617   (metric          short)
1618   (device          '*)
1619   (mtu             unsigned-long)
1620   (window          unsigned-long)
1621   (initial-rtt     unsigned-short))
1622
1623 (define RTF_UP #x0001)                     ;'rtentry' flags from <net/route.h>
1624 (define RTF_GATEWAY #x0002)
1625
1626 (define %sockaddr-any
1627   (make-socket-address AF_INET INADDR_ANY 0))
1628
1629 (define add-network-route/gateway
1630   ;; To allow field names to be matched as literals, we need to move them out
1631   ;; of the lambda's body since the parameters have the same name.  A lot of
1632   ;; fuss for very little.
1633   (let-syntax ((gateway-offset (identifier-syntax
1634                                 (c-struct-field-offset %rtentry gateway)))
1635                (destination-offset (identifier-syntax
1636                                     (c-struct-field-offset %rtentry destination)))
1637                (genmask-offset (identifier-syntax
1638                                 (c-struct-field-offset %rtentry genmask))))
1639     (lambda* (socket gateway
1640                      #:key (destination %sockaddr-any) (genmask %sockaddr-any))
1641       "Add a network route for DESTINATION (a socket address as returned by
1642 'make-socket-address') that goes through GATEWAY (a socket address).  For
1643 instance, the call:
1644
1645   (add-network-route/gateway sock
1646                              (make-socket-address
1647                                AF_INET
1648                                (inet-pton AF_INET \"192.168.0.1\")
1649                                0))
1650
1651 is equivalent to this 'net-tools' command:
1652
1653   route add -net default gw 192.168.0.1
1654
1655 because the default value of DESTINATION is \"0.0.0.0\"."
1656       (let ((route (make-bytevector sizeof-rtentry 0)))
1657         (write-socket-address! gateway route gateway-offset)
1658         (write-socket-address! destination route destination-offset)
1659         (write-socket-address! genmask route genmask-offset)
1660         (bytevector-u16-native-set! route
1661                                     (c-struct-field-offset %rtentry flags)
1662                                     (logior RTF_UP RTF_GATEWAY))
1663         (let-values (((ret err)
1664                       (%ioctl (fileno socket) SIOCADDRT
1665                               (bytevector->pointer route))))
1666           (unless (zero? ret)
1667             (throw 'system-error "add-network-route/gateway"
1668                    "add-network-route/gateway: ~A"
1669                    (list (strerror err))
1670                    (list err))))))))
1671
1672 (define delete-network-route
1673   (let-syntax ((destination-offset (identifier-syntax
1674                                     (c-struct-field-offset %rtentry destination))))
1675     (lambda* (socket destination)
1676       "Delete the network route for DESTINATION.  For instance, the call:
1677
1678   (delete-network-route sock
1679                         (make-socket-address AF_INET INADDR_ANY 0))
1680
1681 is equivalent to the 'net-tools' command:
1682
1683   route del -net default
1684 "
1685
1686       (let ((route (make-bytevector sizeof-rtentry 0)))
1687         (write-socket-address! destination route destination-offset)
1688         (let-values (((ret err)
1689                       (%ioctl (fileno socket) SIOCDELRT
1690                               (bytevector->pointer route))))
1691           (unless (zero? ret)
1692             (throw 'system-error "delete-network-route"
1693                    "delete-network-route: ~A"
1694                    (list (strerror err))
1695                    (list err))))))))
1696
1697 \f
1698 ;;;
1699 ;;; Details about network interfaces---aka. 'getifaddrs'.
1700 ;;;
1701
1702 ;; Network interfaces.  XXX: We would call it <network-interface> but that
1703 ;; would collide with the ioctl wrappers above.
1704 (define-record-type <interface>
1705   (make-interface name flags address netmask broadcast-address)
1706   interface?
1707   (name              interface-name)               ;string
1708   (flags             interface-flags)              ;or'd IFF_* values
1709   (address           interface-address)            ;sockaddr | #f
1710   (netmask           interface-netmask)            ;sockaddr | #f
1711   (broadcast-address interface-broadcast-address)) ;sockaddr | #f
1712
1713 (define (write-interface interface port)
1714   (match interface
1715     (($ <interface> name flags address)
1716      (format port "#<interface ~s " name)
1717      (unless (zero? (logand IFF_UP flags))
1718        (display "up " port))
1719
1720      ;; Check whether ADDRESS really is a sockaddr.
1721      (when address
1722        (if (member (sockaddr:fam address) (list AF_INET AF_INET6))
1723            (format port "~a " (inet-ntop (sockaddr:fam address)
1724                                          (sockaddr:addr address)))
1725            (format port "family:~a " (sockaddr:fam address))))
1726
1727      (format port "~a>" (number->string (object-address interface) 16)))))
1728
1729 (set-record-type-printer! <interface> write-interface)
1730
1731 (define (values->interface next name flags address netmask
1732                            broadcast-address data)
1733   "Given the raw field values passed as arguments, return a pair whose car is
1734 an <interface> object, and whose cdr is the pointer NEXT."
1735   (define (maybe-socket-address pointer)
1736     (if (null-pointer? pointer)
1737         #f
1738         (read-socket-address (pointer->bytevector pointer 50)))) ;XXX: size
1739
1740   (cons (make-interface (if (null-pointer? name)
1741                             #f
1742                             (pointer->string name))
1743                         flags
1744                         (maybe-socket-address address)
1745                         (maybe-socket-address netmask)
1746                         (maybe-socket-address broadcast-address)
1747                         ;; Ignore DATA.
1748                         )
1749         next))
1750
1751 (define-c-struct ifaddrs                          ;<ifaddrs.h>
1752   %sizeof-ifaddrs
1753   values->interface
1754   read-ifaddrs
1755   write-ifaddrs!
1756   (next          '*)
1757   (name          '*)
1758   (flags         unsigned-int)
1759   (addr          '*)
1760   (netmask       '*)
1761   (broadcastaddr '*)
1762   (data          '*))
1763
1764 (define (unfold-interface-list ptr)
1765   "Call 'read-ifaddrs' on PTR and all its 'next' fields, recursively, and
1766 return the list of resulting <interface> objects."
1767   (let loop ((ptr    ptr)
1768              (result '()))
1769     (if (null-pointer? ptr)
1770         (reverse result)
1771         (match (read-ifaddrs (pointer->bytevector ptr %sizeof-ifaddrs))
1772           ((ifaddr . ptr)
1773            (loop ptr (cons ifaddr result)))))))
1774
1775 (define network-interfaces
1776   (let ((proc (syscall->procedure int "getifaddrs" (list '*))))
1777     (lambda ()
1778       "Return a list of <interface> objects, each denoting a configured
1779 network interface.  This is implemented using the 'getifaddrs' libc function."
1780       (let*-values (((ptr)
1781                      (bytevector->pointer (make-bytevector (sizeof* '*))))
1782                     ((ret err)
1783                      (proc ptr)))
1784         (if (zero? ret)
1785             (let* ((ptr    (dereference-pointer ptr))
1786                    (result (unfold-interface-list ptr)))
1787               (free-ifaddrs ptr)
1788               result)
1789             (throw 'system-error "network-interfaces" "~A"
1790                    (list (strerror err))
1791                    (list err)))))))
1792
1793 (define free-ifaddrs
1794   (syscall->procedure void "freeifaddrs" '(*)))
1795
1796 \f
1797 ;;;
1798 ;;; Terminals.
1799 ;;;
1800
1801 (define-syntax bits->symbols-body
1802   (syntax-rules ()
1803     ((_ bits () ())
1804      '())
1805     ((_ bits (name names ...) (value values ...))
1806      (let ((result (bits->symbols-body bits (names ...) (values ...))))
1807        (if (zero? (logand bits value))
1808            result
1809            (cons 'name result))))))
1810
1811 (define-syntax define-bits
1812   (syntax-rules (define)
1813     "Define the given numerical constants under CONSTRUCTOR, such that
1814  (CONSTRUCTOR NAME) returns VALUE.  Define BITS->SYMBOLS as a procedure that,
1815 given an integer, returns the list of names of the constants that are or'd."
1816     ((_ constructor bits->symbols (define names values) ...)
1817      (begin
1818        (define-syntax constructor
1819          (syntax-rules (names ...)
1820            ((_) 0)
1821            ((_ names) values) ...
1822            ((_ first rest (... ...))
1823             (logior (constructor first) rest (... ...)))))
1824        (define (bits->symbols bits)
1825          (bits->symbols-body bits (names ...) (values ...)))))))
1826
1827 ;; 'local-flags' bits from <bits/termios.h>
1828 (define-bits local-flags
1829   local-flags->symbols
1830  (define ISIG #o0000001)
1831  (define ICANON #o0000002)
1832  (define XCASE #o0000004)
1833  (define ECHO #o0000010)
1834  (define ECHOE #o0000020)
1835  (define ECHOK #o0000040)
1836  (define ECHONL #o0000100)
1837  (define NOFLSH #o0000200)
1838  (define TOSTOP #o0000400)
1839  (define ECHOCTL #o0001000)
1840  (define ECHOPRT #o0002000)
1841  (define ECHOKE #o0004000)
1842  (define FLUSHO #o0010000)
1843  (define PENDIN #o0040000)
1844  (define IEXTEN #o0100000)
1845  (define EXTPROC #o0200000))
1846
1847 (define-bits input-flags
1848   input-flags->symbols
1849   (define IGNBRK #o0000001)
1850   (define BRKINT #o0000002)
1851   (define IGNPAR #o0000004)
1852   (define PARMRK #o0000010)
1853   (define INPCK #o0000020)
1854   (define ISTRIP #o0000040)
1855   (define INLCR #o0000100)
1856   (define IGNCR #o0000200)
1857   (define ICRNL #o0000400)
1858   (define IUCLC #o0001000)
1859   (define IXON #o0002000)
1860   (define IXANY #o0004000)
1861   (define IXOFF #o0010000)
1862   (define IMAXBEL #o0020000)
1863   (define IUTF8 #o0040000))
1864
1865 ;; "Actions" values for 'tcsetattr'.
1866 (define-bits tcsetattr-action
1867   %unused-tcsetattr-action->symbols
1868   (define TCSANOW  0)
1869   (define TCSADRAIN 1)
1870   (define TCSAFLUSH 2))
1871
1872 (define-record-type <termios>
1873   (termios input-flags output-flags control-flags local-flags
1874            line-discipline control-chars
1875            input-speed output-speed)
1876   termios?
1877   (input-flags      termios-input-flags)
1878   (output-flags     termios-output-flags)
1879   (control-flags    termios-control-flags)
1880   (local-flags      termios-local-flags)
1881   (line-discipline  termios-line-discipline)
1882   (control-chars    termios-control-chars)
1883   (input-speed      termios-input-speed)
1884   (output-speed     termios-output-speed))
1885
1886 (define-c-struct %termios                         ;<bits/termios.h>
1887   sizeof-termios
1888   termios
1889   read-termios
1890   write-termios!
1891   (input-flags      unsigned-int)
1892   (output-flags     unsigned-int)
1893   (control-flags    unsigned-int)
1894   (local-flags      unsigned-int)
1895   (line-discipline  uint8)
1896   (control-chars    (array uint8 32))
1897   (input-speed      unsigned-int)
1898   (output-speed     unsigned-int))
1899
1900 (define tcgetattr
1901   (let ((proc (syscall->procedure int "tcgetattr" (list int '*))))
1902     (lambda (fd)
1903       "Return the <termios> structure for the tty at FD."
1904       (let*-values (((bv)      (make-bytevector sizeof-termios))
1905                     ((ret err) (proc fd (bytevector->pointer bv))))
1906         (if (zero? ret)
1907             (read-termios bv)
1908             (throw 'system-error "tcgetattr" "~A"
1909                    (list (strerror err))
1910                    (list err)))))))
1911
1912 (define tcsetattr
1913   (let ((proc (syscall->procedure int "tcsetattr" (list int int '*))))
1914     (lambda (fd actions termios)
1915       "Use TERMIOS for the tty at FD.  ACTIONS is one of of the values
1916 produced by 'tcsetattr-action'; see tcsetattr(3) for details."
1917       (define bv
1918         (make-bytevector sizeof-termios))
1919
1920       (let-syntax ((match/write (syntax-rules ()
1921                                   ((_ fields ...)
1922                                    (match termios
1923                                      (($ <termios> fields ...)
1924                                       (write-termios! bv 0 fields ...)))))))
1925         (match/write input-flags output-flags control-flags local-flags
1926                      line-discipline control-chars input-speed output-speed))
1927
1928       (let-values (((ret err) (proc fd actions (bytevector->pointer bv))))
1929         (unless (zero? ret)
1930           (throw 'system-error "tcgetattr" "~A"
1931                  (list (strerror err))
1932                  (list err)))))))
1933
1934 (define-syntax TIOCGWINSZ                         ;<asm-generic/ioctls.h>
1935   (identifier-syntax #x5413))
1936
1937 (define-record-type <window-size>
1938   (window-size rows columns x-pixels y-pixels)
1939   window-size?
1940   (rows     window-size-rows)
1941   (columns  window-size-columns)
1942   (x-pixels window-size-x-pixels)
1943   (y-pixels window-size-y-pixels))
1944
1945 (define-c-struct winsize                          ;<bits/ioctl-types.h>
1946   sizeof-winsize
1947   window-size
1948   read-winsize
1949   write-winsize!
1950   (rows          unsigned-short)
1951   (columns       unsigned-short)
1952   (x-pixels      unsigned-short)
1953   (y-pixels      unsigned-short))
1954
1955 (define* (terminal-window-size #:optional (port (current-output-port)))
1956   "Return a <window-size> structure describing the terminal at PORT, or raise
1957 a 'system-error' if PORT is not backed by a terminal.  This procedure
1958 corresponds to the TIOCGWINSZ ioctl."
1959   (let*-values (((size)    (make-bytevector sizeof-winsize))
1960                 ((ret err) (%ioctl (fileno port) TIOCGWINSZ
1961                                    (bytevector->pointer size))))
1962     (if (zero? ret)
1963         (read-winsize size)
1964         (throw 'system-error "terminal-window-size" "~A"
1965                (list (strerror err))
1966                (list err)))))
1967
1968 (define (terminal-dimension window-dimension port fall-back)
1969   "Return the terminal dimension defined by WINDOW-DIMENSION, one of
1970 'window-size-columns' or 'window-size-rows' for PORT.  If PORT does not
1971 correspond to a terminal, return the value returned by FALL-BACK."
1972   (catch 'system-error
1973     (lambda ()
1974       (if (file-port? port)
1975           (match (window-dimension (terminal-window-size port))
1976             ;; Things like Emacs shell-mode return 0, which is unreasonable.
1977             (0 (fall-back))
1978             ((? number? n) n))
1979           (fall-back)))
1980     (lambda args
1981       (let ((errno (system-error-errno args)))
1982         ;; ENOTTY is what we're after but 2012-and-earlier Linux versions
1983         ;; would return EINVAL instead in some cases:
1984         ;; <https://bugs.ruby-lang.org/issues/10494>.
1985         ;; Furthermore, some FUSE file systems like unionfs return ENOSYS for
1986         ;; that ioctl.
1987         (if (memv errno (list ENOTTY EINVAL ENOSYS))
1988             (fall-back)
1989             (apply throw args))))))
1990
1991 (define* (terminal-columns #:optional (port (current-output-port)))
1992   "Return the best approximation of the number of columns of the terminal at
1993 PORT, trying to guess a reasonable value if all else fails.  The result is
1994 always a positive integer."
1995   (define (fall-back)
1996     (match (and=> (getenv "COLUMNS") string->number)
1997       (#f 80)
1998       ((? number? columns)
1999        (if (> columns 0) columns 80))))
2000
2001   (terminal-dimension window-size-columns port fall-back))
2002
2003 (define* (terminal-rows #:optional (port (current-output-port)))
2004   "Return the best approximation of the number of rows of the terminal at
2005 PORT, trying to guess a reasonable value if all else fails.  The result is
2006 always a positive integer."
2007   (terminal-dimension window-size-rows port (const 25)))
2008
2009 \f
2010 ;;;
2011 ;;; utmpx.
2012 ;;;
2013
2014 (define-record-type <utmpx-entry>
2015   (utmpx type pid line id user host termination exit
2016          session time address)
2017   utmpx?
2018   (type           utmpx-login-type)               ;login-type
2019   (pid            utmpx-pid)
2020   (line           utmpx-line)                     ;device name
2021   (id             utmpx-id)
2022   (user           utmpx-user)                     ;user name
2023   (host           utmpx-host)                     ;host name | #f
2024   (termination    utmpx-termination-status)
2025   (exit           utmpx-exit-status)
2026   (session        utmpx-session-id)               ;session ID, for windowing
2027   (time           utmpx-time)                     ;entry time
2028   (address        utmpx-address))
2029
2030 (define-c-struct %utmpx                           ;<utmpx.h>
2031   sizeof-utmpx
2032   (lambda (type pid line id user host termination exit session
2033                 seconds useconds address %reserved)
2034     (utmpx type pid
2035            (bytes->string line) id
2036            (bytes->string user)
2037            (bytes->string host) termination exit
2038            session
2039            (make-time time-utc (* 1000 useconds) seconds)
2040            address))
2041   read-utmpx
2042   write-utmpx!
2043   (type           short)
2044   (pid            int)
2045   (line           (array uint8 32))
2046   (id             (array uint8 4))
2047   (user           (array uint8 32))
2048   (host           (array uint8 256))
2049   (termination    short)
2050   (exit           short)
2051   (session        int32)
2052   (time-seconds   int32)
2053   (time-useconds  int32)
2054   (address-v6     (array int32 4))
2055   (%reserved      (array uint8 20)))
2056
2057 (define-bits login-type
2058   %unused-login-type->symbols
2059   (define EMPTY 0)                      ;No valid user accounting information.
2060   (define RUN_LVL 1)                    ;The system's runlevel.
2061   (define BOOT_TIME 2)                  ;Time of system boot.
2062   (define NEW_TIME 3)                   ;Time after system clock changed.
2063   (define OLD_TIME 4)                   ;Time when system clock changed.
2064
2065   (define INIT_PROCESS 5)                ;Process spawned by the init process.
2066   (define LOGIN_PROCESS 6)               ;Session leader of a logged in user.
2067   (define USER_PROCESS 7)                ;Normal process.
2068   (define DEAD_PROCESS 8)                ;Terminated process.
2069
2070   (define ACCOUNTING 9))                 ;System accounting.
2071
2072 (define setutxent
2073   (let ((proc (syscall->procedure void "setutxent" '())))
2074     (lambda ()
2075       "Open the user accounting database."
2076       (proc))))
2077
2078 (define endutxent
2079   (let ((proc (syscall->procedure void "endutxent" '())))
2080     (lambda ()
2081       "Close the user accounting database."
2082       (proc))))
2083
2084 (define getutxent
2085   (let ((proc (syscall->procedure '* "getutxent" '())))
2086     (lambda ()
2087       "Return the next entry from the user accounting database."
2088       (let ((ptr (proc)))
2089         (if (null-pointer? ptr)
2090             #f
2091             (read-utmpx (pointer->bytevector ptr sizeof-utmpx)))))))
2092
2093 (define (utmpx-entries)
2094   "Return the list of entries read from the user accounting database."
2095   (setutxent)
2096   (let loop ((entries '()))
2097     (match (getutxent)
2098       (#f
2099        (endutxent)
2100        (reverse entries))
2101       ((? utmpx? entry)
2102        (loop (cons entry entries))))))
2103
2104 (define (read-utmpx-from-port port)
2105   "Read a utmpx entry from PORT.  Return either the EOF object or a utmpx
2106 entry."
2107   (match (get-bytevector-n port sizeof-utmpx)
2108     ((? eof-object? eof)
2109      eof)
2110     ((? bytevector? bv)
2111      (read-utmpx bv))))
2112
2113 ;;; syscalls.scm ends here