;; -*- 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.

(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
   scalarmult-primitive
   scalarmult-pointbytes scalarmult-scalarbytes
   scalarmult*
   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 derive-symmetric-box-key symmetric-box symmetric-unbox
   symmetric-sign-primitive
   symmetric-sign-keybytes
   make-symmetric-sign-key symmetric-sign symmetric-verify
   random-stream-primitive
   random-stream-keybytes random-stream-noncebytes
   make-random-stream-key derive-random-stream-key open-random-stream stream-xor! stream-xor
   hash-primitive
   hash-bytes
   hash)
  (import
   scheme
   (chicken base)
   (chicken foreign)
   (chicken port)
   (only (chicken random) random-bytes)
   (only (chicken fixnum) fx+ fx< fx>=)
   (only (chicken memory) move-memory!)
   (only (chicken blob) make-blob blob-size)
   (only (chicken io) read-string)
   srfi-4)

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

(define current-entropy-port
  (make-parameter
   (make-input-port
    ;read-char
    (lambda ()
      (string-ref (random-bytes (make-string 1)) 0))
    ;char-ready?
    (lambda ()
      #t)
    ;close
    void
    ;peek-char
    #f
    ;read-string!
    (lambda (port len buf ofs)
      (if (zero? ofs)
          (begin
            (random-bytes buf len)
            len)
          (let ((tmp (make-string len)))
            (random-bytes tmp len)
            (move-memory! tmp buf len 0 ofs)
            len))))))

(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 scalarmult-primitive
  (foreign-value "crypto_scalarmult_PRIMITIVE" c-string))

(define scalarmult-pointbytes
  (foreign-value "crypto_scalarmult_BYTES" unsigned-integer))

(define scalarmult-scalarbytes
  (foreign-value "crypto_scalarmult_SCALARBYTES" unsigned-integer))

(define (scalarmult* n p)
  (unless (eqv? (blob-size n) scalarmult-scalarbytes)
    (error 'scalarmult* "invalid scalar" n))
  (unless (eqv? (blob-size p) scalarmult-pointbytes)
    (error 'scalarmult* "invalid point" p))
  (let ((q (make-blob scalarmult-pointbytes)))
    ((foreign-lambda void "crypto_scalarmult" nonnull-blob nonnull-blob nonnull-blob)
     q n p)
    q))

(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 (derive-symmetric-box-key pk sk)
  (unless (eqv? asymmetric-box-beforenmbytes symmetric-box-keybytes)
    (error 'derive-symmetric-box-key "internal key size mismatch" asymmetric-box-beforenmbytes symmetric-box-keybytes))
  (unless (eqv? (blob-size pk) asymmetric-box-publickeybytes)
    (error 'derive-symmetric-box-key "invalid public key" pk))
  (unless (eqv? (blob-size sk) asymmetric-box-secretkeybytes)
    (error 'derive-symmetric-box-key "invalid secret key" sk))
  (let ((k (make-blob symmetric-box-keybytes)))
    ((foreign-lambda void "crypto_box_beforenm" nonnull-blob nonnull-blob nonnull-blob)
     k pk sk)
    k))

(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 random-stream-primitive
  (foreign-value "crypto_stream_PRIMITIVE" c-string))

(define random-stream-keybytes
  (foreign-value "crypto_stream_KEYBYTES" unsigned-integer))

(define random-stream-noncebytes
  (foreign-value "crypto_stream_KEYBYTES" unsigned-integer))

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

(define (derive-random-stream-key pk sk)
  (unless (eqv? asymmetric-box-beforenmbytes random-stream-keybytes)
    (error 'derive-random-stream-key "internal key size mismatch" asymmetric-box-beforenmbytes random-stream-keybytes))
  (unless (eqv? (blob-size pk) asymmetric-box-publickeybytes)
    (error 'derive-random-stream-key "invalid public key" pk))
  (unless (eqv? (blob-size sk) asymmetric-box-secretkeybytes)
    (error 'derive-random-stream-key "invalid secret key" sk))
  (let ((k (make-blob random-stream-keybytes)))
    ((foreign-lambda void "crypto_box_beforenm" nonnull-blob nonnull-blob nonnull-blob)
     k pk sk)
    k))

(define random-stream-blocksize
  64)

(define (open-random-stream k n #!optional (limit (expt 2 30)))
  (unless (eqv? (blob-size k) random-stream-keybytes)
    (error 'open-random-stream "invalid key" k))
  (unless (eqv? (u8vector-length n) random-stream-noncebytes)
    (error 'open-random-stream "invalid nonce" n))
  (unless limit
    (set! limit +inf.0))
  (let ((state (make-blob (foreign-value "sizeof(crypto_stream_state_t)" unsigned-integer)))
        (buf (make-string random-stream-blocksize))
        (pos random-stream-blocksize))
    ((foreign-lambda*
      void ((nonnull-blob s) (nonnull-u8vector n) (nonnull-blob k))
      "crypto_stream_init((crypto_stream_state_t *)s, n, k);")
     state n k)
    (make-input-port
     ;read-char
     (lambda ()
       (when (and (fx>= pos random-stream-blocksize) (positive? limit))
         ((foreign-lambda*
           void ((nonnull-blob s) (nonnull-scheme-pointer c))
           "crypto_stream_xorblock((crypto_stream_state_t *)s, c, 0);")
          state buf)
         (set! limit (- limit random-stream-blocksize))
         (set! pos 0))
       (if (fx< pos random-stream-blocksize)
         (let ((c (string-ref buf pos)))
           (set! pos (fx+ pos 1))
           c)
         #!eof))
     ;char-ready?
     (lambda ()
       (or (fx< pos random-stream-blocksize)
           (positive? limit)))
     ;close
     void)))

(define (stream-xor! buffer #!optional (stream (current-input-port)))
  (let* ((len (string-length buffer))
         (key (read-string len stream)))
    (when (or (eof-object? key)
              (< (string-length key) len))
      (error 'stream-xor! "key source depleted"))
    ((foreign-lambda*
      void ((nonnull-scheme-pointer c_) (nonnull-scheme-pointer k_) (unsigned-integer n))
      "unsigned char *c = (unsigned char *)c_;\n"
      "const unsigned char *k = (unsigned char *)k_;\n"
      "while (n-- > 0) *c++ ^= *k++;\n")
     buffer key len))
  buffer)

(define (stream-xor plain #!optional (stream (current-input-port)))
  (stream-xor! (string-copy plain) stream))

(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))

)
;; vim: set ai et ts=4 sts=2 sw=2 ft=scheme: ;;