;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               client.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2016-04-12 <PJB> Added transmission of local-interface-address and --natp option.
;;;;    2012-04-08 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    AGPL3
;;;;
;;;;    Copyright Pascal J. Bourguignon 2012 - 2016
;;;;
;;;;    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.CLIENT"
  (:use "COMMON-LISP" "MD5" "SPLIT-SEQUENCE" "IRONCLAD")
  (:shadowing-import-from "COMMON-LISP" "NULL")
  (:export "UPDATE" "MAIN"))
(in-package "COM.INFORMATIMAGO.DDNS.CLIENT")


(defparameter *default-port*         8053)
(defparameter *default-ddns-server*  "hubble.informatimago.com")
(defparameter *default-secret-file*  #P"dnskeys/ddns.secret")

(defun not-implemented-yet (&optional what)
  (error "Not implemented yet~@[ ~A~]" what))

(defun digest (sequence)
  #-ddns-use-sha1
  (md5:md5sum-sequence sequence)
  #+ddns-use-sha1
  (let ((digester (make-digest 'sha1))
        (octets (make-array (length sequence) :element-type '(unsigned-byte 8))))
    (map-into octets (function char-code) sequence)
    (update-digest digester octets)
    (produce-digest digester)))

(defun hexadecimal (octets)
  (with-output-to-string (out)
    (loop
      :for byte :across octets
      :do (format out "~:@(~2,'0X~)" byte))))

(defun join (items)
   (with-output-to-string (out)
     (let  ((sep ""))
       (dolist (item items)
         (princ sep) (princ item)
         (setf sep "/")))))

(defun compute-token (&rest items)
  (hexadecimal (digest (join items))))

(defun make-socket-external-format ()
  #+clisp (ext:make-encoding :charset :iso-8859-1
                             :line-terminator :dos
                             :input-error-action :erro
                             :output-error-action :error)
  #+ccl '(:character-encoding  :iso-8859-1
          :line-termination :crlf )
  #-(or clisp ccl) (not-implemented-yet 'make-socket-external-format))

(defun connect (port host &key (external-format :default))
  (declare (ignorable external-format))
  #+clisp (socket:socket-connect port host :external-format external-format)
  #+ccl   (ccl:make-socket :address-family :internet
                             :type :stream
                             :remote-host host
                             :remote-port port
                             :auto-close t
                             :external-format external-format)
  #-(or clisp ccl) (not-implemented-yet 'connect))

(defun local-interface-address (socket)
  #+ccl (ccl:ipaddr-to-dotted (local-host socket))
  #-ccl (not-implemented-yet 'local-interface-address))

(defun arguments ()
  #+clisp ext:*args*
  #+ccl (rest ccl:*command-line-argument-list*)
  #-(or clisp ccl) (not-implemented-yet 'arguments))


(defun update (hostname &key
                          local-interface-address
                          (natp        t)
                          (port        *default-port*)
                          (ddns-server *default-ddns-server*)
                          (secret-file (merge-pathnames *default-secret-file* (user-homedir-pathname))))
  (with-open-stream (socket  (connect port ddns-server :external-format (make-socket-external-format)))
    (let* ((line (read-line socket))
           (local-interface-address (local-interface-address socket))
           (*print-pretty* nil))
      (write-line line)
      (destructuring-bind (&optional code ddns seed)
          (split-sequence #\space line :remove-empty-subseqs t :count 3)
        (let ((code (parse-integer code :junk-allowed nil)))
          (when (and (integerp code)
                     (= 2 (truncate code 100))
                     (string-equal 'ddns ddns)
                     (stringp seed))
            (let ((message  (list (compute-token seed
                                                 (with-open-file (stream secret-file) (read-line stream))
                                                 hostname
                                                 natp
                                                 local-interface-address)
                                  hostname
                                  natp
                                  local-interface-address)))
              (format t "~S~%" message)
              (force-output)
              (prin1 message socket)
              (finish-output socket)
              (loop
                :for line = (read-line socket nil nil)
                :while line
                :do (write-line line)))))))))


(defun main ()
  (let ((arguments (arguments)))
    (if (null arguments)
        (error "Missing argument, try: ddns-client -- kuiper")
        (update (first arguments)
                :natp (or (find "--natp" (rest arguments) :test (function string=))
                          (find "-n"     (rest arguments) :test (function string=)))
                ;; :ddns-server  "hubble.informatimago.com"
                ))))

;;;; THE END ;;;;
ViewGit