Merged.

Pascal J. Bourguignon [2017-05-01 20:15]
Merged.
Filename
ddns/Makefile
ddns/client.lisp
ddns/com.informatimago.ddns.client.asd
diff --git a/ddns/Makefile b/ddns/Makefile
index 05af0f2..7505445 100644
--- a/ddns/Makefile
+++ b/ddns/Makefile
@@ -47,9 +47,9 @@ CLISP          = clisp
 CLISP_LOAD     =
 CLISP_EVAL     = --quiet -repl -x

-LISP           = $(CLISP)
-LOAD           = $(CLISP_LOAD)
-EVAL           = $(CLISP_EVAL)
+LISP           = $(CCL)
+LOAD           = $(CCL_LOAD)
+EVAL           = $(CCL_EVAL)


 all: server client doc
@@ -57,8 +57,8 @@ server:ddns-server
 client:ddns-client

 ddns-server:server.lisp generate-server.lisp
-	$(CLISP) --quiet -ansi -x '(load "generate-server.lisp")'
-# 	$(LISP) $(LOAD) generate-server.lisp
+#	$(CLISP) --quiet -ansi -Kfull -x '(load "generate-server.lisp")'
+	$(LISP) $(LOAD) generate-server.lisp

 ddns-client-clisp:client.lisp generate-client.lisp
 	$(CLISP) --quiet -ansi -x '(load "generate-client.lisp")'
diff --git a/ddns/client.lisp b/ddns/client.lisp
index 6c15123..041ec11 100644
--- a/ddns/client.lisp
+++ b/ddns/client.lisp
@@ -10,12 +10,13 @@
 ;;;;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 - 2012
+;;;;    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
@@ -32,7 +33,8 @@
 ;;;;**************************************************************************

 (defpackage "COM.INFORMATIMAGO.DDNS.CLIENT"
-  (:use "COMMON-LISP" "MD5")
+  (:use "COMMON-LISP" "MD5" "SPLIT-SEQUENCE" "IRONCLAD")
+  (:shadowing-import-from "COMMON-LISP" "NULL")
   (:export "UPDATE" "MAIN"))
 (in-package "COM.INFORMATIMAGO.DDNS.CLIENT")

@@ -41,20 +43,43 @@
 (defparameter *default-ddns-server*  "hubble.informatimago.com")
 (defparameter *default-secret-file*  #P"dnskeys/ddns.secret")

-(defun compute-token (hostname seed 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 (md5:MD5SUM-SEQUENCE (concatenate 'string hostname "/" seed "/" secret))
+      :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)
+                             :input-error-action :erro
+                             :output-error-action :error)
   #+ccl '(:character-encoding  :iso-8859-1
           :line-termination :crlf )
-  #-(or clisp ccl) (error "not implemented yet"))
+  #-(or clisp ccl) (not-implemented-yet 'make-socket-external-format))

 (defun connect (port host &key (external-format :default))
   (declare (ignorable external-format))
@@ -65,45 +90,52 @@
                              :remote-port port
                              :auto-close t
                              :external-format external-format)
-  #-(or clisp ccl) (error "not implemented yet"))
+  #-(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) (error "not implemented yet"))
+  #-(or clisp ccl) (not-implemented-yet 'arguments))


 (defun update (hostname &key
-               (port        *default-port*)
-               (ddns-server *default-ddns-server*)
-               (secret-file (merge-pathnames *default-secret-file* (user-homedir-pathname))))
-  (let ((*print-pretty* nil)
-        (*read-eval* nil)
-        (*package* (find-package  "COM.INFORMATIMAGO.DDNS.CLIENT")))
-    (with-open-stream (socket  (connect port ddns-server :external-format (make-socket-external-format)))
-      (let ((line (read-line socket)))
-        (write-line line)
-        (with-input-from-string (inp line)
-          (let ((code (read inp))
-                (ddns (read inp))
-                (seed (read inp)))
-            (if (and (integerp code)
+                          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))
-                     (eql 'ddns ddns)
+                     (string-equal 'ddns ddns)
                      (stringp seed))
-                (let ((message  (list (compute-token
-                                       hostname
-                                       seed
-                                       (with-open-file (stream secret-file) (read-line stream)))
-                                      hostname)))
-                  (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))))))))))
+            (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 ()
@@ -111,6 +143,8 @@
     (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"
                 ))))

diff --git a/ddns/com.informatimago.ddns.client.asd b/ddns/com.informatimago.ddns.client.asd
index 73a1c58..49c0193 100644
--- a/ddns/com.informatimago.ddns.client.asd
+++ b/ddns/com.informatimago.ddns.client.asd
@@ -46,9 +46,8 @@
                  ((#:albert #:docbook #:bgcolor)   . "white")
                  ((#:albert #:docbook #:textcolor) . "black"))
     #+asdf-unicode :encoding #+asdf-unicode :utf-8
-    :depends-on ()
-    :components ((:file "md5"       :depends-on ())
-                 (:file "client"    :depends-on ("md5"))))
+    :depends-on (:split-sequence :ironclad :md5)
+    :components ((:file "client"    :depends-on ())))


 ;;;; THE END ;;;;
ViewGit