;; This package is designed for LispWorks.  It implements the
;; ACL-style socket interface on top of LispWorks.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "comm"))

#+cl-ssl
(eval-when (:compile-toplevel :load-toplevel :execute)
(ssl-internal::initialize-ssl-library)
)

(in-package acl-compat.socket)

(define-condition stream-error (error)
  ((acl-compat.excl::stream :initarg :stream
           :reader stream-error-stream)
   (acl-compat.excl::action :initarg :action
           :reader stream-error-action)
   (acl-compat.excl::code :initarg :code
         :reader stream-error-code)
   (acl-compat.excl::identifier :initarg :identifier
               :reader stream-error-identifier))
  (:report (lambda (condition stream)
             (format stream "A stream error occured (action=~A identifier=~A code=~A stream=~S)."
                     (stream-error-action condition)
                     (stream-error-identifier condition)
                     (stream-error-code condition)
                     (stream-error-stream condition)))))

(define-condition socket-error (stream-error)
  ()
  (:report (lambda (condition stream)
             (format stream "A socket error occured (action=~A identifier=~A code=~A stream=~S)."
                     (stream-error-action condition)
                     (stream-error-identifier condition)
                     (stream-error-code condition)
                     (stream-error-stream condition)))))

#+unix
(defun %socket-error-identifier (code)
  (case code
    (32 :x-broken-pipe)
    (98 :address-in-use)
    (99 :address-not-available)
    (100 :network-down)
    (102 :network-reset)
    (103 :connection-aborted)
    (104 :connection-reset)
    (105 :no-buffer-space)
    (108 :shutdown)
    (110 :connection-timed-out)
    (111 :connection-refused)
    (112 :host-down)
    (113 :host-unreachable)
    (otherwise :unknown)))

#+win32
(defun %socket-error-identifier (code)
  (case code
    (10048 :address-in-use)
    (10049 :address-not-available)
    (10050 :network-down)
    (10052 :network-reset)
    (10053 :connection-aborted)
    (10054 :connection-reset)
    (10055 :no-buffer-space)
    (10058 :shutdown)
    (10060 :connection-timed-out)
    (10061 :connection-refused)
    (10064 :host-down)
    (10065 :host-unreachable)
    (otherwise :unknown)))

(defun socket-error (stream error-code action format-string &rest format-args)
  (declare (ignore format-string format-args)) ;no valid initargs for this with socket-error
  (let ((code (if (numberp error-code) error-code #+unix(lw:errno-value))))
    (error 'socket-error :stream stream :code code
           :identifier (if (keywordp error-code)
                           error-code
                         (%socket-error-identifier error-code))
           :action action)))


(defclass socket ()
  ((passive-socket :type fixnum
                   :initarg :passive-socket
                   :reader socket-os-fd)))

(defclass passive-socket (socket)
  ((element-type :type (member signed-byte unsigned-byte base-char)
		 :initarg :element-type
		 :reader element-type)
   (port :type fixnum
	 :initarg :port
	 :reader local-port)))

(defclass binary-socket-stream (de.dataheaven.chunked-stream-mixin:chunked-stream-mixin comm:socket-stream) ())
(defclass input-binary-socket-stream (binary-socket-stream)())
(defclass output-binary-socket-stream (binary-socket-stream)())
(defclass bidirectional-binary-socket-stream (input-binary-socket-stream output-binary-socket-stream)())


(defmethod comm::socket-error ((stream binary-socket-stream) error-code format-string &rest format-args)
  (apply #'socket-error stream error-code :IO format-string format-args))


(declaim (inline %reader-function-for-sequence))
(defun %reader-function-for-sequence (sequence)
  (typecase sequence
    (string #'read-char)
    ((array unsigned-byte (*)) #'read-byte)
    ((array signed-byte (*)) #'read-byte)
    (otherwise #'read-byte)))

;; Bivalent socket support for READ-SEQUENCE
(defmethod gray-stream:stream-read-sequence ((stream input-binary-socket-stream) sequence start end)
  (stream::read-elements stream sequence start end (%reader-function-for-sequence sequence)))

;; NDL 2004-06-06 -- without this, emit-clp-entity tries writing a string down a binary stream, and LW barfs
(defmethod gray-stream:stream-write-sequence ((stream output-binary-socket-stream) (sequence string) start end)
  (write-string sequence stream :start start :end end))

;; ACL Gray-Streams Enhancment Generic Functions 

(defmethod stream-input-fn ((stream input-binary-socket-stream))
  (comm:socket-stream-socket stream))

(defmethod stream-output-fn ((stream output-binary-socket-stream))
  (comm:socket-stream-socket stream))

(defmethod socket-os-fd ((socket comm:socket-stream))
  (comm:socket-stream-socket socket))

(defmethod print-object ((passive-socket passive-socket) stream)
  (print-unreadable-object (passive-socket stream :type t :identity nil)
    (format stream "@~d on port ~d" (socket-os-fd passive-socket) (local-port passive-socket))))

(defmethod stream-input-available ((fd fixnum))
  (comm::socket-listen fd))

(defmethod stream-input-available ((stream stream::os-file-handle-stream))
  (stream-input-available (stream::os-file-handle-stream-file-handle stream)))

(defmethod stream-input-available ((stream comm:socket-stream))
  (or (comm::socket-listen (comm:socket-stream-socket stream))
      (listen stream)))

(defmethod stream-input-available ((stream socket::passive-socket))
  (comm::socket-listen (socket::socket-os-fd stream)))

(defvar *passive-socket-backlog* 10) 
(defmethod accept-connection ((passive-socket passive-socket)
			      &key (wait t))
  (if (or wait (stream-input-available passive-socket))
      (make-instance 'bidirectional-binary-socket-stream
                     :socket (comm::get-fd-from-socket (socket-os-fd passive-socket))
                     :direction :io
                     :element-type (element-type passive-socket))))

(defun %new-passive-socket (local-port)
  (multiple-value-bind (socket error-location error-code)
      (comm::create-tcp-socket-for-service local-port :backlog *passive-socket-backlog*
                                           )
    (cond (socket socket)
	  (t (error 'socket-error :action error-location :code error-code :identifier :unknown)))))

(defun make-socket (&key (remote-host "localhost")
			 local-port
			 remote-port 
			 (connect :active)
			 (format :text)
                         (reuse-address t)
			 &allow-other-keys)
  (declare (ignore format))
  (check-type remote-host string)
  (ecase connect 
    (:passive
     (let ((comm::*use_so_reuseaddr* reuse-address))
       (make-instance 'passive-socket
                      :port local-port
                      :passive-socket (%new-passive-socket local-port)
                      :element-type '(unsigned-byte 8))))
    (:active
     (handler-case
         (let ((stream (comm:open-tcp-stream remote-host remote-port
                                             :direction :io
                                             :element-type '(unsigned-byte 8)
                                             :errorp t)))
           (change-class stream 'bidirectional-binary-socket-stream))
       (simple-error (condition) 
                     (let ((code (first (last (simple-condition-format-arguments condition)))))
                       (socket-error condition code
                                     :connect "~A occured while connecting (~?)" (simple-condition-format-arguments condition))))))))


(defmethod close ((passive-socket passive-socket) &key abort)
  (declare (ignore abort))
  (comm::close-socket (socket-os-fd passive-socket)))

;(declaim (ftype (function ((unsigned-byte 32)) (values simple-string))
;		ipaddr-to-dotted))
(defun ipaddr-to-dotted (ipaddr &key values)
  ;(declare (type (unsigned-byte 32) ipaddr))
  (if ipaddr ;sometimes ipaddr is nil in the log call if client has broken the connection
    (let ((a (logand #xff (ash ipaddr -24)))
          (b (logand #xff (ash ipaddr -16)))
          (c (logand #xff (ash ipaddr -8)))
          (d (logand #xff ipaddr)))
      (if values
	(values a b c d)
        (format nil "~d.~d.~d.~d" a b c d)))
    (if values (values 0 0 0 0) "0.0.0.0")))

(defun string-tokens (string)
  (labels ((get-token (str pos1 acc)
                      (let ((pos2 (position #\Space str :start pos1)))
                        (if (not pos2)
                            (nreverse acc)
                          (get-token str (1+ pos2) (cons (read-from-string (subseq str pos1 pos2))
                                                         acc))))))
(get-token (concatenate 'string string " ") 0 nil)))

(declaim (ftype (function (string &key (:errorp t))
                          (values (unsigned-byte 32)))
		dotted-to-ipaddr))
(defun dotted-to-ipaddr (dotted &key (errorp t))
  (declare (string dotted))
  (if errorp
      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
	(+ (ash (first ll) 24) (ash (second ll) 16)
	   (ash (third ll) 8) (fourth ll)))
    (ignore-errors 
      (let ((ll (string-tokens (substitute #\Space #\. dotted))))
	(+ (ash (first ll) 24) (ash (second ll) 16)
	   (ash (third ll) 8) (fourth ll))))))

(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
  (declare (ignore ignore-cache))
  (multiple-value-bind (name)
      (comm:get-host-entry (ipaddr-to-dotted ipaddr) :fields '(:name))
    name))

(defun lookup-hostname (host &key ignore-cache)
  (when ignore-cache
    (warn ":IGNORE-CACHE keyword in LOOKUP-HOSTNAME not supported."))
  (if (stringp host)
      (multiple-value-bind (addr)
	  (comm:get-host-entry host :fields '(:address))
	addr)
    (dotted-to-ipaddr (ipaddr-to-dotted host))))

(defmethod remote-host ((socket comm:socket-stream))
  (comm:socket-stream-peer-address socket))

(defmethod remote-port ((socket comm:socket-stream))
  (multiple-value-bind (host port)
      (comm:socket-stream-peer-address socket)
    (declare (ignore host))
    port))

(defmethod local-host ((socket comm:socket-stream))
  (multiple-value-bind (host port)
      (comm:socket-stream-address socket)
    (declare (ignore port))
    host))

(defmethod local-port ((socket comm:socket-stream))
  (multiple-value-bind (host port)
      (comm:socket-stream-address socket)
    (declare (ignore host))
    port))

(defun socket-control (stream &key (output-chunking nil oc-p) output-chunking-eof (input-chunking nil ic-p))
  (when oc-p
    (when output-chunking
      (de.dataheaven.chunked-stream-mixin::initialize-output-chunking stream))
    (setf (de.dataheaven.chunked-stream-mixin:output-chunking-p stream) output-chunking))
  (when output-chunking-eof
    (de.dataheaven.chunked-stream-mixin::disable-output-chunking stream))
  (when ic-p
    (when input-chunking
      (de.dataheaven.chunked-stream-mixin::initialize-input-chunking stream))
    (setf (de.dataheaven.chunked-stream-mixin:input-chunking-p stream) input-chunking)))

#+(and :lispworks4.4 (not :cl-ssl))
(defmethod make-ssl-client-stream ((socket-stream bidirectional-binary-socket-stream) &rest options)
  (declare (ignore options))
  (comm:attach-ssl socket-stream :ssl-ctx t :ssl-side :client)
  socket-stream)

#+(and :lispworks4.4 (not :cl-ssl))
(defun initialize-ssl-library ()
  ;; Dunno how to force load yet
  (comm:ensure-ssl))

#+(and :lispworks4.4 (not :cl-ssl))
(defmethod make-ssl-server-stream ((socket-stream bidirectional-binary-socket-stream) &key certificate  certificate-password)
  (flet ((ctx-configure-callback (ctx)
	   (comm:ssl-ctx-use-privatekey-file ctx
					     certificate-password
					     comm:SSL_FILETYPE_PEM))
	 (ssl-configure-callback (ssl)
	   (comm:ssl-use-certificate-file ssl
					  certificate
					  comm:SSL_FILETYPE_PEM)))
    (comm:attach-ssl socket-stream
		     :ssl-side :server
		     :ctx-configure-callback #'ctx-configure-callback
		     :ssl-configure-callback #'ssl-configure-callback))
  socket-stream)


;; SSL support using built-in LispWorks OpenSSL interface

(defvar *certificate-ctx-map* (make-hash-table :test 'equal))
(defvar *certificate-ctx-map-lock* (mp:make-lock))
(defvar *share-ssl-ctx-p* nil) ; needs to remain as NIL for ACL compatibility?

(defun ensure-ssl-ctx-for-certificate (certificate-file
                                       key
                                       certificate-password)
  (if *share-ssl-ctx-p*
      (mp:with-lock (*certificate-ctx-map-lock*)
        (or (gethash certificate-file *certificate-ctx-map*)
            (setf (gethash certificate-file *certificate-ctx-map*)
                  (make-ssl-ctx-for-certificate certificate-file
                                                key
                                                certificate-password))))
    (make-ssl-ctx-for-certificate certificate-file
                                  key
                                  certificate-password)))

(defun make-ssl-ctx-for-certificate (certificate-file
                                     key
                                     certificate-password)
  (let ((ssl-ctx (comm:make-ssl-ctx :ssl-side :server)))
    (when certificate-password
      (comm:set-ssl-ctx-password-callback ssl-ctx :password certificate-password))
    (comm:ssl-ctx-use-certificate-chain-file ssl-ctx (namestring certificate-file))
    (comm:ssl-ctx-use-rsaprivatekey-file ssl-ctx
                                         (namestring (or key certificate-file))
                                         comm:ssl_filetype_pem)
    ;; (comm:set-ssl-ctx-dh ssl-ctx :filename dh-file)
    ssl-ctx))

(defmethod make-ssl-server-stream ((stream comm:socket-stream) &key
                                   certificate key certificate-password
                                   ;; method verify max-depth   ; client cert options
                                   ;; ca-file ca-directory      ;   not implemented yet
                                   )
  (let ((ctx (ensure-ssl-ctx-for-certificate certificate
                                             key
                                             certificate-password)))
    (comm:attach-ssl stream :ssl-side :server :ssl-ctx ctx)
    ;; Return the same stream -- is this allowed?
    stream))

(provide 'acl-socket)
