More code cleanup.
[iolib.git] / net.sockets / namedb / hosts.lisp
blob8b7388123fb3406b528e61f37d90623d73a5d0fd
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; hosts.lisp --- Static host lookup.
4 ;;;
6 (in-package :net.sockets)
8 (defvar *hosts-file* "/etc/hosts")
10 (defclass host ()
11 ((truename :initform nil :initarg :truename
12 :accessor host-truename
13 :documentation "The name of the host.")
14 (aliases :initform nil :initarg :aliases
15 :accessor host-aliases
16 :documentation "A list of aliases.")
17 (addresses :initform nil :initarg :addresses
18 :accessor host-addresses
19 :documentation "A list of addresses."))
20 (:documentation "Class representing a host: name, aliases and addresses."))
22 (defmethod initialize-instance :after ((host host) &key)
23 (with-accessors ((name host-truename) (aliases host-aliases)
24 (addresses host-addresses)) host
25 (flet ((namep (h) (and (stringp h) (plusp (length h)))))
26 (assert (namep name) (name) "Invalid host truename: ~A" name)
27 (assert (every #'namep aliases) (aliases) "Invalid host aliases: ~A" aliases)
28 (assert addresses (addresses) "A host must have at least one address.")
29 (setf addresses (ensure-list addresses))
30 (map-into addresses #'ensure-address addresses))))
32 (defun make-host (truename addresses &optional aliases)
33 "Instantiates a HOST object."
34 (make-instance 'host
35 :truename truename
36 :aliases aliases
37 :addresses addresses))
39 (defmethod print-object ((host host) stream)
40 (print-unreadable-object (host stream :type t :identity nil)
41 (with-slots (truename aliases addresses) host
42 (format stream "Canonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~]. Addresses: ~{~A~^, ~}"
43 truename aliases addresses))))
45 (defvar *hosts-cache* ())
46 (defvar *hosts-cache-lock* (bt:make-lock "/etc/hosts cache lock"))
48 (defun parse-/etc/hosts (file)
49 (let (hosts)
50 (flet ((parse-one-line (tokens)
51 (when (< (length tokens) 2) (error 'parse-error))
52 (destructuring-bind (address cname &rest aliases) tokens
53 (push (make-host cname (ensure-address address) aliases)
54 hosts))))
55 (iterate ((tokens (serialize-etc-file file)))
56 (ignore-errors (parse-one-line tokens)))
57 (nreverse hosts))))
59 (defun search-host-by-name (name ipv6)
60 (labels ((compatible-address-p (address)
61 (ecase ipv6
62 ((t) (inet-address-p address))
63 ((nil) (ipv4-address-p address))
64 (:ipv6 (ipv6-address-p address))))
65 (compatible-host-p (host)
66 (and (or (string= name (host-truename host))
67 (member name (host-aliases host)
68 :test #'string=))
69 (compatible-address-p (car (host-addresses host))))))
70 (let ((hosts (bt:with-lock-held (*hosts-cache-lock*)
71 (remove-if-not #'compatible-host-p *hosts-cache*)))
72 addresses aliases)
73 (when hosts
74 (mapc #'(lambda (host)
75 (let ((address (car (host-addresses host))))
76 (push address addresses)
77 (push (cons (host-truename host) address) aliases)
78 (mapc #'(lambda (alias) (push (cons alias address) aliases))
79 (host-aliases host))))
80 hosts)
81 (let ((addresses (nreverse addresses)))
82 (values (car addresses) (cdr addresses)
83 name (nreverse aliases)))))))
85 (defun search-host-by-address (address)
86 (let* ((address (ensure-address address))
87 (host (bt:with-lock-held (*hosts-cache-lock*)
88 (find-if #'(lambda (host)
89 (address= (car (host-addresses host))
90 address))
91 *hosts-cache*))))
92 (when host
93 (values address '()
94 (host-truename host)
95 (list* (cons (host-truename host) address)
96 (mapcar #'(lambda (alias) (cons alias address))
97 (host-aliases host)))))))
99 (defun update-hosts-list (file)
100 (setf *hosts-cache* (parse-/etc/hosts file)))
102 (defvar *hosts-monitor*
103 (make-instance 'file-monitor
104 :file *hosts-file*
105 :update-fn 'update-hosts-list
106 :lock *hosts-cache-lock*))