;;;; This file is part of Guile Netlink

;;;;

;;;; Copyright (C) 2021 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; 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-9)

  #:use-module (srfi srfi-34)

  #:use-module (srfi srfi-35)

  #:export (connect

            connect-route

            close-socket

            send-msg

            receive-msg

            receive-and-decode-msg

            get-addr))

(define libc (dynamic-link))

(define ffi-socket (pointer->procedure int

                                       (dynamic-func "socket" libc)

                                       (list int int int)))

(define ffi-close (pointer->procedure void

                                      (dynamic-func "close" libc)

                                      (list int)))

(define ffi-sendmsg (pointer->procedure int

                                        (dynamic-func "sendmsg" libc)

                                        (list int '* int)

                                        #:return-errno? #t))

(define ffi-sendto (pointer->procedure int

                                       (dynamic-func "sendto" libc)

                                       (list int '* size_t int '* int)

                                       #:return-errno? #t))

(define ffi-recvmsg (pointer->procedure int

                                        (dynamic-func "recvmsg" libc)

                                        (list int '* int)))

(define ffi-bind (pointer->procedure int

                                     (dynamic-func "bind" libc)

                                     (list int '* int)))

;; define socket type

(define-record-type socket

    (make-socket num open?)

    socket?

    (num socket-num)

    (open? socket-open?))

;; define simple functions to open/close sockets

(define (open-socket proto)

    (make-socket (ffi-socket AF_NETLINK (logior SOCK_RAW SOCK_CLOEXEC) proto) #t))

(define (close-socket socket)

    (if (socket-open? socket)

        (ffi-close (socket-num socket)))

    (make-socket (socket-num socket) #f))

(define (get-addr family pid groups)

  (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 (socket-num 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 (socket-num 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 (socket-num 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)))))))