commit 127b2e86a6e7325c899760e996f3d81391e6ee73
parent e4d1c94177fea508d6388f1fbb3dcd69864389d5
Author: Tomas Hlavaty <tom@logand.com>
Date: Wed, 7 Aug 2013 01:30:48 +0200
print-job works via wget
Diffstat:
| M | ipp.lisp | | | 282 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------------------- |
1 file changed, 206 insertions(+), 76 deletions(-)
diff --git a/ipp.lisp b/ipp.lisp
@@ -25,47 +25,62 @@
(in-package :ipp)
-(defun read-octet (stream)
- (if (functionp stream)
- (funcall stream 'read-octet)
- (read-byte stream)))
-
-(defun copy-stream (in out)
- (handler-case (loop (write-byte (read-octet in) out))
- (end-of-file ())))
-
-(defun read-ushort (stream)
- (logior (ash (read-octet stream) 8)
- (read-octet stream)))
-
-(defun read-dword (stream)
- (logior (ash (read-octet stream) 24)
- (ash (read-octet stream) 16)
- (ash (read-octet stream) 8)
- (read-octet stream)))
-
-(defun read-octets (stream n)
+(defvar *input-stream*)
+(defvar *output-stream*)
+(defvar *ipp-client*)
+
+(defun read-octet ()
+ (let ((s *input-stream*))
+ (etypecase s
+ (stream (read-byte s))
+ (function (let ((x (funcall s)))
+ (assert (<= 0 x 256))
+ x)))))
+
+(defun write-octet (x)
+ (assert (<= 0 x #. (1- (expt 2 8))))
+ (let ((s *output-stream*))
+ (etypecase s
+ (stream (write-byte x s))
+ (function (funcall s x)))))
+
+(defun read-ushort ()
+ (logior (ash (read-octet) 8) (read-octet)))
+
+(defun write-ushort (x)
+ (assert (<= 0 x #.(1- (expt 2 16))))
+ (write-octet (ash x -8))
+ (write-octet (logand #xff x)))
+
+(defun read-dword ()
+ (logior (ash (read-ushort) 16) (read-ushort)))
+
+(defun write-dword (x)
+ (assert (<= 0 x #.(1- (expt 2 32))))
+ (write-ushort (ash x -16))
+ (write-ushort (logand #xffff x)))
+
+(defun copy-stream ()
+ (when *input-stream*
+ (handler-case (loop (write-octet (read-octet)))
+ (end-of-file ()))))
+
+(defun read-octets (n)
(let ((x (make-array n :element-type '(unsigned-byte 8) :initial-element 0)))
- (if (functionp stream)
- (let ((i 0))
- (handler-case (do ()
- ((<= n i))
- (setf (aref x i) (read-octet stream))
- (incf i))
- (end-of-file () i)))
- (read-sequence x stream))
+ (read-sequence x *input-stream*)
x))
-(defun make-data-stream (x)
+(defun write-octets (x)
(etypecase x
- (stream (lambda () (read-byte x nil nil)))
- (list (lambda () (pop x)))
- (vector (let ((n (length x))
- (i 0))
- (lambda ()
- (when (< i n)
- (prog1 (aref x i)
- (incf i))))))))
+ (stream (let ((*input-stream* x)) (copy-stream)))
+ (list (mapc 'write-octet x))
+ (vector (map 'vector 'write-octet x))))
+
+(defun string-to-octets (x) ;; TODO encoding
+ (ccl:encode-string-to-octets x))
+
+(defun octets-to-string (x) ;; TODO encoding
+ (ccl:decode-string-from-octets x))
(defun tag (x)
(let ((tags '((#x01 . :operation-attributes-tag)
@@ -102,14 +117,14 @@
(defun attribute-tag (attribute)
(cdr (assoc attribute '((:attributes-charset . :charset)
- (:attributes-natural-language . nil)
+ (:attributes-natural-language . :naturalLanguage)
(:printer-uri . :uri)
- (:requesting-user-name . nil)
- (:job-name . nil)
- (:ipp-attribute-fidelity . nil)
+ (:requesting-user-name . :nameWithoutLanguage)
+ (:job-name . :nameWithoutLanguage)
+ (:ipp-attribute-fidelity . :boolean)
(:document-name . nil)
(:document-format . nil)
- (:document-natural-language . nil)
+ (:document-natural-language . :naturalLanguage)
(:compression . nil)
(:job-k-octets . nil)
(:job-impressions . nil)
@@ -122,20 +137,56 @@
;;(attribute-name :attributes-charset)
-(defun write-group (group control-stream)
+(defun read-attribute ()
+ (let ((tag (read-octet)))
+ (if (member tag (mapcar 'tag ;; TODO optimize
+ '(:operation-attributes-tag
+ :job-attributes-tag
+ :end-of-attributes-tag
+ :printer-attributes-tag
+ :unsupported-attributes-tag)))
+ tag
+ `(,tag ;;(tag (attribute-tag k))
+ ,(octets-to-string (read-octets (read-ushort)))
+ , (case tag ;; TODO handle more cases
+ ((33 35)
+ (assert (= 4 (read-ushort)))
+ (read-dword))
+ (t (octets-to-string (read-octets (read-ushort)))))))))
+
+(defun read-groups ()
+ (let ((sentinel (tag :end-of-attributes-tag)) ;; TODO optimize
+ (x (read-octet)))
+ (loop
+ until (= sentinel x)
+ collect `(,x
+ ,@(loop
+ while (consp (setq x (read-attribute)))
+ collect x)))))
+
+#+nil
+(with-open-file (*input-stream* "response.dat" :element-type '(unsigned-byte 8))
+ (read-ipp 314))
+
+(defun write-group (group)
(destructuring-bind (group-id &rest plist) group
- (when plist ;; TODO exists not null v in plist
- (write-octet group-id control-stream)
+ (when (loop
+ for (k v) on plist by #'cddr
+ when v
+ do (return t))
+ (write-octet group-id)
(loop
for (k v) on plist by #'cddr
when v
do (let ((%k (string-to-octets (attribute-name k)))
(%v (string-to-octets v)))
- (write-octet (tag (attribute-tag k)) control-stream)
- (write-octet (length %k) control-stream)
- (write-octets %k control-stream)
- (write-ushort (length %v) control-stream)
- (write-octets %v control-stream))))))
+ ;; TODO additional value (when v is list)
+ (write-octet (tag (attribute-tag k)))
+ (write-ushort (length %k))
+ (write-octets %k)
+ (write-ushort (length %v))
+ (write-octets %v))))))
+
(defun operation-code (operation)
(cdr (assoc operation '((:print-job 1 0 #x0002)
@@ -181,33 +232,47 @@
;;(operation-code :print-job)
-(defun write-ipp (control-stream request-id operation groups data-stream)
+(defun write-ipp (data-file request-id operation groups)
(destructuring-bind (major minor code) (operation-code operation)
- (write-octet major control-stream)
- (write-octet minor control-stream)
- (write-ushort code control-stream)
- (write-dword request-id control-stream)
- (dolist (group groups)
- (write-group group control-stream))
- (write-octet (tag :end-of-attributes-tag) control-stream)
- (when data-stream
- (copy-stream data-stream control-stream))))
-
-(defun read-ipp (control-stream)
+ (write-octet major)
+ (write-octet minor)
+ (write-ushort code)
+ (write-dword request-id)
+ (mapc 'write-group groups)
+ (write-octet (tag :end-of-attributes-tag))
+ (when data-file
+ (with-open-file (*input-stream* data-file :element-type '(unsigned-byte 8))
+ (copy-stream)))))
+
+(defun read-ipp (request-id)
`(:ipp-response
- :major ,(read-octet control-stream)
- :minor ,(read-octet control-stream)
- :code ,(read-ushort control-stream)
- :request-id ,(read-dword control-stream)
- :groups ,(read-groups control-stream)))
+ :major ,(read-octet)
+ :minor ,(read-octet)
+ :code ,(read-ushort)
+ :request-id , (let ((x (read-dword)))
+ (assert (= x request-id))
+ x)
+ :groups ,(read-groups)))
-(defun ipp (control-stream request-id operation groups data-stream)
- (write-ipp control-stream request-id operation groups data-stream)
- (read-ipp control-stream))
+#+nil
+(with-open-file (*input-stream* "response.dat" :element-type '(unsigned-byte 8))
+ (read-ipp 314))
-(defun print-job (control-stream
+(defun ipp (request-file response-file data-file request-id operation groups)
+ (with-open-file (*output-stream* request-file
+ :element-type '(unsigned-byte 8)
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (write-ipp data-file request-id operation groups))
+ (funcall *ipp-client* request-file response-file)
+ (with-open-file (*input-stream* response-file :element-type '(unsigned-byte 8))
+ (read-ipp request-id)))
+
+(defun print-job (request-file
+ response-file
+ data-file
request-id
- data-stream
attributes-charset
attributes-natural-language
printer-uri
@@ -222,7 +287,9 @@
job-k-octets
job-impressions
job-media-sheets)
- (ipp control-stream
+ (ipp request-file
+ response-file
+ data-file
request-id
:print-job
`((,(tag :operation-attributes-tag)
@@ -239,7 +306,70 @@
:compression ,compression
:job-k-octets ,job-k-octets
:job-impressions ,job-impressions
- :job-media-sheets ,job-media-sheets))
- data-stream))
+ :job-media-sheets ,job-media-sheets))))
+
+(defpackage :ipp.wget
+ (:use :cl))
+
+(in-package :ipp.wget)
+
+(defun wget (url &key request-file response-file content-type)
+ (ccl:run-program
+ "wget"
+ `("-q"
+ ,@ (when request-file
+ `("--post-file" ,request-file))
+ ,@ (when response-file
+ `("-O" ,response-file))
+ ,@ (when content-type
+ `("--header" ,(format nil "Content-Type:~a" content-type)))
+ ,url)))
+
+;;(wget "http://localhost:631/printers/" :response-file "/tmp/a.html")
+;; wget|curl|lisp-http-client driver/backend
+
+(defun make-ipp-client (printer-uri)
+ (lambda (request-file response-file)
+ (wget printer-uri
+ :request-file request-file
+ :response-file response-file
+ :content-type "application/ipp")))
+
+#+nil
+(let* ((url "http://localhost:631/printers/Virtual_PDF_Printer")
+ (ipp::*ipp-client* (make-ipp-client url)))
+ (ipp::print-job "request2.dat" "response2.dat" "test.txt" 314 "utf-8" "en" url
+ :requesting-user-name "tomas"))
+
+(defpackage :ipp.curl
+ (:use :cl))
+
+(in-package :ipp.curl)
+
+(defun curl (url &key request-file response-file content-type)
+ (ccl:run-program
+ "curl"
+ `("-s"
+ ,@ (when request-file
+ `("-d" ,(format nil "@~a" request-file)))
+ ,@ (when response-file
+ `("-o" ,response-file))
+ ,@ (when content-type
+ `("-H" ,(format nil "Content-Type:~a" content-type)))
+ ,url)))
+
+;;(curl "http://localhost:631/printers/" :response-file "/tmp/a.html")
+;; curl|curl|lisp-http-client driver/backend
+
+(defun make-ipp-client (printer-uri)
+ (lambda (request-file response-file)
+ (curl printer-uri
+ :request-file request-file
+ :response-file response-file
+ :content-type "application/ipp")))
-;;(print-job control-stream 1 data-stream "utf-8" "en_GB" "ipp://localhost:631/printers/myprinter")
+#+nil ;; TODO fix Bad Request response
+(let* ((url "http://localhost:631/printers/Virtual_PDF_Printer")
+ (ipp::*ipp-client* (make-ipp-client url)))
+ (ipp::print-job "request2.dat" "response2.dat" "test.txt" 314 "utf-8" "en" url
+ :requesting-user-name "tomas"))
