-
Notifications
You must be signed in to change notification settings - Fork 1
/
common.lisp
143 lines (127 loc) · 6.36 KB
/
common.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
;;;;- common.lisp
;;;;
;;;; Some functions to make Common Lisp life easier and aren't really related
;;;; to the Hello DNS C++ version.
;;; ## Functions
;; At the top since it can be used anywhere.
(defun mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun 2-bytes-to-int (2-bytes &key (big-endian t))
(if big-endian
(+ (ash (elt 2-bytes 0) 8)
(elt 2-bytes 1) )
(+ (elt 2-bytes 0)
(ash (elt 2-bytes 1) 8))))
(defun 4-bytes-to-int (4-bytes &key (big-endian t))
(if big-endian
(+ (ash (elt 4-bytes 0) 24)
(ash (elt 4-bytes 1) 16)
(ash (elt 4-bytes 2) 8)
(elt 4-bytes 3) )
(+ (elt 4-bytes 0)
(ash (elt 4-bytes 1) 8)
(ash (elt 4-bytes 2) 16)
(ash (elt 4-bytes 3) 24))))
;; ASH: arithmetic (binary) shift towards most significant bit
(defun int-to-2-bytes (integer &key (big-endian t))
(if big-endian
(list (ash integer -8)
(logand integer #b0000000011111111))
;; little-endian
(list (logand integer #b0000000011111111)
(ash integer -8))))
(defun int-to-4-bytes (integer &key (big-endian t))
(if big-endian
(list (ash integer -24)
(ash (logand integer #b0000000011111111000000000000000) -16)
(ash (logand integer #b00000000000000001111111100000000) -8)
(logand integer #b00000000000000000000000011111111))
;; little-endian
(list (logand integer #b00000000000000000000000011111111)
(ash (logand integer #b00000000000000001111111100000000) -8)
(ash (logand integer #b0000000011111111000000000000000) -16)
(ash integer -24))))
(defun ipv4-to-str (ipv4)
(format nil "~D.~D.~D.~D"
(elt ipv4 0) (elt ipv4 1) (elt ipv4 2) (elt ipv4 3)))
;; https://en.wikipedia.org/wiki/IPv6_address#Recommended_representation_as_text
;;
;; Test cases:
;; - #(32 1 13 184 0 0 0 0 0 0 0 0 0 2 0 1) → "2001:db8::2:1"
;; - #(32 1 13 184 0 0 0 1 0 1 0 1 0 1 0 1) → "2001:db8:0:1:1:1:1:1"
;; - #(32 1 13 184 0 0 0 0 0 1 0 0 0 0 0 1) → "2001:db8::1:0:0:1"
;;
;; These test cases work but there's still issues with this function. Off the
;; top of my head with all-zeroes at the end, but I do not know what the rules
;; are in that case. We need to find an official list of test cases.
(defun ipv6-to-str (ipv6)
(let* (;; make eight groups of 16-bit fields
(groups (loop for i from 0 to 15 by 2
for field = (+ (ash (elt ipv6 i) 8)
(elt ipv6 (+ i 1)))
collect (string-downcase (format nil "~X" field))))
;; find longest all-zero sequence
(zeros (loop with longest-begin = nil
with longest-length = nil
with current-begin = nil
for group in groups
for i from 0
do (cond (;; If we come across the first "0" (first
;; because CURRENT-BEGIN is NIL) we set
;; CURRENT-BEGIN to the index of the first "0".
(and (string= group "0")
(not current-begin))
(setf current-begin i))
(;; If we come across something that is not a
;; "0" AND the previous group was "0" (because
;; CURRENT-BEGIN was set) we do one of the
;; following things:
(and (string/= group "0")
current-begin)
(let ((len (- i current-begin)))
;(format t "current-begin=~S len=~S~%"
; current-begin len)
(if longest-length
;; If we've already find a long all-zero
;; sequence we compare them and if the
;; current one if longer we overwrite
;; the settings.
(when (> len longest-length)
(setf longest-begin current-begin
longest-length len))
;; If we haven't seen an all-zero
;; sequence AND the current one is longer
;; than 1 we set it as the longest all-
;; zero sequence.
(when (> len 1)
(setf longest-begin current-begin
longest-length len)))
;; Unset CURRENT-BEGIN since we're not in
;; an all-zero sequence anymore.
(setf current-begin nil))))
finally (return (when (and longest-begin longest-length)
(list :begin longest-begin
:end (+ -1 longest-begin
longest-length)))))))
;(format t "groups=~S~%zeros=~S~%" groups zeros)
(when zeros
(setf groups (append (subseq groups 0 (getf zeros :begin))
(list "::")
(subseq groups (+ (getf zeros :end) 1)))))
(loop with result = (first groups)
with prev = nil
for group in (rest groups)
do (setf result (if (or (string= prev "::")
(string= group "::"))
(mkstr result group)
(mkstr result ":" group)))
(setf prev group)
finally (return result))))
(defun ip-to-str (ip)
(case (length ip)
( 4 (ipv4-to-str ip))
(16 (ipv6-to-str ip))
(otherwise (format *debug-io* "[ERROR] unknown IP length: ~D" (length ip))
#|(format *log* "[ERROR] unknown IP length ~D for ~S~%"
(length ip) ip)|#)))