protocols/dns-client/etc-files.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 (defun load-file (path)
  25   (with-open-file (fin path)
  26     (let ((big-string (make-string (file-length fin))))
  27       (read-sequence big-string fin)
  28       big-string)))
  29
  30 (defun space-char-p (char)
  31   (declare (type character char))
  32   (or (char-equal char #\Space)
  33       (char-equal char #\Tab)))
  34
  35 (defun split-string-by-spaces (string &key (start 0) end empty-seqs)
  36   (declare (type string string)
  37            (type unsigned-byte start)
  38            (type (or unsigned-byte null) end))
  39   (let ((substring-length (or end (length string))))
  40     (assert (>= substring-length start))
  41     (loop
  42        :with substr-start := (1- start) :and substr-end := (1- start)
  43        :with dummy-char := #\Space
  44        :for index :upto substring-length
  45        :for char := (if (eql index substring-length) dummy-char (char string index))
  46        :when (and (space-char-p char)
  47                   (setf substr-start (1+ substr-end)
  48                         substr-end   index)
  49                   (or (> substr-end substr-start) empty-seqs))
  50        :collect (subseq string substr-start substr-end))))
  51
  52 (defun search-in-etc-file (path predicate &optional (match-all t))
  53   (let ((file (load-file path))
  54         results)
  55     (with-input-from-string (string-stream file)
  56       (loop
  57          :for line := (read-line string-stream nil nil)
  58          :for comment-start := (or (position #\# line)
  59                                    (length line))
  60          :while line :do
  61          (destructuring-bind (&optional col1 col2 &rest other-cols)
  62              (split-string-by-spaces line :empty-seqs nil :end comment-start)
  63            (when col2 ; skip invalid lines
  64              (let ((result (funcall predicate col1 col2 other-cols)))
  65                (when result
  66                  (push result results)
  67                  (unless match-all
  68                    (loop-finish))))))
  69          :finally (setf results (nreverse results))))
  70     results))
  71
  72 (defun vector-ipv6-good-p (vector ipv6)
  73   (when vector
  74     (let ((len (length vector)))
  75       (case ipv6
  76         (:ipv6 (eql len 8))
  77         ((nil) (eql len 4))
  78         (otherwise t)))))
  79
  80 (defun search-etc-hosts-ip (file ip ipv6)
  81   (let ((line (search-in-etc-file file
  82                                   #'(lambda (col1 col2 other-cols)
  83                                       (let ((vector (string-address-to-vector col1)))
  84                                         (when (and (vector-ipv6-good-p vector ipv6)
  85                                                    (vector-equal vector ip))
  86                                           (let ((host
  87                                                  (make-host col2 (make-address vector) other-cols)))
  88                                             (if (eql ipv6 t)
  89                                                 (map-host-ipv4-addresses-to-ipv6 host)
  90                                                 host)))))
  91                                   nil)))
  92     (car line)))
  93
  94 (defun merge-lines-into-one-host (lines ipv6)
  95   (flet ((pushnew-alias (alias place cname)
  96            (when (string-not-equal alias cname)
  97              (pushnew alias place :test #'string-equal)
  98              place)))
  99
 100     (let (ips aliases host)
 101       (destructuring-bind (first-ip cname first-aliases) (car lines)
 102         (setf ips (list first-ip))
 103         (mapc #'(lambda (alias) (setf aliases (pushnew-alias alias aliases cname)))
 104               first-aliases)
 105         (mapc #'(lambda (line)
 106                   (destructuring-bind (ip alias more-aliases) line
 107                     (pushnew ip ips)
 108                     (mapc #'(lambda (alias) (setf aliases (pushnew-alias alias aliases cname)))
 109                           (cons alias more-aliases))))
 110               (cdr lines))
 111         (setf host (make-host cname
 112                               (mapcar #'make-address (nreverse ips))
 113                               (nreverse aliases)))
 114         (if (eql ipv6 t)
 115             (map-host-ipv4-addresses-to-ipv6 host)
 116             host)))))
 117
 118 (defun search-etc-hosts-name (file name ipv6)
 119   (let ((lines (search-in-etc-file file
 120                                    #'(lambda (col1 col2 other-cols)
 121                                        (let ((vector (string-address-to-vector col1)))
 122                                          (when (and (vector-ipv6-good-p vector ipv6)
 123                                                     (or (string-equal name col2)
 124                                                         (member name other-cols
 125                                                                 :test #'string-equal)))
 126                                            (list vector col2 other-cols))))
 127                                    t)))
 128     (when lines
 129       (merge-lines-into-one-host lines ipv6))))