guix/build/syscalls.scm

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