ipmsg-protocol.lisp

   1
   2 (in-package cl-ipmsg)
   3
   4 (defconstant +IPMSG-VERSION+      #x0001)
   5 (defconstant +IPMSG-DEFAULT-PORT+ #x0979)
   6
   7 (defclass ipmsg-protocol (protocol)
   8   ((version :initform +IPMSG-VERSION+ :reader protocol-ver)
   9    (ipif :initform nil :accessor protocol-if)
  10    (port :initform +IPMSG-DEFAULT-PORT+ :reader protocol-port)
  11    (thread      :initform nil :accessor protocol-thread)
  12    (packetindex :initform (random 1000) :accessor protocol-packet-index)
  13    (selfinfo :initform (make-instance 'ipmsg-protocol-selfinfo)
  14              :accessor protocol-self-info)
  15    (hostinfo :initform () :accessor protocol-host-info)
  16    (buddy-list :initform nil :accessor protocol-buddy-list)
  17
  18    (channel-list :initform nil :accessor protocol-channel-list)
  19    ))
  20
  21 (defmethod protocol-next-packet-index
  22     ((ipmsg-protocol ipmsg-protocol))
  23   (incf (protocol-packet-index ipmsg-protocol)))
  24
  25 (defun ipmsg-protocol-udp-callback (buffer)
  26   (declare (type (simple-array (unsigned-byte 8) *) buffer))
  27   (analyze-message (get-protocol-singleton 'ipmsg-protocol) buffer))
  28
  29 (defun ipmsg-send-initial-message ()
  30   (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
  31     (broadcast-command-message protocol
  32                                (protocol-port protocol)
  33                                :cmd :br-entry)))
  34
  35 (defun ipmsg-send-final-message ()
  36   (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
  37     (broadcast-command-message protocol
  38                                (protocol-port protocol)
  39                                :cmd :br-exit)))
  40
  41 (defun ipmsg-start-server (&optional port)
  42   (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
  43     (handler-case
  44         (multiple-value-bind (thread socket)
  45             (socket-server (format-ip (ip-interface-address (protocol-if protocol)))
  46                            (or port (protocol-port protocol))
  47                            #'ipmsg-protocol-udp-callback
  48                            nil :in-new-thread t :protocol :datagram)
  49           (setf (protocol-thread protocol) thread
  50                 (protocol-udp-socket protocol) socket)
  51           (ipmsg-send-initial-message)
  52           socket)
  53       (error ()
  54               (format t "~&Error: program is running or an error occured.")
  55               (vendor:quit))
  56       )))
  57
  58 (defun ipmsg-stop-server-and-quit ()
  59   (ipmsg-send-final-message)
  60   (vendor:quit)
  61   )
  62
  63 (defmethod broadcast-addr ((this ipmsg-protocol))
  64   (format-ip (ip-interface-broadcast-address (protocol-if this)))
  65   )
  66
  67 (defmethod analyze-message ((this ipmsg-protocol) buffer)
  68   (handler-case
  69       (let ((analyzed-msg (analyze-ipmsg-message
  70                            (octets-to-string buffer :encoding :utf-8))))
  71         #+nil(warn "analyze-message: ~&  buffer=~a~&  msg=~a~&"
  72               buffer analyzed-msg)
  73         (when (/= (getf analyzed-msg :ver) +IPMSG-VERSION+)
  74           (format t "~&Warning: junk message or unsupported protocol version!~2%")
  75           (return-from analyze-message nil))
  76         (apply #'call-command-handler
  77                (list* this *remote-host* *remote-port* analyzed-msg)))
  78     (invalid-utf8-starter-byte () nil)
  79     (invalid-utf8-continuation-byte () nil)))
  80
  81
  82 (defmethod make-message ((this ipmsg-protocol) &rest arguments)
  83   #+nil(warn "make-message: arguments=~a" arguments)
  84   (string-to-octets (apply #'make-ipmsg-message arguments) :encoding :utf-8))
  85
  86 (defmacro define-ipmsg-command-recipient
  87     (name-and-aliases value param-list &body body)
  88   `(define-protocol-command-recipient ipmsg-protocol ,name-and-aliases
  89      ,value ,param-list
  90      #+nil(progn (format t "~& DBG:ipmsg: cmd = ~a , msg = ~a ~%" cmd msg)
  91                  (force-output))
  92      #+nil(warn "in")
  93      (format t "")
  94      ,@body
  95      (format t "")
  96      #+nil(warn "out")))
  97
  98 (defun analyze-ipmsg-message (string)
  99   (let ((string-array (usocket::split-sequence #\: string)))
 100     (list* :ver      (parse-integer (first string-array) :junk-allowed t)
 101            :packno   (parse-integer (second string-array):junk-allowed t)
 102            :username (third  string-array)
 103            :hostname (fourth string-array)
 104            :cmd      (logand (parse-integer (fifth  string-array) :junk-allowed t) #xFF)
 105            :cmd-opt  (logand (parse-integer (fifth  string-array) :junk-allowed t)
 106                              #xFFFFFF00)
 107            (let ((msg-array (usocket::split-sequence #\Nul (sixth string-array))))
 108              (if (> (length msg-array) 1)
 109                  (list :msg (first msg-array)
 110                        :exmsg (format nil #.(format nil "~~{~~a~~^~a~~}" #\Nul)
 111                                       (rest msg-array)))
 112                  (list :msg (first msg-array)))))))
 113
 114 (defun make-ipmsg-message (&key cmd cmd-opt msg exmsg &allow-other-keys)
 115   (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
 116     (format nil "~a:~a:~a:~a:~a:~a"
 117             (protocol-ver protocol)
 118             (protocol-next-packet-index protocol)
 119             (user-name (protocol-self-info protocol))
 120             (host-name (protocol-self-info protocol))
 121             (logior (gethash cmd (cmd-table protocol))
 122                     (or (and cmd-opt
 123                              (gethash cmd-opt (cmd-table protocol)))
 124                         0))
 125             (if exmsg
 126                 (format nil "~a~a~a" (or msg "") #\Nul exmsg)
 127                 (or msg "")))))
 128
 129 (defun register-host (&rest user-info)
 130   #+nil(warn "in")
 131   (unregister-host (getf user-info :username)
 132                    (getf user-info :hostname))
 133   (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
 134     (push user-info (protocol-buddy-list protocol)))
 135   #+nil(warn "out")
 136   )
 137
 138 (defun unregister-host (user-name host-name)
 139   #+nil(warn "in")
 140   (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
 141     (setf (protocol-buddy-list protocol)
 142           (remove-if (lambda (item)
 143                        (and (string-equal (getf item :username) user-name)
 144                             (string-equal (getf item :hostname) host-name)))
 145                      (protocol-buddy-list protocol))))
 146   #+nil(warn "out")
 147   )
 148
 149 (defun get-compound-command-index (&rest command-list)
 150   (let ((cmd-table (cmd-table (get-protocol-singleton 'ipmsg-protocol))))
 151     (apply #'logior (map 'list (lambda (cmd) (gethash cmd cmd-table)) command-list))))
 152
 153
 154 ;;  option for all command
 155 (defconstant IPMSG_ABSENCEOPT                #x00000100)
 156 (defconstant IPMSG_SERVEROPT                 #x00000200)
 157 (defconstant IPMSG_DIALUPOPT                 #x00010000)
 158 (defconstant IPMSG_FILEATTACHOPT             #x00200000)
 159 (defconstant IPMSG_ENCRYPTOPT                #x00400000)
 160
 161 ;;  option for send command
 162 (defconstant IPMSG_SENDCHECKOPT              #x00000100)
 163 (defconstant IPMSG_SECRETOPT                 #x00000200)
 164 (defconstant IPMSG_BROADCASTOPT              #x00000400)
 165 (defconstant IPMSG_MULTICASTOPT              #x00000800)
 166 (defconstant IPMSG_NOPOPUPOPT                #x00001000)
 167 (defconstant IPMSG_AUTORETOPT                #x00002000)
 168 (defconstant IPMSG_RETRYOPT                  #x00004000)
 169 (defconstant IPMSG_PASSWORDOPT               #x00008000)
 170 (defconstant IPMSG_NOLOGOPT                  #x00020000)
 171 (defconstant IPMSG_NEWMUTIOPT                #x00040000)
 172 (defconstant IPMSG_NOADDLISTOPT              #x00080000)
 173 (defconstant IPMSG_READCHECKOPT              #x00100000)
 174
 175 (defconstant IPMSG_SECRETEXOPT               (logior IPMSG_READCHECKOPT
 176                                                        IPMSG_SECRETOPT))
 177
 178 ;; encryption flags for encrypt command
 179 (defconstant IPMSG_RSA-512                   #x00000001)
 180 (defconstant IPMSG_RSA-1024                  #x00000002)
 181 (defconstant IPMSG_RSA-2048                  #x00000004)
 182 (defconstant IPMSG_RC2-40                    #x00001000)
 183 (defconstant IPMSG_RC2-128                   #x00004000)
 184 (defconstant IPMSG_RC2-256                   #x00008000)
 185 (defconstant IPMSG_BLOWFISH-128              #x00020000)
 186 (defconstant IPMSG_BLOWFISH-256              #x00040000)
 187 (defconstant IPMSG_SIGN-MD5                  #x10000000)
 188
 189 ;; compatibilty for Win beta version
 190 (defconstant IPMSG_RC2-40OLD                 #x00000010)    ;; for beta1-4 only
 191
 192 (defconstant IPMSG_RC2-128OLD                #x00000040)    ;; for beta1-4 only
 193
 194 (defconstant IPMSG_BLOWFISH-128OLD                 #x00000400)    ;; for beta1-4 only
 195
 196 (defconstant IPMSG_RC2-40ALL                 (logior IPMSG_RC2-40
 197                                                        IPMSG_RC2-40OLD))
 198
 199 (defconstant IPMSG_RC2-128ALL                (logior IPMSG_RC2-128
 200                                                        IPMSG_RC2-128OLD))
 201
 202 (defconstant IPMSG_BLOWFISH-128ALL           (logior IPMSG_BLOWFISH-128
 203                                                        IPMSG_BLOWFISH-128OLD))
 204
 205
 206 ;; file types for fileattach command
 207 (defconstant IPMSG_FILE-REGULAR              #x00000001)
 208 (defconstant IPMSG_FILE-DIR                  #x00000002)
 209 (defconstant IPMSG_FILE-RETPARENT            #x00000003)    ;; return parent directory
 210
 211 (defconstant IPMSG_FILE-SYMLINK              #x00000004)
 212 (defconstant IPMSG_FILE-CDEV                 #x00000005)    ;; for UNIX
 213
 214 (defconstant IPMSG_FILE-BDEV                 #x00000006)    ;; for UNIX
 215
 216 (defconstant IPMSG_FILE-FIFO                 #x00000007)    ;; for UNIX
 217
 218 (defconstant IPMSG_FILE-RESFORK              #x00000010)    ;; for Mac
 219
 220
 221 ;; file attribute options for fileattach command
 222 (defconstant IPMSG_FILE-RONLYOPT             #x00000100)
 223 (defconstant IPMSG_FILE-HIDDENOPT            #x00001000)
 224 (defconstant IPMSG_FILE-EXHIDDENOPT          #x00002000)    ;; for MacOS X
 225
 226 (defconstant IPMSG_FILE-ARCHIVEOPT           #x00004000)
 227 (defconstant IPMSG_FILE-SYSTEMOPT            #x00008000)
 228
 229 ;; extend attribute types for fileattach command
 230 (defconstant IPMSG_FILE-UID                  #x00000001)
 231 (defconstant IPMSG_FILE-USERNAME             #x00000002)    ;; uid by string
 232
 233 (defconstant IPMSG_FILE-GID                  #x00000003)
 234 (defconstant IPMSG_FILE-GROUPNAME            #x00000004)    ;; gid by string
 235
 236 (defconstant IPMSG_FILE-PERM                 #x00000010)    ;; for UNIX
 237
 238 (defconstant IPMSG_FILE-MAJORNO              #x00000011)    ;; for UNIX devfile
 239
 240 (defconstant IPMSG_FILE-MINORNO              #x00000012)    ;; for UNIX devfile
 241
 242 (defconstant IPMSG_FILE-CTIME                #x00000013)    ;; for UNIX
 243
 244 (defconstant IPMSG_FILE-MTIME                #x00000014)
 245 (defconstant IPMSG_FILE-ATIME                #x00000015)
 246 (defconstant IPMSG_FILE-CREATETIME           #x00000016)
 247 (defconstant IPMSG_FILE-CREATOR              #x00000020)    ;; for Mac
 248
 249 (defconstant IPMSG_FILE-FILETYPE             #x00000021)    ;; for Mac
 250
 251 (defconstant IPMSG_FILE-FINDERINFO           #x00000022)    ;; for Mac
 252
 253 (defconstant IPMSG_FILE-ACL                  #x00000030)
 254 (defconstant IPMSG_FILE-ALIASFNAME           #x00000040)    ;; alias fname
 255
 256 (defconstant IPMSG_FILE-UNICODEFNAME         #x00000041)    ;; UNICODE fname
 257
 258 (define-ipmsg-command-recipient (:NOOPERATION :NOP) #x00000000
 259     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 260           &allow-other-keys)
 261   nil)
 262
 263 (define-ipmsg-command-recipient :BR-ENTRY                  #x00000001
 264   (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 265         &allow-other-keys)
 266   #+nil(warn "in")
 267   (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
 268     (register-host :username username :username username :hostname hostname
 269                    :nickname msg :groupname exmsg :status cmd-opt
 270                    :host hostaddr :port port)
 271     (send-command-message (get-protocol-singleton 'ipmsg-protocol)
 272                           hostaddr port
 273                           :cmd :ANSENTRY
 274                           :msg (user-name (protocol-self-info protocol))))
 275   #+nil(warn "out")
 276   )
 277 (define-ipmsg-command-recipient :BR-EXIT                   #x00000002
 278     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 279           &allow-other-keys)
 280     (unregister-host username hostname)
 281     )
 282 (define-ipmsg-command-recipient :ANSENTRY                  #x00000003
 283     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 284           &allow-other-keys)
 285     #+nil(warn "in")
 286     (register-host :username username :hostname hostname
 287                    :nickname msg :groupname exmsg :status cmd-opt
 288                    :host hostaddr :port port)
 289     #+nil(warn "out")
 290   )
 291 (define-ipmsg-command-recipient :BR-ABSENCE                #x00000004
 292     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 293           &allow-other-keys)
 294   nil)
 295
 296 (define-ipmsg-command-recipient :BR-ISGETLIST              #x00000010
 297     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 298           &allow-other-keys)
 299   nil)
 300 (define-ipmsg-command-recipient :OKGETLIST                 #x00000011
 301     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 302           &allow-other-keys)
 303   nil)
 304 (define-ipmsg-command-recipient :GETLIST                   #x00000012
 305     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 306           &allow-other-keys)
 307   nil)
 308 (define-ipmsg-command-recipient :ANSLIST                   #x00000013
 309     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 310           &allow-other-keys)
 311   nil)
 312 (define-ipmsg-command-recipient :BR-ISGETLIST2             #x00000018
 313     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 314           &allow-other-keys)
 315   nil)
 316
 317 (define-ipmsg-command-recipient :SENDMSG                   #x00000020
 318     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 319           &allow-other-keys)
 320     (when (= (logand cmd-opt IPMSG_SENDCHECKOPT) IPMSG_SENDCHECKOPT)
 321       (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
 322         (send-command-message (get-protocol-singleton 'ipmsg-protocol)
 323                               hostaddr port
 324                               :cmd :RECVMSG
 325                               :msg (format nil "~a" packno))))
 326     (format t "~%~a:~a~&# " username msg)(force-output)
 327     )
 328
 329 (define-ipmsg-command-recipient :RECVMSG                   #x00000021
 330     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 331           &allow-other-keys)
 332   )
 333
 334 (define-ipmsg-command-recipient :READMSG                   #x00000030
 335     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 336           &allow-other-keys)
 337   nil)
 338 (define-ipmsg-command-recipient :DELMSG                    #x00000031
 339     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 340           &allow-other-keys)
 341   nil)
 342 (define-ipmsg-command-recipient :ANSREADMSG                #x00000032
 343     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 344           &allow-other-keys)
 345   nil)
 346
 347 (define-ipmsg-command-recipient :GETINFO                   #x00000040
 348     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 349           &allow-other-keys)
 350   nil)
 351 (define-ipmsg-command-recipient :SENDINFO                  #x00000041
 352     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 353           &allow-other-keys)
 354   nil)
 355
 356 (define-ipmsg-command-recipient :GETABSENCEINFO            #x00000050
 357     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 358           &allow-other-keys)
 359   nil)
 360 (define-ipmsg-command-recipient :SENDABSENCEINFO           #x00000051
 361     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 362           &allow-other-keys)
 363   nil)
 364
 365 (define-ipmsg-command-recipient :GETFILEDATA               #x00000060
 366     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 367           &allow-other-keys)
 368   nil)
 369 (define-ipmsg-command-recipient :RELEASEFILES              #x00000061
 370     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 371           &allow-other-keys)
 372   nil)
 373 (define-ipmsg-command-recipient :GETDIRFILES               #x00000062
 374     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 375           &allow-other-keys)
 376   nil)
 377
 378 (define-ipmsg-command-recipient :GETPUBKEY                 #x00000072
 379     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 380           &allow-other-keys)
 381   nil)
 382 (define-ipmsg-command-recipient :ANSPUBKEY                 #x00000073
 383     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 384           &allow-other-keys)
 385   nil)
 386
 387 (define-ipmsg-command-recipient :FEIQ-UNKNOWNMSG                 #x00000079
 388     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 389           &allow-other-keys)
 390   #+nil(format t "~&FEIQ-SEND [~a] ~a ~a~%" username msg exmsg)
 391   )
 392
 393
 394 (define-ipmsg-command-recipient :EXT-SENDCHANNELMSG               #x00000090
 395     (&key hostaddr port ver packno username hostname cmd cmd-opt msg exmsg
 396           &allow-other-keys)
 397     (let ((protocol (get-protocol-singleton 'ipmsg-protocol)))
 398       #+nil(warn "~a ~a ~a" exmsg (protocol-channel-list protocol) msg)
 399       (when (member exmsg
 400                     (protocol-channel-list protocol) :test #'string-equal)
 401 ;;      (when (not (and (equal hostaddr
 402 ;;                             (format-ip (ip-interface-address
 403 ;;                                         (protocol-if protocol))))
 404 ;;                      (equal port
 405 ;;                             (protocol-port protocol))))
 406             (format t "~&[~a]~a:~a~%" exmsg username msg)(force-output))))
 407 ;;)
 408