;; system.scm -- Low-level operating system interface.
;; Copyright (C) 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;
;; This file is part of the GNU Shepherd.
;;
;; The GNU Shepherd is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or (at
;; your option) any later version.
;;
;; The GNU Shepherd is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.

(define-module (shepherd system)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-11)
  #:export (reboot
            halt
            power-off
            max-file-descriptors))

;; The <sys/reboot.h> constants.
(define RB_AUTOBOOT 19088743)
(define RB_HALT_SYSTEM 3454992675)
(define RB_POWER_OFF 1126301404)

(define (syscall->procedure return-type name argument-types)
  "Return a procedure that wraps the C function NAME using the dynamic FFI,
and that returns two values: NAME's return value, and errno.

If an error occurs while creating the binding, defer the error report until
the returned procedure is called."
  (catch #t
    (lambda ()
      (let ((ptr (dynamic-func name (dynamic-link))))
        ;; The #:return-errno? facility was introduced in Guile 2.0.12.
        ;; Support older versions of Guile by catching 'wrong-number-of-args'.
        (catch 'wrong-number-of-args
          (lambda ()
            (pointer->procedure return-type ptr argument-types
                                #:return-errno? #t))
          (lambda (key . rest)
            (let ((proc (pointer->procedure return-type ptr argument-types)))
              (lambda args
                (let ((result (apply proc args))
                      (err    (errno)))
                  (values result err))))))))
    (lambda args
      (lambda _
        (error (format #f "~a: syscall->procedure failed: ~s"
                       name args))))))

(define %libc-reboot
  ;; libc's 'reboot' function as declared in <sys/reboot.h>.
  (let ((proc (syscall->procedure int "reboot" (list unsigned-int))))
    (define (howto->symbol howto)
      (cond ((eqv? howto RB_AUTOBOOT) 'RB_AUTOBOOT)
            ((eqv? howto RB_HALT_SYSTEM) 'RB_HALT_SYSTEM)
            ((eqv? howto RB_POWER_OFF) 'RB_POWER_OFF)
            (else howto)))

    (lambda (howto)
      (let-values (((ret err) (proc howto)))
        (unless (zero? ret)
          (throw 'system-error "reboot" "~A: ~S"
                 (list (strerror err) (howto->symbol howto))
                 (list err)))))))

(define %libc-errno-pointer
  ;; Glibc's 'errno' pointer.
  (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
    (and errno-loc
         (let ((proc (pointer->procedure '* errno-loc '())))
           (proc)))))

(define errno
  (if %libc-errno-pointer
      (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
        (lambda ()
          "Return the current errno."
          ;; XXX: We assume that nothing changes 'errno' while we're doing all this.
          ;; In particular, that means that no async must be running here.

          ;; Use one of the fixed-size native-ref procedures because they are
          ;; optimized down to a single VM instruction, which reduces the risk
          ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.)
          (let-syntax ((ref (lambda (s)
                              (syntax-case s ()
                                ((_ bv)
                                 (case (sizeof int)
                                   ((4)
                                    #'(bytevector-s32-native-ref bv 0))
                                   ((8)
                                    #'(bytevector-s64-native-ref bv 0))
                                   (else
                                    (error "unsupported 'int' size"
                                           (sizeof int)))))))))
            (ref bv))))
      (lambda () 0)))

(define (reboot)
  "Perform a hard reset of the system now.  Return #f on failure."
  (%libc-reboot RB_AUTOBOOT))

(define (halt)
  "Halt the system.  Return #f on failure."
  (%libc-reboot RB_HALT_SYSTEM))

(define (power-off)
  "Stop system and switch power off if possible.  Return #f on failure."
  (%libc-reboot RB_POWER_OFF))


(define _SC_OPEN_MAX 4)

(define sysconf
  (let ((proc (syscall->procedure long "sysconf" (list int))))
    (lambda (name)
      "Return the system configuration for NAME."
      (let-values (((result err) (proc name)))
        (if (= -1 result)
            (throw 'system-error "sysconf" "~A: ~S"
                   (list (strerror err) name)
                   (list err))
            result)))))

(define (max-file-descriptors)
  "Return the maximum number of open file descriptors allowed."
  (sysconf _SC_OPEN_MAX))
