;;;; This file is part of Guile Netlink
;;;;
;;;; Copyright (C) 2021 Julien Lepiller <julien@lepiller.eu>
;;;; Copyright (C) 2023 Ludovic Courtès <ludo@gnu.org>
;;;;
;;;; This library 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.
;;;;
;;;; This library 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 this library.  If not, see <https://www.gnu.org/licenses/>.

(define-module (netlink connection)
  #:use-module (netlink constant)
  #:use-module (netlink data)
  #:use-module (netlink error)
  #:use-module (netlink message)
  #:use-module (rnrs bytevectors)
  #:use-module (system foreign)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-71)
  #:autoload   (ice-9 suspendable-ports) (current-read-waiter
                                          current-write-waiter)
  #:export (connect
            connect-route
            close-socket
            send-msg
            receive-msg
            receive-and-decode-msg
            get-addr))

(define libc (dynamic-link))

(define* (syscall->procedure return-type function
                             argument-types
                             #:key waiter)
  "Return a procedure that calls FUNCTION, a syscall wrapper from the C library
with the given RETURN-TYPE and ARGUMENT-TYPES.  When WAITER is true and the
first argument is a port, call it upon EAGAIN or EWOULDBLOCK."
  (let ((proc (pointer->procedure return-type
                                  (dynamic-func function libc)
                                  argument-types
                                  #:return-errno? #t)))
    (lambda (first . rest)
      (let loop ()
        (let ((ret errno (apply proc
                                (if (port? first) (fileno first) first)
                                rest)))
          (if (< ret 0)
              (if (and (memv errno (list EAGAIN EWOULDBLOCK))
                       (port? first) waiter)
                  (begin
                    ((waiter) first)
                    (loop))
                  (throw 'system-error function "~A"
                         (list (strerror errno)) (list errno)))
              ret))))))

(define ffi-sendto
  (syscall->procedure int "sendto" (list int '* size_t int '* int)
                      #:waiter (lambda () (current-write-waiter))))
(define ffi-recvmsg
  (syscall->procedure int "recvmsg" (list int '* int)
                      #:waiter (lambda () (current-read-waiter))))
(define ffi-bind
  (syscall->procedure int "bind" (list int '* int)
                      #:waiter (lambda () (current-read-waiter))))

;; define simple functions to open/close sockets
(define (open-socket proto)
  (socket AF_NETLINK (logior SOCK_RAW SOCK_CLOEXEC) proto))

(define (close-socket sock)
  (issue-deprecation-warning
   "'close-socket' is deprecated; use 'close-port' instead.")
  (close-port sock))

(define (get-addr family pid groups)
  "This is a variant of 'make-socket-address' for AF_NETLINK sockets.  The
main difference is that it returns a raw bytevector that libguile procedures
such as 'bind' cannot handle."
  (let ((addr (make-bytevector 12)))
    (bytevector-u16-set! addr 0 family (native-endianness))
    (bytevector-u32-set! addr 4 pid (native-endianness))
    (bytevector-u32-set! addr 8 groups (native-endianness))
    addr))

(define (get-msghdr name namelen iov iovlen control controllen flags)
  (make-c-struct
    (list '* size_t '* size_t '* size_t int)
    (list name namelen iov iovlen control controllen flags)))

(define (get-iovec content size)
  (make-c-struct
    (list '* size_t)
    (list content size)))

(define* (connect proto addr)
  (let ((sock (open-socket proto)))
    (ffi-bind sock
              (bytevector->pointer addr)
              12)
    sock))

(define* (connect-route #:key (groups 0))
  (connect NETLINK_ROUTE (get-addr AF_NETLINK 0 groups)))

(define* (send-msg msg sock #:key (addr (get-addr AF_NETLINK 0 0)))
  (unless (message? msg)
    (raise (condition (&netlink-message-type-error
                        (message msg)))))

  (let* ((len (data-size msg))
         (bv (make-bytevector len)))
    (serialize msg 0 bv)
    (ffi-sendto sock (bytevector->pointer bv) len 0 %null-pointer 0)))

(define* (receive-msg sock #:key (addr (get-addr AF_NETLINK 0 0)))
  (let* ((len (* 1024 32))
         (bv (make-bytevector len))
         (iovec (get-iovec (bytevector->pointer bv) len))
         (msghdr (get-msghdr (bytevector->pointer addr) (bytevector-length addr)
                             iovec 1
                             %null-pointer 0
                             0))
         (size (ffi-recvmsg sock msghdr 0))
         (answer (make-bytevector size)))
    (when (> size (* 1024 32))
      (raise (condition (&netlink-answer-too-big-error (size size)))))
    (when (> size 0)
      (bytevector-copy! bv 0 answer 0 size))
    answer))

(define* (receive-and-decode-msg sock decoder
                                 #:key (addr (get-addr AF_NETLINK 0 0)))
  (let* ((answer (receive-msg sock #:addr addr))
         (size (bytevector-length answer)))
    (let loop ((messages '()) (pos 0))
      (if (>= pos size)
          (let ((last-message (car messages)))
            (if (and
                  (equal? (logand (message-flags last-message) NLM_F_MULTI)
                          NLM_F_MULTI)
                  (> (message-kind last-message) NLMSG_OVERUN))
                (append (reverse messages)
                        (receive-and-decode-msg sock decoder #:addr addr))
                (reverse messages)))
          (let ((message (deserialize 'message decoder answer pos)))
            (loop (cons message messages)
                  (+ (data-size message) pos)))))))