aboutsummaryrefslogtreecommitdiff
path: root/gnu/packages/printers.scm
blob: f78923966cb8ce48ed86f3dd4db4801a1c4b28a9 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu packages printers)
  #:use-module (guix packages)
  #:use-module (guix git-download)
  #:use-module (guix build-system gnu)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (gnu packages libusb)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages qt))

;; This is a module for packages related to printer-like devices, but not
;; related to CUPS.

(define-public robocut
  (package
    (name "robocut")
    (version "1.0.11")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
             (url "https://github.com/Timmmm/robocut")
             (commit (string-append "v" version))))
       (file-name (git-file-name name version))
       (sha256
        (base32 "0dp9cssyik63yvkk35s51v94a873x751iqg93qzd8dpqkmz5z8gn"))))
    (build-system gnu-build-system)
    (arguments
     '(#:phases (modify-phases %standard-phases
                  (replace 'configure
                    (lambda* (#:key outputs #:allow-other-keys)
                      (let ((out (assoc-ref outputs "out")))
                        (substitute* "Robocut.pro"
                          (("/usr/")
                           (string-append out "/")))

                        (invoke "qmake"
                                (string-append "PREFIX=" out))
                        #t))))))
    (inputs
     `(("libusb" ,libusb)
       ("qt" ,qtbase-5)
       ("qtsvg" ,qtsvg)))
    (native-inputs
     `(("pkg-config" ,pkg-config)
       ("qmake" ,qtbase-5)))
    (synopsis "Graphical program to drive plotting cutters")
    (description
     "Robocut is a simple graphical program that allows you to cut graphics
with Graphtec and Sihouette plotting cutters using an SVG file as its input.")
    (home-page "http://robocut.org")
    (license license:gpl3+)))
()))) (unless (null? missing) ;; Note: What we suggest here is a list of module names (e.g., ;; "usb_storage"), not file names (e.g., "usb-storage.ko"). This is ;; OK because we have machinery that accepts both the hyphen and the ;; underscore version. (raise (make-compound-condition (formatted-message (G_ "you may need these modules \ in the initrd for ~a:~{ ~a~}") device missing) (condition (&fix-hint (hint (format #f (G_ "Try adding them to the @code{initrd-modules} field of your @code{operating-system} declaration, along these lines: @example (operating-system ;; @dots{} (initrd-modules (append (list~{ ~s~}) %base-initrd-modules))) @end example If you think this diagnostic is inaccurate, use the @option{--skip-checks} option of @command{guix system}.\n") missing)))) (condition (&error-location (location (source-properties->location location)))))))) ;;; ;;; Common device mappings. ;;; (define* (open-luks-device source targets #:key key-file) "Return a gexp that maps SOURCE to TARGET as a LUKS device, using 'cryptsetup'." (with-imported-modules (source-module-closure '((gnu build file-systems) (guix build utils))) ;; For mkdir-p (match targets ((target) #~(let ((source #$(if (uuid? source) (uuid-bytevector source) source)) (keyfile #$key-file)) ;; Create '/run/cryptsetup/' if it does not exist, as device locking ;; is mandatory for LUKS2. (mkdir-p "/run/cryptsetup/") ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the ;; whole world inside the initrd (for when we're in an initrd). ;; 'cryptsetup open' requires standard input to be a tty to allow ;; for interaction but shepherd sets standard input to /dev/null; ;; thus, explicitly request a tty. (let ((partition ;; Note: We cannot use the "UUID=source" syntax here ;; because 'cryptsetup' implements it by searching the ;; udev-populated /dev/disk/by-id directory but udev may ;; be unavailable at the time we run this. (if (bytevector? source) (or (let loop ((tries-left 10)) (and (positive? tries-left) (or (find-partition-by-luks-uuid source) ;; If the underlying partition is ;; not found, try again after ;; waiting a second, up to ten ;; times. FIXME: This should be ;; dealt with in a more robust way. (begin (sleep 1) (loop (- tries-left 1)))))) (error "LUKS partition not found" source)) source))) ;; We want to fallback to the password unlock if the keyfile fails. (or (and keyfile (zero? (system*/tty #$(file-append cryptsetup-static "/sbin/cryptsetup") "open" "--type" "luks" "--key-file" keyfile partition #$target))) (zero? (system*/tty #$(file-append cryptsetup-static "/sbin/cryptsetup") "open" "--type" "luks" partition #$target))))))))) (define (close-luks-device source targets) "Return a gexp that closes TARGET, a LUKS device." (match targets ((target) #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") "close" #$target))))) (define* (check-luks-device md #:key needed-for-boot? (initrd-modules '()) #:allow-other-keys #:rest rest) "Ensure the source of MD is valid." (let ((source (mapped-device-source md)) (location (mapped-device-location md))) (or (not (zero? (getuid))) (if (uuid? source) (match (find-partition-by-luks-uuid (uuid-bytevector source)) (#f (raise (make-compound-condition (formatted-message (G_ "no LUKS partition with UUID '~a'") (uuid->string source)) (condition (&error-location (location (source-properties->location (mapped-device-location md)))))))) ((? string? device) (check-device-initrd-modules device initrd-modules location))) (check-device-initrd-modules source initrd-modules location))))) (define luks-device-mapping ;; The type of LUKS mapped devices. (mapped-device-kind (open open-luks-device) (close close-luks-device) (check check-luks-device) (modules '((rnrs bytevectors) ;bytevector? ((gnu build file-systems) #:select (find-partition-by-luks-uuid system*/tty)))))) (define* (luks-device-mapping-with-options #:key key-file) "Return a luks-device-mapping object with open modified to pass the arguments into the open-luks-device procedure." (mapped-device-kind (inherit luks-device-mapping) (open (λ (source targets) (open-luks-device source targets #:key-file key-file))))) (define (open-raid-device sources targets) "Return a gexp that assembles SOURCES (a list of devices) to the RAID device TARGET (e.g., \"/dev/md0\"), using 'mdadm'." (match targets ((target) #~(let ((sources '#$sources) ;; XXX: We're not at the top level here. We could use a ;; non-top-level 'use-modules' form but that doesn't work when the ;; code is eval'd, like the Shepherd does. (every (@ (srfi srfi-1) every)) (format (@ (ice-9 format) format))) (let loop ((attempts 0)) (unless (every file-exists? sources) (when (> attempts 20) (error "RAID devices did not show up; bailing out" sources)) (format #t "waiting for RAID source devices~{ ~a~}...~%" sources) (sleep 1) (loop (+ 1 attempts)))) ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole ;; closure (80 MiB) in the initrd when a RAID device is needed for boot. (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm") "--assemble" #$target sources)))))) (define (close-raid-device sources targets) "Return a gexp that stops the RAID device TARGET." (match targets ((target) #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm") "--stop" #$target))))) (define raid-device-mapping ;; The type of RAID mapped devices. (mapped-device-kind (open open-raid-device) (close close-raid-device))) (define (open-lvm-device source targets) #~(and (zero? (system* #$(file-append lvm2-static "/sbin/lvm") "vgchange" "--activate" "ay" #$source)) ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here. (zero? (system* #$(file-append lvm2-static "/sbin/lvm") "vgscan" "--mknodes")) (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file)) '#$targets)))) (define (close-lvm-device source targets) #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm") "vgchange" "--activate" "n" #$source))) (define lvm-device-mapping (mapped-device-kind (open open-lvm-device) (close close-lvm-device) (modules '((srfi srfi-1))))) ;;; mapped-devices.scm ends here