pipe-client.lisp

(cl:defpackage #:pipe-client
  (:use #:cl))

(in-package #:pipe-client)

;;; Create/Close pipe
(defun create-pipe-client! (pipe-filename)
  "Creates a pipe-client with the given pipe-filename.
Returns a valid pipe handle or signals an error.
Assumes a pipe-server is already open with the same pipe-filname."
  (let ((pipe (win32-create-file-a!
	       pipe-filename ; filename
	       (win32-generic-read/write) ; open with read/write permissions
	       0 ; default share-mode
	       (null-sap) ; default security attributes
	       (win32-open-existing) ; open an already existing pipe
	       0 ; default flags/attributes
	       (null-sap)))) ; no template file

    (when (= (sb-sys:sap-int pipe) (win32-invalid-handle-value))
      ;; If the pipe handle is invalid, throw an error.
      (win32-error (win32-get-last-error) "Failed to open pipe"))

    ;; The pipe opened successfully: set it to read mode.
    (unless (set-pipe-read-message-mode! pipe)
      (let ((error-code (win32-get-last-error)))
	(close-pipe-client! pipe)
	(win32-error error-code "Failed to set the pipe to read-message mode")))

    ;; Return the pipe.
    pipe))

(defun win32-generic-read ()
  "CreateFile access flag to enable read operations."
  (ash 1 31))
(defun win32-generic-write ()
  "CreateFile access flag to enable write operations."
  (ash 1 30))
(defun win32-generic-read/write ()
  "CreateFile access flag to enable read and write operations."
  (logior (win32-generic-read) (win32-generic-write)))
(defun win32-open-existing ()
  "CreateFile creation disposition flag to indicate opening an existing file as opposed to e.g. creating a new file."
  3)
(defun win32-invalid-handle-value ()
  "Integer value of an invalid file handle."
  #XFFFFFFFFFFFFFFFF)

(defun null-sap ()
  "NULL pointer in C."
  (sb-sys:int-sap 0))

(sb-alien:define-alien-routine ("CreateFileA" win32-create-file-a!) sb-alien:system-area-pointer
  (file-name sb-alien:c-string)
  (desired-access (sb-alien:unsigned 32))
  (share-mode (sb-alien:unsigned 32))
  (security-attributes sb-alien:system-area-pointer)
  (creation-disposition (sb-alien:unsigned 32))
  (flags-and-attributes (sb-alien:unsigned 32))
  (template-file sb-alien:system-area-pointer))

;;; Set pipe to read-message mode
(defun set-pipe-read-message-mode! (pipe)
  "Sets the given pipe to read-message. Returns true if successful."
  (sb-alien:with-alien ((mode (sb-alien:unsigned 32) 1))
    (setf mode (win32-pipe-readmode-message))
    (win32-set-named-pipe-handle-state! pipe
					(sb-alien:addr mode) ; set to read-message mode
					(null-sap)	     ; unused
					(null-sap)))) ; unused

(defun win32-pipe-readmode-message ()
  "SetNamedPipeHandleState mode flag used to set the pipe mode to read messages."
  #x2)

(sb-alien:define-alien-routine ("SetNamedPipeHandleState" win32-set-named-pipe-handle-state!) sb-alien:boolean
  (named-pipe sb-alien:system-area-pointer)
  (mode (sb-alien:* (sb-alien:unsigned 32)))
  (max-collection-count (sb-alien:* (sb-alien:unsigned 32)))
  (collection-data-timeout (sb-alien:* (sb-alien:unsigned 32))))

;;; Close client pipe
(defun close-pipe-client! (pipe)
  "Closes the given pipe-client. Returns true if successful."
  (win32-close-handle! pipe))

(sb-alien:define-alien-routine ("CloseHandle" win32-close-handle!) sb-alien:boolean
  (object sb-alien:system-area-pointer))

;;; Send request
(defun send-pipe-request! (pipe request-bytes)
  "Sends the request-bytes vector to the pipe-client. 
Blocks until a response is read, and returns (values response-bytes num-response-bytes)."
  (write-request-bytes! pipe request-bytes)
  (read-response-bytes! pipe))

;;; Write request
(defun write-request-bytes! (pipe request-bytes)
  "Write request-bytes to the pipe. Return the number of bytes written."
  (multiple-value-bind (succeeded num-bytes-written)
      (sb-sys:with-pinned-objects (request-bytes)
	(win32-write-file! pipe		; file handle
			   (sb-sys:vector-sap request-bytes) ; byte array
			   (length request-bytes) ; number of bytes to write
			   (null-sap)))		  ; no overlapped IO
    (unless succeeded
      (win32-error (win32-get-last-error) "Failed to write request bytes"))
    ;; return the number of bytes written.
    num-bytes-written))

(sb-alien:define-alien-routine ("WriteFile" win32-write-file!) sb-alien:boolean
  (file sb-alien:system-area-pointer)
  (buffer sb-alien:system-area-pointer)
  (number-of-bytes-to-write (sb-alien:unsigned 32))
  (number-of-bytes-written (sb-alien:unsigned 32) :out)
  (overlapped (sb-alien:* (sb-alien:unsigned 32))))


;;; Read Response
(defun read-response-bytes! (pipe &optional (buffer *response-buffer*))
  "Read the next message from the pipe. Return (values buffer num-bytes-read)."
  (sb-sys:with-pinned-objects (buffer)
    (multiple-value-bind (succeeded num-bytes-read)
	(win32-read-file! pipe
			  (sb-sys:vector-sap buffer) ; where to write the response bytes
			  (length buffer) ; max message length
			  (null-sap))	  ; no overlapped IO
      (unless succeeded
	(win32-error (win32-get-last-error) "Could not read response bytes"))
      (values buffer num-bytes-read))))

(defvar *response-buffer*)

(sb-alien:define-alien-routine ("ReadFile" win32-read-file!) sb-alien:boolean
  (file sb-alien:system-area-pointer)
  (buffer sb-alien:system-area-pointer)
  (number-of-bytes-to-read (sb-alien:unsigned 32))
  (number-of-bytes-read (sb-alien:unsigned 32) :out)
  (overlapped (sb-alien:* (sb-alien:unsigned 32))))

;;; Error-Reporting
(sb-alien:define-alien-routine ("GetLastError" win32-get-last-error) (sb-alien:unsigned 32))

(defun win32-error (error-code format-string &rest format-arguments)
  "Signals an error with the given format string and arguments. 
Appends the error code and error string to the error message."
  (error "~A: ~S ~S"
	 (apply #'format nil format-string format-arguments)
	 error-code (win32-error-code->string error-code)))

(defun win32-error-code->string (error-code)
  "Convert a Win32 system error code to a string using FormatMessageA."
  (sb-sys:with-pinned-objects (*error-code-buffer*)
    (win32-format-message-a (win32-format-message-from-system) ; flags
			    (null-sap)	; source
			    error-code	; message-id
			    0		; language-id
			    (sb-sys:vector-sap *error-code-buffer*) ; buffer
			    (length *error-code-buffer*) ; buffer length
			    (null-sap)))		 ; arguments
  (bytes->string *error-code-buffer*))

(defun win32-format-message-from-system ()
  "Flag for FormatMessageA indicating the message-id is a system error-code."
  #x1000)
(sb-alien:define-alien-routine ("FormatMessageA" win32-format-message-a) (sb-alien:unsigned 32)
  (flags (sb-alien:unsigned 32))
  (source sb-alien:system-area-pointer)
  (message-id (sb-alien:unsigned 32))
  (language-id (sb-alien:unsigned 32))
  (buffer (sb-alien:* (sb-alien:signed 8)))
  (size (sb-alien:unsigned 32))
  (arguments sb-alien:system-area-pointer))

(defun make-byte-vector (num-bytes)
  "Return an array of num-bytes bytes."
  (make-array num-bytes
	      :element-type '(unsigned-byte 8)
	      :initial-element 0))
(defvar *error-code-buffer* (make-byte-vector 1024)
  "The byte buffer used by win32-error-code->string.")

(defun bytes->string (bytes)
  "Convert an array of c-string bytes into a lisp string."
  (map 'string #'code-char (subseq bytes 0 (position 0 bytes))))

;;; Example

(defvar *pipe*)
(defun run-pipe-client-example! ()
  "Connects to the example_pipe pipe server, sends a message, prints the response, and closes the pipe."
  (setf *pipe* (create-pipe-client! (pipe-filename "example_pipe")))
  ;; Example server expects a string and will respond with a string.
  (let ((*response-buffer* (make-byte-vector 1024)))
    (print (bytes->string (send-pipe-request! *pipe* (string->bytes "Hello, server")))))
  (close-pipe-client! *pipe*))

(defun pipe-filename (pipe-name)
  "Prepends \"\\\\.\\pipe\\\" to pipe-name to form a valid pipe filename."
  ;; Looks like:
  ;;   \\.\pipe\pipe-name
  (concatenate 'string "\\\\.\\pipe\\" pipe-name))

(defun string->bytes (string)
  "Convert a string into a 0-terminated byte-vector."
  (let ((bytes (make-byte-vector (1+ (length string)))))
    (loop for char across string
	  for i from 0
	  do (setf (aref bytes i) (char-code char)))
    bytes))

#+nil
(run-pipe-client-example!)
#||
Output:

"Hello, client!" 
||#
;; => T