home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / krypt.scm < prev    next >
Text File  |  2001-03-21  |  8KB  |  251 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: krypt.scm,v 1.12 2001/03/21 05:39:47 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Encryption/Decryption functions
  24. ;;; package: (runtime krypt)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. ;;; This implementation is based on krypt.c, written by Ron Rivest.
  29. ;;; encrypt and decrypt are compatible with krypt.c.
  30.  
  31. (define-integrable ts 256)        ; Actual table size to use
  32.  
  33. (define-structure (krypt-key (conc-name krypt-key/)
  34.                  (constructor make-krypt-key ()))
  35.   (state-table (make-vector ts))
  36.   (index-i #f)
  37.   (index-j #f))
  38.  
  39. (define (rcm-keyinit key)
  40.   (let loop ((i 0))
  41.     (if (fix:< i ts)
  42.     (begin
  43.       (vector-set! (krypt-key/state-table key) i i)
  44.       (loop (fix:1+ i)))
  45.     (begin
  46.       (set-krypt-key/index-i! key 0)
  47.       (set-krypt-key/index-j! key 0)))))
  48.  
  49. (define (rcm-key key kbuf)
  50.   (let ((m (string-length kbuf)))
  51.     (let loop ((i 0)
  52.            (j 0)
  53.            (k 0))
  54.       (if (fix:< i ts)
  55.       (begin
  56.         (let ((s (krypt-key/state-table key)))
  57.           (let* ((j (fix:remainder (fix:+ (fix:+ j 1)
  58.                           (fix:+ (vector-ref s i)
  59.                              (vector-8b-ref kbuf k)))
  60.                        ts))
  61.              (t (vector-ref s i)))
  62.         (vector-set! s i (vector-ref s j))
  63.         (vector-set! s j t)
  64.         (loop (fix:1+ i) j (fix:remainder (fix:1+ k) m)))))))))
  65.  
  66. (define-integrable (inc-mod i ts)
  67.   (fix:remainder i ts))
  68.  
  69. (define-integrable (rcm key n buf)
  70.   (rcm-iter key n buf 0))
  71.  
  72. (define (rcm-iter key n buf start-index)
  73.   (let ((i (krypt-key/index-i key))
  74.     (j (krypt-key/index-j key))
  75.     (s (krypt-key/state-table key))
  76.     (end-index (fix:+ n start-index)))
  77.     (let loop ((k start-index)
  78.            (i i)
  79.            (j j))
  80.       (if (fix:< k end-index)
  81.       (begin
  82.         (let* ((i (inc-mod (fix:1+ i) ts))
  83.            (j (inc-mod (fix:+ j (vector-ref s i)) ts))
  84.            (t (vector-ref s i)))
  85.           (vector-set! s i (vector-ref s j))
  86.           (vector-set! s j t)
  87.           (vector-8b-set!
  88.            buf k
  89.            (fix:xor (vector-8b-ref buf k)
  90.             (vector-ref s (inc-mod
  91.                        (fix:+ (fix:1+ (vector-ref s i))
  92.                           (vector-ref s j)) 
  93.                        ts))))
  94.           (loop (fix:1+ k) i j)))
  95.       (begin
  96.         (set-krypt-key/index-i! key i)
  97.         (set-krypt-key/index-j! key j))))))
  98.  
  99. (define kryptid "This file krypted ")
  100.  
  101. (define (get-krypt-time-string)
  102.   (let ((the-time (local-decoded-time)))
  103.     (string-append
  104.      (vector-ref '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
  105.          (decoded-time/day-of-week the-time))
  106.      " "
  107.      (vector-ref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" 
  108.               "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
  109.            (-1+ (decoded-time/month the-time)))
  110.      " "
  111.      (string-pad-left (write-to-string (decoded-time/day the-time)) 2)
  112.      " "
  113.      (string-pad-left (write-to-string (decoded-time/hour the-time)) 2)
  114.      ":"
  115.      (string-pad-left (write-to-string (decoded-time/minute the-time)) 2 #\0)
  116.      ":"
  117.      (string-pad-left (write-to-string (decoded-time/second the-time)) 2 #\0)
  118.      " "
  119.      (write-to-string (decoded-time/year the-time)))))
  120.  
  121. (define (update-checksum cs block index length)
  122.   (let ((end-index (fix:+ index length)))
  123.     (let loop ((i index)
  124.            (checksum cs))
  125.       (if (fix:< i end-index)
  126.       (loop (fix:1+ i) (fix:+ checksum (vector-8b-ref block i)))
  127.       (fix:remainder checksum 256)))))
  128.  
  129. (define encrypt)
  130. (define decrypt)
  131.  
  132. (let ((unlocked? 'UNKNOWN)
  133.       (key-sum "84c3aad7f848b9a5a02e65b7834a696c"))
  134.  
  135.   (define (check-key)
  136.     (initialize-key)
  137.     (if (not unlocked?)
  138.     (error "Krypt support disabled in this implementation.")))
  139.  
  140.   (define (initialize-key)
  141.     (if (eq? 'UNKNOWN unlocked?)
  142.     (set! unlocked?
  143.           (and (md5-available?)
  144.            (let ((pathname
  145.               (call-with-current-continuation
  146.                (lambda (k)
  147.                  (bind-condition-handler
  148.                  (list condition-type:file-error)
  149.                  (lambda (condition)
  150.                    condition
  151.                    (k #f))
  152.                    (lambda ()
  153.                  (system-library-pathname "krypt.key")))))))
  154.              (and pathname
  155.               (string=? key-sum
  156.                     (mhash-sum->hexadecimal
  157.                      (md5-file pathname)))))))))
  158.  
  159.   (set! encrypt
  160.     (lambda (input-string password)
  161.       (check-key)
  162.       (let* ((checksum 0)
  163.          (header (string-append kryptid (get-krypt-time-string) "\n"))
  164.          (hlen (string-length header))
  165.          (output-string
  166.           (make-string
  167.            (fix:+ 6 (fix:+ hlen (string-length input-string)))))
  168.          (end-index (fix:- (string-length output-string) ts)))
  169.         (let ((key1 (make-krypt-key)))
  170.           (rcm-keyinit key1)
  171.           (rcm-key key1 header)
  172.           (rcm-key key1 password)
  173.           (let ((passwordmac (make-string 5 #\NUL)))
  174.         (rcm key1 5 passwordmac)
  175.         (substring-move! header 0 hlen output-string 0)
  176.         (substring-move! passwordmac 0 5 output-string hlen)
  177.         (substring-move! input-string 0
  178.                  (string-length input-string)
  179.                  output-string (fix:+ hlen 5)))
  180.           (let loop ((index (fix:+ hlen 5)))
  181.         (if (fix:< index end-index)
  182.             (begin
  183.               (set! checksum
  184.                 (update-checksum checksum output-string index ts))
  185.               (rcm-iter key1 ts output-string index)
  186.               (loop (fix:+ index ts)))
  187.             (let ((count
  188.                (fix:- (string-length output-string)
  189.                   (fix:1+ index))))
  190.               (set! checksum
  191.                 (update-checksum checksum output-string index
  192.                          count))
  193.               (rcm-iter key1 count output-string index))))
  194.           (let ((check-char (ascii->char (modulo (- checksum) ts))))
  195.         (let ((cc-string (char->string check-char)))
  196.           (rcm key1 1 cc-string)
  197.           (string-set! output-string
  198.                    (fix:-1+ (string-length output-string))
  199.                    (string-ref cc-string 0))))
  200.           output-string))))
  201.  
  202.   (set! decrypt
  203.     (lambda (input-string password
  204.                   #!optional password-error checksum-error)
  205.       (check-key)
  206.       (let* ((header-length (+ (string-length kryptid) 25))
  207.          (header (string-head input-string header-length))
  208.          (pwordmac
  209.           (substring input-string header-length
  210.                  (fix:+ header-length 5)))
  211.          (output-string
  212.           (string-tail input-string (fix:+ header-length 5)))
  213.          (end-index (fix:- (string-length output-string) ts))
  214.          (key1 (make-krypt-key))
  215.          (checksum 0))
  216.           (rcm-keyinit key1)
  217.           (rcm-key key1 header)
  218.           (rcm-key key1 password)
  219.           (let ((passwordmac (make-string 5 #\NUL)))
  220.         (rcm key1 5 passwordmac)
  221.         (if (string=? passwordmac pwordmac)
  222.             (begin
  223.               (let loop ((index 0))
  224.             (if (fix:< index end-index)
  225.                 (begin
  226.                   (rcm-iter key1 ts output-string index)
  227.                   (set! checksum
  228.                     (update-checksum checksum output-string
  229.                              index ts))
  230.                   (loop (fix:+ index ts)))
  231.                 (let ((count
  232.                    (fix:- (string-length output-string)
  233.                       index)))
  234.                   (rcm-iter key1 count output-string index)
  235.                   (set! checksum
  236.                     (update-checksum checksum output-string
  237.                              index count)))))
  238.               (if (not (= (modulo checksum 256) 0))
  239.               (if (default-object? checksum-error)
  240.                   (error "krypt: Checksum error.")
  241.                   (checksum-error output-string))
  242.               (begin
  243.                 (set-string-length!
  244.                  output-string
  245.                  (fix:-1+ (string-length output-string)))
  246.                 output-string)))
  247.             (if (default-object? password-error)
  248.             (error "krypt: Password error.")
  249.             (password-error)))))))
  250.  
  251.   )