ipp.lisp (33877B)
1 ;;; Copyright (C) 2013 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :ipp 24 (:use :cl) 25 (:export :cancel-job 26 :create-job 27 :curl-client 28 :disable-printer 29 :enable-printer 30 :get-job-attributes 31 :get-jobs 32 :get-printer-attributes 33 :hold-job 34 :list-printers 35 :make-job 36 :make-printer 37 :pause-printer 38 :print-job 39 :purge-jobs 40 :release-job 41 :restart-job 42 :resume-printer 43 :validate-job 44 :wget-client)) 45 46 (in-package :ipp) 47 48 (defun string-to-octets (x) ;; TODO encoding 49 #+ccl(ccl:encode-string-to-octets x) 50 #-ccl(error "TODO port IPP::STRING-TO-OCTETS")) 51 52 (defun octets-to-string (x) ;; TODO encoding 53 #+ccl(ccl:decode-string-from-octets x) 54 #-ccl(error "TODO port IPP::OCTETS-TO-STRING")) 55 56 (defun tag (x) 57 (let ((tags '((#x01 . :operation-attributes-tag) 58 (#x02 . :job-attributes-tag) 59 (#x03 . :end-of-attributes-tag) 60 (#x04 . :printer-attributes-tag) 61 (#x05 . :unsupported-attributes-tag) 62 (#x10 . :unsupported) 63 (#x12 . :unknown) 64 (#x13 . :no-value) 65 (#x21 . :integer) 66 (#x22 . :boolean) 67 (#x23 . :enum) 68 (#x30 . :octetString) 69 (#x31 . :dateTime) 70 (#x32 . :resolution) 71 (#x33 . :rangeOfInteger) 72 (#x35 . :textWithLanguage) 73 (#x36 . :nameWithLanguage) 74 (#x41 . :textWithoutLanguage) 75 (#x42 . :nameWithoutLanguage) 76 (#x44 . :keyword) 77 (#x45 . :uri) 78 (#x46 . :uriScheme) 79 (#x47 . :charset) 80 (#x48 . :naturalLanguage) 81 (#x49 . :mimeMediaType)))) 82 (etypecase x 83 (integer (cdr (assoc x tags))) 84 (keyword (car (rassoc x tags)))))) 85 86 ;;(tag #x45) 87 ;;(tag :uri) 88 89 ;; TODO how to handle attributes, as keyword|string? error|ok 90 (let ((attributes '((:attributes-charset . :charset) 91 (:attributes-natural-language . :naturalLanguage) 92 (:printer-uri . :uri) 93 (:requesting-user-name . :nameWithoutLanguage) 94 (:job-name . :nameWithoutLanguage) 95 (:ipp-attribute-fidelity . :boolean) 96 (:document-name . nil) 97 (:document-format . nil) 98 (:document-natural-language . :naturalLanguage) 99 (:compression . nil) 100 (:job-k-octets . nil) 101 (:job-impressions . nil) 102 (:job-media-sheets . nil) 103 (:copies . :integer) 104 (:sides . :keyword) 105 (:job-uri . :uri) 106 (:job-id . :integer) 107 (:job-state . nil) 108 (:job-state-reasons . nil) 109 (:limit . :integer) 110 (:requested-attributes . :keyword) 111 (:status-message . :textWithoutLanguage) 112 (:message . :textWithoutLanguage) ;; TODO really? 113 (:marker-change-time . nil) 114 (:printer-current-time . nil) 115 (:printer-dns-sd-name . nil) 116 (:printer-is-accepting-jobs . nil) 117 (:printer-error-policy . nil) 118 (:printer-error-policy-supported . nil) 119 (:job-sheets-default . nil) 120 (:all . nil) 121 (:which-jobs . nil) 122 (:completed . nil) 123 (:not-completed . nil) 124 (:my-jobs . nil) 125 (:printer-icons . nil) 126 (:printer-is-shared . nil) 127 (:printer-more-info . nil) 128 (:printer-op-policy . nil) 129 (:printer-state . nil) 130 (:printer-state-change-time . nil) 131 (:printer-state-message . nil) 132 (:printer-type . nil) 133 (:printer-up-time . nil) 134 (:printer-uri-supported . nil) 135 (:queued-job-count . nil) 136 (:uri-authentication-supported . nil) 137 (:requesting-user-name . nil) 138 (:uri-security-supported . nil) 139 (:printer-name . nil) 140 (:printer-location . nil) 141 (:printer-info . nil) 142 (:printer-uuid . nil) 143 (:job-quota-period . nil) 144 (:printer-state-reasons . nil) 145 (:job-k-limit . nil) 146 (:job-page-limit . nil) 147 (:job-sheets-default . nil) 148 (:device-uri . nil)))) 149 150 (defun attribute-tag (attribute) 151 (or (cdr (assoc attribute attributes)) 152 (error "unknown IPP type of attribute ~s" attribute))) 153 154 (let ((x (loop 155 for (k) in attributes 156 collect (cons (string-downcase (symbol-name k)) k)))) 157 (defun attribute-keyword (string) 158 (cdr (assoc string x :test #'equal)) 159 #+nil 160 (or (cdr (assoc string x :test #'equal)) 161 (error "unknown IPP attribute ~s" string))))) 162 163 #+nil 164 (with-open-file (s "response2.dat" :element-type '(unsigned-byte 8)) 165 (read-ipp (rw:byte-reader s) 314)) 166 167 ;;(attribute-tag :printer-uri) 168 ;;(attribute-keyword "printer-uri") 169 170 (defun attribute-name (attribute) 171 (format nil "~(~a~)" attribute)) 172 173 ;;(attribute-name :attributes-charset) 174 175 (defun read-text (reader) 176 (let ((n (rw:next-u16 reader))) 177 (when (plusp n) 178 (octets-to-string (rw:next-octets reader n))))) 179 180 (defun read-value (reader tag) ;; TODO signed integers! 181 (ecase tag 182 (:no-value 183 (assert (= 0 (rw:next-u16 reader)))) 184 ((:integer :enum) 185 (assert (= 4 (rw:next-u16 reader))) 186 (rw:next-u32 reader)) 187 (:boolean 188 (assert (= 1 (rw:next-u16 reader))) 189 (not (zerop (rw:next-u8 reader)))) 190 (:octetString 191 (let ((n (rw:next-u16 reader))) 192 (when (plusp n) 193 (let ((x (rw:next-octets reader n))) 194 (assert x) 195 x)))) 196 (:dateTime 197 (assert (= 11 (rw:next-u16 reader))) 198 (list tag 199 (rw:next-u16 reader) 200 (rw:next-u8 reader) 201 (rw:next-u8 reader) 202 (rw:next-u8 reader) 203 (rw:next-u8 reader) 204 (rw:next-u8 reader) 205 (rw:next-u8 reader) 206 (rw:next-u8 reader) 207 (rw:next-u8 reader) 208 (rw:next-u8 reader))) 209 (:resolution 210 (assert (= 9 (rw:next-u16 reader))) 211 (list tag (rw:next-u32 reader) (rw:next-u32 reader) (rw:next-u8 reader))) 212 (:rangeOfInteger 213 (assert (= 8 (rw:next-u16 reader))) 214 (list tag (rw:next-u32 reader) (rw:next-u32 reader))) 215 ((:textWithLanguage 216 :nameWithLanguage 217 :textWithoutLanguage 218 :nameWithoutLanguage 219 :keyword 220 :uri 221 :uriScheme 222 :charset 223 :naturalLanguage 224 :mimeMediaType) 225 (read-text reader)))) 226 227 (defun group-reader (reader) 228 (let (done tag group-tag attributes attribute (r (rw:peek-reader reader))) 229 (lambda () 230 (unless done 231 (block found 232 (flet ((yield () 233 ;;(print (list :@@@ done tag group-tag attributes attribute)) 234 (let ((z (when (and group-tag (or attributes attribute)) 235 (when attribute 236 (push attribute attributes)) 237 (cons group-tag (nreverse attributes))))) 238 (setq group-tag tag attributes nil attribute nil) 239 (return-from found z)))) 240 (loop 241 (setq tag (tag (rw:next-u8 r))) 242 ;;(print (list :!!! tag)) 243 (when (eq :end-of-attributes-tag tag) 244 (setq done t) 245 (yield)) 246 (if (member tag '(:operation-attributes-tag 247 :job-attributes-tag 248 ;;:end-of-attributes-tag 249 :printer-attributes-tag 250 :unsupported-attributes-tag)) 251 (if (and group-tag (or attributes attribute)) 252 (yield) 253 (setq group-tag tag)) 254 (let ((k (read-text r))) 255 (if k 256 (progn 257 (when attribute 258 (push attribute attributes)) 259 (setq attribute (list tag 260 (or (attribute-keyword k) k) 261 (read-value r tag)))) 262 (setq attribute (nconc 263 attribute 264 (list (read-value r tag))))) 265 #+nil(print (list :%%% attribute))))))))))) 266 267 #+nil 268 (with-open-file (s "response.dat" :element-type '(unsigned-byte 8)) 269 (read-ipp (rw:byte-reader s) 314)) 270 271 #+nil 272 (with-open-file (s "response2.dat" :element-type '(unsigned-byte 8)) 273 (read-ipp (rw:byte-reader s) 314)) 274 275 (defun write-text (writer x) 276 (let ((y (string-to-octets x))) 277 (rw:write-u16 writer (length y)) 278 (rw:write-octets writer y))) 279 280 (defun write-value (writer tag x) ;; TODO signed integers! 281 (ecase tag 282 (:no-value 283 (rw:write-u16 writer 0)) 284 ((:integer :enum) 285 (rw:write-u16 writer 4) 286 (rw:write-u32 writer x)) 287 (:boolean 288 (rw:write-u16 writer 1) 289 (rw:write-u8 writer (if x 1 0))) 290 (:octetString 291 (rw:write-u16 writer (length x)) 292 (rw:write-octets writer x)) 293 (:dateTime 294 (rw:write-u16 writer 11) 295 (destructuring-bind (tag2 a b c d e f g h i j) x 296 (assert (eq tag tag2)) 297 (rw:write-u16 writer a) 298 (rw:write-u8 writer b) 299 (rw:write-u8 writer c) 300 (rw:write-u8 writer d) 301 (rw:write-u8 writer e) 302 (rw:write-u8 writer f) 303 (rw:write-u8 writer g) 304 (rw:write-u8 writer h) 305 (rw:write-u8 writer i) 306 (rw:write-u8 writer j))) 307 (:resolution 308 (rw:write-u16 writer 9) 309 (destructuring-bind (tag2 a b c) x 310 (assert (eq tag tag2)) 311 (rw:write-u32 writer a) 312 (rw:write-u32 writer b) 313 (rw:write-u8 writer c))) 314 (:rangeOfInteger 315 (rw:write-u16 writer 8) 316 (destructuring-bind (tag2 a b) x 317 (assert (eq tag tag2)) 318 (rw:write-u32 writer a) 319 (rw:write-u32 writer b))) 320 ((:textWithLanguage 321 :nameWithLanguage 322 :textWithoutLanguage 323 :nameWithoutLanguage 324 :keyword 325 :uri 326 :uriScheme 327 :charset 328 :naturalLanguage 329 :mimeMediaType) 330 (write-text writer x)))) 331 332 (defun write-group (writer group) 333 (destructuring-bind (group-id &rest plist) group 334 (when (loop 335 for (v) on (cdr plist) by #'cddr 336 when v 337 do (return t)) 338 (rw:write-u8 writer group-id) 339 (loop 340 for (k v) on plist by #'cddr 341 when v 342 do (let* ((tag (attribute-tag k)) 343 (n (tag tag))) 344 (rw:write-u8 writer n) 345 (write-text writer (attribute-name k)) 346 (if (atom v) 347 (write-value writer tag v) 348 (progn 349 (write-value writer tag (attribute-name (car v))) 350 (dolist (v (cdr v)) 351 (rw:write-u8 writer n) 352 (rw:write-u16 writer 0) 353 (write-value writer tag (attribute-name v)))))))))) 354 355 (defun operation-code (operation) 356 (cdr (assoc operation '((:print-job 1 0 #x0002) 357 (:validate-job 1 0 #x0004) 358 (:create-job 1 1 #x0005) 359 (:send-document 1 1 #x0006) 360 (:cancel-job 1 0 #x0008) 361 (:get-job-attributes 1 0 #x0009) 362 (:get-jobs 1 0 #x000a) 363 (:get-printer-attributes 1 0 #x000b) 364 (:hold-job 1 1 #x000c) 365 (:release-job 1 1 #x000d) 366 (:restart-job 1 1 #x000e) 367 (:pause-printer 1 0 #x0010) 368 (:resume-printer 1 0 #x0011) 369 (:purge-jobs 1 0 #x0012) 370 (:set-job-attributes 1 1 #x0014) 371 (:create-printer-subscription 1 2 #x0016) 372 (:create-job-subscription 1 2 #x0017) 373 (:get-subscription-attributes 1 2 #x0018) 374 (:get-subscriptions 1 2 #x0019) 375 (:renew-subscription 1 2 #x001a) 376 (:cancel-subscription 1 2 #x001b) 377 (:get-notifications 1 2 #x001c) 378 (:enable-printer 1 2 #x0022) 379 (:disable-printer 1 2 #x0023) 380 (:cups-get-default 1 0 #x4001) 381 (:cups-get-printers 1 0 #x4002) 382 (:cups-add-modify-printer 1 0 #x4003) 383 (:cups-delete-printer 1 0 #x4004) 384 (:cups-get-classes 1 0 #x4005) 385 (:cups-add-modify-class 1 0 #x4006) 386 (:cups-delete-class 1 0 #x4007) 387 (:cups-accept-jobs 1 0 #x4008) 388 (:cups-reject-jobs 1 0 #x4009) 389 (:cups-set-default 1 0 #x400a) 390 (:cups-get-devices 1 1 #x400b) 391 (:cups-get-ppds 1 1 #x400c) 392 (:cups-move-job 1 1 #x400d) 393 (:cups-authenticate-job 1 2 #x400e) 394 (:cups-get-ppd 1 3 #x400f) 395 (:cups-get-document 1 4 #x4027))))) 396 397 ;;(operation-code :print-job) 398 399 (defun write-ipp (writer data-file request-id operation groups) 400 (destructuring-bind (major minor code) (operation-code operation) 401 (rw:write-u8 writer major) 402 (rw:write-u8 writer minor) 403 (rw:write-u16 writer code) 404 (rw:write-u32 writer request-id) 405 (dolist (i groups) 406 (write-group writer i)) 407 (rw:write-u8 writer (tag :end-of-attributes-tag)) 408 (when data-file 409 (with-open-file (s data-file :element-type '(unsigned-byte 8)) 410 (rw:copy (rw:byte-reader s) writer))))) 411 412 (defun read-ipp (reader request-id) 413 `(:ipp-response 414 :major ,(rw:next-u8 reader) 415 :minor ,(rw:next-u8 reader) 416 :code ,(rw:next-u16 reader) 417 :request-id , (let ((x (rw:next-u32 reader))) 418 (assert (= x request-id)) 419 x) 420 :groups ,(rw:till (rw:peek-reader (group-reader reader))))) 421 422 #+nil 423 (with-open-file (s "response.dat" :element-type '(unsigned-byte 8)) 424 (read-ipp (rw:byte-reader s) 314)) 425 426 (defun ipp (ipp-client printer-uri request-file response-file 427 data-file request-id operation groups) 428 (with-open-file (s request-file 429 :element-type '(unsigned-byte 8) 430 :direction :output 431 :if-exists :supersede 432 :if-does-not-exist :create) 433 (write-ipp (rw:byte-writer s) data-file request-id operation groups)) 434 (funcall ipp-client "application/ipp" printer-uri request-file response-file) 435 (with-open-file (s response-file :element-type '(unsigned-byte 8)) 436 (read-ipp (rw:byte-reader s) request-id))) 437 438 (defun user-name () 439 (car (last (pathname-directory (user-homedir-pathname))))) 440 441 (defun get-printer-attributes (printer &key requested-attributes 442 document-format limit) 443 (funcall printer :get-printer-attributes 444 :requested-attributes requested-attributes 445 :document-format document-format 446 :limit limit)) 447 448 (defun pause-printer (printer) 449 (funcall printer :pause-printer)) 450 451 (defun resume-printer (printer) 452 (funcall printer :resume-printer)) 453 454 (defun enable-printer (printer) 455 (funcall printer :enable-printer)) 456 457 (defun disable-printer (printer) 458 (funcall printer :disable-printer)) 459 460 (defun create-job (printer) 461 (funcall printer :create-job)) 462 463 (defun purge-jobs (printer) 464 (funcall printer :purge-jobs)) 465 466 (defun get-jobs (printer &key requested-attributes which-jobs completed 467 not-completed my-jobs limit) 468 (funcall printer :get-jobs 469 :requested-attributes requested-attributes 470 :which-jobs which-jobs 471 :completed completed 472 :not-completed not-completed 473 :my-jobs my-jobs 474 :limit limit)) 475 476 (defun print-job (printer data-file &key job-name (ipp-attribute-fidelity t) 477 document-name document-format 478 document-natural-language compression 479 job-k-octets job-impressions 480 job-media-sheets copies sides) 481 (funcall printer :print-job data-file 482 :job-name job-name 483 :ipp-attribute-fidelity ipp-attribute-fidelity 484 :document-name document-name 485 :document-format document-format 486 :document-natural-language document-natural-language 487 :compression compression 488 :job-k-octets job-k-octets 489 :job-impressions job-impressions 490 :job-media-sheets job-media-sheets 491 :copies copies 492 :sides sides)) 493 494 (defun validate-job (printer &key job-name (ipp-attribute-fidelity t) 495 document-name document-format 496 document-natural-language compression 497 job-k-octets job-impressions 498 job-media-sheets copies sides) 499 (funcall printer :validate-job 500 :job-name job-name 501 :ipp-attribute-fidelity ipp-attribute-fidelity 502 :document-name document-name 503 :document-format document-format 504 :document-natural-language document-natural-language 505 :compression compression 506 :job-k-octets job-k-octets 507 :job-impressions job-impressions 508 :job-media-sheets job-media-sheets 509 :copies copies 510 :sides sides)) 511 512 (defun make-printer (ipp-client 513 printer-uri 514 request-file 515 response-file 516 request-id 517 &key 518 (attributes-charset "utf-8") 519 (attributes-natural-language "en") 520 (requesting-user-name (user-name))) 521 (lambda (msg &rest args) 522 (flet ((%ipp (&optional oa ja data-file) 523 (ipp ipp-client printer-uri request-file response-file data-file 524 request-id msg 525 `((,(tag :operation-attributes-tag) 526 :attributes-charset ,attributes-charset 527 :attributes-natural-language ,attributes-natural-language 528 :requesting-user-name ,requesting-user-name 529 :printer-uri ,printer-uri 530 ,@oa) 531 (,(tag :job-attributes-tag) ,@ja))))) 532 (ecase msg 533 (:get-printer-attributes 534 (destructuring-bind (&key requested-attributes document-format 535 limit) args 536 #+nil ;; TODO sort 537 (assert (let ((x '(:job-template :printer-description :all))) 538 (equal x (union x requested-attributes)))) 539 (%ipp (list :requested-attributes requested-attributes 540 :document-format document-format 541 :limit limit)))) 542 ((:pause-printer :resume-printer :enable-printer :disable-printer 543 :create-job :purge-jobs) 544 ;; TODO check spec for :enable-printer and :disable-printer 545 (destructuring-bind () args 546 (%ipp))) 547 (:get-jobs 548 (destructuring-bind (&key requested-attributes which-jobs completed 549 not-completed my-jobs limit) args 550 (%ipp (list :requested-attributes requested-attributes 551 :which-jobs which-jobs 552 :completed completed 553 :not-completed not-completed 554 :my-jobs my-jobs 555 :limit limit)))) 556 (:print-job 557 (destructuring-bind (data-file 558 &key job-name (ipp-attribute-fidelity t) 559 document-name document-format 560 document-natural-language compression 561 job-k-octets job-impressions 562 job-media-sheets copies sides) args 563 (%ipp nil 564 (list :job-name job-name 565 :ipp-attribute-fidelity ipp-attribute-fidelity 566 :document-name document-name 567 :document-format document-format 568 :document-natural-language document-natural-language 569 :compression compression 570 :job-k-octets job-k-octets 571 :job-impressions job-impressions 572 :job-media-sheets job-media-sheets 573 :copies copies 574 :sides sides) 575 data-file))) 576 (:validate-job 577 (destructuring-bind (&key job-name (ipp-attribute-fidelity t) 578 document-name document-format 579 document-natural-language compression 580 job-k-octets job-impressions 581 job-media-sheets copies sides) args 582 (%ipp nil 583 (list :job-name job-name 584 :ipp-attribute-fidelity ipp-attribute-fidelity 585 :document-name document-name 586 :document-format document-format 587 :document-natural-language document-natural-language 588 :compression compression 589 :job-k-octets job-k-octets 590 :job-impressions job-impressions 591 :job-media-sheets job-media-sheets 592 :copies copies 593 :sides sides)))))))) 594 595 (defun cancel-job (job &optional message) 596 (funcall job :cancel-job message)) 597 598 (defun get-job-attributes (job &key requested-attributes limit) 599 (funcall job :get-job-attributes 600 :requested-attributes requested-attributes 601 :limit limit)) 602 603 (defun hold-job (job &optional job-hold-until) 604 (funcall job :hold-job job-hold-until)) 605 606 (defun restart-job (job &optional job-hold-until) 607 (funcall job :restart-job job-hold-until)) 608 609 (defun release-job (job) 610 (funcall job :release-job)) 611 612 (defun send-document (job data-file last-document 613 &key (ipp-attribute-fidelity t) 614 document-name document-format 615 document-natural-language compression 616 job-k-octets job-impressions 617 job-media-sheets copies sides) 618 (funcall job :send-document data-file last-document 619 :ipp-attribute-fidelity ipp-attribute-fidelity 620 :document-name document-name 621 :document-format document-format 622 :document-natural-language document-natural-language 623 :compression compression 624 :job-k-octets job-k-octets 625 :job-impressions job-impressions 626 :job-media-sheets job-media-sheets 627 :copies copies 628 :sides sides)) 629 630 (defun make-job (ipp-client 631 printer-uri 632 request-file 633 response-file 634 request-id 635 job-id 636 &key 637 (attributes-charset "utf-8") 638 (attributes-natural-language "en") 639 (requesting-user-name (user-name))) 640 (lambda (msg &rest args) 641 (flet ((%ipp (&optional oa ja data-file) 642 (ipp ipp-client printer-uri request-file response-file data-file 643 request-id msg 644 `((,(tag :operation-attributes-tag) 645 :attributes-charset ,attributes-charset 646 :attributes-natural-language ,attributes-natural-language 647 :requesting-user-name ,requesting-user-name 648 :printer-uri ,printer-uri 649 :job-id ,job-id 650 ,@oa) 651 (,(tag :job-attributes-tag) ,@ja))))) 652 (ecase msg 653 (:cancel-job 654 (destructuring-bind (&optional message) args 655 (%ipp (list :message message)))) 656 (:get-job-attributes 657 (destructuring-bind (&key requested-attributes limit) args 658 #+nil ;; TODO sort 659 (assert (let ((x '(:job-template :job-description :all))) 660 (equal x (union x requested-attributes)))) 661 (%ipp (list :requested-attributes requested-attributes 662 :limit limit)))) 663 ((:hold-job :restart-job) 664 (destructuring-bind (&optional job-hold-until) args 665 (%ipp (list :job-hold-until job-hold-until)))) 666 (:release-job 667 (destructuring-bind () args 668 (%ipp))) 669 (:send-document 670 (destructuring-bind (data-file 671 last-document 672 &key (ipp-attribute-fidelity t) 673 document-name document-format 674 document-natural-language compression 675 job-k-octets job-impressions 676 job-media-sheets copies sides) args 677 (%ipp (list :last-document last-document) 678 (list :ipp-attribute-fidelity ipp-attribute-fidelity 679 :document-name document-name 680 :document-format document-format 681 :document-natural-language document-natural-language 682 :compression compression 683 :job-k-octets job-k-octets 684 :job-impressions job-impressions 685 :job-media-sheets job-media-sheets 686 :copies copies 687 :sides sides) 688 data-file))))))) 689 690 ;; TODO ? set-job-attributes 691 ;; TODO ? create-printer-subscription 692 ;; TODO ? create-job-subscription 693 ;; TODO ? get-subscription-attributes 694 ;; TODO ? get-subscriptions 695 ;; TODO ? renew-subscription 696 ;; TODO ? cancel-subscription 697 ;; TODO ? get-notifications 698 ;; TODO cups-get-default 699 700 (defun cups-get-default (ipp-client 701 printer-uri 702 request-file 703 response-file 704 request-id 705 &key 706 (attributes-charset "utf-8") 707 (attributes-natural-language "en")) 708 (ipp ipp-client 709 printer-uri 710 request-file 711 response-file 712 nil 713 request-id 714 :cups-get-default 715 `((,(tag :operation-attributes-tag) 716 :attributes-charset ,attributes-charset 717 :attributes-natural-language ,attributes-natural-language 718 :printer-uri ,printer-uri)))) 719 720 (defun cups-get-printers (ipp-client 721 printer-uri 722 request-file 723 response-file 724 request-id 725 &key 726 (attributes-charset "utf-8") 727 (attributes-natural-language "en")) 728 (ipp ipp-client 729 printer-uri 730 request-file 731 response-file 732 nil 733 request-id 734 :cups-get-printers 735 `((,(tag :operation-attributes-tag) 736 :attributes-charset ,attributes-charset 737 :attributes-natural-language ,attributes-natural-language 738 :printer-uri ,printer-uri)))) 739 740 ;; TODO cups-add-modify-printer 741 ;; TODO cups-delete-printer 742 ;; TODO cups-get-classes 743 ;; TODO cups-add-modify-class 744 ;; TODO cups-delete-class 745 ;; TODO cups-accept-jobs 746 ;; TODO cups-reject-jobs 747 ;; TODO cups-set-default 748 ;; TODO cups-get-devices 749 ;; TODO cups-get-ppds 750 ;; TODO cups-move-job 751 ;; TODO cups-authenticate-job 752 ;; TODO cups-get-ppd 753 ;; TODO cups-get-document 754 755 (defun printer-search-reader (reader) 756 (let* ((k '#.(coerce "\"/printers/" 'list)) ;; TODO #\' as attribute quote 757 (n (length k)) 758 (s (rw:search-reader reader k))) 759 (lambda () 760 (block found 761 (loop 762 (multiple-value-bind (i all) (funcall s) 763 (unless i 764 (return-from found nil)) 765 (let ((z (rw:till 766 (rw:skip 767 (rw:peek-reader (rw:reader all)) (+ i n)) '(#\")))) 768 (when (and z (char/= #\? (car z))) 769 (return-from found (coerce z 'string)))))))))) 770 771 #+nil 772 (with-open-file (s "printers.html") 773 (rw:till (rw:peek-reader (printer-search-reader (rw:char-reader s))))) 774 775 (defun list-printers (ipp-client printer-uri response-file) 776 (funcall ipp-client nil printer-uri nil response-file) 777 (with-open-file (s response-file) 778 (rw:till (rw:peek-reader 779 (printer-search-reader (rw:char-reader s)))))) 780 781 (defun wget-client (content-type printer-uri request-file response-file) 782 (rw.net:wget printer-uri 783 :request-file request-file 784 :response-file response-file 785 :content-type content-type)) 786 787 ;;(ipp:list-printers 'wget-client "http://localhost:631/printers/" "printers.html") 788 789 (defun curl-client (content-type printer-uri request-file response-file) 790 (rw.net:curl printer-uri 791 :request-file request-file 792 :response-file response-file 793 :content-type content-type)) 794 795 (defpackage :ipp.test 796 (:use :cl)) 797 798 (in-package :ipp.test) 799 800 #+nil 801 (ipp::cups-get-default 'ipp:wget-client 802 "http://localhost:631/printers/Virtual_PDF_Printer" 803 "request2.dat" 804 "response2.dat" 805 314) 806 807 #+nil 808 (ipp::cups-get-printers 'ipp:wget-client 809 "http://localhost:631/printers/Virtual_PDF_Printer" 810 "request2.dat" 811 "response2.dat" 812 314) 813 814 ;;(ipp:list-printers 'ipp:wget-client "http://localhost:631/printers/" "printers.html") 815 816 #+nil 817 (let ((p (ipp:make-printer 818 'ipp:wget-client 819 "http://localhost:631/printers/Virtual_PDF_Printer" 820 "request2.dat" 821 "response2.dat" 822 314))) 823 ;;(ipp:get-printer-attributes p) 824 ;;(ipp:get-printer-attributes p :limit 2) 825 ;;(ipp:get-printer-attributes p requested-attributes '(:all)) 826 ;;TODO (ipp:get-printer-attributes p requested-attributes '(:printer-description)) 827 ;;TODO (ipp:get-printer-attributes p requested-attributes '(:job-template)) 828 ;;TODO (ipp:get-printer-attributes p requested-attributes '(:job-template :printer-description)) 829 ;;TODO login (ipp:pause-printer p) 830 ;;TODO login (ipp:resume-printer p) 831 ;;TODO login (ipp:enable-printer p) 832 ;;TODO login (ipp:disable-printer p) 833 ;;(ipp:create-job p) 834 ;;TODO login (ipp:purge-jobs p) 835 ;;(ipp:get-jobs p) 836 ;;(ipp:get-jobs p :limit 2) 837 ;;(ipp:get-jobs p :requested-attributes '(:job-id)) 838 ;;(ipp:get-jobs p :requested-attributes '(:job-description)) 839 ;;(ipp:get-jobs p :requested-attributes '(:job-id :job-description)) 840 ;;(ipp:get-jobs p :requested-attributes '(:all)) 841 (ipp:print-job p "/home/tomas/git/cl-ipp/test.txt" :ipp-attribute-fidelity nil :copies 2 :sides "two-sided-long-edge") ;; TODO create job object? 842 ;;(ipp:validate-job p :ipp-attribute-fidelity nil :copies 2 :sides "two-sided-long-edge") 843 ) 844 845 #+nil 846 (let ((x (ipp:make-job 847 'ipp:wget-client 848 "http://localhost:631/printers/Virtual_PDF_Printer" 849 "request2.dat" 850 "response2.dat" 851 314 852 100 #+nil"http://localhost:631/jobs/100"))) 853 (ipp:cancel-job x "cancelling from cl-ipp") 854 ;;(ipp:get-job-attributes x) 855 ;;(ipp:hold-job x) 856 ;;(ipp:restart-job x) 857 ;;(ipp:release-job x) 858 ) 859 860 #+nil ;; TODO 861 (let* ((p (ipp:make-printer 862 'ipp:wget-client 863 "http://localhost:631/printers/Virtual_PDF_Printer" 864 "request2.dat" 865 "response2.dat" 866 314)) 867 (j (ipp:create-job p))) 868 (ipp:send-document j "test.txt" :ipp-attribute-fidelity nil :copies 2 :sides "two-sided-long-edge"))