From: Brian A. LaMacchia <edu/mit/csail/zurich/bal>
Date: Fri, 20 Mar 1992 02:24:40 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~9579
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=55a08f9a5b7851bfd4d88ecf57608c489dca304e;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/runtime/krypt.scm b/v7/src/runtime/krypt.scm
new file mode 100644
index 000000000..ef62eabef
--- /dev/null
+++ b/v7/src/runtime/krypt.scm
@@ -0,0 +1,128 @@
+;;; -*- Scheme -*-
+
+(define TS 256)				; Actual table size to use
+
+(define-structure (key (conc-name key/)
+		       (constructor %make-key))
+  state-table
+  index-i
+  index-j)
+
+(define (make-key)
+  (%make-key
+    (make-vector ts)
+    #f
+    #f))
+
+(define (rcm-keyinit key)
+  (let loop ((i 0))
+    (if (< i ts)
+	(begin
+	  (vector-set! (key/state-table key) i i)
+	  (loop (1+ i)))
+	(begin
+	  (set-key/index-i! key 0)
+	  (set-key/index-j! key 0)))))
+
+(define (rcm-key key kbuf)
+  (let ((m (string-length kbuf)))
+    (let loop ((i 0)
+	       (j 0)
+	       (k 0))
+      (if (< i ts)
+	  (begin
+	    (let ((s (key/state-table key)))
+	      (let* ((j (modulo (+ j 1 
+				   (vector-ref s i)
+				   (char->ascii (string-ref kbuf k))) ts))
+		     (t (vector-ref s i)))
+		(vector-set! s i (vector-ref s j))
+		(vector-set! s j t)
+		(loop (1+ i) j (modulo (1+ k) m)))))))))
+
+(define (rcm key n buf)
+  (let ((i (key/index-i key))
+	(j (key/index-j key)))
+    (let ((s (key/state-table key)))
+      (let loop ((k 0)
+		 (i i)
+		 (j j))
+	(if (< k n)
+	    (begin
+	      (let* ((i (modulo (1+ i) ts))
+		     (j (modulo (+ j (vector-ref s i)) ts))
+		     (t (vector-ref s i)))
+		(vector-set! s i (vector-ref s j))
+		(vector-set! s j t)
+		(let ((buf-k-bitstr
+		       (unsigned-integer->bit-string 
+			8 (char->ascii (string-ref buf k))))
+		      (xor-string
+		       (unsigned-integer->bit-string
+			8 (vector-ref s (modulo (+ 1 (vector-ref s i) 
+						   (vector-ref s j)) ts)))))
+		  (string-set! buf k (ascii->char 
+				      (bit-string->unsigned-integer
+				       (bit-string-xor buf-k-bitstr xor-string)))))
+		(loop (1+ k) i j)))
+	    (begin
+	      (set-key/index-i! key i)
+	      (set-key/index-j! key j)))))))
+
+(define kryptid "This file krypted ")
+
+(define (get-krypt-time-string)
+  (let ((the-time (get-decoded-time)))
+    (string-append
+     (vector-ref '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
+		 (decoded-time/day-of-week the-time))
+     " "
+     (vector-ref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" 
+			  "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
+	       (-1+ (decoded-time/month the-time)))
+     " "
+     (write-to-string (decoded-time/day the-time))
+     " "
+     (write-to-string (decoded-time/hour the-time))
+     ":"
+     (write-to-string (decoded-time/minute the-time))
+     ":"
+     (write-to-string (decoded-time/second the-time))
+     " "
+     (write-to-string (decoded-time/year the-time)))))
+#|
+(define (get-krypt-time-string)
+  "Thu Mar 19 19:13:45 1992")
+|#
+(define (encrypt input-string password)
+  (let ((checksum 0)
+	(output-string "")
+	(header (string-append kryptid (get-krypt-time-string) "\n")))
+    (set! output-string (string-append output-string header))
+    (let ((key1 (make-key)))
+      (rcm-keyinit key1)
+      (rcm-key key1 header)
+      (rcm-key key1 password)
+      (let ((passwordmac (list->string (map ascii->char '(0 0 0 0 0)))))
+	(rcm key1 5 passwordmac)
+	(set! output-string (string-append output-string passwordmac)))
+      (let loop ((rest input-string))
+	(if (>= (string-length rest) 256)
+	    (let ((current-block (string-head rest 256))
+		  (new-rest (string-tail rest 256)))
+	      (set! checksum (+ checksum 
+				(apply + (map char->ascii (string->list current-block)))))
+	      (rcm key1 (string-length current-block) current-block)
+	      (set! output-string (string-append output-string current-block))
+	      (loop new-rest))
+	    (begin
+	      (set! checksum (+ checksum 
+				(apply + (map char->ascii (string->list rest)))))
+	      (rcm key1 (string-length rest) rest)
+	      (set! output-string (string-append output-string rest)))))
+      (let ((check-char (ascii->char (modulo (- checksum) 256))))
+	(let ((cc-string (char->string check-char)))
+	  (rcm key1 1 cc-string)
+	  (set! output-string (string-append output-string cc-string))))
+      output-string)))
+