blob: 5190143f7069a3c525d89387bed035e90d559f7c (
plain)
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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
;;;; -*- mode: lisp -*-
(ql:quickload '(cffi cffi-libffi split-sequence mmap ironclad babel nibbles fiveam local-time))
(defpackage :geoip
(:use :common-lisp :cffi :split-sequence))
(in-package :geoip)
(defun octet-to-int (seq &key (big-endian t))
(reduce (lambda (acc n)
(+ (ash acc 8) n))
(if big-endian
seq (reverse seq))
:initial-value 0))
(5am:test t-ints
(5am:is (= (octet-to-int '(1 5) :big-endian t) #x105))
(5am:is (= (octet-to-int '(1 5) :big-endian nil) #x501)))
(defun parse-ipv4 (ip-address)
(reduce (lambda (acc part)
(let ((n (parse-integer part)))
(assert (<= 0 n 255))
(+ (ash acc 8) n)))
(split-sequence #\. ip-address)
:initial-value 0))
(defun parse-ipv6 (ip-address)
(reduce (lambda (acc part)
(let ((n (if (string= part "") 0
(parse-integer part :radix 16))))
(assert (<= 0 n #xFFFF))
(+ (ash acc 16) n)))
(split-sequence #\: ip-address)
:initial-value 0))
(defun parse-ip (ip-address)
(if (find #\. ip-address)
(cons 4 (parse-ipv4 ip-address))
(cons 6 (parse-ipv6 ip-address))))
(5am:test ipv4
(5am:is (= (parse-ipv4 "8.8.8.8") 134744072))
(5am:is (= (parse-ipv6 "::1") 1)))
(defparameter *metadata-marker*
(concatenate 'vector
#(#xab #xcd #xef)
(map 'vector #'char-code "MaxMind.com")))
(defstruct maxmind-database
(ptr nil :read-only t)
(fd nil :read-only t)
(filename nil :read-only t)
(size 0 :read-only t)
(metadata nil)
(data-offset -1 :type fixnum))
(defstruct db-reader
(db-ptr))
(defstruct maxmind-database-metadata
(node-count 0 :read-only t :type fixnum)
(record-size 0 :read-only t :type fixnum)
(ip-version 0 :read-only t :type fixnum)
(database-type nil :read-only t :type string)
(languages nil :read-only t :type list)
(binary-format-major-version 0 :read-only t :type fixnum)
(binary-format-minor-version 0 :read-only t :type fixnum)
(build-epoch 0 :read-only t :type fixnum)
(description nil :read-only t :type list))
(defun get-val (alist key &key (test #'equal))
(cdr (assoc key alist :test test)))
(defun make-metadata (data)
(make-maxmind-database-metadata
:binary-format-major-version (get-val data "binary-format-major-version")
:binary-format-minor-version (get-val data "binary-format-minor-version")
:build-epoch (get-val data "build-epoch")
:database-type (get-val data "database-type")
:description (get-val data "description")
:ip-version (get-val data "ip-version")
:languages (get-val data "languages")
:node-count (get-val data "node-count")
:record-size (get-val data "record-size")))
(defun metadata-marker-p (ptr offset)
(loop for i below #.(length *metadata-marker*)
always (eql (mem-ref ptr :uchar (+ i offset))
(svref *metadata-marker* i))))
(defun find-metadata-start (ptr size)
(loop for offset from (- size 1 #.(length *metadata-marker*))
downto (- size 1 (* 128 1024))
when (metadata-marker-p ptr offset)
return (+ offset #.(length *metadata-marker*))))
(defun mmap->mmdb (file ptr fd size)
(let* ((metadata-start (find-metadata-start ptr size))
(db-reader (make-db-reader :db-ptr (inc-pointer ptr metadata-start)))
(metadata (make-metadata (mread-data db-reader))))
(with-slots (record-size node-count) metadata
(make-maxmind-database
:ptr ptr :fd fd :filename file :size size
:metadata metadata
:data-offset (+ 16 (* (/ (* 2 record-size) 8) node-count))))))
(defun make-mmdb (file)
(multiple-value-bind (ptr fd size) (mmap:mmap file)
(mmap->mmdb file ptr fd size)))
(defun read-db-char (reader)
(with-slots (db-ptr) reader
(prog1 (mem-ref db-ptr :uchar)
(incf-pointer db-ptr))))
(defun bytes-from-foreign (db-ptr data-length)
(let ((bytes (make-array data-length :element-type '(unsigned-byte 8))))
(loop for i below data-length
do (setf (aref bytes i) (read-db-char db-ptr)))
bytes))
(defun mread-unsigned (ptr size &key (big-endian t))
(octet-to-int
(bytes-from-foreign ptr size)
:big-endian big-endian))
(defun mread-datafield-metadata (db-ptr)
(let* ((control-byte (read-db-char db-ptr))
(type (ldb (byte 3 5) control-byte))
(length (ldb (byte 5 0) control-byte)))
(when (= type 0)
(setf type (+ 7 (read-db-char db-ptr))))
(list type
(cond
((or (= type 1) (< length 29))
length)
((= length 29)
(+ 29 (read-uchar db-ptr)))
((= length 30)
(+ 285 (mread-unsigned db-ptr 2)))
((= length 31)
(+ 65821 (mread-unsigned db-ptr 3)))))))
(defun mread-uft8 (db-ptr length)
(babel:octets-to-string
(bytes-from-foreign db-ptr length)))
(defun mread-map (db-ptr length)
(loop repeat length
collect
(cons
(substitute #\- #\_ (mread-data db-ptr))
(mread-data db-ptr))))
(defun mread-list (db-ptr length)
(loop repeat length collect (mread-data db-ptr)))
(defun mread-data (db-ptr)
(destructuring-bind (type length) (mread-datafield-metadata db-ptr)
(ecase type
(2 (mread-uft8 db-ptr length))
((5 6 9 10) (mread-unsigned db-ptr length))
(7 (mread-map db-ptr length))
(11 (mread-list db-ptr length)))))
(defvar *refdb*
(cl-maxminddb:make-mmdb "GeoLite2-Country.mmdb"))
(defvar *mmdb* (make-mmdb "GeoLite2-Country.mmdb"))
(with-slots (metadata) *mmdb*
(with-slots (build-epoch) metadata
(local-time:unix-to-timestamp
build-epoch)))
|
