From f7217eebf8c8715c61d09ea7fb7cb8fa4428ae87 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 10 Aug 1999 16:54:57 +0000
Subject: [PATCH] Eliminate use of krypt and the ".ky" file suffix. Change all
encryption commands to use Blowfish, and also to be more paranoid about
eliminating passphrases and plaintext after use.
---
v7/src/edwin/comint.scm | 5 +-
v7/src/edwin/dired.scm | 86 ++++++++--------------------
v7/src/edwin/dosfile.scm | 96 ++-----------------------------
v7/src/edwin/edwin.pkg | 8 +--
v7/src/edwin/filcom.scm | 120 ++++++++++++++++++++++++++-------------
v7/src/edwin/fileio.scm | 54 +++++++++++++++++-
v7/src/edwin/rmail.scm | 5 +-
v7/src/edwin/unix.scm | 108 ++++-------------------------------
8 files changed, 183 insertions(+), 299 deletions(-)
diff --git a/v7/src/edwin/comint.scm b/v7/src/edwin/comint.scm
index 9fb0164fd..b03863d6b 100644
--- a/v7/src/edwin/comint.scm
+++ b/v7/src/edwin/comint.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: comint.scm,v 1.28 1999/01/02 06:11:34 cph Exp $
+$Id: comint.scm,v 1.29 1999/08/10 16:54:57 cph Exp $
Copyright (c) 1991-1999 Massachusetts Institute of Technology
@@ -227,7 +227,8 @@ String is not saved on comint input history list.
Security bug: your string can still be temporarily recovered with
\\[view-lossage]."
()
- (lambda () (send-invisible (prompt-for-password "Non-echoed text: "))))
+ (lambda ()
+ (call-with-pass-phrase "Non-echoed text" send-invisible)))
(define (send-invisible string)
(process-send-string (current-process) string)
diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm
index 1ab1f5e05..3291964ee 100644
--- a/v7/src/edwin/dired.scm
+++ b/v7/src/edwin/dired.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: dired.scm,v 1.169 1999/01/28 03:59:47 cph Exp $
+;;; $Id: dired.scm,v 1.170 1999/08/10 16:54:51 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
;;;
@@ -102,7 +102,7 @@ Space and Rubout can be used to move down and up by lines."
(define-key 'dired #\~ 'dired-flag-backup-files)
(define-key 'dired #\C 'dired-do-copy)
-(define-key 'dired #\K 'dired-krypt-file)
+(define-key 'dired #\K 'dired-encrypt/decrypt-file)
(define-key 'dired #\R 'dired-do-rename)
(define-key 'dired #\c-d 'dired-flag-file-deletion)
@@ -659,67 +659,31 @@ When renaming multiple or marked files, you specify a directory."
(mark-temporary! (cdr filename)))
filenames)))
-;;;; Krypt File
+;;;; Encrypt/Decrypt File
-(define-command dired-krypt-file
- "Krypt/unkrypt a file. If the file ends in KY, assume it is already
-krypted and unkrypt it. Otherwise, krypt it."
- '()
- (lambda ()
- (load-option 'krypt)
+(define-command dired-encrypt/decrypt-file
+ "Encrypt/Decrypt a file.
+Decrypts if the file's suffix is recognized as a known encryption type.
+Otherwise encrypts using Blowfish.
+Prefix arg means treat the plaintext file as binary data (ignored on unix)."
+ "P"
+ (lambda (binary-plaintext?)
(let ((pathname (dired-current-pathname)))
- (if (and (pathname-type pathname)
- (string=? (pathname-type pathname) "KY"))
- (dired-decrypt-file pathname)
- (dired-encrypt-file pathname)))))
-
-(define (dired-decrypt-file pathname)
- (let ((the-encrypted-file
- (with-input-from-file pathname
- (lambda ()
- (read-string (char-set)))))
- (password
- (prompt-for-password "Password: ")))
- (let ((the-string
- (decrypt the-encrypted-file password
- (lambda ()
- (editor-beep)
- (message "krypt: Password error!")
- 'FAIL)
- (lambda (x)
- x
- (editor-beep)
- (message "krypt: Checksum error!")
- 'FAIL))))
- (if (not (eq? the-string 'FAIL))
- (let ((new-name (pathname-new-type pathname false)))
- (with-output-to-file new-name
- (lambda ()
- (write-string the-string)))
- (delete-file pathname)
- (dired-redisplay new-name))))))
-
-(define (dired-encrypt-file pathname)
- (let ((the-file-string
- (with-input-from-file pathname
- (lambda ()
- (read-string (char-set)))))
- (password
- (prompt-for-confirmed-password)))
- (let ((the-encrypted-string
- (encrypt the-file-string password)))
- (let ((new-name
- (pathname-new-type
- pathname
- (let ((old-type (pathname-type pathname)))
- (if (not old-type)
- "KY"
- (string-append old-type ".KY"))))))
- (with-output-to-file new-name
- (lambda ()
- (write-string the-encrypted-string)))
- (delete-file pathname)
- (dired-redisplay new-name)))))
+ (let ((type (pathname-type pathname)))
+ (cond ((equal? "bf" type)
+ (dired-blowfish-decrypt-file pathname binary-plaintext?))
+ (else
+ (dired-blowfish-encrypt-file pathname binary-plaintext?)))))))
+
+(define (dired-blowfish-encrypt-file from binary-plaintext?)
+ (let ((to (string-append (->namestring from) ".bf")))
+ (blowfish-encrypt-file from to binary-plaintext? #t)
+ (dired-redisplay to)))
+
+(define (dired-blowfish-decrypt-file from binary-plaintext?)
+ (let ((to (pathname-new-type from #f)))
+ (blowfish-decrypt-file from to binary-plaintext? #t)
+ (dired-redisplay to)))
;;;; List Directory
diff --git a/v7/src/edwin/dosfile.scm b/v7/src/edwin/dosfile.scm
index 3da58f043..188b62345 100644
--- a/v7/src/edwin/dosfile.scm
+++ b/v7/src/edwin/dosfile.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: dosfile.scm,v 1.29 1999/08/09 18:19:15 cph Exp $
+;;; $Id: dosfile.scm,v 1.30 1999/08/10 16:54:41 cph Exp $
;;;
;;; Copyright (c) 1994-1999 Massachusetts Institute of Technology
;;;
@@ -495,20 +495,14 @@ Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'."
. ,(lambda (pathname mark visit?)
visit?
(read-compressed-file "gzip -d" pathname mark)))
- (,(read/write-encrypted-file? #f)
- . ,(lambda (pathname mark visit?)
- visit?
- (read-encrypted-file pathname mark)))))
+ ,@(os-independent/read-file-methods)))
(define (os/write-file-methods)
`((,read/write-compressed-file?
. ,(lambda (region pathname visit?)
visit?
(write-compressed-file "gzip" region pathname)))
- (,(read/write-encrypted-file? #t)
- . ,(lambda (region pathname visit?)
- visit?
- (write-encrypted-file region pathname)))))
+ ,@(os-independent/write-file-methods)))
(define (os/alternate-pathnames group pathname)
(if (dos/fs-long-filenames? pathname)
@@ -516,14 +510,7 @@ Switches may be concatenated, e.g. `-lt' is equivalent to `-l -t'."
(not (equal? "gz" (pathname-type pathname))))
(list (string-append (->namestring pathname) ".gz"))
'())
- (if (and (ref-variable enable-encrypted-files group)
- (not (equal? "bf" (pathname-type pathname))))
- (list (string-append (->namestring pathname) ".bf"))
- '())
- (if (and (ref-variable enable-encrypted-files group)
- (not (equal? "ky" (pathname-type pathname))))
- (list (string-append (->namestring pathname) ".ky"))
- '()))
+ (os-independent/alternate-pathnames group pathname))
'()))
;;;; Compressed Files
@@ -583,77 +570,4 @@ filename suffix \".gz\"."
"[unknown]"
write-compressed-file
(list region pathname)))
- (append-message "done"))
-
-;;;; Encrypted files
-
-(define-variable enable-encrypted-files
- "If true, encrypted files are automatically decrypted when read,
-and recrypted when written. An encrypted file is identified by the
-filename suffixes \".bf\" and \".ky\"."
- #t
- boolean?)
-
-(define ((read/write-encrypted-file? write?) group pathname)
- (and (ref-variable enable-encrypted-files group)
- (or (and (equal? "bf" (pathname-type pathname))
- (blowfish-available?)
- (or write? (blowfish-file? pathname)))
- (equal? "ky" (pathname-type pathname)))))
-
-(define (read-encrypted-file pathname mark)
- (let ((password (prompt-for-password "Pass phrase"))
- (type (pathname-type pathname)))
- (message "Decrypting file " (->namestring pathname) "...")
- (cond ((equal? "bf" type)
- (call-with-binary-input-file pathname
- (lambda (input)
- (call-with-output-mark mark
- (lambda (output)
- (blowfish-encrypt-port input output (md5 password)
- (read-blowfish-file-header input)
- #f))))))
- ((or (equal? "ky" type) (equal? "KY" type))
- (insert-string (let ((the-encrypted-file
- (call-with-binary-input-file pathname
- (lambda (port)
- (read-string (char-set) port)))))
- (decrypt the-encrypted-file password
- (lambda ()
- (kill-buffer (mark-buffer mark))
- (editor-error "krypt: Password error!"))
- (lambda (x)
- (editor-beep)
- (message "krypt: Checksum error!")
- x)))
- mark)))
- ;; Disable auto-save here since we don't want to
- ;; auto-save the unencrypted contents of the
- ;; encrypted file.
- (define-variable-local-value! (mark-buffer mark)
- (ref-variable-object auto-save-default)
- #f)
- (append-message "done")))
-
-(define (write-encrypted-file region pathname)
- (let ((password (prompt-for-confirmed-password))
- (type (pathname-type pathname)))
- (message "Encrypting file " (->namestring pathname) "...")
- (cond ((equal? "bf" type)
- (let ((input
- (make-buffer-input-port (region-start region)
- (region-end region))))
- (call-with-binary-output-file pathname
- (lambda (output)
- (blowfish-encrypt-port input output (md5 password)
- (write-blowfish-file-header output)
- #t)))))
- ((or (equal? "ky" type) (equal? "KY" type))
- (let ((the-encrypted-file
- (encrypt (extract-string (region-start region)
- (region-end region))
- password)))
- (call-with-binary-output-file pathname
- (lambda (port)
- (write-string the-encrypted-file port))))))
- (append-message "done")))
\ No newline at end of file
+ (append-message "done"))
\ No newline at end of file
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index e37fc4763..5651d041c 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.238 1999/05/13 03:06:39 cph Exp $
+$Id: edwin.pkg,v 1.239 1999/08/10 16:54:44 cph Exp $
Copyright (c) 1989-1999 Massachusetts Institute of Technology
@@ -444,6 +444,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
(files "prompt")
(parent (edwin))
(export (edwin)
+ call-with-confirmed-pass-phrase
+ call-with-pass-phrase
completion-message
edwin-command$exit-minibuffer
edwin-command$exit-minibuffer-yes-or-no
@@ -467,10 +469,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
prompt-for-command
prompt-for-completed-string
prompt-for-confirmation?
- prompt-for-confirmed-password
prompt-for-key
prompt-for-number
- prompt-for-password
prompt-for-string
prompt-for-string-table-name
prompt-for-string-table-value
@@ -652,12 +652,12 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
edwin-command$dired-do-copy
edwin-command$dired-do-deletions
edwin-command$dired-do-rename
+ edwin-command$dired-encrypt/decrypt-file
edwin-command$dired-find-file
edwin-command$dired-find-file-other-window
edwin-command$dired-flag-auto-save-files
edwin-command$dired-flag-backup-files
edwin-command$dired-flag-file-deletion
- edwin-command$dired-krypt-file
edwin-command$dired-mark
edwin-command$dired-next-line
edwin-command$dired-other-window
diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm
index 95d64d2fd..9d3cf86ba 100644
--- a/v7/src/edwin/filcom.scm
+++ b/v7/src/edwin/filcom.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: filcom.scm,v 1.203 1999/08/09 18:19:24 cph Exp $
+;;; $Id: filcom.scm,v 1.204 1999/08/10 16:54:34 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
;;;
@@ -613,41 +613,22 @@ Prompts for the plaintext and ciphertext filenames.
Prefix arg means treat the plaintext file as binary data.
Deletes the plaintext file after encryption."
(lambda ()
- (if (not (blowfish-available?))
- (editor-error "Blowfish encryption not supported on this system"))
+ (guarantee-blowfish-available)
(let ((from (prompt-for-existing-file "Encrypt file (plaintext)" #f)))
(let ((to
(prompt-for-file
"Encrypt file to (ciphertext)"
(list (string-append (->namestring from) ".bf")))))
(list from to (command-argument)))))
- (lambda (from to binary?)
- (if (or (not (file-exists? to))
- (prompt-for-yes-or-no?
- (string-append "File "
- (->namestring to)
- " already exists; overwrite")))
- (begin
- (let ((password (prompt-for-confirmed-password)))
- ((if binary?
- call-with-binary-input-file
- call-with-input-file)
- from
- (lambda (input)
- (call-with-binary-output-file to
- (lambda (output)
- (blowfish-encrypt-port input output (md5 password)
- (write-blowfish-file-header output)
- #t))))))
- (delete-file from)))))
+ (lambda (from to binary-plaintext?)
+ (blowfish-encrypt-file from to binary-plaintext? #t)))
(define-command decrypt-file
"Decrypt a file with the blowfish encryption algorithm.
Prompts for the ciphertext and plaintext filenames.
Prefix arg means treat the plaintext file as binary data."
(lambda ()
- (if (not (blowfish-available?))
- (editor-error "Blowfish encryption not supported on this system"))
+ (guarantee-blowfish-available)
(let ((from (prompt-for-existing-file "Decrypt file (ciphertext)" #f)))
(let ((to
(prompt-for-file
@@ -655,23 +636,80 @@ Prefix arg means treat the plaintext file as binary data."
(and (pathname-type from)
(list (pathname-new-type from #f))))))
(list from to (command-argument)))))
- (lambda (from to binary?)
- (if (or (not (file-exists? to))
- (prompt-for-yes-or-no?
- (string-append "File "
- (->namestring to)
- " already exists; overwrite")))
- (let ((password (prompt-for-password "Pass phrase")))
- (call-with-binary-input-file from
- (lambda (input)
- ((if binary?
- call-with-binary-output-file
- call-with-output-file)
- to
- (lambda (output)
- (blowfish-encrypt-port input output (md5 password)
- (read-blowfish-file-header input)
- #f)))))))))
+ (lambda (from to binary-plaintext?)
+ (blowfish-decrypt-file from to binary-plaintext? #f)))
+
+(define (guarantee-blowfish-available)
+ (if (not (blowfish-available?))
+ (editor-error "Blowfish encryption not supported on this system.")))
+
+(define (blowfish-encrypt-file from to binary-plaintext? delete-plaintext?)
+ (guarantee-blowfish-available)
+ (and (or (not (file-exists? to))
+ (prompt-for-yes-or-no?
+ (string-append "File "
+ (->namestring to)
+ " already exists; overwrite")))
+ (begin
+ ((if binary-plaintext?
+ call-with-binary-input-file
+ call-with-input-file)
+ from
+ (lambda (input)
+ (%blowfish-encrypt-file to input)))
+ (let ((t (file-modification-time-indirect from)))
+ (set-file-times! to t t))
+ (set-file-modes! to (file-modes from))
+ (if delete-plaintext? (delete-file from))
+ #t)))
+
+(define (blowfish-decrypt-file from to binary-plaintext? delete-ciphertext?)
+ (guarantee-blowfish-available)
+ (and (or (not (file-exists? to))
+ (prompt-for-yes-or-no?
+ (string-append "File "
+ (->namestring to)
+ " already exists; overwrite")))
+ (begin
+ ((if binary-plaintext?
+ call-with-binary-output-file
+ call-with-output-file)
+ to
+ (lambda (output)
+ (%blowfish-decrypt-file from output)))
+ (let ((t (file-modification-time-indirect from)))
+ (set-file-times! to t t))
+ (set-file-modes! to (file-modes from))
+ (if delete-ciphertext? (delete-file from))
+ #t)))
+
+(define (%blowfish-encrypt-file pathname input)
+ (call-with-binary-output-file pathname
+ (lambda (output)
+ (call-with-sensitive-string (call-with-confirmed-pass-phrase md5)
+ (lambda (key-string)
+ (blowfish-encrypt-port input output key-string
+ (write-blowfish-file-header output)
+ #t))))))
+
+(define (%blowfish-decrypt-file pathname output)
+ (call-with-binary-input-file pathname
+ (lambda (input)
+ (call-with-sensitive-string (call-with-pass-phrase "Pass phrase" md5)
+ (lambda (key-string)
+ (blowfish-encrypt-port input output key-string
+ (read-blowfish-file-header input)
+ #f))))))
+
+(define (call-with-sensitive-string string receiver)
+ (dynamic-wind (lambda ()
+ unspecific)
+ (lambda ()
+ (receiver string))
+ (lambda ()
+ (string-fill! string #\NUL)
+ (set! string)
+ unspecific)))
;;;; Prompting
diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 31742857e..f7f5d1a14 100644
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: fileio.scm,v 1.145 1999/01/14 18:24:58 cph Exp $
+;;; $Id: fileio.scm,v 1.146 1999/08/10 16:54:37 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
;;;
@@ -22,6 +22,58 @@
(declare (usual-integrations))
+;;;; Encrypted files
+
+(define-variable enable-encrypted-files
+ "If true, encrypted files are automatically decrypted when read,
+and recrypted when written. An encrypted file is identified by the
+filename suffix \".bf\"."
+ #t
+ boolean?)
+
+(define ((read/write-encrypted-file? write?) group pathname)
+ (and (ref-variable enable-encrypted-files group)
+ (equal? "bf" (pathname-type pathname))
+ (blowfish-available?)
+ (or write? (blowfish-file? pathname))
+ #t))
+
+(define (read-encrypted-file pathname mark)
+ (let ((m (string-append "Decrypting file " (->namestring pathname) "...")))
+ (message m)
+ (call-with-output-mark mark
+ (lambda (output)
+ (%blowfish-decrypt-file pathname output)))
+ ;; Disable auto-save here since we don't want to auto-save the
+ ;; unencrypted contents of the encrypted file.
+ (local-set-variable! auto-save-default #f (mark-buffer mark))
+ (message m "done")))
+
+(define (write-encrypted-file region pathname)
+ (let ((m (string-append "Encrypting file " (->namestring pathname) "...")))
+ (message m)
+ (%blowfish-decrypt-file pathname
+ (make-buffer-input-port (region-start region)
+ (region-end region)))
+ (message m "done")))
+
+(define (os-independent/read-file-methods)
+ (list (cons (read/write-encrypted-file? #f)
+ (lambda (pathname mark visit?)
+ visit?
+ (read-encrypted-file pathname mark)))))
+
+(define (os-independent/write-file-methods)
+ (list (cons (read/write-encrypted-file? #t)
+ (lambda (region pathname visit?)
+ visit?
+ (write-encrypted-file region pathname)))))
+
+(define (os-independent/alternate-pathnames group pathname)
+ (if (ref-variable enable-encrypted-files group)
+ (list (string-append (->namestring pathname) ".bf"))
+ '()))
+
;;;; Special File I/O Methods
(define (r/w-file-methods? objects)
diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm
index 7795b61ba..3c8cd9b54 100644
--- a/v7/src/edwin/rmail.scm
+++ b/v7/src/edwin/rmail.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: rmail.scm,v 1.62 1999/05/13 03:06:43 cph Exp $
+;;; $Id: rmail.scm,v 1.63 1999/08/10 16:54:54 cph Exp $
;;;
;;; Copyright (c) 1991-1999 Massachusetts Institute of Technology
;;;
@@ -670,7 +670,8 @@ This variable is ignored if rmail-pop-procedure is #F."
(define saved-pop-passwords '())
(define (prompt-for-pop-server-password server)
- (prompt-for-password (string-append "Password for POP server " server)))
+ (call-with-pass-phrase (string-append "Password for POP server " server)
+ string-copy))
;;;; Moving around
diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index b02dc3b2e..5a17be79d 100644
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: unix.scm,v 1.97 1999/08/09 18:19:19 cph Exp $
+;;; $Id: unix.scm,v 1.98 1999/08/10 16:54:48 cph Exp $
;;;
;;; Copyright (c) 1989-1999 Massachusetts Institute of Technology
;;;
@@ -238,7 +238,7 @@ Includes the new backup. Must be > 0."
result))))))
(define os/encoding-pathname-types
- '("Z" "gz" "bz2" "KY" "ky" "bf"))
+ '("Z" "gz" "bz2" "bf"))
(define unix/backup-suffixes
(cons "~"
@@ -350,10 +350,7 @@ Includes the new backup. Must be > 0."
(read-compressed-file "bzip2 -d" pathname mark))
((equal? "Z" type)
(read-compressed-file "uncompress" pathname mark))))))
- (,(read/write-encrypted-file? #f)
- . ,(lambda (pathname mark visit?)
- visit?
- (read-encrypted-file pathname mark)))))
+ ,@(os-independent/read-file-methods)))
(define (os/write-file-methods)
`((,read/write-compressed-file?
@@ -366,21 +363,16 @@ Includes the new backup. Must be > 0."
(write-compressed-file "bzip2" region pathname))
((equal? "Z" type)
(write-compressed-file "compress" region pathname))))))
- (,(read/write-encrypted-file? #t)
- . ,(lambda (region pathname visit?)
- visit?
- (write-encrypted-file region pathname)))))
+ ,@(os-independent/write-file-methods)))
(define (os/alternate-pathnames group pathname)
- (let ((filename (->namestring pathname)))
- `(,@(if (ref-variable enable-compressed-files group)
- (map (lambda (suffix) (string-append filename "." suffix))
- unix/compressed-file-suffixes)
- '())
- ,@(if (ref-variable enable-encrypted-files group)
- (map (lambda (suffix) (string-append filename "." suffix))
- unix/encrypted-file-suffixes)
- '()))))
+ (if (ref-variable enable-compressed-files group)
+ (append (map (let ((filename (->namestring pathname)))
+ (lambda (suffix)
+ (string-append filename "." suffix)))
+ unix/compressed-file-suffixes)
+ (os-independent/alternate-pathnames group pathname))
+ '()))
;;;; Compressed Files
@@ -444,84 +436,6 @@ of the filename suffixes \".gz\", \".bz2\", or \".Z\"."
(list region pathname)))
(append-message "done"))
-;;;; Encrypted files
-
-(define-variable enable-encrypted-files
- "If #T, encrypted files are automatically decrypted when read,
-and recrypted when written. An encrypted file is identified by the
-filename suffixes \".bf\" and \".ky\"."
- #t
- boolean?)
-
-(define ((read/write-encrypted-file? write?) group pathname)
- (and (ref-variable enable-encrypted-files group)
- (let ((type (pathname-type pathname)))
- (and (member type unix/encrypted-file-suffixes)
- (if (equal? "bf" type)
- (and (blowfish-available?)
- (or write? (blowfish-file? pathname)))
- #t)))))
-
-(define unix/encrypted-file-suffixes
- '("bf" "ky" "KY"))
-
-(define (read-encrypted-file pathname mark)
- (let ((password (prompt-for-password "Pass phrase"))
- (type (pathname-type pathname)))
- (message "Decrypting file " (->namestring pathname) "...")
- (cond ((equal? "bf" type)
- (call-with-binary-input-file pathname
- (lambda (input)
- (call-with-output-mark mark
- (lambda (output)
- (blowfish-encrypt-port input output (md5 password)
- (read-blowfish-file-header input)
- #f))))))
- ((or (equal? "ky" type) (equal? "KY" type))
- (insert-string (let ((the-encrypted-file
- (call-with-binary-input-file pathname
- (lambda (port)
- (read-string (char-set) port)))))
- (decrypt the-encrypted-file password
- (lambda ()
- (kill-buffer (mark-buffer mark))
- (editor-error "krypt: Password error!"))
- (lambda (x)
- (editor-beep)
- (message "krypt: Checksum error!")
- x)))
- mark)))
- ;; Disable auto-save here since we don't want to
- ;; auto-save the unencrypted contents of the
- ;; encrypted file.
- (define-variable-local-value! (mark-buffer mark)
- (ref-variable-object auto-save-default)
- #f)
- (append-message "done")))
-
-(define (write-encrypted-file region pathname)
- (let ((password (prompt-for-confirmed-password))
- (type (pathname-type pathname)))
- (message "Encrypting file " (->namestring pathname) "...")
- (cond ((equal? "bf" type)
- (let ((input
- (make-buffer-input-port (region-start region)
- (region-end region))))
- (call-with-binary-output-file pathname
- (lambda (output)
- (blowfish-encrypt-port input output (md5 password)
- (write-blowfish-file-header output)
- #t)))))
- ((or (equal? "ky" type) (equal? "KY" type))
- (let ((the-encrypted-file
- (encrypt (extract-string (region-start region)
- (region-end region))
- password)))
- (call-with-binary-output-file pathname
- (lambda (port)
- (write-string the-encrypted-file port))))))
- (append-message "done")))
-
;;;; Dired customization
(define-variable dired-listing-switches
--
2.25.1