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 / crypto.scm < prev    next >
Text File  |  2001-03-08  |  17KB  |  508 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: crypto.scm,v 14.13 2001/03/08 19:27:35 cph Exp $
  4.  
  5. Copyright (c) 2000-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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Interface to cryptography libraries
  23. ;;; package: (runtime crypto)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; The mhash library
  28.  
  29. (define mhash-initialized?)
  30. (define mhash-algorithm-names)
  31. (define mhash-contexts)
  32. (define mhash-hmac-contexts)
  33.  
  34. (define (mhash-name->id name procedure)
  35.   (let ((n (vector-length mhash-algorithm-names)))
  36.     (let loop ((i 0))
  37.       (cond ((fix:= i n) (error:bad-range-argument name procedure))
  38.         ((eq? name (vector-ref mhash-algorithm-names i)) i)
  39.         (else (loop (fix:+ i 1)))))))
  40.  
  41. (define-structure mhash-context (index #f read-only #t))
  42. (define-structure mhash-hmac-context (index #f read-only #t))
  43.  
  44. (define (guarantee-mhash-context object procedure)
  45.   (if (not (mhash-context? object))
  46.       (error:wrong-type-argument object "mhash context" procedure)))
  47.  
  48. (define (guarantee-mhash-hmac-context object procedure)
  49.   (if (not (mhash-hmac-context? object))
  50.       (error:wrong-type-argument object "mhash HMAC context" procedure)))
  51.  
  52. (define (mhash-type-names)
  53.   (names-vector->list mhash-algorithm-names))
  54.  
  55. (define (mhash-get-block-size name)
  56.   ((ucode-primitive mhash_get_block_size 1)
  57.    (mhash-name->id name 'MHASH-GET-BLOCK-SIZE)))
  58.  
  59. (define (mhash-init name)
  60.   (let ((id (mhash-name->id name 'MHASH-INIT)))
  61.     (without-interrupts
  62.      (lambda ()
  63.        (let ((index ((ucode-primitive mhash_init 1) id)))
  64.      (if (not index)
  65.          (error "Unable to allocate mhash context:" name))
  66.      (let ((context (make-mhash-context index)))
  67.        (add-to-gc-finalizer! mhash-contexts context index)
  68.        context))))))
  69.  
  70. (define (mhash-update context string start end)
  71.   (guarantee-mhash-context context 'MHASH-UPDATE)
  72.   ((ucode-primitive mhash 4) (mhash-context-index context) string start end))
  73.  
  74. (define (mhash-end context)
  75.   (guarantee-mhash-context context 'MHASH-END)
  76.   (remove-from-gc-finalizer! mhash-contexts context))
  77.  
  78. (define (mhash-hmac-init name key)
  79.   (let* ((id (mhash-name->id name 'MHASH-INIT))
  80.      (pblock ((ucode-primitive mhash_get_hash_pblock 1) id)))
  81.     (without-interrupts
  82.      (lambda ()
  83.        (let ((index ((ucode-primitive mhash_hmac_init 3) id key pblock)))
  84.      (if (not index)
  85.          (error "Unable to allocate mhash HMAC context:" name))
  86.      (let ((context (make-mhash-hmac-context index)))
  87.        (add-to-gc-finalizer! mhash-hmac-contexts context index)
  88.        context))))))
  89.  
  90. (define (mhash-hmac-update context string start end)
  91.   (guarantee-mhash-hmac-context context 'MHASH-HMAC-UPDATE)
  92.   ((ucode-primitive mhash 4) (mhash-hmac-context-index context)
  93.                  string start end))
  94.  
  95. (define (mhash-hmac-end context)
  96.   (guarantee-mhash-hmac-context context 'MHASH-HMAC-END)
  97.   (remove-from-gc-finalizer! mhash-hmac-contexts context))
  98.  
  99. (define mhash-keygen-names)
  100.  
  101. (define (keygen-name->id name procedure)
  102.   (let ((n (vector-length mhash-keygen-names)))
  103.     (let loop ((i 0))
  104.       (cond ((fix:= i n) (error:bad-range-argument name procedure))
  105.         ((eq? name (vector-ref mhash-keygen-names i)) i)
  106.         (else (loop (fix:+ i 1)))))))
  107.  
  108. (define (mhash-keygen-type-names)
  109.   (names-vector->list mhash-keygen-names))
  110.  
  111. (define (mhash-keygen-uses-salt? name)
  112.   ((ucode-primitive mhash_keygen_uses_salt 1)
  113.    (keygen-name->id name 'MHASH-KEYGEN-USES-SALT?)))
  114.  
  115. (define (mhash-keygen-uses-count? name)
  116.   ((ucode-primitive mhash_keygen_uses_count 1)
  117.    (keygen-name->id name 'MHASH-KEYGEN-USES-COUNT?)))
  118.  
  119. (define (mhash-keygen-uses-hash-algorithm name)
  120.   ((ucode-primitive mhash_keygen_uses_hash_algorithm 1)
  121.    (keygen-name->id name 'MHASH-KEYGEN-USES-HASH-ALGORITHM)))
  122.  
  123. (define (mhash-keygen-salt-size name)
  124.   ((ucode-primitive mhash_get_keygen_salt_size 1)
  125.    (keygen-name->id name 'MHASH-KEYGEN-SALT-SIZE)))
  126.  
  127. (define (mhash-keygen-max-key-size name)
  128.   ((ucode-primitive mhash_get_keygen_max_key_size 1)
  129.    (keygen-name->id name 'MHASH-KEYGEN-MAX-KEY-SIZE)))
  130.  
  131. (define (mhash-keygen type passphrase #!optional salt)
  132.   (if (not (mhash-keygen-type? type))
  133.       (error:wrong-type-argument type "mhash type" 'MHASH-KEYGEN))
  134.   (let ((id (mhash-keygen-type-id type))
  135.     (keyword (make-string (mhash-keygen-type-key-length type)))
  136.     (v (mhash-keygen-type-parameter-vector type)))
  137.     (if (not ((ucode-primitive mhash_keygen 4)
  138.           id
  139.           (if ((ucode-primitive mhash_keygen_uses_salt 1) id)
  140.           (begin
  141.             (if (or (default-object? salt) (not salt))
  142.             (error "Salt required:"
  143.                    (vector-ref mhash-keygen-names id)))
  144.             (let ((n
  145.                ((ucode-primitive mhash_get_keygen_salt_size 1)
  146.                 id)))
  147.               (if (not (or (= n 0)
  148.                    (= n (string-length salt))))
  149.               (error "Salt size incorrect:"
  150.                  (string-length salt)
  151.                  (error-irritant/noise "; should be:")
  152.                  n)))
  153.             (let ((v (vector-copy v)))
  154.               (vector-set! v 0 salt)
  155.               v))
  156.           v)
  157.           keyword
  158.           passphrase))
  159.     (error "Error signalled by mhash_keygen."))
  160.     keyword))
  161.  
  162. (define-structure (mhash-keygen-type (constructor %make-mhash-keygen-type))
  163.   (id #f read-only #t)
  164.   (key-length #f read-only #t)
  165.   (parameter-vector #f read-only #t))
  166.  
  167. (define (make-mhash-keygen-type name key-length hash-names #!optional count)
  168.   (if (not (index-fixnum? key-length))
  169.       (error:wrong-type-argument key-length "key length"
  170.                  'MAKE-MHASH-KEYGEN-TYPE))
  171.   (if (not (let ((m (mhash-keygen-max-key-size name)))
  172.          (or (= m 0)
  173.          (<= key-length m))))
  174.       (error:bad-range-argument key-length 'MAKE-MHASH-KEYGEN-TYPE))
  175.   (%make-mhash-keygen-type
  176.    (keygen-name->id name 'MAKE-MHASH-KEYGEN-TYPE)
  177.    key-length
  178.    (let ((n-algorithms (mhash-keygen-uses-hash-algorithm name))
  179.      (hash-names
  180.       (if (list? hash-names) hash-names (list hash-names))))
  181.      (let ((m (length hash-names)))
  182.        (if (not (= n-algorithms m))
  183.        (error "Wrong number of hash types supplied:"
  184.           m
  185.           (error-irritant/noise "; should be:")
  186.           n-algorithms)))
  187.      (let ((n (+ 2 n-algorithms)))
  188.        (let ((v (make-vector n)))
  189.      (vector-set! v 0 #f)
  190.      (vector-set!
  191.       v 1
  192.       (and (mhash-keygen-uses-count? name)
  193.            (begin
  194.          (if (or (default-object? count) (not count))
  195.              (error "Iteration count required:" name))
  196.          (if (not (and (exact-integer? count)
  197.                    (positive? count)))
  198.              (error:bad-range-argument count 'MAKE-MHASH-KEYGEN-TYPE))
  199.          count)))
  200.      (do ((i 2 (fix:+ i 1))
  201.           (names hash-names (cdr names)))
  202.          ((fix:= i n))
  203.        (vector-set! v i
  204.             (mhash-name->id (car names) 'MAKE-MHASH-KEYGEN-TYPE)))
  205.      v)))))
  206.  
  207. (define (mhash-available?)
  208.   (load-library-object-file "prmhash" #f)
  209.   (and (implemented-primitive-procedure? (ucode-primitive mhash 4))
  210.        (begin
  211.      (if (not mhash-initialized?)
  212.          (begin
  213.            (set! mhash-algorithm-names
  214.              (make-names-vector
  215.               (ucode-primitive mhash_count 0)
  216.               (ucode-primitive mhash_get_hash_name 1)))
  217.            (set! mhash-contexts
  218.              (make-gc-finalizer (ucode-primitive mhash_end 1)))
  219.            (set! mhash-hmac-contexts
  220.              (make-gc-finalizer (ucode-primitive mhash_hmac_end 1)))
  221.            (set! mhash-keygen-names
  222.              (make-names-vector
  223.               (ucode-primitive mhash_keygen_count 0)
  224.               (ucode-primitive mhash_get_keygen_name 1)))
  225.            (set! mhash-initialized? #t)))
  226.      #t)))
  227.  
  228. (define (reset-mhash-variables!)
  229.   (set! mhash-initialized? #f)
  230.   unspecific)
  231.  
  232. (define (mhash-file hash-type filename)
  233.   (call-with-binary-input-file filename
  234.     (lambda (port)
  235.       (let ((buffer (make-string 4096))
  236.         (context (mhash-init hash-type)))
  237.     (dynamic-wind (lambda ()
  238.             unspecific)
  239.               (lambda ()
  240.             (let loop ()
  241.               (let ((n (read-substring! buffer 0 4096 port)))
  242.                 (if (fix:= 0 n)
  243.                 (mhash-end context)
  244.                 (begin
  245.                   (mhash-update context buffer 0 n)
  246.                   (loop))))))
  247.               (lambda ()
  248.             (string-fill! buffer #\NUL)))))))
  249.  
  250. (define (mhash-string hash-type string)
  251.   (mhash-substring hash-type string 0 (string-length string)))
  252.  
  253. (define (mhash-substring hash-type string start end)
  254.   (let ((context (mhash-init hash-type)))
  255.     (mhash-update context string start end)
  256.     (mhash-end context)))
  257.  
  258. (define (mhash-sum->number sum)
  259.   (let ((l (string-length sum)))
  260.     (do ((i 0 (fix:+ i 1))
  261.      (n 0 (+ (* n #x100) (vector-8b-ref sum i))))
  262.     ((fix:= i l) n))))
  263.  
  264. (define (mhash-sum->hexadecimal sum)
  265.   (let ((n (string-length sum))
  266.     (digits "0123456789abcdef"))
  267.     (let ((s (make-string (fix:* 2 n))))
  268.       (do ((i 0 (fix:+ i 1)))
  269.       ((fix:= i n))
  270.     (string-set! s (fix:* 2 i)
  271.              (string-ref digits
  272.                  (fix:lsh (vector-8b-ref sum i) -4)))
  273.     (string-set! s (fix:+ (fix:* 2 i) 1)
  274.              (string-ref digits
  275.                  (fix:and (vector-8b-ref sum i) #x0F))))
  276.       s)))
  277.  
  278. ;;;; MD5
  279.  
  280. (define (md5-available?)
  281.   (or (mhash-available?)
  282.       (begin
  283.     (load-library-object-file "prmd5" #f)
  284.     (implemented-primitive-procedure? (ucode-primitive md5-init 0)))))
  285.  
  286. (define (md5-file filename)
  287.   (if (mhash-available?)
  288.       (mhash-file 'MD5 filename)
  289.       (call-with-binary-input-file filename
  290.     (lambda (port)
  291.       (let ((buffer (make-string 4096))
  292.         (context ((ucode-primitive md5-init 0))))
  293.         (dynamic-wind (lambda ()
  294.                 unspecific)
  295.               (lambda ()
  296.                 (let loop ()
  297.                   (let ((n (read-substring! buffer 0 4096 port)))
  298.                 (if (fix:= 0 n)
  299.                     ((ucode-primitive md5-final 1) context)
  300.                     (begin
  301.                       ((ucode-primitive md5-update 4)
  302.                        context buffer 0 n)
  303.                       (loop))))))
  304.               (lambda ()
  305.                 (string-fill! buffer #\NUL))))))))
  306.  
  307. (define (md5-string string)
  308.   (md5-substring string 0 (string-length string)))
  309.  
  310. (define (md5-substring string start end)
  311.   (if (mhash-available?)
  312.       (mhash-substring 'MD5 string start end)
  313.       (let ((context ((ucode-primitive md5-init 0))))
  314.     ((ucode-primitive md5-update 4) context string start end)
  315.     ((ucode-primitive md5-final 1) context))))
  316.  
  317. (define md5-sum->number mhash-sum->number)
  318. (define md5-sum->hexadecimal mhash-sum->hexadecimal)
  319.  
  320. ;;;; The mcrypt library
  321.  
  322. (define mcrypt-initialized?)
  323. (define mcrypt-algorithm-names-vector)
  324. (define mcrypt-mode-names-vector)
  325. (define mcrypt-contexts)
  326. (define-structure mcrypt-context (index #f read-only #t))
  327.  
  328. (define (guarantee-mcrypt-context object procedure)
  329.   (if (not (mcrypt-context? object))
  330.       (error:wrong-type-argument object "mcrypt context" procedure)))
  331.  
  332. (define (mcrypt-available?)
  333.   (load-library-object-file "prmcrypt" #f)
  334.   (and (implemented-primitive-procedure?
  335.     (ucode-primitive mcrypt_module_open 2))
  336.        (begin
  337.      (if (not mcrypt-initialized?)
  338.          (begin
  339.            (set! mcrypt-contexts
  340.              (make-gc-finalizer
  341.               (ucode-primitive mcrypt_generic_end 1)))
  342.            (set! mcrypt-algorithm-names-vector
  343.              ((ucode-primitive mcrypt_list_algorithms 0)))
  344.            (set! mcrypt-mode-names-vector
  345.              ((ucode-primitive mcrypt_list_modes 0)))
  346.            (set! mcrypt-initialized? #t)))
  347.      #t)))
  348.  
  349. (define (reset-mcrypt-variables!)
  350.   (set! mcrypt-initialized? #f)
  351.   unspecific)
  352.  
  353. (define (mcrypt-algorithm-names)
  354.   (names-vector->list mcrypt-algorithm-names-vector))
  355.  
  356. (define (mcrypt-mode-names)
  357.   (names-vector->list mcrypt-mode-names-vector))
  358.  
  359. (define (mcrypt-open-module algorithm mode)
  360.   (without-interrupts
  361.    (lambda ()
  362.      (let ((index ((ucode-primitive mcrypt_module_open 2) algorithm mode)))
  363.        (let ((context (make-mcrypt-context index)))
  364.      (add-to-gc-finalizer! mcrypt-contexts context index)
  365.      context)))))
  366.  
  367. (define (mcrypt-init context key init-vector)
  368.   (guarantee-mcrypt-context context 'MCRYPT-INIT)
  369.   (let ((code
  370.      ((ucode-primitive mcrypt_generic_init 3)
  371.       (mcrypt-context-index context) key init-vector)))
  372.     (if (not (= code 0))
  373.     (error "Error code signalled by mcrypt_generic_init:" code))))
  374.  
  375. (define (mcrypt-encrypt context input input-start input-end
  376.             output output-start encrypt?)
  377.   (guarantee-mcrypt-context context 'MCRYPT-ENCRYPT)
  378.   (substring-move! input input-start input-end output output-start)
  379.   (let ((code
  380.      ((if encrypt?
  381.           (ucode-primitive mcrypt_generic 4)
  382.           (ucode-primitive mdecrypt_generic 4))
  383.       (mcrypt-context-index context)
  384.       output
  385.       output-start
  386.       (fix:+ output-start (fix:- input-end input-start)))))
  387.     (if (not (= code 0))
  388.     (error (string-append "Error code signalled by "
  389.                   (if encrypt?
  390.                   "mcrypt_generic"
  391.                   "mdecrypt_generic")
  392.                   ":")
  393.            code))))
  394.  
  395. (define (mcrypt-end context)
  396.   (guarantee-mcrypt-context context 'MCRYPT-END)
  397.   (remove-from-gc-finalizer! mcrypt-contexts context))
  398.  
  399. (define (mcrypt-generic-unary name context-op module-op)
  400.   (lambda (object)
  401.     (cond ((mcrypt-context? object) (context-op (mcrypt-context-index object)))
  402.       ((string? object) (module-op object))
  403.       (else (error:wrong-type-argument object "mcrypt context" name)))))
  404.  
  405. (define mcrypt-self-test
  406.   (mcrypt-generic-unary
  407.    'MCRYPT-SELF-TEST
  408.    (ucode-primitive mcrypt_enc_self_test 1)
  409.    (ucode-primitive mcrypt_module_self_test 1)))
  410.  
  411. (define mcrypt-block-algorithm-mode?
  412.   (mcrypt-generic-unary
  413.    'MCRYPT-BLOCK-ALGORITHM-MODE?
  414.    (ucode-primitive mcrypt_enc_is_block_algorithm_mode 1)
  415.    (ucode-primitive mcrypt_module_is_block_algorithm_mode 1)))
  416.  
  417. (define mcrypt-block-algorithm?
  418.   (mcrypt-generic-unary
  419.    'MCRYPT-BLOCK-ALGORITHM?
  420.    (ucode-primitive mcrypt_enc_is_block_algorithm 1)
  421.    (ucode-primitive mcrypt_module_is_block_algorithm 1)))
  422.  
  423. (define mcrypt-block-mode?
  424.   (mcrypt-generic-unary
  425.    'MCRYPT-BLOCK-MODE?
  426.    (ucode-primitive mcrypt_enc_is_block_mode 1)
  427.    (ucode-primitive mcrypt_module_is_block_mode 1)))
  428.  
  429. (define mcrypt-key-size
  430.   (mcrypt-generic-unary
  431.    'MCRYPT-KEY-SIZE
  432.    (ucode-primitive mcrypt_enc_get_key_size 1)
  433.    (ucode-primitive mcrypt_module_get_algo_key_size 1)))
  434.  
  435. (define mcrypt-supported-key-sizes
  436.   (mcrypt-generic-unary
  437.    'MCRYPT-SUPPORTED-KEY-SIZES
  438.    (ucode-primitive mcrypt_enc_get_supported_key_sizes 1)
  439.    (ucode-primitive mcrypt_module_get_algo_supported_key_sizes 1)))
  440.  
  441. (define (mcrypt-init-vector-size context)
  442.   (guarantee-mcrypt-context context 'MCRYPT-INIT-VECTOR-SIZE)
  443.   ((ucode-primitive mcrypt_enc_get_iv_size 1)
  444.    (mcrypt-context-index context)))
  445.  
  446. (define (mcrypt-algorithm-name context)
  447.   (guarantee-mcrypt-context context 'MCRYPT-ALGORITHM-NAME)
  448.   ((ucode-primitive mcrypt_enc_get_algorithms_name 1)
  449.    (mcrypt-context-index context)))
  450.  
  451. (define (mcrypt-mode-name context)
  452.   (guarantee-mcrypt-context context 'MCRYPT-MODE-NAME)
  453.   ((ucode-primitive mcrypt_enc_get_modes_name 1)
  454.    (mcrypt-context-index context)))
  455.  
  456. (define (mcrypt-encrypt-port algorithm mode input output key init-vector
  457.                  encrypt?)
  458.   ;; Assumes that INPUT is in blocking mode.
  459.   (let ((context (mcrypt-open-module algorithm mode))
  460.     (input-buffer (make-string 4096))
  461.     (output-buffer (make-string 4096)))
  462.     (mcrypt-init context key init-vector)
  463.     (dynamic-wind
  464.      (lambda ()
  465.        unspecific)
  466.      (lambda ()
  467.        (let loop ()
  468.      (let ((n (input-port/read-string! input input-buffer)))
  469.        (if (not (fix:= 0 n))
  470.            (begin
  471.          (mcrypt-encrypt context input-buffer 0 n output-buffer 0
  472.                  encrypt?)
  473.          (write-substring output-buffer 0 n output)
  474.          (loop)))))
  475.        (mcrypt-end context))
  476.      (lambda ()
  477.        (string-fill! input-buffer #\NUL)
  478.        (string-fill! output-buffer #\NUL)))))
  479.  
  480. ;;;; Package initialization
  481.  
  482. (define (initialize-package!)
  483.   (reset-mhash-variables!)
  484.   (add-event-receiver! event:after-restart reset-mhash-variables!)
  485.   (reset-mcrypt-variables!)
  486.   (add-event-receiver! event:after-restart reset-mcrypt-variables!))
  487.  
  488. (define (make-names-vector get-count get-name)
  489.   (let ((n (get-count)))
  490.     (let ((v (make-vector n)))
  491.       (do ((i 0 (fix:+ i 1)))
  492.       ((fix:= i n))
  493.     (vector-set! v i
  494.              (let ((name (get-name i)))
  495.                (and name
  496.                 (intern name)))))
  497.       v)))
  498.  
  499. (define (names-vector->list v)
  500.   (let ((end (vector-length v)))
  501.     (let loop ((index 0) (names '()))
  502.       (if (fix:< index end)
  503.       (loop (fix:+ index 1)
  504.         (let ((name (vector-ref v index)))
  505.           (if name
  506.               (cons name names)
  507.               names)))
  508.       names))))