;; endpoints.scm -- Network connection endpoints.
;; Copyright (C) 2023-2024 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 endpoints)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 match)
  #:use-module (shepherd support)
  #:use-module (shepherd system)
  #:export (endpoint
            endpoint?
            endpoint-name
            endpoint-address
            endpoint-style
            endpoint-backlog
            endpoint-socket-owner
            endpoint-socket-group
            endpoint-socket-directory-permissions
            endpoint-bind-attempts
            endpoint->sexp
            default-bind-attempts
            bind/retry-if-in-use
            open-sockets))

;;; Commentary:
;;;
;;; This module defines "server endpoints", an abstraction representing
;;; server-side endpoints to listen on, along with a procedure to open a set
;;; of endpoints and obtain the corresponding listening sockets.
;;;
;;; Code:

;; Endpoint of a systemd-style or inetd-style service.
(define-record-type <endpoint>
  (make-endpoint name address style backlog owner group permissions
                 bind-attempts)
  endpoint?
  (name        endpoint-name)                          ;string
  (address     endpoint-address)                       ;socket address
  (style       endpoint-style)                         ;SOCK_STREAM, etc.
  (backlog     endpoint-backlog)                       ;integer
  (owner       endpoint-socket-owner)                  ;integer
  (group       endpoint-socket-group)                  ;integer
  (permissions endpoint-socket-directory-permissions)  ;integer
  (bind-attempts endpoint-bind-attempts))              ;integer

(define (endpoint->sexp endpoint)
  `(endpoint (version 0)
             (name ,(endpoint-name endpoint))
             (address ,(endpoint-address endpoint))
             (style ,(endpoint-style endpoint))
             (backlog ,(endpoint-backlog endpoint))
             (owner ,(endpoint-socket-owner endpoint))
             (group ,(endpoint-socket-group endpoint))
             (permissions ,(endpoint-socket-directory-permissions endpoint))
             (bind-attempts ,(endpoint-bind-attempts endpoint))))

(define default-bind-attempts
  ;; Default number of 'bind' attempts upon EADDRINUSE.
  (make-parameter 5))

(define* (endpoint address
                   #:key (name "unknown") (style SOCK_STREAM)
                   (backlog 128)
                   (socket-owner (getuid)) (socket-group (getgid))
                   (socket-directory-permissions #o755)
                   (bind-attempts (default-bind-attempts)))
  "Return a new endpoint called @var{name} of @var{address}, an address as
return by @code{make-socket-address}, with the given @var{style} and
@var{backlog}.

When @var{address} is of type @code{AF_INET6}, the endpoint is
@emph{IPv6-only}.  Thus, if you want a service available both on IPv4 and
IPv6, you need two endpoints.

When @var{address} is of type @code{AF_UNIX}, @var{socket-owner} and
@var{socket-group} are strings or integers that specify its ownership and that
of its parent directory; @var{socket-directory-permissions} specifies the
permissions for its parent directory.

Upon @samp{EADDRINUSE} (``Address already in use''), up to @var{bind-attempts}
attempts will be made to @code{bind} on @var{address}, one every second."
  (make-endpoint name address style backlog
                 socket-owner socket-group
                 socket-directory-permissions
                 bind-attempts))

(define* (bind/retry-if-in-use sock address
                               #:key (max-attempts (default-bind-attempts)))
  "Bind @var{sock} to @var{address}.  Retry up to @var{max-attempts} times upon
EADDRINUSE."
  (let loop ((attempts 1))
    (catch 'system-error
      (lambda ()
        (bind sock address))
      (lambda args
        (if (and (= EADDRINUSE (system-error-errno args))
                 (< attempts max-attempts))
            (begin
              (local-output
               (l10n "Address ~a is in use; \
retrying to bind it in one second.")
               (socket-address->string address))
              (sleep 1)
              (loop (+ attempts 1)))
            (apply throw args))))))

(define (endpoint->listening-socket endpoint)
  "Return a listening socket for ENDPOINT."
  (match endpoint
    (($ <endpoint> name address style backlog
                   owner group permissions bind-attempts)
     ;; Make listening sockets SOCK_CLOEXEC: inetd-style services don't pass
     ;; them to the child process, and systemd-style do pass them but call
     ;; 'dup2' right before 'exec', thereby clearing this property.
     (let* ((sock    (socket (sockaddr:fam address)
                             (logior SOCK_NONBLOCK SOCK_CLOEXEC style)
                             0))
            (owner   (if (integer? owner)
                         owner
                         (passwd:uid (getpwnam owner))))
            (group   (if (integer? group)
                         group
                         (group:gid (getgrnam group)))))
       (when (= AF_INET6 (sockaddr:fam address))
         ;; Interpret AF_INET6 endpoints as IPv6-only.  This is contrary to
         ;; the Linux defaults where listening on an IPv6 address also listens
         ;; on its IPv4 counterpart.
         (ipv6-only sock))
       (when (= AF_UNIX (sockaddr:fam address))
         (mkdir-p (dirname (sockaddr:path address)) permissions)
         (chown (dirname (sockaddr:path address)) owner group)
         (catch-system-error (delete-file (sockaddr:path address))))

       ;; SO_REUSEADDR appears to be undefined for AF_UNIX sockets; on
       ;; GNU/Hurd, attempting to set it raises ENOPROTOOPT.
       (unless (= AF_UNIX (sockaddr:fam address))
         (setsockopt sock SOL_SOCKET SO_REUSEADDR 1))

       (bind/retry-if-in-use sock address
                             #:max-attempts bind-attempts)
       (when (= SOCK_STREAM style)
         (listen sock backlog))

       (when (= AF_UNIX (sockaddr:fam address))
         (chown (sockaddr:path address) owner group)
         (chmod (sockaddr:path address) #o666))

       sock))))

(define (open-sockets endpoints)
  "Return a list of listening sockets corresponding to @var{endpoints}, in the
same order as @var{endpoints}.  If opening or binding one of them fails, an
exception is thrown and previously-opened sockets are closed."
  (let loop ((endpoints endpoints)
             (result   '()))
    (match endpoints
      (()
       (reverse result))
      ((head tail ...)
       (let ((sock (catch 'system-error
                     (lambda ()
                       (endpoint->listening-socket head))
                     (lambda args
                       ;; When opening one socket fails, abort the whole
                       ;; process.
                       (for-each (match-lambda
                                   ((_ . socket) (close-port socket)))
                                 result)
                       (apply throw args)))))
         (loop tail (cons sock result)))))))

(define-syntax-rule (define-as-needed name value)
  (unless (defined? 'name)
    (module-define! (current-module) 'name value)
    (module-export! (current-module) '(name))))

;; These values are not defined as of Guile 3.0.8.  Provide them as a
;; convenience.
(define-as-needed IN6ADDR_LOOPBACK 1)
(define-as-needed IN6ADDR_ANY 0)
