commit e4d1c94177fea508d6388f1fbb3dcd69864389d5
Author: Tomas Hlavaty <tom@logand.com>
Date: Thu, 1 Aug 2013 00:05:44 +0200
initial sketch
Diffstat:
| A | .gitignore | | | 1 | + |
| A | cl-ipp.asd | | | 38 | ++++++++++++++++++++++++++++++++++++++ |
| A | ipp.lisp | | | 245 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
3 files changed, 284 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1 @@
+*~
diff --git a/cl-ipp.asd b/cl-ipp.asd
@@ -0,0 +1,38 @@
+;;; -*- lisp; -*-
+
+;;; Copyright (C) 2013 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :cl-ipp-system
+ (:use :asdf :cl))
+
+(in-package :cl-ipp-system)
+
+(asdf:defsystem :cl-ipp
+ :description "cl-ipp -- Internet Printing Protocol (IPP) for Common Lisp."
+ :version ""
+ :author "Tomas Hlavaty"
+ :maintainer "Tomas Hlavaty"
+ :licence "MIT"
+ :depends-on ()
+ :serial t
+ :components ((:file "ipp")))
diff --git a/ipp.lisp b/ipp.lisp
@@ -0,0 +1,245 @@
+;;; Copyright (C) 2013 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :ipp
+ (:use :cl))
+
+(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)
+ (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))
+ x))
+
+(defun make-data-stream (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))))))))
+
+(defun tag (x)
+ (let ((tags '((#x01 . :operation-attributes-tag)
+ (#x02 . :job-attributes-tag)
+ (#x03 . :end-of-attributes-tag)
+ (#x04 . :printer-attributes-tag)
+ (#x05 . :unsupported-attributes-tag)
+ (#x10 . :unsupported)
+ (#x12 . :unknown)
+ (#x13 . :no-value)
+ (#x21 . :integer)
+ (#x22 . :boolean)
+ (#x23 . :enum)
+ (#x30 . :octetString)
+ (#x31 . :dateTime)
+ (#x32 . :resolution)
+ (#x33 . :rangeOfInteger)
+ (#x35 . :textWithLanguage)
+ (#x36 . :nameWithLanguage)
+ (#x41 . :textWithoutLanguage)
+ (#x42 . :nameWithoutLanguage)
+ (#x44 . :keyword)
+ (#x45 . :uri)
+ (#x46 . :uriScheme)
+ (#x47 . :charset)
+ (#x48 . :naturalLanguage)
+ (#x49 . :mimeMediaType))))
+ (etypecase x
+ (integer (cdr (assoc x tags)))
+ (keyword (car (rassoc x tags))))))
+
+;;(tag #x45)
+;;(tag :uri)
+
+(defun attribute-tag (attribute)
+ (cdr (assoc attribute '((:attributes-charset . :charset)
+ (:attributes-natural-language . nil)
+ (:printer-uri . :uri)
+ (:requesting-user-name . nil)
+ (:job-name . nil)
+ (:ipp-attribute-fidelity . nil)
+ (:document-name . nil)
+ (:document-format . nil)
+ (:document-natural-language . nil)
+ (:compression . nil)
+ (:job-k-octets . nil)
+ (:job-impressions . nil)
+ (:job-media-sheets . nil)))))
+
+;;(attribute-tag :printer-uri)
+
+(defun attribute-name (attribute)
+ (format nil "~(~a~)" attribute))
+
+;;(attribute-name :attributes-charset)
+
+(defun write-group (group control-stream)
+ (destructuring-bind (group-id &rest plist) group
+ (when plist ;; TODO exists not null v in plist
+ (write-octet group-id control-stream)
+ (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))))))
+
+(defun operation-code (operation)
+ (cdr (assoc operation '((:print-job 1 0 #x0002)
+ (:validate-job 1 0 #x0004)
+ (:create-job 1 1 #x0005)
+ (:send-document 1 1 #x0006)
+ (:cancel-job 1 0 #x0008)
+ (:get-job-attributes 1 0 #x0009)
+ (:get-jobs 1 0 #x000a)
+ (:get-printer-attributes 1 0 #x000b)
+ (:hold-job 1 1 #x000c)
+ (:release-job 1 1 #x000d)
+ (:restart-job 1 1 #x000e)
+ (:pause-printer 1 0 #x0010)
+ (:resume-printer 1 0 #x0011)
+ (:purge-jobs 1 0 #x0012)
+ (:set-job-attributes 1 1 #x0014)
+ (:create-printer-subscription 1 2 #x0016)
+ (:create-job-subscription 1 2 #x0017)
+ (:get-subscription-attributes 1 2 #x0018)
+ (:get-subscriptions 1 2 #x0019)
+ (:renew-subscription 1 2 #x001a)
+ (:cancel-subscription 1 2 #x001b)
+ (:get-notifications 1 2 #x001c)
+ (:enable-printer 1 2 #x0022)
+ (:disable-printer 1 2 #x0023)
+ (:cups-get-default 1 0 #x4001)
+ (:cups-get-printers 1 0 #x4002)
+ (:cups-add-modify-printer 1 0 #x4003)
+ (:cups-delete-printer 1 0 #x4004)
+ (:cups-get-classes 1 0 #x4005)
+ (:cups-add-modify-class 1 0 #x4006)
+ (:cups-delete-class 1 0 #x4007)
+ (:cups-accept-jobs 1 0 #x4008)
+ (:cups-reject-jobs 1 0 #x4009)
+ (:cups-set-default 1 0 #x400a)
+ (:cups-get-devices 1 1 #x400b)
+ (:cups-get-ppds 1 1 #x400c)
+ (:cups-move-job 1 1 #x400d)
+ (:cups-authenticate-job 1 2 #x400e)
+ (:cups-get-ppd 1 3 #x400f)
+ (:cups-get-document 1 4 #x4027)))))
+
+;;(operation-code :print-job)
+
+(defun write-ipp (control-stream request-id operation groups data-stream)
+ (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)
+ `(: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)))
+
+(defun ipp (control-stream request-id operation groups data-stream)
+ (write-ipp control-stream request-id operation groups data-stream)
+ (read-ipp control-stream))
+
+(defun print-job (control-stream
+ request-id
+ data-stream
+ attributes-charset
+ attributes-natural-language
+ printer-uri
+ &key
+ requesting-user-name
+ job-name
+ ipp-attribute-fidelity
+ document-name
+ document-format
+ document-natural-language
+ compression
+ job-k-octets
+ job-impressions
+ job-media-sheets)
+ (ipp control-stream
+ request-id
+ :print-job
+ `((,(tag :operation-attributes-tag)
+ :attributes-charset ,attributes-charset
+ :attributes-natural-language ,attributes-natural-language
+ :printer-uri ,printer-uri)
+ (,(tag :job-attributes-tag)
+ :requesting-user-name ,requesting-user-name
+ :job-name ,job-name
+ :ipp-attribute-fidelity ,ipp-attribute-fidelity
+ :document-name ,document-name
+ :document-format ,document-format
+ :document-natural-language ,document-natural-language
+ :compression ,compression
+ :job-k-octets ,job-k-octets
+ :job-impressions ,job-impressions
+ :job-media-sheets ,job-media-sheets))
+ data-stream))
+
+;;(print-job control-stream 1 data-stream "utf-8" "en_GB" "ipp://localhost:631/printers/myprinter")
