Initial commit.

* guix.scm: New file.
* zabbix.scm: New file.
* zabbix_guix: New file.

3 files changed, 246 insertions, 0 deletions

diff --git a/guix.scm b/guix.scm
new file mode 100644
index 0000000..9fddd7f
--- /dev/null
+++ b/guix.scm
@@ -0,0 +1,104 @@
+;; guix.scm --- Guix package for Zabbix-Guix
+;; Copyright © 2019 Oleg Pykhalov <go.wigust@gmail.com>
+;; Released under the GNU GPLv3 or any later version.
+
+(use-modules ((guix licenses) #:prefix license:)
+             (guix build-system guile)
+             (guix build utils)
+             (guix packages)
+             (guix gexp)
+             (guix git-download)
+             (ice-9 popen)
+             (ice-9 rdelim)
+             (gnu packages bash)
+             (gnu packages guile)
+             (gnu packages package-management))
+
+(define %source-dir (dirname (current-filename)))
+
+(define (git . args)
+  "Execute 'git ARGS ...' command and return its output without trailing
+newspace."
+  (with-directory-excursion %source-dir
+    (let* ((port   (apply open-pipe* OPEN_READ "git" args))
+           (output (read-string port)))
+      (close-port port)
+      (string-trim-right output #\newline))))
+
+(let ((commit (git "log" "-n" "1" "--pretty=format:%H")))
+  (package
+    (name "zabbix-guix")
+    (version (string-append "0.0.1" "-" (string-take commit 7)))
+    (source (local-file %source-dir
+                        #:recursive? #t
+                        #:select? (git-predicate %source-dir)))
+    (build-system guile-build-system)
+    (inputs
+     `(("bash" ,bash)))
+    (native-inputs
+     `(("guile" ,guile-2.2)
+       ("guile-json" ,guile-json)
+       ("guix" ,guix)
+       ,@(package-propagated-inputs guix)))
+    (arguments
+     `(#:modules ((guix build guile-build-system)
+                  (guix build utils)
+                  (srfi srfi-26)
+                  (ice-9 popen)
+                  (ice-9 rdelim))
+                 #:phases
+                 (modify-phases %standard-phases
+                   (replace 'unpack
+                     (lambda* (#:key inputs #:allow-other-keys)
+                       (for-each (lambda (file)
+                                   (copy-file (string-append (assoc-ref inputs "source") "/" file)
+                                              (string-append "./" file)))
+                                 '("zabbix_guix" "zabbix.scm"))))
+                   (add-after 'unpack 'setenv
+                     (lambda _
+                       (setenv "PATH"
+                               (string-append (assoc-ref %build-inputs "bash") "/bin" ":"
+                                              (getenv "PATH")))))
+                   (add-after 'install 'install-script
+                     (lambda* (#:key inputs outputs #:allow-other-keys)
+                       (let* ((out (assoc-ref outputs "out"))
+                              (bin (string-append out "/bin"))
+                              (zabbix-guix (string-append bin "/zabbix_guix"))
+                              (guile (assoc-ref inputs "guile"))
+                              (guile-bin (string-append guile "/bin/guile"))
+                              (git (assoc-ref inputs "guile-git"))
+                              (bs (assoc-ref inputs "guile-bytestructures"))
+                              (gcrypt (assoc-ref inputs "guile-gcrypt"))
+                              (json (assoc-ref inputs "guile-json"))
+                              (guix (assoc-ref inputs "guix"))
+                              (deps (list out gcrypt json bs git guix))
+                              (effective
+                               (read-line
+                                (open-pipe* OPEN_READ guile-bin
+                                            "-c" "(display (effective-version))")))
+                              (path   (string-join
+                                       (map (cut string-append <>
+                                                 "/share/guile/site/"
+                                                 effective)
+                                            deps)
+                                       ":"))
+                              (gopath (string-join
+                                       (map (cut string-append <>
+                                                 "/lib/guile/" effective
+                                                 "/site-ccache")
+                                            deps)
+                                       ":")))
+                         (mkdir-p bin)
+                         (substitute* "./zabbix_guix"
+                           (("\\$\\(which guile\\)") guile-bin))
+                         (install-file "./zabbix_guix" bin)
+                         (chmod zabbix-guix #o555)
+                         (wrap-program zabbix-guix
+                           `("GUILE_LOAD_PATH" ":" prefix (,path))
+                           `("GUILE_LOAD_COMPILED_PATH" ":" prefix (,gopath)))
+                         #t))))))
+    (home-page "https://anongit.duckdns.org/guix/zabbix-guix")
+    (description "This package provides a Guile script to monitor Guix
+channels difference.")
+    (synopsis "Monitor Guix in Zabbix")
+    (license license:gpl3+)))
diff --git a/zabbix.scm b/zabbix.scm
new file mode 100644
index 0000000..4237140
--- /dev/null
+++ b/zabbix.scm
@@ -0,0 +1,138 @@
+;; zabbix.scm --- Monitor Guix in Zabbix.
+;; Copyright © 2019 Oleg Pykhalov <go.wigust@gmail.com>
+;; Released under the GNU GPLv3 or any later version.
+
+(define-module (zabbix)
+  #:use-module (guix channels)
+  #:use-module (guix describe)
+  #:use-module (guix profiles)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (json)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-37))
+
+(define (git . args)
+  "Execute 'git ARGS ...' command and return its output without trailing
+newspace."
+  (let* ((port   (apply open-pipe* OPEN_READ "git" args))
+         (output (read-string port)))
+    (close-port port)
+    (string-trim-right output #\newline)))
+
+(define (remote-channels channels)
+  (map (lambda (c)
+         (match (string-split (git "ls-remote" (channel-url c)
+                                   (string-append "*/" (channel-branch c)))
+                              #\tab)
+           ((commit ref)
+            (channel (name (channel-name c))
+                     (url (channel-url c))
+                     (commit commit)
+                     (branch (channel-branch c))
+                     (location #f)))))
+       (eval (begin (use-modules (guix channels))
+                    (with-input-from-file channels read))
+             (current-module))))
+
+(define (channels profile)
+  (define number
+    (generation-number profile))
+
+  (map (lambda (entry)
+         (match (assq 'source (manifest-entry-properties entry))
+           (('source ('repository ('version 0)
+                                  ('url url)
+                                  ('branch branch)
+                                  ('commit commit)
+                                  _ ...))
+            (channel (name (string->symbol (manifest-entry-name entry)))
+                     (url url)
+                     (commit commit)
+                     (location #f)))
+
+           ;; Pre-0.15.0 Guix does not provide that information,
+           ;; so there's not much we can do in that case.
+           (_ (channel (name 'guix)
+                       (url "?")
+                       (commit "?")))))
+
+       ;; Show most recently installed packages last.
+       (reverse
+        (manifest-entries
+         (profile-manifest
+          (if (zero? number)
+              profile
+              (generation-file-name profile number)))))))
+
+(define %options
+  (let ((display-and-exit-proc (lambda (msg)
+                                 (lambda (opt name arg loads)
+                                   (display msg) (quit)))))
+    (list (option '(#\v "version") #f #f
+                  (display-and-exit-proc "Guiz version 0.0.1\n"))
+          (option '(#\h "help") #f #f
+                  (display-and-exit-proc
+                   "Usage: foo scheme-file ..."))
+          (option '(#\A "available") #f #t
+                  (lambda (opt name arg loads)
+                    (cons `(query list-available ,(or arg ""))
+                          loads)))
+          (option '(#\d "diff") #t #f
+                  (lambda (opt name arg loads)
+                    (cons `(query diff ,(or arg ""))
+                          loads)))
+          (option '(#\p "profile") #t #f
+                  (lambda (opt name arg loads)
+                    (alist-cons 'profile (canonicalize-profile arg)
+                                loads)))
+          (option '(#\r "remote") #t #f
+                  (lambda (opt name arg loads)
+                    (alist-cons 'remote arg loads))))))
+
+(define %default-options
+  '())
+
+(define (main args)
+  (define opts
+    (args-fold (cdr (program-arguments))
+               %options
+               (lambda (opt name arg loads)
+                 (error "Unrecognized option `~A'" name))
+               (lambda (op loads)
+                 (cons op loads))
+               %default-options))
+
+  (define (find-channel-name name channels)
+    (fold (lambda (x xs)
+            (if (string=? (symbol->string (channel-name x)) name)
+                (cons x xs)
+                xs))
+          '()
+          channels))
+
+  (define remote (or (assq-ref opts 'remote)
+                     (string-append (getenv "HOME") "/.config/guix/channels.scm")))
+
+  (define profile (or (assq-ref opts 'profile) (current-profile)))
+
+  (match (assoc-ref opts 'query)
+    (('list-available name)
+     (scm->json
+      `((data ,@(map (lambda (local remote)
+                       `(("{#REMOTE_NAME}" . ,(channel-name remote))
+                         ("{#REMOTE_URL}" . ,(channel-url remote))
+                         ("{#REMOTE_COMMIT}" . ,(channel-commit remote))
+                         ("{#LOCAL_NAME}" . ,(channel-name local))
+                         ("{#LOCAL_URL}" . ,(channel-url local))
+                         ("{#LOCAL_COMMIT}" . ,(channel-commit local))))
+                     (channels profile)
+                     (remote-channels remote))))))
+    (('diff name)
+     (map (lambda (local remote)
+            (if (string=? name (symbol->string (channel-name local)))
+                (begin (display 0) (exit 1))
+                (begin (display 1) (exit 0))))
+          (channels profile)
+          (remote-channels remote)))))
diff --git a/zabbix_guix b/zabbix_guix
new file mode 100644
index 0000000..b220d40
--- /dev/null
+++ b/zabbix_guix
@@ -0,0 +1,4 @@
+#!/bin/sh
+# -*- scheme -*-
+exec ${GUILE:-$(which guile)} $GUILE_FLAGS --no-auto-compile -e '(@@ (zabbix) main)' -s "$0" "$@"
+!#