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
  69 (defun map-host-ipv4-addresses-to-ipv6 (hostobj)
  70   (declare (type host hostobj))
  71   (with-accessors ((addresses host-addresses)) hostobj
  72     (setf addresses
  73           (mapcar (lambda (address)
  74                     (if (ipv4-address-p address)
  75                         (make-address (map-ipv4-vector-to-ipv6
  76                                        (address-name address)))
  77                         address))
  78                   addresses)))
  79   (values hostobj))
  80
  81 (defun parse-/etc/hosts (file)
  82   (let (hosts)
  83     (flet ((parse-one-line (tokens)
  84              (when (< (length tokens) 2) (error 'parse-error))
  85              (destructuring-bind (address cname &rest aliases) tokens
  86                (push (make-host cname (ensure-address address) aliases)
  87                      hosts))))
  88       (iterate ((tokens (serialize-etc-file file)))
  89         (ignore-errors (parse-one-line tokens)))
  90       (nreverse hosts))))
  91
  92 (defun update-hosts-list (file)
  93   (setf *hosts-cache* (parse-/etc/hosts file)))
  94
  95 (defun search-host-by-name (name ipv6)
  96   (labels ((compatible-address-p (address)
  97              (ecase ipv6
  98                ((t)   (inet-address-p address))
  99                ((nil) (ipv4-address-p address))
 100                (:ipv6 (ipv6-address-p address))))
 101            (compatible-host-p (host)
 102              (and (or (string= name (host-truename host))
 103                       (member name (host-aliases host)
 104                               :test #'string=))
 105                   (compatible-address-p (car (host-addresses host))))))
 106     (let ((hosts (remove-if-not #'compatible-host-p *hosts-cache*))
 107           addresses aliases)
 108       (when hosts
 109         (mapc #'(lambda (host)
 110                   (let ((address (car (host-addresses host))))
 111                     (push address addresses)
 112                     (push (cons (host-truename host) address) aliases)
 113                     (mapc #'(lambda (alias) (push (cons alias address) aliases))
 114                           (host-aliases host))))
 115               hosts)
 116         (values (nreverse addresses)
 117                 name
 118                 (nreverse aliases))))))
 119
 120 (defun search-host-by-address (address)
 121   (let* ((address (ensure-address address))
 122          (host (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 (defvar *hosts-monitor*
 134   (make-instance 'file-monitor
 135                  :file *hosts-file*
 136                  :update-fn 'update-hosts-list))