;; -*- mode: Scheme; -*-
;;
;; This file is part of TweetNaCl for CHICKEN
;; Copyright (c) 2015 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(require-library
 lolevel extras srfi-4)

(cond-expand
 (windows
  (require-library ports))
 (else
  ))

(module tweetnacl
  (current-entropy-port
   asymmetric-box-primitive
   asymmetric-box-publickeybytes asymmetric-box-secretkeybytes asymmetric-box-noncebytes
   make-asymmetric-box-keypair asymmetric-box asymmetric-unbox
   asymmetric-sign-primitive
   asymmetric-sign-publickeybytes asymmetric-sign-secretkeybytes
   make-asymmetric-sign-keypair asymmetric-sign asymmetric-verify
   symmetric-box-primitive
   symmetric-box-keybytes symmetric-box-noncebytes
   make-symmetric-box-key symmetric-box symmetric-unbox
   symmetric-sign-primitive
   symmetric-sign-keybytes
   make-symmetric-sign-key symmetric-sign symmetric-verify
   hash-primitive
   hash)
  (import
   scheme chicken foreign lolevel extras srfi-4)

(foreign-declare "#include \"tweetnacl.h\"")

(cond-expand
 (windows
  (import ports)
  (foreign-declare
   "#include <windows.h>"
   "#include <stdio.h>"
   "#define RtlGenRandom SystemFunction036"
   "BOOLEAN NTAPI RtlGenRandom(PVOID RandomBuffer,ULONG RandomBufferLength);"))
 (else
  ))

(define current-entropy-port
  (make-parameter
   (cond-expand
    (unix
     (open-input-file "/dev/random"))
    (windows
     (make-input-port
      ;read-char
      (foreign-lambda*
       scheme-object ()
       "unsigned char buf;"
       "C_return(RtlGenRandom(&buf, sizeof(buf)) ? C_make_character(buf) : C_SCHEME_END_OF_FILE);")
      ;char-ready?
      (lambda ()
	#t)
      ;close
      void
      ;peek-char
      #f
      ;read-string!
      (foreign-lambda*
       unsigned-long ((scheme-object port) (unsigned-long len)
		      (nonnull-scheme-pointer buf) (integer ofs))
       "C_return(RtlGenRandom(buf + ofs, len) ? len : 0);")))
    (else
     #f))))

(define asymmetric-box-primitive
  (foreign-value "crypto_box_PRIMITIVE" c-string))

(define asymmetric-box-publickeybytes
  (foreign-value "crypto_box_PUBLICKEYBYTES" unsigned-integer))

(define asymmetric-box-secretkeybytes
  (foreign-value "crypto_box_SECRETKEYBYTES" unsigned-integer))

(define asymmetric-box-noncebytes
  (foreign-value "crypto_box_NONCEBYTES" unsigned-integer))

(define asymmetric-box-beforenmbytes
  (foreign-value "crypto_box_BEFORENMBYTES" unsigned-integer))

(define asymmetric-box-zerobytes
  (foreign-value "crypto_box_ZEROBYTES" unsigned-integer))

(define asymmetric-box-boxzerobytes
  (foreign-value "crypto_box_BOXZEROBYTES" unsigned-integer))

(define (make-asymmetric-box-keypair #!optional (entropy-port (current-entropy-port)))
  (let ((pk (make-blob asymmetric-box-publickeybytes))
	(sk (read-u8vector asymmetric-box-secretkeybytes entropy-port)))
    (unless (or (eof-object? sk)
		(eqv? (u8vector-length sk) asymmetric-box-secretkeybytes))
      (error 'make-asymmetric-box-keypair "entropy source depleted"))
    ((foreign-lambda void "crypto_box_keypair" nonnull-blob nonnull-u8vector)
     pk sk)
    (values pk (u8vector->blob/shared sk))))

(define (asymmetric-box pk sk)
  (unless (eqv? (blob-size pk) asymmetric-box-publickeybytes)
    (error 'asymmetric-box "invalid public key" pk))
  (unless (eqv? (blob-size sk) asymmetric-box-secretkeybytes)
    (error 'asymmetric-box "invalid secret key" sk))
  (let ((k (make-blob asymmetric-box-beforenmbytes)))
    ((foreign-lambda void "crypto_box_beforenm" nonnull-blob nonnull-blob nonnull-blob)
     k pk sk)
    (lambda (m n)
      (unless (eqv? (u8vector-length n) asymmetric-box-noncebytes)
	(error 'asymmetric-box "invalid nonce" n))
      (let* ((len (string-length m))
	     (pm (make-string (+ asymmetric-box-zerobytes len) #\nul))
	     (pc (make-string (string-length pm) #\nul)))
	(move-memory! m pm len 0 asymmetric-box-zerobytes)
	(and
	 (zero?
	  ((foreign-lambda
	    int "crypto_box_afternm"
	    nonnull-scheme-pointer nonnull-scheme-pointer unsigned-integer64
	    nonnull-u8vector nonnull-blob)
	   pc pm (string-length pm) n k))
	 (substring pc asymmetric-box-boxzerobytes (string-length pc)))))))

(define (asymmetric-unbox pk sk)
  (unless (eqv? (blob-size pk) asymmetric-box-publickeybytes)
    (error 'asymmetric-unbox "invalid public key" pk))
  (unless (eqv? (blob-size sk) asymmetric-box-secretkeybytes)
    (error 'asymmetric-unbox "invalid secret key" sk))
  (let ((k (make-blob asymmetric-box-beforenmbytes)))
    ((foreign-lambda void "crypto_box_beforenm" nonnull-blob nonnull-blob nonnull-blob)
     k pk sk)
    (lambda (c n)
      (unless (eqv? (u8vector-length n) asymmetric-box-noncebytes)
	(error 'asymmetric-unbox "invalid nonce" n))
      (let* ((len (string-length c))
	     (pc (make-string (+ asymmetric-box-boxzerobytes len) #\nul))
	     (pm (make-string (string-length pc) #\nul)))
	(move-memory! c pc len 0 asymmetric-box-boxzerobytes)
	(and
	 (zero?
	  ((foreign-lambda
	    int "crypto_box_open_afternm"
	    nonnull-scheme-pointer nonnull-scheme-pointer unsigned-integer64
	    nonnull-u8vector nonnull-blob)
	   pm pc (string-length pc) n k))
	 (substring pm asymmetric-box-zerobytes (string-length pm)))))))

(define asymmetric-sign-primitive
  (foreign-value "crypto_sign_PRIMITIVE" c-string))

(define asymmetric-sign-publickeybytes
  (foreign-value "crypto_sign_PUBLICKEYBYTES" unsigned-integer))

(define asymmetric-sign-secretkeybytes
  (foreign-value "crypto_sign_SECRETKEYBYTES" unsigned-integer))

(define asymmetric-sign-bytes
  (foreign-value "crypto_sign_BYTES" unsigned-integer))

(define (make-asymmetric-sign-keypair #!optional (entropy-port (current-entropy-port)))
  (let ((pk (make-blob asymmetric-sign-publickeybytes))
	(sk (read-u8vector asymmetric-sign-secretkeybytes entropy-port)))
    (unless (or (eof-object? sk)
		(eqv? (u8vector-length sk) asymmetric-sign-secretkeybytes))
      (error 'make-asymmetric-sign-keypair "entropy source depleted"))
    ((foreign-lambda void "crypto_sign_keypair" nonnull-blob nonnull-u8vector)
     pk sk)
    (values pk (u8vector->blob/shared sk))))

(define (asymmetric-sign sk)
  (unless (eqv? (blob-size sk) asymmetric-sign-secretkeybytes)
    (error 'asymmetric-sign "invalid secret key" sk))
  (lambda (m)
    (let* ((len (string-length m))
	   (sm (make-string (+ len asymmetric-sign-bytes) #\nul)))
      (let-location ((slen unsigned-integer64 (string-length sm)))
	(and
	 (zero?
	  ((foreign-lambda
	    int "crypto_sign"
	    nonnull-scheme-pointer (nonnull-c-pointer unsigned-integer64)
	    nonnull-scheme-pointer unsigned-integer64
	    nonnull-blob)
	   sm #$slen m len sk))
	 (substring sm 0 slen))))))

(define (asymmetric-verify pk)
  (unless (eqv? (blob-size pk) asymmetric-sign-publickeybytes)
    (error 'asymmetric-verify "invalid public key" pk))
  (lambda (sm)
    (let* ((slen (string-length sm))
	   (m (make-string slen #\nul)))
      (let-location ((len unsigned-integer64 (string-length m)))
	(and
	 (zero?
	  ((foreign-lambda
	    int "crypto_sign_open"
	    nonnull-scheme-pointer (nonnull-c-pointer unsigned-integer64)
	    nonnull-scheme-pointer unsigned-integer64
	    nonnull-blob)
	   m #$len sm slen pk))
	 (substring m 0 len))))))

(define symmetric-box-primitive
  (foreign-value "crypto_secretbox_PRIMITIVE" c-string))

(define symmetric-box-keybytes
  (foreign-value "crypto_secretbox_KEYBYTES" unsigned-integer))

(define symmetric-box-noncebytes
  (foreign-value "crypto_secretbox_NONCEBYTES" unsigned-integer))

(define symmetric-box-zerobytes
  (foreign-value "crypto_secretbox_ZEROBYTES" unsigned-integer))

(define symmetric-box-boxzerobytes
  (foreign-value "crypto_secretbox_BOXZEROBYTES" unsigned-integer))

(define (make-symmetric-box-key #!optional (entropy-port (current-entropy-port)))
  (let ((tmp (read-u8vector symmetric-box-keybytes entropy-port)))
    (when (or (eof-object? tmp)
	      (< (u8vector-length tmp) symmetric-box-keybytes))
      (error 'make-symmetric-box-key "entropy source depleted"))
    (u8vector->blob/shared tmp)))

(define (symmetric-box k)
  (unless (eqv? (blob-size k) symmetric-box-keybytes)
    (error 'symmetric-box "invalid key" k))
  (lambda (m n)
    (unless (eqv? (u8vector-length n) symmetric-box-noncebytes)
      (error 'symmetric-box "invalid nonce" n))
    (let* ((len (string-length m))
	   (pm (make-string (+ symmetric-box-zerobytes len) #\nul))
	   (pc (make-string (string-length pm) #\nul)))
      (move-memory! m pm len 0 symmetric-box-zerobytes)
      (and
       (zero?
	((foreign-lambda
	  int "crypto_secretbox"
	  nonnull-scheme-pointer nonnull-scheme-pointer unsigned-integer64
	  nonnull-u8vector nonnull-blob)
	 pc pm (string-length pm) n k))
       (substring pc symmetric-box-boxzerobytes (string-length pc))))))

(define (symmetric-unbox k)
  (unless (eqv? (blob-size k) symmetric-box-keybytes)
    (error 'symmetric-unbox "invalid key" k))
  (lambda (c n)
    (unless (eqv? (u8vector-length n) symmetric-box-noncebytes)
      (error 'symmetric-unbox "invalid nonce" n))
    (let* ((len (string-length c))
	   (pc (make-string (+ symmetric-box-boxzerobytes len) #\nul))
	   (pm (make-string (string-length pc) #\nul)))
      (move-memory! c pc len 0 symmetric-box-boxzerobytes)
      (and
       (zero?
	((foreign-lambda
	  int "crypto_secretbox_open"
	  nonnull-scheme-pointer nonnull-scheme-pointer unsigned-integer64
	  nonnull-u8vector nonnull-blob)
	 pm pc (string-length pc) n k))
       (substring pm symmetric-box-zerobytes (string-length pm))))))

(define symmetric-sign-primitive
  (foreign-value "crypto_onetimeauth_PRIMITIVE" c-string))

(define symmetric-sign-keybytes
  (foreign-value "crypto_onetimeauth_KEYBYTES" unsigned-integer))

(define symmetric-sign-bytes
  (foreign-value "crypto_onetimeauth_BYTES" unsigned-integer))

(define (make-symmetric-sign-key #!optional (entropy-port (current-entropy-port)))
  (let ((tmp (read-u8vector symmetric-sign-keybytes entropy-port)))
    (when (or (eof-object? tmp)
	      (< (u8vector-length tmp) symmetric-sign-keybytes))
      (error 'make-symmetric-sign-key "entropy source depleted"))
    (u8vector->blob/shared tmp)))

(define (symmetric-sign k)
  (unless (eqv? (blob-size k) symmetric-sign-keybytes)
    (error 'symmetric-sign "invalid key" k))
  (lambda (m #!key tag-only?)
    (let* ((len (string-length m))
	   (sm (make-string (+ (if tag-only? 0 len) symmetric-sign-bytes) #\nul)))
      (and
       (zero?
	((foreign-lambda
	  int "crypto_onetimeauth"
	  nonnull-scheme-pointer
	  nonnull-scheme-pointer unsigned-integer64
	  nonnull-blob)
	 sm m len k))
       (unless tag-only? (move-memory! m sm len 0 symmetric-sign-bytes))
       sm))))

(define (symmetric-verify k)
  (unless (eqv? (blob-size k) symmetric-sign-keybytes)
    (error 'symmetric-verify "invalid key" k))
  (lambda (sm #!optional m)
    (let ((len (string-length sm)))
      (and
       ((if m = >=) len symmetric-sign-bytes)
       (zero?
	(if m
	    ((foreign-lambda
	      int "crypto_onetimeauth_verify"
	      nonnull-scheme-pointer
	      nonnull-scheme-pointer unsigned-integer64
	      nonnull-blob)
	     sm m (string-length m) k)
	    ((foreign-lambda*
	      int ((nonnull-scheme-pointer sm) (unsigned-integer64 slen) (nonnull-blob k))
	      "C_return(crypto_onetimeauth_verify("
	      "  sm, ((const unsigned char *) sm) + crypto_onetimeauth_BYTES,"
	      "  slen - crypto_onetimeauth_BYTES, k"
	      "));")
	     sm len k)))
       (or m (substring sm symmetric-sign-bytes len))))))

(define hash-primitive
  (foreign-value "crypto_hash_PRIMITIVE" c-string))

(define hash-bytes
  (foreign-value "crypto_hash_BYTES" unsigned-integer))

(define (hash m)
  (let ((h (make-string hash-bytes #\nul)))
    ((foreign-lambda
      void "crypto_hash"
      nonnull-scheme-pointer nonnull-scheme-pointer unsigned-integer64)
     h m (string-length m))
    h))

)