net.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) (name) "Invalid host truename: ~A" name)
  45       (assert (every #'namep aliases) (aliases) "Invalid host aliases: ~A" aliases)
  46       (assert addresses (addresses) "A host must have at least one address.")
  47       (setf addresses (ensure-list addresses))
  48       (map-into addresses #'ensure-address addresses))))
  49
  50 (defun make-host (truename addresses &optional aliases)
  51   "Instantiates a HOST object."
  52   (make-instance 'host
  53                  :truename truename
  54                  :aliases aliases
  55                  :addresses addresses))
  56
  57 (defmethod print-object ((host host) stream)
  58   (print-unreadable-object (host stream :type t :identity nil)
  59     (with-slots (truename aliases addresses) host
  60       (format stream "Canonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~]. Addresses: ~{~A~^, ~}"
  61               truename aliases addresses))))
  62
  63 (defvar *hosts-cache* ())
  64 (defvar *hosts-cache-lock* (bt:make-lock "/etc/hosts cache lock"))
  65
  66 (defun parse-/etc/hosts (file)
  67   (let (hosts)
  68     (flet ((parse-one-line (tokens)
  69              (when (< (length tokens) 2) (error 'parse-error))
  70              (destructuring-bind (address cname &rest aliases) tokens
  71                (push (make-host cname (ensure-address address) aliases)
  72                      hosts))))
  73       (iterate ((tokens (serialize-etc-file file)))
  74         (ignore-errors (parse-one-line tokens)))
  75       (nreverse hosts))))
  76
  77 (defun search-host-by-name (name ipv6)
  78   (labels ((compatible-address-p (address)
  79              (ecase ipv6
  80                ((t)   (inet-address-p address))
  81                ((nil) (ipv4-address-p address))
  82                (:ipv6 (ipv6-address-p address))))
  83            (compatible-host-p (host)
  84              (and (or (string= name (host-truename host))
  85                       (member name (host-aliases host)
  86                               :test #'string=))
  87                   (compatible-address-p (car (host-addresses host))))))
  88     (let ((hosts (bt:with-lock-held (*hosts-cache-lock*)
  89                    (remove-if-not #'compatible-host-p *hosts-cache*)))
  90           addresses aliases)
  91       (when hosts
  92         (mapc #'(lambda (host)
  93                   (let ((address (car (host-addresses host))))
  94                     (push address addresses)
  95                     (push (cons (host-truename host) address) aliases)
  96                     (mapc #'(lambda (alias) (push (cons alias address) aliases))
  97                           (host-aliases host))))
  98               hosts)
  99         (values (nreverse addresses)
 100                 name
 101                 (nreverse aliases))))))
 102
 103 (defun search-host-by-address (address)
 104   (let* ((address (ensure-address address))
 105          (host (bt:with-lock-held (*hosts-cache-lock*)
 106                  (find-if #'(lambda (host)
 107                               (address= (car (host-addresses host))
 108                                         address))
 109                           *hosts-cache*))))
 110     (when host
 111       (values (list address)
 112               (host-truename host)
 113               (list* (cons (host-truename host) address)
 114                      (mapcar #'(lambda (alias) (cons alias address))
 115                              (host-aliases host)))))))
 116
 117 (defun update-hosts-list (file)
 118   (setf *hosts-cache* (parse-/etc/hosts file)))
 119
 120 (defvar *hosts-monitor*
 121   (make-instance 'file-monitor
 122                  :file *hosts-file*
 123                  :update-fn 'update-hosts-list
 124                  :lock *hosts-cache-lock*))