;; Simple signature tool for file hierarchies.
;; Copyright (c) 2018  Thomas C. Chust <chust@web.de>.
;; This code is in the public domain.

(module signacl
  *
  (import
    scheme
    srfi-1
    srfi-4
    (chicken base)
    (chicken blob)
    (chicken sort)
    (chicken string)
    (chicken file)
    (chicken process-context)
    (only (chicken io) read-string read-token)
    (only (chicken port) call-with-input-string call-with-output-string)
    (only (chicken format) fprintf)
    tweetnacl)

  (define options
    '([(-k --keygen) . keyfile]
      [(-s --sign) . keyfile]
      [(-v --verify) . keyfile]
      [(-m --manifest) . manifest]
      [--help]))

  (define (help)
    (print "Usage:")
    (print #\tab (program-name) " [OPTION...] [FILE...]")
    (print "Options:")
    (for-each
      (lambda (opt)
        (let ([opt (car opt)] [arg (cdr opt)])
          (print
            #\tab
            (if (pair? opt)
                (string-intersperse (map symbol->string opt) ", ")
                opt)
            (cond
              [(null? arg)
               ""]
              [(pair? arg)
               (string-append
                " "
                (string-intersperse (map symbol->string opt) ", "))]
              [else
               (string-append
                " "
                (symbol->string arg))]))))
      options))

  (define (logf message . args)
    (fprintf (current-error-port) "; ~?~%~!" message args))

  (define initialize-entropy-port!
    (letrec ([nonce
              (blob->u8vector/shared
               (string->blob
                "signacl:key-generation-nonce\x00\x00\x00\x00"))]
             [initialize-entropy-port!
              (lambda ()
                (when nonce
                  (logf "initializing random number generator")
                  (current-entropy-port
                   (open-random-stream (make-random-stream-key) nonce))
                  (set! nonce #f)))])
      initialize-entropy-port!))

  (define (keygen keyfile)
    (when (file-exists? keyfile)
      (error "keyfile already exists" keyfile))
    (call-with-output-file keyfile
      (lambda (key)
        (initialize-entropy-port!)
        (logf "generating ~a keypair into ~s" asymmetric-sign-primitive keyfile)
        (let-values ([(pk sk) (make-asymmetric-sign-keypair)])
          (fprintf key "; signacl ~a keypair~%" asymmetric-sign-primitive)
          (write pk key)
          (newline key)
          (write sk key)
          (newline key))))
    (logf "all done"))

  (define (read-key keyfile)
    (call-with-input-file keyfile
      (lambda (key)
        (let* ([pk (read key)]
               [sk (read key)])
          (unless (and (blob? pk)
                       (= (blob-size pk) asymmetric-sign-publickeybytes)
                       (blob? sk)
                       (= (blob-size sk) asymmetric-sign-secretkeybytes))
            (error "invalid key pair" pk sk))
          (values pk sk)))))

  (define (read-netstring #!optional [port (current-input-port)])
    (let ([l (read-token char-numeric? port)])
      (if (zero? (string-length l))
          #!eof
          (let ([l (string->number l)])
            (unless l
              (error
               'read-netstring
               "client side protocol error: malformed netstring (bad length)"))
            (unless (eq? (read-char port) #\:)
              (error
               'read-netstring
               "client side protocol error: malformed netstring (bad delimiter)"))
            (let ((s (read-string l port)))
              (unless (eq? (read-char port) #\,)
                (error
                 'read-netstring
                 "client side protocol error: malformed netstring (bad terminal)"))
              s)))))

  (define (write-netstring s #!optional [port (current-output-port)])
    (fprintf port "~a:~a," (string-length s) s))

  (define (hash-file path)
    (hash (call-with-input-file path (cut read-string #f <>))))

  (define (sign keyfile paths)
    (let-values ([(pk sk) (read-key keyfile)])
      (logf "computing file hashes")
      (let ([manifest
             (let ([collect-hash
                    (lambda (path acc)
                      (if (directory-exists? path)
                          acc
                          (merge!
                           (list (cons path (hash-file path))) acc
                           (lambda (a b) (string<? (car a) (car b))))))])
               (fold
                (lambda (path acc)
                  (if (directory-exists? path)
                      (find-files path #:action collect-hash #:seed acc)
                      (collect-hash path acc)))
                '()
                paths))])
        (logf "signing manifest")
        (display
         ((asymmetric-sign sk)
          (call-with-output-string
            (lambda (out)
              (for-each
                (lambda (it)
                  (write-netstring (car it) out)
                  (display (cdr it) out))
                manifest)))))))
    (logf "all done"))

  (define (verify keyfile)
    (let-values ([(pk sk) (read-key keyfile)])
      (logf "verifying manifest")
      (let ([manifest ((asymmetric-verify pk) (read-string #f))])
        (unless manifest
          (logf "invalid manifest detected")
          (exit 1))
        (call-with-input-string manifest
          (lambda (in)
            (logf "verifying file hashes")
            (let loop ()
              (let ([path (read-netstring in)])
                (unless (eof-object? path)
                  (let ([digest0 (read-string hash-bytes in)]
                        [digest1 (hash-file path)])
                    (unless (string=? digest0 digest1)
                      (logf "invalid file hash detected for ~s: ~s <> ~s" path digest0 digest1)
                      (exit 1)))
                  (loop))))))))
    (logf "all done"))

  (define (main args)
    (cond
      [(assq '--help args)
       (help)]
      [(any (cut assq <> args) '(-k --keygen))
       => (lambda (keyfile)
            (keygen (cdr keyfile)))]
      [(any (cut assq <> args) '(-s --sign))
       => (lambda (keyfile)
            (let ([keyfile (cdr keyfile)]
                  [paths (cdr (assq '-- args))]
                  [manifest (cond
                              [(any (cut assq <> args) '(-m --manifest))
                               => cdr]
                              [else
                               #f])])
              (if manifest
                  (with-output-to-file manifest
                    (lambda ()
                      (sign keyfile paths)))
                  (sign keyfile paths))))]
      [(any (cut assq <> args) '(-v --verify))
       => (lambda (keyfile)
            (let ([keyfile (cdr keyfile)]
                  [manifest (cond
                              [(any (cut assq <> args) '(-m --manifest))
                               => cdr]
                              [else
                               #f])])
              (if manifest
                  (with-input-from-file manifest
                    (lambda ()
                      (verify keyfile)))
                  (verify keyfile))))]
      [else
       (apply error "unknown command line arguments" args)])))

(import
  optimism
  (only signacl options main))

(main (parse-command-line options))

;; vim:set sts=2 sw=2 ts=8 et ai: ;;