sockets/namedb/hosts.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; hosts.lisp --- Static host lookup.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :net.sockets)
  25
  26 (defvar *hosts-file* "/etc/hosts")
  27
  28 (defclass host ()
  29   ((truename :initform nil :initarg :truename
  30              :accessor host-truename
  31              :documentation "The name of the host.")
  32    (aliases :initform nil :initarg :aliases
  33             :accessor host-aliases
  34             :documentation "A list of aliases.")
  35    (addresses :initform nil :initarg :addresses
  36               :accessor host-addresses
  37               :documentation "A list of addresses."))
  38   (:documentation "Class representing a host: name, aliases and addresses."))
  39
  40 (defmethod initialize-instance :after ((host host) &key)
  41   (with-accessors ((name host-truename) (aliases host-aliases)
  42                    (addresses host-addresses)) host
  43     (flet ((namep (h) (and (stringp h) (plusp (length h)))))
  44       (assert (namep name))
  45       (assert (every #'namep aliases))
  46       (assert addresses)
  47       (setf addresses (ensure-list addresses))
  48       (map-into addresses #'ensure-address addresses))))
  49
  50 (defun host-random-address (host)
  51   "Returns a random address from HOST's address list."
  52   (random-elt (host-addresses host)))
  53
  54 (defun make-host (truename addresses &optional aliases)
  55   "Instantiates a HOST object."
  56   (make-instance 'host
  57                  :truename truename
  58                  :aliases aliases
  59                  :addresses addresses))
  60
  61 (defmethod print-object ((host host) stream)
  62   (print-unreadable-object (host stream :type t :identity nil)
  63     (with-slots (truename aliases addresses) host
  64       (format stream "Canonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~]. Addresses: ~{~A~^, ~}"
  65               truename aliases addresses))))
  66
  67 (defvar *hosts-cache* ())
  68 (defvar *hosts-cache-lock* (bt:make-lock "/etc/hosts cache lock"))
  69
  70 (defun map-host-ipv4-addresses-to-ipv6 (hostobj)
  71   (declare (type host hostobj))
  72   (with-accessors ((addresses host-addresses)) hostobj
  73     (setf addresses
  74           (mapcar (lambda (address)
  75                     (if (ipv4-address-p address)
  76                         (make-address (map-ipv4-vector-to-ipv6
  77                                        (address-name address)))
  78                         address))
  79                   addresses)))
  80   (values hostobj))
  81
  82 (defun parse-/etc/hosts (file)
  83   (let (hosts)
  84     (flet ((parse-one-line (tokens)
  85              (when (< (length tokens) 2) (error 'parse-error))
  86              (destructuring-bind (address cname &rest aliases) tokens
  87                (push (make-host cname (ensure-address address) aliases)
  88                      hosts))))
  89       (iterate ((tokens (serialize-etc-file file)))
  90         (ignore-errors (parse-one-line tokens)))
  91       (nreverse hosts))))
  92
  93 (defun search-host-by-name (name ipv6)
  94   (labels ((compatible-address-p (address)
  95              (ecase ipv6
  96                ((t)   (inet-address-p address))
  97                ((nil) (ipv4-address-p address))
  98                (:ipv6 (ipv6-address-p address))))
  99            (compatible-host-p (host)
 100              (and (or (string= name (host-truename host))
 101                       (member name (host-aliases host)
 102                               :test #'string=))
 103                   (compatible-address-p (car (host-addresses host))))))
 104     (let ((hosts (bt:with-lock-held (*hosts-cache-lock*)
 105                    (remove-if-not #'compatible-host-p *hosts-cache*)))
 106           addresses aliases)
 107       (when hosts
 108         (mapc #'(lambda (host)
 109                   (let ((address (car (host-addresses host))))
 110                     (push address addresses)
 111                     (push (cons (host-truename host) address) aliases)
 112                     (mapc #'(lambda (alias) (push (cons alias address) aliases))
 113                           (host-aliases host))))
 114               hosts)
 115         (values (nreverse addresses)
 116                 name
 117                 (nreverse aliases))))))
 118
 119 (defun search-host-by-address (address)
 120   (let* ((address (ensure-address address))
 121          (host (bt:with-lock-held (*hosts-cache-lock*)
 122                  (find-if #'(lambda (host)
 123                               (address= (car (host-addresses host))
 124                                         address))
 125                           *hosts-cache*))))
 126     (when host
 127       (values (list address)
 128               (host-truename host)
 129               (list* (cons (host-truename host) address)
 130                      (mapcar #'(lambda (alias) (cons alias address))
 131                              (host-aliases host)))))))
 132
 133 (defun update-hosts-list (file)
 134   (setf *hosts-cache* (parse-/etc/hosts file)))
 135
 136 (defvar *hosts-monitor*
 137   (make-instance 'file-monitor
 138                  :file *hosts-file*
 139                  :update-fn 'update-hosts-list
 140                  :lock *hosts-cache-lock*))