protocols/dns-client/etc-files.lisp

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