;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               udp.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Provides a simple UDP API.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@ogamita.com>
;;;;MODIFICATIONS
;;;;    2011-04-10 <PJB> Added implementation for ccl.
;;;;    2010-11-08 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2011 - 2011
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 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 General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************

(defpackage "COM.OGAMITA.FGFS.UDP"
  (:use "COMMON-LISP")
  (:export
   "ADDRESS" "ADDRESS-P" "MAKE-ADDRESS" "COPY-ADDRESS" "ADDRESS-HOST" "ADDRESS-PORT"
   "IP-ADDRESS-OF-HOST" "MAKE-SOCKADDR"
   "UDP-SOCKET" "UDP-SOCKET-P" "UDP-SOCKET-LOCAL-SOCKADDR" "UDP-SOCKET-REMOTE-SOCKADDR"
   "UDP-SET-BLOCKING" "UDP-CONNECT" "UDP-SEND-PACKET" "UDP-RECEIVE-PACKET" "UDP-CLOSE")
  (:documentation "
Provides a simple UDP API.
Copyright Pascal J. Bourguignon 2011 - 2011
GPL
"))
(in-package "COM.OGAMITA.FGFS.UDP")


(defstruct address
  (host #+clisp #(0 0 0 0)
        #+ccl   0)
  (port 0))


(declaim (inline octetp))
(defun octetp (x)
  (and (integerp x) (<= 0 x 255)))


(declaim (inline octets-to-integer))
(defun octets-to-integer (octets)
  (reduce (lambda (a b) (+ (ash a 8) b)) octets :initial-value 0))


(defgeneric ip-address-of-host (host)
  (:documentation "
Resolves the  hostname or IP address given as a string HOST
into a list of bytes of the IP address.
")
  (:method ((host address))
    (make-address :host (ip-address-of-host (address-host host))
                  :port  (address-port host)))
  (:method ((host null))
    (declare (ignorable host))
    #-ccl '(0 0 0 0)
    #+ccl 0)
  (:method ((host cons))
    #-ccl host
    #+ccl (octets-to-integer host))
  (:method ((host vector))
    #-ccl host
    #+ccl (octets-to-integer host))
  (:method ((host string))
    #+clisp
    (progn
      (when (regexp:match "^[0-9]\\+\\.[0-9]\\+\\.[0-9]\\+\\.[0-9]\\+$" host)
        (let ((bytes (mapcar (function parse-integer) (split-sequence #\. host))))
          (when (every (function octetp) bytes)
            (return-from ip-address-of-host bytes))))
      (let ((entry (POSIX:RESOLVE-HOST-IPADDR host)))
        (when (and (= 2 (posix:hostent-addrtype entry))
                   (posix:hostent-addr-list entry))
          (dolist (address (posix:hostent-addr-list entry))
            (ignore-errors (return-from ip-address-of-host (ip-address-of-host address)))))
        (error "Cannot find an acceptable address in ~S" entry)))
    #+ccl
    (or (ignore-errors (ccl:lookup-hostname host))
        (error "Cannot find an acceptable address for ~S" host))
    #-(or ccl clisp) (error "~S not implemented for ~A."
                            'ip-address-of-host (lisp-implementation-type))))


(defun make-sockaddr (family address)
  (declare (ignorable family))
  (let ((host (address-host address))
        (port (address-port address)))
    #+clisp
    (rawsock:make-sockaddr family
                           (concatenate 'vector
                             (multiple-value-list (truncate port 256))
                             (etypecase host
                               (null                       #(0 0 0 0))
                               (string                     (ip-address-of-host host))
                               ((vector (unsigned-byte 8)) host)
                               (sequence   (coerce host '(vector (unsigned-byte 8)))))
                             #(0 0 0 0   0 0 0 0)))
    #+ccl
    (make-address :port port
                  :host (etypecase host
                          (null                       0)
                          (string                     (ip-address-of-host host))
                          ((vector (unsigned-byte 8)) (ip-address-of-host host))
                          (sequence                   (ip-address-of-host host))))
    #-(or ccl clisp) (error "~S not implemented for ~A."
                            'make-sockaddr (lisp-implementation-type))))




(defstruct udp-socket
  socket
  local-sockaddr
  remote-sockaddr)

;; set dispatch macro character to be able to read ccl code from other
;; implementations (#+ccl is not enough to read suppress them).
#-ccl (eval-when (:execute :compile-toplevel :load-toplevel)
        (set-dispatch-macro-character #\# #\_ 'read)
        (set-dispatch-macro-character #\# #\$ 'read))

(defun udp-set-blocking (socket blocking)
  (let ((socket (udp-socket-socket socket)))
    #+clisp
    (let ((delay-flag (linux:|fcntl3l|  socket linux:|F_GETFL| 0)))
      (linux:|fcntl3l| (udp-socket-socket socket) linux:|F_SETFL|
             (if blocking
                 (logand delay-flag (lognot LINUX:|O_NDELAY|))
                 (logior delay-flag LINUX:|O_NDELAY|))))
    #+ccl
    (let ((fd (ccl:socket-os-fd socket)))
      (let ((delay-flag (#_|fcntl| fd #$|F_GETFL| :signed-fullword 0)))
        (#_|fcntl| fd #$|F_SETFL|
           :SIGNED-FULLWORD (if blocking
                                (logand delay-flag (lognot #$|O_NDELAY|))
                                (logior delay-flag #$|O_NDELAY|))))))
  #-(or ccl clisp) (error "~S not implemented for ~A."
                          'udp-set-blocking (lisp-implementation-type)))


(defun udp-connect (remote-address local-address)
  #-(or clisp ccl) (error "~S not implemented for ~A."
                          'udp-connect (lisp-implementation-type))
  (let* ((remote (make-sockaddr :inet remote-address))
         (local  (make-sockaddr :inet local-address))
         (socket #+clisp (rawsock:socket :inet :dgram 0)
                 #-clisp (ccl:make-socket :address-family :internet
                                          :remote-host (address-host remote)
                                          :remote-port (address-port remote)
                                          :local-host  (address-host local)
                                          :local-port  (address-port local))))
    (handler-case
        (progn
          (udp-set-blocking socket nil)
          #+clisp (rawsock:bind socket local)
          #+clisp (rawsock:connect socket remote)
          #+ccl   (ccl:socket-connect socket)
          (make-udp-socket :socket socket
                           :local-sockaddr local
                           :remote-sockaddr remote))
      (error (err)
mu        #+clisp (rawsock:sock-close socket)
        #-ccl   (close socket)
        (error err)))))


(defun udp-send-packet (connection packet)
  #+clisp (rawsock:sendto (udp-socket-socket connection) packet
                          (udp-socket-remote-sockaddr connection))
  #+ccl (let ((remote (udp-socket-remote-sockaddr connection)))
          (ccl:send-to (udp-socket-socket connection) packet
                       (length packet)
                       :remote-host (address-host remote)
                       :remote-port (address-port remote)))
  #-(or clisp ccl) (error "~S not implemented for ~A."
                          'udp-send-packet (lisp-implementation-type)))


(defun udp-receive-packet (connection buffer)
  #+clisp (rawsock:recvfrom (udp-socket-socket connection) buffer
                            (udp-socket-remote-sockaddr connection))
  #+ccl (let ((remote (udp-socket-remote-sockaddr connection)))
          (multiple-value-bind (buffer bytes-read host port)
              (ccl:receive-from (udp-socket-socket connection)
                                (length buffer)
                                :buffer buffer)
            (declare (ignore buffer))
            (setf (address-host remote) host
                  (address-port remote) port)
            bytes-read))
  #-(or clisp ccl) (error "~S not implemented for ~A."
                          'udp-receive-packet (lisp-implementation-type)))


(defun udp-close (connection)
  #+clisp (rawsock:sock-close (udp-socket-socket connection))
  #-ccl   (close (udp-socket-socket connection))
  #-(or clisp ccl) (error "~S not implemented for ~A."
                          'udp-close (lisp-implementation-type))
  (setf (udp-socket-socket connection) nil))



;;;; THE END ;;;;
ViewGit