;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               server.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    This server listens for incoming messages.
;;;;    If the message is correctly authenticated, then it updates DNS
;;;;    with the IP address of the incoming message.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2012-04-08 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    AGPL3
;;;;
;;;;    Copyright Pascal J. Bourguignon 2012 - 2012
;;;;
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, or
;;;;    (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be useful,
;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;;    GNU Affero General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************

(defpackage "COM.INFORMATIMAGO.DDNS.SERVER"
  (:use "COMMON-LISP" "MD5")
  (:export "SERVER" "MAIN"))
(in-package "COM.INFORMATIMAGO.DDNS.SERVER")

(defparameter *default-port*         8053)
(defparameter *default-origin*      "dyn.informatimago.com.")
(defparameter *default-dns-server*  "localhost")

(defun default-dnskey-file ()
  (merge-pathnames #P"dnskeys/Kdyn.informatimago.com.+157+24639.private"
                   (user-homedir-pathname)))

(defun default-secret-file ()
  (merge-pathnames #P"dnskeys/ddns.secret"
                   (user-homedir-pathname)))


(defun compute-token (hostname seed secret)
  (with-output-to-string (out)
    (loop
      :for byte :across (md5:MD5SUM-SEQUENCE (concatenate 'string hostname "/" seed "/" secret))
      :do (format out "~:@(~2,'0X~)" byte))))

;; (compute-token "ono" "127.0.0.1" "Pink Floyd -- The Wall")
;; "669CCF328A13F184C5243B3FE7ECD09D"



(defun valid-token-p (token hostname seed secret)
  (equal (compute-token hostname seed secret) token))


(defun update-dns (dnskey-file dns-server origin name ip-address)
  (with-open-file (update "update.txt"
                          :direction :output
                          :if-does-not-exist :create
                          :if-exists :supersede)
    (format update "server ~A
update delete ~A.~A    A~2:*
update add    ~A.~A 10 A ~A
show
send
quit
"
            dns-server name origin ip-address))
  (let ((status (or (ext:run-shell-command
                     (format nil "nsupdate -k ~S < update.txt > output.txt 2> error.txt"
                             (namestring dnskey-file))
                     :wait t)
                    0)))
    (values status
            (with-output-to-string (result)
              (format result (if (zerop status)
                                 "250 ~S Update successful.~%"
                                 "553 ~S Update failed.~%") ip-address)
              (with-open-file (input (if (zerop status) "output.txt" "error.txt"))
                (loop
                  :for line = (read-line input nil nil)
                  :while line
                  :do (write-string (if  (zerop status) "250-" "553-") result)
                  :do (write-line line result)))))))


(defun server-format (socket control-string &rest arguments)
  (format t "~?" control-string arguments)
  (force-output)
  (format socket "~?" control-string arguments)
  (finish-output socket))


(defun server (&key
               (port        *default-port*)
               (origin      *default-origin*)
               (dns-server  *default-dns-server*)
               (dnskey-file (default-dnskey-file))
               (secret-file (default-secret-file)))
  (let ((secret         (with-open-file (stream secret-file) (read-line stream)))
        (server         (socket:socket-server port))
        (last-name-ip   (make-hash-table :test 'equal))
        (*print-pretty* nil))
    (format t "~&Waiting for a connection on ~S:~D~%"
            (socket:socket-server-host server) (socket:socket-server-port server))
    (force-output)
    (unwind-protect
         ;; infinite loop, terminate with Control+C
         (loop
           (with-open-stream (socket (socket:socket-accept server  :external-format :dos))
             (handler-case
                 (multiple-value-bind (local-host local-port) (socket:socket-stream-local socket t)
                   (multiple-value-bind (remote-host remote-port) (socket:socket-stream-peer socket t)
                     (let ((seed (format nil "~16,'0X" (random #.(expt 2 64)))))
                       (format t "~&Connection: ~S:~D -- ~S:~D~%"
                               remote-host remote-port local-host local-port)
                       (force-output)
                       (format socket "220 DDNS ~S ~A~%" seed origin)
                       (finish-output socket)
                       (with-standard-io-syntax
                         (let* ((*read-eval* nil)
                                (*package*   (find-package "COM.INFORMATIMAGO.DDNS.SERVER"))
                                (message     (read socket)))
                           (if (and (listp message)
                                    (every 'stringp message))
                               (destructuring-bind (token name) message
                                 (if (valid-token-p token name seed secret)
                                     (if (equal (gethash name last-name-ip) remote-host)
                                         (server-format socket "251 ~S No change.~%" remote-host)
                                         (multiple-value-bind (status result)
                                             (update-dns dnskey-file dns-server
                                                         origin name remote-host)
                                           (when (zerop status)
                                             (setf (gethash name last-name-ip) remote-host))
                                           (server-format socket "~A~%" result)))
                                     (server-format socket "530 Authentication invalid.~%")))
                               (server-format socket "501 Invalid token.~%"))
                           ;; flush everything left in socket
                           ;; (loop :for c = (read-char-no-hang socket nil nil) :while c)
                           )))))
               (error (err)
                 (ignore-errors
                   (server-format socket "554 ~A~%" (remove #\Newline (princ-to-string err))))))))
      ;; make sure server is closed
      (socket:socket-server-close server))))

(defun main ()
  (format t "main~%") (finish-output)
  (ext:cd (setf *default-pathname-defaults*
                (make-pathname :name nil :type nil :version nil
                               :defaults (default-dnskey-file))))
  (format t "initializing random state~%") (finish-output)
  (setf *random-state* (make-random-state t))
  (format t "calling server~%") (finish-output)
  (server))

;;;; THE END ;;;;
ViewGit