From 18ef97dcae8dd2b8af2dc905e11d2dbd3e452a06 Mon Sep 17 00:00:00 2001 From: Matěj Cepl Date: Sat, 25 Nov 2023 20:00:56 +0100 Subject: Move everything irrelevant to _attic/. It was too confusing for newcomers to look at the stuff which is just a note from the old project. --- Makefile.am | 88 --------- TODO.txt | 10 - _attic/Makefile.am | 88 +++++++++ _attic/TODO.txt | 10 + _attic/pinentry-rofi.bats | 457 ++++++++++++++++++++++++++++++++++++++++++++++ _attic/pinentry-rofi.scm | 435 +++++++++++++++++++++++++++++++++++++++++++ pinentry-rofi.scm | 435 ------------------------------------------- tests/pinentry-rofi.bats | 457 ---------------------------------------------- 8 files changed, 990 insertions(+), 990 deletions(-) delete mode 100644 Makefile.am delete mode 100644 TODO.txt create mode 100644 _attic/Makefile.am create mode 100644 _attic/TODO.txt create mode 100755 _attic/pinentry-rofi.bats create mode 100644 _attic/pinentry-rofi.scm delete mode 100644 pinentry-rofi.scm delete mode 100755 tests/pinentry-rofi.bats diff --git a/Makefile.am b/Makefile.am deleted file mode 100644 index 1986219..0000000 --- a/Makefile.am +++ /dev/null @@ -1,88 +0,0 @@ -# SPDX-FileCopyrightText: 2023 Fredrik Salomonsson -# -# SPDX-License-Identifier: CC0-1.0 - -bin_SCRIPTS = scripts/pinentry-rofi - -# Handle substitution of fully-expanded Autoconf variables. -do_subst = $(SED) \ - -e 's,[@]GUILE[@],$(GUILE),g' \ - -e 's,[@]guilemoduledir[@],$(guilemoduledir),g' \ - -e 's,[@]guileobjectdir[@],$(guileobjectdir),g' \ - -e 's,[@]GUILE_OBJECT_DIR[@],$(prefix)/$(GUILE_OBJECT_DIR),g' \ - -e 's,[@]GUILE_MODULE_DIR[@],$(exec_prefix)/$(GUILE_MODULE_DIR),g' \ - -e 's,[@]localedir[@],$(localedir),g' - -nodist_noinst_SCRIPTS = pre-inst-env - -GOBJECTS = $(SOURCES:%.scm=%.go) - -moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION) -godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache -ccachedir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache - -nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) -nobase_go_DATA = $(GOBJECTS) - -# Make sure source files are installed first, so that the mtime of -# installed compiled files is greater than that of installed source -# files. See -# -# for details. -guile_install_go_files = install-nobase_goDATA -$(guile_install_go_files): install-nobase_modDATA - -EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) -GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat -SUFFIXES = .scm .go -.scm.go: - $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<" - -SOURCES = pinentry-rofi.scm - -TESTS = tests/pinentry-rofi.scm - -TEST_EXTENSIONS = .scm -SCM_LOG_DRIVER = \ - $(top_builddir)/pre-inst-env \ - $(GUILE) --no-auto-compile -e main \ - $(top_srcdir)/build-aux/test-driver.scm - -# Tell 'build-aux/test-driver.scm' to display only source file names, -# not indivdual test names. -AM_SCM_LOG_DRIVER_FLAGS = --brief=yes - -AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)" - -AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" - -info_TEXINFOS = doc/pinentry-rofi.texi -dvi: # Don't build dvi docs - -EXTRA_DIST += README.org \ - README \ - AUTHORS \ - NEWS \ - HACKING \ - COPYING \ - ChangeLog \ - guix.scm \ - hall.scm \ - build-aux/test-driver.scm \ - $(TESTS) - -ACLOCAL_AMFLAGS = -I m4 - -clean-go: - -$(RM) $(GOBJECTS) -.PHONY: clean-go - -CLEANFILES = \ - $(GOBJECTS) \ - $(TESTS:tests/%.scm=%.log) - -# Sanity checks for the script -installcheck-local: - [ `$(bindir)/pinentry-rofi --version` = $(HVERSION) ] - $(bindir)/pinentry-rofi --help - echo BYE | $(bindir)/pinentry-rofi diff --git a/TODO.txt b/TODO.txt deleted file mode 100644 index a030520..0000000 --- a/TODO.txt +++ /dev/null @@ -1,10 +0,0 @@ -Make sure these all are somehow accommodated: - - * Add search paths to guile's module and object directory in the - executable. - * Fix issue with --version. - * Fixed crash when rofi is aborted. - * Propper newline between error and description. - * Added support for popup. (???) - * Added support for underline characters in message. - * Added support to ask again if password is wrong. diff --git a/_attic/Makefile.am b/_attic/Makefile.am new file mode 100644 index 0000000..1986219 --- /dev/null +++ b/_attic/Makefile.am @@ -0,0 +1,88 @@ +# SPDX-FileCopyrightText: 2023 Fredrik Salomonsson +# +# SPDX-License-Identifier: CC0-1.0 + +bin_SCRIPTS = scripts/pinentry-rofi + +# Handle substitution of fully-expanded Autoconf variables. +do_subst = $(SED) \ + -e 's,[@]GUILE[@],$(GUILE),g' \ + -e 's,[@]guilemoduledir[@],$(guilemoduledir),g' \ + -e 's,[@]guileobjectdir[@],$(guileobjectdir),g' \ + -e 's,[@]GUILE_OBJECT_DIR[@],$(prefix)/$(GUILE_OBJECT_DIR),g' \ + -e 's,[@]GUILE_MODULE_DIR[@],$(exec_prefix)/$(GUILE_MODULE_DIR),g' \ + -e 's,[@]localedir[@],$(localedir),g' + +nodist_noinst_SCRIPTS = pre-inst-env + +GOBJECTS = $(SOURCES:%.scm=%.go) + +moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION) +godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache +ccachedir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache + +nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) +nobase_go_DATA = $(GOBJECTS) + +# Make sure source files are installed first, so that the mtime of +# installed compiled files is greater than that of installed source +# files. See +# +# for details. +guile_install_go_files = install-nobase_goDATA +$(guile_install_go_files): install-nobase_modDATA + +EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) +GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +SUFFIXES = .scm .go +.scm.go: + $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<" + +SOURCES = pinentry-rofi.scm + +TESTS = tests/pinentry-rofi.scm + +TEST_EXTENSIONS = .scm +SCM_LOG_DRIVER = \ + $(top_builddir)/pre-inst-env \ + $(GUILE) --no-auto-compile -e main \ + $(top_srcdir)/build-aux/test-driver.scm + +# Tell 'build-aux/test-driver.scm' to display only source file names, +# not indivdual test names. +AM_SCM_LOG_DRIVER_FLAGS = --brief=yes + +AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)" + +AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)" + +info_TEXINFOS = doc/pinentry-rofi.texi +dvi: # Don't build dvi docs + +EXTRA_DIST += README.org \ + README \ + AUTHORS \ + NEWS \ + HACKING \ + COPYING \ + ChangeLog \ + guix.scm \ + hall.scm \ + build-aux/test-driver.scm \ + $(TESTS) + +ACLOCAL_AMFLAGS = -I m4 + +clean-go: + -$(RM) $(GOBJECTS) +.PHONY: clean-go + +CLEANFILES = \ + $(GOBJECTS) \ + $(TESTS:tests/%.scm=%.log) + +# Sanity checks for the script +installcheck-local: + [ `$(bindir)/pinentry-rofi --version` = $(HVERSION) ] + $(bindir)/pinentry-rofi --help + echo BYE | $(bindir)/pinentry-rofi diff --git a/_attic/TODO.txt b/_attic/TODO.txt new file mode 100644 index 0000000..a030520 --- /dev/null +++ b/_attic/TODO.txt @@ -0,0 +1,10 @@ +Make sure these all are somehow accommodated: + + * Add search paths to guile's module and object directory in the + executable. + * Fix issue with --version. + * Fixed crash when rofi is aborted. + * Propper newline between error and description. + * Added support for popup. (???) + * Added support for underline characters in message. + * Added support to ask again if password is wrong. diff --git a/_attic/pinentry-rofi.bats b/_attic/pinentry-rofi.bats new file mode 100755 index 0000000..8c7748e --- /dev/null +++ b/_attic/pinentry-rofi.bats @@ -0,0 +1,457 @@ +#!/usr/bin/env bats + +## (define-module (tests-pinentry-rofi) +## #:use-module (srfi srfi-64) +## #:use-module (ice-9 popen) +## #:use-module (ice-9 textual-ports) +## #:use-module (pinentry-rofi)) + +# XXX (test-begin "pinentry-rofi") + +# XXX ;; (test-begin "pinentry") +# XXX (let ((pinentry (make-pinentry #t "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry? pinentry)) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) +# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) +# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) +# XXX (test-equal ":1" (pinentry-display pinentry)) +# XXX (test-equal "test.log" (pinentry-logfile pinentry)) +# XXX (test-assert (not (pinentry-notok-button pinentry))) +# XXX (test-assert (not (pinentry-visibility pinentry))) +# XXX (test-assert (not (pinentry-error pinentry)))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (not (pinentry-ok pinentry)))) +# XXX +# XXX ;; (test-end "pinentry") +# XXX +# XXX ;; (test-begin "utils") +# XXX +# XXX (test-equal "Ok" (remove-underline "_Ok")) +# XXX (test-equal " Ok" (remove-underline " _Ok")) +# XXX (test-equal "foo_bar" (remove-underline "foo_bar")) +# XXX (test-equal "foo__bar" (remove-underline "foo__bar")) +# XXX (test-equal " __Ok" (remove-underline " __Ok")) +# XXX (test-equal "__Ok" (remove-underline "__Ok")) +# XXX (test-equal "Ok%0ACancel" (remove-underline "_Ok%0A_Cancel")) +# XXX (test-equal "Ok Cancel" (remove-underline "_Ok _Cancel")) +# XXX +# XXX (test-equal "_Ok" (escape-underscore "_Ok")) +# XXX (test-equal " _Ok" (escape-underscore " _Ok")) +# XXX (test-equal "foo_bar" (escape-underscore "foo_bar")) +# XXX (test-equal "foo__bar" (escape-underscore "foo__bar")) +# XXX (test-equal " _Ok" (escape-underscore " __Ok")) +# XXX (test-equal "_Ok" (escape-underscore "__Ok")) +# XXX (test-equal "_Ok%0A_Cancel" (escape-underscore "__Ok%0A__Cancel")) +# XXX (test-equal "_Ok _Cancel" (escape-underscore "__Ok __Cancel")) +# XXX +# XXX (test-assert (string-empty? "")) +# XXX (test-assert (not (string-empty? "foo"))) +# XXX ;; (test-end "utils") +# XXX +# XXX (test-equal "This is one line\nThis is another%OA" +# XXX (hex->char "%54his is one line%0AThis is another%OA")) +# XXX +# XXX ;; (test-begin "html") +# XXX (test-equal "%54his is one line This is another%OA" +# XXX (html-newline "%54his is one line%0AThis is another%OA")) +# XXX (test-equal "%54his is one line\nThis is another%OA" +# XXX (html-newline "%54his is one line\nThis is another%OA")) +# XXX +# XXX (test-equal "Ok" (html-underline "_Ok")) +# XXX (test-equal " Ok" (html-underline " _Ok")) +# XXX (test-equal "foo_bar" (html-underline "foo_bar")) +# XXX (test-equal "foo__bar" (html-underline "foo__bar")) +# XXX (test-equal " __Ok" (html-underline " __Ok")) +# XXX (test-equal "__Ok" (html-underline "__Ok")) +# XXX (test-equal "Ok%0ACancel" (html-underline "_Ok%0A_Cancel")) +# XXX (test-equal "Ok Cancel" (html-underline "_Ok _Cancel")) +# XXX +# XXX ;; (test-end "html") +# XXX +# XXX (test-equal "This is one line This is another%OA" +# XXX (pango-markup "_%54his is one line%0A_This is another%OA")) +# XXX +# XXX (test-equal "Ok\nCancel" +# XXX (input-string "_Ok\nCancel")) +# XXX +# XXX (test-equal "Ok\n_Cancel" +# XXX (input-string "_Ok\n__Cancel")) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (pinentry-set set-pinentry-notok-button! pinentry "Not ok") +# XXX (test-equal "Not ok" (pinentry-notok-button pinentry)) +# XXX (test-assert (pinentry-ok pinentry))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-error #t (pinentry-set pinentry-notok-button pinentry "Not ok"))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-option pinentry "OPTION default-ok=Okay")) +# XXX (test-equal "Okay" (pinentry-ok-button pinentry)) +# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) +# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) +# XXX (test-equal "C" (pinentry-lc-ctype pinentry)) +# XXX (test-equal "C" (pinentry-lc-messages pinentry)) +# XXX (test-assert (pinentry-ok pinentry))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-option pinentry "OPTION default-cancel=No")) +# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) +# XXX (test-equal "No" (pinentry-cancel-button pinentry)) +# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) +# XXX (test-equal "C" (pinentry-lc-ctype pinentry)) +# XXX (test-equal "C" (pinentry-lc-messages pinentry)) +# XXX (test-assert (pinentry-ok pinentry))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-option pinentry "OPTION default-prompt=Password:")) +# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) +# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) +# XXX (test-equal "Password:" (pinentry-prompt pinentry)) +# XXX (test-equal "C" (pinentry-lc-ctype pinentry)) +# XXX (test-equal "C" (pinentry-lc-messages pinentry)) +# XXX (test-assert (pinentry-ok pinentry))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-option pinentry "OPTION lc-ctype=en_US.UTF-8")) +# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) +# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) +# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) +# XXX (test-equal "en_US.UTF-8" (pinentry-lc-ctype pinentry)) +# XXX (test-equal "C" (pinentry-lc-messages pinentry)) +# XXX (test-assert (pinentry-ok pinentry))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-option pinentry "OPTION lc-messages=en_US.UTF-8")) +# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) +# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) +# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) +# XXX (test-equal "C" (pinentry-lc-ctype pinentry)) +# XXX (test-equal "en_US.UTF-8" (pinentry-lc-messages pinentry)) +# XXX (test-assert (pinentry-ok pinentry))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-option pinentry "OPTION foo bar"))) +# XXX +# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (not (pinentry-option pinentry " OPTION foo bar"))) +# XXX (test-assert (not (pinentry-option pinentry "OPTION"))) +# XXX (test-assert (not (pinentry-option pinentry "Foo")))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C")) +# XXX (output "") +# XXX (fake-port (make-soft-port +# XXX (vector +# XXX (lambda (c) (set! output (string-append output c))) +# XXX (lambda (s) (set! output (string-append output s))) +# XXX (lambda () #t) +# XXX #f +# XXX (lambda () #t)) +# XXX "w"))) +# XXX (test-assert (pinentry-getinfo pinentry "GETINFO pid" #:port fake-port)) +# XXX (test-equal (format #f "D ~a\n" (getpid)) output) +# XXX (test-assert (pinentry-getinfo pinentry "GETINFO foo bar")) +# XXX (test-assert (not (pinentry-getinfo pinentry " GETINFO foo bar"))) +# XXX (test-assert (not (pinentry-getinfo pinentry "GETINFO"))) +# XXX (test-assert (not (pinentry-getinfo pinentry "Foo")))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-setkeyinfo pinentry "SETKEYINFO Foo")) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-assert (not (pinentry-setkeyinfo pinentry " SETKEYINFO foo bar"))) +# XXX (test-assert (not (pinentry-setkeyinfo pinentry "SETKEYINFO"))) +# XXX (test-assert (not (pinentry-setkeyinfo pinentry "Foo")))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-setok pinentry "SETOK Foo")) +# XXX (test-equal "Foo" (pinentry-ok-button pinentry)) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-assert (pinentry-setok pinentry "SETOK _Ok okay")) +# XXX (test-equal "Ok okay" (pinentry-ok-button pinentry)) +# XXX (test-assert (not (pinentry-setok pinentry " SETOK foo bar"))) +# XXX (test-equal "Ok okay" (pinentry-ok-button pinentry)) +# XXX (test-assert (not (pinentry-setok pinentry "SETOK"))) +# XXX (test-equal "Ok okay" (pinentry-ok-button pinentry)) +# XXX (test-assert (not (pinentry-setok pinentry "Foo"))) +# XXX (test-equal "Ok okay" (pinentry-ok-button pinentry))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-setnotok pinentry "SETNOTOK Foo")) +# XXX (test-equal "Foo" (pinentry-notok-button pinentry)) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-assert (pinentry-setnotok pinentry "SETNOTOK Not _Ok")) +# XXX (test-equal "Not Ok" (pinentry-notok-button pinentry)) +# XXX (test-assert (not (pinentry-setnotok pinentry " SETNOTOK foo bar"))) +# XXX (test-equal "Not Ok" (pinentry-notok-button pinentry)) +# XXX (test-assert (not (pinentry-setnotok pinentry "SETNOTOK"))) +# XXX (test-equal "Not Ok" (pinentry-notok-button pinentry)) +# XXX (test-assert (not (pinentry-setnotok pinentry "Foo"))) +# XXX (test-equal "Not Ok" (pinentry-notok-button pinentry))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-setcancel pinentry "SETCANCEL Foo")) +# XXX (test-equal "Foo" (pinentry-cancel-button pinentry)) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-assert (pinentry-setcancel pinentry "SETCANCEL _Abort")) +# XXX (test-equal "Abort" (pinentry-cancel-button pinentry)) +# XXX (test-assert (not (pinentry-setcancel pinentry " SETCANCEL foo bar"))) +# XXX (test-equal "Abort" (pinentry-cancel-button pinentry)) +# XXX (test-assert (not (pinentry-setcancel pinentry "SETCANCEL"))) +# XXX (test-equal "Abort" (pinentry-cancel-button pinentry)) +# XXX (test-assert (not (pinentry-setcancel pinentry "Foo"))) +# XXX (test-equal "Abort" (pinentry-cancel-button pinentry))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Desc" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-setdesc pinentry "SETDESC Foo")) +# XXX (test-equal "Foo" (pinentry-desc pinentry)) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-assert (pinentry-setdesc pinentry "SETDESC _%54his is a description%0A_On two lines")) +# XXX (test-equal "This is a description On two lines" (pinentry-desc pinentry)) +# XXX (test-assert (not (pinentry-setdesc pinentry " SETDESC foo bar"))) +# XXX (test-equal "This is a description On two lines" (pinentry-desc pinentry)) +# XXX (test-assert (not (pinentry-setdesc pinentry "SETDESC"))) +# XXX (test-equal "This is a description On two lines" (pinentry-desc pinentry)) +# XXX (test-assert (not (pinentry-setdesc pinentry "Foo"))) +# XXX (test-equal "This is a description On two lines" (pinentry-desc pinentry))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Error" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-seterror pinentry "SETERROR Foo")) +# XXX (test-equal "Foo" (pinentry-error pinentry)) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-assert (pinentry-seterror pinentry "SETERROR _%54his is an error%0A_On two lines")) +# XXX (test-equal "This is an error On two lines" (pinentry-error pinentry)) +# XXX (test-assert (not (pinentry-seterror pinentry " SETERROR foo bar"))) +# XXX (test-equal "This is an error On two lines" (pinentry-error pinentry)) +# XXX (test-assert (not (pinentry-seterror pinentry "SETERROR"))) +# XXX (test-equal "This is an error On two lines" (pinentry-error pinentry)) +# XXX (test-assert (not (pinentry-seterror pinentry "Foo"))) +# XXX (test-equal "This is an error On two lines" (pinentry-error pinentry))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Prompt" ":1" "test.log" "C" "C"))) +# XXX (test-assert (pinentry-setprompt pinentry "SETPROMPT Foo")) +# XXX (test-equal "Foo" (pinentry-prompt pinentry)) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-assert (pinentry-setprompt pinentry "SETPROMPT _%54his is a prompt%0A_On two lines")) +# XXX (test-equal "This is a prompt On two lines" (pinentry-prompt pinentry)) +# XXX (test-assert (not (pinentry-setprompt pinentry " SETPROMPT foo bar"))) +# XXX (test-equal "This is a prompt On two lines" (pinentry-prompt pinentry)) +# XXX (test-assert (not (pinentry-setprompt pinentry "SETPROMPT"))) +# XXX (test-equal "This is a prompt On two lines" (pinentry-prompt pinentry)) +# XXX (test-assert (not (pinentry-setprompt pinentry "Foo"))) +# XXX (test-equal "This is a prompt On two lines" (pinentry-prompt pinentry))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Prompt" ":1" "test.log" "C" "C"))) +# XXX (test-error "(quit #t)" (pinentry-bye pinentry "BYE")) +# XXX (test-assert (not (pinentry-bye pinentry "Hej då")))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "en_US.UTF-8")) +# XXX (output "") +# XXX (fake-port (make-soft-port +# XXX (vector +# XXX (lambda (c) (set! output (string-append output c))) +# XXX (lambda (s) (set! output (string-append output s))) +# XXX (lambda () #t) +# XXX #f +# XXX (lambda () #t)) +# XXX "w")) +# XXX (description "This is a description") +# XXX (error "Something went wrong") +# XXX (display ":1")) +# XXX (set-pinentry-desc! pinentry description) +# XXX (set-pinentry-display! pinentry display) +# XXX (test-assert (pinentry-getpin pinentry "GETPIN" +# XXX (lambda* (#:key (env '()) +# XXX visibility +# XXX (prompt ">") +# XXX message +# XXX buttons +# XXX only-match) +# XXX (test-equal "Prompt" prompt) +# XXX (test-equal description message) +# XXX (test-assert (not visibility)) +# XXX (test-assert (not only-match)) +# XXX (test-assert (not buttons)) +# XXX (test-equal `(("DISPLAY" . ,display) +# XXX ("LC_CTYPE" . "C") +# XXX ("LC_MESSAGES" . "en_US.UTF-8")) +# XXX env) +# XXX "password") +# XXX #:port fake-port)) +# XXX (test-equal (format #f "D password") output) +# XXX (set-pinentry-error! pinentry error) +# XXX (set! output "") +# XXX (test-assert (pinentry-getpin pinentry "GETPIN" +# XXX (lambda* (#:key (env '()) +# XXX visibility +# XXX (prompt ">") +# XXX message +# XXX buttons +# XXX only-match) +# XXX (test-equal "Prompt" prompt) +# XXX (test-equal (format #f "~a ~a" error description) +# XXX message) +# XXX (test-assert (not visibility)) +# XXX (test-assert (not only-match)) +# XXX (test-assert (not buttons)) +# XXX (test-equal `(("DISPLAY" . ,display) +# XXX ("LC_CTYPE" . "C") +# XXX ("LC_MESSAGES" . "en_US.UTF-8")) +# XXX env) +# XXX "password") +# XXX #:port fake-port)) +# XXX (test-equal (format #f "D password") output) +# XXX (set! output "") +# XXX (test-assert (pinentry-getpin pinentry "GETPIN" +# XXX (lambda* (#:key (env '()) +# XXX visibility +# XXX (prompt ">") +# XXX message +# XXX buttons +# XXX only-match) +# XXX (test-equal "Prompt" prompt) +# XXX (test-equal (format #f "~a ~a" error description) +# XXX message) +# XXX (test-assert (not visibility)) +# XXX (test-assert (not only-match)) +# XXX (test-assert (not buttons)) +# XXX (test-equal `(("DISPLAY" . ,display) +# XXX ("LC_CTYPE" . "C") +# XXX ("LC_MESSAGES" . "en_US.UTF-8")) +# XXX env) +# XXX "") +# XXX #:port fake-port)) +# XXX (test-equal (format #f "ERR 83886179 Operation cancelled \n") output) +# XXX (set! output "") +# XXX (test-assert (pinentry-getpin pinentry "GETPIN" +# XXX (lambda* (#:key (env '()) +# XXX visibility +# XXX (prompt ">") +# XXX message +# XXX buttons +# XXX only-match) +# XXX (test-equal "Prompt" prompt) +# XXX (test-equal (format #f "~a ~a" error description) +# XXX message) +# XXX (test-assert (not visibility)) +# XXX (test-assert (not only-match)) +# XXX (test-assert (not buttons)) +# XXX (test-equal `(("DISPLAY" . ,display) +# XXX ("LC_CTYPE" . "C") +# XXX ("LC_MESSAGES" . "en_US.UTF-8")) +# XXX env) +# XXX " ") +# XXX #:port fake-port)) +# XXX (test-equal (format #f "ERR 83886179 Operation cancelled \n") output) +# XXX (test-assert (not (pinentry-getinfo pinentry " GETPIN"))) +# XXX (test-assert (not (pinentry-getinfo pinentry "Foo")))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "en_US.UTF-8")) +# XXX (description "This is a description") +# XXX (error "Something went wrong") +# XXX (display ":1")) +# XXX (set-pinentry-desc! pinentry description) +# XXX (set-pinentry-display! pinentry display) +# XXX (test-assert (pinentry-confirm pinentry "CONFIRM" +# XXX (lambda* (#:key (env '()) +# XXX visibility +# XXX (prompt ">") +# XXX message +# XXX buttons +# XXX only-match) +# XXX (test-equal ">" prompt) +# XXX (test-equal description message) +# XXX (test-assert visibility) +# XXX (test-assert only-match) +# XXX (test-equal `("Ok" "Cancel") buttons) +# XXX (test-equal `(("DISPLAY" . ,display) +# XXX ("LC_CTYPE" . "C") +# XXX ("LC_MESSAGES" . "en_US.UTF-8")) +# XXX env) +# XXX "Ok"))) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (set-pinentry-error! pinentry error) +# XXX (let* ((output "") +# XXX (fake-port (make-soft-port +# XXX (vector +# XXX (lambda (c) (set! output (string-append output c))) +# XXX (lambda (s) (set! output (string-append output s))) +# XXX (lambda () #t) +# XXX #f +# XXX (lambda () #t)) +# XXX "w"))) +# XXX (test-assert (pinentry-confirm +# XXX pinentry +# XXX "CONFIRM" +# XXX (lambda* (#:key (env '()) +# XXX visibility +# XXX (prompt ">") +# XXX message +# XXX buttons +# XXX only-match) +# XXX (test-equal ">" prompt) +# XXX (test-equal (format #f "~a ~a" error description) +# XXX message) +# XXX (test-assert visibility) +# XXX (test-assert only-match) +# XXX (test-equal `("Ok" "Cancel") buttons) +# XXX (test-equal `(("DISPLAY" . ,display) +# XXX ("LC_CTYPE" . "C") +# XXX ("LC_MESSAGES" . "en_US.UTF-8")) +# XXX env) +# XXX "Cancel") +# XXX #:port fake-port)) +# XXX (test-equal (format #f "ERR 277 Operation cancelled\n") output)) +# XXX (test-assert (not (pinentry-ok pinentry))) +# XXX (test-assert (not (pinentry-getinfo pinentry " CONFIRM"))) +# XXX (test-assert (not (pinentry-getinfo pinentry "Foo")))) +# XXX +# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "en_US.UTF-8")) +# XXX (description "This is a description") +# XXX (display ":1")) +# XXX (set-pinentry-desc! pinentry description) +# XXX (set-pinentry-display! pinentry display) +# XXX (test-assert (pinentry-confirm pinentry "CONFIRM --one-button" +# XXX (lambda* (#:key (env '()) +# XXX visibility +# XXX (prompt ">") +# XXX message +# XXX buttons +# XXX only-match) +# XXX (test-equal ">" prompt) +# XXX (test-equal description message) +# XXX (test-assert visibility) +# XXX (test-assert only-match) +# XXX (test-equal `("Ok") buttons) +# XXX (test-equal `(("DISPLAY" . ,display) +# XXX ("LC_CTYPE" . "C") +# XXX ("LC_MESSAGES" . "en_US.UTF-8")) +# XXX env) +# XXX "Ok"))) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (set-pinentry-ok! pinentry #f) +# XXX (test-assert (pinentry-confirm pinentry "MESSAGE" +# XXX (lambda* (#:key (env '()) +# XXX visibility +# XXX (prompt ">") +# XXX message +# XXX buttons +# XXX only-match) +# XXX (test-equal ">" prompt) +# XXX (test-equal description message) +# XXX (test-assert visibility) +# XXX (test-assert only-match) +# XXX (test-equal `("Ok") buttons) +# XXX (test-equal `(("DISPLAY" . ,display) +# XXX ("LC_CTYPE" . "C") +# XXX ("LC_MESSAGES" . "en_US.UTF-8")) +# XXX env) +# XXX "Ok"))) +# XXX (test-assert (pinentry-ok pinentry)) +# XXX (test-assert (not (pinentry-getinfo pinentry " CONFIRM --one-button"))) +# XXX (test-assert (not (pinentry-getinfo pinentry "MESSAGE --one-button"))) +# XXX (test-assert (not (pinentry-getinfo pinentry " MESSAGE"))) +# XXX (test-assert (not (pinentry-getinfo pinentry "Foo")))) +# XXX +# XXX (test-end "pinentry-rofi") diff --git a/_attic/pinentry-rofi.scm b/_attic/pinentry-rofi.scm new file mode 100644 index 0000000..4114eb3 --- /dev/null +++ b/_attic/pinentry-rofi.scm @@ -0,0 +1,435 @@ +;; SPDX-FileCopyrightText: 2016 Quentin "Sardem FF7" Glidic +;; SPDX-FileCopyrightText: 2018-2023 Fredrik Salomonsson +;; +;; SPDX-License-Identifier: GPL-3.0-or-later + +(define-module (pinentry-rofi) + #:use-module (ice-9 popen) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-1) ;; concatenate + #:use-module (srfi srfi-9) ;; For records + #:use-module (ice-9 format) + #:use-module (ice-9 regex) + #:export (make-pinentry + pinentry? + pinentry-ok set-pinentry-ok! + pinentry-prompt set-pinentry-prompt! + pinentry-desc set-pinentry-desc! + pinentry-visibility set-pinentry-visibility! + pinentry-display set-pinentry-display! + pinentry-error set-pinentry-error! + pinentry-logfile set-pinentry-logfile! + pinentry-ok-button set-pinentry-ok-button! + pinentry-notok-button set-pinentry-notok-button! + pinentry-cancel-button set-pinentry-cancel-button! + pinentry-lc-ctype set-pinentry-lc-ctype! + pinentry-lc-messages set-pinentry-lc-messages! + + remove-underline + escape-underscore + + html-newline + html-underline + html-< + string-empty? + + hex->char + input-string + pango-markup + + pinentry-set + + rofi-popup + + pinentry-option + pinentry-getinfo + pinentry-setkeyinfo + pinentry-setok + pinentry-setcancel + pinentry-setnotok + pinentry-setdesc + pinentry-seterror + pinentry-setprompt + pinentry-getpin + pinentry-confirm + pinentry-bye + pinentry-loop)) + +(when (equal? (system-file-name-convention) 'windows) + (format #t "Only support posix systems!") + (exit #f)) + +(define-record-type + (make-pinentry ok prompt ok-button cancel-button display logfile lc-ctype lc-messages) + pinentry? + (ok pinentry-ok set-pinentry-ok!) + (prompt pinentry-prompt set-pinentry-prompt!) + (desc pinentry-desc set-pinentry-desc!) + (visibility pinentry-visibility set-pinentry-visibility!) + (display pinentry-display set-pinentry-display!) + (error pinentry-error set-pinentry-error!) + (logfile pinentry-logfile set-pinentry-logfile!) + (ok-button pinentry-ok-button set-pinentry-ok-button!) + (notok-button pinentry-notok-button set-pinentry-notok-button!) + (cancel-button pinentry-cancel-button set-pinentry-cancel-button!) + (lc-ctype pinentry-lc-ctype set-pinentry-lc-ctype!) + (lc-messages pinentry-lc-messages set-pinentry-lc-messages!)) + +(define-syntax-rule (set-and-return! val expr) + "Set val to expr and return val." + (begin (set! val expr) val)) + +(define (string-empty? str) + "Evaluates to #t if string is empty." + (string=? str "")) + +(define (remove-underline str) + "Replace _ followed by a character with just the character." + (regexp-substitute/global #f "(^|%0A| |\n|[[:blank:]])_([[:alpha:]])" str + 'pre 1 2 'post)) + +(define (escape-underscore str) + "Replace __ followed by a character with _ and said character. +Always call this after `remove-underline' or +`html-underline'." + (regexp-substitute/global #f "(^|%0A| |\n|[[:blank:]])__([[:alpha:]])" str + 'pre 1 "_" 2 'post)) + +(define (html-newline str) + "Replace %0A with " + (regexp-substitute/global #f "%0A" str 'pre " " 'post)) + +(define (html-underline str) + "Underscore followed by a character, underlines that character." + (regexp-substitute/global #f "(^|%0A| |\n|[[:blank:]])_([[:alpha:]])" str + 'pre 1""2"" 'post)) +(define (html-< str) + "Replace < with <" + (regexp-substitute/global #f "<" str 'pre "<" 'post)) + +(define (hex->char str) + "Replace matching'%XX' where X ∈ {0-F} with their respective char." + (regexp-substitute/global + #f "%([[:xdigit:]]{2})" str 'pre + (lambda (m) (integer->char + (string->number + (match:substring m 1) 16))) 'post)) + +(define (pango-markup str) + "Transform string to pango." + (escape-underscore + (html-underline + (hex->char + (html-< + (html-newline str)))))) + +(define (input-string str) + "Transform string to input for rofi. +Input strings does not support pango markup" + (escape-underscore + (remove-underline str))) + +(define* (pinentry-set set-func pinentry label) + "Using SET-FUNC, set the entry in PINENTRY to LABEL." + (set-func pinentry label) + (set-pinentry-ok! pinentry #t)) + +(define (pinentry-set-button set-func pinentry label) + "Using SET-BUTTON-FUNC, set the entry in PINENTRY to LABEL. +LABEL will be transformed using `input-string'" + (pinentry-set set-func pinentry (input-string label))) + +(define (pinentry-set-mesg set-func pinentry label) + "Using SET-FUNC, set the entry in PINENTRY to LABEL. +LABEL will be transformed using `pango-markup'" + (pinentry-set set-func pinentry (pango-markup label))) + +(define (pinentry-option pinentry line) + "Process line if it starts with OPTION. +Return false otherwise. + +Known options are: +grab +ttyname=/dev/pts/1 +ttytype=tmux-256color +lc-ctype=C +lc-messages=C +allow-external-password-cache +default-ok=_OK +default-cancel=_Cancel +default-yes=_Yes +default-no=_No +default-prompt=PIN: +default-pwmngr=_Save in password manager +default-cf-visi=Do you really want to make your passphrase visible on the screen? +default-tt-visi=Make passphrase visible +default-tt-hide=Hide passphrase +touch-file=/run/user/1000/gnupg/S.gpg-agent" + (let ((regex-match #f) + (option-re (make-regexp "^OPTION (.+)$"))) + (cond + ((set-and-return! regex-match + (regexp-exec + (make-regexp "^OPTION[[:blank:]]+default-ok=(.+)$") line)) + (pinentry-set-button + set-pinentry-ok-button! + pinentry + (match:substring regex-match 1))) + ((set-and-return! regex-match + (regexp-exec + (make-regexp "^OPTION[[:blank:]]+default-cancel=(.+)$") line)) + (pinentry-set-button + set-pinentry-cancel-button! + pinentry + (match:substring regex-match 1))) + ((set-and-return! regex-match + (regexp-exec + (make-regexp "^OPTION[[:blank:]]+default-prompt=(.+)$") line)) + (pinentry-set-mesg + set-pinentry-prompt! + pinentry + (match:substring regex-match 1))) + ((set-and-return! regex-match + (regexp-exec + (make-regexp "^OPTION[[:blank:]]+lc-ctype=(.+)$") line)) + (pinentry-set + set-pinentry-lc-ctype! + pinentry + (match:substring regex-match 1))) + ((set-and-return! regex-match + (regexp-exec + (make-regexp "^OPTION[[:blank:]]+lc-messages=(.+)$") line)) + (pinentry-set + set-pinentry-lc-messages! + pinentry + (match:substring regex-match 1))) + ((set-and-return! regex-match (regexp-exec option-re line)))) + regex-match)) + +(define* (pinentry-getinfo pinentry line #:key (port #t)) + "Process line if it starts with GETINFO" + (let ((getinfo-re (make-regexp "^GETINFO (.+)$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec getinfo-re line)) + (let ((info (match:substring regex-match 1))) + (cond + ((string=? info "pid") + (format port "D ~a~%~!" (getpid))))) + (set-pinentry-ok! pinentry #t)) + regex-match)) + +(define (pinentry-setkeyinfo pinentry line) + "SETKEYINFO s/FINGERPRINT" + (let ((setkeyinfo-re (make-regexp "^SETKEYINFO (.+)$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec setkeyinfo-re line)) + (set-pinentry-ok! pinentry #t)) + regex-match)) + +(define (pinentry-setok pinentry line) + "Set ok button label." + (let ((setok-button-re (make-regexp "^SETOK (.+)$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec setok-button-re line)) + (pinentry-set-button + set-pinentry-ok-button! + pinentry + (match:substring regex-match 1))) + regex-match)) + +(define (pinentry-setcancel pinentry line) + "Set cancel button label." + (let ((setcancel-button-re (make-regexp "^SETCANCEL (.+)$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec setcancel-button-re line)) + (pinentry-set-button + set-pinentry-cancel-button! + pinentry + (match:substring regex-match 1))) + regex-match)) + +(define (pinentry-setnotok pinentry line) + "Set notok button label." + (let ((setnotok-button-re (make-regexp "^SETNOTOK (.+)$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec setnotok-button-re line)) + (pinentry-set-button + set-pinentry-notok-button! + pinentry + (match:substring regex-match 1))) + regex-match)) + +(define (pinentry-setdesc pinentry line) + "SETDESC description" + (let ((setdesc-re (make-regexp "^SETDESC (.+)$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec setdesc-re line)) + (pinentry-set-mesg + set-pinentry-desc! + pinentry + (match:substring regex-match 1))) + regex-match)) + +(define (pinentry-seterror pinentry line) + "SETERROR MESSAGE" + (let ((seterror-re (make-regexp "^SETERROR (.+)$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec seterror-re line)) + (pinentry-set-mesg + set-pinentry-error! + pinentry + (match:substring regex-match 1))) + regex-match)) + +(define (pinentry-setprompt pinentry line) + "SETPROMPT Passphrase:" + (let ((setprompt-re (make-regexp "^SETPROMPT (.+)$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec setprompt-re line)) + (pinentry-set-mesg + set-pinentry-prompt! + pinentry + (match:substring regex-match 1))) + regex-match)) + +(define* (rofi-popup #:key (env '()) + visibility + (prompt ">") + message + buttons + only-match) + "Run external program rofi and fetch the input from the user. + +Keyword arguments: +PROMPT: Text for the prompt, default '>' +ENV: List of environemnt variables in the form (ENVVAR . VALUE) +VISIBILITY: If #t show the input +MESSAGE: Message for the popup window +BUTTONS: List of strings that will be buttons. +ONLY-MATCH: Only allow to match what is listed in the buttons. + +Return the input from the user if succeeded else #f." + (let* ((inputs (if buttons `("echo -e" + ,(format #f "~s" (string-join buttons "\n")) + "|") + '())) + (rofi-sh `("env" + ,(string-join + (map (lambda (x) (format #f "~a=~s" (car x) (cdr x))) env)) + ,(format #f "rofi -dmenu -disable-history -l ~a -i" + (if (list? buttons) (length buttons) 1)) + ,(if (and only-match buttons) "-only-match" "") + ,(if (not buttons) "-input /dev/null" "") + ,(if visibility "" "-password") + ,(format #f "-p ~s" prompt) + ,(if message (format #f "-mesg ~s" message) ""))) + (pipe (open-pipe (string-join (concatenate `(,inputs ,rofi-sh))) OPEN_READ)) + (pass (get-string-all pipe)) + (status (close-pipe pipe))) + (if (and (equal? (status:exit-val status) 0)) pass #f))) + +(define (compose-message pinentry) + "Create the message by combining the error and desc from PINENTRY" + (if (pinentry-error pinentry) + (format #f "~a ~a" + (pinentry-error pinentry) + (pinentry-desc pinentry)) + (pinentry-desc pinentry))) + +(define* (pinentry-getpin pinentry line pin-program #:key (port #t)) + "Get pin using PIN-PROGRAM if LINE is equal to GETPIN." + (let ((getpin-re (make-regexp "^GETPIN$")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec getpin-re line)) + (let ((pass (pin-program #:prompt (pinentry-prompt pinentry) + #:message (compose-message pinentry) + #:visibility (pinentry-visibility pinentry) + #:env `(("DISPLAY" . ,(pinentry-display pinentry)) + ("LC_CTYPE" . ,(pinentry-lc-ctype pinentry)) + ("LC_MESSAGES" . ,(pinentry-lc-messages pinentry)))))) + (if (and pass (not (string-empty? (string-trim-both pass)))) + (begin + (format port "D ~a~!" pass) + (set-pinentry-ok! pinentry #t)) + (begin + (format port "ERR 83886179 Operation cancelled ~%~!") + (set-pinentry-ok! pinentry #f))))) + regex-match)) + +(define* (pinentry-confirm pinentry line confirm-program #:key (port #t)) + (let ((confirm-re (make-regexp "^CONFIRM$")) + (confirm-one-button-re + (make-regexp "^CONFIRM[[:blank:]]+--one-button[[:blank:]]*$")) + (message-re (make-regexp "^MESSAGE$")) + (regex-match #f)) + (cond + ((set-and-return! regex-match (regexp-exec confirm-re line)) + ;; Can probably do this with a pipe in both direction, but + ;; manual warns about deadlocks so sticking with this for now. + (let ((button (confirm-program + #:env `(("DISPLAY" . ,(pinentry-display pinentry)) + ("LC_CTYPE" . ,(pinentry-lc-ctype pinentry)) + ("LC_MESSAGES" . ,(pinentry-lc-messages pinentry))) + #:visibility #t + #:only-match #t + #:buttons `(,(pinentry-ok-button pinentry) + ,(or (pinentry-notok-button pinentry) + (pinentry-cancel-button pinentry))) + #:message (compose-message pinentry)))) + (if (and button + (string=? (string-trim-right button) (pinentry-ok-button pinentry))) + (set-pinentry-ok! pinentry #t) + (begin + (format port "ERR 277 Operation cancelled~%~!") + (set-pinentry-ok! pinentry #f))))) + ((or (set-and-return! regex-match (regexp-exec confirm-one-button-re line)) + (set-and-return! regex-match (regexp-exec message-re line))) + (let ((button (confirm-program + #:env `(("DISPLAY" . ,(pinentry-display pinentry)) + ("LC_CTYPE" . ,(pinentry-lc-ctype pinentry)) + ("LC_MESSAGES" . ,(pinentry-lc-messages pinentry))) + #:visibility #t + #:only-match #t + #:buttons `(,(pinentry-ok-button pinentry)) + #:message (compose-message pinentry)))) + (if (and button + (string=? (string-trim-right button) (pinentry-ok-button pinentry))) + (set-pinentry-ok! pinentry #t) + (begin + (format port "ERR 277 Operation cancelled~%~!") + (set-pinentry-ok! pinentry #f)))))) + regex-match)) + +(define (pinentry-bye pinentry line) + (let ((bye-re (make-regexp "^BYE")) + (regex-match #f)) + (when (set-and-return! regex-match (regexp-exec bye-re line)) + (exit #t)) + regex-match)) + +(define (pinentry-loop pinentry input-port) + (let ((line (get-line input-port))) + (unless (eof-object? line) + (cond + ((pinentry-option pinentry line)) + ((pinentry-getinfo pinentry line)) + ((pinentry-setkeyinfo pinentry line)) + ((pinentry-setdesc pinentry line)) + ((pinentry-setok pinentry line)) + ((pinentry-setnotok pinentry line)) + ((pinentry-setcancel pinentry line)) + ((pinentry-setprompt pinentry line)) + ((pinentry-getpin pinentry line rofi-popup)) + ((pinentry-confirm pinentry line rofi-popup)) + ((pinentry-seterror pinentry line)) + ((pinentry-bye pinentry line)) + (#t (begin + (let ((log (pinentry-logfile pinentry))) + (when (file-port? log) + (format log "Unknown command: ~s~%~!" line))) + ;; GPG_ERR_ASS_UNKNOWN_CMD = 275, + (format #t "ERR 275 Unknown command ~s~%~!" line) + (set-pinentry-ok! pinentry #f)))) + (when (pinentry-ok pinentry) + (format #t "OK~%~!")) + (pinentry-loop pinentry input-port)))) diff --git a/pinentry-rofi.scm b/pinentry-rofi.scm deleted file mode 100644 index 4114eb3..0000000 --- a/pinentry-rofi.scm +++ /dev/null @@ -1,435 +0,0 @@ -;; SPDX-FileCopyrightText: 2016 Quentin "Sardem FF7" Glidic -;; SPDX-FileCopyrightText: 2018-2023 Fredrik Salomonsson -;; -;; SPDX-License-Identifier: GPL-3.0-or-later - -(define-module (pinentry-rofi) - #:use-module (ice-9 popen) - #:use-module (ice-9 textual-ports) - #:use-module (srfi srfi-1) ;; concatenate - #:use-module (srfi srfi-9) ;; For records - #:use-module (ice-9 format) - #:use-module (ice-9 regex) - #:export (make-pinentry - pinentry? - pinentry-ok set-pinentry-ok! - pinentry-prompt set-pinentry-prompt! - pinentry-desc set-pinentry-desc! - pinentry-visibility set-pinentry-visibility! - pinentry-display set-pinentry-display! - pinentry-error set-pinentry-error! - pinentry-logfile set-pinentry-logfile! - pinentry-ok-button set-pinentry-ok-button! - pinentry-notok-button set-pinentry-notok-button! - pinentry-cancel-button set-pinentry-cancel-button! - pinentry-lc-ctype set-pinentry-lc-ctype! - pinentry-lc-messages set-pinentry-lc-messages! - - remove-underline - escape-underscore - - html-newline - html-underline - html-< - string-empty? - - hex->char - input-string - pango-markup - - pinentry-set - - rofi-popup - - pinentry-option - pinentry-getinfo - pinentry-setkeyinfo - pinentry-setok - pinentry-setcancel - pinentry-setnotok - pinentry-setdesc - pinentry-seterror - pinentry-setprompt - pinentry-getpin - pinentry-confirm - pinentry-bye - pinentry-loop)) - -(when (equal? (system-file-name-convention) 'windows) - (format #t "Only support posix systems!") - (exit #f)) - -(define-record-type - (make-pinentry ok prompt ok-button cancel-button display logfile lc-ctype lc-messages) - pinentry? - (ok pinentry-ok set-pinentry-ok!) - (prompt pinentry-prompt set-pinentry-prompt!) - (desc pinentry-desc set-pinentry-desc!) - (visibility pinentry-visibility set-pinentry-visibility!) - (display pinentry-display set-pinentry-display!) - (error pinentry-error set-pinentry-error!) - (logfile pinentry-logfile set-pinentry-logfile!) - (ok-button pinentry-ok-button set-pinentry-ok-button!) - (notok-button pinentry-notok-button set-pinentry-notok-button!) - (cancel-button pinentry-cancel-button set-pinentry-cancel-button!) - (lc-ctype pinentry-lc-ctype set-pinentry-lc-ctype!) - (lc-messages pinentry-lc-messages set-pinentry-lc-messages!)) - -(define-syntax-rule (set-and-return! val expr) - "Set val to expr and return val." - (begin (set! val expr) val)) - -(define (string-empty? str) - "Evaluates to #t if string is empty." - (string=? str "")) - -(define (remove-underline str) - "Replace _ followed by a character with just the character." - (regexp-substitute/global #f "(^|%0A| |\n|[[:blank:]])_([[:alpha:]])" str - 'pre 1 2 'post)) - -(define (escape-underscore str) - "Replace __ followed by a character with _ and said character. -Always call this after `remove-underline' or -`html-underline'." - (regexp-substitute/global #f "(^|%0A| |\n|[[:blank:]])__([[:alpha:]])" str - 'pre 1 "_" 2 'post)) - -(define (html-newline str) - "Replace %0A with " - (regexp-substitute/global #f "%0A" str 'pre " " 'post)) - -(define (html-underline str) - "Underscore followed by a character, underlines that character." - (regexp-substitute/global #f "(^|%0A| |\n|[[:blank:]])_([[:alpha:]])" str - 'pre 1""2"" 'post)) -(define (html-< str) - "Replace < with <" - (regexp-substitute/global #f "<" str 'pre "<" 'post)) - -(define (hex->char str) - "Replace matching'%XX' where X ∈ {0-F} with their respective char." - (regexp-substitute/global - #f "%([[:xdigit:]]{2})" str 'pre - (lambda (m) (integer->char - (string->number - (match:substring m 1) 16))) 'post)) - -(define (pango-markup str) - "Transform string to pango." - (escape-underscore - (html-underline - (hex->char - (html-< - (html-newline str)))))) - -(define (input-string str) - "Transform string to input for rofi. -Input strings does not support pango markup" - (escape-underscore - (remove-underline str))) - -(define* (pinentry-set set-func pinentry label) - "Using SET-FUNC, set the entry in PINENTRY to LABEL." - (set-func pinentry label) - (set-pinentry-ok! pinentry #t)) - -(define (pinentry-set-button set-func pinentry label) - "Using SET-BUTTON-FUNC, set the entry in PINENTRY to LABEL. -LABEL will be transformed using `input-string'" - (pinentry-set set-func pinentry (input-string label))) - -(define (pinentry-set-mesg set-func pinentry label) - "Using SET-FUNC, set the entry in PINENTRY to LABEL. -LABEL will be transformed using `pango-markup'" - (pinentry-set set-func pinentry (pango-markup label))) - -(define (pinentry-option pinentry line) - "Process line if it starts with OPTION. -Return false otherwise. - -Known options are: -grab -ttyname=/dev/pts/1 -ttytype=tmux-256color -lc-ctype=C -lc-messages=C -allow-external-password-cache -default-ok=_OK -default-cancel=_Cancel -default-yes=_Yes -default-no=_No -default-prompt=PIN: -default-pwmngr=_Save in password manager -default-cf-visi=Do you really want to make your passphrase visible on the screen? -default-tt-visi=Make passphrase visible -default-tt-hide=Hide passphrase -touch-file=/run/user/1000/gnupg/S.gpg-agent" - (let ((regex-match #f) - (option-re (make-regexp "^OPTION (.+)$"))) - (cond - ((set-and-return! regex-match - (regexp-exec - (make-regexp "^OPTION[[:blank:]]+default-ok=(.+)$") line)) - (pinentry-set-button - set-pinentry-ok-button! - pinentry - (match:substring regex-match 1))) - ((set-and-return! regex-match - (regexp-exec - (make-regexp "^OPTION[[:blank:]]+default-cancel=(.+)$") line)) - (pinentry-set-button - set-pinentry-cancel-button! - pinentry - (match:substring regex-match 1))) - ((set-and-return! regex-match - (regexp-exec - (make-regexp "^OPTION[[:blank:]]+default-prompt=(.+)$") line)) - (pinentry-set-mesg - set-pinentry-prompt! - pinentry - (match:substring regex-match 1))) - ((set-and-return! regex-match - (regexp-exec - (make-regexp "^OPTION[[:blank:]]+lc-ctype=(.+)$") line)) - (pinentry-set - set-pinentry-lc-ctype! - pinentry - (match:substring regex-match 1))) - ((set-and-return! regex-match - (regexp-exec - (make-regexp "^OPTION[[:blank:]]+lc-messages=(.+)$") line)) - (pinentry-set - set-pinentry-lc-messages! - pinentry - (match:substring regex-match 1))) - ((set-and-return! regex-match (regexp-exec option-re line)))) - regex-match)) - -(define* (pinentry-getinfo pinentry line #:key (port #t)) - "Process line if it starts with GETINFO" - (let ((getinfo-re (make-regexp "^GETINFO (.+)$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec getinfo-re line)) - (let ((info (match:substring regex-match 1))) - (cond - ((string=? info "pid") - (format port "D ~a~%~!" (getpid))))) - (set-pinentry-ok! pinentry #t)) - regex-match)) - -(define (pinentry-setkeyinfo pinentry line) - "SETKEYINFO s/FINGERPRINT" - (let ((setkeyinfo-re (make-regexp "^SETKEYINFO (.+)$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec setkeyinfo-re line)) - (set-pinentry-ok! pinentry #t)) - regex-match)) - -(define (pinentry-setok pinentry line) - "Set ok button label." - (let ((setok-button-re (make-regexp "^SETOK (.+)$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec setok-button-re line)) - (pinentry-set-button - set-pinentry-ok-button! - pinentry - (match:substring regex-match 1))) - regex-match)) - -(define (pinentry-setcancel pinentry line) - "Set cancel button label." - (let ((setcancel-button-re (make-regexp "^SETCANCEL (.+)$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec setcancel-button-re line)) - (pinentry-set-button - set-pinentry-cancel-button! - pinentry - (match:substring regex-match 1))) - regex-match)) - -(define (pinentry-setnotok pinentry line) - "Set notok button label." - (let ((setnotok-button-re (make-regexp "^SETNOTOK (.+)$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec setnotok-button-re line)) - (pinentry-set-button - set-pinentry-notok-button! - pinentry - (match:substring regex-match 1))) - regex-match)) - -(define (pinentry-setdesc pinentry line) - "SETDESC description" - (let ((setdesc-re (make-regexp "^SETDESC (.+)$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec setdesc-re line)) - (pinentry-set-mesg - set-pinentry-desc! - pinentry - (match:substring regex-match 1))) - regex-match)) - -(define (pinentry-seterror pinentry line) - "SETERROR MESSAGE" - (let ((seterror-re (make-regexp "^SETERROR (.+)$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec seterror-re line)) - (pinentry-set-mesg - set-pinentry-error! - pinentry - (match:substring regex-match 1))) - regex-match)) - -(define (pinentry-setprompt pinentry line) - "SETPROMPT Passphrase:" - (let ((setprompt-re (make-regexp "^SETPROMPT (.+)$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec setprompt-re line)) - (pinentry-set-mesg - set-pinentry-prompt! - pinentry - (match:substring regex-match 1))) - regex-match)) - -(define* (rofi-popup #:key (env '()) - visibility - (prompt ">") - message - buttons - only-match) - "Run external program rofi and fetch the input from the user. - -Keyword arguments: -PROMPT: Text for the prompt, default '>' -ENV: List of environemnt variables in the form (ENVVAR . VALUE) -VISIBILITY: If #t show the input -MESSAGE: Message for the popup window -BUTTONS: List of strings that will be buttons. -ONLY-MATCH: Only allow to match what is listed in the buttons. - -Return the input from the user if succeeded else #f." - (let* ((inputs (if buttons `("echo -e" - ,(format #f "~s" (string-join buttons "\n")) - "|") - '())) - (rofi-sh `("env" - ,(string-join - (map (lambda (x) (format #f "~a=~s" (car x) (cdr x))) env)) - ,(format #f "rofi -dmenu -disable-history -l ~a -i" - (if (list? buttons) (length buttons) 1)) - ,(if (and only-match buttons) "-only-match" "") - ,(if (not buttons) "-input /dev/null" "") - ,(if visibility "" "-password") - ,(format #f "-p ~s" prompt) - ,(if message (format #f "-mesg ~s" message) ""))) - (pipe (open-pipe (string-join (concatenate `(,inputs ,rofi-sh))) OPEN_READ)) - (pass (get-string-all pipe)) - (status (close-pipe pipe))) - (if (and (equal? (status:exit-val status) 0)) pass #f))) - -(define (compose-message pinentry) - "Create the message by combining the error and desc from PINENTRY" - (if (pinentry-error pinentry) - (format #f "~a ~a" - (pinentry-error pinentry) - (pinentry-desc pinentry)) - (pinentry-desc pinentry))) - -(define* (pinentry-getpin pinentry line pin-program #:key (port #t)) - "Get pin using PIN-PROGRAM if LINE is equal to GETPIN." - (let ((getpin-re (make-regexp "^GETPIN$")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec getpin-re line)) - (let ((pass (pin-program #:prompt (pinentry-prompt pinentry) - #:message (compose-message pinentry) - #:visibility (pinentry-visibility pinentry) - #:env `(("DISPLAY" . ,(pinentry-display pinentry)) - ("LC_CTYPE" . ,(pinentry-lc-ctype pinentry)) - ("LC_MESSAGES" . ,(pinentry-lc-messages pinentry)))))) - (if (and pass (not (string-empty? (string-trim-both pass)))) - (begin - (format port "D ~a~!" pass) - (set-pinentry-ok! pinentry #t)) - (begin - (format port "ERR 83886179 Operation cancelled ~%~!") - (set-pinentry-ok! pinentry #f))))) - regex-match)) - -(define* (pinentry-confirm pinentry line confirm-program #:key (port #t)) - (let ((confirm-re (make-regexp "^CONFIRM$")) - (confirm-one-button-re - (make-regexp "^CONFIRM[[:blank:]]+--one-button[[:blank:]]*$")) - (message-re (make-regexp "^MESSAGE$")) - (regex-match #f)) - (cond - ((set-and-return! regex-match (regexp-exec confirm-re line)) - ;; Can probably do this with a pipe in both direction, but - ;; manual warns about deadlocks so sticking with this for now. - (let ((button (confirm-program - #:env `(("DISPLAY" . ,(pinentry-display pinentry)) - ("LC_CTYPE" . ,(pinentry-lc-ctype pinentry)) - ("LC_MESSAGES" . ,(pinentry-lc-messages pinentry))) - #:visibility #t - #:only-match #t - #:buttons `(,(pinentry-ok-button pinentry) - ,(or (pinentry-notok-button pinentry) - (pinentry-cancel-button pinentry))) - #:message (compose-message pinentry)))) - (if (and button - (string=? (string-trim-right button) (pinentry-ok-button pinentry))) - (set-pinentry-ok! pinentry #t) - (begin - (format port "ERR 277 Operation cancelled~%~!") - (set-pinentry-ok! pinentry #f))))) - ((or (set-and-return! regex-match (regexp-exec confirm-one-button-re line)) - (set-and-return! regex-match (regexp-exec message-re line))) - (let ((button (confirm-program - #:env `(("DISPLAY" . ,(pinentry-display pinentry)) - ("LC_CTYPE" . ,(pinentry-lc-ctype pinentry)) - ("LC_MESSAGES" . ,(pinentry-lc-messages pinentry))) - #:visibility #t - #:only-match #t - #:buttons `(,(pinentry-ok-button pinentry)) - #:message (compose-message pinentry)))) - (if (and button - (string=? (string-trim-right button) (pinentry-ok-button pinentry))) - (set-pinentry-ok! pinentry #t) - (begin - (format port "ERR 277 Operation cancelled~%~!") - (set-pinentry-ok! pinentry #f)))))) - regex-match)) - -(define (pinentry-bye pinentry line) - (let ((bye-re (make-regexp "^BYE")) - (regex-match #f)) - (when (set-and-return! regex-match (regexp-exec bye-re line)) - (exit #t)) - regex-match)) - -(define (pinentry-loop pinentry input-port) - (let ((line (get-line input-port))) - (unless (eof-object? line) - (cond - ((pinentry-option pinentry line)) - ((pinentry-getinfo pinentry line)) - ((pinentry-setkeyinfo pinentry line)) - ((pinentry-setdesc pinentry line)) - ((pinentry-setok pinentry line)) - ((pinentry-setnotok pinentry line)) - ((pinentry-setcancel pinentry line)) - ((pinentry-setprompt pinentry line)) - ((pinentry-getpin pinentry line rofi-popup)) - ((pinentry-confirm pinentry line rofi-popup)) - ((pinentry-seterror pinentry line)) - ((pinentry-bye pinentry line)) - (#t (begin - (let ((log (pinentry-logfile pinentry))) - (when (file-port? log) - (format log "Unknown command: ~s~%~!" line))) - ;; GPG_ERR_ASS_UNKNOWN_CMD = 275, - (format #t "ERR 275 Unknown command ~s~%~!" line) - (set-pinentry-ok! pinentry #f)))) - (when (pinentry-ok pinentry) - (format #t "OK~%~!")) - (pinentry-loop pinentry input-port)))) diff --git a/tests/pinentry-rofi.bats b/tests/pinentry-rofi.bats deleted file mode 100755 index 8c7748e..0000000 --- a/tests/pinentry-rofi.bats +++ /dev/null @@ -1,457 +0,0 @@ -#!/usr/bin/env bats - -## (define-module (tests-pinentry-rofi) -## #:use-module (srfi srfi-64) -## #:use-module (ice-9 popen) -## #:use-module (ice-9 textual-ports) -## #:use-module (pinentry-rofi)) - -# XXX (test-begin "pinentry-rofi") - -# XXX ;; (test-begin "pinentry") -# XXX (let ((pinentry (make-pinentry #t "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry? pinentry)) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) -# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) -# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) -# XXX (test-equal ":1" (pinentry-display pinentry)) -# XXX (test-equal "test.log" (pinentry-logfile pinentry)) -# XXX (test-assert (not (pinentry-notok-button pinentry))) -# XXX (test-assert (not (pinentry-visibility pinentry))) -# XXX (test-assert (not (pinentry-error pinentry)))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (not (pinentry-ok pinentry)))) -# XXX -# XXX ;; (test-end "pinentry") -# XXX -# XXX ;; (test-begin "utils") -# XXX -# XXX (test-equal "Ok" (remove-underline "_Ok")) -# XXX (test-equal " Ok" (remove-underline " _Ok")) -# XXX (test-equal "foo_bar" (remove-underline "foo_bar")) -# XXX (test-equal "foo__bar" (remove-underline "foo__bar")) -# XXX (test-equal " __Ok" (remove-underline " __Ok")) -# XXX (test-equal "__Ok" (remove-underline "__Ok")) -# XXX (test-equal "Ok%0ACancel" (remove-underline "_Ok%0A_Cancel")) -# XXX (test-equal "Ok Cancel" (remove-underline "_Ok _Cancel")) -# XXX -# XXX (test-equal "_Ok" (escape-underscore "_Ok")) -# XXX (test-equal " _Ok" (escape-underscore " _Ok")) -# XXX (test-equal "foo_bar" (escape-underscore "foo_bar")) -# XXX (test-equal "foo__bar" (escape-underscore "foo__bar")) -# XXX (test-equal " _Ok" (escape-underscore " __Ok")) -# XXX (test-equal "_Ok" (escape-underscore "__Ok")) -# XXX (test-equal "_Ok%0A_Cancel" (escape-underscore "__Ok%0A__Cancel")) -# XXX (test-equal "_Ok _Cancel" (escape-underscore "__Ok __Cancel")) -# XXX -# XXX (test-assert (string-empty? "")) -# XXX (test-assert (not (string-empty? "foo"))) -# XXX ;; (test-end "utils") -# XXX -# XXX (test-equal "This is one line\nThis is another%OA" -# XXX (hex->char "%54his is one line%0AThis is another%OA")) -# XXX -# XXX ;; (test-begin "html") -# XXX (test-equal "%54his is one line This is another%OA" -# XXX (html-newline "%54his is one line%0AThis is another%OA")) -# XXX (test-equal "%54his is one line\nThis is another%OA" -# XXX (html-newline "%54his is one line\nThis is another%OA")) -# XXX -# XXX (test-equal "Ok" (html-underline "_Ok")) -# XXX (test-equal " Ok" (html-underline " _Ok")) -# XXX (test-equal "foo_bar" (html-underline "foo_bar")) -# XXX (test-equal "foo__bar" (html-underline "foo__bar")) -# XXX (test-equal " __Ok" (html-underline " __Ok")) -# XXX (test-equal "__Ok" (html-underline "__Ok")) -# XXX (test-equal "Ok%0ACancel" (html-underline "_Ok%0A_Cancel")) -# XXX (test-equal "Ok Cancel" (html-underline "_Ok _Cancel")) -# XXX -# XXX ;; (test-end "html") -# XXX -# XXX (test-equal "This is one line This is another%OA" -# XXX (pango-markup "_%54his is one line%0A_This is another%OA")) -# XXX -# XXX (test-equal "Ok\nCancel" -# XXX (input-string "_Ok\nCancel")) -# XXX -# XXX (test-equal "Ok\n_Cancel" -# XXX (input-string "_Ok\n__Cancel")) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (pinentry-set set-pinentry-notok-button! pinentry "Not ok") -# XXX (test-equal "Not ok" (pinentry-notok-button pinentry)) -# XXX (test-assert (pinentry-ok pinentry))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-error #t (pinentry-set pinentry-notok-button pinentry "Not ok"))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-option pinentry "OPTION default-ok=Okay")) -# XXX (test-equal "Okay" (pinentry-ok-button pinentry)) -# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) -# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) -# XXX (test-equal "C" (pinentry-lc-ctype pinentry)) -# XXX (test-equal "C" (pinentry-lc-messages pinentry)) -# XXX (test-assert (pinentry-ok pinentry))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-option pinentry "OPTION default-cancel=No")) -# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) -# XXX (test-equal "No" (pinentry-cancel-button pinentry)) -# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) -# XXX (test-equal "C" (pinentry-lc-ctype pinentry)) -# XXX (test-equal "C" (pinentry-lc-messages pinentry)) -# XXX (test-assert (pinentry-ok pinentry))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-option pinentry "OPTION default-prompt=Password:")) -# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) -# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) -# XXX (test-equal "Password:" (pinentry-prompt pinentry)) -# XXX (test-equal "C" (pinentry-lc-ctype pinentry)) -# XXX (test-equal "C" (pinentry-lc-messages pinentry)) -# XXX (test-assert (pinentry-ok pinentry))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-option pinentry "OPTION lc-ctype=en_US.UTF-8")) -# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) -# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) -# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) -# XXX (test-equal "en_US.UTF-8" (pinentry-lc-ctype pinentry)) -# XXX (test-equal "C" (pinentry-lc-messages pinentry)) -# XXX (test-assert (pinentry-ok pinentry))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-option pinentry "OPTION lc-messages=en_US.UTF-8")) -# XXX (test-equal "Ok" (pinentry-ok-button pinentry)) -# XXX (test-equal "Cancel" (pinentry-cancel-button pinentry)) -# XXX (test-equal "Prompt" (pinentry-prompt pinentry)) -# XXX (test-equal "C" (pinentry-lc-ctype pinentry)) -# XXX (test-equal "en_US.UTF-8" (pinentry-lc-messages pinentry)) -# XXX (test-assert (pinentry-ok pinentry))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-option pinentry "OPTION foo bar"))) -# XXX -# XXX (let ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (not (pinentry-option pinentry " OPTION foo bar"))) -# XXX (test-assert (not (pinentry-option pinentry "OPTION"))) -# XXX (test-assert (not (pinentry-option pinentry "Foo")))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C")) -# XXX (output "") -# XXX (fake-port (make-soft-port -# XXX (vector -# XXX (lambda (c) (set! output (string-append output c))) -# XXX (lambda (s) (set! output (string-append output s))) -# XXX (lambda () #t) -# XXX #f -# XXX (lambda () #t)) -# XXX "w"))) -# XXX (test-assert (pinentry-getinfo pinentry "GETINFO pid" #:port fake-port)) -# XXX (test-equal (format #f "D ~a\n" (getpid)) output) -# XXX (test-assert (pinentry-getinfo pinentry "GETINFO foo bar")) -# XXX (test-assert (not (pinentry-getinfo pinentry " GETINFO foo bar"))) -# XXX (test-assert (not (pinentry-getinfo pinentry "GETINFO"))) -# XXX (test-assert (not (pinentry-getinfo pinentry "Foo")))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-setkeyinfo pinentry "SETKEYINFO Foo")) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-assert (not (pinentry-setkeyinfo pinentry " SETKEYINFO foo bar"))) -# XXX (test-assert (not (pinentry-setkeyinfo pinentry "SETKEYINFO"))) -# XXX (test-assert (not (pinentry-setkeyinfo pinentry "Foo")))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-setok pinentry "SETOK Foo")) -# XXX (test-equal "Foo" (pinentry-ok-button pinentry)) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-assert (pinentry-setok pinentry "SETOK _Ok okay")) -# XXX (test-equal "Ok okay" (pinentry-ok-button pinentry)) -# XXX (test-assert (not (pinentry-setok pinentry " SETOK foo bar"))) -# XXX (test-equal "Ok okay" (pinentry-ok-button pinentry)) -# XXX (test-assert (not (pinentry-setok pinentry "SETOK"))) -# XXX (test-equal "Ok okay" (pinentry-ok-button pinentry)) -# XXX (test-assert (not (pinentry-setok pinentry "Foo"))) -# XXX (test-equal "Ok okay" (pinentry-ok-button pinentry))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-setnotok pinentry "SETNOTOK Foo")) -# XXX (test-equal "Foo" (pinentry-notok-button pinentry)) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-assert (pinentry-setnotok pinentry "SETNOTOK Not _Ok")) -# XXX (test-equal "Not Ok" (pinentry-notok-button pinentry)) -# XXX (test-assert (not (pinentry-setnotok pinentry " SETNOTOK foo bar"))) -# XXX (test-equal "Not Ok" (pinentry-notok-button pinentry)) -# XXX (test-assert (not (pinentry-setnotok pinentry "SETNOTOK"))) -# XXX (test-equal "Not Ok" (pinentry-notok-button pinentry)) -# XXX (test-assert (not (pinentry-setnotok pinentry "Foo"))) -# XXX (test-equal "Not Ok" (pinentry-notok-button pinentry))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-setcancel pinentry "SETCANCEL Foo")) -# XXX (test-equal "Foo" (pinentry-cancel-button pinentry)) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-assert (pinentry-setcancel pinentry "SETCANCEL _Abort")) -# XXX (test-equal "Abort" (pinentry-cancel-button pinentry)) -# XXX (test-assert (not (pinentry-setcancel pinentry " SETCANCEL foo bar"))) -# XXX (test-equal "Abort" (pinentry-cancel-button pinentry)) -# XXX (test-assert (not (pinentry-setcancel pinentry "SETCANCEL"))) -# XXX (test-equal "Abort" (pinentry-cancel-button pinentry)) -# XXX (test-assert (not (pinentry-setcancel pinentry "Foo"))) -# XXX (test-equal "Abort" (pinentry-cancel-button pinentry))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Desc" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-setdesc pinentry "SETDESC Foo")) -# XXX (test-equal "Foo" (pinentry-desc pinentry)) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-assert (pinentry-setdesc pinentry "SETDESC _%54his is a description%0A_On two lines")) -# XXX (test-equal "This is a description On two lines" (pinentry-desc pinentry)) -# XXX (test-assert (not (pinentry-setdesc pinentry " SETDESC foo bar"))) -# XXX (test-equal "This is a description On two lines" (pinentry-desc pinentry)) -# XXX (test-assert (not (pinentry-setdesc pinentry "SETDESC"))) -# XXX (test-equal "This is a description On two lines" (pinentry-desc pinentry)) -# XXX (test-assert (not (pinentry-setdesc pinentry "Foo"))) -# XXX (test-equal "This is a description On two lines" (pinentry-desc pinentry))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Error" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-seterror pinentry "SETERROR Foo")) -# XXX (test-equal "Foo" (pinentry-error pinentry)) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-assert (pinentry-seterror pinentry "SETERROR _%54his is an error%0A_On two lines")) -# XXX (test-equal "This is an error On two lines" (pinentry-error pinentry)) -# XXX (test-assert (not (pinentry-seterror pinentry " SETERROR foo bar"))) -# XXX (test-equal "This is an error On two lines" (pinentry-error pinentry)) -# XXX (test-assert (not (pinentry-seterror pinentry "SETERROR"))) -# XXX (test-equal "This is an error On two lines" (pinentry-error pinentry)) -# XXX (test-assert (not (pinentry-seterror pinentry "Foo"))) -# XXX (test-equal "This is an error On two lines" (pinentry-error pinentry))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Prompt" ":1" "test.log" "C" "C"))) -# XXX (test-assert (pinentry-setprompt pinentry "SETPROMPT Foo")) -# XXX (test-equal "Foo" (pinentry-prompt pinentry)) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-assert (pinentry-setprompt pinentry "SETPROMPT _%54his is a prompt%0A_On two lines")) -# XXX (test-equal "This is a prompt On two lines" (pinentry-prompt pinentry)) -# XXX (test-assert (not (pinentry-setprompt pinentry " SETPROMPT foo bar"))) -# XXX (test-equal "This is a prompt On two lines" (pinentry-prompt pinentry)) -# XXX (test-assert (not (pinentry-setprompt pinentry "SETPROMPT"))) -# XXX (test-equal "This is a prompt On two lines" (pinentry-prompt pinentry)) -# XXX (test-assert (not (pinentry-setprompt pinentry "Foo"))) -# XXX (test-equal "This is a prompt On two lines" (pinentry-prompt pinentry))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Prompt" ":1" "test.log" "C" "C"))) -# XXX (test-error "(quit #t)" (pinentry-bye pinentry "BYE")) -# XXX (test-assert (not (pinentry-bye pinentry "Hej då")))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "en_US.UTF-8")) -# XXX (output "") -# XXX (fake-port (make-soft-port -# XXX (vector -# XXX (lambda (c) (set! output (string-append output c))) -# XXX (lambda (s) (set! output (string-append output s))) -# XXX (lambda () #t) -# XXX #f -# XXX (lambda () #t)) -# XXX "w")) -# XXX (description "This is a description") -# XXX (error "Something went wrong") -# XXX (display ":1")) -# XXX (set-pinentry-desc! pinentry description) -# XXX (set-pinentry-display! pinentry display) -# XXX (test-assert (pinentry-getpin pinentry "GETPIN" -# XXX (lambda* (#:key (env '()) -# XXX visibility -# XXX (prompt ">") -# XXX message -# XXX buttons -# XXX only-match) -# XXX (test-equal "Prompt" prompt) -# XXX (test-equal description message) -# XXX (test-assert (not visibility)) -# XXX (test-assert (not only-match)) -# XXX (test-assert (not buttons)) -# XXX (test-equal `(("DISPLAY" . ,display) -# XXX ("LC_CTYPE" . "C") -# XXX ("LC_MESSAGES" . "en_US.UTF-8")) -# XXX env) -# XXX "password") -# XXX #:port fake-port)) -# XXX (test-equal (format #f "D password") output) -# XXX (set-pinentry-error! pinentry error) -# XXX (set! output "") -# XXX (test-assert (pinentry-getpin pinentry "GETPIN" -# XXX (lambda* (#:key (env '()) -# XXX visibility -# XXX (prompt ">") -# XXX message -# XXX buttons -# XXX only-match) -# XXX (test-equal "Prompt" prompt) -# XXX (test-equal (format #f "~a ~a" error description) -# XXX message) -# XXX (test-assert (not visibility)) -# XXX (test-assert (not only-match)) -# XXX (test-assert (not buttons)) -# XXX (test-equal `(("DISPLAY" . ,display) -# XXX ("LC_CTYPE" . "C") -# XXX ("LC_MESSAGES" . "en_US.UTF-8")) -# XXX env) -# XXX "password") -# XXX #:port fake-port)) -# XXX (test-equal (format #f "D password") output) -# XXX (set! output "") -# XXX (test-assert (pinentry-getpin pinentry "GETPIN" -# XXX (lambda* (#:key (env '()) -# XXX visibility -# XXX (prompt ">") -# XXX message -# XXX buttons -# XXX only-match) -# XXX (test-equal "Prompt" prompt) -# XXX (test-equal (format #f "~a ~a" error description) -# XXX message) -# XXX (test-assert (not visibility)) -# XXX (test-assert (not only-match)) -# XXX (test-assert (not buttons)) -# XXX (test-equal `(("DISPLAY" . ,display) -# XXX ("LC_CTYPE" . "C") -# XXX ("LC_MESSAGES" . "en_US.UTF-8")) -# XXX env) -# XXX "") -# XXX #:port fake-port)) -# XXX (test-equal (format #f "ERR 83886179 Operation cancelled \n") output) -# XXX (set! output "") -# XXX (test-assert (pinentry-getpin pinentry "GETPIN" -# XXX (lambda* (#:key (env '()) -# XXX visibility -# XXX (prompt ">") -# XXX message -# XXX buttons -# XXX only-match) -# XXX (test-equal "Prompt" prompt) -# XXX (test-equal (format #f "~a ~a" error description) -# XXX message) -# XXX (test-assert (not visibility)) -# XXX (test-assert (not only-match)) -# XXX (test-assert (not buttons)) -# XXX (test-equal `(("DISPLAY" . ,display) -# XXX ("LC_CTYPE" . "C") -# XXX ("LC_MESSAGES" . "en_US.UTF-8")) -# XXX env) -# XXX " ") -# XXX #:port fake-port)) -# XXX (test-equal (format #f "ERR 83886179 Operation cancelled \n") output) -# XXX (test-assert (not (pinentry-getinfo pinentry " GETPIN"))) -# XXX (test-assert (not (pinentry-getinfo pinentry "Foo")))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "en_US.UTF-8")) -# XXX (description "This is a description") -# XXX (error "Something went wrong") -# XXX (display ":1")) -# XXX (set-pinentry-desc! pinentry description) -# XXX (set-pinentry-display! pinentry display) -# XXX (test-assert (pinentry-confirm pinentry "CONFIRM" -# XXX (lambda* (#:key (env '()) -# XXX visibility -# XXX (prompt ">") -# XXX message -# XXX buttons -# XXX only-match) -# XXX (test-equal ">" prompt) -# XXX (test-equal description message) -# XXX (test-assert visibility) -# XXX (test-assert only-match) -# XXX (test-equal `("Ok" "Cancel") buttons) -# XXX (test-equal `(("DISPLAY" . ,display) -# XXX ("LC_CTYPE" . "C") -# XXX ("LC_MESSAGES" . "en_US.UTF-8")) -# XXX env) -# XXX "Ok"))) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (set-pinentry-error! pinentry error) -# XXX (let* ((output "") -# XXX (fake-port (make-soft-port -# XXX (vector -# XXX (lambda (c) (set! output (string-append output c))) -# XXX (lambda (s) (set! output (string-append output s))) -# XXX (lambda () #t) -# XXX #f -# XXX (lambda () #t)) -# XXX "w"))) -# XXX (test-assert (pinentry-confirm -# XXX pinentry -# XXX "CONFIRM" -# XXX (lambda* (#:key (env '()) -# XXX visibility -# XXX (prompt ">") -# XXX message -# XXX buttons -# XXX only-match) -# XXX (test-equal ">" prompt) -# XXX (test-equal (format #f "~a ~a" error description) -# XXX message) -# XXX (test-assert visibility) -# XXX (test-assert only-match) -# XXX (test-equal `("Ok" "Cancel") buttons) -# XXX (test-equal `(("DISPLAY" . ,display) -# XXX ("LC_CTYPE" . "C") -# XXX ("LC_MESSAGES" . "en_US.UTF-8")) -# XXX env) -# XXX "Cancel") -# XXX #:port fake-port)) -# XXX (test-equal (format #f "ERR 277 Operation cancelled\n") output)) -# XXX (test-assert (not (pinentry-ok pinentry))) -# XXX (test-assert (not (pinentry-getinfo pinentry " CONFIRM"))) -# XXX (test-assert (not (pinentry-getinfo pinentry "Foo")))) -# XXX -# XXX (let* ((pinentry (make-pinentry #f "Prompt" "Ok" "Cancel" ":1" "test.log" "C" "en_US.UTF-8")) -# XXX (description "This is a description") -# XXX (display ":1")) -# XXX (set-pinentry-desc! pinentry description) -# XXX (set-pinentry-display! pinentry display) -# XXX (test-assert (pinentry-confirm pinentry "CONFIRM --one-button" -# XXX (lambda* (#:key (env '()) -# XXX visibility -# XXX (prompt ">") -# XXX message -# XXX buttons -# XXX only-match) -# XXX (test-equal ">" prompt) -# XXX (test-equal description message) -# XXX (test-assert visibility) -# XXX (test-assert only-match) -# XXX (test-equal `("Ok") buttons) -# XXX (test-equal `(("DISPLAY" . ,display) -# XXX ("LC_CTYPE" . "C") -# XXX ("LC_MESSAGES" . "en_US.UTF-8")) -# XXX env) -# XXX "Ok"))) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (set-pinentry-ok! pinentry #f) -# XXX (test-assert (pinentry-confirm pinentry "MESSAGE" -# XXX (lambda* (#:key (env '()) -# XXX visibility -# XXX (prompt ">") -# XXX message -# XXX buttons -# XXX only-match) -# XXX (test-equal ">" prompt) -# XXX (test-equal description message) -# XXX (test-assert visibility) -# XXX (test-assert only-match) -# XXX (test-equal `("Ok") buttons) -# XXX (test-equal `(("DISPLAY" . ,display) -# XXX ("LC_CTYPE" . "C") -# XXX ("LC_MESSAGES" . "en_US.UTF-8")) -# XXX env) -# XXX "Ok"))) -# XXX (test-assert (pinentry-ok pinentry)) -# XXX (test-assert (not (pinentry-getinfo pinentry " CONFIRM --one-button"))) -# XXX (test-assert (not (pinentry-getinfo pinentry "MESSAGE --one-button"))) -# XXX (test-assert (not (pinentry-getinfo pinentry " MESSAGE"))) -# XXX (test-assert (not (pinentry-getinfo pinentry "Foo")))) -# XXX -# XXX (test-end "pinentry-rofi") -- cgit