src/sockets/namedb/hosts.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; hosts.lisp --- Static host lookup.
   4 ;;;
   5
   6 (in-package :iolib/sockets)
   7
   8 (defvar *hosts-file* "/etc/hosts")
   9
  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."))
  21
  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))))
  31
  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))
  38
  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))))
  44
  45 (defvar *hosts-cache* ())
  46 (defvar *hosts-cache-lock* (bt:make-lock "/etc/hosts cache lock"))
  47
  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       (map-etc-file (lambda (tokens) (ignore-errors (parse-one-line tokens)))
  56                     file)
  57       (nreverse hosts))))
  58
  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)))))))
  84
  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)))))))
  98
  99 (defun update-hosts-list (file)
 100   (setf *hosts-cache* (parse-/etc/hosts file)))
 101
 102 (defvar *hosts-monitor*
 103   (make-instance 'file-monitor
 104                  :file *hosts-file*
 105                  :update-fn 'update-hosts-list
 106                  :lock *hosts-cache-lock*))