;; mzcrypto: crypto library for mzscheme
;; Copyright (C) 2007 Dimitris Vyzovitis <[email protected]>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
;; USA

(module dh mzscheme
  (require-for-syntax "stx-util.ss")
  (require (lib "foreign.ss")
           (only (lib "list.ss" "srfi" "1") last)
           (only (lib "base64.ss" "net") base64-decode)
           (only (lib "etc.ss") compose))
  (require "libcrypto.ss" "error.ss" "bn.ss")
  (provide (all-defined))

  (define-struct dh:params (bits bs))
  (define-struct dhkey (p))

  (define/alloc DH)
  (define/ffi (DH_size _pointer) -> _int)
  (define/ffi (DH_generate_key _pointer) -> _int : check-error)
  (define/ffi (DH_compute_key _pointer _pointer _pointer) 
    -> _int : check-error)
  (define/ffi (d2i_DHparams (_pointer = #f) (_ptr i _pointer) _long)
    -> _pointer : pointer/error)

  ;; DH: struct dh_st {pad version p g length pub_key ...}
  (define (dhkey-pubk dh)
    (bn->bytes
     (last (ptr-ref 
            (dhkey-p dh) 
            (_list-struct _int _int _pointer _pointer _long _pointer)))))

  (define (params->dhkey params)
    (let* ((bs (dh:params-bs params))
           (dhp (d2i_DHparams bs (bytes-length bs)))
           (dh (make-dhkey dhp)))
      (register-finalizer dh (compose DH_free dhkey-p))
      dh))
  
  (define dhkey-size (compose DH_size dhkey-p))
  
  (define (generate-dhkey params)
    (let ((dh (params->dhkey params)))
      (DH_generate_key (dhkey-p dh))
      (values dh (dhkey-pubk dh))))

  (define (compute-key dh pubk)
    (let/fini ((bs (make-bytes (dhkey-size dh)))
               (bn (bytes->bn pubk) BN_free))
      (DH_compute_key bs bn (dhkey-p dh))
      bs))

  (define-syntax (define-dh stx)
    (syntax-case stx ()
      ((_ bits bbs)
       (with-syntax
           ((params (->stx stx (make-symbol "dh:" (->datum #'bits)))))
         #'(define params (make-dh:params bits (base64-decode bbs)))))))

  ;; DH parameter generation can take a really long time
  ;; These are base64 encoded defaults provided by the OpenSSL project.
  ;; openssl dhparam can be used to generate new ones
  (define-dh 192
    #"MB4CGQDUoLoCULb9LsYm5+/WN992xxbiLQlEuIsCAQM=")
  (define-dh 512
    #"MEYCQQDaWDwW2YUiidDkr3VvTMqS3UvlM7gE+w/tlO+cikQD7VdGUNNpmdsp13Yn
      a6LT1BLiGPTdHghM9tgAPnxHdOgzAgEC")
  (define-dh 1024
    #"MIGHAoGBAJf2QmHKtQXdKCjhPx1ottPb0PMTBH9A6FbaWMsTuKG/K3g6TG1Z1fkq
      /Gz/PWk/eLI9TzFgqVAuPvr3q14a1aZeVUMTgo2oO5/y2UHe6VaJ+trqCTat3xlx
      /mNbIK9HA2RgPC3gWfVLZQrY+gz3ASHHR5nXWHEyvpuZm7m3h+irAgEC")
  (define-dh 2048
    #"MIIBCAKCAQEA7ZKJNYJFVcs7+6J2WmkEYb8h86tT0s0h2v94GRFS8Q7B4lW9aG9o
      AFO5Imov5Jo0H2XMWTKKvbHbSe3fpxJmw/0hBHAY8H/W91hRGXKCeyKpNBgdL8sh
      z22SrkO2qCnHJ6PLAMXy5fsKpFmFor2tRfCzrfnggTXu2YOzzK7q62bmqVdmufEo
      pT8igNcLpvZxk5uBDvhakObMym9mX3rAEBoe8PwttggMYiiw7NuJKO4MqD1llGkW
      aVM8U2ATsCun1IKHrRxynkE1/MJ86VHeYYX8GZt2YA8z+GuzylIOKcMH6JAWzMwA
      Gbatw6QwizOhr9iMjZ0B26TE3X8LvW84wwIBAg==")
  (define-dh 4096
    #"MIICCAKCAgEA/urRnb6vkPYc/KEGXWnbCIOaKitq7ySIq9dTH7s+Ri59zs77zty7
      vfVlSe6VFTBWgYjD2XKUFmtqq6CqXMhVX5ElUDoYDpAyTH85xqNFLzFC7nKrff/H
      TFKNttp22cZE9V0IPpzedPfnQkE7aUdmF9JnDyv21Z/818O93u1B4r0szdnmEvEF
      bKuIxEHX+bp0ZR7RqE1AeifXGJX3d6tsd2PMAObxwwsv55RGkn50vHO4QxtTARr1
      rRUV5j3B3oPMgC7Offxx+98Xn45B1/G0Prp11anDsR1PGwtaCYipqsvMwQUSJtyE
      EOQWk+yFkeMe4vWv367eEi0Sd/wnC+TSXBE3pYvpYerJ8n1MceI5GQTdarJ77OW9
      bGTHmxRsLSCM1jpLdPja5jjb4siAa6EHc4qN9c/iFKS3PQPJEnX7pXKBRs5f7AF3
      W3RIGt+G9IVNZfXaS7Z/iCpgzgvKCs0VeqN38QsJGtC1aIkwOeyjPNy2G6jJ4yqH
      ovXYt/0mc00vCWeSNS1wren0pR2EiLxX0ypjjgsU1mk/Z3b/+zVf7fZSIB+nDLjb
      NPtUlJCVGnAeBK1J1nG3TQicqowOXoM6ISkdaXj5GPJdXHab2+S7cqhKGv5qC7rR
      jT6sx7RUr0CNTxzLI7muV2/a4tGmj0PSdXQdsZ7tw7gbXlaWT1+MM2MCAQI=")
  
  (define-syntax provide:dh
    (syntax-rules ()
      ((_)
       (provide dhkey? (rename dh:params-bits dh-bits) dhkey-size compute-key 
                dh:192 dh:512 dh:1024 dh:2048 dh:4096))))

)