;; Copyright 2016-2024
;; Kaz Kylheku <kaz@kylheku.com>
;; Vancouver, Canada
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;; 1. Redistributions of source code must retain the above copyright notice,
;; this list of conditions and the following disclaimer.
;;
;; 2. Redistributions in binary form must reproduce the above copyright notice,
;; this list of conditions and the following disclaimer in the documentation
;; and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
(defstruct sockaddr nil
canonname ;; from getaddrinfo
(:static family nil))
(defstruct sockaddr-in sockaddr
(addr 0) (port 0)
(prefix 32)
(:static family af-inet))
(defstruct sockaddr-in6 sockaddr
(addr 0) (port 0) (flow-info 0) (scope-id 0)
(prefix 128)
(:static family af-inet6))
(defstruct sockaddr-un sockaddr
path
(:static family af-unix))
(defstruct addrinfo nil
(flags 0)
(family 0)
(socktype 0)
(protocol 0)
canonname)
(defvarl shut-rd 0)
(defvarl shut-wr 1)
(defvarl shut-rdwr 2)
(defun str-inaddr (addr : port)
(let ((d (logand addr #xFF))
(c (logand (ash addr -8) #xFF))
(b (logand (ash addr -16) #xFF))
(a (ash addr -24))
(p (if port `:@port` "")))
(if (or (> a 255) (minusp a))
(throwf 'eval-error "~s: ~a out of range for IPv4 address"
'str-inaddr addr)
`@a.@b.@c.@d@p`)))
(defun sys:in6addr-condensed-text (numeric-pieces)
(let* ((str (cat-str [mapcar [iff zerop (ret "Z") (op fmt "~x")]
numeric-pieces] ":"))
(zr (rra #/Z(:Z)+/ str))
(lp [pos-max zr : [callf - to from]])
(lr [zr lp]))
(when lp
(del [str lr]))
(upd str (regsub "Z" "0"))
(cond
((equal "" str) "::")
((starts-with ":" str) `:@str`)
((ends-with ":" str) `@str:`)
(t str))))
(defun str-in6addr (addr : port)
(let ((str (if (and (<= (width addr) 48)
(= (ash addr -32) #xFFFF))
`::ffff:@(str-inaddr (logtrunc addr 32))`
(let* ((pieces (let ((count 8))
(nexpand-left (lambda (val)
(if (minusp (dec count))
(unless (zerop val)
(throwf 'eval-error
"~s: \
\ ~a out of range \
\ for IPv6 address"
'str-in6addr
addr))
(cons (logand val #xFFFF)
(ash val -16))))
addr))))
(sys:in6addr-condensed-text pieces)))))
(if port
`[@str]:@port`
str)))
(defun sys:str-inaddr-net-impl (addr wextra : weff)
(let ((mask addr))
(set-mask mask (ash mask 1))
(set-mask mask (ash mask 2))
(set-mask mask (ash mask 4))
(set-mask mask (ash mask 8))
(set-mask mask (ash mask 16))
(let* ((w (- 32 (width (lognot mask 32))))
(d (logand addr #xFF))
(c (logand (ash addr -8) #xFF))
(b (logand (ash addr -16) #xFF))
(a (ash addr -24))
(we (or weff (+ w wextra))))
(cond
((or (> a 255) (minusp a))
(throwf 'eval-error "~s: ~a out of range for IPv4 address"
'str-inaddr-net addr))
((> w 24) `@a.@b.@c.@d/@we`)
((> w 16) `@a.@b.@c/@we`)
((> w 8) `@a.@b/@we`)
(t `@a/@we`)))))
(defun str-inaddr-net (addr : width)
(sys:str-inaddr-net-impl addr 0 width))
(defun str-in6addr-net (addr : width)
(if (and (<= (width addr) 48)
(= (ash addr -32) #xFFFF))
`::ffff:@(sys:str-inaddr-net-impl (logtrunc addr 32) 96 width)`
(let ((mask addr))
(set-mask mask (ash mask 1))
(set-mask mask (ash mask 2))
(set-mask mask (ash mask 4))
(set-mask mask (ash mask 8))
(set-mask mask (ash mask 16))
(set-mask mask (ash mask 32))
(set-mask mask (ash mask 64))
(let* ((w (- 128 (width (lognot mask 128))))
(pieces (let ((count 8))
(nexpand-left (lambda (val)
(if (minusp (dec count))
(unless (zerop val)
(throwf 'eval-error
"~s: \
\ ~a out of range \
\ for IPv6 address"
'str-in6addr-net
addr))
(cons (logand val #xFFFF)
(ash val -16))))
addr)))
(cand-prefix [pieces 0..(trunc (+ w 15) 16)])
(prefix (if (search cand-prefix '(0 0)) pieces cand-prefix)))
`@(sys:in6addr-condensed-text prefix)/@(or width w)`))))
(defun inaddr-str (str)
(labels ((invalid ()
(error "~s: invalid address ~s" 'inaddr-str str))
(mkaddr (octets port)
(unless [all octets (op <= 0 @1 255)]
(invalid))
(unless (<= 0 port 65535)
(invalid))
(new sockaddr-in
addr (+ (ash (pop octets) 24)
(ash (pop octets) 16)
(ash (pop octets) 8)
(car octets))
port port))
(mkaddr-pf (octets prefix port)
(unless [all octets (op <= 0 @1 255)]
(invalid))
(unless (<= 0 prefix 32)
(invalid))
(unless (<= 0 port 65535)
(invalid))
(let* ((addr (+ (ash (or (pop octets) 0) 24)
(ash (or (pop octets) 0) 16)
(ash (or (pop octets) 0) 8)
(or (car octets) 0))))
(new sockaddr-in
addr (logand addr (ash -1 (- 32 prefix)))
port port
prefix prefix))))
(cond
((r^$ #/\d+\.\d+\.\d+\.\d+:\d+/ str)
(tree-bind (addr port) (split* str (rpos #\: str))
(mkaddr [mapcar toint (spl #\. addr)] (toint port))))
((r^$ #/\d+\.\d+\.\d+\.\d+(:\d+)?/ str)
(mkaddr [mapcar toint (spl #\. str)] 0))
((r^$ #/\d+(\.\d+(\.\d+(\.\d+)?)?)?\/\d+/ str)
(tree-bind (addr prefix) (spl #\/ str)
(mkaddr-pf [mapcar toint (spl #\. addr)] (toint prefix) 0)))
((r^$ #/\d+(\.\d+(\.\d+(\.\d+)?)?)?\/\d+:\d+/ str)
(tree-bind (addr prefix port) (split-str-set str ":/")
(mkaddr-pf [mapcar toint (spl #\. addr)] (toint prefix) (toint port))))
(t (invalid)))))
(defun in6addr-str (str)
(labels ((invalid ()
(error "~s: invalid address ~s" 'in6addr-str str))
(mkaddr-full (pieces)
(unless [all pieces (op <= 0 @1 #xffff)]
(invalid))
(unless (eql 8 (length pieces))
(invalid))
(new sockaddr-in6
addr (reduce-left (op + @2 (ash @1 16)) pieces)))
(mkaddr-brev (pieces-x pieces-y)
(let ((len-x (len pieces-x))
(len-y (len pieces-y)))
(unless (<= (+ len-x len-y) 7)
(invalid))
(let* ((val-x (reduce-left (op + @2 (ash @1 16)) pieces-x 0))
(val-y (reduce-left (op + @2 (ash @1 16)) pieces-y 0))
(addr (cond
((null pieces-x) val-y)
((null pieces-y) (ash val-x (* 16 (- 8 len-x))))
(t (+ val-y
(ash val-x (* 16 (- 8 len-x))))))))
(new sockaddr-in6
addr addr))))
(str-to-pieces (str)
(unless (empty str)
[mapcar (lop toint 16) (spl #\: str)]))
(octets-to-pieces (octets)
(unless [all octets (op <= 0 @1 255)]
(invalid))
(list (+ (ash (pop octets) 8)
(pop octets))
(+ (ash (pop octets) 8)
(pop octets)))))
(cond
((r^$ #/\[.*\]:\d+/ str)
(tree-bind (addr-str port-str) (split* str (rpos #\: str))
(let ((addr (in6addr-str [addr-str 1..-1]))
(port (toint port-str)))
(unless (<= 0 port 65535)
(invalid))
(set addr.port port)
addr)))
((r^$ #/[^\/]+\/\d+/ str)
(tree-bind (addr-str prefix-str) (split* str (rpos #\/ str))
(let ((addr (in6addr-str addr-str))
(prefix (toint prefix-str)))
(unless (<= 0 prefix 128)
(invalid))
(upd addr.addr (logand (ash -1 (- 128 prefix))))
(set addr.prefix prefix)
addr)))
((r^$ #/[\da-fA-F]*(:[\da-fA-F]*)*/ str)
(let* ((str-splat (regsub "::" "@" str))
(maj-pieces (spl #\@ str-splat)))
(caseql (len maj-pieces)
(1 (mkaddr-full (str-to-pieces (car maj-pieces))))
(2 (mkaddr-brev (str-to-pieces (car maj-pieces))
(str-to-pieces (cadr maj-pieces))))
(t (invalid)))))
((r^$ #/::0*[fF][fF][fF][fF]:\d+\.\d+\.\d+\.\d+/ str)
(let* ((bigsplit (split* str (rpos #\: str)))
(4part (cadr bigsplit))
(octets [mapcar toint (spl #\. 4part)])
(pieces (cons #xffff (octets-to-pieces octets))))
(mkaddr-brev nil pieces)))
(t (invalid)))))
(defplace (sock-peer sock) body
(getter setter
^(macrolet ((,getter () ^(sock-peer ,',sock))
(,setter (val) ^(sock-set-peer ,',sock ,val)))
,body)))
(defplace (sock-opt sock level option : type) body
(getter setter
^(macrolet ((,getter () ^(sock-opt ,',sock ,',level ,',option ,',type))
(,setter (val)
^(sock-set-opt ,',sock ,',level ,',option ,val ,',type)))
,body)))
(defun sockaddr-str (str)
(cond
((starts-with "[" str) (in6addr-str str))
((starts-with "/" str) (new sockaddr-un path str))
((contains "::" str) (in6addr-str str))
((contains "." str) (inaddr-str str))
(t (or (ignerr (in6addr-str str))
(inaddr-str str)))))
(defmeth sockaddr-in str-addr (me)
(let* ((pfx me.prefix)
(port me.port)
(addr me.addr)
(str (if (and pfx (< pfx 32))
(str-inaddr-net addr pfx)
(str-inaddr addr))))
(if (and port (plusp port))
`@str:@port`
str)))
(defmeth sockaddr-in6 str-addr (me)
(let* ((pfx me.prefix)
(port me.port)
(addr me.addr)
(str (if (and pfx (< pfx 128))
(str-in6addr-net addr pfx)
(str-in6addr addr))))
(if (and port (plusp port))
`[@str]:@port`
str)))
(defmeth sockaddr-un str-addr (me)
(let ((path me.path))
(if (stringp me.path)
path
(error "~s: slot path of ~s isn't a string" '(meth socakddr-un str-addr) me))))