ip/route.scm \

* Addr::                   Actions on network addresses.

* Route::                  Actions on network routes.

If you wish to add an IPv6 address instead, set @code{#:ipv6} to @code{#t},

@node Route

@section Route

The @code{(ip route)} module introduces procedures to access and modify the

network routes on your machine.  They are equivalent to the @command{ip route}

family of commands, from @code{iproute2}.

@deffn {Scheme Procedure} route-add @var{dest} [@var{#:ipv6?} #f] @

    [@var{#:device} #f] [@var{#:table} RT_TABLE_MAIN] [@var{#:protocol} #f] @

    [@var{#:scope} RT_SCOPE_LINK] [@var{#:type} RTN_UNICAST] @

    [@var{#:priority} #f] [@var{#:src} #f] [@var{#:via} #f]

Add the route described by the argmuents.  @var{dest} is the destination network,

in cidr notation (@code{addr/prefix}) or the string @code{"default"}.

@var{#:device} is the name or index of a network link. @var{#:table} is the

index of a routing table, one of @code{RT_TABLE_COMPAT}, @code{RT_TABLE_DEFAULT},

@code{RT_TABLE_MAIN} or @code{RT_TABLE_LOCAL}, as defined in

@code{(netlink constant)}.

If it is set, @var{#:protocol} must be the routing protocol, @code{RTPROT_*},

as defined in @code{(netlink constant)}.

@var{#:scope} must be the scope of the route, one of @code{RT_SCOPE_*}, as

defined in @code{(netlink constant)}.

@var{#:type} must be the type of route, one of @code{RTN_*}, as defined in

@code{(netlink constant)}.

If set, @var{#:priority} is a number specifying the priority of the rule

when the kernel is looking for a matching rule.  This is also known as the

metric of the route.

If set, @var{#:src} is the source address in cidr notation, or as a single

address.

If set, @var{#:via} is the gateway address.  This is not in cidr notation, as

the gateway is a single address, not a network.

@example

(route-add "default" #:device "enp1s0" #:via "192.0.2.1")

(route-add "192.0.2.0/24" #:device "enp1s0" #:src "192.0.2.15")

@end example

If you wish to add an IPv6 route instead, set @code{#:ipv6} to @code{#t},

as in the following example.

@example

(addr-add "2001:db8::/64" #:device "enp1s0" #:src "2001:db8::1a4c" #:ipv6? #t)

@end example

Note that using the wrong ip type with the wrong value for the @code{#:ipv6?}

flag will result in a @code{Bad address} exception from inet-pton.

@end deffn

@deffn {Scheme Procedure} route-del @var{dest} [@var{#:ipv6?} #f] @

    [@var{#:device} #f] [@var{#:table} RT_TABLE_MAIN] [@var{#:protocol} #f] @

    [@var{#:scope} #f] [@var{#:type} #f] [@var{#:priority} #f] @

    [@var{#:src} #f] [@var{#:via} #f]

Delete the route given in arguments.  The arguments follow the same structure

as @code{route-add}.  By specifying more arguments, you can narrow down the

search for the rule to delete further.  Each call will only remove one route,

so being more precise ensures you target the rule you wish to delete.  It

is not clear which route is deleted if multiple routes match your query.

@end deffn

@deffn {Scheme Procedure} route-show [@var{#:table} RT_TABLE_MAIN] @

    [@var{#:family} AF_UNSPEC]

Print the list of routes on standard output.  Note that, contrary to

@command{ip route show}, we show both IPv4 and IPv6 routes.  To narrow down the

number of routes displayed, you can specify the family as in this example.

@example

(route-show #:family AF_INET6)

@end example

@end deffn

;;;; 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 Lesser 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

;;;; Lesser General Public License for more details.

;;;; 

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; 

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

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

(define* (route-add dest

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

                          (protocol #f) (scope RT_SCOPE_LINK)

                          (type RTN_UNICAST) (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_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

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