;;;; 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 (ip route)

  #:use-module (ice-9 match)

  #:use-module (ip link)

  #:use-module (ip utils)

  #:use-module (netlink route route)

  #:use-module (netlink route attrs)

  #:use-module (netlink connection)

  #:use-module (netlink constant)

  #:use-module (netlink deserialize)

  #:use-module (netlink message)

  #:use-module (netlink standard)

  #:use-module (srfi srfi-1)

  #:use-module (srfi srfi-9)

  #:export (route-add

            route-del

            route-show))

(define-record-type <route>

  (make-route family table dest src gateway proto scope priority device)

  route?

  (family   route-family)

  (table    route-table)

  (dest     route-dest)

  (src      route-src)

  (gateway  route-gateway)

  (proto    route-proto)

  (scope    route-scope)

  (priority route-priority)

  (device   route-device))

(define* (route-del dest

                    #:key (ipv6? #f) (device #f) (table RT_TABLE_MAIN)

                          (protocol #f) (scope RT_SCOPE_NOWHERE) (type #f)

                          (priority #f) (src #f) (via #f))

  (define request-num (random 65535))

  (define index

    (cond

      ((number? device) device)

      ((string? device) (link-name->index device))

      (else #f)))

  (define message

    (make-message

      RTM_DELROUTE

      (logior NLM_F_REQUEST NLM_F_ACK)

      request-num

      0

      (make-route-message

        (if ipv6? AF_INET6 AF_INET)

        (if (equal? dest "default") 0 (cidr->prefix dest))

        (if src (cidr->prefix src) 0)

        0

        table

        (or protocol 0)

        scope

        (or type 0)

        0

        `(,@(if (equal? dest "default")

                '()

                (list (make-route-attr RTA_DST

                        ((if ipv6?

                             make-ipv6-route-attr

                             make-ipv4-route-attr)

                         (cidr->addr dest)))))

          ,@(if index

                (list (make-route-attr RTA_OIF

                        (make-u32-route-attr index)))

                '())

          ,@(if src

                (list (make-route-attr RTA_PREFSRC

                        ((if ipv6?

                             make-ipv6-route-attr

                             make-ipv4-route-attr)

                         (cidr->addr src))))

                '())

          ,@(if via

                (list (make-route-attr RTA_GATEWAY

                        ((if ipv6?

                             make-ipv6-route-attr

                             make-ipv4-route-attr)

                         via)))

                '())

          ,@(if priority

                (list (make-route-attr RTA_PRIORITY

                        (make-u32-route-attr priority)))

                '())))))

  (let ((sock (connect-route)))

    (send-msg message sock)

    (let ((answer (receive-and-decode-msg sock %default-route-decoder)))

      (close-port sock)

      (answer-ok? (last answer)))))

(define* (route-add dest

                    #:key (ipv6? #f) (device #f) (table RT_TABLE_MAIN)

                          (protocol RTPROT_BOOT) (scope RT_SCOPE_UNIVERSE)

                          (type RTN_UNICAST) (priority #f) (src #f) (via #f)

                          (onlink? #f))

  (define request-num (random 65535))

  (define index

    (cond

      ((number? device) device)

      ((string? device) (link-name->index device))

      (else #f)))

  (define message

    (make-message

      RTM_NEWROUTE

      (logior NLM_F_REQUEST NLM_F_ACK NLM_F_EXCL NLM_F_CREATE)

      request-num

      0

      (make-route-message

        (if ipv6? AF_INET6 AF_INET)

        (if (equal? dest "default") 0 (cidr->prefix dest))

        (if src (cidr->prefix src) 0)

        0

        table

        (or protocol 0)

        scope

        type

        (if onlink? RTNH_F_ONLINK 0)

        `(,@(if (equal? dest "default")

                '()

                (list (make-route-attr RTA_DST

                        ((if ipv6?

                             make-ipv6-route-attr

                             make-ipv4-route-attr)

                         (cidr->addr dest)))))

          ,@(if index

                (list (make-route-attr RTA_OIF

                        (make-u32-route-attr index)))

                '())

          ,@(if src

                (list (make-route-attr RTA_PREFSRC

                        ((if ipv6?

                             make-ipv6-route-attr

                             make-ipv4-route-attr)

                         (cidr->addr src))))

                '())

          ,@(if via

                (list (make-route-attr RTA_GATEWAY

                        ((if ipv6?

                             make-ipv6-route-attr

                             make-ipv4-route-attr)

                         via)))

                '())

          ,@(if priority

                (list (make-route-attr RTA_PRIORITY

                        (make-u32-route-attr priority)))

                '())))))

  (let ((sock (connect-route)))

    (send-msg message sock)

    (let ((answer (receive-and-decode-msg sock %default-route-decoder)))

      (close-port sock)

      (answer-ok? (last answer)))))

(define (link-ref links id)

  (let loop ((links links))

    (match links

      (() #f)

      ((link links ...)

       (if (equal? (link-id link) id)

           link

           (loop links))))))

(define (get-routes links)

  (define request-num (random 65535))

  (define message

    (make-message

      RTM_GETROUTE

      (logior NLM_F_REQUEST NLM_F_DUMP)

      request-num

      0

      (make-route-message AF_UNSPEC 0 0 0 0 0 0 0 0 '())))

  (let ((sock (connect-route)))

    (send-msg message sock)

    (let* ((answer (receive-and-decode-msg sock %default-route-decoder))

           (routes (filter

                     (lambda (msg) (equal? (message-kind msg) RTM_NEWROUTE))

                     answer))

           (routes (map

                     (lambda (msg)

                       (let* ((data (message-data msg))

                              (attrs (route-message-attrs data)))

                         (make-route

                           (route-message-family data)

                           (or (get-attr attrs RTA_TABLE)

                               (route-message-table data))

                           (let ((len (route-message-dest-len data))

                                 (dest (get-attr attrs RTA_DST)))

                             (if (or (equal? len 0) (not dest))

                                 #f

                                 (string-append dest "/" (number->string len))))

                           (let ((len (route-message-src-len data))

                                 (src (get-attr attrs RTA_PREFSRC)))

                             (if (or (equal? len 0) (not src))

                                 #f

                                 (string-append src "/" (number->string len))))

                           (get-attr attrs RTA_GATEWAY)

                           (route-message-protocol data)

                           (route-message-scope data)

                           (get-attr attrs RTA_PRIORITY)

                           (link-ref links (get-attr attrs RTA_OIF)))))

                     routes)))

      (close-port sock)

      routes)))

(define print-route

  (match-lambda

    (($ <route> family table dest src gateway proto scope priority device)

     (format #t "    ~a"

             (or dest "default"))

     (when gateway

       (format #t " via ~a" gateway))

     (when device

       (format #t " dev ~a" (link-name device)))

     (when (and proto (> proto 0))

       (format #t " proto ~a"

               (string-downcase

                 (substring (symbol->string (int->rtm-protocol proto)) 7))))

     (when (and scope (> scope 0))

       (format #t " scope ~a"

               (string-downcase

                 (substring (symbol->string (int->rtm-scope scope)) 9))))

     (when src

       (format #t " src ~a" src))

     (when priority

       (format #t " metric ~a" priority))

     (format #t "~%"))))

(define* (route-show #:key (table RT_TABLE_MAIN) (family AF_UNSPEC))

  (define links (get-links))

  (define routes (get-routes links))

  (for-each

    (lambda (route)

      (when (and (equal? (route-table route) table)

                 (or (equal? family AF_UNSPEC)

                     (equal? (route-family route) family)))

        (print-route route)))

    routes))